From 9907e296e21fdd9dc3fab2b84fe7159b35af654c Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Thu, 2 Jun 2016 16:11:03 +0200 Subject: Remove tabulation support from pretty-printing. This mechanism relied on functions that are deprecated in recent versions of ocaml. It was incorrectly used for the most part anyway. The only place that was using tabulations correctly is "print_loadpath", so there is a minor regression there: physical paths of short logical paths are no longer aligned. --- interp/notation.ml | 14 +++++++------- interp/ppextend.ml | 6 ------ interp/ppextend.mli | 3 --- kernel/cbytecodes.ml | 2 +- lib/pp.ml | 16 ---------------- lib/pp.mli | 5 ----- toplevel/vernacentries.ml | 7 +++---- 7 files changed, 11 insertions(+), 42 deletions(-) diff --git a/interp/notation.ml b/interp/notation.ml index b19fd9e1fe..3a078143bd 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -898,19 +898,19 @@ let locate_notation prglob ntn scope = match ntns with | [] -> str "Unknown notation" | _ -> - t (str "Notation " ++ - tab () ++ str "Scope " ++ tab () ++ fnl () ++ + str "Notation" ++ fnl () ++ prlist (fun (ntn,l) -> let scope = find_default ntn scopes in prlist (fun (sc,r,(_,df)) -> hov 0 ( - pr_notation_info prglob df r ++ tbrk (1,2) ++ - (if String.equal sc default_scope then mt () else (str ": " ++ str sc)) ++ - tbrk (1,2) ++ - (if Option.equal String.equal (Some sc) scope then str "(default interpretation)" else mt ()) + pr_notation_info prglob df r ++ + (if String.equal sc default_scope then mt () + else (spc () ++ str ": " ++ str sc)) ++ + (if Option.equal String.equal (Some sc) scope + then spc () ++ str "(default interpretation)" else mt ()) ++ fnl ())) - l) ntns) + l) ntns let collect_notation_in_scope scope sc known = assert (not (String.equal scope default_scope)); diff --git a/interp/ppextend.ml b/interp/ppextend.ml index 37bbe0ce87..87ca253253 100644 --- a/interp/ppextend.ml +++ b/interp/ppextend.ml @@ -23,12 +23,9 @@ type ppbox = | PpHOVB of int | PpHVB of int | PpVB of int - | PpTB type ppcut = | PpBrk of int * int - | PpTbrk of int * int - | PpTab | PpFnl let ppcmd_of_box = function @@ -36,13 +33,10 @@ let ppcmd_of_box = function | PpHOVB n -> hov n | PpHVB n -> hv n | PpVB n -> v n - | PpTB -> t let ppcmd_of_cut = function - | PpTab -> tab () | PpFnl -> fnl () | PpBrk(n1,n2) -> brk(n1,n2) - | PpTbrk(n1,n2) -> tbrk(n1,n2) type unparsing = | UnpMetaVar of int * parenRelation diff --git a/interp/ppextend.mli b/interp/ppextend.mli index de7a42eee5..09dc369437 100644 --- a/interp/ppextend.mli +++ b/interp/ppextend.mli @@ -23,12 +23,9 @@ type ppbox = | PpHOVB of int | PpHVB of int | PpVB of int - | PpTB type ppcut = | PpBrk of int * int - | PpTbrk of int * int - | PpTab | PpFnl val ppcmd_of_box : ppbox -> std_ppcmds -> std_ppcmds diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index a705e3004f..09afbb5758 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -278,7 +278,7 @@ and pp_bytecodes c = | Ksequence (l1, l2) :: c -> pp_bytecodes l1 ++ pp_bytecodes l2 ++ pp_bytecodes c | i :: c -> - tab () ++ pp_instr i ++ fnl () ++ pp_bytecodes c + pp_instr i ++ fnl () ++ pp_bytecodes c (*spiwack: moved this type in this file because I needed it for retroknowledge which can't depend from cbytegen *) diff --git a/lib/pp.ml b/lib/pp.ml index d07f01b906..d8e12ea6e7 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -72,8 +72,6 @@ open Pp_control this block is small enough to fit on a single line \item[hovbox:] Horizontal or Vertical block: breaks lead to new line only when necessary to print the content of the block - \item[tbox:] Tabulation block: go to tabulation marks and no line breaking - (except if no mark yet on the reste of the line) \end{description} *) @@ -93,7 +91,6 @@ type block_type = | Pp_vbox of int | Pp_hvbox of int | Pp_hovbox of int - | Pp_tbox type str_token = | Str_def of string @@ -103,14 +100,11 @@ type 'a ppcmd_token = | Ppcmd_print of 'a | Ppcmd_box of block_type * ('a ppcmd_token Glue.t) | Ppcmd_print_break of int * int - | Ppcmd_set_tab - | Ppcmd_print_tbreak of int * int | Ppcmd_white_space of int | Ppcmd_force_newline | Ppcmd_print_if_broken | Ppcmd_open_box of block_type | Ppcmd_close_box - | Ppcmd_close_tbox | Ppcmd_comment of int | Ppcmd_open_tag of Tag.t | Ppcmd_close_tag @@ -172,8 +166,6 @@ let utf8_length s = let str s = Glue.atom(Ppcmd_print (Str_def s)) let stras (i, s) = Glue.atom(Ppcmd_print (Str_len (s, i))) let brk (a,b) = Glue.atom(Ppcmd_print_break (a,b)) -let tbrk (a,b) = Glue.atom(Ppcmd_print_tbreak (a,b)) -let tab () = Glue.atom(Ppcmd_set_tab) let fnl () = Glue.atom(Ppcmd_force_newline) let pifb () = Glue.atom(Ppcmd_print_if_broken) let ws n = Glue.atom(Ppcmd_white_space n) @@ -204,16 +196,13 @@ let h n s = Glue.atom(Ppcmd_box(Pp_hbox n,s)) let v n s = Glue.atom(Ppcmd_box(Pp_vbox n,s)) let hv n s = Glue.atom(Ppcmd_box(Pp_hvbox n,s)) let hov n s = Glue.atom(Ppcmd_box(Pp_hovbox n,s)) -let t s = Glue.atom(Ppcmd_box(Pp_tbox,s)) (* Opening and closing of boxes *) let hb n = Glue.atom(Ppcmd_open_box(Pp_hbox n)) let vb n = Glue.atom(Ppcmd_open_box(Pp_vbox n)) let hvb n = Glue.atom(Ppcmd_open_box(Pp_hvbox n)) let hovb n = Glue.atom(Ppcmd_open_box(Pp_hovbox n)) -let tb () = Glue.atom(Ppcmd_open_box Pp_tbox) let close () = Glue.atom(Ppcmd_close_box) -let tclose () = Glue.atom(Ppcmd_close_tbox) (* Opening and closed of tags *) let open_tag t = Glue.atom(Ppcmd_open_tag t) @@ -272,7 +261,6 @@ let pp_dirs ?pp_tag ft = | Pp_vbox n -> Format.pp_open_vbox ft n | Pp_hvbox n -> Format.pp_open_hvbox ft n | Pp_hovbox n -> Format.pp_open_hovbox ft n - | Pp_tbox -> Format.pp_open_tbox ft () in let rec pp_cmd = function | Ppcmd_print tok -> @@ -290,14 +278,10 @@ let pp_dirs ?pp_tag ft = Format.pp_close_box ft () | 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.from_fun (fun()->Format.pp_print_break ft n 0)) | Ppcmd_print_break(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.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 -> diff --git a/lib/pp.mli b/lib/pp.mli index ced4b66032..d7ab5cc96f 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -15,8 +15,6 @@ type std_ppcmds val str : string -> std_ppcmds val stras : int * string -> std_ppcmds val brk : int * int -> std_ppcmds -val tbrk : int * int -> std_ppcmds -val tab : unit -> std_ppcmds val fnl : unit -> std_ppcmds val pifb : unit -> std_ppcmds val ws : int -> std_ppcmds @@ -59,7 +57,6 @@ val h : int -> std_ppcmds -> std_ppcmds val v : int -> std_ppcmds -> std_ppcmds val hv : int -> std_ppcmds -> std_ppcmds val hov : int -> std_ppcmds -> std_ppcmds -val t : std_ppcmds -> std_ppcmds (** {6 Opening and closing of boxes} *) @@ -67,9 +64,7 @@ val hb : int -> std_ppcmds val vb : int -> std_ppcmds val hvb : int -> std_ppcmds val hovb : int -> std_ppcmds -val tb : unit -> std_ppcmds val close : unit -> std_ppcmds -val tclose : unit -> std_ppcmds (** {6 Opening and closing of tags} *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 222b7d3df1..65d71c8d51 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -160,7 +160,7 @@ let show_match id = let print_path_entry p = let dir = pr_dirpath (Loadpath.logical p) in let path = str (Loadpath.physical p) in - (dir ++ str " " ++ tbrk (0, 0) ++ path) + Pp.hov 2 (dir ++ spc () ++ path) let print_loadpath dir = let l = Loadpath.get_load_paths () in @@ -170,9 +170,8 @@ let print_loadpath dir = let filter p = is_dirpath_prefix_of dir (Loadpath.logical p) in List.filter filter l in - Pp.t (str "Logical Path: " ++ - tab () ++ str "Physical path:" ++ fnl () ++ - prlist_with_sep fnl print_path_entry l) + str "Logical Path / Physical path:" ++ fnl () ++ + prlist_with_sep fnl print_path_entry l let print_modules () = let opened = Library.opened_libraries () -- cgit v1.2.3 From 6eefbf216bd4d674f84a7827ecb205c6e12c33d3 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 26 Aug 2016 15:15:44 +0200 Subject: A proposal for recommended uniformity of style in programming Coq. Starting listing some recommendations in using the API. --- dev/doc/api.txt | 10 +++ dev/doc/style.txt | 215 +++++++++++++++++++++++++++++++++++------------------- 2 files changed, 151 insertions(+), 74 deletions(-) create mode 100644 dev/doc/api.txt diff --git a/dev/doc/api.txt b/dev/doc/api.txt new file mode 100644 index 0000000000..5827257b53 --- /dev/null +++ b/dev/doc/api.txt @@ -0,0 +1,10 @@ +Recommendations in using the API: + +The type of terms: constr (see kernel/constr.ml and kernel/term.ml) + +- On type constr, the canonical equality on CIC (up to + alpha-conversion and cast removal) is Constr.equal +- The type constr is abstract, use mkRel, mkSort, etc. to build + elements in constr; use "kind_of_term" to analyze the head of a + constr; use destRel, destSort, etc. when the head constructor is + known diff --git a/dev/doc/style.txt b/dev/doc/style.txt index 27695a09b1..2ee3dadd77 100644 --- a/dev/doc/style.txt +++ b/dev/doc/style.txt @@ -1,75 +1,142 @@ - -<< L'uniformité du style est plus importante que le style lui-même. >> -(Kernigan & Pike, The Practice of Programming) - -Mode Emacs -========== - Tuareg, que l'on trouve ici : http://www.prism.uvsq.fr/~acohen/tuareg/ - - avec le réglage suivant : (setq tuareg-in-indent 2) - -Types récursifs et filtrages -============================ - Une barre de séparation y compris sur le premier constructeur - -type t = - | A - | B of machin - -match expr with - | A -> ... - | B x -> ... - -Remarque : à partir de la 8.2 environ, la tendance est à utiliser le -format suivant qui permet de limiter l'escalade d'indentation tout en -produisant un aspect visuel intéressant de bloc : - -type t = -| A -| B of machin - -match expr with -| A -> ... -| B x -> ... - -let f expr = match expr with -| A -> ... -| B x -> ... - -let f expr = function -| A -> ... -| B x -> ... - -Le deuxième cas est obtenu sous tuareg avec les réglages - - (setq tuareg-with-indent 0) - (setq tuareg-function-indent 0) - (setq tuareg-let-always-indent nil) /// notons que cette dernière est bien - /// pour les let mais pas pour les let-in - -Conditionnelles -=============== - if condition then - premier-cas - else - deuxieme-cas - - Si effets de bord dans les branches, utilisez begin ... end et non des - parenthèses i.e. - - if condition then begin - instr1; - instr2 - end else begin - instr3; - instr4 - end - - Si la première branche lève une exception, évitez le else i.e. - - if condition then if condition then error "machin"; - error "machin" -----> suite +<< Style uniformity is more important than style itself >> + (Kernigan & Pike, The Practice of Programming) + +OCaml Style: +- Spacing and indentation + - indent your code (using tuareg default) + - no strong constraints in formatting "let in"; possible styles are: + "let x = ... in" + "let x = + ... in" + "let + x = ... + in" + - but: no extra indentation before a "in" coming on next line, + otherwise, it first shifts further and further on the right, + reducing the amount of space available; second, it is not robust to + insertion of a new "let" + - it is established usage to have space around "|" as in + "match c with + | [] | [a] -> ... + | a::b::l -> ..." + - in a one-line "match", it is preferred to have no "|" in front of + the first case (this saves spaces for the match to hold in the line) + - from about 8.2, the tendency is to use the following format which + limit excessive indentation while providing an interesting "block" aspect + type t = + | A + | B of machin + + let f expr = match expr with + | A -> ... + | B x -> ... + + let f expr = function + | A -> ... + | B x -> ... + - add spaces around = and == (make the code "breaths") + - the common usage is to write "let x,y = ... in ..." rather than + "let (x,y) = ... in ..." + - parenthesizing with either "(" and ")" or with "begin" and "end" is + common practice + - preferred layout for conditionals: + if condition then + premier-cas else - suite - - + deuxieme-cas + - in case of effects in branches, use "begin ... end" rather than + parentheses + if condition then begin + instr1; + instr2 + end else begin + instr3; + instr4 + end + - if the first branch raises an exception, avoid the "else", i.e.: + if condition then if condition then error "foo"; + error "foo" -----> bar + else + bar + - it is the usage not to use ;; to end OCaml sentences (however, + inserting ";;" can be useful for debugging syntax errors crossing + the boundary of functions) + - relevant options in tuareg: + (setq tuareg-in-indent 2) + (setq tuareg-with-indent 0) + (setq tuareg-function-indent 0) + (setq tuareg-let-always-indent nil) + +- Coding methodology + - no "try ... with _ -> ..." which catches even Sys.Break (Ctrl-C), + Out_of_memory, Stack_overflow, etc. + at least, use "try with e when Errors.noncritical e -> ..." + (to be detailed, Pierre L. ?) + - do not abuse of fancy combinators: sometimes what a "let rec" loop + does is more readable and simpler to grasp than what a "fold" does + - do not break abstractions: if an internal property is hidden + behind an interface, do no rely on it in code which uses this + interface (e.g. do not use List.map thinking it is left-to-right, + use map_left) + - in particular, do not use "=" on abstract types: there is no + reason a priori that it is the intended equality on this type; use the + "equal" function normally provided with the abstract type + - avoid polymorphically typed "=" whose implementation is not + optimized in OCaml and which has moreover no reason to be the + intended implementation of the equality when it comes to be + instantiated on a particular type (e.g. use List.mem_f, + List.assoc_f, rather than List.mem, List.assoc, etc, unless it is + absolutely clear that "=" will implement the intended equality, and + with the right complexity) + - any new general-purpose enough combinator on list should be put in + cList.ml, on type option in cOpt.ml, etc. + - unless of a good reason not to so, follow the style of the + surrounding code in the same file as much as possible, + the general guidelines are otherwise "let spacing breaths" (we + have large screen nowadays), "make your code easy to read and + to understand" + - document what is tricky, but do not overdocument, sometimes the + choice of names and the structuration of the code is a better + documentation than a long discourse; use of unicode in comments is + welcome if it can make comments more readable (then + "toggle-enable-multibyte-characters" can help when using the + debugger in emacs) + - all of initial "open File", or of small-scope File.(...), or + per-ident File.foo are common practices + +- Choice of variable names + - be consistent when naming from one function to another + - be consistent with the naming adopted in the functions from the + same file, or with the naming used elsewhere by similar functions + - use variable names which express meaning + - keep "cst" for constants and avoid it for constructors which is + otherwise a source of confusion + - for constructors, use "cstr" in type constructor (resp. "cstru" in + constructor puniverse); avoid "constr" for "constructor" which + could be think as the name of an arbitrary Constr.t + - for inductive types, use "ind" in the type inductive (resp "indu" + in inductive puniverse) + - for env, use "env" + - for evar_map, use "sigma", with tolerance into "evm" and "evd" + - for named_context or rel_context, use "ctxt" or "ctx" (or "sign") + - for formal/actual indices of inductive types: "realdecls", "realargs" + - for formal/actual parameters of inductive types: "paramdecls", "paramargs" + - for terms, use e.g. c, b, a, ... + - if a term is known to be a function: f, ... + - if a term is known to be a type: t, u, typ, ... + - for a declaration, use d or "decl" + - for errors, exceptions, use e + +- Common OCaml pitfalls + - in "match ... with Case1 -> try ... with ... -> ... | Case2 -> ...", or in + "match ... with Case1 -> match ... with SubCase -> ... | Case2 -> ...", or in + parentheses are needed around the "try" and the inner "match" + - even if stream are lazy, the Pp.(++) combinator is strict and + forces the evaluation of its arguments (use a "lazy" or a "fun () ->") + to make it lazy explicitly + - in "if ... then ... else ... ++ ...", the default parenthesizing + is somehow counter-intuitive; use "(if ... then ... else ...) ++ ..." + - in "let myspecialfun = mygenericfun args", be sure that it does no + do side-effect; prefer otherwise "let mygenericfun arg = + mygenericfun args arg" to ensure that the function is evaluated at + runtime -- cgit v1.2.3 From c694b91bba898aad1e071d91fa70b7c5574cbf98 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 29 Sep 2016 17:42:53 +0200 Subject: Fix bug 4969, autoapply was not tagging shelved subgoals correctly as unresolvable --- tactics/class_tactics.ml | 12 +++++++++--- test-suite/bugs/closed/4969.v | 11 +++++++++++ 2 files changed, 20 insertions(+), 3 deletions(-) create mode 100644 test-suite/bugs/closed/4969.v diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 8d6c085e63..c5b0e149a8 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1511,10 +1511,16 @@ let is_ground c gl = else tclFAIL 0 (str"Not ground") gl let autoapply c i gl = + let open Proofview.Notations in 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),0,ce) } in - Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl + let enter gl = + (unify_e_resolve false flags).enter gl + ((c,cty,Univ.ContextSet.empty),0,ce) <*> + Proofview.tclEVARMAP >>= (fun sigma -> + let sigma = Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals sigma in + Proofview.Unsafe.tclEVARS sigma) + in + Proofview.V82.of_tactic (Proofview.Goal.nf_enter { enter }) gl diff --git a/test-suite/bugs/closed/4969.v b/test-suite/bugs/closed/4969.v new file mode 100644 index 0000000000..4dee41e221 --- /dev/null +++ b/test-suite/bugs/closed/4969.v @@ -0,0 +1,11 @@ +Require Import Classes.Init. + +Class C A := c : A. +Instance nat_C : C nat := 0. +Instance bool_C : C bool := true. +Lemma silly {A} `{C A} : 0 = 0 -> c = c -> True. +Proof. auto. Qed. + +Goal True. + class_apply @silly; [reflexivity|]. + reflexivity. Fail Qed. -- cgit v1.2.3 From d7abadbef61ab0d45ffc5a5a45ff31bd39103446 Mon Sep 17 00:00:00 2001 From: Abhishek Anand Date: Sun, 11 Dec 2016 11:59:33 -0500 Subject: strengthened the statement of JMeq_eq_dep because P:U->Prop implies P:U->Type, the new statement is strictly more useful. No change was needed to the proof.--- theories/Logic/JMeq.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 2f95856b4b..86d05e8fb2 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -130,7 +130,7 @@ Qed. is as strong as [eq_dep U P p x q y] (this uses [JMeq_eq]) *) Lemma JMeq_eq_dep : - forall U (P:U->Prop) p q (x:P p) (y:P q), + forall U (P:U->Type) p q (x:P p) (y:P q), p = q -> JMeq x y -> eq_dep U P p x q y. Proof. intros. -- cgit v1.2.3 From 105f346cc707b3433379514cd5ddcd3389912083 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Tue, 13 Dec 2016 19:44:23 +0100 Subject: Improve unification debug trace. - Add a debug message when applying a heuristic. - Fix double newlines. --- pretyping/evarconv.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index a2ffe12e93..88ea08c840 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -500,8 +500,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* Evar must be undefined since we have flushed evars *) let () = if !debug_unification then let open Pp in - Feedback.msg_notice (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ()) - ++ fnl ()) in + Feedback.msg_notice (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ())) in match (flex_kind_of_term (fst ts) env evd term1 sk1, flex_kind_of_term (fst ts) env evd term2 sk2) with | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) -> @@ -1129,6 +1128,10 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = let t2 = apprec_nohdbeta ts env evd (whd_head_evar evd t2) in let (term1,l1 as appr1) = try destApp t1 with DestKO -> (t1, [||]) in let (term2,l2 as appr2) = try destApp t2 with DestKO -> (t2, [||]) in + let () = if !debug_unification then + let open Pp in + Feedback.msg_notice (v 0 (str "Heuristic:" ++ spc () ++ print_constr t1 + ++ cut () ++ print_constr t2 ++ cut ())) in let app_empty = Array.is_empty l1 && Array.is_empty l2 in match kind_of_term term1, kind_of_term term2 with | Evar (evk1,args1), (Rel _|Var _) when app_empty -- cgit v1.2.3 From 0bf85fbc04b448ede279842aec30659c9377969d Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 9 Jan 2017 16:43:07 +0100 Subject: Compile with debug information by default. Addition of debug info can be prevented using -nodebug at configure time. --- configure.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/configure.ml b/configure.ml index f75bbb538c..9c22c52375 100644 --- a/configure.ml +++ b/configure.ml @@ -261,7 +261,7 @@ module Prefs = struct let withdoc = ref false let geoproof = ref false let byteonly = ref false - let debug = ref false + let debug = ref true let profile = ref false let annotate = ref false let nativecompiler = ref (not (os_type_win32 || os_type_cygwin)) @@ -337,6 +337,8 @@ let args_options = Arg.align [ " Compiles only bytecode version of Coq"; "-debug", Arg.Set Prefs.debug, " Add debugging information in the Coq executables"; + "-nodebug", Arg.Clear Prefs.debug, + " Do not add debugging information in the Coq executables"; "-profile", Arg.Set Prefs.profile, " Add profiling information in the Coq executables"; "-annotate", Arg.Set Prefs.annotate, -- cgit v1.2.3 From e69f8622d1b844f77d14e3ba4db797f7c64e6bed Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Sun, 29 Jan 2017 18:42:33 +0100 Subject: Remove outdated comment from 2002. The comment was arguing against the "Proof proof_term." syntax. This syntax is still there 15 years later (while the alternative proposition uses outdated syntax). --- toplevel/vernacentries.ml | 3 --- 1 file changed, 3 deletions(-) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index a2f2ded327..e5e2c6179c 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -521,9 +521,6 @@ let vernac_end_proof ?proof = function Stm.show_script ?proof (); save_proof ?proof e - (* A stupid macro that should be replaced by ``Exact c. Save.'' all along - the theories [??] *) - let vernac_exact_proof c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the begining of a proof. *) -- cgit v1.2.3 From 99b61a6ea3e7c9c96022ac7d573b10b2366e5c16 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Mon, 30 Jan 2017 18:43:26 +0100 Subject: Proof clean-up. - Do not use induction/elim when not necessary: use destruct or destructive intro-pattern instead. - Do not use heavy automation when lightweight automation is enough. - Prefer shorter proofs when it does not hinder readability. - Do not rely on automatically generated names. - Use bullets. --- theories/Arith/Between.v | 72 ++++++++++++++++++++++++------------------------ 1 file changed, 36 insertions(+), 36 deletions(-) diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index 58d3a2b38c..5a3d5631d5 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -24,7 +24,7 @@ Section Between. Lemma bet_eq : forall k l, l = k -> between k l. Proof. - induction 1; auto with arith. + intros * ->; auto with arith. Qed. Hint Resolve bet_eq: arith. @@ -37,9 +37,7 @@ Section Between. Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l. Proof. - intros k l H; induction H as [|l H]. - intros; absurd (S k <= k); auto with arith. - destruct H; auto with arith. + induction 1 as [|* [|]]; auto with arith. Qed. Hint Resolve between_Sk_l: arith. @@ -74,32 +72,32 @@ Section Between. Lemma in_int_intro : forall p q r, p <= r -> r < q -> in_int p q r. Proof. - red; auto with arith. + split; assumption. Qed. Hint Resolve in_int_intro: arith. Lemma in_int_lt : forall p q r, in_int p q r -> p < q. Proof. - induction 1; intros. - apply le_lt_trans with r; auto with arith. + intros * []. + eapply le_lt_trans; eassumption. Qed. Lemma in_int_p_Sq : - forall p q r, in_int p (S q) r -> in_int p q r \/ r = q :>nat. + forall p q r, in_int p (S q) r -> in_int p q r \/ r = q. Proof. - induction 1; intros. - elim (le_lt_or_eq r q); auto with arith. + intros p q r []. + destruct (le_lt_or_eq r q); auto with arith. Qed. Lemma in_int_S : forall p q r, in_int p q r -> in_int p (S q) r. Proof. - induction 1; auto with arith. + intros * []; auto with arith. Qed. Hint Resolve in_int_S: arith. Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r. Proof. - induction 1; auto with arith. + intros * []; auto with arith. Qed. Hint Immediate in_int_Sp_q: arith. @@ -107,10 +105,9 @@ Section Between. forall k l, between k l -> forall r, in_int k l r -> P r. Proof. induction 1; intros. - absurd (k < k); auto with arith. - apply in_int_lt with r; auto with arith. - elim (in_int_p_Sq k l r); intros; auto with arith. - rewrite H2; trivial with arith. + - absurd (k < k). { auto with arith. } + eapply in_int_lt; eassumption. + - destruct (in_int_p_Sq k l r) as [| ->]; auto with arith. Qed. Lemma in_int_between : @@ -120,17 +117,17 @@ Section Between. Qed. Lemma exists_in_int : - forall k l, exists_between k l -> exists2 m : nat, in_int k l m & Q m. + forall k l, exists_between k l -> exists2 m : nat, in_int k l m & Q m. Proof. - induction 1. - case IHexists_between; intros p inp Qp; exists p; auto with arith. - exists l; auto with arith. + induction 1 as [* ? (p, ?, ?)|]. + - exists p; auto with arith. + - exists l; auto with arith. Qed. Lemma in_int_exists : forall k l r, in_int k l r -> Q r -> exists_between k l. Proof. - destruct 1; intros. - elim H0; auto with arith. + intros * (?, lt_r_l) ?. + induction lt_r_l; auto with arith. Qed. Lemma between_or_exists : @@ -139,9 +136,11 @@ Section Between. (forall n:nat, in_int k l n -> P n \/ Q n) -> between k l \/ exists_between k l. Proof. - induction 1; intros; auto with arith. - elim IHle; intro; auto with arith. - elim (H0 m); auto with arith. + induction 1 as [|m ? IHle]. + - auto with arith. + - intros P_or_Q. + destruct IHle; auto with arith. + destruct (P_or_Q m); auto with arith. Qed. Lemma between_not_exists : @@ -150,14 +149,14 @@ Section Between. (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l. Proof. induction 1; red; intros. - absurd (k < k); auto with arith. - absurd (Q l); auto with arith. - elim (exists_in_int k (S l)); auto with arith; intros l' inl' Ql'. - replace l with l'; auto with arith. - elim inl'; intros. - elim (le_lt_or_eq l' l); auto with arith; intros. - absurd (exists_between k l); auto with arith. - apply in_int_exists with l'; auto with arith. + - absurd (k < k); auto with arith. + - absurd (Q l). { auto with arith. } + destruct (exists_in_int k (S l)) as (l',[],?). + + auto with arith. + + replace l with l'. { trivial. } + destruct (le_lt_or_eq l' l); auto with arith. + absurd (exists_between k l). { auto with arith. } + eapply in_int_exists; eauto with arith. Qed. Inductive P_nth (init:nat) : nat -> nat -> Prop := @@ -168,15 +167,16 @@ Section Between. Lemma nth_le : forall (init:nat) l (n:nat), P_nth init l n -> init <= l. Proof. - induction 1; intros; auto with arith. - apply le_trans with (S k); auto with arith. + induction 1. + - auto with arith. + - eapply le_trans; eauto with arith. Qed. Definition eventually (n:nat) := exists2 k : nat, k <= n & Q k. Lemma event_O : eventually 0 -> Q 0. Proof. - induction 1; intros. + intros (x, ?, ?). replace 0 with x; auto with arith. Qed. -- cgit v1.2.3 From dec77f282575842ff5369e732c0acfaf99d75037 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 2 Feb 2017 11:19:07 +0100 Subject: Fixing an anomaly with 'pat after cofix. --- interp/constrintern.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index e6340646f5..c916fcd886 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1602,7 +1602,8 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = let idl_tmp = Array.map (fun ((loc,id),bl,ty,_) -> let (env',rbl) = List.fold_left intern_local_binder (env,[]) bl in - let rbl = List.map (function BDRawDef a -> a | BDPattern _ -> assert false) rbl in + let rbl = List.map (function BDRawDef a -> a | BDPattern _ -> + Loc.raise loc (Stream.Error "pattern with quote not allowed after cofix")) rbl in (List.rev rbl, intern_type env' ty,env')) dl in let idl = Array.map2 (fun (_,_,_,bd) (b,c,env') -> -- cgit v1.2.3 From aa60931752217a7bf0536acae4e7858f48eb8c8e Mon Sep 17 00:00:00 2001 From: Hendrik Tews Date: Mon, 30 Jan 2017 21:08:29 +0100 Subject: fix Emacs compiler warning on '(lambda...) lambda is self-quoting, see elisp manual, section 12.7 Anonymous Functions --- tools/gallina-db.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/gallina-db.el b/tools/gallina-db.el index baabebb13a..9664f69f8b 100644 --- a/tools/gallina-db.el +++ b/tools/gallina-db.el @@ -163,7 +163,7 @@ for DB structure." (defun coq-sort-menu-entries (menu) (sort menu - '(lambda (x y) (string< + (lambda (x y) (string< (downcase (elt x 0)) (downcase (elt y 0)))))) -- cgit v1.2.3 From 5e909ab948ea3db4b5d734ec1c68198874c9724c Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Fri, 16 Dec 2016 18:35:34 +0100 Subject: pre_ident can be bound to Ltac variables. The use case is to take a hint database as an argument of Ltac or Tactic Notation. --- ltac/tacintern.ml | 1 + ltac/tacinterp.ml | 7 ++++--- ltac/tacsubst.ml | 1 + 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/ltac/tacintern.ml b/ltac/tacintern.ml index 763e0dc22e..4b5d87fc3c 100644 --- a/ltac/tacintern.ml +++ b/ltac/tacintern.ml @@ -782,6 +782,7 @@ let intern_ltac ist tac = 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_pre_ident (fun ist c -> (ist,c)); 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); diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml index 32bcdfb6a4..fda9142eda 100644 --- a/ltac/tacinterp.ml +++ b/ltac/tacinterp.ml @@ -2023,9 +2023,6 @@ let () = let () = declare_uniform wit_string -let () = - declare_uniform wit_pre_ident - let lift f = (); fun ist x -> Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in @@ -2053,9 +2050,13 @@ let interp_destruction_arg' ist c = Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (interp_destruction_arg ist gl c) end } +let interp_pre_ident ist env sigma s = + s |> Id.of_string |> interp_ident ist env sigma |> Id.to_string + let () = register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); register_interp0 wit_ref (lift interp_reference); + register_interp0 wit_pre_ident (lift interp_pre_ident); register_interp0 wit_ident (lift interp_ident); register_interp0 wit_var (lift interp_hyp); register_interp0 wit_intro_pattern (lifts interp_intro_pattern); diff --git a/ltac/tacsubst.ml b/ltac/tacsubst.ml index 55de583613..b09bdda65c 100644 --- a/ltac/tacsubst.ml +++ b/ltac/tacsubst.ml @@ -291,6 +291,7 @@ and subst_genarg subst (GenArg (Glbwit wit, x)) = let () = Genintern.register_subst0 wit_int_or_var (fun _ v -> v); Genintern.register_subst0 wit_ref subst_global_reference; + Genintern.register_subst0 wit_pre_ident (fun _ v -> v); 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); -- cgit v1.2.3 From 9e87e9582ffe68ff549347d4fab37f7514992361 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Fri, 16 Dec 2016 18:38:20 +0100 Subject: Remove hackish autounfoldify now that hintdb can be bound to Ltac variables. It will be possible to replace any call to 'autounfoldify x' with 'autounfold with x'. --- ltac/g_auto.ml4 | 9 --------- 1 file changed, 9 deletions(-) diff --git a/ltac/g_auto.ml4 b/ltac/g_auto.ml4 index a37cf306e1..4ec42c676f 100644 --- a/ltac/g_auto.ml4 +++ b/ltac/g_auto.ml4 @@ -149,15 +149,6 @@ TACTIC EXTEND autounfold_one [ 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) ] -> [ -- cgit v1.2.3 From ed9ab22b8c3b2210f479689f46d3e4b2fd4f52df Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Sat, 17 Dec 2016 13:00:55 +0100 Subject: Add test-suite files for hintdb variables in Ltac. In particular, this closes bug 2417. --- test-suite/bugs/closed/2417.v | 15 +++++++++++++++ test-suite/success/hintdb_in_ltac.v | 14 ++++++++++++++ test-suite/success/hintdb_in_ltac_bis.v | 15 +++++++++++++++ 3 files changed, 44 insertions(+) create mode 100644 test-suite/bugs/closed/2417.v create mode 100644 test-suite/success/hintdb_in_ltac.v create mode 100644 test-suite/success/hintdb_in_ltac_bis.v diff --git a/test-suite/bugs/closed/2417.v b/test-suite/bugs/closed/2417.v new file mode 100644 index 0000000000..b2f00ffc65 --- /dev/null +++ b/test-suite/bugs/closed/2417.v @@ -0,0 +1,15 @@ +Parameter x y : nat. +Axiom H : x = y. +Hint Rewrite H : mybase. + +Ltac bar base := autorewrite with base. + +Tactic Notation "foo" ident(base) := autorewrite with base. + +Goal x = 0. + bar mybase. + now_show (y = 0). + Undo 2. + foo mybase. + now_show (y = 0). +Abort. diff --git a/test-suite/success/hintdb_in_ltac.v b/test-suite/success/hintdb_in_ltac.v new file mode 100644 index 0000000000..f12b4d1f45 --- /dev/null +++ b/test-suite/success/hintdb_in_ltac.v @@ -0,0 +1,14 @@ +Definition x := 0. + +Hint Unfold x : mybase. + +Ltac autounfoldify base := autounfold with base. + +Tactic Notation "autounfoldify_bis" ident(base) := autounfold with base. + +Goal x = 0. + progress autounfoldify mybase. + Undo. + progress autounfoldify_bis mybase. + trivial. +Qed. diff --git a/test-suite/success/hintdb_in_ltac_bis.v b/test-suite/success/hintdb_in_ltac_bis.v new file mode 100644 index 0000000000..f5c25540ef --- /dev/null +++ b/test-suite/success/hintdb_in_ltac_bis.v @@ -0,0 +1,15 @@ +Parameter Foo : Prop. +Axiom H : Foo. + +Hint Resolve H : mybase. + +Ltac foo base := eauto with base. + +Tactic Notation "bar" ident(base) := + typeclasses eauto with base. + +Goal Foo. + progress foo mybase. + Undo. + progress bar mybase. +Qed. \ No newline at end of file -- cgit v1.2.3 From 4ddf3ee41eb6e8faaf223041d2bd42d4c62be58d Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Sat, 4 Feb 2017 01:50:58 +0100 Subject: Extraction: fix complexity issue #5310 A double call to pp_module_type inside Ocaml.pp_specif was causing an complexity blowup when pretty-printing heavily modular extracted code. I wasn't able to figure out why this double call is there. It could be the leftover of some intermediate work in 2007 before commit 350398eae (which introduced global printing phases Pre/Impl/Intf). Anyway I'm reasonably sure that today these two pp_module_type calls produce the exact same pretty-printed signature (even if there's a large bunch of imperative states around). Moreover, this duplicated signature is actually slightly wrong: when we alias a module M with a unambiguous name like Coq__123, the type of Coq__123 should not be an exact copy of the type of M, but rather a "strengthened" version of it (with equality between inductive types). So the best solution is now to use this funny feature of OCaml introduced in 3.12 : module Coq__123 : module type of struct include M end This "module type of struct include" is slightly awkward, but short, correct, and trivial to produce :-). And I doubt anybody will object to the (rare) use of some 3.12 features in extracted code of 2017... --- plugins/extraction/ocaml.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 3cb3810cbc..13b100fdb6 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -618,12 +618,13 @@ let rec pp_specif = function with Not_found -> pp_spec s) | (l,Smodule mt) -> 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) ++ (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^" :") ++ spc () ++ + str "module type of struct include " ++ name ++ str " end") with Not_found -> Pp.mt ()) | (l,Smodtype mt) -> let def = pp_module_type [] mt in -- cgit v1.2.3 From 0929a78f9a663ac2bcdf1294de93797b9fdfefad Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Sat, 4 Feb 2017 01:50:58 +0100 Subject: Extraction: fix complexity issue #5310 A double call to pp_module_type inside Ocaml.pp_specif was causing an complexity blowup when pretty-printing heavily modular extracted code. I wasn't able to figure out why this double call is there. It could be the leftover of some intermediate work in 2007 before commit 350398eae (which introduced global printing phases Pre/Impl/Intf). Anyway I'm reasonably sure that today these two pp_module_type calls produce the exact same pretty-printed signature (even if there's a large bunch of imperative states around). Moreover, this duplicated signature is actually slightly wrong: when we alias a module M with a unambiguous name like Coq__123, the type of Coq__123 should not be an exact copy of the type of M, but rather a "strengthened" version of it (with equality between inductive types). So the best solution is now to use this funny feature of OCaml introduced in 3.12 : module Coq__123 : module type of struct include M end This "module type of struct include" is slightly awkward, but short, correct, and trivial to produce :-). And I doubt anybody will object to the (rare) use of some 3.12 features in extracted code of 2017... --- plugins/extraction/ocaml.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 1c29a9bc24..5d10cb939d 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -618,12 +618,13 @@ let rec pp_specif = function with Not_found -> pp_spec s) | (l,Smodule mt) -> 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) ++ (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^" :") ++ spc () ++ + str "module type of struct include " ++ name ++ str " end") with Not_found -> Pp.mt ()) | (l,Smodtype mt) -> let def = pp_module_type [] mt in -- cgit v1.2.3 From 0b8d185baab95d92a7779482c7861c7be0a8e979 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 9 Feb 2017 18:26:33 +0100 Subject: Fixing bug #5346 (an unimplemented application of 'pat). --- test-suite/bugs/closed/5346.v | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 test-suite/bugs/closed/5346.v diff --git a/test-suite/bugs/closed/5346.v b/test-suite/bugs/closed/5346.v new file mode 100644 index 0000000000..0118c18704 --- /dev/null +++ b/test-suite/bugs/closed/5346.v @@ -0,0 +1,29 @@ +Inductive comp : Type -> Type := +| Ret {T} : forall (v:T), comp T +| Bind {T T'} : forall (p: comp T') (p': T' -> comp T), comp T. + +Notation "'do' x .. y <- p1 ; p2" := + (Bind p1 (fun x => .. (fun y => p2) ..)) + (at level 60, right associativity, + x binder, y binder). + +Definition Fst1 A B (p: comp (A*B)) : comp A := + do '(a, b) <- p; + Ret a. + +Definition Fst2 A B (p: comp (A*B)) : comp A := + match tt with + | _ => Bind p (fun '(a, b) => Ret a) + end. + +Definition Fst3 A B (p: comp (A*B)) : comp A := + match tt with + | _ => do a <- p; + Ret (fst a) + end. + +Definition Fst A B (p: comp (A * B)) : comp A := + match tt with + | _ => do '(a, b) <- p; + Ret a + end. -- cgit v1.2.3 From 29d7872c0159d2aab7264c0577a2f5a9dc7c90c9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 9 Feb 2017 18:33:08 +0100 Subject: Turning an anomaly on 'pat into a proper "unsupported" error message. --- interp/topconstr.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/interp/topconstr.ml b/interp/topconstr.ml index d388376bc2..a397ca82eb 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -60,6 +60,9 @@ let rec cases_pattern_fold_names f a = function | CPatPrim _ | CPatAtom _ -> a | CPatCast _ -> assert false +let ids_of_pattern = + cases_pattern_fold_names Id.Set.add Id.Set.empty + let ids_of_pattern_list = List.fold_left (Loc.located_fold_left @@ -173,7 +176,8 @@ let split_at_annot bl na = (List.rev ans, LocalRawAssum (r, k, t) :: rest) end | LocalRawDef _ as x :: rest -> aux (x :: acc) rest - | LocalPattern _ :: rest -> assert false + | LocalPattern (loc,_,_) :: rest -> + Loc.raise loc (Stream.Error "pattern with quote not allowed after fix") | [] -> user_err_loc(loc,"", str "No parameter named " ++ Nameops.pr_id id ++ str".") @@ -196,8 +200,9 @@ let map_local_binders f g e bl = (map_binder g e nal, LocalRawAssum(nal,k,f e ty)::bl) | LocalRawDef((loc,na),ty) -> (name_fold g na e, LocalRawDef((loc,na),f e ty)::bl) - | LocalPattern _ -> - assert false in + | LocalPattern (loc,pat,t) -> + let ids = ids_of_pattern pat in + (Id.Set.fold g ids e, LocalPattern (loc,pat,Option.map (f e) t)::bl) in let (e,rbl) = List.fold_left h (e,[]) bl in (e, List.rev rbl) -- cgit v1.2.3 From 0ca1717a3a1243d3fd905bb2f6c3d427f1f98dc6 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 10 Oct 2016 17:09:24 +0200 Subject: [misc] Remove unused binding. --- ltac/pptactic.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/ltac/pptactic.ml b/ltac/pptactic.ml index b1a6fa63d6..fccee6e40a 100644 --- a/ltac/pptactic.ml +++ b/ltac/pptactic.ml @@ -1243,11 +1243,10 @@ let declare_extra_genarg_pprule wit (f : 'a raw_extra_genarg_printer) (g : 'b glob_extra_genarg_printer) (h : 'c extra_genarg_printer) = - let s = match wit with - | ExtraArg s -> ArgT.repr s - | _ -> error - "Can declare a pretty-printing rule only for extra argument types." - in + begin match wit with + | ExtraArg s -> () + | _ -> error "Can declare a pretty-printing rule only for extra argument types." + end; let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in let g x = let env = Global.env () in -- cgit v1.2.3 From 2a4f21db56400ee8928f33c3b47edfee54579afc Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 10 Oct 2016 17:10:23 +0200 Subject: [safe-string] Use `String.init` to build string. --- lib/unicode.ml | 39 +++++++++++++++++++++------------------ 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/lib/unicode.ml b/lib/unicode.ml index ced5e258c2..3ac4e8ca7c 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -125,26 +125,29 @@ let utf8_of_unicode n = if n < 128 then String.make 1 (Char.chr n) else if n < 2048 then - let s = String.make 2 (Char.chr (128 + n mod 64)) in - begin - s.[0] <- Char.chr (192 + n / 64); - s - end + String.init 2 (fun idx -> + match idx with + | 0 -> Char.chr (192 + n / 64) + | 1 -> Char.chr (128 + n mod 64) + | _ -> 'x' + ) else if n < 65536 then - let s = String.make 3 (Char.chr (128 + n mod 64)) in - begin - s.[1] <- Char.chr (128 + (n / 64) mod 64); - s.[0] <- Char.chr (224 + n / 4096); - s - end + String.init 3 (fun idx -> + match idx with + | 0 -> Char.chr (224 + n / 4096) + | 1 -> Char.chr (128 + (n / 64) mod 64) + | 2 -> Char.chr (128 + n mod 64) + | _ -> 'x' + ) else - let s = String.make 4 (Char.chr (128 + n mod 64)) in - begin - s.[2] <- Char.chr (128 + (n / 64) mod 64); - s.[1] <- Char.chr (128 + (n / 4096) mod 64); - s.[0] <- Char.chr (240 + n / 262144); - s - end + String.init 4 (fun idx -> + match idx with + | 0 -> Char.chr (240 + n / 262144) + | 1 -> Char.chr (128 + (n / 4096) mod 64) + | 2 -> Char.chr (128 + (n / 64) mod 64) + | 4 -> Char.chr (128 + n mod 64) + | _ -> 'x' + ) (* If [s] is some UTF-8 encoded string and [i] is a position of some UTF-8 character within [s] -- cgit v1.2.3 From a92492652c146c4c51a94922345ddf4c168cdcf4 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 10 Oct 2016 17:10:48 +0200 Subject: [safe-string] Switch to buffer to `Bytes` --- toplevel/vernac.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 0e72a044c1..c1a659c38d 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -105,7 +105,7 @@ let verbose_phrase verbch loc = match verbch with | Some ch -> let len = snd loc - fst loc in - let s = String.create len in + let s = Bytes.create len in seek_in ch (fst loc); really_input ch s 0 len; Feedback.msg_notice (str s) @@ -162,7 +162,7 @@ let pr_new_syntax po loc chan_beautify ocom = let pp_cmd_header loc com = let shorten s = try (String.sub s 0 30)^"..." with _ -> s in let noblank s = - for i = 0 to String.length s - 1 do + for i = 0 to Bytes.length s - 1 do match s.[i] with | ' ' | '\n' | '\t' | '\r' -> s.[i] <- '~' | _ -> () -- cgit v1.2.3 From 3cdcad29ee9d28b0cb39740004da90a0fe291543 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 30 Jan 2017 15:28:01 +0100 Subject: [unicode] Address comments in PR#314. --- lib/unicode.ml | 27 ++++----------------------- 1 file changed, 4 insertions(+), 23 deletions(-) diff --git a/lib/unicode.ml b/lib/unicode.ml index 3ac4e8ca7c..959ccaf73c 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -124,30 +124,11 @@ exception End_of_input let utf8_of_unicode n = if n < 128 then String.make 1 (Char.chr n) - else if n < 2048 then - String.init 2 (fun idx -> - match idx with - | 0 -> Char.chr (192 + n / 64) - | 1 -> Char.chr (128 + n mod 64) - | _ -> 'x' - ) - else if n < 65536 then - String.init 3 (fun idx -> - match idx with - | 0 -> Char.chr (224 + n / 4096) - | 1 -> Char.chr (128 + (n / 64) mod 64) - | 2 -> Char.chr (128 + n mod 64) - | _ -> 'x' - ) else - String.init 4 (fun idx -> - match idx with - | 0 -> Char.chr (240 + n / 262144) - | 1 -> Char.chr (128 + (n / 4096) mod 64) - | 2 -> Char.chr (128 + (n / 64) mod 64) - | 4 -> Char.chr (128 + n mod 64) - | _ -> 'x' - ) + let (m,s) = if n < 2048 then (2,192) else if n < 65536 then (3,224) else (4,240) in + String.init m (fun i -> + let j = (n lsr ((m - 1 - i) * 6)) land 63 in + Char.chr (j + if i = 0 then s else 128)) (* If [s] is some UTF-8 encoded string and [i] is a position of some UTF-8 character within [s] -- cgit v1.2.3 From fa9df2efe5666789bf91bb7761567cd53e6c451f Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Sun, 18 Dec 2016 18:14:58 +0100 Subject: [stm] Break stm/toplevel dependency loop. Currently, the STM, vernac interpretation, and the toplevel are intertwined in a mutual dependency that needs to be resolved using imperative callbacks. This is problematic for a few reasons, in particular it makes the interpretation of commands that affect the document quite intricate. As a first step, we split the `toplevel/` directory into two: "pure" vernac interpretation is moved to the `vernac/` directory, on which the STM relies. Test suite passes, and only one command seems to be disabled with this approach, "Show Script" which is to my understanding obsolete. Subsequent commits will fix this and refine some of the invariants that are not needed anymore. --- .merlin | 2 + Makefile.common | 4 +- proofs/proof_global.ml | 7 +- stm/lemmas.ml | 557 ----------- stm/lemmas.mli | 69 -- stm/stm.ml | 59 +- stm/stm.mli | 5 - stm/stm.mllib | 1 - tools/coq_makefile.ml | 2 +- tools/coqmktop.ml | 1 + toplevel/assumptions.ml | 320 ------- toplevel/assumptions.mli | 31 - toplevel/auto_ind_decl.ml | 969 ------------------- toplevel/auto_ind_decl.mli | 42 - toplevel/class.ml | 328 ------- toplevel/class.mli | 48 - toplevel/classes.ml | 410 -------- toplevel/classes.mli | 66 -- toplevel/command.ml | 1357 -------------------------- toplevel/command.mli | 176 ---- toplevel/discharge.ml | 120 --- toplevel/discharge.mli | 14 - toplevel/doc.tex | 10 - toplevel/explainErr.ml | 129 --- toplevel/explainErr.mli | 21 - toplevel/himsg.ml | 1268 ------------------------- toplevel/himsg.mli | 42 - toplevel/ind_tables.ml | 203 ---- toplevel/ind_tables.mli | 51 - toplevel/indschemes.ml | 530 ----------- toplevel/indschemes.mli | 49 - toplevel/locality.ml | 107 --- toplevel/locality.mli | 51 - toplevel/metasyntax.ml | 1469 ---------------------------- toplevel/metasyntax.mli | 63 -- toplevel/mltop.ml | 447 --------- toplevel/mltop.mli | 88 -- toplevel/obligations.ml | 1173 ----------------------- toplevel/obligations.mli | 113 --- toplevel/record.ml | 583 ------------ toplevel/record.mli | 46 - toplevel/search.ml | 381 -------- toplevel/search.mli | 84 -- toplevel/toplevel.mllib | 16 - toplevel/vernac.ml | 2 +- toplevel/vernacentries.ml | 2258 ------------------------------------------- toplevel/vernacentries.mli | 66 -- toplevel/vernacinterp.ml | 77 -- toplevel/vernacinterp.mli | 20 - vernac/assumptions.ml | 320 +++++++ vernac/assumptions.mli | 31 + vernac/auto_ind_decl.ml | 969 +++++++++++++++++++ vernac/auto_ind_decl.mli | 42 + vernac/class.ml | 328 +++++++ vernac/class.mli | 48 + vernac/classes.ml | 410 ++++++++ vernac/classes.mli | 66 ++ vernac/command.ml | 1357 ++++++++++++++++++++++++++ vernac/command.mli | 176 ++++ vernac/discharge.ml | 120 +++ vernac/discharge.mli | 14 + vernac/doc.tex | 10 + vernac/explainErr.ml | 129 +++ vernac/explainErr.mli | 21 + vernac/himsg.ml | 1268 +++++++++++++++++++++++++ vernac/himsg.mli | 42 + vernac/ind_tables.ml | 203 ++++ vernac/ind_tables.mli | 51 + vernac/indschemes.ml | 530 +++++++++++ vernac/indschemes.mli | 49 + vernac/lemmas.ml | 557 +++++++++++ vernac/lemmas.mli | 69 ++ vernac/locality.ml | 107 +++ vernac/locality.mli | 51 + vernac/metasyntax.ml | 1469 ++++++++++++++++++++++++++++ vernac/metasyntax.mli | 63 ++ vernac/mltop.ml | 447 +++++++++ vernac/mltop.mli | 88 ++ vernac/obligations.ml | 1179 +++++++++++++++++++++++ vernac/obligations.mli | 113 +++ vernac/record.ml | 583 ++++++++++++ vernac/record.mli | 46 + vernac/search.ml | 381 ++++++++ vernac/search.mli | 84 ++ vernac/vernac.mllib | 17 + vernac/vernacentries.ml | 2271 ++++++++++++++++++++++++++++++++++++++++++++ vernac/vernacentries.mli | 66 ++ vernac/vernacinterp.ml | 77 ++ vernac/vernacinterp.mli | 20 + 89 files changed, 13915 insertions(+), 13892 deletions(-) delete mode 100644 stm/lemmas.ml delete mode 100644 stm/lemmas.mli delete mode 100644 toplevel/assumptions.ml delete mode 100644 toplevel/assumptions.mli delete mode 100644 toplevel/auto_ind_decl.ml delete mode 100644 toplevel/auto_ind_decl.mli delete mode 100644 toplevel/class.ml delete mode 100644 toplevel/class.mli delete mode 100644 toplevel/classes.ml delete mode 100644 toplevel/classes.mli delete mode 100644 toplevel/command.ml delete mode 100644 toplevel/command.mli delete mode 100644 toplevel/discharge.ml delete mode 100644 toplevel/discharge.mli delete mode 100644 toplevel/doc.tex delete mode 100644 toplevel/explainErr.ml delete mode 100644 toplevel/explainErr.mli delete mode 100644 toplevel/himsg.ml delete mode 100644 toplevel/himsg.mli delete mode 100644 toplevel/ind_tables.ml delete mode 100644 toplevel/ind_tables.mli delete mode 100644 toplevel/indschemes.ml delete mode 100644 toplevel/indschemes.mli delete mode 100644 toplevel/locality.ml delete mode 100644 toplevel/locality.mli delete mode 100644 toplevel/metasyntax.ml delete mode 100644 toplevel/metasyntax.mli delete mode 100644 toplevel/mltop.ml delete mode 100644 toplevel/mltop.mli delete mode 100644 toplevel/obligations.ml delete mode 100644 toplevel/obligations.mli delete mode 100644 toplevel/record.ml delete mode 100644 toplevel/record.mli delete mode 100644 toplevel/search.ml delete mode 100644 toplevel/search.mli delete mode 100644 toplevel/vernacentries.ml delete mode 100644 toplevel/vernacentries.mli delete mode 100644 toplevel/vernacinterp.ml delete mode 100644 toplevel/vernacinterp.mli create mode 100644 vernac/assumptions.ml create mode 100644 vernac/assumptions.mli create mode 100644 vernac/auto_ind_decl.ml create mode 100644 vernac/auto_ind_decl.mli create mode 100644 vernac/class.ml create mode 100644 vernac/class.mli create mode 100644 vernac/classes.ml create mode 100644 vernac/classes.mli create mode 100644 vernac/command.ml create mode 100644 vernac/command.mli create mode 100644 vernac/discharge.ml create mode 100644 vernac/discharge.mli create mode 100644 vernac/doc.tex create mode 100644 vernac/explainErr.ml create mode 100644 vernac/explainErr.mli create mode 100644 vernac/himsg.ml create mode 100644 vernac/himsg.mli create mode 100644 vernac/ind_tables.ml create mode 100644 vernac/ind_tables.mli create mode 100644 vernac/indschemes.ml create mode 100644 vernac/indschemes.mli create mode 100644 vernac/lemmas.ml create mode 100644 vernac/lemmas.mli create mode 100644 vernac/locality.ml create mode 100644 vernac/locality.mli create mode 100644 vernac/metasyntax.ml create mode 100644 vernac/metasyntax.mli create mode 100644 vernac/mltop.ml create mode 100644 vernac/mltop.mli create mode 100644 vernac/obligations.ml create mode 100644 vernac/obligations.mli create mode 100644 vernac/record.ml create mode 100644 vernac/record.mli create mode 100644 vernac/search.ml create mode 100644 vernac/search.mli create mode 100644 vernac/vernac.mllib create mode 100644 vernac/vernacentries.ml create mode 100644 vernac/vernacentries.mli create mode 100644 vernac/vernacinterp.ml create mode 100644 vernac/vernacinterp.mli diff --git a/.merlin b/.merlin index 7410e601b7..bda18d5490 100644 --- a/.merlin +++ b/.merlin @@ -34,6 +34,8 @@ S stm B stm S toplevel B toplevel +S vernac +B vernac S tools B tools diff --git a/Makefile.common b/Makefile.common index 49fe1fd939..2c55d76cc8 100644 --- a/Makefile.common +++ b/Makefile.common @@ -55,7 +55,7 @@ MKDIR:=install -d CORESRCDIRS:=\ config lib kernel kernel/byterun library \ proofs tactics pretyping interp stm \ - toplevel parsing printing intf engine ltac + toplevel parsing printing intf engine ltac vernac PLUGINDIRS:=\ omega romega micromega quote \ @@ -83,7 +83,7 @@ BYTERUN:=$(addprefix kernel/byterun/, \ 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 \ + parsing/parsing.cma printing/printing.cma tactics/tactics.cma vernac/vernac.cma \ stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma ltac/ltac.cma TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index a2ee622215..120cde5e55 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -317,7 +317,10 @@ let constrain_variables init uctx = 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 = +type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context + +let close_proof ~keep_body_ucst_separate ?feedback_id ~now + (fpl : closed_proof_output Future.computation) = let { pid; section_vars; strength; proof; terminator; universe_binders } = cur_pstate () in let poly = pi2 strength (* Polymorphic *) in @@ -395,8 +398,6 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = universes = (universes, binders) }, fun pr_ending -> CEphemeron.get terminator pr_ending -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 if allow_partial then begin diff --git a/stm/lemmas.ml b/stm/lemmas.ml deleted file mode 100644 index 55f33be399..0000000000 --- a/stm/lemmas.ml +++ /dev/null @@ -1,557 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Globnames.global_reference -> 'a -let mk_hook hook = hook -let call_hook fix_exn hook l c = - try hook l c - with e when CErrors.noncritical e -> - let e = CErrors.push e in - iraise (fix_exn e) - -(* Support for mutually proved theorems *) - -let retrieve_first_recthm = function - | VarRef id -> - (NamedDecl.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) - | _ -> assert false - -let adjust_guardness_conditions const = function - | [] -> const (* Not a recursive statement *) - | possible_indexes -> - (* Try all combinations... not optimal *) - let env = Global.env() in - { const with const_entry_body = - Future.chain ~greedy:true ~pure:true const.const_entry_body - (fun ((body, ctx), eff) -> - match kind_of_term body with - | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> -(* let possible_indexes = - List.map2 (fun i c -> match i with Some i -> i | None -> - List.interval 0 (List.length ((lam_assum c)))) - lemma_guard (Array.to_list fixdefs) in -*) - let add c cb e = - let exists c e = - 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 = 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 (Safe_typing.side_effects_of_private_constants eff) in - let indexes = - search_guard Loc.ghost env - possible_indexes fixdecls in - (mkFix ((indexes,0),fixdecls), ctx), eff - | _ -> (body, ctx), eff) } - -let find_mutually_recursive_statements thms = - let n = List.length thms in - let inds = List.map (fun (id,(t,impls,annot)) -> - let (hyps,ccl) = decompose_prod_assum t in - let x = (id,(t,impls)) in - match annot with - (* Explicit fixpoint decreasing argument is given *) - | Some (Some (_,id),CStructRec) -> - let i,b,typ = lookup_rel_id id hyps 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.Finite && Option.is_empty b -> - [ind,x,i],[] - | _ -> - error "Decreasing argument is not an inductive assumption.") - (* Unsupported cases *) - | Some (_,(CWfRec _|CMeasureRec _)) -> - error "Only structural decreasing is supported for mutual statements." - (* Cofixpoint or fixpoint w/o explicit decreasing argument *) - | None | Some (None, CStructRec) -> - let whnf_hyp_hds = map_rel_context_in_env - (fun env c -> fst (whd_all_stack env Evd.empty c)) - (Global.env()) hyps in - let ind_hyps = - List.flatten (List.map_i (fun i decl -> - let t = RelDecl.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 && is_local_assum decl -> - [ind,x,i] - | _ -> - []) 0 (List.rev whnf_hyp_hds)) in - let ind_ccl = - let cclenv = push_rel_context hyps (Global.env()) in - let whnf_ccl,_ = whd_all_stack cclenv Evd.empty ccl in - match kind_of_term whnf_ccl with - | Ind ((kn,_ as ind),u) when - let mind = Global.lookup_mind kn in - Int.equal mind.mind_ntypes n && mind.mind_finite == Decl_kinds.CoFinite -> - [ind,x,0] - | _ -> - [] in - ind_hyps,ind_ccl) thms in - let inds_hyps,ind_ccls = List.split inds in - let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> eq_mind kn kn' in - (* Check if all conclusions are coinductive in the same type *) - (* (degenerated cartesian product since there is at most one coind ccl) *) - let same_indccl = - List.cartesians_filter (fun hyp oks -> - if List.for_all (of_same_mutind hyp) oks - then Some (hyp::oks) else None) [] ind_ccls in - let ordered_same_indccl = - List.filter (List.for_all_i (fun i ((kn,j),_,_) -> Int.equal i j) 0) same_indccl in - (* Check if some hypotheses are inductive in the same type *) - let common_same_indhyp = - List.cartesians_filter (fun hyp oks -> - if List.for_all (of_same_mutind hyp) oks - then Some (hyp::oks) else None) [] inds_hyps in - let ordered_inds,finite,guard = - match ordered_same_indccl, common_same_indhyp with - | indccl::rest, _ -> - assert (List.is_empty rest); - (* One occ. of common coind ccls and no common inductive hyps *) - if not (List.is_empty common_same_indhyp) then - if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements."); - flush_all (); - indccl, true, [] - | [], _::_ -> - let () = match same_indccl with - | ind :: _ -> - if List.distinct_f ind_ord (List.map pi1 ind) - then - if_verbose Feedback.msg_info - (strbrk - ("Coinductive statements do not follow the order of "^ - "definition, assuming the proof to be by induction.")); - flush_all () - | _ -> () - in - let possible_guards = List.map (List.map pi3) inds_hyps in - (* assume the largest indices as possible *) - List.last common_same_indhyp, false, possible_guards - | _, [] -> - error - ("Cannot find common (mutual) inductive premises or coinductive" ^ - " conclusions in the statements.") - in - (finite,guard,None), ordered_inds - -let look_for_possibly_mutual_statements = function - | [id,(t,impls,None)] -> - (* One non recursively proved theorem *) - None,[id,(t,impls)],None - | _::_ as thms -> - (* More than one statement and/or an explicit decreasing mark: *) - (* we look for a common inductive hyp or a common coinductive conclusion *) - let recguard,ordered_inds = find_mutually_recursive_statements thms in - let thms = List.map pi2 ordered_inds in - Some recguard,thms, Some (List.map (fun (_,_,i) -> succ i) ordered_inds) - | [] -> anomaly (Pp.str "Empty list of theorems.") - -(* Saving a goal *) - -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 - let k = Kindops.logical_kind_of_goal_kind kind in - let l,r = match locality with - | Discharge when Lib.sections_are_opened () -> - let c = SectionLocalDef const in - let _ = declare_variable id (Lib.cwd(), c, k) in - (Local, VarRef id) - | Local | Global | Discharge -> - let local = match locality with - | Local | Discharge -> true - | Global -> false - in - let kn = - 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 CErrors.noncritical e -> - let e = CErrors.push e in - iraise (fix_exn e) - -let default_thm_id = Id.of_string "Unnamed_thm" - -let compute_proof_name locality = function - | 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) - then - user_err ~loc (pr_id id ++ str " already exists."); - id, pl - | None -> - 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,pl),(t_i,(_,imps))) = - let t_i = norm t_i in - match body with - | None -> - (match locality with - | Discharge -> - let impl = false in (* copy values from Vernacentries *) - let k = IsAssumption Conjectural in - let c = SectionLocalAssum ((t_i,ctx),p,impl) in - let _ = declare_variable id (Lib.cwd(),c,k) in - (Discharge, VarRef id,imps) - | Local | Global -> - let k = IsAssumption Conjectural in - let local = match locality with - | Local -> true - | Global -> false - | Discharge -> assert false - in - let ctx = Univ.ContextSet.to_context ctx in - let decl = (ParameterEntry (None,p,(t_i,ctx),None), k) in - let kn = declare_constant id ~local decl in - (locality,ConstRef kn,imps)) - | Some body -> - let body = norm body in - let k = Kindops.logical_kind_of_goal_kind kind in - let rec body_i t = match kind_of_term t with - | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) - | CoFix (0,decls) -> mkCoFix (i,decls) - | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, body_i t2) - | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t) - | App (t, args) -> mkApp (body_i t, args) - | _ -> anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr body) in - let body_i = body_i body in - match locality with - | Discharge -> - let const = definition_entry ~types:t_i ~opaque:opaq ~poly:p - ~univs:(Univ.ContextSet.to_context ctx) body_i in - let c = SectionLocalDef const in - let _ = declare_variable id (Lib.cwd(), c, k) in - (Discharge,VarRef id,imps) - | Local | Global -> - let ctx = Univ.ContextSet.to_context ctx in - let local = match locality with - | Local -> true - | Global -> false - | Discharge -> assert false - in - let const = - Declare.definition_entry ~types:t_i ~poly:p ~univs:ctx ~opaque:opaq body_i - in - let kn = declare_constant id ~local (DefinitionEntry const, k) in - (locality,ConstRef kn,imps) - -let save_hook = ref ignore -let set_save_hook f = save_hook := f - -let save_named ?export_seff proof = - 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,pl),do_guard,persistence,hook = proof in - check_anonymity id save_ident; - 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,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 pl do_guard - (Global, const.const_entry_polymorphic, Proof kind) hook - -(* Admitted *) - -let warn_let_as_axiom = - CWarnings.create ~name:"let-as-axiom" ~category:"vernacular" - (fun id -> strbrk "Let definition" ++ spc () ++ pr_id id ++ - spc () ++ strbrk "declared as an axiom.") - -let admit (id,k,e) pl hook () = - let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in - let () = match k with - | Global, _, _ -> () - | Local, _, _ | Discharge, _, _ -> warn_let_as_axiom id - 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 *) - -let start_hook = ref ignore -let set_start_hook = (:=) start_hook - - -let get_proof proof do_guard hook opacity = - let (id,(const,univs,persistence)) = - Pfedit.cook_this_proof proof - in - id,{const with const_entry_opaque = opacity},univs,do_guard,persistence,hook - -let check_exist = - List.iter (fun (loc,id) -> - if not (Nametab.exists_cci (Lib.make_path id)) then - user_err ~loc (pr_id id ++ str " does not exist.") - ) - -let universe_proof_terminator compute_guard hook = - let open Proof_global in - make_terminator begin function - | Admitted (id,k,pe,(ctx,pl)) -> - admit (id,k,pe) pl (hook (Some ctx)) (); - Feedback.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 (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 - | Some ((_,id),Some kind) -> - save_anonymous_with_strength ~export_seff proof kind id - end; - check_exist exports - end - -let standard_proof_terminator compute_guard hook = - universe_proof_terminator compute_guard (fun _ -> hook) - -let start_proof id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = - let terminator = match terminator with - | None -> standard_proof_terminator compute_guard hook - | Some terminator -> terminator compute_guard hook - in - let sign = - match sign with - | Some sign -> sign - | None -> initialize_named_context_for_proof () - in - !start_hook c; - Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator - -let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = - let terminator = match terminator with - | None -> universe_proof_terminator compute_guard hook - | Some terminator -> terminator compute_guard hook - in - let sign = - match sign with - | Some sign -> sign - | None -> initialize_named_context_for_proof () - in - !start_hook c; - 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 - | (id,_)::l -> Tactics.mutual_cofix id l 0 - | _ -> assert false - else - (* nl is dummy: it will be recomputed at Qed-time *) - 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 - | (id,n,_)::l -> Tactics.mutual_fix id n l 0 - | _ -> assert false - -let start_proof_with_initialization kind ctx recguard thms snl hook = - let intro_tac (_, (_, (ids, _))) = - Tacticals.New.tclMAP (function - | Name id -> Tactics.intro_mustbe_force id - | Anonymous -> Tactics.intro) (List.rev ids) in - let init_tac,guard = match recguard with - | Some (finite,guard,init_tac) -> - let rec_tac = rec_tac_initializer finite guard thms snl in - Some (match init_tac with - | None -> - if Flags.is_auto_intros () then - Tacticals.New.tclTHENS rec_tac (List.map intro_tac thms) - else - rec_tac - | Some tacl -> - Tacticals.New.tclTHENS rec_tac - (if Flags.is_auto_intros () then - List.map2 (fun tac thm -> Tacticals.New.tclTHEN tac (intro_tac thm)) tacl thms - else - tacl)),guard - | None -> - let () = match thms with [_] -> () | _ -> assert false in - (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,pl),(t,(_,imps)))::other_thms -> - let hook ctx strength ref = - let ctx = match ctx with - | None -> Evd.empty_evar_universe_context - | Some ctx -> ctx - in - let other_thms_data = - if List.is_empty other_thms then [] else - (* there are several theorems defined mutually *) - 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 = 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 - 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 ?pl kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard - -let start_proof_com ?inference_hook kind thms hook = - let env0 = Global.env () 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 - let flags = all_and_fail_flags in - let flags = { flags with use_hook = inference_hook } in - evdref := solve_remaining_evars flags env !evdref (Evd.empty,!evdref); - let ids = List.map RelDecl.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'), - guard))) - thms in - 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 - let () = - match levels with - | None -> () - | Some l -> ignore (Evd.universe_context evd ?names:l) - in - 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 *) - -let keep_admitted_vars = ref true - -let _ = - let open Goptions in - declare_bool_option - { optsync = true; - optdepr = false; - optname = "keep section variables in admitted proofs"; - optkey = ["Keep"; "Admitted"; "Variables"]; - optread = (fun () -> !keep_admitted_vars); - optwrite = (fun b -> keep_admitted_vars := b) } - -let save_proof ?proof = function - | Vernacexpr.Admitted -> - let pe = - let open Proof_global in - match proof with - | Some ({ id; entries; persistence = k; universes }, _) -> - if List.length entries <> 1 then - error "Admitted does not support multiple statements"; - let { const_entry_secctx; const_entry_type } = List.hd entries in - 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 (fst universes) in - let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in - Admitted(id, k, (sec_vars, pi2 k, (typ, ctx), None), universes) - | None -> - let pftree = Pfedit.get_pftreestate () in - let id, k, typ = Pfedit.current_proof_statement () in - let universes = Proof.initial_euctx pftree in - (* This will warn if the proof is complete *) - let pproofs, _univs = - Proof_global.return_proof ~allow_partial:true () in - let sec_vars = - if not !keep_admitted_vars then None - else match Pfedit.get_used_variables(), pproofs with - | Some _ as x, _ -> x - | None, (pproof, _) :: _ -> - let env = Global.env () in - let ids_typ = Environ.global_vars_set env typ in - let ids_def = Environ.global_vars_set env pproof in - Some (Environ.keep_hyps env (Idset.union ids_typ ids_def)) - | _ -> None in - let names = Pfedit.get_universe_binders () in - let evd = Evd.from_ctx universes in - let binders, ctx = Evd.universe_context ?names evd in - Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None), - (universes, Some binders)) - in - Proof_global.apply_terminator (Proof_global.get_terminator ()) pe - | Vernacexpr.Proved (is_opaque,idopt) -> - let (proof_obj,terminator) = - match proof with - | None -> - Proof_global.close_proof ~keep_body_ucst_separate:false (fun x -> x) - | Some proof -> proof - in - (* if the proof is given explicitly, nothing has to be deleted *) - if Option.is_empty proof then Pfedit.delete_current_proof (); - Proof_global.(apply_terminator terminator (Proved (is_opaque,idopt,proof_obj))) - -(* Miscellaneous *) - -let get_current_context () = - Pfedit.get_current_context () - diff --git a/stm/lemmas.mli b/stm/lemmas.mli deleted file mode 100644 index 39c089be9f..0000000000 --- a/stm/lemmas.mli +++ /dev/null @@ -1,69 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Globnames.global_reference -> 'a) -> 'a declaration_hook - -val call_hook : - Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> Globnames.global_reference -> 'a - -(** 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 -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> - ?terminator:(lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> - ?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 -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> - ?terminator:(lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator) -> - ?sign:Environ.named_context_val -> types -> - ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> - (Evd.evar_universe_context option -> unit declaration_hook) -> unit - -val start_proof_com : - ?inference_hook:Pretyping.inference_hook -> - 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 * universe_binders option) * - (types * (Name.t list * Impargs.manual_explicitation list))) list - -> int list option -> unit declaration_hook -> unit - -val universe_proof_terminator : - Proof_global.lemma_possible_guards -> - (Evd.evar_universe_context option -> unit declaration_hook) -> - Proof_global.proof_terminator - -val standard_proof_terminator : - Proof_global.lemma_possible_guards -> unit declaration_hook -> - Proof_global.proof_terminator - -(** {6 ... } *) - -(** A hook the next three functions pass to cook_proof *) -val set_save_hook : (Proof.proof -> unit) -> unit - -val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit - - -(** [get_current_context ()] returns the evar context and env of the - current open proof if any, otherwise returns the empty evar context - and the current global env *) - -val get_current_context : unit -> Evd.evar_map * Environ.env diff --git a/stm/stm.ml b/stm/stm.ml index 6f34c8dbc3..be3e841cb9 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -24,11 +24,13 @@ open Ppvernac open Vernac_classifier open Feedback +let execution_error state_id loc msg = + feedback ~id:(State state_id) + (Message (Error, Some loc, pp_to_richpp msg)) + module Hooks = struct let process_error, process_error_hook = Hook.make () -let interp, interp_hook = Hook.make () -let with_fail, with_fail_hook = Hook.make () let state_computed, state_computed_hook = Hook.make ~default:(fun state_id ~in_cache -> @@ -48,10 +50,6 @@ let parse_error, parse_error_hook = Hook.make ~default:(fun id loc msg -> feedback ~id (Message(Error, Some loc, pp_to_richpp msg))) () -let execution_error, execution_error_hook = Hook.make - ~default:(fun state_id loc msg -> - feedback ~id:(State state_id) (Message(Error, Some loc, pp_to_richpp msg))) () - let unreachable_state, unreachable_state_hook = Hook.make ~default:(fun _ _ -> ()) () @@ -106,24 +104,36 @@ let may_pierce_opaque = function | _ -> false (* Wrapper for Vernacentries.interp to set the feedback id *) -let vernac_interp ?proof id ?route { verbose; loc; expr } = - let rec internal_command = function - | VernacResetName _ | VernacResetInitial | VernacBack _ - | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ - | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true - | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> internal_command e - | _ -> false in - if internal_command expr then begin +(* It is currently called 19 times, this number should be certainly + reduced... *) +let stm_vernac_interp ?proof id ?route { verbose; loc; expr } = + (* The Stm will gain the capability to interpret commmads affecting + the whole document state, such as backtrack, etc... so we start + to design the stm command interpreter now *) + set_id_for_feedback ?route (State id); + Aux_file.record_in_aux_set_at loc; + (* We need to check if a command should be filtered from + * vernac_entries, as it cannot handle it. This should go away in + * future refactorings. + *) + let rec is_filtered_command = function + | VernacResetName _ | VernacResetInitial | VernacBack _ + | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ + | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true + | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> is_filtered_command e + | _ -> false + in + let aux_interp cmd = + if is_filtered_command cmd then prerr_endline (fun () -> "ignoring " ^ Pp.string_of_ppcmds(pr_vernac expr)) - end else begin - set_id_for_feedback ?route (State id); - Aux_file.record_in_aux_set_at loc; + else match cmd with + | expr -> prerr_endline (fun () -> "interpreting " ^ Pp.string_of_ppcmds(pr_vernac expr)); - try Hooks.(call interp ?verbosely:(Some verbose) ?proof (loc, expr)) + try Vernacentries.interp ?verbosely:(Some verbose) ?proof (loc, expr) with e -> let e = CErrors.push e in iraise Hooks.(call_process_error_once e) - end + in aux_interp expr (* Wrapper for Vernac.parse_sentence to set the feedback id *) let indentation_of_string s = @@ -860,7 +870,7 @@ end = struct (* {{{ *) | None -> let loc = Option.default Loc.ghost (Loc.get_loc info) in let (e, info) = Hooks.(call_process_error_once (e, info)) in - Hooks.(call execution_error id loc (iprint (e, info))); + execution_error id loc (iprint (e, info)); (e, Stateid.add info ~valid id) let same_env { system = s1 } { system = s2 } = @@ -910,7 +920,6 @@ end = struct (* {{{ *) end (* }}} *) - (****************************** CRUFT *****************************************) (******************************************************************************) @@ -1287,7 +1296,7 @@ end = struct (* {{{ *) let info = Stateid.add ~valid:start Exninfo.null start in let e = (RemoteException (strbrk s), info) in t_assign (`Exn e); - Hooks.(call execution_error start Loc.ghost (strbrk s)); + execution_error start Loc.ghost (strbrk s); feedback (InProgress ~-1) let build_proof_here ~drop_pt (id,valid) loc eop = @@ -1750,7 +1759,7 @@ end = struct (* {{{ *) | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> find true fail e | VernacFail e -> find time true e | _ -> e, time, fail in find false false e in - Hooks.call Hooks.with_fail fail (fun () -> + Vernacentries.with_fail fail (fun () -> (if time then System.with_time false else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> Proof_global.with_current_proof (fun _ p -> @@ -2946,12 +2955,8 @@ let show_script ?proof () = let state_computed_hook = Hooks.state_computed_hook let state_ready_hook = Hooks.state_ready_hook let parse_error_hook = Hooks.parse_error_hook -let execution_error_hook = Hooks.execution_error_hook let forward_feedback_hook = Hooks.forward_feedback_hook 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 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 b8a2a38596..36341a5d51 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -184,7 +184,6 @@ val register_proof_block_delimiter : 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 -> Exninfo.iexn -> unit) Hook.t (* ready means that master has it at hand *) val state_ready_hook : (Stateid.t -> unit) Hook.t @@ -218,7 +217,3 @@ val show_script : ?proof:Proof_global.closed_proof -> unit -> unit (* Hooks to be set by other Coq components in order to break file cycles *) 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/stm/stm.mllib b/stm/stm.mllib index 939ee187ae..4b254e8113 100644 --- a/stm/stm.mllib +++ b/stm/stm.mllib @@ -4,7 +4,6 @@ Vcs TQueue WorkerPool Vernac_classifier -Lemmas CoqworkmgrApi AsyncTaskQueue Stm diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index b7dd5f2a14..624b9ced7d 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -51,7 +51,7 @@ let lib_dirs = ["kernel"; "lib"; "library"; "parsing"; "pretyping"; "interp"; "printing"; "intf"; "proofs"; "tactics"; "tools"; "ltacprof"; - "toplevel"; "stm"; "grammar"; "config"; + "vernac"; "stm"; "toplevel"; "grammar"; "config"; "ltac"; "engine"] diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml index eaf938e8ce..645b3665e0 100644 --- a/tools/coqmktop.ml +++ b/tools/coqmktop.ml @@ -75,6 +75,7 @@ let std_includes basedir = let rebase d = match basedir with None -> d | Some base -> base / d in ["-I"; rebase "."; "-I"; rebase "lib"; + "-I"; rebase "vernac"; (* For Mltop *) "-I"; rebase "toplevel"; "-I"; rebase "kernel/byterun"; "-I"; Envars.camlp4lib () ] @ diff --git a/toplevel/assumptions.ml b/toplevel/assumptions.ml deleted file mode 100644 index 8865cd6469..0000000000 --- a/toplevel/assumptions.ml +++ /dev/null @@ -1,320 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* raise Not_found - | (l, SFBmodule mb) :: _ when Label.equal l lab -> mb - | _ :: fields -> search_mod_label lab fields - -let rec search_cst_label lab = function - | [] -> raise Not_found - | (l, SFBconst cb) :: _ when Label.equal l lab -> cb - | _ :: fields -> search_cst_label lab fields - -(* TODO: using [empty_delta_resolver] below is probably slightly incorrect. But: - a) I don't see currently what should be used instead - b) this shouldn't be critical for Print Assumption. At worse some - constants will have a canonical name which is non-canonical, - leading to failures in [Global.lookup_constant], but our own - [lookup_constant] should work. -*) - -let rec fields_of_functor f subs mp0 args = function - |NoFunctor a -> f subs mp0 args a - |MoreFunctor (mbid,_,e) -> - match args with - | [] -> assert false (* we should only encounter applied functors *) - | mpa :: args -> - 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 = - try Global.lookup_module mp - with Not_found -> - (* 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 _ -> 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 - with Not_found -> - let l = fields_of_mp mp in - modcache := MPmap.add mp l !modcache; - l - -and fields_of_mp mp = - let mb = lookup_module_in_impl mp in - let fields,inner_mp,subs = fields_of_mb empty_subst mb [] in - let subs = - if mp_eq inner_mp mp then subs - else add_mp inner_mp mp mb.mod_delta subs - in - Modops.subst_structure subs fields - -and fields_of_mb subs mb args = match mb.mod_expr with - |Algebraic expr -> fields_of_expression subs mb.mod_mp args expr - |Struct sign -> fields_of_signature subs mb.mod_mp args sign - |Abstract|FullStruct -> fields_of_signature subs mb.mod_mp args mb.mod_type - -(** The Abstract case above corresponds to [Declare Module] *) - -and fields_of_signature x = - fields_of_functor - (fun subs mp0 args struc -> - assert (List.is_empty args); - (struc, mp0, subs)) x - -and fields_of_expr subs mp0 args = function - |MEident mp -> - let mb = lookup_module_in_impl (subst_mp subs mp) in - fields_of_mb subs mb args - |MEapply (me1,mp2) -> fields_of_expr subs mp0 (mp2::args) me1 - |MEwith _ -> assert false (* no 'with' in [mod_expr] *) - -and fields_of_expression x = fields_of_functor fields_of_expr x - -let lookup_constant_in_impl cst fallback = - try - let mp,dp,lab = repr_kn (canonical_con cst) in - let fields = memoize_fields_of_mp mp in - (* A module found this way is necessarily closed, in particular - our constant cannot be in an opened section : *) - search_cst_label lab fields - with Not_found -> - (* Either: - - The module part of the constant isn't registered yet : - we're still in it, so the [constant_body] found earlier - (if any) was a true axiom. - - The label has not been found in the structure. This is an error *) - match fallback with - | Some cb -> cb - | None -> anomaly (str "Print Assumption: unknown constant " ++ pr_con cst) - -let lookup_constant cst = - try - let cb = Global.lookup_constant cst in - if Declareops.constant_has_body cb then cb - else lookup_constant_in_impl cst (Some cb) - with Not_found -> lookup_constant_in_impl cst None - -(** Graph traversal of an object, collecting on the way the dependencies of - traversed objects *) - -let label_of = function - | ConstRef kn -> pi3 (repr_con kn) - | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> pi3 (repr_mind kn) - | VarRef id -> Label.of_id id - -let rec traverse current ctx accu t = match kind_of_term t with -| Var id -> - let body () = id |> Global.lookup_named |> NamedDecl.get_value in - traverse_object accu body (VarRef id) -| Const (kn, _) -> - let body () = Global.body_of_constant_body (lookup_constant kn) in - traverse_object accu body (ConstRef kn) -| 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 *) - begin match Constr.(kind oty, kind c) with - | 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 - Context.Rel.add (traverse current) ctx accu t - end -| _ -> Termops.fold_constr_with_full_binders - Context.Rel.add (traverse current) ctx accu t - -and traverse_object ?inhabits (curr, data, ax2ty) body obj = - let data, ax2ty = - let already_in = Refmap_env.mem obj data in - match body () with - | None -> - let data = - 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_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) Context.Rel.empty - (Refset_env.empty,data,ax2ty) body in - Refmap_env.add obj contents data, ax2ty - in - (Refset_env.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_env.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.Rel.empty - (Refset_env.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.Rel.add (Context.Rel.Declaration.LocalAssum (ind_name, ind_type)) accu) - Context.Rel.empty 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.(Rel.fold_outside Context.Rel.add ~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_env.add (IndRef ind) contents data in - Array.fold_left_i (fun k data _ -> - Refmap_env.add (ConstructRef (ind, k+1)) contents data - ) data oib.mind_consnames) data mib.mind_packets - in - data, ax2ty - in - (Refset_env.add obj curr, data, ax2ty) - -(** Collects references in a rel_context. *) -and traverse_context current ctx accu ctxt = - snd (Context.Rel.fold_outside (fun decl (ctx, accu) -> - match decl with - | Context.Rel.Declaration.LocalDef (_,c,t) -> - let accu = traverse current ctx (traverse current ctx accu t) c in - let ctx = Context.Rel.add decl ctx in - ctx, accu - | Context.Rel.Declaration.LocalAssum (_,t) -> - let accu = traverse current ctx accu t in - let ctx = Context.Rel.add decl ctx in - ctx, accu) ctxt ~init:(ctx, accu)) - -let traverse current t = - let () = modcache := MPmap.empty in - traverse current Context.Rel.empty (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 - considering terms out of any valid environment, so use with caution. *) -let type_of_constant cb = match cb.Declarations.const_type with -| Declarations.RegularArity ty -> ty -| Declarations.TemplateArity (ctx, arity) -> - Term.mkArity (ctx, Sorts.sort_of_univ arity.Declarations.template_level) - -let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = - let (idts, knst) = st in - (** Only keep the transitive dependencies *) - let (_, graph, ax2ty) = traverse (label_of gr) t in - let fold obj _ accu = match obj with - | VarRef id -> - let decl = Global.lookup_named id in - if is_local_assum decl then - let t = Context.Named.Declaration.get_type decl in - ContextObjectMap.add (Variable id) t accu - else accu - | ConstRef kn -> - let cb = lookup_constant kn in - let accu = - if cb.const_typing_flags.check_guarded then accu - else - let l = try Refmap_env.find obj ax2ty with Not_found -> [] in - ContextObjectMap.add (Axiom (Guarded kn, l)) Constr.mkProp accu - in - if not (Declareops.constant_has_body cb) || not cb.const_typing_flags.check_universes then - let t = type_of_constant cb in - let l = try Refmap_env.find obj ax2ty with Not_found -> [] in - ContextObjectMap.add (Axiom (Constant 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 - ContextObjectMap.add (Opaque kn) t accu - else if add_transparent then - let t = type_of_constant cb in - ContextObjectMap.add (Transparent kn) t accu - else - accu - | IndRef (m,_) | ConstructRef ((m,_),_) -> - let mind = Global.lookup_mind m in - if mind.mind_typing_flags.check_guarded then - accu - else - let l = try Refmap_env.find obj ax2ty with Not_found -> [] in - ContextObjectMap.add (Axiom (Positive m, l)) Constr.mkProp accu - in - Refmap_env.fold fold graph ContextObjectMap.empty diff --git a/toplevel/assumptions.mli b/toplevel/assumptions.mli deleted file mode 100644 index 0726757839..0000000000 --- a/toplevel/assumptions.mli +++ /dev/null @@ -1,31 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr -> - (Refset_env.t * Refset_env.t 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 - {!traverse} also applies. *) -val assumptions : - ?add_opaque:bool -> ?add_transparent:bool -> transparent_state -> - global_reference -> constr -> Term.types ContextObjectMap.t diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml deleted file mode 100644 index 594f2e9449..0000000000 --- a/toplevel/auto_ind_decl.ml +++ /dev/null @@ -1,969 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [] - | t::q -> t::(kick_last q) - | [] -> failwith "kick_last" -and aux = function - | (0,l') -> l' - | (n,h::t) -> aux (n-1,t) - | _ -> failwith "quick_chop" - in - if n > (List.length l) then failwith "quick_chop args" - else kick_last (aux (n,l) ) - -let deconstruct_type t = - let l,r = decompose_prod t in - (List.rev_map snd l)@[r] - -exception EqNotFound of inductive * inductive -exception EqUnknown of string -exception UndefinedCst of string -exception InductiveWithProduct -exception InductiveWithSort -exception ParameterWithoutEquality of global_reference -exception NonSingletonProp of inductive -exception DecidabilityMutualNotSupported -exception NoDecidabilityCoInductive - -let dl = Loc.ghost - -let constr_of_global g = lazy (Universes.constr_of_global g) - -(* Some pre declaration of constant we are going to use *) -let bb = constr_of_global Coqlib.glob_bool - -let andb_prop = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb_prop - -let andb_true_intro = fun _ -> - (Coqlib.build_bool_type()).Coqlib.andb_true_intro - -let tt = constr_of_global Coqlib.glob_true - -let ff = constr_of_global Coqlib.glob_false - -let eq = constr_of_global Coqlib.glob_eq - -let sumbool = Coqlib.build_coq_sumbool - -let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb - -let induct_on c = induction false None c None None - -let destruct_on c = destruct false None c None None - -let destruct_on_using c id = - destruct false None c - (Some (dl,IntroOrPattern [[dl,IntroNaming IntroAnonymous]; - [dl,IntroNaming (IntroIdentifier id)]])) - None - -let destruct_on_as c l = - destruct false None c (Some (dl,l)) None - -(* reconstruct the inductive with the correct deBruijn indexes *) -let mkFullInd (ind,u) n = - let mib = Global.lookup_mind (fst ind) in - let nparams = mib.mind_nparams in - let nparrec = mib.mind_nparams_rec in - (* params context divided *) - let lnonparrec,lnamesparrec = - context_chop (nparams-nparrec) mib.mind_params_ctxt in - if nparrec > 0 - then mkApp (mkIndU (ind,u), - Array.of_list(Context.Rel.to_extended_list (nparrec+n) lnamesparrec)) - else mkIndU (ind,u) - -let check_bool_is_defined () = - try let _ = Global.type_of_global_unsafe Coqlib.glob_bool in () - with e when CErrors.noncritical e -> raise (UndefinedCst "bool") - -let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") - -let build_beq_scheme mode kn = - check_bool_is_defined (); - (* fetching global env *) - let env = Global.env() in - (* fetching the mutual inductive body *) - let mib = Global.lookup_mind kn in - (* number of inductives in the mutual *) - let nb_ind = Array.length mib.mind_packets in - (* number of params in the type *) - let nparams = mib.mind_nparams in - let nparrec = mib.mind_nparams_rec in - (* params context divided *) - let lnonparrec,lnamesparrec = - context_chop (nparams-nparrec) mib.mind_params_ctxt in - (* predef coq's boolean type *) - (* rec name *) - let rec_name i =(Id.to_string (Array.get mib.mind_packets i).mind_typename)^ - "_eqrec" - in - (* construct the "fun A B ... N, eqA eqB eqC ... N => fixpoint" part *) - let create_input c = - let myArrow u v = mkArrow u (lift 1 v) - and eqName = function - | Name s -> Id.of_string ("eq_"^(Id.to_string s)) - | Anonymous -> Id.of_string "eq_A" - 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 - incr lift_cnt; - myArrow a (myArrow a (Lazy.force bb)) - ) ext_rel_list in - - let eq_input = List.fold_left2 - ( 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 (RelDecl.get_name decl)) b a ) - c (List.rev eqs_typ) lnamesparrec - in - 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 RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") - (RelDecl.get_type decl) a) eq_input lnamesparrec - in - let make_one_eq cur = - let u = Univ.Instance.empty in - let ind = (kn,cur),u (* FIXME *) in - (* current inductive we are working on *) - let cur_packet = mib.mind_packets.(snd (fst ind)) in - (* Inductive toto : [rettyp] := *) - let rettyp = Inductive.type_of_inductive env ((mib,cur_packet),u) in - (* split rettyp in a list without the non rec params and the last -> - e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *) - let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in - (* give a type A, this function tries to find the equality on A declared - previously *) - (* nlist = the number of args (A , B , ... ) - eqA = the deBruijn index of the first eq param - ndx = how much to translate due to the 2nd Case - *) - let compute_A_equality rel_list nlist eqA ndx t = - let lifti = ndx in - 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), Safe_typing.empty_private_constants - | Var x -> - let eid = id_of_string ("eq_"^(string_of_id x)) in - let () = - try ignore (Environ.lookup_named eid env) - with Not_found -> raise (ParameterWithoutEquality (VarRef x)) - in - mkVar eid, 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), Safe_typing.empty_private_constants - else begin - try - let eq, eff = - 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 - Array.of_list eqa, - 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 - if Int.equal (Array.length args) 0 then eq, eff - else mkApp (eq, args), eff - with Not_found -> raise(EqNotFound (ind', fst ind)) - end - | Sort _ -> raise InductiveWithSort - | Prod _ -> raise InductiveWithProduct - | Lambda _-> raise (EqUnknown "abstraction") - | LetIn _ -> raise (EqUnknown "let-in") - | Const kn -> - (match Environ.constant_opt_value_in env kn with - | None -> raise (ParameterWithoutEquality (ConstRef (fst kn))) - | Some c -> aux (applist (c,a))) - | Proj _ -> raise (EqUnknown "projection") - | Construct _ -> raise (EqUnknown "constructor") - | Case _ -> raise (EqUnknown "match") - | CoFix _ -> raise (EqUnknown "cofix") - | Fix _ -> raise (EqUnknown "fix") - | Meta _ -> raise (EqUnknown "meta-variable") - | Evar _ -> raise (EqUnknown "existential variable") - in - aux t - in - (* construct the predicate for the Case part*) - let do_predicate rel_list n = - List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) - (mkLambda (Anonymous, - mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), - (Lazy.force bb))) - (List.rev rettyp_l) in - (* make_one_eq *) - (* do the [| C1 ... => match Y with ... end - ... - 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, - 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 - 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 - let constrsj = constrs (3+nparrec+nb_cstr_args) in - for j=0 to n-1 do - if Int.equal i j then - ar2.(j) <- let cc = (match nb_cstr_args with - | 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 = RelDecl.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) - (nb_cstr_args+ndx+1) - cc - in - eff := Safe_typing.concat_private eff' !eff; - Array.set eqs ndx - (mkApp (eqA, - [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|] - )) - done; - Array.fold_left - (fun a b -> mkApp (andb(),[|b;a|])) - (eqs.(0)) - (Array.sub eqs 1 (nb_cstr_args - 1)) - ) - in - (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) cc - (constrsj.(j).cs_args) - ) - else ar2.(j) <- (List.fold_left (fun a decl -> - mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) (Lazy.force ff) (constrsj.(j).cs_args) ) - done; - - ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) - (mkCase (ci,do_predicate rel_list nb_cstr_args, - mkVar (Id.of_string "Y") ,ar2)) - (constrsi.(i).cs_args)) - done; - mkNamedLambda (Id.of_string "X") (mkFullInd ind (nb_ind-1+1)) ( - mkNamedLambda (Id.of_string "Y") (mkFullInd ind (nb_ind-1+2)) ( - mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))), - !eff - in (* build_beq_scheme *) - 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 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)); - types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) - (mkArrow (mkFullInd ((kn,i),u) 1) (Lazy.force bb)); - let c, eff' = make_one_eq i in - cores.(i) <- c; - 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 - if not (Sorts.List.mem InSet kelim) then - raise (NonSingletonProp (kn,i)); - if mib.mind_finite = Decl_kinds.CoFinite then - raise NoDecidabilityCoInductive; - let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in - create_input fix), - Evd.make_evar_universe_context (Global.env ()) None), - !eff - -let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme - -let _ = beq_scheme_kind_aux := fun () -> beq_scheme_kind - -(* This function tryies to get the [inductive] between a constr - the constr should be Ind i or App(Ind i,[|args|]) -*) -let destruct_ind c = - try let u,v = destApp c in - let indc = destInd u in - indc,v - with DestKO -> let indc = destInd c in - indc,[||] - -(* - In the following, avoid is the list of names to avoid. - If the args of the Inductive type are A1 ... An - then avoid should be - [| lb_An ... lb _A1 (resp. bl_An ... bl_A1) - eq_An .... eq_A1 An ... A1 |] -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 mode lb_scheme_key aavoid narg p q = - let avoid = Array.of_list aavoid in - let do_arg v offset = - try - let x = narg*offset in - let s = destVar v in - let n = Array.length avoid in - let rec find i = - if Id.equal avoid.(n-i) s then avoid.(n-i-x) - else (if i - (* if this happen then the args have to be already declared as a - Parameter*) - ( - let mp,dir,lbl = repr_con (fst (destConst v)) in - mkConst (make_con mp dir (mk_label ( - if Int.equal offset 1 then ("eq_"^(Label.to_string lbl)) - else ((Label.to_string lbl)^"_lb") - ))) - ) - in - 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 = - try - 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 - be improved. *) - let err_msg = - (str "Leibniz->boolean:" ++ - str "You have to declare the" ++ - str "decidability over " ++ - Printer.pr_constr type_of_pq ++ - str " first.") - in - Tacticals.New.tclZEROMSG err_msg - in - lb_type_of_p >>= fun (lb_type_of_p,eff) -> - let lb_args = Array.append (Array.append - (Array.map (fun x -> x) v) - (Array.map (fun x -> do_arg x 1) v)) - (Array.map (fun x -> do_arg x 2) v) - in let app = if Array.equal eq_constr lb_args [||] - then lb_type_of_p else mkApp (lb_type_of_p,lb_args) - in - Tacticals.New.tclTHENLIST [ - Proofview.tclEFFECTS eff; - Equality.replace p q ; apply app ; Auto.default_auto] - end } - -(* used in the bool -> leib side *) -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 - let x = narg*offset in - let s = destVar v in - let n = Array.length avoid in - let rec find i = - if Id.equal avoid.(n-i) s then avoid.(n-i-x) - else (if i - (* if this happen then the args have to be already declared as a - Parameter*) - ( - let mp,dir,lbl = repr_con (fst (destConst v)) in - mkConst (make_con mp dir (mk_label ( - if Int.equal offset 1 then ("eq_"^(Label.to_string lbl)) - else ((Label.to_string lbl)^"_bl") - ))) - ) - in - - let rec aux l1 l2 = - match (l1,l2) with - | (t1::q1,t2::q2) -> - 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 ( - let u,v = try destruct_ind tt1 - (* trick so that the good sequence is returned*) - with e when CErrors.noncritical e -> indu,[||] - in if eq_ind (fst u) ind - then Tacticals.New.tclTHENLIST [Equality.replace t1 t2; Auto.default_auto ; aux q1 q2 ] - else ( - let bl_t1, eff = - try - let c, eff = find_scheme bl_scheme_key (out_punivs u) (*FIXME*) in - mkConst c, eff - with Not_found -> - (* spiwack: the format of this error message should probably - be improved. *) - let err_msg = string_of_ppcmds - (str "boolean->Leibniz:" ++ - str "You have to declare the" ++ - str "decidability over " ++ - Printer.pr_constr tt1 ++ - str " first.") - in - error err_msg - in let bl_args = - Array.append (Array.append - (Array.map (fun x -> x) v) - (Array.map (fun x -> do_arg x 1) v)) - (Array.map (fun x -> do_arg x 2) v ) - in - let app = if Array.equal eq_constr bl_args [||] - then bl_t1 else mkApp (bl_t1,bl_args) - in - Tacticals.New.tclTHENLIST [ - Proofview.tclEFFECTS eff; - Equality.replace_by t1 t2 - (Tacticals.New.tclTHEN (apply app) (Auto.default_auto)) ; - aux q1 q2 ] - ) - ) - end } - | ([],[]) -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclZEROMSG (str "Both side of the equality must have the same arity.") - in - begin try Proofview.tclUNIT (destApp lft) - with DestKO -> Tacticals.New.tclZEROMSG (str "replace failed.") - end >>= fun (ind1,ca1) -> - begin try Proofview.tclUNIT (destApp rgt) - with DestKO -> Tacticals.New.tclZEROMSG (str "replace failed.") - end >>= fun (ind2,ca2) -> - begin try Proofview.tclUNIT (out_punivs (destInd ind1)) - with DestKO -> - begin try Proofview.tclUNIT (fst (fst (destConstruct ind1))) - with DestKO -> Tacticals.New.tclZEROMSG (str "The expected type is an inductive one.") - end - end >>= fun (sp1,i1) -> - begin try Proofview.tclUNIT (out_punivs (destInd ind2)) - with DestKO -> - begin try Proofview.tclUNIT (fst (fst (destConstruct ind2))) - with DestKO -> Tacticals.New.tclZEROMSG (str "The expected type is an inductive one.") - end - end >>= fun (sp2,i2) -> - if not (eq_mind sp1 sp2) || not (Int.equal i1 i2) - then Tacticals.New.tclZEROMSG (str "Eq should be on the same type") - else aux (Array.to_list ca1) (Array.to_list ca2) - -(* - 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 decl -> let s' = - match RelDecl.get_name decl with - Name s -> Id.to_string s - | Anonymous -> "A" in - (Id.of_string s',Id.of_string ("eq_"^s'), - Id.of_string (s'^"_bl"), - Id.of_string (s'^"_lb")) - ::a - ) [] l -(* - build the right eq_I A B.. N eq_A .. eq_N -*) -let eqI ind l = - let list_id = list_id l in - let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@ - (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) - and e, eff = - try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff - with Not_found -> user_err ~hdr:"AutoIndDecl.eqI" - (str "The boolean equality on " ++ pr_mind (fst ind) ++ str " is needed."); - in (if Array.equal eq_constr eA [||] then e else mkApp(e,eA)), eff - -(**********************************************************************) -(* Boolean->Leibniz *) - -open Namegen - -let compute_bl_goal ind lnamesparrec nparrec = - let eqI, eff = eqI ind lnamesparrec in - let list_id = list_id lnamesparrec in - let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in - let create_input c = - let x = next_ident_away (Id.of_string "x") avoid and - y = next_ident_away (Id.of_string "y") avoid in - let bl_typ = List.map (fun (s,seq,_,_) -> - mkNamedProd x (mkVar s) ( - mkNamedProd y (mkVar s) ( - mkArrow - ( mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(mkVar seq,[|mkVar x;mkVar y|]);(Lazy.force tt)|])) - ( mkApp(Lazy.force eq,[|mkVar s;mkVar x;mkVar y|])) - )) - ) list_id in - let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> - mkNamedProd sbl b a - ) c (List.rev list_id) (List.rev bl_typ) in - let eqs_typ = List.map (fun (s,_,_,_) -> - mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,(Lazy.force bb))) - ) list_id in - 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 decl -> mkNamedProd - (match RelDecl.get_name decl with Name s -> s | Anonymous -> next_ident_away (Id.of_string "A") avoid) - (RelDecl.get_type decl) a) eq_input lnamesparrec - in - let n = next_ident_away (Id.of_string "x") avoid and - m = next_ident_away (Id.of_string "y") avoid in - let u = Univ.Instance.empty in - create_input ( - mkNamedProd n (mkFullInd (ind,u) nparrec) ( - mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( - mkArrow - (mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(eqI,[|mkVar n;mkVar m|]);(Lazy.force tt)|])) - (mkApp(Lazy.force eq,[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) - ))), eff - -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 = - ( List.map (fun (s,_,_,_) -> s ) list_id ) @ - ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) @ - ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) - in - let fresh_id s gl = - Tacmach.New.of_old begin fun gsig -> - let fresh = fresh_id (!avoid) s gsig in - avoid := fresh::(!avoid); fresh - end gl - in - 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 - let freshz = fresh_id (Id.of_string "Z") gl in - (* try with *) - Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros; - intro_using freshn ; - induct_on (mkVar freshn); - intro_using freshm; - destruct_on (mkVar freshm); - intro_using freshz; - intros; - Tacticals.New.tclTRY ( - Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) - ); - simpl_in_hyp (freshz,Locus.InHyp); -(* -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 { enter = begin fun gl -> - let fresht = fresh_id (Id.of_string "Z") gl in - destruct_on_as (mkVar freshz) - (IntroOrPattern [[dl,IntroNaming (IntroIdentifier fresht); - dl,IntroNaming (IntroIdentifier freshz)]]) - 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 { enter = begin fun gls -> - let gl = Proofview.Goal.concl gls in - match (kind_of_term gl) with - | App (c,ca) -> ( - match (kind_of_term c) with - | Ind (indeq, u) -> - if eq_gr (IndRef indeq) Coqlib.glob_eq - then - Tacticals.New.tclTHEN - (do_replace_bl mode bl_scheme_key ind - (!avoid) - nparrec (ca.(2)) - (ca.(1))) - Auto.default_auto - else - Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") - | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.") - ) - | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") - end } - - ] - end } - -let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined") - -let side_effect_of_mode = function - | Declare.UserAutomaticRequest -> false - | Declare.InternalTacticRequest -> true - | Declare.UserIndividualRequest -> 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 - user_err - (str "Automatic building of boolean->Leibniz lemmas not supported"); - let ind = (mind,0) in - let nparams = mib.mind_nparams in - let nparrec = mib.mind_nparams_rec in - 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.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) - in - ([|ans|], ctx), eff - -let bl_scheme_kind = declare_mutual_scheme_object "_dec_bl" make_bl_scheme - -let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind - -(**********************************************************************) -(* Leibniz->Boolean *) - -let compute_lb_goal ind lnamesparrec nparrec = - let list_id = list_id lnamesparrec in - let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in - let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in - let eqI, eff = eqI ind lnamesparrec in - let create_input c = - let x = next_ident_away (Id.of_string "x") avoid and - y = next_ident_away (Id.of_string "y") avoid in - let lb_typ = List.map (fun (s,seq,_,_) -> - mkNamedProd x (mkVar s) ( - mkNamedProd y (mkVar s) ( - mkArrow - ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) - ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) - )) - ) list_id in - let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> - mkNamedProd slb b a - ) c (List.rev list_id) (List.rev lb_typ) in - let eqs_typ = List.map (fun (s,_,_,_) -> - mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) - ) list_id in - 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 decl -> mkNamedProd - (match (RelDecl.get_name decl) with Name s -> s | Anonymous -> Id.of_string "A") - (RelDecl.get_type decl) a) eq_input lnamesparrec - in - let n = next_ident_away (Id.of_string "x") avoid and - m = next_ident_away (Id.of_string "y") avoid in - let u = Univ.Instance.empty in - create_input ( - mkNamedProd n (mkFullInd (ind,u) nparrec) ( - mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( - mkArrow - (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar n;mkVar m|])) - (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) - ))), eff - -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 = - ( List.map (fun (s,_,_,_) -> s ) list_id ) @ - ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ - ( List.map (fun (_,_,_,slb) -> slb) list_id ) - in - let fresh_id s gl = - Tacmach.New.of_old begin fun gsig -> - let fresh = fresh_id (!avoid) s gsig in - avoid := fresh::(!avoid); fresh - end gl - in - 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 - let freshz = fresh_id (Id.of_string "Z") gl in - (* try with *) - Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros; - intro_using freshn ; - induct_on (mkVar freshn); - intro_using freshm; - destruct_on (mkVar freshm); - intro_using freshz; - intros; - Tacticals.New.tclTRY ( - Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) - ); - Equality.inj None false None (mkVar freshz,NoBindings); - intros; simpl_in_concl; - Auto.default_auto; - Tacticals.New.tclREPEAT ( - Tacticals.New.tclTHENLIST [apply (andb_true_intro()); - simplest_split ;Auto.default_auto ] - ); - 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 - | App(c,ca) -> (match (kind_of_term ca.(1)) with - | App(c',ca') -> - let n = Array.length ca' in - do_replace_lb mode lb_scheme_key - (!avoid) - nparrec - ca'.(n-2) ca'.(n-1) - | _ -> - Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") - ) - | _ -> - Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") - end } - ] - end } - -let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") - -let make_lb_scheme mode mind = - let mib = Global.lookup_mind mind in - if not (Int.equal (Array.length mib.mind_packets) 1) then - user_err - (str "Automatic building of Leibniz->boolean lemmas not supported"); - let ind = (mind,0) in - let nparams = mib.mind_nparams in - let nparrec = mib.mind_nparams_rec in - let lnonparrec,lnamesparrec = - context_chop (nparams-nparrec) mib.mind_params_ctxt in - let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec 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) - in - ([|ans|], ctx), eff - -let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme - -let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind - -(**********************************************************************) -(* Decidable equality *) - -let check_not_is_defined () = - try ignore (Coqlib.build_coq_not ()) - with e when CErrors.noncritical e -> raise (UndefinedCst "not") - -(* {n=m}+{n<>m} part *) -let compute_dec_goal ind lnamesparrec nparrec = - check_not_is_defined (); - let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in - let list_id = list_id lnamesparrec in - let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in - let create_input c = - let x = next_ident_away (Id.of_string "x") avoid and - y = next_ident_away (Id.of_string "y") avoid in - let lb_typ = List.map (fun (s,seq,_,_) -> - mkNamedProd x (mkVar s) ( - mkNamedProd y (mkVar s) ( - mkArrow - ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) - ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) - )) - ) list_id in - let bl_typ = List.map (fun (s,seq,_,_) -> - mkNamedProd x (mkVar s) ( - mkNamedProd y (mkVar s) ( - mkArrow - ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) - ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) - )) - ) list_id in - - let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> - mkNamedProd slb b a - ) c (List.rev list_id) (List.rev lb_typ) in - let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> - mkNamedProd sbl b a - ) lb_input (List.rev list_id) (List.rev bl_typ) in - - let eqs_typ = List.map (fun (s,_,_,_) -> - mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) - ) list_id in - 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 decl -> mkNamedProd - (match RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") - (RelDecl.get_type decl) a) eq_input lnamesparrec - in - let n = next_ident_away (Id.of_string "x") avoid and - m = next_ident_away (Id.of_string "y") avoid in - let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in - create_input ( - mkNamedProd n (mkFullInd ind (2*nparrec)) ( - mkNamedProd m (mkFullInd ind (2*nparrec+1)) ( - mkApp(sumbool(),[|eqnm;mkApp (Coqlib.build_coq_not(),[|eqnm|])|]) - ) - ) - ) - -let compute_dec_tact ind lnamesparrec nparrec = - let eq = Lazy.force eq and tt = Lazy.force tt - and ff = Lazy.force ff and bb = Lazy.force bb in - let list_id = list_id lnamesparrec in - let eqI, eff = eqI ind lnamesparrec in - let avoid = ref [] in - let eqtrue x = mkApp(eq,[|bb;x;tt|]) in - let eqfalse x = mkApp(eq,[|bb;x;ff|]) in - let first_intros = - ( List.map (fun (s,_,_,_) -> s ) list_id ) @ - ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ - ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @ - ( List.map (fun (_,_,_,slb) -> slb) list_id ) - in - let fresh_id s gl = - Tacmach.New.of_old begin fun gsig -> - let fresh = fresh_id (!avoid) s gsig in - avoid := fresh::(!avoid); fresh - end gl - in - 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 - let freshH = fresh_id (Id.of_string "H") gl in - let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in - let arfresh = Array.of_list fresh_first_intros in - let xargs = Array.sub arfresh 0 (2*nparrec) in - begin try - let c, eff = find_scheme bl_scheme_kind ind in - Proofview.tclUNIT (mkConst c,eff) with - Not_found -> - Tacticals.New.tclZEROMSG (str "Error during the decidability part, boolean to leibniz equality is required.") - end >>= fun (blI,eff') -> - begin try - let c, eff = find_scheme lb_scheme_kind ind in - Proofview.tclUNIT (mkConst c,eff) with - Not_found -> - Tacticals.New.tclZEROMSG (str "Error during the decidability part, leibniz to boolean equality is required.") - end >>= fun (lbI,eff'') -> - 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; - intros_using [freshn;freshm]; - (*we do this so we don't have to prove the same goal twice *) - assert_by (Name freshH) ( - mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) - ) - (Tacticals.New.tclTHEN (destruct_on eqbnm) Auto.default_auto); - - 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 *) - Tacticals.New.tclTHENLIST [ - simplest_left; - apply (mkApp(blI,Array.map(fun x->mkVar x) xargs)); - Auto.default_auto - ] - ; - - (*right *) - Proofview.Goal.nf_enter { enter = begin fun gl -> - let freshH3 = fresh_id (Id.of_string "H") gl in - Tacticals.New.tclTHENLIST [ - simplest_right ; - unfold_constr (Lazy.force Coqlib.coq_not_ref); - intro; - Equality.subst_all (); - assert_by (Name freshH3) - (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|])) - (Tacticals.New.tclTHENLIST [ - apply (mkApp(lbI,Array.map (fun x->mkVar x) xargs)); - Auto.default_auto - ]); - Equality.general_rewrite_bindings_in true - Locus.AllOccurrences true false - (List.hd !avoid) - ((mkVar (List.hd (List.tl !avoid))), - NoBindings - ) - true; - Equality.discr_tac false None - ] - end } - ] - end } - ] - end } - -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; - let ind = (mind,0) in - let nparams = mib.mind_nparams in - let nparrec = mib.mind_nparams_rec in - let u = Univ.Instance.empty 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 - 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 - ([|ans|], ctx), Safe_typing.empty_private_constants - -let eq_dec_scheme_kind = - declare_mutual_scheme_object "_eq_dec" make_eq_decidability - -(* The eq_dec_scheme proofs depend on the equality and discr tactics - but the inj tactics, that comes with discr, depends on the - eq_dec_scheme... *) - -let _ = Equality.set_eq_dec_scheme_kind eq_dec_scheme_kind diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli deleted file mode 100644 index 60232ba8f4..0000000000 --- a/toplevel/auto_ind_decl.mli +++ /dev/null @@ -1,42 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - (Printer.pr_global g ++ str" is already a coercion") - | NotAFunction -> - (Printer.pr_global g ++ str" is not a function") - | NoSource (Some cl) -> - (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of " - ++ Printer.pr_global g) - | NoSource None -> - (str ": cannot find the source class of " ++ Printer.pr_global g) - | ForbiddenSourceClass cl -> - pr_class cl ++ str " cannot be a source class" - | NoTarget -> - (str"Cannot find the target class") - | WrongTarget (clt,cl) -> - (str"Found target class " ++ pr_class cl ++ - str " instead of " ++ pr_class clt) - | NotAClass ref -> - (str "Type of " ++ Printer.pr_global ref ++ - str " does not end with a sort") - -(* Verifications pour l'ajout d'une classe *) - -let check_reference_arity ref = - if not (Reductionops.is_arity (Global.env()) Evd.empty (Global.type_of_global_unsafe ref)) then - raise (CoercionError (NotAClass ref)) - -let check_arity = function - | CL_FUN | CL_SORT -> () - | CL_CONST cst -> check_reference_arity (ConstRef cst) - | CL_PROJ cst -> check_reference_arity (ConstRef cst) - | CL_SECVAR id -> check_reference_arity (VarRef id) - | CL_IND kn -> check_reference_arity (IndRef kn) - -(* Coercions *) - -(* check that the computed target is the provided one *) -let check_target clt = function - | Some cl when not (cl_typ_eq cl clt) -> raise (CoercionError (WrongTarget(clt,cl))) - | _ -> () - -(* condition d'heritage uniforme *) - -let uniform_cond nargs lt = - let rec aux = function - | (0,[]) -> true - | (n,t::l) -> - let t = strip_outer_cast t in - isRel t && Int.equal (destRel t) n && aux ((n-1),l) - | _ -> false - in - aux (nargs,lt) - -let class_of_global = function - | ConstRef sp -> - if Environ.is_projection sp (Global.env ()) - then CL_PROJ sp else CL_CONST sp - | IndRef sp -> CL_IND sp - | VarRef id -> CL_SECVAR id - | ConstructRef _ as c -> - user_err ~hdr:"class_of_global" - (str "Constructors, such as " ++ Printer.pr_global c ++ - str ", cannot be used as a class.") - -(* -lp est la liste (inverse'e) des arguments de la coercion -ids est le nom de la classe source -sps_opt est le sp de la classe source dans le cas des structures -retourne: -la classe source -nbre d'arguments de la classe -le constr de la class -la liste des variables dont depend la classe source -l'indice de la classe source dans la liste lp -*) - -let get_source lp source = - match source with - | None -> - let (cl1,u1,lv1) = - match lp with - | [] -> raise Not_found - | t1::_ -> find_class_type Evd.empty t1 - in - (cl1,u1,lv1,1) - | Some cl -> - let rec aux = function - | [] -> raise Not_found - | t1::lt -> - try - let cl1,u1,lv1 = find_class_type Evd.empty t1 in - if cl_typ_eq cl cl1 then cl1,u1,lv1,(List.length lt+1) - else raise Not_found - with Not_found -> aux lt - in aux (List.rev lp) - -let get_target t ind = - if (ind > 1) then - CL_FUN - else - match pi1 (find_class_type Evd.empty t) with - | CL_CONST p when Environ.is_projection p (Global.env ()) -> - CL_PROJ p - | x -> x - - -let prods_of t = - let rec aux acc d = match kind_of_term d with - | Prod (_,c1,c2) -> aux (c1::acc) c2 - | Cast (c,_,_) -> aux acc c - | _ -> (d,acc) - in - aux [] t - -let strength_of_cl = function - | CL_CONST kn -> `GLOBAL - | CL_SECVAR id -> `LOCAL - | _ -> `GLOBAL - -let strength_of_global = function - | VarRef _ -> `LOCAL - | _ -> `GLOBAL - -let get_strength stre ref cls clt = - let stres = strength_of_cl cls in - let stret = strength_of_cl clt in - let stref = strength_of_global ref in - strength_min [stre;stres;stret;stref] - -let ident_key_of_class = function - | CL_FUN -> "Funclass" - | CL_SORT -> "Sortclass" - | CL_CONST sp | CL_PROJ sp -> Label.to_string (con_label sp) - | CL_IND (sp,_) -> Label.to_string (mind_label sp) - | CL_SECVAR id -> Id.to_string id - -(* Identity coercion *) - -let error_not_transparent source = - user_err ~hdr:"build_id_coercion" - (pr_class source ++ str " must be a transparent constant.") - -let build_id_coercion idf_opt source poly = - let env = Global.env () in - 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 - | None -> error_not_transparent source in - let lams,t = decompose_lam_assum c in - let val_f = - it_mkLambda_or_LetIn - (mkLambda (Name Namegen.default_dependent_ident, - applistc vs (Context.Rel.to_extended_list 0 lams), - mkRel 1)) - lams - in - let typ_f = - it_mkProd_wo_LetIn - (mkProd (Anonymous, applistc vs (Context.Rel.to_extended_list 0 lams), lift 1 t)) - lams - in - (* juste pour verification *) - let _ = - if not - (Reductionops.is_conv_leq env sigma - (Typing.unsafe_type_of env sigma val_f) typ_f) - then - user_err (strbrk - "Cannot be defined as coercion (maybe a bad number of arguments).") - in - let idf = - match idf_opt with - | Some idf -> idf - | None -> - 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:(snd (Evd.universe_context sigma)) - ~inline:true (mkCast (val_f, DEFAULTcast, typ_f))) - in - let decl = (constr_entry, IsDefinition IdentityCoercion) in - let kn = declare_constant idf decl in - ConstRef kn - -let check_source = function -| Some (CL_FUN|CL_SORT as s) -> raise (CoercionError (ForbiddenSourceClass s)) -| _ -> () - -(* -nom de la fonction coercion -strength de f -nom de la classe source (optionnel) -sp de la classe source (dans le cas des structures) -nom de la classe target (optionnel) -booleen "coercion identite'?" - -lorque source est None alors target est None aussi. -*) - -let warn_uniform_inheritance = - CWarnings.create ~name:"uniform-inheritance" ~category:"typechecker" - (fun g -> - Printer.pr_global g ++ - strbrk" does not respect the uniform inheritance condition") - -let add_new_coercion_core coef stre poly source target isid = - check_source source; - let t = Global.type_of_global_unsafe coef in - if coercion_exists coef then raise (CoercionError AlreadyExists); - let tg,lp = prods_of t in - let llp = List.length lp in - if Int.equal llp 0 then raise (CoercionError NotAFunction); - let (cls,us,lvs,ind) = - try - get_source lp source - with Not_found -> - raise (CoercionError (NoSource source)) - in - check_source (Some cls); - if not (uniform_cond (llp-ind) lvs) then - warn_uniform_inheritance coef; - let clt = - try - get_target tg ind - with Not_found -> - raise (CoercionError NoTarget) - in - check_target clt target; - check_arity cls; - check_arity clt; - let local = match get_strength stre coef cls clt with - | `LOCAL -> true - | `GLOBAL -> false - in - declare_coercion coef ~local ~isid ~src:cls ~target:clt ~params:(List.length lvs) - - -let try_add_new_coercion_core ref ~local c d e f = - try add_new_coercion_core ref (loc_of_bool local) c d e f - with CoercionError e -> - user_err ~hdr:"try_add_new_coercion_core" - (explain_coercion_error ref e ++ str ".") - -let try_add_new_coercion ref ~local poly = - try_add_new_coercion_core ref ~local poly None None false - -let try_add_new_coercion_subclass cl ~local poly = - let coe_ref = build_id_coercion None cl poly in - try_add_new_coercion_core coe_ref ~local poly (Some cl) None true - -let try_add_new_coercion_with_target ref ~local poly ~source ~target = - try_add_new_coercion_core ref ~local poly (Some source) (Some target) false - -let try_add_new_identity_coercion id ~local poly ~source ~target = - let ref = build_id_coercion (Some id) source poly in - try_add_new_coercion_core ref ~local poly (Some source) (Some target) true - -let try_add_new_coercion_with_source ref ~local poly ~source = - try_add_new_coercion_core ref ~local poly (Some source) None false - -let add_coercion_hook poly local ref = - let stre = match local with - | Local -> true - | Global -> false - | Discharge -> assert false - in - let () = try_add_new_coercion ref stre poly in - let msg = pr_global_env Id.Set.empty ref ++ str " is now a coercion" in - Flags.if_verbose Feedback.msg_info msg - -let add_coercion_hook poly = Lemmas.mk_hook (add_coercion_hook poly) - -let add_subclass_hook poly local ref = - let stre = match local with - | Local -> true - | Global -> false - | Discharge -> assert false - in - let cl = class_of_global ref in - try_add_new_coercion_subclass cl stre poly - -let add_subclass_hook poly = Lemmas.mk_hook (add_subclass_hook poly) diff --git a/toplevel/class.mli b/toplevel/class.mli deleted file mode 100644 index 5f9ae28f62..0000000000 --- a/toplevel/class.mli +++ /dev/null @@ -1,48 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* local:bool -> - Decl_kinds.polymorphic -> - source:cl_typ -> target:cl_typ -> unit - -(** [try_add_new_coercion ref s] declares [ref], assumed to be of type - [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *) -val try_add_new_coercion : global_reference -> local:bool -> - Decl_kinds.polymorphic -> unit - -(** [try_add_new_coercion_subclass cst s] expects that [cst] denotes a - transparent constant which unfolds to some class [tg]; it declares - an identity coercion from [cst] to [tg], named something like - ["Id_cst_tg"] *) -val try_add_new_coercion_subclass : cl_typ -> local:bool -> - Decl_kinds.polymorphic -> unit - -(** [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion - from [src] to [tg] where the target is inferred from the type of [ref] *) -val try_add_new_coercion_with_source : global_reference -> local:bool -> - Decl_kinds.polymorphic -> source:cl_typ -> unit - -(** [try_add_new_identity_coercion id s src tg] enriches the - environment with a new definition of name [id] declared as an - identity coercion from [src] to [tg] *) -val try_add_new_identity_coercion : Id.t -> local:bool -> - Decl_kinds.polymorphic -> source:cl_typ -> target:cl_typ -> unit - -val add_coercion_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook - -val add_subclass_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook - -val class_of_global : global_reference -> cl_typ diff --git a/toplevel/classes.ml b/toplevel/classes.ml deleted file mode 100644 index 6512f3defa..0000000000 --- a/toplevel/classes.ml +++ /dev/null @@ -1,410 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* !refine_instance); - Goptions.optwrite = (fun b -> refine_instance := b) -} - -let typeclasses_db = "typeclass_instances" - -let set_typeclass_transparency c local b = - Hints.add_hints local [typeclasses_db] - (Hints.HintsTransparencyEntry ([c], b)) - -let _ = - Hook.set Typeclasses.add_instance_hint_hook - (fun inst path local info poly -> - let inst' = match inst with IsConstr c -> Hints.IsConstr (c, Univ.ContextSet.empty) - | IsGlobal gr -> Hints.IsGlobRef gr - in - let info = - let open Vernacexpr in - { info with hint_pattern = - Option.map - (Constrintern.intern_constr_pattern (Global.env())) - info.hint_pattern } in - Flags.silently (fun () -> - Hints.add_hints local [typeclasses_db] - (Hints.HintsResolveEntry - [info, poly, false, Hints.PathHints path, inst'])) ()); - Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency; - Hook.set Typeclasses.classes_transparent_state_hook - (fun () -> Hints.Hint_db.transparent_state (Hints.searchtable_map typeclasses_db)) - -open Vernacexpr - -(** TODO: add subinstances *) -let existing_instance glob g info = - let c = global g in - let info = Option.default Hints.empty_hint_info info in - let instance = Global.type_of_global_unsafe c in - let _, r = decompose_prod_assum instance in - match class_of_constr r with - | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob - (*FIXME*) (Flags.use_polymorphic_flag ()) c) - | None -> user_err ~loc:(loc_of_reference g) - ~hdr:"declare_instance" - (Pp.str "Constant does not build instances of a declared type class.") - -let mismatched_params env n m = mismatched_ctx_inst env Parameters n m -let mismatched_props env n m = mismatched_ctx_inst env Properties n m - -(* Declare everything in the parameters as implicit, and the class instance as well *) - -let type_ctx_instance evars env ctx inst subst = - let rec aux (subst, instctx) l = function - decl :: ctx -> - let t' = substl subst (RelDecl.get_type decl) in - let c', 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 = RelDecl.get_name decl, Some c', t' in - aux (c' :: subst, d :: instctx) l ctx - | [] -> subst - in aux (subst, []) inst (List.rev ctx) - -let id_of_class cl = - match cl.cl_impl with - | ConstRef kn -> let _,_,l = repr_con kn in Label.to_id l - | IndRef (kn,i) -> - let mip = (Environ.lookup_mind kn (Global.env ())).Declarations.mind_packets in - mip.(0).Declarations.mind_typename - | _ -> assert false - -open Pp - -let instance_hook k info global imps ?hook cst = - Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps; - Typeclasses.declare_instance (Some info) (not global) cst; - (match hook with Some h -> h cst | None -> ()) - -let declare_instance_constant k info global imps ?hook id pl poly evm term termtype = - let kind = IsDefinition Instance in - let evm = - let levels = Univ.LSet.union (Universes.universes_of_constr termtype) - (Universes.universes_of_constr term) in - 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: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 info global imps ?hook (ConstRef kn); - id - -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 - 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 - | Decl_kinds.Implicit -> - Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false - (fun avoid (clname, _) -> - match clname with - | Some (cl, b) -> - let t = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in - t, avoid - | None -> failwith ("new instance: under-applied typeclass")) - cl - | Explicit -> cl, Id.Set.empty - in - let tclass = - if generalize then CGeneralization (Loc.ghost, Implicit, Some AbsPi, tclass) - else tclass - in - let k, u, cty, ctx', ctx, len, imps, subst = - let impls, ((env', ctx), imps) = interp_context_evars env evars ctx in - let c', imps' = interp_type_evars_impls ~impls env' evars tclass in - let len = List.length ctx in - let imps = imps @ Impargs.lift_implicits len imps' in - let ctx', c = decompose_prod_assum c' in - let ctx'' = ctx' @ ctx in - 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 decl (args, args') -> - 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 - in - let id = - match instid with - Name id -> - let sp = Lib.make_path id in - if Nametab.exists_cci sp then - user_err ~hdr:"new_instance" (Nameops.pr_id id ++ Pp.str " already exists."); - id - | Anonymous -> - let i = Nameops.add_suffix (id_of_class k) "_instance_0" in - Namegen.next_global_ident_away i (Termops.ids_of_context env) - in - let env' = push_rel_context ctx env in - evars := Evarutil.nf_evar_map !evars; - evars := resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env !evars; - let subst = List.map (Evarutil.nf_evar !evars) subst in - if abstract then - begin - let subst = List.fold_left2 - (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 - let nf, subst = Evarutil.e_nf_evars_and_universes evars in - let termtype = - let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - nf t - in - 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 - (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) - in - Universes.register_universe_binders (ConstRef cst) pl; - instance_hook k pri global imps ?hook (ConstRef cst); id - end - else ( - let props = - match props with - | 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) - | Some (_, t) -> Some (Inr t) - | None -> - if Flags.is_program_mode () then Some (Inl []) - else None - in - let subst = - match props with - | None -> if List.is_empty k.cl_props then Some (Inl subst) else None - | Some (Inr term) -> - let c = interp_casted_constr_evars env' evars term cty in - Some (Inr (c, subst)) - | Some (Inl props) -> - let get_id = - function - | Ident id' -> id' - | Qualid (loc,id') -> (loc, snd (repr_qualid id')) - in - let props, rest = - List.fold_left - (fun (props, rest) decl -> - if is_local_assum decl then - try - let is_id (id', _) = match RelDecl.get_name decl, get_id id' with - | Name id, (_, id') -> Id.equal id id' - | Anonymous, _ -> false - in - let (loc_mid, c) = - List.find is_id rest - in - let rest' = - List.filter (fun v -> not (is_id v)) rest - in - let (loc, mid) = get_id loc_mid in - List.iter (fun (n, _, x) -> - if Name.equal n (Name mid) then - Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x) - k.cl_projs; - c :: props, rest' - with Not_found -> - (CHole (Loc.ghost, None(* Some Evar_kinds.GoalEvar *), Misctypes.IntroAnonymous, None) :: props), rest - else props, rest) - ([], props) k.cl_props - in - match rest with - | (n, _) :: _ -> - unbound_method env' k.cl_impl (get_id n) - | _ -> - Some (Inl (type_ctx_instance evars (push_rel_context ctx' env') - k.cl_props props subst)) - in - let term, termtype = - match subst with - | None -> let termtype = it_mkProd_or_LetIn cty ctx in - None, termtype - | Some (Inl subst) -> - let subst = List.fold_left2 - (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 - let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in - Some term, termtype - | Some (Inr (def, subst)) -> - let termtype = it_mkProd_or_LetIn cty ctx in - let term = Termops.it_mkLambda_or_LetIn def ctx in - Some term, termtype - in - let _ = - evars := Evarutil.nf_evar_map !evars; - evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals_or_obligations ~fail:true - env !evars; - (* Try resolving fields that are typeclasses automatically. *) - evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false - env !evars - in - let _ = evars := Evarutil.nf_evar_map_undefined !evars in - 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. *) - 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 - declare_instance_constant k pri global imps ?hook id pl - poly evm (Option.get term) termtype - 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 _ = - let cst = match gr with ConstRef kn -> kn | _ -> assert false in - Impargs.declare_manual_implicits false gr ~enriching:false [imps]; - Typeclasses.declare_instance (Some pri) (not global) (ConstRef cst) - in - let obls, constr, typ = - match term with - | Some t -> - let obls, _, constr, typ = - Obligations.eterm_obligations env id evm 0 t termtype - in obls, Some constr, typ - | None -> [||], None, termtype - in - let hook = Lemmas.mk_hook hook in - let ctx = Evd.evar_universe_context evm in - ignore (Obligations.add_definition id ?term:constr - ?pl typ ctx ~kind:(Global,poly,Instance) ~hook obls); - id - else - (Flags.silently - (fun () -> - (* spiwack: it is hard to reorder the actions to do - the pretyping after the proof has opened. As a - consequence, we use the low-level primitives to code - the refinement manually.*) - let gls = List.rev (Evd.future_goals evm) in - let evm = Evd.reset_future_goals evm in - Lemmas.start_proof id kind evm termtype - (Lemmas.mk_hook - (fun _ -> instance_hook k pri global imps ?hook)); - (* spiwack: I don't know what to do with the status here. *) - if not (Option.is_empty term) then - let init_refine = - Tacticals.New.tclTHENLIST [ - Refine.refine { run = fun evm -> Sigma (Option.get term, evm, Sigma.refl) }; - Proofview.Unsafe.tclNEWGOALS gls; - Tactics.New.reduce_after_refine; - ] - in - ignore (Pfedit.by init_refine) - else if Flags.is_auto_intros () then - ignore (Pfedit.by (Tacticals.New.tclDO len Tactics.intro)); - (match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) (); - id) - end - else CErrors.error "Unsolved obligations remaining.") - -let named_of_rel_context l = - let acc, ctx = - List.fold_right - (fun decl (subst, ctx) -> - let id = match RelDecl.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 - -let context poly l = - let env = Global.env() 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.Rel.map subst fullctx 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 - with e when CErrors.noncritical e -> - error "Anonymous variables not allowed in contexts." - 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 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) -> - add_instance (Typeclasses.new_instance tc Hints.empty_hint_info false (*FIXME*) - poly (ConstRef cst)); - status - (* declare_subclasses (ConstRef cst) cl *) - | None -> status - else - let test (x, _) = match x with - | ExplByPos (_, Some id') -> Id.equal id id' - | _ -> false - in - let impl = List.exists test impls in - let decl = (Discharge, poly, Definitional) in - let nstatus = - pi3 (Command.declare_assumption false decl (t, !uctx) [] [] impl - Vernacexpr.NoInline (Loc.ghost, id)) - in - let () = uctx := Univ.ContextSet.empty in - status && nstatus - in List.fold_left fn true (List.rev ctx) diff --git a/toplevel/classes.mli b/toplevel/classes.mli deleted file mode 100644 index d2cb788eae..0000000000 --- a/toplevel/classes.mli +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr_expr list -> Context.Rel.t -> 'a - -val mismatched_props : env -> constr_expr list -> Context.Rel.t -> 'a - -(** Instance declaration *) - -val existing_instance : bool -> reference -> Vernacexpr.hint_info_expr option -> unit -(** globality, reference, optional priority and pattern information *) - -val declare_instance_constant : - typeclass -> - Vernacexpr.hint_info_expr -> (** priority *) - bool -> (** globality *) - Impargs.manual_explicitation list -> (** implicits *) - ?hook:(Globnames.global_reference -> unit) -> - Id.t -> (** name *) - Id.t Loc.located list option -> - bool -> (* polymorphic *) - Evd.evar_map -> (* Universes *) - Constr.t -> (** body *) - Term.types -> (** type *) - Names.Id.t - -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 -> - (bool * constr_expr) option -> - ?generalize:bool -> - ?tac:unit Proofview.tactic -> - ?hook:(Globnames.global_reference -> unit) -> - Vernacexpr.hint_info_expr -> - Id.t - -(** Setting opacity *) - -val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit - -(** For generation on names based on classes only *) - -val id_of_class : typeclass -> Id.t - -(** Context command *) - -(** returns [false] if, for lack of section, it declares an assumption - (unless in a module type). *) -val context : Decl_kinds.polymorphic -> local_binder list -> bool diff --git a/toplevel/command.ml b/toplevel/command.ml deleted file mode 100644 index 049f58aa26..0000000000 --- a/toplevel/command.ml +++ /dev/null @@ -1,1357 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - 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 (LocalDef (x,b,t)) env) sigma f (n-1) c) - | _ -> assert false - -let rec complete_conclusion a cs = function - | CProdN (loc,bl,c) -> CProdN (loc,bl,complete_conclusion a cs c) - | CLetIn (loc,b,t,c) -> CLetIn (loc,b,t,complete_conclusion a cs c) - | CHole (loc, k, _, _) -> - let (has_no_args,name,params) = a in - if not has_no_args then - user_err ~loc - (strbrk"Cannot infer the non constant arguments of the conclusion of " - ++ pr_id cs ++ str "."); - let args = List.map (fun id -> CRef(Ident(loc,id),None)) params in - CAppExpl (loc,(None,Ident(loc,name),None),List.rev args) - | c -> c - -(* Commands of the interface *) - -(* 1| Constant definitions *) - -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 - 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 redfun n body,ctx),eff) } - -let warn_implicits_in_term = - CWarnings.create ~name:"implicits-in-term" ~category:"implicits" - (fun () -> - strbrk "Implicit arguments declaration relies on type." ++ spc () ++ - strbrk "The term declares more implicits than the type here.") - -let interp_definition pl bl p red_option c ctypopt = - let env = Global.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,pl,ce = - match ctypopt with - None -> - let subst = evd_comb0 Evd.nf_univ_variables evdref 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 - 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 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 - let subst = evd_comb0 Evd.nf_univ_variables evdref 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 - let body = nf (it_mkLambda_or_LetIn c ctx) in - let typ = nf (it_mkProd_or_LetIn ty ctx) in - let beq b1 b2 = if b1 then b2 else not b2 in - let impl_eq (x,y,z) (x',y',z') = beq x x' && beq y y' && beq z z' in - (* Check that all implicit arguments inferable from the term - are inferable from the type *) - let chk (key,va) = - impl_eq (List.assoc_f Pervasives.(=) key impsty) va (* FIXME *) - in - if not (try List.for_all chk imps2 with Not_found -> false) - then warn_implicits_in_term (); - 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 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 (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); - ce - -let warn_local_declaration = - CWarnings.create ~name:"local-declaration" ~category:"scope" - (fun (id,kind) -> - pr_id id ++ strbrk " is declared as a local " ++ str kind) - -let get_locality id ~kind = function -| Discharge -> - (** If a Let is defined outside a section, then we consider it as a local definition *) - warn_local_declaration (id,kind); - true -| Local -> true -| Global -> false - -let declare_global_definition ident ce local k pl imps = - let local = get_locality ident ~kind:"definition" 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 - -let declare_definition_hook = ref ignore -let set_declare_definition_hook = (:=) declare_definition_hook -let get_declare_definition_hook () = !declare_definition_hook - -let warn_definition_not_visible = - CWarnings.create ~name:"definition-not-visible" ~category:"implicits" - (fun ident -> - strbrk "Section definition " ++ - pr_id ident ++ strbrk " is not visible from current goals") - -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 () -> - let c = SectionLocalDef ce in - let _ = declare_variable ident (Lib.cwd(), c, IsDefinition k) in - let () = definition_message ident in - let gr = VarRef ident in - let () = maybe_declare_manual_implicits false gr imps in - let () = if Pfedit.refining () then - warn_definition_not_visible ident - in - gr - | Discharge | Local | Global -> - declare_global_definition ident ce local k pl imps in - 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) - -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 - if Flags.is_program_mode () then - let env = Global.env () in - let (c,ctx), sideff = Future.force ce.const_entry_body in - assert(Safe_typing.empty_private_constants = sideff); - assert(Univ.ContextSet.is_empty ctx); - let typ = match ce.const_entry_type with - | Some t -> t - | None -> Retyping.get_type_of env evd c - in - Obligations.check_evars env evd; - let obls, _, c, cty = - 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 ?pl ~implicits:imps ~kind:k ~hook obls) - else let ce = check_definition def in - 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) 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 - let () = assumption_message ident in - let () = - if is_verbose () && Pfedit.refining () then - Feedback.msg_info (str"Variable" ++ spc () ++ pr_id ident ++ - strbrk " is not visible from current goals") - in - let r = VarRef ident in - let () = Typeclasses.declare_instance None true r in - let () = if is_coe then Class.try_add_new_coercion r ~local:true false in - (r,Univ.Instance.empty,true) - -| Global | Local | Discharge -> - let local = get_locality ident ~kind:"axiom" local in - let inl = match nl with - | NoInline -> None - | DefaultInline -> Some (Flags.get_inline_level()) - | InlineAt i -> Some i - in - let ctx = Univ.ContextSet.to_context ctx in - let decl = (ParameterEntry (None,p,(c,ctx),inl), IsAssumption kind) in - 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 - let inst = - if p (* polymorphic *) then Univ.UContext.instance ctx - else Univ.Instance.empty - in - (gr,inst,Lib.is_modtype_strict ()) - -let interp_assumption evdref env impls bl c = - let c = prod_constr_expr c bl in - interp_type_evars_impls env evdref ~impls c - -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) pl 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_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 = - if poly then - (* Separate declarations so that A B : Type puts A and B in different levels. *) - List.fold_right (fun (is_coe,(idl,c)) acc -> - List.fold_right (fun id acc -> - (is_coe, ([id], c)) :: acc) idl acc) - l [] - else l - in - (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) - let _,l = List.fold_map (fun (env,ienv) (is_coe,(idl,c)) -> - let t,imps = interp_assumption evdref env ienv [] c in - let env = - 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 - ((env,ienv),((is_coe,idl),t,imps))) - (env,empty_internalization_env) l - in - let evd = solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref) in - (* The universe constraints come from the whole telescope. *) - let evd = Evd.nf_constraints evd in - let ctx = Evd.universe_context_set evd in - let l = List.map (on_pi2 (nf_evar evd)) l in - pi2 (List.fold_left (fun (subst,status,ctx) ((is_coe,idl),t,imps) -> - let t = replace_vars subst t 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 - in - (subst'@subst, status' && status, - (* The universe constraints are declared with the first declaration only. *) - Univ.ContextSet.empty)) ([],true,ctx) 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 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) pl 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 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 one at a time." in - user_err ~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 *) - -let push_types env idl tl = - List.fold_left2 (fun env id t -> Environ.push_rel (LocalAssum (Name id,t)) env) - 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 -} - -type structured_inductive_expr = - local_binder list * structured_one_inductive_expr list - -let minductive_message warn = function - | [] -> error "No inductive definition." - | [x] -> (pr_id x ++ str " is defined" ++ - if warn then str " as a non-primitive record" else mt()) - | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++ - spc () ++ str "are defined") - -let check_all_names_different indl = - let ind_names = List.map (fun ind -> ind.ind_name) indl in - let cstr_names = List.map_append (fun ind -> List.map fst ind.ind_lc) indl in - let l = List.duplicates Id.equal ind_names in - let () = match l with - | [] -> () - | t :: _ -> raise (InductiveError (SameNamesTypes t)) - in - let l = List.duplicates Id.equal cstr_names in - let () = match l with - | [] -> () - | c :: _ -> raise (InductiveError (SameNamesConstructors (List.hd l))) - in - let l = List.intersect Id.equal ind_names cstr_names in - match l with - | [] -> () - | _ -> raise (InductiveError (SameNamesOverlap l)) - -let mk_mltype_data evdref env assums arity indname = - let is_ml_type = is_sort env !evdref arity in - (is_ml_type,indname,assums) - -let prepare_param = function - | 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. - This is really a hack to stay compatible with the semantics of template polymorphic - inductives which are recognized when a "Type" appears at the end of the conlusion in - the source syntax. *) - -let rec check_anonymous_type ind = - let open Glob_term in - match ind with - | GSort (_, GType []) -> true - | GProd (_, _, _, _, e) - | GLetIn (_, _, _, e) - | GLambda (_, _, _, _, e) - | GApp (_, e, _) - | GCast (_, e, _) -> check_anonymous_type e - | _ -> false - -let make_conclusion_flexible evdref ty poly = - if poly && isArity ty then - let _, concl = destArity ty in - match concl with - | Type u -> - (match Univ.universe_level u with - | Some u -> - evdref := Evd.make_flexible_variable !evdref true u - | None -> ()) - | _ -> () - else () - -let is_impredicative env u = - u = Prop Null || (is_impredicative_set env && u = Prop Pos) - -let interp_ind_arity env evdref ind = - let c = intern_gen IsType env ind.ind_arity in - let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in - let t, impls = understand_tcc_evars env evdref ~expected_type:IsType c, imps in - let pseudo_poly = check_anonymous_type c in - let () = if not (Reduction.is_arity env t) then - user_err ~loc:(constr_loc ind.ind_arity) (str "Not an arity") - in - t, pseudo_poly, impls - -let interp_cstrs evdref env impls mldata arity ind = - let cnames,ctyps = List.split ind.ind_lc in - (* Complete conclusions of constructor types if given in ML-style syntax *) - let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in - (* Interpret the constructor types *) - let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls evdref env ~impls) ctyps') in - (cnames, ctyps'', cimpls) - -let sign_level env evd sign = - fst (List.fold_right - (fun d (lev,env) -> - match d with - | LocalDef _ -> lev, push_rel d env - | LocalAssum _ -> - let s = destSort (Reduction.whd_all env - (nf_evar evd (Retyping.get_type_of env evd (RelDecl.get_type d)))) - in - let u = univ_of_sort s in - (Univ.sup u lev, push_rel d env)) - sign (Univ.type0m_univ,env)) - -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 (LocalAssum (Anonymous, concl) :: ctx)) tys - in sup_list min sorts - -let is_flexible_sort evd u = - match Univ.Universe.level u with - | Some l -> Evd.is_flexible_level evd l - | None -> false - -let inductive_levels env evdref poly arities inds = - let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in - let levels = List.map (fun (x,(ctx,a)) -> - if a = Prop Null then None - else Some (univ_of_sort a)) destarities - in - let cstrs_levels, min_levels, sizes = - CList.split3 - (List.map2 (fun (_,tys,_) (arity,(ctx,du)) -> - let len = List.length tys in - let minlev = Sorts.univ_of_sort du in - let minlev = - if len > 1 && not (is_impredicative env du) then - Univ.sup minlev Univ.type0_univ - else minlev - in - let minlev = - (** Indices contribute. *) - if Indtypes.is_indices_matter () && List.length ctx > 0 then ( - let ilev = sign_level env !evdref ctx in - Univ.sup ilev minlev) - else minlev - in - let clev = extract_level env !evdref minlev tys in - (clev, minlev, len)) inds destarities) - in - (* Take the transitive closure of the system of constructors *) - (* level constraints and remove the recursive dependencies *) - let levels' = Universes.solve_constraints_system (Array.of_list levels) - (Array.of_list cstrs_levels) (Array.of_list min_levels) - in - let evd, arities = - CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> - if is_impredicative env du then - (** Any product is allowed here. *) - evd, arity :: arities - else (** If in a predicative sort, or asked to infer the type, - we take the max of: - - indices (if in indices-matter mode) - - constructors - - Type(1) if there is more than 1 constructor - *) - (** Constructors contribute. *) - let evd = - if Sorts.is_set du then - if not (Evd.check_leq evd cu Univ.type0_univ) then - raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType) - else evd - else evd - (* Evd.set_leq_sort env evd (Type cu) du *) - in - let evd = - if len >= 2 && Univ.is_type0m_univ cu then - (** "Polymorphic" type constraint and more than one constructor, - should not land in Prop. Add constraint only if it would - land in Prop directly (no informative arguments as well). *) - Evd.set_leq_sort env evd (Prop Pos) du - else evd - in - let duu = Sorts.univ_of_sort du in - let evd = - if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then - if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ 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)) - (!evdref,[]) (Array.to_list levels') destarities sizes - in evdref := evd; List.rev arities - -let check_named (loc, na) = match na with -| Name _ -> () -| Anonymous -> - let msg = str "Parameters must be named." in - user_err ~loc msg - - -let check_param = function -| LocalRawDef (na, _) -> check_named na -| LocalRawAssum (nas, Default _, _) -> List.iter check_named nas -| LocalRawAssum (nas, Generalized _, _) -> () -| LocalPattern _ -> assert false - -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 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 - - (* Names of parameters as arguments of the inductive type (defs removed) *) - let assums = List.filter is_local_assum ctx_params in - let params = List.map (RelDecl.get_name %> out_name) assums in - - (* Interpret the arities *) - let arities = List.map (interp_ind_arity env_params evdref) indl in - - let fullarities = List.map (fun (c, _, _) -> it_mkProd_or_LetIn c ctx_params) arities in - let env_ar = push_types env0 indnames fullarities in - let env_ar_params = push_rel_context ctx_params env_ar in - - (* Compute interpretation metadatas *) - let indimpls = List.map (fun (_, _, impls) -> userimpls @ - 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 - - let constructors = - Metasyntax.with_syntax_protection (fun () -> - (* Temporary declaration of notations and scopes *) - List.iter (Metasyntax.set_notation_for_interpretation impls) notations; - (* Interpret the constructor types *) - List.map3 (interp_cstrs env_ar_params evdref impls) mldatas arities indl) - () in - - (* Try further to solve evars, and instantiate them *) - let sigma = solve_remaining_evars all_and_fail_flags env_params !evdref (Evd.empty,!evdref) in - evdref := sigma; - (* Compute renewed arities *) - let nf,_ = e_nf_evars_and_universes evdref 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 _ = List.iter2 (fun ty poly -> make_conclusion_flexible evdref ty poly) arities aritypoly in - let arities = inductive_levels env_ar_params evdref poly arities constructors in - let nf',_ = e_nf_evars_and_universes evdref in - 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 = 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; - 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; - - (* Build the inductive entries *) - let entries = List.map4 (fun ind arity template (cnames,ctypes,cimpls) -> { - mind_entry_typename = ind.ind_name; - mind_entry_arity = arity; - mind_entry_template = template; - mind_entry_consnames = cnames; - mind_entry_lc = ctypes - }) indl arities aritypoly constructors in - let impls = - 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 - in - (* Build the mutual inductive entry *) - { mind_entry_params = List.map prepare_param ctx_params; - mind_entry_record = None; - mind_entry_finite = finite; - mind_entry_inds = entries; - mind_entry_polymorphic = poly; - mind_entry_private = if prv then Some false else None; - mind_entry_universes = uctx; - }, - pl, impls - -(* Very syntactical equality *) -let eq_local_binders bl1 bl2 = - List.equal local_binder_eq bl1 bl2 - -let extract_coercions indl = - let mkqid (_,((_,id),_)) = qualid_of_ident id in - let extract lc = List.filter (fun (iscoe,_) -> iscoe) lc in - List.map mkqid (List.flatten(List.map (fun (_,_,_,lc) -> extract lc) indl)) - -let extract_params indl = - let paramsl = List.map (fun (_,params,_,_) -> params) indl in - match paramsl with - | [] -> anomaly (Pp.str "empty list of inductive types") - | params::paramsl -> - if not (List.for_all (eq_local_binders params) paramsl) then error - "Parameters should be syntactically the same for each inductive type."; - params - -let extract_inductive indl = - 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 - -let extract_mutual_inductive_declaration_components indl = - let indl,ntnl = List.split indl in - let params = extract_params indl in - let coes = extract_coercions indl in - let indl = extract_inductive indl in - (params,indl), coes, List.flatten ntnl - -let is_recursive mie = - let rec is_recursive_constructor lift typ = - match Term.kind_of_term typ with - | Prod (_,arg,rest) -> - Termops.dependent (mkRel lift) arg || - is_recursive_constructor (lift+1) rest - | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest - | _ -> false - in - match mie.mind_entry_inds with - | [ind] -> - let nparams = List.length mie.mind_entry_params in - List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc - | _ -> false - -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 - | BiFinite when is_recursive mie -> - if Option.has_some mie.mind_entry_record then - error "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command." - else - error ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.") - | _ -> () - end; - let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in - 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 - 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 Feedback.msg_info (minductive_message warn_prim names); - if mie.mind_entry_private == None - then declare_default_schemes mind; - mind - -type one_inductive_impls = - Impargs.manual_explicitation list (* for inds *)* - Impargs.manual_explicitation list list (* for constrs *) - -let do_mutual_inductive indl poly prv finite = - let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in - (* Interpret the types *) - 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 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; - (* If positivity is assumed declares itself as unsafe. *) - if Environ.deactivated_guard (Global.env ()) then Feedback.feedback Feedback.AddedAxiom else () - -(* 3c| Fixpoints and co-fixpoints *) - -(* An (unoptimized) function that maps preorders to partial orders... - - Input: a list of associations (x,[y1;...;yn]), all yi distincts - and different of x, meaning x<=y1, ..., x<=yn - - Output: a list of associations (x,Inr [y1;...;yn]), collecting all - distincts yi greater than x, _or_, (x, Inl y) meaning that - x is in the same class as y (in which case, x occurs - nowhere else in the association map) - - partial_order : ('a * 'a list) list -> ('a * ('a,'a list) union) list -*) - -let rec partial_order cmp = function - | [] -> [] - | (x,xge)::rest -> - let rec browse res xge' = function - | [] -> - let res = List.map (function - | (z, Inr zge) when List.mem_f cmp x zge -> - (z, Inr (List.union cmp zge xge')) - | r -> r) res in - (x,Inr xge')::res - | y::xge -> - let rec link y = - try match List.assoc_f cmp y res with - | Inl z -> link z - | Inr yge -> - if List.mem_f cmp x yge then - let res = List.remove_assoc_f cmp y res in - let res = List.map (function - | (z, Inl t) -> - if cmp t y then (z, Inl x) else (z, Inl t) - | (z, Inr zge) -> - if List.mem_f cmp y zge then - (z, Inr (List.add_set cmp x (List.remove cmp y zge))) - else - (z, Inr zge)) res in - browse ((y,Inl x)::res) xge' (List.union cmp xge (List.remove cmp x yge)) - else - browse res (List.add_set cmp y (List.union cmp xge' yge)) xge - with Not_found -> browse res (List.add_set cmp y xge') xge - in link y - in browse (partial_order cmp rest) [] xge - -let non_full_mutual_message x xge y yge isfix rest = - let reason = - if Id.List.mem x yge then - pr_id y ++ str " depends on " ++ pr_id x ++ strbrk " but not conversely" - else if Id.List.mem y xge then - pr_id x ++ str " depends on " ++ pr_id y ++ strbrk " but not conversely" - else - pr_id y ++ str " and " ++ pr_id x ++ strbrk " are not mutually dependent" in - let e = if List.is_empty rest then reason else strbrk "e.g., " ++ reason in - let k = if isfix then "fixpoint" else "cofixpoint" in - let w = - if isfix - then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl() - else mt () in - strbrk "Not a fully mutually defined " ++ str k ++ fnl () ++ - str "(" ++ e ++ str ")." ++ fnl () ++ w - -let warn_non_full_mutual = - CWarnings.create ~name:"non-full-mutual" ~category:"fixpoints" - (fun (x,xge,y,yge,isfix,rest) -> - non_full_mutual_message x xge y yge isfix rest) - -let check_mutuality env isfix fixl = - let names = List.map fst fixl in - let preorder = - List.map (fun (id,def) -> - (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env id' def) names)) - fixl in - let po = partial_order Id.equal preorder in - match List.filter (function (_,Inr _) -> true | _ -> false) po with - | (x,Inr xge)::(y,Inr yge)::rest -> - warn_non_full_mutual (x,xge,y,yge,isfix,rest) - | _ -> () - -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; - fix_type : constr_expr -} - -let interp_fix_context env evdref isfix fix = - let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in - let impl_env, ((env', ctx), imps) = interp_context_evars env evdref before in - let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env ~shift:(List.length before) env' evdref after in - let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in - ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) - -let interp_fix_ccl evdref impls (env,_) fix = - interp_type_evars_impls ~impls env evdref fix.fix_type - -let interp_fix_body env_rec evdref impls (_,ctx) fix ccl = - Option.map (fun body -> - let env = push_rel_context ctx env_rec in - let body = interp_casted_constr_evars env evdref ~impls body ccl in - it_mkLambda_or_LetIn body ctx) fix.fix_body - -let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx - -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 pl imps (Lemmas.mk_hook (fun _ r -> r)) - -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 - let names = List.map (fun id -> Name id) fixnames in - (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) - -(* Jump over let-bindings. *) - -let compute_possible_guardness_evidences (ids,_,na) = - match na with - | Some i -> [i] - | None -> - (* If recursive argument was not given by user, we try all args. - An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem to worth the effort (except for huge mutual - fixpoints ?) *) - List.interval 0 (List.length ids - 1) - -type recursive_preentry = - Id.t list * constr option list * types list - -(* Wellfounded definition *) - -open Coqlib - -let contrib_name = "Program" -let subtac_dir = [contrib_name] -let fixsub_module = subtac_dir @ ["Wf"] -let tactics_module = subtac_dir @ ["Tactics"] - -let init_reference dir s () = Coqlib.gen_reference "Command" dir s -let init_constant dir s () = Coqlib.gen_constant "Command" dir s -let make_ref l s = init_reference l s -let fix_proto = init_constant tactics_module "fix_proto" -let fix_sub_ref = make_ref fixsub_module "Fix_sub" -let measure_on_R_ref = make_ref fixsub_module "MR" -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.from_fun build_sigma_type - -let make_qref s = Qualid (Loc.ghost, qualid_of_string s) -let lt_ref = make_qref "Init.Peano.lt" - -let rec telescope = function - | [] -> assert false - | [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)) decl -> - let t = RelDecl.get_type decl in - let pred = mkLambda (RelDecl.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 - let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in - (sigty, pred :: tys, (succ k, intro))) - (t, [], (2, mkRel 1)) tl - in - let (last, subst) = List.fold_right2 - (fun pred decl (prev, subst) -> - let t = RelDecl.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, LocalDef (get_name decl, proj1, t) :: subst)) - (List.rev tys) tl (mkRel 1, []) - in ty, (LocalDef (n, last, t) :: subst), constr - - | 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 (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"]; - let env = Global.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 - let top_arity = interp_type_evars top_env evdref arityc in - 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 = 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 - let relty = Typing.unsafe_type_of env !evdref rel in - let relargty = - let error () = - user_err ~loc:(constr_loc r) - ~hdr:"Command.build_wellfounded" - (Printer.pr_constr_env env !evdref rel ++ str " is not an homogeneous binary relation.") - in - try - let ctx, ar = Reductionops.splay_prod_n env !evdref 2 relty in - match ctx, kind_of_term ar with - | [LocalAssum (_,t); LocalAssum (_,u)], Sort (Prop Null) - when Reductionops.is_conv env !evdref t u -> t - | _, _ -> error () - with e when CErrors.noncritical e -> error () - in - let measure = interp_casted_constr_evars binders_env evdref measure relargty in - let wf_rel, wf_rel_fun, measure_fn = - let measure_body, measure = - it_mkLambda_or_LetIn measure letbinders, - it_mkLambda_or_LetIn measure binders - in - let comb = Universes.constr_of_global (delayed_force measure_on_R_ref) in - let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in - let wf_rel_fun x y = - mkApp (rel, [| subst1 x measure_body; - subst1 y measure_body |]) - in wf_rel, wf_rel_fun, measure - 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 = 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 - let proj = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.proj1 in - let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in - let projection = (* in wfarg :: arg :: before *) - mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) - in - let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in - let intern_arity = substl [projection] top_arity_let in - (* 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 = 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 = 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 - 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 = 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 - in - let newimpls = Id.Map.singleton recname - (r, l, impls @ [(Some (Id.of_string "recproof", Impargs.Manual, (true, false)))], - scopes @ [None]) in - interp_casted_constr_evars (push_rel_context ctx env) evdref - ~impls:newimpls body (lift 1 top_arity) - in - let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in - let prop = mkLambda (Name argname, argtyp, top_arity_let) in - let def = - mkApp (Universes.constr_of_global (delayed_force fix_sub_ref), - [| argtyp ; wf_rel ; - Evarutil.e_new_evar env evdref - ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof; - prop |]) - 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 - let binders = nf_evar_context !evdref binders in - let top_arity = Evarutil.nf_evar !evdref top_arity in - let hook, recname, typ = - if List.length binders_rel > 1 then - let name = add_suffix recname "_func" in - 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 ?names:pl !evdref in - (*FIXME poly? *) - 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 - if Impargs.is_implicit_args () || not (List.is_empty impls) then - Impargs.declare_manual_implicits false gr [impls] - in - let typ = it_mkProd_or_LetIn top_arity binders in - hook, name, typ - else - let typ = it_mkProd_or_LetIn top_arity binders_rel in - 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 - in - let hook = Lemmas.mk_hook hook in - let fullcoqc = Evarutil.nf_evar !evdref def in - let fullctyp = Evarutil.nf_evar !evdref typ in - Obligations.check_evars env !evdref; - let evars, _, evars_def, evars_typ = - 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 ?pl - 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 - - (* Interp arities allowing for unresolved types *) - 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 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 - let fixccls,fixcclimps = List.split (List.map3 (interp_fix_ccl evdref) fixctximpenvs fixctxs fixl) in - let fixtypes = List.map2 build_fix_type fixctxs fixccls in - let fixtypes = List.map (nf_evar !evdref) fixtypes in - let fiximps = List.map3 - (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (List.length ctx) cclimps)) - fixctximps fixcclimps fixctxs in - let rec_sign = - List.fold_left2 - (fun env' id t -> - if Flags.is_program_mode () then - let sort = Evarutil.evd_comb1 (Typing.type_of ~refresh:true env) evdref t in - let fixprot = - try - let app = mkApp (delayed_force fix_proto, [|sort; t|]) in - Typing.e_solve_evars env evdref app - with e when CErrors.noncritical e -> t - in - LocalAssum (id,fixprot) :: env' - else LocalAssum (id,t) :: env') - [] fixnames fixtypes - in - let env_rec = push_named_context rec_sign env in - - (* Get interpretation metadatas *) - let impls = compute_internalization_env env Recursive fixnames fixtypes fiximps in - - (* Interp bodies with rollback because temp use of notations/implicit *) - let fixdefs = - Metasyntax.with_syntax_protection (fun () -> - List.iter (Metasyntax.set_notation_for_interpretation impls) notations; - List.map4 - (fun fixctximpenv -> interp_fix_body env_rec evdref (Id.Map.fold Id.Map.add fixctximpenv impls)) - fixctximpenvs fixctxs fixl fixccls) - () in - - (* Instantiate evars and check all are resolved *) - let evd = solve_unif_constraints_with_heuristics env_rec !evdref in - 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 RelDecl.get_name ctx) fixctxs in - - (* Build the fix declaration block *) - (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); - if List.for_all Option.has_some fixdefs then begin - let fixdefs = List.map Option.get fixdefs in - check_mutuality env isfix (List.combine fixnames fixdefs) - end - -let interp_fixpoint l ntns = - let (env,_,pl,evd),fix,info = interp_recursive true l ntns in - check_recursive true env evd fix; - (fix,pl,Evd.evar_universe_context evd,info) - -let interp_cofixpoint l ntns = - let (env,_,pl,evd),fix,info = interp_recursive false l ntns in - check_recursive false env evd fix; - (fix,pl,Evd.evar_universe_context evd,info) - -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 = - 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 - let init_tac = - Option.map (List.map Proofview.V82.tactic) init_tac - 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 - (* We shortcut the proof process *) - let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in - let env = Global.env() in - let indexes = search_guard Loc.ghost env indexes fixdecls in - let fiximps = List.map (fun (n,r,p) -> r) fiximps in - 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 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 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; - end; - (* Declare notations *) - List.iter Metasyntax.add_notation_interpretation 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 = - 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 - let init_tac = - Option.map (List.map Proofview.V82.tactic) init_tac - in - 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 *) - 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 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 - 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 - end; - (* Declare notations *) - List.iter Metasyntax.add_notation_interpretation ntns - -let extract_decreasing_argument limit = function - | (na,CStructRec) -> na - | (na,_) when not limit -> na - | _ -> error - "Only structural decreasing is supported for a non-Program Fixpoint" - -let extract_fixpoint_components limit l = - let fixl, ntnl = List.split l in - 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_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),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 - | Some def -> def - | None -> error "Program Fixpoint needs defined bodies." - -let collect_evars_of_term evd c ty = - let evars = Evar.Set.union (Evd.evars_of_term c) (Evd.evars_of_term ty) in - Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) - evars (Evd.from_ctx (Evd.evar_universe_context evd)) - -let do_program_recursive local p fixkind fixl ntns = - let isfix = fixkind != Obligations.IsCoFixpoint in - let (env, rec_sign, pl, evd), fix, info = - interp_recursive isfix fixl ntns - in - (* Program-specific code *) - (* Get the interesting evars, those that were not instanciated *) - let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in - (* Solve remaining evars *) - let evd = nf_evar_map_undefined evd in - let collect_evars id def typ imps = - (* Generalize by the recursive prototypes *) - let def = - nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) - and typ = - nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) - in - let evm = collect_evars_of_term evd def typ in - let evars, _, def, typ = - Obligations.eterm_obligations env id evm - (List.length rec_sign) def typ - in (id, def, typ, imps, evars) - in - let (fixnames,fixdefs,fixtypes) = fix in - let fiximps = List.map pi2 info in - let fixdefs = List.map out_def fixdefs in - let defs = List.map4 collect_evars fixnames fixdefs fixtypes fiximps in - let () = if isfix then begin - let possible_indexes = List.map compute_possible_guardness_evidences info in - let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), - Array.of_list fixtypes, - Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) - in - let indexes = - Pretyping.search_guard - Loc.ghost (Global.env ()) possible_indexes fixdecls in - List.iteri (fun i _ -> - Inductive.check_fix env - ((indexes,i),fixdecls)) - fixl - end in - let ctx = Evd.evar_universe_context evd in - let kind = match fixkind with - | Obligations.IsFixpoint _ -> (local, p, Fixpoint) - | Obligations.IsCoFixpoint -> (local, p, CoFixpoint) - in - 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),pl),_,bl,typ,def),ntn)] -> - let recarg = - match n with - | Some n -> mkIdentC (snd n) - | None -> - user_err ~hdr:"do_program_fixpoint" - (str "Recursive argument required for well-founded fixpoints") - in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn - - | [(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 -> - let fixl,ntns = extract_fixpoint_components true l in - let fixkind = Obligations.IsFixpoint g in - do_program_recursive local poly fixkind fixl ntns - - | _, _ -> - user_err ~hdr:"do_program_fixpoint" - (str "Well-founded fixpoints not allowed in mutually recursive blocks") - -let check_safe () = - let open Declarations in - let flags = Environ.typing_flags (Global.env ()) in - flags.check_universes && flags.check_guarded - -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 (_, _, _, info as fix) = interp_fixpoint fixl ntns in - let possible_indexes = - List.map compute_possible_guardness_evidences info in - declare_fixpoint local poly fix possible_indexes ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () - -let do_cofixpoint local poly l = - let fixl,ntns = extract_cofixpoint_components l in - if Flags.is_program_mode () then - do_program_recursive local poly Obligations.IsCoFixpoint fixl ntns - else - let cofix = interp_cofixpoint fixl ntns in - declare_cofixpoint local poly cofix ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/toplevel/command.mli b/toplevel/command.mli deleted file mode 100644 index 616afb91f0..0000000000 --- a/toplevel/command.mli +++ /dev/null @@ -1,176 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Id.t Loc.located list -> unit -val do_constraint : polymorphic -> - (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> unit - -(** {6 Hooks for Pcoq} *) - -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 -> 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 -> 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 -> - local_binder list -> red_expr option -> constr_expr -> - constr_expr option -> unit Lemmas.declaration_hook -> unit - -(** {6 Parameters/Assumptions} *) - -(* val interp_assumption : env -> evar_map ref -> *) -(* local_binder list -> constr_expr -> *) -(* types Univ.in_universe_context_set * Impargs.manual_implicits *) - -(** returns [false] if the assumption is neither local to a section, - nor in a module type and meant to be instantiated. *) -val declare_assumption : coercion_flag -> assumption_kind -> - types Univ.in_universe_context_set -> - Universes.universe_binders -> Impargs.manual_implicits -> - bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located -> - global_reference * Univ.Instance.t * bool - -val do_assumptions : locality * polymorphic * assumption_object_kind -> - 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 -> *) -(* Impargs.manual_implicits -> bool -> Vernacexpr.inline -> bool *) - -(** {6 Inductive and coinductive types} *) - -(** Extracting the semantical components out of the raw syntax of mutual - inductive declarations *) - -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 -} - -type structured_inductive_expr = - local_binder list * structured_one_inductive_expr list - -val extract_mutual_inductive_declaration_components : - (one_inductive_expr * decl_notation list) list -> - structured_inductive_expr * (*coercions:*) qualid list * decl_notation list - -(** Typing mutual inductive definitions *) - -type one_inductive_impls = - Impargs.manual_implicits (** for inds *)* - Impargs.manual_implicits list (** for constrs *) - -val interp_mutual_inductive : - structured_inductive_expr -> decl_notation list -> polymorphic -> - private_flag -> Decl_kinds.recursivity_kind -> - 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 -> Universes.universe_binders -> one_inductive_impls list -> - mutual_inductive - -(** Entry points for the vernacular commands Inductive and CoInductive *) - -val do_mutual_inductive : - (one_inductive_expr * decl_notation list) list -> polymorphic -> - private_flag -> Decl_kinds.recursivity_kind -> unit - -(** {6 Fixpoints and cofixpoints} *) - -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; - fix_type : constr_expr -} - -(** Extracting the semantical components out of the raw syntax of - (co)fixpoints declarations *) - -val extract_fixpoint_components : bool -> - (fixpoint_expr * decl_notation list) list -> - structured_fixpoint_expr list * decl_notation list - -val extract_cofixpoint_components : - (cofixpoint_expr * decl_notation list) list -> - structured_fixpoint_expr list * decl_notation list - -(** Typing global fixpoints and cofixpoint_expr *) - -type recursive_preentry = - Id.t list * constr option list * types list - -val interp_fixpoint : - structured_fixpoint_expr list -> decl_notation list -> - 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 * 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 * 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 * lident list option * Evd.evar_universe_context * - (Name.t list * Impargs.manual_implicits * int option) list -> - decl_notation list -> unit - -(** Entry points for the vernacular commands Fixpoint and CoFixpoint *) - -val do_fixpoint : - (* When [false], assume guarded. *) - locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit - -val do_cofixpoint : - (* When [false], assume guarded. *) - locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit - -(** Utils *) - -val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit - -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/discharge.ml b/toplevel/discharge.ml deleted file mode 100644 index e24d5e74fb..0000000000 --- a/toplevel/discharge.ml +++ /dev/null @@ -1,120 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* id, LocalAssumEntry p - | LocalDef (Name id, p,_) -> id, LocalDefEntry p - | _ -> anomaly (Pp.str "Unnamed inductive local variable") - -(* Replace - - Var(y1)..Var(yq):C1..Cq |- Ij:Bj - Var(y1)..Var(yq):C1..Cq; I1..Ip:B1..Bp |- ci : Ti - - by - - |- Ij: (y1..yq:C1..Cq)Bj - I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)] -*) - -let abstract_inductive hyps nparams inds = - let ntyp = List.length inds 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' = - List.map - (function (tname,arity,template,cnames,lc) -> - let lc' = List.map (substl subs) lc in - let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in - let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in - (tname,arity',template,cnames,lc'')) - inds in - let nparams' = nparams + Array.length args in -(* 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 - in - let ind'' = - List.map - (fun (a,arity,template,c,lc) -> - let _, short_arity = decompose_prod_n_assum nparams' arity in - let shortlc = - List.map (fun c -> snd (decompose_prod_n_assum nparams' c)) lc in - { mind_entry_typename = a; - mind_entry_arity = short_arity; - mind_entry_template = template; - mind_entry_consnames = c; - mind_entry_lc = shortlc }) - inds' - in (params',ind'') - -let refresh_polymorphic_type_of_inductive (_,mip) = - match mip.mind_arity with - | RegularArity s -> s.mind_user_arity, false - | TemplateArity ar -> - let ctx = List.rev mip.mind_arity_ctxt in - mkArity (List.rev ctx, Type ar.template_level), true - -let process_inductive (sechyps,abs_ctx) modlist mib = - let nparams = mib.mind_nparams in - let subst, univs = - if mib.mind_polymorphic then - let inst = Univ.UContext.instance mib.mind_universes in - let cstrs = Univ.UContext.constraints mib.mind_universes in - inst, Univ.UContext.make (inst, Univ.subst_instance_constraints inst cstrs) - else Univ.Instance.empty, mib.mind_universes - in - let inds = - Array.map_to_list - (fun mip -> - let ty, template = refresh_polymorphic_type_of_inductive (mib,mip) in - let arity = expmod_constr modlist ty in - let arity = Vars.subst_instance_constr subst arity in - let lc = Array.map - (fun c -> Vars.subst_instance_constr subst (expmod_constr modlist c)) - mip.mind_user_lc - in - (mip.mind_typename, - arity, template, - Array.to_list mip.mind_consnames, - Array.to_list lc)) - mib.mind_packets 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 - let record = match mib.mind_record with - | Some (Some (id, _, _)) -> Some (Some id) - | Some None -> Some None - | None -> None - in - { mind_entry_record = record; - mind_entry_finite = mib.mind_finite; - mind_entry_params = params'; - mind_entry_inds = inds'; - mind_entry_polymorphic = mib.mind_polymorphic; - mind_entry_private = mib.mind_private; - mind_entry_universes = univs; - } diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli deleted file mode 100644 index 18d1b67766..0000000000 --- a/toplevel/discharge.mli +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* work_list -> mutual_inductive_body -> mutual_inductive_entry diff --git a/toplevel/doc.tex b/toplevel/doc.tex deleted file mode 100644 index f2550fda11..0000000000 --- a/toplevel/doc.tex +++ /dev/null @@ -1,10 +0,0 @@ - -\newpage -\section*{The Coq toplevel} - -\ocwsection \label{toplevel} -This chapter describes the highest modules of the \Coq\ system. -They are organized as follows: - -\bigskip -\begin{center}\epsfig{file=toplevel.dep.ps,width=\linewidth}\end{center} diff --git a/toplevel/explainErr.ml b/toplevel/explainErr.ml deleted file mode 100644 index 17897460c0..0000000000 --- a/toplevel/explainErr.ml +++ /dev/null @@ -1,129 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* hov 0 (str "Syntax error: " ++ str txt ++ str ".") - | Compat.Token.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") - | CLexer.Error.E err -> hov 0 (str (CLexer.Error.to_string err)) - | Sys_error msg -> hov 0 (str "System error: " ++ guill msg) - | Out_of_memory -> hov 0 (str "Out of memory.") - | Stack_overflow -> hov 0 (str "Stack overflow.") - | Timeout -> hov 0 (str "Timeout!") - | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") - (* Exceptions with pre-evaluated error messages *) - | EvaluatedError (msg,None) -> msg - | EvaluatedError (msg,Some reraise) -> msg ++ CErrors.print reraise - (* Otherwise, not handled here *) - | _ -> raise CErrors.Unhandled - -let _ = CErrors.register_handler explain_exn_default - - -(** Pre-explain a vernac interpretation error *) - -let wrap_vernac_error with_header (exn, info) strm = - if with_header then - let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in - let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in - (e, info) - else - (EvaluatedError (strm, None), info) - -let process_vernac_interp_error with_header exn = match fst exn with - | Univ.UniverseInconsistency i -> - let msg = - if !Constrextern.print_universes then - str "." ++ spc() ++ - Univ.explain_universe_inconsistency Universes.pr_with_global_universes i - else - mt() in - wrap_vernac_error with_header exn (str "Universe inconsistency" ++ msg ++ str ".") - | TypeError(ctx,te) -> - wrap_vernac_error with_header exn (Himsg.explain_type_error ctx Evd.empty te) - | PretypeError(ctx,sigma,te) -> - wrap_vernac_error with_header exn (Himsg.explain_pretype_error ctx sigma te) - | Typeclasses_errors.TypeClassError(env, te) -> - wrap_vernac_error with_header exn (Himsg.explain_typeclass_error env te) - | InductiveError e -> - wrap_vernac_error with_header exn (Himsg.explain_inductive_error e) - | Modops.ModuleTypingError e -> - wrap_vernac_error with_header exn (Himsg.explain_module_error e) - | Modintern.ModuleInternalizationError e -> - wrap_vernac_error with_header exn (Himsg.explain_module_internalization_error e) - | RecursionSchemeError e -> - wrap_vernac_error with_header exn (Himsg.explain_recursion_scheme_error e) - | Cases.PatternMatchingError (env,sigma,e) -> - wrap_vernac_error with_header exn (Himsg.explain_pattern_matching_error env sigma e) - | Tacred.ReductionTacticError e -> - wrap_vernac_error with_header exn (Himsg.explain_reduction_tactic_error e) - | Logic.RefinerError e -> - wrap_vernac_error with_header exn (Himsg.explain_refiner_error e) - | Nametab.GlobalizationError q -> - wrap_vernac_error with_header exn - (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ - spc () ++ str "was not found" ++ - spc () ++ str "in the current" ++ spc () ++ str "environment.") - | Refiner.FailError (i,s) -> - let s = Lazy.force s in - wrap_vernac_error with_header exn - (str "Tactic failure" ++ - (if Pp.is_empty s then s else str ": " ++ s) ++ - if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").") - | AlreadyDeclared msg -> - wrap_vernac_error with_header exn (msg ++ str ".") - | _ -> - exn - -let rec strip_wrapping_exceptions = function - | Logic_monad.TacticFailure e -> - 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 - let () = - if not allow_uncaught && not (CErrors.handled (fst e)) then - let (e, info) = e in - let msg = str "Uncaught exception " ++ str (Printexc.to_string e) in - let err = CErrors.make_anomaly msg in - Util.iraise (err, info) - in - let e' = - try Some (CList.find_map (fun f -> f e) !additional_error_info) - with _ -> None - in - match e' with - | None -> e - | 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/explainErr.mli b/toplevel/explainErr.mli deleted file mode 100644 index a67c887af3..0000000000 --- a/toplevel/explainErr.mli +++ /dev/null @@ -1,21 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ?with_header:bool -> Util.iexn -> Util.iexn - -(** General explain function. Should not be used directly now, - see instead function [Errors.print] and variants *) - -val explain_exn_default : exn -> Pp.std_ppcmds - -val register_additional_error_info : (Util.iexn -> (Pp.std_ppcmds option * Loc.t) option) -> unit diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml deleted file mode 100644 index 6cff805fc2..0000000000 --- a/toplevel/himsg.ml +++ /dev/null @@ -1,1268 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - l := (Vars.substl !l c') :: !l; - env - | _ -> - let t = Vars.substl !l (RelDecl.get_type decl) in - let decl = decl |> RelDecl.map_name (named_hd env t) |> RelDecl.map_value (Vars.substl !l) |> RelDecl.set_type t in - l := (mkRel 1) :: List.map (Vars.lift 1) !l; - push_rel decl env - in - let env = process_rel_context contract_context env in - (env, List.map (Vars.substl !l) lc) - -let contract2 env a b = match contract env [a;b] with - | env, [a;b] -> env,a,b | _ -> assert false - -let contract3 env a b c = match contract env [a;b;c] with - | env, [a;b;c] -> env,a,b,c | _ -> assert false - -let contract4 env a b c d = match contract env [a;b;c;d] with - | env, [a;b;c;d] -> (env,a,b,c),d | _ -> assert false - -let contract1_vect env a v = - match contract env (a :: Array.to_list v) with - | env, a::l -> env,a,Array.of_list l - | _ -> assert false - -let rec contract3' env a b c = function - | OccurCheck (evk,d) -> let x,d = contract4 env a b c d in x,OccurCheck(evk,d) - | NotClean ((evk,args),env',d) -> - let env',d,args = contract1_vect env' d args in - contract3 env a b c,NotClean((evk,args),env',d) - | ConversionFailed (env',t1,t2) -> - let (env',t1,t2) = contract2 env' t1 t2 in - contract3 env a b c, ConversionFailed (env',t1,t2) - | NotSameArgSize | NotSameHead | NoCanonicalStructure - | MetaOccurInBody _ | InstanceNotSameType _ | ProblemBeyondCapabilities - | UnifUnivInconsistency _ as x -> contract3 env a b c, x - | CannotSolveConstraint ((pb,env',t,u),x) -> - let env',t,u = contract2 env' t u in - 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) -let pr_lconstr_env e s c = quote (pr_lconstr_env e s c) -let pr_ljudge_env e s c = let v,t = pr_ljudge_env e s c in (quote v,quote t) - -(** A canonisation procedure for constr such that comparing there - externalisation catches more equalities *) -let canonize_constr c = - (* replaces all the names in binders by [dn] ("default name"), - ensures that [alpha]-equivalent terms will have the same - externalisation. *) - let dn = Name.Anonymous in - let rec canonize_binders c = - match Term.kind_of_term c with - | Prod (_,t,b) -> mkProd(dn,t,b) - | Lambda (_,t,b) -> mkLambda(dn,t,b) - | LetIn (_,u,t,b) -> mkLetIn(dn,u,t,b) - | _ -> Term.map_constr canonize_binders c - in - canonize_binders c - -(** Tries to realize when the two terms, albeit different are printed the same. *) -let display_eq ~flags env sigma t1 t2 = - (* terms are canonized, then their externalisation is compared syntactically *) - let open Constrextern in - let t1 = canonize_constr t1 in - let t2 = canonize_constr t2 in - let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) () in - let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) () in - Constrexpr_ops.constr_expr_eq ct1 ct2 - -(** This function adds some explicit printing flags if the two arguments are - printed alike. *) -let rec pr_explicit_aux env sigma t1 t2 = function -| [] -> - (** no specified flags: default. *) - (quote (Printer.pr_lconstr_env env sigma t1), quote (Printer.pr_lconstr_env env sigma t2)) -| flags :: rem -> - let equal = display_eq ~flags env sigma t1 t2 in - if equal then - (** The two terms are the same from the user point of view *) - pr_explicit_aux env sigma t1 t2 rem - else - let open Constrextern in - let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) () - in - let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) () - in - quote (Ppconstr.pr_lconstr_expr ct1), quote (Ppconstr.pr_lconstr_expr ct2) - -let explicit_flags = - let open Constrextern in - [ []; (** First, try with the current flags *) - [print_implicits]; (** Then with implicit *) - [print_universes]; (** Then with universes *) - [print_universes; print_implicits]; (** With universes AND implicits *) - [print_implicits; print_coercions; print_no_symbol]; (** Then more! *) - [print_universes; print_implicits; print_coercions; print_no_symbol] (** and more! *) ] - -let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags - -let pr_db env i = - try - match env |> lookup_rel i |> 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 = - let pe = pr_ne_context_of (str "In environment") env sigma in - str "Unbound reference: " ++ pe ++ - str "The reference " ++ int n ++ str " is free." - -let explain_unbound_var env v = - let var = pr_id v in - str "No such section variable or assumption: " ++ var ++ str "." - -let explain_not_type env sigma j = - let j = Evarutil.j_nf_evar sigma j in - let pe = pr_ne_context_of (str "In environment") env sigma in - let pc,pt = pr_ljudge_env env sigma j in - pe ++ str "The term" ++ brk(1,1) ++ pc ++ spc () ++ - str "has type" ++ spc () ++ pt ++ spc () ++ - str "which should be Set, Prop or Type." - -let explain_bad_assumption env sigma j = - let pe = pr_ne_context_of (str "In environment") env sigma in - let pc,pt = pr_ljudge_env env sigma j in - pe ++ str "Cannot declare a variable or hypothesis over the term" ++ - brk(1,1) ++ pc ++ spc () ++ str "of type" ++ spc () ++ pt ++ spc () ++ - str "because this term is not a type." - -let explain_reference_variables id c = - (* c is intended to be a global reference *) - let pc = pr_global (Globnames.global_of_constr c) in - pc ++ strbrk " depends on the variable " ++ pr_id id ++ - strbrk " which is not declared in the context." - -let rec pr_disjunction pr = function - | [a] -> pr a - | [a;b] -> pr a ++ str " or" ++ spc () ++ pr b - | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l - | [] -> assert false - -let pr_puniverses f env (c,u) = - f env c ++ - (if Flags.is_universe_polymorphism () && not (Univ.Instance.is_empty u) then - str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)" - else mt()) - -let explain_elim_arity env sigma ind sorts c pj okinds = - let env = make_all_name_different env in - let pi = pr_inductive env (fst ind) in - let pc = pr_lconstr_env env sigma c in - let msg = match okinds with - | Some(kp,ki,explanation) -> - let pki = pr_sort_family ki in - let pkp = pr_sort_family kp in - let explanation = match explanation with - | NonInformativeToInformative -> - "proofs can be eliminated only to build proofs" - | StrongEliminationOnNonSmallType -> - "strong elimination on non-small inductive types leads to paradoxes" - | WrongArity -> - "wrong arity" in - let ppar = pr_disjunction (fun s -> quote (pr_sort_family s)) sorts in - let ppt = pr_lconstr_env env sigma ((strip_prod_assum pj.uj_type)) in - hov 0 - (str "the return type has sort" ++ spc () ++ ppt ++ spc () ++ - str "while it" ++ spc () ++ str "should be " ++ ppar ++ str ".") ++ - fnl () ++ - hov 0 - (str "Elimination of an inductive object of sort " ++ - pki ++ brk(1,0) ++ - str "is not allowed on a predicate in sort " ++ pkp ++ fnl () ++ - str "because" ++ spc () ++ str explanation ++ str ".") - | None -> - str "ill-formed elimination predicate." - in - hov 0 ( - str "Incorrect elimination of" ++ spc () ++ pc ++ spc () ++ - str "in the inductive type" ++ spc () ++ quote pi ++ str ":") ++ - fnl () ++ msg - -let explain_case_not_inductive env sigma cj = - let cj = Evarutil.j_nf_evar sigma cj in - let env = make_all_name_different env in - let pc = pr_lconstr_env env sigma cj.uj_val in - let pct = pr_lconstr_env env sigma cj.uj_type in - match kind_of_term cj.uj_type with - | Evar _ -> - str "Cannot infer a type for this expression." - | _ -> - str "The term" ++ brk(1,1) ++ pc ++ spc () ++ - str "has type" ++ brk(1,1) ++ pct ++ spc () ++ - str "which is not a (co-)inductive type." - -let explain_number_branches env sigma cj expn = - let cj = Evarutil.j_nf_evar sigma cj in - let env = make_all_name_different env in - let pc = pr_lconstr_env env sigma cj.uj_val in - let pct = pr_lconstr_env env sigma cj.uj_type in - str "Matching on term" ++ brk(1,1) ++ pc ++ spc () ++ - str "of type" ++ brk(1,1) ++ pct ++ spc () ++ - str "expects " ++ int expn ++ str " branches." - -let explain_ill_formed_branch env sigma c ci actty expty = - let simp t = Reduction.nf_betaiota env (Evarutil.nf_evar sigma t) in - let c = Evarutil.nf_evar sigma c in - let env = make_all_name_different env in - let pc = pr_lconstr_env env sigma c in - let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in - strbrk "In pattern-matching on term" ++ brk(1,1) ++ pc ++ - spc () ++ strbrk "the branch for constructor" ++ spc () ++ - quote (pr_puniverses pr_constructor env ci) ++ - spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++ - str "which should be" ++ brk(1,1) ++ pe ++ str "." - -let explain_generalization env sigma (name,var) j = - let pe = pr_ne_context_of (str "In environment") env sigma in - let pv = pr_ltype_env env sigma var in - let (pc,pt) = pr_ljudge_env (push_rel_assum (name,var) env) sigma j in - pe ++ str "Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++ - str "over" ++ brk(1,1) ++ pc ++ str "," ++ spc () ++ - str "it has type" ++ spc () ++ pt ++ - spc () ++ str "which should be Set, Prop or Type." - -let explain_unification_error env sigma p1 p2 = function - | None -> mt() - | Some e -> - let rec aux p1 p2 = function - | OccurCheck (evk,rhs) -> - let rhs = Evarutil.nf_evar sigma rhs in - [str "cannot define " ++ quote (pr_existential_key sigma evk) ++ - strbrk " with term " ++ pr_lconstr_env env sigma rhs ++ - strbrk " that would depend on itself"] - | NotClean ((evk,args),env,c) -> - let c = Evarutil.nf_evar sigma c in - let args = Array.map (Evarutil.nf_evar sigma) args in - [str "cannot instantiate " ++ quote (pr_existential_key sigma evk) - ++ strbrk " because " ++ pr_lconstr_env env sigma c ++ - strbrk " is not in its scope" ++ - (if Array.is_empty args then mt() else - strbrk ": available arguments are " ++ - pr_sequence (pr_lconstr_env env sigma) (List.rev (Array.to_list args)))] - | NotSameArgSize | NotSameHead | NoCanonicalStructure -> - (* Error speaks from itself *) [] - | ConversionFailed (env,t1,t2) -> - if Term.eq_constr t1 p1 && Term.eq_constr t2 p2 then [] else - let env = make_all_name_different env in - let t1 = Evarutil.nf_evar sigma t1 in - let t2 = Evarutil.nf_evar sigma t2 in - if not (Term.eq_constr t1 p1) || not (Term.eq_constr t2 p2) then - let t1, t2 = pr_explicit env sigma t1 t2 in - [str "cannot unify " ++ t1 ++ strbrk " and " ++ t2] - else [] - | MetaOccurInBody evk -> - [str "instance for " ++ quote (pr_existential_key sigma evk) ++ - strbrk " refers to a metavariable - please report your example" ++ - strbrk "at " ++ str Coq_config.wwwbugtracker ++ str "."] - | InstanceNotSameType (evk,env,t,u) -> - let t, u = pr_explicit env sigma t u in - [str "unable to find a well-typed instantiation for " ++ - quote (pr_existential_key sigma evk) ++ - strbrk ": cannot ensure that " ++ - t ++ strbrk " is a subtype of " ++ u] - | UnifUnivInconsistency p -> - if !Constrextern.print_universes then - [str "universe inconsistency: " ++ - Univ.explain_universe_inconsistency Universes.pr_with_global_universes p] - else - [str "universe inconsistency"] - | CannotSolveConstraint ((pb,env,t,u),e) -> - let t = Evarutil.nf_evar sigma t in - let u = Evarutil.nf_evar sigma u in - let env = make_all_name_different env in - (strbrk "cannot satisfy constraint " ++ pr_lconstr_env env sigma t ++ - str " == " ++ pr_lconstr_env env sigma u) - :: aux t u e - | ProblemBeyondCapabilities -> - [] - in - match aux p1 p2 e with - | [] -> mt () - | l -> spc () ++ str "(" ++ - prlist_with_sep pr_semicolon (fun x -> x) l ++ str ")" - -let explain_actual_type env sigma j t reason = - let env = make_all_name_different env 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 - let pc = pr_lconstr_env env sigma (Environ.j_val j) in - let (pt, pct) = pr_explicit env sigma t (Environ.j_type j) in - let ppreason = explain_unification_error env sigma j.uj_type t reason in - pe ++ - hov 0 ( - str "The term" ++ brk(1,1) ++ pc ++ spc () ++ - str "has type" ++ brk(1,1) ++ pct ++ spc () ++ - str "while it is expected to have type" ++ brk(1,1) ++ pt ++ - ppreason ++ str ".") - -let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = - 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 - let env = make_all_name_different env in - let actualtyp, exptyp = pr_explicit env sigma actualtyp exptyp in - let nargs = Array.length randl in -(* let pe = pr_ne_context_of (str "in environment") env sigma in*) - let pr,prt = pr_ljudge_env env sigma rator in - let term_string1 = str (String.plural nargs "term") in - let term_string2 = - if nargs>1 then str "The " ++ pr_nth n ++ str " term" else str "This term" - in - let appl = prvect_with_sep fnl - (fun c -> - let pc,pct = pr_ljudge_env env sigma c in - hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl - in - str "Illegal application: " ++ (* pe ++ *) fnl () ++ - str "The term" ++ brk(1,1) ++ pr ++ spc () ++ - str "of type" ++ brk(1,1) ++ prt ++ spc () ++ - str "cannot be applied to the " ++ term_string1 ++ fnl () ++ - str " " ++ v 0 appl ++ fnl () ++ term_string2 ++ str " has type" ++ - brk(1,1) ++ actualtyp ++ spc () ++ - str "which should be coercible to" ++ brk(1,1) ++ - exptyp ++ str "." - -let explain_cant_apply_not_functional env sigma rator randl = - let randl = Evarutil.jv_nf_evar sigma randl in - let rator = Evarutil.j_nf_evar sigma rator in - let env = make_all_name_different env in - let nargs = Array.length randl in -(* let pe = pr_ne_context_of (str "in environment") env sigma in*) - let pr = pr_lconstr_env env sigma rator.uj_val in - let prt = pr_lconstr_env env sigma rator.uj_type in - let appl = prvect_with_sep fnl - (fun c -> - let pc = pr_lconstr_env env sigma c.uj_val in - let pct = pr_lconstr_env env sigma c.uj_type in - hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl - in - str "Illegal application (Non-functional construction): " ++ - (* pe ++ *) fnl () ++ - str "The expression" ++ brk(1,1) ++ pr ++ spc () ++ - str "of type" ++ brk(1,1) ++ prt ++ spc () ++ - str "cannot be applied to the " ++ str (String.plural nargs "term") ++ - fnl () ++ str " " ++ v 0 appl - -let explain_unexpected_type env sigma actual_type expected_type = - let actual_type = Evarutil.nf_evar sigma actual_type in - let expected_type = Evarutil.nf_evar sigma expected_type in - let pract, prexp = pr_explicit env sigma actual_type expected_type in - str "Found type" ++ spc () ++ pract ++ spc () ++ - str "where" ++ spc () ++ prexp ++ str " was expected." - -let explain_not_product env sigma c = - let c = Evarutil.nf_evar sigma c in - let pr = pr_lconstr_env env sigma c in - str "The type of this term is a product" ++ spc () ++ - str "while it is expected to be" ++ - (if is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." - -(* TODO: use the names *) -(* (co)fixpoints *) -let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = - let prt_name i = - match names.(i) with - Name id -> str "Recursive definition of " ++ pr_id id - | Anonymous -> str "The " ++ pr_nth i ++ str " definition" in - - let st = match err with - - (* Fixpoint guard errors *) - | NotEnoughAbstractionInFixBody -> - str "Not enough abstractions in the definition" - | RecursionNotOnInductiveType c -> - str "Recursive definition on" ++ spc () ++ pr_lconstr_env env sigma c ++ - spc () ++ str "which should be an inductive type" - | RecursionOnIllegalTerm(j,(arg_env, arg),le,lt) -> - let arg_env = make_all_name_different arg_env in - let called = - match names.(j) with - Name id -> pr_id id - | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in - let pr_db x = quote (pr_db env x) in - let vars = - match (lt,le) with - ([],[]) -> assert false - | ([],[x]) -> str "a subterm of " ++ pr_db x - | ([],_) -> str "a subterm of the following variables: " ++ - pr_sequence pr_db le - | ([x],_) -> pr_db x - | _ -> - str "one of the following variables: " ++ - pr_sequence pr_db lt in - str "Recursive call to " ++ called ++ spc () ++ - strbrk "has principal argument equal to" ++ spc () ++ - pr_lconstr_env arg_env sigma arg ++ strbrk " instead of " ++ vars - - | NotEnoughArgumentsForFixCall j -> - let called = - match names.(j) with - Name id -> pr_id id - | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in - str "Recursive call to " ++ called ++ str " has not enough arguments" - - (* CoFixpoint guard errors *) - | CodomainNotInductiveType c -> - str "The codomain is" ++ spc () ++ pr_lconstr_env env sigma c ++ spc () ++ - str "which should be a coinductive type" - | NestedRecursiveOccurrences -> - str "Nested recursive occurrences" - | UnguardedRecursiveCall c -> - str "Unguarded recursive call in" ++ spc () ++ pr_lconstr_env env sigma c - | RecCallInTypeOfAbstraction c -> - str "Recursive call forbidden in the domain of an abstraction:" ++ - spc () ++ pr_lconstr_env env sigma c - | RecCallInNonRecArgOfConstructor c -> - str "Recursive call on a non-recursive argument of constructor" ++ - spc () ++ pr_lconstr_env env sigma c - | RecCallInTypeOfDef c -> - str "Recursive call forbidden in the type of a recursive definition" ++ - spc () ++ pr_lconstr_env env sigma c - | RecCallInCaseFun c -> - str "Invalid recursive call in a branch of" ++ - spc () ++ pr_lconstr_env env sigma c - | RecCallInCaseArg c -> - str "Invalid recursive call in the argument of \"match\" in" ++ spc () ++ - pr_lconstr_env env sigma c - | RecCallInCasePred c -> - str "Invalid recursive call in the \"return\" clause of \"match\" in" ++ - spc () ++ pr_lconstr_env env sigma c - | NotGuardedForm c -> - str "Sub-expression " ++ pr_lconstr_env env sigma c ++ - strbrk " not in guarded form (should be a constructor," ++ - strbrk " an abstraction, a match, a cofix or a recursive call)" - | ReturnPredicateNotCoInductive c -> - str "The return clause of the following pattern matching should be" ++ - strbrk " a coinductive type:" ++ - spc () ++ pr_lconstr_env env sigma c - in - prt_name i ++ str " is ill-formed." ++ fnl () ++ - pr_ne_context_of (str "In environment") env sigma ++ - st ++ str "." ++ fnl () ++ - (try (* May fail with unresolved globals. *) - let fixenv = make_all_name_different fixenv in - let pvd = pr_lconstr_env fixenv sigma vdefj.(i).uj_val in - str"Recursive definition is:" ++ spc () ++ pvd ++ str "." - with e when CErrors.noncritical e -> mt ()) - -let explain_ill_typed_rec_body env sigma i names vdefj vargs = - let vdefj = Evarutil.jv_nf_evar sigma vdefj in - let vargs = Array.map (Evarutil.nf_evar sigma) vargs in - let env = make_all_name_different env in - let pvd = pr_lconstr_env env sigma vdefj.(i).uj_val in - let pvdt, pv = pr_explicit env sigma vdefj.(i).uj_type vargs.(i) in - str "The " ++ - (match vdefj with [|_|] -> mt () | _ -> pr_nth (i+1) ++ spc ()) ++ - str "recursive definition" ++ spc () ++ pvd ++ spc () ++ - str "has type" ++ spc () ++ pvdt ++ spc () ++ - str "while it should be" ++ spc () ++ pv ++ str "." - -let explain_cant_find_case_type env sigma c = - let c = Evarutil.nf_evar sigma c in - let env = make_all_name_different env in - let pe = pr_lconstr_env env sigma c in - str "Cannot infer the return type of pattern-matching on" ++ ws 1 ++ - pe ++ str "." - -let explain_occur_check env sigma ev rhs = - let rhs = Evarutil.nf_evar sigma rhs in - let env = make_all_name_different env in - let pt = pr_lconstr_env env sigma rhs in - str "Cannot define " ++ pr_existential_key sigma ev ++ str " with term" ++ - brk(1,1) ++ pt ++ spc () ++ str "that would depend on itself." - -let pr_trailing_ne_context_of env sigma = - if List.is_empty (Environ.rel_context env) && - List.is_empty (Environ.named_context env) - then str "." - else (str " in environment:"++ pr_context_unlimited env sigma) - -let rec explain_evar_kind env sigma evk ty = function - | Evar_kinds.NamedHole id -> - strbrk "the existential variable named " ++ pr_id id - | Evar_kinds.QuestionMark _ -> - strbrk "this placeholder of type " ++ ty - | Evar_kinds.CasesType false -> - strbrk "the type of this pattern-matching problem" - | Evar_kinds.CasesType true -> - strbrk "a subterm of type " ++ ty ++ - strbrk " in the type of this pattern-matching problem" - | Evar_kinds.BinderType (Name id) -> - strbrk "the type of " ++ Nameops.pr_id id - | Evar_kinds.BinderType Anonymous -> - strbrk "the type of this anonymous binder" - | Evar_kinds.ImplicitArg (c,(n,ido),b) -> - let id = Option.get ido in - strbrk "the implicit parameter " ++ pr_id id ++ spc () ++ str "of" ++ - spc () ++ Nametab.pr_global_env Id.Set.empty c ++ - strbrk " whose type is " ++ ty - | Evar_kinds.InternalHole -> strbrk "an internal placeholder of type " ++ ty - | Evar_kinds.TomatchTypeParameter (tyi,n) -> - strbrk "the " ++ pr_nth n ++ - strbrk " argument of the inductive type (" ++ pr_inductive env tyi ++ - strbrk ") of this term" - | Evar_kinds.GoalEvar -> - strbrk "an existential variable of type " ++ ty - | Evar_kinds.ImpossibleCase -> - strbrk "the type of an impossible pattern-matching clause" - | Evar_kinds.MatchingVar _ -> - assert false - | Evar_kinds.VarInstance id -> - strbrk "an instance of type " ++ ty ++ - str " for the variable " ++ pr_id id - | Evar_kinds.SubEvar evk' -> - let evi = Evd.find sigma evk' in - let pc = match evi.evar_body with - | Evar_defined c -> pr_lconstr_env env sigma (Evarutil.nf_evar sigma c) - | Evar_empty -> assert false in - let ty' = Evarutil.nf_evar sigma evi.evar_concl in - pr_existential_key sigma evk ++ str " of type " ++ ty ++ - str " in the partial instance " ++ pc ++ - str " found for " ++ explain_evar_kind env sigma evk' - (pr_lconstr_env env sigma ty') (snd evi.evar_source) - -let explain_typeclass_resolution env sigma evi k = - match Typeclasses.class_of_constr evi.evar_concl with - | Some _ -> - let env = Evd.evar_filtered_env evi in - fnl () ++ str "Could not find an instance for " ++ - pr_lconstr_env env sigma evi.evar_concl ++ - pr_trailing_ne_context_of env sigma - | _ -> mt() - -let explain_placeholder_kind env sigma c e = - match e with - | Some (SeveralInstancesFound n) -> - strbrk " (several distinct possible type class instances found)" - | None -> - match Typeclasses.class_of_constr c with - | Some _ -> strbrk " (no type class instance found)" - | _ -> mt () - -let explain_unsolvable_implicit env sigma evk explain = - let evi = Evarutil.nf_evar_info sigma (Evd.find_undefined sigma evk) in - let env = Evd.evar_filtered_env evi in - let type_of_hole = pr_lconstr_env env sigma evi.evar_concl in - let pe = pr_trailing_ne_context_of env sigma in - strbrk "Cannot infer " ++ - explain_evar_kind env sigma evk type_of_hole (snd evi.evar_source) ++ - explain_placeholder_kind env sigma evi.evar_concl explain ++ pe - -let explain_var_not_found env id = - str "The variable" ++ spc () ++ pr_id id ++ - spc () ++ str "was not found" ++ - spc () ++ str "in the current" ++ spc () ++ str "environment" ++ str "." - -let explain_wrong_case_info env (ind,u) ci = - let pi = pr_inductive (Global.env()) ind in - if eq_ind ci.ci_ind ind then - str "Pattern-matching expression on an object of inductive type" ++ - spc () ++ pi ++ spc () ++ str "has invalid information." - else - let pc = pr_inductive (Global.env()) ci.ci_ind in - str "A term of inductive type" ++ spc () ++ pi ++ spc () ++ - str "was given to a pattern-matching expression on the inductive type" ++ - spc () ++ pc ++ str "." - -let explain_cannot_unify env sigma m n e = - let env = make_all_name_different env in - let m = Evarutil.nf_evar sigma m in - let n = Evarutil.nf_evar sigma n in - let pm, pn = pr_explicit env sigma m n in - let ppreason = explain_unification_error env sigma m n e in - let pe = pr_ne_context_of (str "In environment") env sigma in - pe ++ str "Unable to unify" ++ brk(1,1) ++ pm ++ spc () ++ - str "with" ++ brk(1,1) ++ pn ++ ppreason ++ str "." - -let explain_cannot_unify_local env sigma m n subn = - let pm = pr_lconstr_env env sigma m in - let pn = pr_lconstr_env env sigma n in - let psubn = pr_lconstr_env env sigma subn in - str "Unable to unify" ++ brk(1,1) ++ pm ++ spc () ++ - str "with" ++ brk(1,1) ++ pn ++ spc () ++ str "as" ++ brk(1,1) ++ - psubn ++ str " contains local variables." - -let explain_refiner_cannot_generalize env sigma ty = - str "Cannot find a well-typed generalisation of the goal with type: " ++ - pr_lconstr_env env sigma ty ++ str "." - -let explain_no_occurrence_found env sigma c id = - str "Found no subterm matching " ++ pr_lconstr_env env sigma c ++ - str " in " ++ - (match id with - | Some id -> pr_id id - | None -> str"the current goal") ++ str "." - -let explain_cannot_unify_binding_type env sigma m n = - let pm = pr_lconstr_env env sigma m in - let pn = pr_lconstr_env env sigma n in - str "This binding has type" ++ brk(1,1) ++ pm ++ spc () ++ - str "which should be unifiable with" ++ brk(1,1) ++ pn ++ str "." - -let explain_cannot_find_well_typed_abstraction env sigma p l e = - str "Abstracting over the " ++ - str (String.plural (List.length l) "term") ++ spc () ++ - hov 0 (pr_enum (pr_lconstr_env env sigma) l) ++ spc () ++ - str "leads to a term" ++ spc () ++ pr_lconstr_goal_style_env env sigma p ++ - spc () ++ str "which is ill-typed." ++ - (match e with None -> mt () | Some e -> fnl () ++ str "Reason is: " ++ e) - -let explain_wrong_abstraction_type env sigma na abs expected result = - let ppname = match na with Name id -> pr_id id ++ spc () | _ -> mt () in - str "Cannot instantiate metavariable " ++ ppname ++ strbrk "of type " ++ - pr_lconstr_env env sigma expected ++ strbrk " with abstraction " ++ - pr_lconstr_env env sigma abs ++ strbrk " of incompatible type " ++ - pr_lconstr_env env sigma result ++ str "." - -let explain_abstraction_over_meta _ m n = - strbrk "Too complex unification problem: cannot find a solution for both " ++ - pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "." - -let explain_non_linear_unification env sigma m t = - strbrk "Cannot unambiguously instantiate " ++ - pr_name m ++ str ":" ++ - strbrk " which would require to abstract twice on " ++ - pr_lconstr_env env sigma t ++ str "." - -let explain_unsatisfied_constraints env sigma cst = - strbrk "Unsatisfied constraints: " ++ - Univ.pr_constraints (Evd.pr_evd_level sigma) cst ++ - spc () ++ str "(maybe a bugged tactic)." - -let explain_type_error env sigma err = - let env = make_all_name_different env in - match err with - | UnboundRel n -> - explain_unbound_rel env sigma n - | UnboundVar v -> - explain_unbound_var env v - | NotAType j -> - explain_not_type env sigma j - | BadAssumption c -> - explain_bad_assumption env sigma c - | ReferenceVariables (id,c) -> - explain_reference_variables id c - | ElimArity (ind, aritylst, c, pj, okinds) -> - explain_elim_arity env sigma ind aritylst c pj okinds - | CaseNotInductive cj -> - explain_case_not_inductive env sigma cj - | NumberBranches (cj, n) -> - explain_number_branches env sigma cj n - | IllFormedBranch (c, i, actty, expty) -> - explain_ill_formed_branch env sigma c i actty expty - | Generalization (nvar, c) -> - explain_generalization env sigma nvar c - | ActualType (j, pt) -> - explain_actual_type env sigma j pt None - | CantApplyBadType (t, rator, randl) -> - explain_cant_apply_bad_type env sigma t rator randl - | CantApplyNonFunctional (rator, randl) -> - explain_cant_apply_not_functional env sigma rator randl - | IllFormedRecBody (err, lna, i, fixenv, vdefj) -> - explain_ill_formed_rec_body env sigma err lna i fixenv vdefj - | IllTypedRecBody (i, lna, vdefj, vargs) -> - explain_ill_typed_rec_body env sigma i lna vdefj vargs - | WrongCaseInfo (ind,ci) -> - explain_wrong_case_info env ind ci - | UnsatisfiedConstraints cst -> - explain_unsatisfied_constraints env sigma cst - -let pr_position (cl,pos) = - let clpos = match cl with - | None -> str " of the goal" - | Some (id,Locus.InHyp) -> str " of hypothesis " ++ pr_id id - | Some (id,Locus.InHypTypeOnly) -> str " of the type of hypothesis " ++ pr_id id - | Some (id,Locus.InHypValueOnly) -> str " of the body of hypothesis " ++ pr_id id in - int pos ++ clpos - -let explain_cannot_unify_occurrences env sigma nested ((cl2,pos2),t2) ((cl1,pos1),t1) e = - if nested then - str "Found nested occurrences of the pattern at positions " ++ - int pos1 ++ strbrk " and " ++ pr_position (cl2,pos2) ++ str "." - else - let ppreason = match e with None -> mt() | Some (c1,c2,e) -> explain_unification_error env sigma c1 c2 (Some e) in - str "Found incompatible occurrences of the pattern" ++ str ":" ++ - spc () ++ str "Matched term " ++ pr_lconstr_env env sigma t2 ++ - strbrk " at position " ++ pr_position (cl2,pos2) ++ - strbrk " is not compatible with matched term " ++ - pr_lconstr_env env sigma t1 ++ strbrk " at position " ++ - pr_position (cl1,pos1) ++ ppreason ++ str "." - -let pr_constraints printenv env sigma evars cstrs = - let (ev, evi) = Evar.Map.choose evars in - if Evar.Map.for_all (fun ev' evi' -> - eq_named_context_val evi.evar_hyps evi'.evar_hyps) evars - then - let l = Evar.Map.bindings evars in - let env' = reset_with_named_context evi.evar_hyps env in - let pe = - if printenv then - pr_ne_context_of (str "In environment:") env' sigma - else mt () - in - let evs = - prlist - (fun (ev, evi) -> fnl () ++ pr_existential_key sigma ev ++ - str " : " ++ pr_lconstr_env env' sigma evi.evar_concl ++ fnl ()) l - in - h 0 (pe ++ evs ++ pr_evar_constraints cstrs) - else - let filter evk _ = Evar.Map.mem evk evars in - pr_evar_map_filter ~with_univs:false filter sigma - -let explain_unsatisfiable_constraints env sigma constr comp = - let (_, constraints) = Evd.extract_all_conv_pbs sigma in - let undef = Evd.undefined_map (Evarutil.nf_evar_map_undefined sigma) in - (** Only keep evars that are subject to resolution and members of the given - component. *) - let is_kept evk evi = match comp with - | None -> Typeclasses.is_resolvable evi - | Some comp -> Typeclasses.is_resolvable evi && Evar.Set.mem evk comp - in - let undef = - let m = Evar.Map.filter is_kept undef in - if Evar.Map.is_empty m then undef - else m - in - match constr with - | None -> - str "Unable to satisfy the following constraints:" ++ fnl () ++ - pr_constraints true env sigma undef constraints - | Some (ev, k) -> - let cstr = - let remaining = Evar.Map.remove ev undef in - if not (Evar.Map.is_empty remaining) then - str "With the following constraints:" ++ fnl () ++ - pr_constraints false env sigma remaining constraints - else mt () - in - let info = Evar.Map.find ev undef in - explain_typeclass_resolution env sigma info k ++ fnl () ++ cstr - -let explain_pretype_error env sigma err = - 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 - | ActualTypeNotCoercible (j,t,e) -> - 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 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 - | UnexpectedType (actual,expect) -> - let env, actual, expect = contract2 env actual expect in - explain_unexpected_type env sigma actual expect - | NotProduct c -> explain_not_product env sigma c - | CannotUnify (m,n,e) -> - let env, m, n = contract2 env m n in - explain_cannot_unify env sigma m n e - | CannotUnifyLocal (m,n,sn) -> explain_cannot_unify_local env sigma m n sn - | CannotGeneralize ty -> explain_refiner_cannot_generalize env sigma ty - | NoOccurrenceFound (c, id) -> explain_no_occurrence_found env sigma c id - | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env sigma m n - | CannotFindWellTypedAbstraction (p,l,e) -> - explain_cannot_find_well_typed_abstraction env sigma p l - (Option.map (fun (env',e) -> explain_type_error env' sigma e) e) - | WrongAbstractionType (n,a,t,u) -> - explain_wrong_abstraction_type env sigma n a t u - | AbstractionOverMeta (m,n) -> explain_abstraction_over_meta env m n - | NonLinearUnification (m,c) -> explain_non_linear_unification env sigma m c - | TypingError t -> explain_type_error env sigma t - | CannotUnifyOccurrences (b,c1,c2,e) -> explain_cannot_unify_occurrences env sigma b c1 c2 e - | UnsatisfiableConstraints (c,comp) -> explain_unsatisfiable_constraints env sigma c comp -(* Module errors *) - -open Modops - -let explain_not_match_error = function - | InductiveFieldExpected _ -> - strbrk "an inductive definition is expected" - | DefinitionFieldExpected -> - strbrk "a definition is expected" - | ModuleFieldExpected -> - strbrk "a module is expected" - | ModuleTypeFieldExpected -> - strbrk "a module type is expected" - | NotConvertibleInductiveField id | NotConvertibleConstructorField id -> - str "types given to " ++ pr_id id ++ str " differ" - | NotConvertibleBodyField -> - str "the body of definitions differs" - | NotConvertibleTypeField (env, typ1, typ2) -> - str "expected type" ++ spc () ++ - quote (Printer.safe_pr_lconstr_env env Evd.empty typ2) ++ spc () ++ - str "but found type" ++ spc () ++ - quote (Printer.safe_pr_lconstr_env env Evd.empty typ1) - | NotSameConstructorNamesField -> - str "constructor names differ" - | NotSameInductiveNameInBlockField -> - str "inductive types names differ" - | FiniteInductiveFieldExpected isfinite -> - str "type is expected to be " ++ - str (if isfinite then "coinductive" else "inductive") - | InductiveNumbersFieldExpected n -> - str "number of inductive types differs" - | InductiveParamsNumberField n -> - str "inductive type has not the right number of parameters" - | RecordFieldExpected isrecord -> - str "type is expected " ++ str (if isrecord then "" else "not ") ++ - str "to be a record" - | RecordProjectionsExpected nal -> - (if List.length nal >= 2 then str "expected projection names are " - else str "expected projection name is ") ++ - pr_enum (function Name id -> pr_id id | _ -> str "_") nal - | NotEqualInductiveAliases -> - str "Aliases to inductive types do not match" - | NoTypeConstraintExpected -> - strbrk "a definition whose type is constrained can only be subtype " ++ - strbrk "of a definition whose type is itself constrained" - | PolymorphicStatusExpected b -> - let status b = if b then str"polymorphic" else str"monomorphic" in - str "a " ++ status b ++ str" declaration was expected, but a " ++ - status (not b) ++ str" declaration was found" - | IncompatibleInstances -> - str"polymorphic universe instances do not match" - | IncompatibleUniverses incon -> - str"the universe constraints are inconsistent: " ++ - Univ.explain_universe_inconsistency Universes.pr_with_global_universes incon - | IncompatiblePolymorphism (env, t1, t2) -> - str "conversion of polymorphic values generates additional constraints: " ++ - quote (Printer.safe_pr_lconstr_env env Evd.empty t1) ++ spc () ++ - str "compared to " ++ spc () ++ - quote (Printer.safe_pr_lconstr_env env Evd.empty t2) - | IncompatibleConstraints cst -> - str " the expected (polymorphic) constraints do not imply " ++ - quote (Univ.pr_constraints (Evd.pr_evd_level Evd.empty) cst) - -let explain_signature_mismatch l spec why = - str "Signature components for label " ++ pr_label l ++ - str " do not match:" ++ spc () ++ explain_not_match_error why ++ str "." - -let explain_label_already_declared l = - str "The label " ++ pr_label l ++ str " is already declared." - -let explain_application_to_not_path _ = - strbrk "A module cannot be applied to another module application or " ++ - strbrk "with-expression; you must give a name to the intermediate result " ++ - strbrk "module first." - -let explain_not_a_functor () = - str "Application of a non-functor." - -let explain_is_a_functor () = - str "Illegal use of a functor." - -let explain_incompatible_module_types mexpr1 mexpr2 = - 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." - -let explain_no_such_label l = - str "No such label " ++ pr_label l ++ str "." - -let explain_incompatible_labels l l' = - str "Opening and closing labels are not the same: " ++ - pr_label l ++ str " <> " ++ pr_label l' ++ str "!" - -let explain_not_a_module s = - quote (str s) ++ str " is not a module." - -let explain_not_a_module_type s = - quote (str s) ++ str " is not a module type." - -let explain_not_a_constant l = - quote (pr_label l) ++ str " is not a constant." - -let explain_incorrect_label_constraint l = - str "Incorrect constraint for label " ++ - quote (pr_label l) ++ str "." - -let explain_generative_module_expected l = - 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 " ++ pr_label 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 - | ApplicationToNotPath mexpr -> explain_application_to_not_path mexpr - | NotAFunctor -> explain_not_a_functor () - | IsAFunctor -> explain_is_a_functor () - | IncompatibleModuleTypes (m1,m2) -> explain_incompatible_module_types m1 m2 - | NotEqualModulePaths (mp1,mp2) -> explain_not_equal_module_paths mp1 mp2 - | NoSuchLabel l -> explain_no_such_label l - | IncompatibleLabels (l1,l2) -> explain_incompatible_labels l1 l2 - | NotAModule s -> explain_not_a_module s - | NotAModuleType s -> explain_not_a_module_type s - | NotAConstant l -> explain_not_a_constant l - | 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 *) - -(* -let explain_declaration_not_path _ = - str "Declaration is not a path." - -*) - -let explain_not_module_nor_modtype s = - quote (str s) ++ str " is not a module or module type." - -let explain_incorrect_with_in_module () = - str "The syntax \"with\" is not allowed for modules." - -let explain_incorrect_module_application () = - str "Illegal application to a module type." - -open Modintern - -let explain_module_internalization_error = function - | NotAModuleNorModtype s -> explain_not_module_nor_modtype s - | IncorrectWithInModule -> explain_incorrect_with_in_module () - | IncorrectModuleApplication -> explain_incorrect_module_application () - -(* Typeclass errors *) - -let explain_not_a_class env c = - pr_constr_env env Evd.empty c ++ str" is not a declared type class." - -let explain_unbound_method env cid id = - str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++ - str"of class" ++ spc () ++ pr_global cid ++ str "." - -let pr_constr_exprs exprs = - hv 0 (List.fold_right - (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr d ++ pps) - exprs (mt ())) - -let explain_mismatched_contexts env c i j = - str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++ - hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env Evd.empty j) ++ - fnl () ++ brk (1,1) ++ - hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i) - -let explain_typeclass_error env = function - | NotAClass c -> explain_not_a_class env c - | UnboundMethod (cid, id) -> explain_unbound_method env cid id - | MismatchedContextInstance (c,i,j) -> explain_mismatched_contexts env c i j - -(* Refiner errors *) - -let explain_refiner_bad_type arg ty conclty = - str "Refiner was given an argument" ++ brk(1,1) ++ - pr_lconstr arg ++ spc () ++ - str "of type" ++ brk(1,1) ++ pr_lconstr ty ++ spc () ++ - str "instead of" ++ brk(1,1) ++ pr_lconstr conclty ++ str "." - -let explain_refiner_unresolved_bindings l = - str "Unable to find an instance for the " ++ - str (String.plural (List.length l) "variable") ++ spc () ++ - prlist_with_sep pr_comma pr_name l ++ str"." - -let explain_refiner_cannot_apply t harg = - str "In refiner, a term of type" ++ brk(1,1) ++ - pr_lconstr t ++ spc () ++ str "could not be applied to" ++ brk(1,1) ++ - pr_lconstr harg ++ str "." - -let explain_refiner_not_well_typed c = - str "The term " ++ pr_lconstr c ++ str " is not well-typed." - -let explain_intro_needs_product () = - str "Introduction tactics needs products." - -let explain_does_not_occur_in c hyp = - str "The term" ++ spc () ++ pr_lconstr c ++ spc () ++ - str "does not occur in" ++ spc () ++ pr_id hyp ++ str "." - -let explain_non_linear_proof c = - str "Cannot refine with term" ++ brk(1,1) ++ pr_lconstr c ++ - spc () ++ str "because a metavariable has several occurrences." - -let explain_meta_in_type c = - str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++ - str " of another meta" - -let explain_no_such_hyp id = - str "No such hypothesis: " ++ pr_id id - -let explain_refiner_error = function - | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty - | UnresolvedBindings t -> explain_refiner_unresolved_bindings t - | CannotApply (t,harg) -> explain_refiner_cannot_apply t harg - | NotWellTyped c -> explain_refiner_not_well_typed c - | IntroNeedsProduct -> explain_intro_needs_product () - | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp - | NonLinearProof c -> explain_non_linear_proof c - | MetaInType c -> explain_meta_in_type c - | NoSuchHyp id -> explain_no_such_hyp id - -(* Inductive errors *) - -let error_non_strictly_positive env c v = - let pc = pr_lconstr_env env Evd.empty c in - let pv = pr_lconstr_env env Evd.empty v in - str "Non strictly positive occurrence of " ++ pv ++ str " in" ++ - brk(1,1) ++ pc ++ str "." - -let error_ill_formed_inductive env c v = - let pc = pr_lconstr_env env Evd.empty c in - let pv = pr_lconstr_env env Evd.empty v in - str "Not enough arguments applied to the " ++ pv ++ - str " in" ++ brk(1,1) ++ pc ++ str "." - -let error_ill_formed_constructor env id c v nparams nargs = - let pv = pr_lconstr_env env Evd.empty v in - let atomic = Int.equal (nb_prod c) 0 in - str "The type of constructor" ++ brk(1,1) ++ pr_id id ++ brk(1,1) ++ - str "is not valid;" ++ brk(1,1) ++ - strbrk (if atomic then "it must be " else "its conclusion must be ") ++ - pv ++ - (* warning: because of implicit arguments it is difficult to say which - parameters must be explicitly given *) - (if not (Int.equal nparams 0) then - strbrk " applied to its " ++ str (String.plural nparams "parameter") - else - mt()) ++ - (if not (Int.equal nargs 0) then - str (if not (Int.equal nparams 0) then " and" else " applied") ++ - strbrk " to some " ++ str (String.plural nargs "argument") - else - mt()) ++ str "." - -let pr_ltype_using_barendregt_convention_env env c = - (* Use goal_concl_style as an approximation of Barendregt's convention (?) *) - quote (pr_goal_concl_style_env env Evd.empty c) - -let error_bad_ind_parameters env c n v1 v2 = - let pc = pr_ltype_using_barendregt_convention_env env c in - let pv1 = pr_lconstr_env env Evd.empty v1 in - let pv2 = pr_lconstr_env env Evd.empty v2 in - str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++ - str " as " ++ pr_nth n ++ str " argument in" ++ brk(1,1) ++ pc ++ str "." - -let error_same_names_types id = - str "The name" ++ spc () ++ pr_id id ++ spc () ++ - str "is used more than once." - -let error_same_names_constructors id = - str "The constructor name" ++ spc () ++ pr_id id ++ spc () ++ - str "is used more than once." - -let error_same_names_overlap idl = - strbrk "The following names are used both as type names and constructor " ++ - str "names:" ++ spc () ++ - prlist_with_sep pr_comma pr_id idl ++ str "." - -let error_not_an_arity env c = - str "The type" ++ spc () ++ pr_lconstr_env env Evd.empty c ++ spc () ++ - str "is not an arity." - -let error_bad_entry () = - str "Bad inductive definition." - -let error_large_non_prop_inductive_not_in_type () = - str "Large non-propositional inductive types must be in Type." - -(* Recursion schemes errors *) - -let error_not_allowed_case_analysis isrec kind i = - str (if isrec then "Induction" else "Case analysis") ++ - strbrk " on sort " ++ pr_sort Evd.empty kind ++ - strbrk " is not allowed for inductive definition " ++ - pr_inductive (Global.env()) (fst i) ++ str "." - -let error_not_allowed_dependent_analysis isrec i = - str "Dependent " ++ str (if isrec then "Induction" else "Case analysis") ++ - strbrk " is not allowed for inductive definition " ++ - pr_inductive (Global.env()) i ++ str "." - -let error_not_mutual_in_scheme ind ind' = - if eq_ind ind ind' then - str "The inductive type " ++ pr_inductive (Global.env()) ind ++ - str " occurs twice." - else - str "The inductive types " ++ pr_inductive (Global.env()) ind ++ spc () ++ - str "and" ++ spc () ++ pr_inductive (Global.env()) ind' ++ spc () ++ - str "are not mutually defined." - -(* Inductive constructions errors *) - -let explain_inductive_error = function - | NonPos (env,c,v) -> error_non_strictly_positive env c v - | NotEnoughArgs (env,c,v) -> error_ill_formed_inductive env c v - | NotConstructor (env,id,c,v,n,m) -> - error_ill_formed_constructor env id c v n m - | NonPar (env,c,n,v1,v2) -> error_bad_ind_parameters env c n v1 v2 - | SameNamesTypes id -> error_same_names_types id - | SameNamesConstructors id -> error_same_names_constructors id - | SameNamesOverlap idl -> error_same_names_overlap idl - | NotAnArity (env, c) -> error_not_an_arity env c - | BadEntry -> error_bad_entry () - | LargeNonPropInductiveNotInType -> - error_large_non_prop_inductive_not_in_type () - -(* Recursion schemes errors *) - -let explain_recursion_scheme_error = function - | NotAllowedCaseAnalysis (isrec,k,i) -> - error_not_allowed_case_analysis isrec k i - | NotMutualInScheme (ind,ind')-> error_not_mutual_in_scheme ind ind' - | NotAllowedDependentAnalysis (isrec, i) -> - error_not_allowed_dependent_analysis isrec i - -(* Pattern-matching errors *) - -let explain_bad_pattern env sigma cstr ty = - let env = make_all_name_different env in - let pt = pr_lconstr_env env sigma ty in - let pc = pr_constructor env cstr in - str "Found the constructor " ++ pc ++ brk(1,1) ++ - str "while matching a term of type " ++ pt ++ brk(1,1) ++ - str "which is not an inductive type." - -let explain_bad_constructor env cstr ind = - let pi = pr_inductive env ind in -(* let pc = pr_constructor env cstr in*) - let pt = pr_inductive env (inductive_of_constructor cstr) in - str "Found a constructor of inductive type " ++ pt ++ brk(1,1) ++ - str "while a constructor of " ++ pi ++ brk(1,1) ++ - str "is expected." - -let decline_string n s = - if Int.equal n 0 then str "no " ++ str s ++ str "s" - else if Int.equal n 1 then str "1 " ++ str s - else (int n ++ str " " ++ str s ++ str "s") - -let explain_wrong_numarg_constructor env cstr n = - str "The constructor " ++ pr_constructor env cstr ++ - str " (in type " ++ pr_inductive env (inductive_of_constructor cstr) ++ - str ") expects " ++ decline_string n "argument" ++ str "." - -let explain_wrong_numarg_inductive env ind n = - str "The inductive type " ++ pr_inductive env ind ++ - str " expects " ++ decline_string n "argument" ++ str "." - -let explain_unused_clause env pats = -(* Without localisation - let s = if List.length pats > 1 then "s" else "" in - (str ("Unused clause with pattern"^s) ++ spc () ++ - hov 0 (pr_sequence pr_cases_pattern pats) ++ str ")") -*) - str "This clause is redundant." - -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 (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 - let pr_branch (cstr,typ) = - let cstr,_ = decompose_app cstr in - str "For " ++ pr_lconstr_env env sigma cstr ++ str ": " ++ pr_lconstr_env env sigma typ - in - str "Unable to unify the types found in the branches:" ++ - spc () ++ hov 0 (prlist_with_sep fnl pr_branch (Array.to_list typs)) - -let explain_pattern_matching_error env sigma = function - | BadPattern (c,t) -> - explain_bad_pattern env sigma c t - | BadConstructor (c,ind) -> - explain_bad_constructor env c ind - | WrongNumargConstructor (c,n) -> - explain_wrong_numarg_constructor env c n - | WrongNumargInductive (c,n) -> - explain_wrong_numarg_inductive env c n - | UnusedClause tms -> - explain_unused_clause env tms - | NonExhaustive tms -> - explain_non_exhaustive env tms - | CannotInferPredicate typs -> - explain_cannot_infer_predicate env sigma typs - -let explain_reduction_tactic_error = function - | Tacred.InvalidAbstraction (env,sigma,c,(env',e)) -> - str "The abstracted term" ++ spc () ++ - quote (pr_goal_concl_style_env env sigma c) ++ - spc () ++ str "is not well typed." ++ fnl () ++ - explain_type_error env' Evd.empty e diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli deleted file mode 100644 index ced54fd279..0000000000 --- a/toplevel/himsg.mli +++ /dev/null @@ -1,42 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Evd.evar_map -> type_error -> std_ppcmds - -val explain_pretype_error : env -> Evd.evar_map -> pretype_error -> std_ppcmds - -val explain_inductive_error : inductive_error -> std_ppcmds - -val explain_typeclass_error : env -> typeclass_error -> Pp.std_ppcmds - -val explain_recursion_scheme_error : recursion_scheme_error -> std_ppcmds - -val explain_refiner_error : refiner_error -> std_ppcmds - -val explain_pattern_matching_error : - env -> Evd.evar_map -> pattern_matching_error -> std_ppcmds - -val explain_reduction_tactic_error : - Tacred.reduction_tactic_error -> std_ppcmds - -val explain_module_error : Modops.module_typing_error -> std_ppcmds - -val explain_module_internalization_error : - Modintern.module_internalization_error -> std_ppcmds diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml deleted file mode 100644 index 85d0b6194c..0000000000 --- a/toplevel/ind_tables.ml +++ /dev/null @@ -1,203 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 * Safe_typing.private_constants - -type 'a scheme_kind = string - -let scheme_map = Summary.ref Indmap.empty ~name:"Schemes" - -let pr_scheme_kind = Pp.str - -let cache_one_scheme kind (ind,const) = - let map = try Indmap.find ind !scheme_map with Not_found -> String.Map.empty in - scheme_map := Indmap.add ind (String.Map.add kind const map) !scheme_map - -let cache_scheme (_,(kind,l)) = - Array.iter (cache_one_scheme kind) l - -let subst_one_scheme subst (ind,const) = - (* Remark: const is a def: the result of substitution is a constant *) - (subst_ind subst ind,subst_constant subst const) - -let subst_scheme (subst,(kind,l)) = - (kind,Array.map (subst_one_scheme subst) l) - -let discharge_scheme (_,(kind,l)) = - Some (kind,Array.map (fun (ind,const) -> - (Lib.discharge_inductive ind,Lib.discharge_con const)) l) - -let inScheme : string * (inductive * constant) array -> obj = - declare_object {(default_object "SCHEME") with - cache_function = cache_scheme; - load_function = (fun _ -> cache_scheme); - subst_function = subst_scheme; - classify_function = (fun obj -> Substitute obj); - discharge_function = discharge_scheme} - -(**********************************************************************) -(* The table of scheme building functions *) - -type individual -type mutual - -type scheme_object_function = - | MutualSchemeFunction of mutual_scheme_object_function - | IndividualSchemeFunction of individual_scheme_object_function - -let scheme_object_table = - (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t) - -let declare_scheme_object s aux f = - let () = - if not (Id.is_valid ("ind" ^ s)) then - error ("Illegal induction scheme suffix: " ^ s) - in - let key = if String.is_empty aux then s else aux in - try - let _ = Hashtbl.find scheme_object_table key in -(* let aux_msg = if aux="" then "" else " (with key "^aux^")" in*) - user_err ~hdr:"IndTables.declare_scheme_object" - (str "Scheme object " ++ str key ++ str " already declared.") - with Not_found -> - Hashtbl.add scheme_object_table key (s,f); - key - -let declare_mutual_scheme_object s ?(aux="") f = - declare_scheme_object s aux (MutualSchemeFunction f) - -let declare_individual_scheme_object s ?(aux="") f = - declare_scheme_object s aux (IndividualSchemeFunction f) - -(**********************************************************************) -(* Defining/retrieving schemes *) - -let declare_scheme kind indcl = - Lib.add_anonymous_leaf (inScheme (kind,indcl)) - -let () = Declare.set_declare_scheme declare_scheme - -let is_visible_name id = - try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true - with Not_found -> false - -let compute_name internal id = - match internal with - | UserAutomaticRequest | UserIndividualRequest -> id - | InternalTacticRequest -> - Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name - -let define internal id c p univs = - let fd = declare_constant ~internal in - let id = compute_name internal id in - let ctx = Evd.normalize_evar_universe_context univs in - 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), - Safe_typing.empty_private_constants); - const_entry_secctx = None; - const_entry_type = None; - const_entry_polymorphic = p; - const_entry_universes = Evd.evar_context_universe_context ctx; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in - let kn = fd id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in - let () = match internal with - | InternalTacticRequest -> () - | _-> definition_message id - in - kn - -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 mode id c mib.mind_polymorphic ctx in - declare_scheme kind [|ind,const|]; - 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 - | _,MutualSchemeFunction f -> assert false - | s,IndividualSchemeFunction f -> - define_individual_scheme_base kind s f mode names ind - -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 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, - Safe_typing.add_private - (Safe_typing.private_con_of_scheme - kind (Global.safe_env()) (Array.to_list schemes)) - eff - -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 mode names mind - -let find_scheme_on_env_too kind ind = - let s = String.Map.find kind (Indmap.find ind !scheme_map) in - s, Safe_typing.add_private - (Safe_typing.private_con_of_scheme - kind (Global.safe_env()) [ind, s]) - Safe_typing.empty_private_constants - -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 - | s,IndividualSchemeFunction f -> - define_individual_scheme_base kind s f mode None ind - | s,MutualSchemeFunction f -> - let ca, eff = define_mutual_scheme_base kind s f mode [] mind in - ca.(i), eff - -let check_scheme kind ind = - try let _ = find_scheme_on_env_too kind ind in true - with Not_found -> false diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli deleted file mode 100644 index 20f30d6d16..0000000000 --- a/toplevel/ind_tables.mli +++ /dev/null @@ -1,51 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 * Safe_typing.private_constants - -(** Main functions to register a scheme builder *) - -val declare_mutual_scheme_object : string -> ?aux:string -> - mutual_scheme_object_function -> mutual scheme_kind - -val declare_individual_scheme_object : string -> ?aux:string -> - individual_scheme_object_function -> - individual scheme_kind - -(** Force generation of a (mutually) scheme with possibly user-level names *) - -val define_individual_scheme : individual scheme_kind -> - internal_flag (** internal *) -> - 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 * 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 * Safe_typing.private_constants - -val check_scheme : 'a scheme_kind -> inductive -> bool - - -val pr_scheme_kind : 'a scheme_kind -> Pp.std_ppcmds diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml deleted file mode 100644 index f7e3f0d954..0000000000 --- a/toplevel/indschemes.ml +++ /dev/null @@ -1,530 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* !elim_flag) ; - optwrite = (fun b -> elim_flag := b) } - -let bifinite_elim_flag = ref false -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "automatic declaration of induction schemes for non-recursive types"; - optkey = ["Nonrecursive";"Elimination";"Schemes"]; - optread = (fun () -> !bifinite_elim_flag) ; - optwrite = (fun b -> bifinite_elim_flag := b) } -let _ = - declare_bool_option - { optsync = true; - optdepr = true; (* compatibility 2014-09-03*) - optname = "automatic declaration of induction schemes for non-recursive types"; - optkey = ["Record";"Elimination";"Schemes"]; - optread = (fun () -> !bifinite_elim_flag) ; - optwrite = (fun b -> bifinite_elim_flag := b) } - -let case_flag = ref false -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "automatic declaration of case analysis schemes"; - optkey = ["Case";"Analysis";"Schemes"]; - optread = (fun () -> !case_flag) ; - optwrite = (fun b -> case_flag := b) } - -let eq_flag = ref false -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "automatic declaration of boolean equality"; - optkey = ["Boolean";"Equality";"Schemes"]; - optread = (fun () -> !eq_flag) ; - optwrite = (fun b -> eq_flag := b) } -let _ = (* compatibility *) - declare_bool_option - { optsync = true; - optdepr = true; - optname = "automatic declaration of boolean equality"; - optkey = ["Equality";"Scheme"]; - optread = (fun () -> !eq_flag) ; - optwrite = (fun b -> eq_flag := b) } - -let is_eq_flag () = !eq_flag && Flags.version_strictly_greater Flags.V8_2 - -let eq_dec_flag = ref false -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "automatic declaration of decidable equality"; - optkey = ["Decidable";"Equality";"Schemes"]; - optread = (fun () -> !eq_dec_flag) ; - optwrite = (fun b -> eq_dec_flag := b) } - -let rewriting_flag = ref false -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname ="automatic declaration of rewriting schemes for equality types"; - optkey = ["Rewriting";"Schemes"]; - optread = (fun () -> !rewriting_flag) ; - optwrite = (fun b -> rewriting_flag := b) } - -(* Util *) - -let define id internal ctx c t = - let f = declare_constant ~internal in - let kn = f id - (DefinitionEntry - { const_entry_body = c; - const_entry_secctx = None; - const_entry_type = t; - const_entry_polymorphic = Flags.is_universe_polymorphism (); - const_entry_universes = snd (Evd.universe_context ctx); - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - }, - Decl_kinds.IsDefinition Scheme) in - definition_message id; - kn - -(* Boolean equality *) - -let declare_beq_scheme_gen internal names kn = - ignore (define_mutual_scheme beq_scheme_kind internal names kn) - -let alarm what internal msg = - let debug = false in - match internal with - | UserAutomaticRequest - | InternalTacticRequest -> - (if debug then - Feedback.msg_debug - (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 e -> - let e = CErrors.push e in - let msg = match fst e with - | ParameterWithoutEquality cst -> - alarm what internal - (str "Boolean equality not found for parameter " ++ Printer.pr_global cst ++ - str".") - | InductiveWithProduct -> - alarm what internal - (str "Unable to decide equality of functional arguments.") - | InductiveWithSort -> - alarm what internal - (str "Unable to decide equality of type arguments.") - | NonSingletonProp ind -> - alarm what internal - (str "Cannot extract computational content from proposition " ++ - quote (Printer.pr_inductive (Global.env()) ind) ++ str ".") - | EqNotFound (ind',ind) -> - alarm what internal - (str "Boolean equality on " ++ - quote (Printer.pr_inductive (Global.env()) ind') ++ - strbrk " is missing.") - | UndefinedCst s -> - alarm what internal - (strbrk "Required constant " ++ str s ++ str " undefined.") - | AlreadyDeclared msg -> - alarm what internal (msg ++ str ".") - | DecidabilityMutualNotSupported -> - alarm what internal - (str "Decidability lemma for mutual inductive types not supported.") - | EqUnknown s -> - alarm what internal - (str "Found unsupported " ++ str s ++ str " while building Boolean equality.") - | NoDecidabilityCoInductive -> - alarm what internal - (str "Scheme Equality is only for inductive types.") - | e when CErrors.noncritical e -> - alarm what internal - (str "Unexpected error during scheme creation: " ++ CErrors.print e) - | _ -> iraise e - in - match msg with - | None -> () - | Some msg -> iraise (UserError (None, msg), snd e) - -let beq_scheme_msg mind = - let mib = Global.lookup_mind mind in - (* TODO: mutual inductive case *) - str "Boolean equality on " ++ - pr_enum (fun ind -> quote (Printer.pr_inductive (Global.env()) ind)) - (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 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 UserAutomaticRequest [] kn - -let declare_beq_scheme = declare_beq_scheme_with [] - -(* Case analysis schemes *) -let declare_one_case_analysis_scheme ind = - let (mib,mip) = Global.lookup_inductive ind in - let kind = inductive_sort_family mip in - let dep = - if kind == InProp then case_scheme_kind_from_prop - else if not (Inductiveops.has_dependent_elim mib) then - case_scheme_kind_from_type - else case_dep_scheme_kind_from_type in - let kelim = elim_sorts (mib,mip) in - (* in case the inductive has a type elimination, generates only one - 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 UserAutomaticRequest None ind) - -(* Induction/recursion schemes *) - -let kinds_from_prop = - [InType,rect_scheme_kind_from_prop; - InProp,ind_scheme_kind_from_prop; - InSet,rec_scheme_kind_from_prop] - -let kinds_from_type = - [InType,rect_dep_scheme_kind_from_type; - InProp,ind_dep_scheme_kind_from_type; - InSet,rec_dep_scheme_kind_from_type] - -let nondep_kinds_from_type = - [InType,rect_scheme_kind_from_type; - InProp,ind_scheme_kind_from_type; - InSet,rec_scheme_kind_from_type] - -let declare_one_induction_scheme ind = - let (mib,mip) = Global.lookup_inductive ind in - let kind = inductive_sort_family mip in - let from_prop = kind == InProp in - let depelim = Inductiveops.has_dependent_elim mib in - let kelim = elim_sorts (mib,mip) in - let elims = - 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 if depelim then kinds_from_type - else nondep_kinds_from_type) in - List.iter (fun kind -> ignore (define_individual_scheme kind UserAutomaticRequest None ind)) - elims - -let declare_induction_schemes kn = - let mib = Global.lookup_mind kn in - if mib.mind_finite <> Decl_kinds.CoFinite then begin - for i = 0 to Array.length mib.mind_packets - 1 do - declare_one_induction_scheme (kn,i); - done; - end - -(* Decidable equality *) - -let declare_eq_decidability_gen internal names kn = - let mib = Global.lookup_mind kn in - if mib.mind_finite <> Decl_kinds.CoFinite then - ignore (define_mutual_scheme eq_dec_scheme_kind internal names kn) - -let eq_dec_scheme_msg ind = (* TODO: mutual inductive case *) - str "Decidable equality on " ++ quote (Printer.pr_inductive (Global.env()) ind) - -let declare_eq_decidability_scheme_with l kn = - try_declare_scheme (eq_dec_scheme_msg (kn,0)) - 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 UserAutomaticRequest [] kn - -let declare_eq_decidability = declare_eq_decidability_scheme_with [] - -let ignore_error f x = - try ignore (f x) with e when CErrors.noncritical e -> () - -let declare_rewriting_schemes ind = - if Hipattern.is_inductive_equality ind then begin - 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 - 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 UserAutomaticRequest None) ind; - ignore_error - (define_individual_scheme rew_l2r_dep_scheme_kind UserAutomaticRequest None) ind; - ignore_error - (define_individual_scheme rew_l2r_forward_dep_scheme_kind UserAutomaticRequest None) ind - end - -let warn_cannot_build_congruence = - CWarnings.create ~name:"cannot-build-congruence" ~category:"schemes" - (fun () -> - strbrk "Cannot build congruence scheme because eq is not found") - -let declare_congr_scheme ind = - if Hipattern.is_equality_type (mkInd ind) then begin - if - try Coqlib.check_required_library Coqlib.logic_module_name; true - with e when CErrors.noncritical e -> false - then - ignore (define_individual_scheme congr_scheme_kind UserAutomaticRequest None ind) - else - warn_cannot_build_congruence () - end - -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 UserAutomaticRequest None) ind - -(* Scheme command *) - -let smart_global_inductive y = smart_global_inductive y -let rec split_scheme l = - let env = Global.env() in - match l with - | [] -> [],[] - | (Some id,t)::q -> let l1,l2 = split_scheme q in - ( match t with - | InductionScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2 - | CaseScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2 - | EqualityScheme x -> l1,((Some id,smart_global_inductive x)::l2) - ) -(* - if no name has been provided, we build one from the types of the ind -requested -*) - | (None,t)::q -> - let l1,l2 = split_scheme q in - let names inds recs isdep y z = - let ind = smart_global_inductive y in - let sort_of_ind = inductive_sort_family (snd (lookup_mind_specif env ind)) in - let z' = interp_elimination_sort z in - let suffix = ( - match sort_of_ind with - | InProp -> - if isdep then (match z' with - | InProp -> inds ^ "_dep" - | InSet -> recs ^ "_dep" - | InType -> recs ^ "t_dep") - else ( match z' with - | InProp -> inds - | InSet -> recs - | InType -> recs ^ "t" ) - | _ -> - if isdep then (match z' with - | InProp -> inds - | InSet -> recs - | InType -> recs ^ "t" ) - else (match z' with - | InProp -> inds ^ "_nodep" - | InSet -> recs ^ "_nodep" - | InType -> recs ^ "t_nodep") - ) in - let newid = add_suffix (basename_of_global (IndRef ind)) suffix in - let newref = (Loc.ghost,newid) in - ((newref,isdep,ind,z)::l1),l2 - in - match t with - | CaseScheme (x,y,z) -> names "_case" "_case" x y z - | InductionScheme (x,y,z) -> names "_ind" "_rec" x y z - | EqualityScheme x -> l1,((None,smart_global_inductive x)::l2) - - -let do_mutual_induction_scheme lnamedepindsort = - let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort - and env0 = Global.env() in - let sigma, lrecspec, _ = - List.fold_right - (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 = - let decltype = Retyping.get_type_of env0 sigma decl 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 - let _ = List.fold_right2 declare listdecl lrecnames [] in - fixpoint_message None lrecnames - -let get_common_underlying_mutual_inductive = function - | [] -> assert false - | (id,(mind,i as ind))::l as all -> - match List.filter (fun (_,(mind',_)) -> not (eq_mind mind mind')) l with - | (_,ind')::_ -> - raise (RecursionSchemeError (NotMutualInScheme (ind,ind'))) - | [] -> - if not (List.distinct_f Int.compare (List.map snd (List.map snd all))) - then error "A type occurs twice"; - mind, - List.map_filter - (function (Some id,(_,i)) -> Some (i,snd id) | (None,_) -> None) all - -let do_scheme l = - let ischeme,escheme = split_scheme l in -(* we want 1 kind of scheme at a time so we check if the user -tried to declare different schemes at once *) - if not (List.is_empty ischeme) && not (List.is_empty escheme) - then - error "Do not declare equality and induction scheme at the same time." - else ( - if not (List.is_empty ischeme) then do_mutual_induction_scheme ischeme - else - let mind,l = get_common_underlying_mutual_inductive escheme in - declare_beq_scheme_with l mind; - declare_eq_decidability_scheme_with l mind - ) - -(**********************************************************************) -(* Combined scheme *) -(* Matthieu Sozeau, Dec 2006 *) - -let list_split_rev_at index l = - let rec aux i acc = function - hd :: tl when Int.equal i index -> acc, tl - | hd :: tl -> aux (succ i) (hd :: acc) tl - | [] -> failwith "List.split_when: Invalid argument" - in aux 0 [] l - -let fold_left' f = function - [] -> invalid_arg "fold_left'" - | hd :: tl -> List.fold_left f hd tl - -let build_combined_scheme env schemes = - let defs = List.map (fun cst -> (* FIXME *) - 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 = - let (ctx, arity) = decompose_prod ty in - let (_, last) = List.hd ctx in - match kind_of_term last with - | App (ind, args) -> - let ind = destInd ind in - let (_,spec) = Inductive.lookup_mind_specif env (fst ind) in - ctx, ind, spec.mind_nrealargs - | _ -> ctx, destInd last, 0 - in - let (c, t) = List.hd defs in - let ctx, ind, nargs = find_inductive t in - (* Number of clauses, including the predicates quantification *) - let prods = nb_prod t - (nargs + 1) in - let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in - let relargs = rel_vect 0 prods in - let concls = List.rev_map - (fun (cst, t) -> (* FIXME *) - mkApp(mkConstU cst, relargs), - snd (decompose_prod_n prods t)) defs in - let concl_bod, concl_typ = - fold_left' - (fun (accb, acct) (cst, x) -> - mkApp (coqconj, [| x; acct; cst; accb |]), - mkApp (coqand, [| x; acct |])) concls - in - let ctx, _ = - list_split_rev_at prods - (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) - -let do_combined_scheme name schemes = - let csts = - List.map (fun x -> - let refe = Ident x in - let qualid = qualid_of_reference refe in - try Nametab.locate_constant (snd qualid) - with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared.")) - schemes - in - let body,typ = build_combined_scheme (Global.env ()) csts 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] - -(**********************************************************************) - -let map_inductive_block f kn n = for i=0 to n-1 do f (kn,i) done - -let declare_default_schemes kn = - let mib = Global.lookup_mind kn in - let n = Array.length mib.mind_packets in - if !elim_flag && (mib.mind_finite <> BiFinite || !bifinite_elim_flag) - && mib.mind_typing_flags.check_guarded then - declare_induction_schemes kn; - if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n; - if is_eq_flag() then try_declare_beq_scheme kn; - if !eq_dec_flag then try_declare_eq_decidability kn; - if !rewriting_flag then map_inductive_block declare_congr_scheme kn n; - if !rewriting_flag then map_inductive_block declare_sym_scheme kn n; - if !rewriting_flag then map_inductive_block declare_rewriting_schemes kn n diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli deleted file mode 100644 index e5d79fd514..0000000000 --- a/toplevel/indschemes.mli +++ /dev/null @@ -1,49 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit - -val declare_eq_decidability : mutual_inductive -> unit - -(** Build and register a congruence scheme for an equality-like inductive type *) - -val declare_congr_scheme : inductive -> unit - -(** Build and register rewriting schemes for an equality-like inductive type *) - -val declare_rewriting_schemes : inductive -> unit - -(** Mutual Minimality/Induction scheme *) - -val do_mutual_induction_scheme : - (Id.t located * bool * inductive * glob_sort) list -> unit - -(** Main calls to interpret the Scheme command *) - -val do_scheme : (Id.t located option * scheme) list -> unit - -(** Combine a list of schemes into a conjunction of them *) - -val build_combined_scheme : env -> constant list -> constr * types - -val do_combined_scheme : Id.t located -> Id.t located list -> unit - -(** Hook called at each inductive type definition *) - -val declare_default_schemes : mutual_inductive -> unit diff --git a/toplevel/locality.ml b/toplevel/locality.ml deleted file mode 100644 index 03640676e6..0000000000 --- a/toplevel/locality.ml +++ /dev/null @@ -1,107 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Decl_kinds.Local - | false -> Decl_kinds.Global - -let check_locality locality_flag = - match locality_flag with - | Some b -> - let s = if b then "Local" else "Global" in - CErrors.user_err ~hdr:"Locality.check_locality" - (str "This command does not support the \"" ++ str s ++ str "\" prefix.") - | None -> () - -(** Extracting the locality flag *) - -(* Commands which supported an inlined Local flag *) - -let warn_deprecated_local_syntax = - CWarnings.create ~name:"deprecated-local-syntax" ~category:"deprecated" - (fun () -> - Pp.strbrk "Deprecated syntax: use \"Local\" as a prefix.") - -let enforce_locality_full locality_flag local = - let local = - match locality_flag with - | Some false when local -> - CErrors.error "Cannot be simultaneously Local and Global." - | Some true when local -> - CErrors.error "Use only prefix \"Local\"." - | None -> - if local then begin - warn_deprecated_local_syntax (); - Some true - end else - None - | Some b -> Some b in - local - -(** Positioning locality for commands supporting discharging and export - outside of modules *) - -(* For commands whose default is to discharge and export: - Global is the default and is neutral; - Local in a section deactivates discharge, - Local not in a section deactivates export *) -let make_non_locality = function Some false -> false | _ -> true - -let make_locality = function Some true -> true | _ -> false - -let enforce_locality locality_flag local = - make_locality (enforce_locality_full locality_flag local) - -let enforce_locality_exp locality_flag local = - match locality_flag, local with - | None, Some local -> local - | Some b, None -> local_of_bool b - | None, None -> Decl_kinds.Global - | Some _, Some _ -> CErrors.error "Local non allowed in this case" - -(* For commands whose default is to not discharge but to export: - Global in sections forces discharge, Global not in section is the default; - Local in sections is the default, Local not in section forces non-export *) - -let make_section_locality = - function Some b -> b | None -> Lib.sections_are_opened () - -let enforce_section_locality locality_flag local = - make_section_locality (enforce_locality_full locality_flag local) - -(** Positioning locality for commands supporting export but not discharge *) - -(* For commands whose default is to export (if not in section): - Global in sections is forbidden, Global not in section is neutral; - Local in sections is the default, Local not in section forces non-export *) - -let make_module_locality = function - | Some false -> - if Lib.sections_are_opened () then - CErrors.error - "This command does not support the Global option in sections."; - false - | Some true -> true - | None -> false - -let enforce_module_locality locality_flag local = - make_module_locality (enforce_locality_full locality_flag local) - -module LocalityFixme = struct - let locality = ref None - let set l = locality := l - let consume () = - let l = !locality in - locality := None; - l - let assert_consumed () = check_locality !locality -end diff --git a/toplevel/locality.mli b/toplevel/locality.mli deleted file mode 100644 index 2ec392eefc..0000000000 --- a/toplevel/locality.mli +++ /dev/null @@ -1,51 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool -> bool option - -(** * Positioning locality for commands supporting discharging and export - outside of modules *) - -(** For commands whose default is to discharge and export: - Global is the default and is neutral; - Local in a section deactivates discharge, - Local not in a section deactivates export *) - -val make_locality : bool option -> bool -val make_non_locality : bool option -> bool -val enforce_locality : bool option -> bool -> bool -val enforce_locality_exp : - bool option -> Decl_kinds.locality option -> Decl_kinds.locality - -(** For commands whose default is to not discharge but to export: - Global in sections forces discharge, Global not in section is the default; - Local in sections is the default, Local not in section forces non-export *) - -val make_section_locality : bool option -> bool -val enforce_section_locality : bool option -> bool -> bool - -(** * Positioning locality for commands supporting export but not discharge *) - -(** For commands whose default is to export (if not in section): - Global in sections is forbidden, Global not in section is neutral; - Local in sections is the default, Local not in section forces non-export *) - -val make_module_locality : bool option -> bool -val enforce_module_locality : bool option -> bool -> bool - -(* This is the old imperative interface that is still used for - * VernacExtend vernaculars. Time permitting this could be trashed too *) -module LocalityFixme : sig - val set : bool option -> unit - val consume : unit -> bool option - val assert_consumed : unit -> unit -end diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml deleted file mode 100644 index 0aaf6afd7e..0000000000 --- a/toplevel/metasyntax.ml +++ /dev/null @@ -1,1469 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* obj = - declare_object {(default_object "TOKEN") with - open_function = (fun i o -> if Int.equal i 1 then cache_token o); - cache_function = cache_token; - subst_function = Libobject.ident_subst_function; - classify_function = (fun o -> Substitute o)} - -let add_token_obj s = Lib.add_anonymous_leaf (inToken s) - -(**********************************************************************) -(* Printing grammar entries *) - -let entry_buf = Buffer.create 64 - -type any_entry = AnyEntry : 'a Pcoq.Gram.entry -> any_entry - -let grammars : any_entry list String.Map.t ref = ref String.Map.empty - -let register_grammar name grams = - grammars := String.Map.add name grams !grammars - -let pr_entry e = - let () = Buffer.clear entry_buf in - let ft = Format.formatter_of_buffer entry_buf in - let () = Pcoq.Gram.entry_print ft e in - str (Buffer.contents entry_buf) - -let pr_registered_grammar name = - let gram = try Some (String.Map.find name !grammars) with Not_found -> None in - match gram with - | None -> error "Unknown or unprintable grammar entry." - | Some entries -> - let pr_one (AnyEntry e) = - str "Entry " ++ str (Pcoq.Gram.Entry.name e) ++ str " is" ++ fnl () ++ - pr_entry e - in - prlist pr_one entries - -let pr_grammar = function - | "constr" | "operconstr" | "binder_constr" -> - str "Entry constr is" ++ fnl () ++ - pr_entry Pcoq.Constr.constr ++ - str "and lconstr is" ++ fnl () ++ - pr_entry Pcoq.Constr.lconstr ++ - str "where binder_constr is" ++ fnl () ++ - pr_entry Pcoq.Constr.binder_constr ++ - str "and operconstr is" ++ fnl () ++ - pr_entry Pcoq.Constr.operconstr - | "pattern" -> - pr_entry Pcoq.Constr.pattern - | "vernac" -> - str "Entry vernac is" ++ fnl () ++ - pr_entry Pcoq.Vernac_.vernac ++ - str "Entry command is" ++ fnl () ++ - pr_entry Pcoq.Vernac_.command ++ - str "Entry syntax is" ++ fnl () ++ - pr_entry Pcoq.Vernac_.syntax ++ - str "Entry gallina is" ++ fnl () ++ - pr_entry Pcoq.Vernac_.gallina ++ - str "Entry gallina_ext is" ++ fnl () ++ - pr_entry Pcoq.Vernac_.gallina_ext - | name -> pr_registered_grammar name - -(**********************************************************************) -(* Parse a format (every terminal starting with a letter or a single - quote (except a single quote alone) must be quoted) *) - -let parse_format ((loc, str) : lstring) = - let str = " "^str in - let l = String.length str in - let push_token a = function - | cur::l -> (a::cur)::l - | [] -> [[a]] in - let push_white n l = - if Int.equal n 0 then l else push_token (UnpTerminal (String.make n ' ')) l in - let close_box i b = function - | a::(_::_ as l) -> push_token (UnpBox (b,a)) l - | _ -> error "Non terminated box in format." in - let close_quotation i = - if i < String.length str && str.[i] == '\'' && (Int.equal (i+1) l || str.[i+1] == ' ') - then i+1 - else error "Incorrectly terminated quoted expression." in - let rec spaces n i = - if i < String.length str && str.[i] == ' ' then spaces (n+1) (i+1) - else n in - let rec nonspaces quoted n i = - if i < String.length str && str.[i] != ' ' then - if str.[i] == '\'' && quoted && - (i+1 >= String.length str || str.[i+1] == ' ') - then if Int.equal n 0 then error "Empty quoted token." else n - else nonspaces quoted (n+1) (i+1) - else - if quoted then error "Spaces are not allowed in (quoted) symbols." - else n in - let rec parse_non_format i = - let n = nonspaces false 0 i in - push_token (UnpTerminal (String.sub str i n)) (parse_token (i+n)) - and parse_quoted n i = - if i < String.length str then match str.[i] with - (* Parse " // " *) - | '/' when i <= String.length str && str.[i+1] == '/' -> - (* We forget the useless n spaces... *) - push_token (UnpCut PpFnl) - (parse_token (close_quotation (i+2))) - (* Parse " .. / .. " *) - | '/' when i <= String.length str -> - let p = spaces 0 (i+1) in - push_token (UnpCut (PpBrk (n,p))) - (parse_token (close_quotation (i+p+1))) - | c -> - (* The spaces are real spaces *) - push_white n (match c with - | '[' -> - if i <= String.length str then match str.[i+1] with - (* Parse " [h .. ", *) - | 'h' when i+1 <= String.length str && str.[i+2] == 'v' -> - (parse_box (fun n -> PpHVB n) (i+3)) - (* Parse " [v .. ", *) - | 'v' -> - parse_box (fun n -> PpVB n) (i+2) - (* Parse " [ .. ", *) - | ' ' | '\'' -> - parse_box (fun n -> PpHOVB n) (i+1) - | _ -> error "\"v\", \"hv\", \" \" expected after \"[\" in format." - else error "\"v\", \"hv\" or \" \" expected after \"[\" in format." - (* Parse "]" *) - | ']' -> - ([] :: parse_token (close_quotation (i+1))) - (* Parse a non formatting token *) - | c -> - let n = nonspaces true 0 i in - push_token (UnpTerminal (String.sub str (i-1) (n+2))) - (parse_token (close_quotation (i+n)))) - else - if Int.equal n 0 then [] - else error "Ending spaces non part of a format annotation." - and parse_box box i = - let n = spaces 0 i in - close_box i (box n) (parse_token (close_quotation (i+n))) - and parse_token i = - let n = spaces 0 i in - let i = i+n in - if i < l then match str.[i] with - (* Parse a ' *) - | '\'' when i+1 >= String.length str || str.[i+1] == ' ' -> - push_white (n-1) (push_token (UnpTerminal "'") (parse_token (i+1))) - (* Parse the beginning of a quoted expression *) - | '\'' -> - parse_quoted (n-1) (i+1) - (* Otherwise *) - | _ -> - push_white (n-1) (parse_non_format i) - else push_white n [[]] - in - try - if not (String.is_empty str) then match parse_token 0 with - | [l] -> l - | _ -> error "Box closed without being opened in format." - else - error "Empty format." - with reraise -> - let (e, info) = CErrors.push reraise in - let info = Loc.add_loc info loc in - iraise (e, info) - -(***********************) -(* Analyzing notations *) - -type symbol_token = WhiteSpace of int | String of string - -let split_notation_string str = - let push_token beg i l = - if Int.equal beg i then l else - let s = String.sub str beg (i - beg) in - String s :: l - in - let push_whitespace beg i l = - if Int.equal beg i then l else WhiteSpace (i-beg) :: l - in - let rec loop beg i = - if i < String.length str then - if str.[i] == ' ' then - push_token beg i (loop_on_whitespace (i+1) (i+1)) - else - loop beg (i+1) - else - push_token beg i [] - and loop_on_whitespace beg i = - if i < String.length str then - if str.[i] != ' ' then - push_whitespace beg i (loop i (i+1)) - else - loop_on_whitespace beg (i+1) - else - push_whitespace beg i [] - in - loop 0 0 - -(* Interpret notations with a recursive component *) - -let out_nt = function NonTerminal x -> x | _ -> assert false - -let msg_expected_form_of_recursive_notation = - "In the notation, the special symbol \"..\" must occur in\na configuration of the form \"x symbs .. symbs y\"." - -let rec find_pattern nt xl = function - | Break n as x :: l, Break n' :: l' when Int.equal n n' -> - find_pattern nt (x::xl) (l,l') - | Terminal s as x :: l, Terminal s' :: l' when String.equal s s' -> - find_pattern nt (x::xl) (l,l') - | [], NonTerminal x' :: l' -> - (out_nt nt,x',List.rev xl),l' - | _, Break s :: _ | Break s :: _, _ -> - error ("A break occurs on one side of \"..\" but not on the other side.") - | _, Terminal s :: _ | Terminal s :: _, _ -> - user_err ~hdr:"Metasyntax.find_pattern" - (str "The token \"" ++ str s ++ str "\" occurs on one side of \"..\" but not on the other side.") - | _, [] -> - error msg_expected_form_of_recursive_notation - | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) -> - anomaly (Pp.str "Only Terminal or Break expected on left, non-SProdList on right") - -let rec interp_list_parser hd = function - | [] -> [], List.rev hd - | NonTerminal id :: tl when Id.equal id ldots_var -> - if List.is_empty hd then error msg_expected_form_of_recursive_notation; - let hd = List.rev hd in - let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in - let xyl,tl'' = interp_list_parser [] tl' in - (* We remember each pair of variable denoting a recursive part to *) - (* remove the second copy of it afterwards *) - (x,y)::xyl, SProdList (x,sl) :: tl'' - | (Terminal _ | Break _) as s :: tl -> - if List.is_empty hd then - let yl,tl' = interp_list_parser [] tl in - yl, s :: tl' - else - interp_list_parser (s::hd) tl - | NonTerminal _ as x :: tl -> - let xyl,tl' = interp_list_parser [x] tl in - xyl, List.rev_append hd tl' - | SProdList _ :: _ -> anomaly (Pp.str "Unexpected SProdList in interp_list_parser") - - -(* Find non-terminal tokens of notation *) - -(* To protect alphabetic tokens and quotes from being seen as variables *) -let quote_notation_token x = - let n = String.length x in - let norm = CLexer.is_ident x in - if (n > 0 && norm) || (n > 2 && x.[0] == '\'') then "'"^x^"'" - else x - -let rec raw_analyze_notation_tokens = function - | [] -> [] - | String ".." :: sl -> NonTerminal ldots_var :: raw_analyze_notation_tokens sl - | String "_" :: _ -> error "_ must be quoted." - | String x :: sl when CLexer.is_ident x -> - NonTerminal (Names.Id.of_string x) :: raw_analyze_notation_tokens sl - | String s :: sl -> - Terminal (String.drop_simple_quotes s) :: raw_analyze_notation_tokens sl - | WhiteSpace n :: sl -> - Break n :: raw_analyze_notation_tokens sl - -let is_numeral symbs = - match List.filter (function Break _ -> false | _ -> true) symbs with - | ([Terminal "-"; Terminal x] | [Terminal x]) -> - (try let _ = Bigint.of_string x in true with Failure _ -> false) - | _ -> - false - -let rec get_notation_vars = function - | [] -> [] - | NonTerminal id :: sl -> - let vars = get_notation_vars sl in - if Id.equal id ldots_var then vars else - if Id.List.mem id vars then - user_err ~hdr:"Metasyntax.get_notation_vars" - (str "Variable " ++ pr_id id ++ str " occurs more than once.") - else - id::vars - | (Terminal _ | Break _) :: sl -> get_notation_vars sl - | SProdList _ :: _ -> assert false - -let analyze_notation_tokens l = - let l = raw_analyze_notation_tokens l in - let vars = get_notation_vars l in - let recvars,l = interp_list_parser [] l in - recvars, List.subtract Id.equal vars (List.map snd recvars), l - -let error_not_same_scope x y = - user_err ~hdr:"Metasyntax.error_not_name_scope" - (str "Variables " ++ pr_id x ++ str " and " ++ pr_id y ++ str " must be in the same scope.") - -(**********************************************************************) -(* Build pretty-printing rules *) - -let prec_assoc = function - | RightA -> (L,E) - | LeftA -> (E,L) - | NonA -> (L,L) - -let precedence_of_entry_type from = function - | ETConstr (NumLevel n,BorderProd (_,None)) -> n, Prec n - | ETConstr (NumLevel n,BorderProd (b,Some a)) -> - n, let (lp,rp) = prec_assoc a in if b == Left then lp else rp - | ETConstr (NumLevel n,InternalProd) -> n, Prec n - | ETConstr (NextLevel,_) -> from, L - | _ -> 0, E (* ?? *) - -(* Some breaking examples *) -(* "x = y" : "x /1 = y" (breaks before any symbol) *) -(* "x =S y" : "x /1 =S /1 y" (protect from confusion; each side for symmetry)*) -(* "+ {" : "+ {" may breaks reversibility without space but oth. not elegant *) -(* "x y" : "x spc y" *) -(* "{ x } + { y }" : "{ x } / + { y }" *) -(* "< x , y > { z , t }" : "< x , / y > / { z , / t }" *) - -let starts_with_left_bracket s = - let l = String.length s in not (Int.equal l 0) && - (s.[0] == '{' || s.[0] == '[' || s.[0] == '(') - -let ends_with_right_bracket s = - let l = String.length s in not (Int.equal l 0) && - (s.[l-1] == '}' || s.[l-1] == ']' || s.[l-1] == ')') - -let is_left_bracket s = - starts_with_left_bracket s && not (ends_with_right_bracket s) - -let is_right_bracket s = - not (starts_with_left_bracket s) && ends_with_right_bracket s - -let is_comma s = - let l = String.length s in not (Int.equal l 0) && - (s.[0] == ',' || s.[0] == ';') - -let is_operator s = - let l = String.length s in not (Int.equal l 0) && - (s.[0] == '+' || s.[0] == '*' || s.[0] == '=' || - s.[0] == '-' || s.[0] == '/' || s.[0] == '<' || s.[0] == '>' || - s.[0] == '@' || s.[0] == '\\' || s.[0] == '&' || s.[0] == '~' || s.[0] == '$') - -let is_non_terminal = function - | NonTerminal _ | SProdList _ -> true - | _ -> false - -let is_next_non_terminal = function -| [] -> false -| pr :: _ -> is_non_terminal pr - -let is_next_terminal = function Terminal _ :: _ -> true | _ -> false - -let is_next_break = function Break _ :: _ -> true | _ -> false - -let add_break n l = UnpCut (PpBrk(n,0)) :: l - -let add_break_if_none n = function - | ((UnpCut (PpBrk _) :: _) | []) as l -> l - | 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 - user_err (str "as " ++ pr_id m ++ - str " is a non-closed binder, no such \"" ++ - prlist_with_sep spc pr_token sl - ++ strbrk "\" is allowed to occur.") - -(* Heuristics for building default printing rules *) - -let index_id id l = List.index Id.equal id l - -let make_hunks etyps symbols from = - let vars,typs = List.split etyps in - let rec make = function - | NonTerminal m :: prods -> - let i = index_id m vars in - let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in - let u = UnpMetaVar (i,prec) in - if is_next_non_terminal prods then - u :: add_break_if_none 1 (make prods) - else - u :: make_with_space prods - | Terminal s :: prods when List.exists is_non_terminal prods -> - if (is_comma s || is_operator s) then - (* Always a breakable space after comma or separator *) - UnpTerminal s :: add_break_if_none 1 (make prods) - else if is_right_bracket s && is_next_terminal prods then - (* Always no space after right bracked, but possibly a break *) - UnpTerminal s :: add_break_if_none 0 (make prods) - else if is_left_bracket s && is_next_non_terminal prods then - UnpTerminal s :: make prods - else if not (is_next_break prods) then - (* Add rigid space, no break, unless user asked for something *) - UnpTerminal (s^" ") :: make prods - else - (* Rely on user spaces *) - UnpTerminal s :: make prods - - | Terminal s :: prods -> - (* Separate but do not cut a trailing sequence of terminal *) - (match prods with - | Terminal _ :: _ -> UnpTerminal (s^" ") :: make prods - | _ -> UnpTerminal s :: make prods) - - | Break n :: prods -> - add_break n (make prods) - - | SProdList (m,sl) :: prods -> - let i = index_id m vars in - let typ = List.nth typs (i-1) in - let _,prec = precedence_of_entry_type from typ in - let sl' = - (* If no separator: add a break *) - if List.is_empty sl then add_break 1 [] - (* We add NonTerminal for simulation but remove it afterwards *) - else snd (List.sep_last (make (sl@[NonTerminal m]))) in - let hunk = match typ with - | ETConstr _ -> UnpListMetaVar (i,prec,sl') - | ETBinder isopen -> - check_open_binder isopen sl m; - UnpBinderListMetaVar (i,isopen,sl') - | _ -> assert false in - hunk :: make_with_space prods - - | [] -> [] - - and make_with_space prods = - match prods with - | Terminal s' :: prods'-> - if is_operator s' then - (* A rigid space before operator and a breakable after *) - UnpTerminal (" "^s') :: add_break_if_none 1 (make prods') - else if is_comma s' then - (* No space whatsoever before comma *) - make prods - else if is_right_bracket s' then - make prods - else - (* A breakable space between any other two terminals *) - add_break_if_none 1 (make prods) - | (NonTerminal _ | SProdList _) :: _ -> - (* A breakable space before a non-terminal *) - add_break_if_none 1 (make prods) - | Break _ :: _ -> - (* Rely on user wish *) - make prods - | [] -> [] - - in make symbols - -(* Build default printing rules from explicit format *) - -let error_format () = error "The format does not match the notation." - -let rec split_format_at_ldots hd = function - | UnpTerminal s :: fmt when String.equal s (Id.to_string ldots_var) -> List.rev hd, fmt - | u :: fmt -> - check_no_ldots_in_box u; - split_format_at_ldots (u::hd) fmt - | [] -> raise Exit - -and check_no_ldots_in_box = function - | UnpBox (_,fmt) -> - (try - let _ = split_format_at_ldots [] fmt in - error ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.") - with Exit -> ()) - | _ -> () - -let skip_var_in_recursive_format = function - | UnpTerminal _ :: sl (* skip first var *) -> - (* To do, though not so important: check that the names match - the names in the notation *) - sl - | _ -> error_format () - -let read_recursive_format sl fmt = - let get_head fmt = - let sl = skip_var_in_recursive_format fmt in - try split_format_at_ldots [] sl with Exit -> error_format () in - let rec get_tail = function - | a :: sepfmt, b :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *) - | [], tail -> skip_var_in_recursive_format tail - | _ -> error "The format is not the same on the right and left hand side of the special token \"..\"." in - let slfmt, fmt = get_head fmt in - slfmt, get_tail (slfmt, fmt) - -let hunks_of_format (from,(vars,typs)) symfmt = - let rec aux = function - | symbs, (UnpTerminal s' as u) :: fmt - when String.equal s' (String.make (String.length s') ' ') -> - let symbs, l = aux (symbs,fmt) in symbs, u :: l - | Terminal s :: symbs, (UnpTerminal s') :: fmt - when String.equal s (String.drop_simple_quotes s') -> - let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l - | NonTerminal s :: symbs, UnpTerminal s' :: fmt when Id.equal s (Id.of_string s') -> - let i = index_id s vars in - let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in - let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l - | symbs, UnpBox (a,b) :: fmt -> - let symbs', b' = aux (symbs,b) in - let symbs', l = aux (symbs',fmt) in - symbs', UnpBox (a,b') :: l - | symbs, (UnpCut _ as u) :: fmt -> - let symbs, l = aux (symbs,fmt) in symbs, u :: l - | SProdList (m,sl) :: symbs, fmt -> - let i = index_id m vars in - let typ = List.nth typs (i-1) in - let _,prec = precedence_of_entry_type from typ in - let slfmt,fmt = read_recursive_format sl fmt in - let sl, slfmt = aux (sl,slfmt) in - if not (List.is_empty sl) then error_format (); - let symbs, l = aux (symbs,fmt) in - let hunk = match typ with - | ETConstr _ -> UnpListMetaVar (i,prec,slfmt) - | ETBinder isopen -> - check_open_binder isopen sl m; - UnpBinderListMetaVar (i,isopen,slfmt) - | _ -> assert false in - symbs, hunk :: l - | symbs, [] -> symbs, [] - | _, _ -> error_format () - in - match aux symfmt with - | [], l -> l - | _ -> error_format () - -(**********************************************************************) -(* Build parsing rules *) - -let assoc_of_type n (_,typ) = precedence_of_entry_type n typ - -let is_not_small_constr = function - ETConstr _ -> true - | ETOther("constr","binder_constr") -> true - | _ -> false - -let rec define_keywords_aux = function - | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(IDENT k) :: l - when is_not_small_constr e -> - Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); - CLexer.add_keyword k; - n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l - | n :: l -> n :: define_keywords_aux l - | [] -> [] - - (* Ensure that IDENT articulation terminal symbols are keywords *) -let define_keywords = function - | GramConstrTerminal(IDENT k)::l -> - Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); - CLexer.add_keyword k; - GramConstrTerminal(KEYWORD k) :: define_keywords_aux l - | l -> define_keywords_aux l - -let distribute a ll = List.map (fun l -> a @ l) ll - - (* Expand LIST1(t,sep) into the combination of t and t;sep;LIST1(t,sep) - as many times as expected in [n] argument *) -let rec expand_list_rule typ tkl x n i hds ll = - if Int.equal i n then - let hds = - GramConstrListMark (n,true) :: hds - @ [GramConstrNonTerminal (ETConstrList (typ,tkl), Some x)] in - distribute hds ll - else - let camlp4_message_name = Some (add_suffix x ("_"^string_of_int n)) in - let main = GramConstrNonTerminal (ETConstr typ, camlp4_message_name) in - let tks = List.map (fun x -> GramConstrTerminal x) tkl in - distribute (GramConstrListMark (i+1,false) :: hds @ [main]) ll @ - expand_list_rule typ tkl x n (i+1) (main :: tks @ hds) ll - -let make_production etyps symbols = - let prod = - List.fold_right - (fun t ll -> match t with - | NonTerminal m -> - let typ = List.assoc m etyps in - distribute [GramConstrNonTerminal (typ, Some m)] ll - | Terminal s -> - distribute [GramConstrTerminal (CLexer.terminal s)] ll - | Break _ -> - ll - | SProdList (x,sl) -> - let tkl = List.flatten - (List.map (function Terminal s -> [CLexer.terminal s] - | Break _ -> [] - | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator")) sl) in - match List.assoc x etyps with - | ETConstr typ -> expand_list_rule typ tkl x 1 0 [] ll - | ETBinder o -> - distribute - [GramConstrNonTerminal (ETBinderList (o,tkl), Some x)] ll - | _ -> - error "Components of recursive patterns in notation must be terms or binders.") - symbols [[]] in - List.map define_keywords prod - -let rec find_symbols c_current c_next c_last = function - | [] -> [] - | NonTerminal id :: sl -> - let prec = if not (List.is_empty sl) then c_current else c_last in - (id, prec) :: (find_symbols c_next c_next c_last sl) - | Terminal s :: sl -> find_symbols c_next c_next c_last sl - | Break n :: sl -> find_symbols c_current c_next c_last sl - | SProdList (x,_) :: sl' -> - (x,c_next)::(find_symbols c_next c_next c_last sl') - -let border = function - | (_,ETConstr(_,BorderProd (_,a))) :: _ -> a - | _ -> None - -let recompute_assoc typs = - match border typs, border (List.rev typs) with - | Some LeftA, Some RightA -> assert false - | Some LeftA, _ -> Some LeftA - | _, Some RightA -> Some RightA - | _ -> None - -(**************************************************************************) -(* Registration of syntax extensions (parsing/printing, no interpretation)*) - -let pr_arg_level from = function - | (n,L) when Int.equal n from -> str "at next level" - | (n,E) -> str "at level " ++ int n - | (n,L) -> str "at level below " ++ int n - | (n,Prec m) when Int.equal m n -> str "at level " ++ int n - | (n,_) -> str "Unknown level" - -let pr_level ntn (from,args) = - str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++ - prlist_with_sep pr_comma (pr_arg_level from) args - -let error_incompatible_level ntn oldprec prec = - user_err - (str "Notation " ++ str ntn ++ str " is already defined" ++ spc() ++ - pr_level ntn oldprec ++ - spc() ++ str "while it is now required to be" ++ spc() ++ - pr_level ntn prec ++ str ".") - -type syntax_extension = { - synext_level : Notation.level; - synext_notation : notation; - synext_notgram : notation_grammar; - synext_unparsing : unparsing list; - synext_extra : (string * string) list; - synext_compat : Flags.compat_version option; -} - -let is_active_compat = function -| None -> true -| Some v -> 0 <= Flags.version_compare v !Flags.compat_version - -type syntax_extension_obj = locality_flag * syntax_extension list - -let cache_one_syntax_extension se = - let ntn = se.synext_notation in - let prec = se.synext_level in - let onlyprint = se.synext_notgram.notgram_onlyprinting in - try - let oldprec = Notation.level_of_notation ntn in - if not (Notation.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec - with Not_found -> - if is_active_compat se.synext_compat then begin - (* Reserve the notation level *) - Notation.declare_notation_level ntn prec; - (* Declare the parsing rule *) - if not onlyprint then Egramcoq.extend_constr_grammar prec se.synext_notgram; - (* Declare the notation rule *) - Notation.declare_notation_rule ntn - ~extra:se.synext_extra (se.synext_unparsing, fst prec) se.synext_notgram - end - -let cache_syntax_extension (_, (_, sy)) = - List.iter cache_one_syntax_extension sy - -let subst_parsing_rule subst x = x - -let subst_printing_rule subst x = x - -let subst_syntax_extension (subst, (local, sy)) = - let map sy = { sy with - synext_notgram = subst_parsing_rule subst sy.synext_notgram; - synext_unparsing = subst_printing_rule subst sy.synext_unparsing; - } in - (local, List.map map sy) - -let classify_syntax_definition (local, _ as o) = - if local then Dispose else Substitute o - -let inSyntaxExtension : syntax_extension_obj -> obj = - declare_object {(default_object "SYNTAX-EXTENSION") with - open_function = (fun i o -> if Int.equal i 1 then cache_syntax_extension o); - cache_function = cache_syntax_extension; - subst_function = subst_syntax_extension; - classify_function = classify_syntax_definition} - -(**************************************************************************) -(* Precedences *) - -(* Interpreting user-provided modifiers *) - -(* XXX: We could move this to the parser itself *) -module NotationMods = struct - -type notation_modifier = { - assoc : gram_assoc option; - level : int option; - etyps : (Id.t * simple_constr_prod_entry_key) list; - - (* common to syn_data below *) - only_parsing : bool; - only_printing : bool; - compat : compat_version option; - format : string Loc.located option; - extra : (string * string) list; -} - -let default = { - assoc = None; - level = None; - etyps = []; - only_parsing = false; - only_printing = false; - compat = None; - format = None; - extra = []; -} - -end - -let interp_modifiers modl = let open NotationMods in - let rec interp acc = function - | [] -> acc - | SetEntryType (s,typ) :: l -> - let id = Id.of_string s in - if Id.List.mem_assoc id acc.etyps then - user_err ~hdr:"Metasyntax.interp_modifiers" - (str s ++ str " is already assigned to an entry or constr level."); - interp { acc with etyps = (id,typ) :: acc.etyps; } l - | SetItemLevel ([],n) :: l -> - interp acc l - | SetItemLevel (s::idl,n) :: l -> - let id = Id.of_string s in - if Id.List.mem_assoc id acc.etyps then - user_err ~hdr:"Metasyntax.interp_modifiers" - (str s ++ str " is already assigned to an entry or constr level."); - let typ = ETConstr (n,()) in - interp { acc with etyps = (id,typ)::acc.etyps; } (SetItemLevel (idl,n)::l) - | SetLevel n :: l -> - - interp { acc with level = Some n; } l - | SetAssoc a :: l -> - if not (Option.is_empty acc.assoc) then error "An associativity is given more than once."; - interp { acc with assoc = Some a; } l - | SetOnlyParsing :: l -> - interp { acc with only_parsing = true; } l - | SetOnlyPrinting :: l -> - interp { acc with only_printing = true; } l - | SetCompatVersion v :: l -> - interp { acc with compat = Some v; } l - | SetFormat ("text",s) :: l -> - if not (Option.is_empty acc.format) then error "A format is given more than once."; - interp { acc with format = Some s; } l - | SetFormat (k,(_,s)) :: l -> - interp { acc with extra = (k,s)::acc.extra; } l - in interp default modl - -let check_infix_modifiers modifiers = - let t = (interp_modifiers modifiers).NotationMods.etyps in - if not (List.is_empty t) then - error "Explicit entry level or type unexpected in infix notation." - -let check_useless_entry_types recvars mainvars etyps = - let vars = let (l1,l2) = List.split recvars in l1@l2@mainvars in - match List.filter (fun (x,etyp) -> not (List.mem x vars)) etyps with - | (x,_)::_ -> user_err ~hdr:"Metasyntax.check_useless_entry_types" - (pr_id x ++ str " is unbound in the notation.") - | _ -> () - -let not_a_syntax_modifier = function -| SetOnlyParsing -> true -| SetOnlyPrinting -> true -| SetCompatVersion _ -> true -| _ -> false - -let no_syntax_modifiers mods = List.for_all not_a_syntax_modifier mods - -let is_only_parsing mods = - let test = function SetOnlyParsing -> true | _ -> false in - List.exists test mods - -let is_only_printing mods = - let test = function SetOnlyPrinting -> true | _ -> false in - List.exists test mods - -let get_compat_version mods = - let test = function SetCompatVersion v -> Some v | _ -> None in - try Some (List.find_map test mods) with Not_found -> None - -(* Compute precedences from modifiers (or find default ones) *) - -let set_entry_type etyps (x,typ) = - let typ = try - match List.assoc x etyps, typ with - | ETConstr (n,()), (_,BorderProd (left,_)) -> - ETConstr (n,BorderProd (left,None)) - | ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd) - | (ETPattern | ETName | ETBigint | ETOther _ | - ETReference | ETBinder _ as t), _ -> t - | (ETBinderList _ |ETConstrList _), _ -> assert false - with Not_found -> ETConstr typ - in (x,typ) - -let join_auxiliary_recursive_types recvars etyps = - List.fold_right (fun (x,y) typs -> - let xtyp = try Some (List.assoc x etyps) with Not_found -> None in - let ytyp = try Some (List.assoc y etyps) with Not_found -> None in - match xtyp,ytyp with - | None, None -> typs - | Some _, None -> typs - | None, Some ytyp -> (x,ytyp)::typs - | Some xtyp, Some ytyp when Pervasives.(=) xtyp ytyp -> typs (* FIXME *) - | Some xtyp, Some ytyp -> - user_err - (strbrk "In " ++ pr_id x ++ str " .. " ++ pr_id y ++ - strbrk ", both ends have incompatible types.")) - recvars etyps - -let internalization_type_of_entry_type = function - | ETConstr _ -> NtnInternTypeConstr - | ETBigint | ETReference -> NtnInternTypeConstr - | ETBinder _ -> NtnInternTypeBinder - | ETName -> NtnInternTypeIdent - | ETPattern | ETOther _ -> error "Not supported." - | ETBinderList _ | ETConstrList _ -> assert false - -let set_internalization_type typs = - List.map (fun (_, e) -> internalization_type_of_entry_type e) typs - -let make_internalization_vars recvars mainvars typs = - let maintyps = List.combine mainvars typs in - let extratyps = List.map (fun (x,y) -> (y,List.assoc x maintyps)) recvars in - maintyps @ extratyps - -let make_interpretation_type isrec isonlybinding = function - | NtnInternTypeConstr when isrec -> NtnTypeConstrList - | NtnInternTypeConstr | NtnInternTypeIdent -> - if isonlybinding then NtnTypeOnlyBinder else NtnTypeConstr - | NtnInternTypeBinder when isrec -> NtnTypeBinderList - | NtnInternTypeBinder -> error "Type binder is only for use in recursive notations for binders." - -let make_interpretation_vars recvars allvars = - let eq_subscope (sc1, l1) (sc2, l2) = - Option.equal String.equal sc1 sc2 && - 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 - 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 (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 _ | Break _ -> true | _ -> false) l then - error "A notation must include at least one symbol."; - if (match l with SProdList _ :: _ -> true | _ -> false) then - error "A recursive notation must start with at least one symbol." - -let warn_notation_bound_to_variable = - CWarnings.create ~name:"notation-bound-to-variable" ~category:"parsing" - (fun () -> - strbrk "This notation will not be used for printing as it is bound to a single variable.") - -let warn_non_reversible_notation = - CWarnings.create ~name:"non-reversible-notation" ~category:"parsing" - (fun () -> - strbrk "This notation will not be used for printing as it is not reversible.") - -let is_not_printable onlyparse nonreversible = function -| NVar _ -> - if not onlyparse then warn_notation_bound_to_variable (); - true -| _ -> - if not onlyparse && nonreversible then - (warn_non_reversible_notation (); true) - else onlyparse - -let find_precedence lev etyps symbols = - let first_symbol = - let rec aux = function - | Break _ :: t -> aux t - | h :: t -> h - | [] -> assert false (* rule is known to be productive *) in - aux symbols in - let last_is_terminal () = - let rec aux b = function - | Break _ :: t -> aux b t - | Terminal _ :: t -> aux true t - | _ :: t -> aux false t - | [] -> b in - aux false symbols in - match first_symbol with - | NonTerminal x -> - (try match List.assoc x etyps with - | ETConstr _ -> - error "The level of the leftmost non-terminal cannot be changed." - | ETName | ETBigint | ETReference -> - begin match lev with - | None -> - ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."],0) - | Some 0 -> - ([],0) - | _ -> - error "A notation starting with an atomic expression must be at level 0." - end - | ETPattern | ETBinder _ | ETOther _ -> (* Give a default ? *) - if Option.is_empty lev then - error "Need an explicit level." - else [],Option.get lev - | ETConstrList _ | ETBinderList _ -> - assert false (* internally used in grammar only *) - with Not_found -> - if Option.is_empty lev then - error "A left-recursive notation must have an explicit level." - else [],Option.get lev) - | Terminal _ when last_is_terminal () -> - if Option.is_empty lev then - ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."], 0) - else [],Option.get lev - | _ -> - if Option.is_empty lev then error "Cannot determine the level."; - [],Option.get lev - -let check_curly_brackets_notation_exists () = - try let _ = Notation.level_of_notation "{ _ }" in () - with Not_found -> - error "Notations involving patterns of the form \"{ _ }\" are treated \n\ -specially and require that the notation \"{ _ }\" is already reserved." - -let warn_skip_spaces_curly = - CWarnings.create ~name:"skip-spaces-curly" ~category:"parsing" - (fun () ->strbrk "Skipping spaces inside curly brackets") - -(* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *) -let remove_curly_brackets l = - let rec skip_break acc = function - | Break _ as br :: l -> skip_break (br::acc) l - | l -> List.rev acc, l in - let rec aux deb = function - | [] -> [] - | Terminal "{" as t1 :: l -> - let br,next = skip_break [] l in - (match next with - | NonTerminal _ as x :: l' as l0 -> - let br',next' = skip_break [] l' in - (match next' with - | Terminal "}" as t2 :: l'' as l1 -> - if not (List.equal Notation.symbol_eq l l0) || - not (List.equal Notation.symbol_eq l' l1) then - warn_skip_spaces_curly (); - if deb && List.is_empty l'' then [t1;x;t2] else begin - check_curly_brackets_notation_exists (); - x :: aux false l'' - end - | l1 -> t1 :: br @ x :: br' @ aux false l1) - | l0 -> t1 :: aux false l0) - | x :: l -> x :: aux false l - in aux true l - -module SynData = struct - - (* XXX: Document *) - type syn_data = { - - (* Notation name and location *) - info : notation * notation_location; - - (* Fields coming from the vernac-level modifiers *) - only_parsing : bool; - only_printing : bool; - compat : compat_version option; - format : string Loc.located option; - extra : (string * string) list; - - (* XXX: Callback to printing, must remove *) - msgs : ((std_ppcmds -> unit) * std_ppcmds) list; - - (* Fields for internalization *) - recvars : (Id.t * Id.t) list; - mainvars : Id.List.elt list; - intern_typs : notation_var_internalization_type list; - - (* Notation data for parsing *) - - level : int; - syntax_data : (Id.t * (production_level, production_position) constr_entry_key_gen) list * (* typs *) - symbol list; (* symbols *) - not_data : notation * (* notation *) - (int * parenRelation) list * (* precedence *) - bool; (* needs_squash *) - } - -end - -let compute_syntax_data df modifiers = - let open SynData in - let open NotationMods in - let mods = interp_modifiers modifiers in - let assoc = Option.append mods.assoc (Some NonA) in - let toks = split_notation_string df in - let recvars,mainvars,symbols = analyze_notation_tokens toks in - let _ = check_useless_entry_types recvars mainvars mods.etyps in - - (* Notations for interp and grammar *) - let ntn_for_interp = make_notation_key symbols in - let symbols' = remove_curly_brackets symbols in - let ntn_for_grammar = make_notation_key symbols' in - check_rule_productivity symbols'; - - (* Misc *) - let need_squash = not (List.equal Notation.symbol_eq symbols symbols') in - let msgs,n = find_precedence mods.level mods.etyps symbols' in - let innerlevel = NumLevel 200 in - let typs = - find_symbols - (NumLevel n,BorderProd(Left,assoc)) - (innerlevel,InternalProd) - (NumLevel n,BorderProd(Right,assoc)) - symbols' in - (* To globalize... *) - let etyps = join_auxiliary_recursive_types recvars mods.etyps in - let sy_typs = List.map (set_entry_type etyps) typs in - let prec = List.map (assoc_of_type n) sy_typs in - let i_typs = set_internalization_type sy_typs in - let sy_data = (sy_typs,symbols') in - let sy_fulldata = (ntn_for_grammar,prec,need_squash) in - let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in - let i_data = ntn_for_interp, df' in - - (* Return relevant data for interpretation and for parsing/printing *) - { info = i_data; - - only_parsing = mods.only_parsing; - only_printing = mods.only_printing; - compat = mods.compat; - format = mods.format; - extra = mods.extra; - - msgs; - - recvars; - mainvars; - intern_typs = i_typs; - - level = n; - syntax_data = sy_data; - not_data = sy_fulldata; - } - -let compute_pure_syntax_data df mods = - let open SynData in - let sd = compute_syntax_data df mods in - let msgs = - if sd.only_parsing then - (Feedback.msg_warning ?loc:None, - strbrk "The only parsing modifier has no effect in Reserved Notation.")::sd.msgs - else sd.msgs in - { sd with msgs } - -(**********************************************************************) -(* Registration of notations interpretation *) - -type notation_obj = { - notobj_local : bool; - notobj_scope : scope_name option; - notobj_interp : interpretation; - notobj_onlyparse : bool; - notobj_onlyprint : bool; - notobj_compat : Flags.compat_version option; - notobj_notation : notation * notation_location; -} - -let load_notation _ (_, nobj) = - Option.iter Notation.declare_scope nobj.notobj_scope - -let open_notation i (_, nobj) = - let scope = nobj.notobj_scope in - let (ntn, df) = nobj.notobj_notation in - let pat = nobj.notobj_interp in - let fresh = not (Notation.exists_notation_in_scope scope ntn pat) in - let active = is_active_compat nobj.notobj_compat in - if Int.equal i 1 && fresh && active then begin - (* Declare the interpretation *) - let onlyprint = nobj.notobj_onlyprint in - let () = Notation.declare_notation_interpretation ntn scope pat df ~onlyprint in - (* Declare the uninterpretation *) - if not nobj.notobj_onlyparse then - Notation.declare_uninterpretation (NotationRule (scope, ntn)) pat - end - -let cache_notation o = - load_notation 1 o; - open_notation 1 o - -let subst_notation (subst, nobj) = - { nobj with notobj_interp = subst_interpretation subst nobj.notobj_interp; } - -let classify_notation nobj = - if nobj.notobj_local then Dispose else Substitute nobj - -let inNotation : notation_obj -> obj = - declare_object {(default_object "NOTATION") with - open_function = open_notation; - cache_function = cache_notation; - subst_function = subst_notation; - load_function = load_notation; - classify_function = classify_notation} - -(**********************************************************************) - -let with_lib_stk_protection f x = - let fs = Lib.freeze `No in - try let a = f x in Lib.unfreeze fs; a - with reraise -> - let reraise = CErrors.push reraise in - let () = Lib.unfreeze fs in - iraise reraise - -let with_syntax_protection f x = - with_lib_stk_protection - (Pcoq.with_grammar_rule_protection - (with_notation_protection f)) x - -(**********************************************************************) -(* Recovering existing syntax *) - -let contract_notation ntn = - if String.equal ntn "{ _ }" then ntn else - let rec aux ntn i = - if i <= String.length ntn - 5 then - let ntn' = - if String.is_sub "{ _ }" ntn i && - (i = 0 || ntn.[i-1] = ' ') && - (i = String.length ntn - 5 || ntn.[i+5] = ' ') - then - String.sub ntn 0 i ^ "_" ^ - String.sub ntn (i+5) (String.length ntn -i-5) - else ntn in - aux ntn' (i+1) - else ntn in - aux ntn 0 - -exception NoSyntaxRule - -let recover_syntax ntn = - try - let prec = Notation.level_of_notation ntn in - let pp_rule,_ = Notation.find_notation_printing_rule ntn in - let pp_extra_rules = Notation.find_notation_extra_printing_rules ntn in - let pa_rule = Notation.find_notation_parsing_rules ntn in - { synext_level = prec; - synext_notation = ntn; - synext_notgram = pa_rule; - synext_unparsing = pp_rule; - synext_extra = pp_extra_rules; - synext_compat = None; - } - with Not_found -> - raise NoSyntaxRule - -let recover_squash_syntax sy = - let sq = recover_syntax "{ _ }" in - [sy; sq] - -let recover_notation_syntax rawntn = - let ntn = contract_notation rawntn in - let sy = recover_syntax ntn in - let need_squash = not (String.equal ntn rawntn) in - let rules = if need_squash then recover_squash_syntax sy else [sy] in - sy.synext_notgram.notgram_typs, rules, sy.synext_notgram.notgram_onlyprinting - -(**********************************************************************) -(* Main entry point for building parsing and printing rules *) - -let make_pa_rule i_typs level (typs,symbols) ntn onlyprint = - let assoc = recompute_assoc typs in - let prod = make_production typs symbols in - { notgram_level = level; - notgram_assoc = assoc; - notgram_notation = ntn; - notgram_prods = prod; - notgram_typs = i_typs; - notgram_onlyprinting = onlyprint; - } - -let make_pp_rule level (typs,symbols) fmt = - match fmt with - | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols level)] - | Some fmt -> hunks_of_format (level, List.split typs) (symbols, parse_format fmt) - -(* let make_syntax_rules i_typs (ntn,prec,need_squash) sy_data fmt extra onlyprint compat = *) -let make_syntax_rules (sd : SynData.syn_data) = let open SynData in - let ntn, prec, need_squash = sd.not_data in - let pa_rule = make_pa_rule sd.intern_typs sd.level sd.syntax_data ntn sd.only_printing in - let pp_rule = make_pp_rule sd.level sd.syntax_data sd.format in - let sy = { - synext_level = (sd.level, prec); - synext_notation = ntn; - synext_notgram = pa_rule; - synext_unparsing = pp_rule; - synext_extra = sd.extra; - synext_compat = sd.compat; - } in - (* By construction, the rule for "{ _ }" is declared, but we need to - redeclare it because the file where it is declared needs not be open - when the current file opens (especially in presence of -nois) *) - if need_squash then recover_squash_syntax sy else [sy] - -(**********************************************************************) -(* Main functions about notations *) - -let to_map l = - let fold accu (x, v) = Id.Map.add x v accu in - List.fold_left fold Id.Map.empty l - -let add_notation_in_scope local df c mods scope = - let open SynData in - let sd = compute_syntax_data df mods in - (* Prepare the interpretation *) - (* Prepare the parsing and printing rules *) - let sy_rules = make_syntax_rules sd in - let i_vars = make_internalization_vars sd.recvars sd.mainvars sd.intern_typs in - let nenv = { - ninterp_var_type = to_map i_vars; - ninterp_rec_vars = to_map sd.recvars; - } in - let (acvars, ac, reversible) = interp_notation_constr nenv c in - let interp = make_interpretation_vars sd.recvars acvars in - let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse = is_not_printable sd.only_parsing (not reversible) ac in - let notation = { - notobj_local = local; - notobj_scope = scope; - notobj_interp = (List.map_filter map i_vars, ac); - (** Order is important here! *) - notobj_onlyparse = onlyparse; - notobj_onlyprint = sd.only_printing; - notobj_compat = sd.compat; - notobj_notation = sd.info; - } in - (* Ready to change the global state *) - Flags.if_verbose (List.iter (fun (f,x) -> f x)) sd.msgs; - Lib.add_anonymous_leaf (inSyntaxExtension (local, sy_rules)); - Lib.add_anonymous_leaf (inNotation notation); - sd.info - -let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat = - let dfs = split_notation_string df in - let recvars,mainvars,symbs = analyze_notation_tokens dfs in - (* Recover types of variables and pa/pp rules; redeclare them if needed *) - let i_typs, onlyprint = if not (is_numeral symbs) then begin - let i_typs,sy_rules,onlyprint' = recover_notation_syntax (make_notation_key symbs) in - let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules)) in - (** If the only printing flag has been explicitly requested, put it back *) - let onlyprint = onlyprint || onlyprint' in - i_typs, onlyprint - end else [], false in - (* Declare interpretation *) - let path = (Lib.library_dp(), Lib.current_dirpath true) in - let df' = (make_notation_key symbs, (path,df)) in - let i_vars = make_internalization_vars recvars mainvars i_typs in - let nenv = { - ninterp_var_type = to_map i_vars; - ninterp_rec_vars = to_map recvars; - } in - let (acvars, ac, reversible) = interp_notation_constr ~impls nenv c in - let interp = make_interpretation_vars recvars acvars in - let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse = is_not_printable onlyparse (not reversible) ac in - let notation = { - notobj_local = local; - notobj_scope = scope; - notobj_interp = (List.map_filter map i_vars, ac); - (** Order is important here! *) - notobj_onlyparse = onlyparse; - notobj_onlyprint = onlyprint; - notobj_compat = compat; - notobj_notation = df'; - } in - Lib.add_anonymous_leaf (inNotation notation); - df' - -(* Notations without interpretation (Reserved Notation) *) - -let add_syntax_extension local ((loc,df),mods) = let open SynData in - let psd = compute_pure_syntax_data df mods in - let sy_rules = make_syntax_rules {psd with compat = None} in - Flags.if_verbose (List.iter (fun (f,x) -> f x)) psd.msgs; - Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)) - -(* Notations with only interpretation *) - -let add_notation_interpretation ((loc,df),c,sc) = - let df' = add_notation_interpretation_core false df c sc false false None in - Dumpglob.dump_notation (loc,df') sc true - -let set_notation_for_interpretation impls ((_,df),c,sc) = - (try ignore - (silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ()); - with NoSyntaxRule -> - error "Parsing rule for this notation has to be previously declared."); - Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc - -(* Main entry point *) - -let add_notation local c ((loc,df),modifiers) sc = - let df' = - if no_syntax_modifiers modifiers then - (* No syntax data: try to rely on a previously declared rule *) - let onlyparse = is_only_parsing modifiers in - let onlyprint = is_only_printing modifiers in - let compat = get_compat_version modifiers in - try add_notation_interpretation_core local df c sc onlyparse onlyprint compat - with NoSyntaxRule -> - (* Try to determine a default syntax rule *) - add_notation_in_scope local df c modifiers sc - else - (* Declare both syntax and interpretation *) - add_notation_in_scope local df c modifiers sc - in - Dumpglob.dump_notation (loc,df') sc true - -let add_notation_extra_printing_rule df k v = - let notk = - let dfs = split_notation_string df in - let _,_, symbs = analyze_notation_tokens dfs in - make_notation_key symbs in - Notation.add_notation_extra_printing_rule notk k v - -(* Infix notations *) - -let inject_var x = CRef (Ident (Loc.ghost, Id.of_string x),None) - -let add_infix local ((loc,inf),modifiers) pr sc = - check_infix_modifiers modifiers; - (* check the precedence *) - let metas = [inject_var "x"; inject_var "y"] in - let c = mkAppC (pr,metas) in - let df = "x "^(quote_notation_token inf)^" y" in - add_notation local c ((loc,df),modifiers) sc - -(**********************************************************************) -(* Delimiters and classes bound to scopes *) - -type scope_command = - | ScopeDelim of string - | ScopeClasses of scope_class list - | ScopeRemove - -let load_scope_command _ (_,(scope,dlm)) = - Notation.declare_scope scope - -let open_scope_command i (_,(scope,o)) = - if Int.equal i 1 then - match o with - | ScopeDelim dlm -> Notation.declare_delimiters scope dlm - | ScopeClasses cl -> List.iter (Notation.declare_scope_class scope) cl - | ScopeRemove -> Notation.remove_delimiters scope - -let cache_scope_command o = - load_scope_command 1 o; - open_scope_command 1 o - -let subst_scope_command (subst,(scope,o as x)) = match o with - | ScopeClasses cl -> - let cl' = List.map_filter (subst_scope_class subst) cl in - let cl' = - if List.for_all2eq (==) cl cl' then cl - else cl' in - scope, ScopeClasses cl' - | _ -> x - -let inScopeCommand : scope_name * scope_command -> obj = - declare_object {(default_object "DELIMITERS") with - cache_function = cache_scope_command; - open_function = open_scope_command; - load_function = load_scope_command; - subst_function = subst_scope_command; - classify_function = (fun obj -> Substitute obj)} - -let add_delimiters scope key = - Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key)) - -let remove_delimiters scope = - Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeRemove)) - -let add_class_scope scope cl = - Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl)) - -(* Check if abbreviation to a name and avoid early insertion of - maximal implicit arguments *) -let try_interp_name_alias = function - | [], CRef (ref,_) -> intern_reference ref - | _ -> raise Not_found - -let add_syntactic_definition ident (vars,c) local onlyparse = - let nonprintable = ref false in - let vars,pat = - try [], NRef (try_interp_name_alias (vars,c)) - with Not_found -> - let fold accu id = Id.Map.add id NtnInternTypeConstr accu in - let i_vars = List.fold_left fold Id.Map.empty vars in - let nenv = { - ninterp_var_type = i_vars; - ninterp_rec_vars = Id.Map.empty; - } in - let nvars, pat, reversible = interp_notation_constr nenv c in - let () = nonprintable := not reversible 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 - | None when (is_not_printable false !nonprintable pat) -> Some Flags.Current - | p -> p - in - Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat) diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli deleted file mode 100644 index 57c1204022..0000000000 --- a/toplevel/metasyntax.mli +++ /dev/null @@ -1,63 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit - -(** Adding a (constr) notation in the environment*) - -val add_infix : locality_flag -> (lstring * syntax_modifier list) -> - constr_expr -> scope_name option -> unit - -val add_notation : locality_flag -> constr_expr -> - (lstring * syntax_modifier list) -> scope_name option -> unit - -val add_notation_extra_printing_rule : string -> string -> string -> unit - -(** Declaring delimiter keys and default scopes *) - -val add_delimiters : scope_name -> string -> unit -val remove_delimiters : scope_name -> unit -val add_class_scope : scope_name -> scope_class list -> unit - -(** Add only the interpretation of a notation that already has pa/pp rules *) - -val add_notation_interpretation : - (lstring * constr_expr * scope_name option) -> unit - -(** Add a notation interpretation for supporting the "where" clause *) - -val set_notation_for_interpretation : Constrintern.internalization_env -> - (lstring * constr_expr * scope_name option) -> unit - -(** Add only the parsing/printing rule of a notation *) - -val add_syntax_extension : - locality_flag -> (lstring * syntax_modifier list) -> unit - -(** Add a syntactic definition (as in "Notation f := ...") *) - -val add_syntactic_definition : Id.t -> Id.t list * constr_expr -> - bool -> Flags.compat_version option -> unit - -(** Print the Camlp4 state of a grammar *) - -val pr_grammar : string -> Pp.std_ppcmds - -type any_entry = AnyEntry : 'a Pcoq.Gram.entry -> any_entry - -val register_grammar : string -> any_entry list -> unit - -val check_infix_modifiers : syntax_modifier list -> unit - -val with_syntax_protection : ('a -> 'b) -> 'a -> 'b diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml deleted file mode 100644 index 2396cf04a4..0000000000 --- a/toplevel/mltop.ml +++ /dev/null @@ -1,447 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit; - use_file : string -> unit; - add_dir : string -> unit; - ml_loop : unit -> unit } - -(* Determines the behaviour of Coq with respect to ML files (compiled - or not) *) -type kind_load = - | WithTop of toplevel - | WithoutTop - -(* Must be always initialized *) -let load = ref WithoutTop - -(* Are we in a native version of Coq? *) -let is_native = Dynlink.is_native - -(* Sets and initializes a toplevel (if any) *) -let set_top toplevel = load := - WithTop toplevel; - Nativelib.load_obj := toplevel.load_obj - -(* Removes the toplevel (if any) *) -let remove () = - load := WithoutTop; - Nativelib.load_obj := (fun x -> () : string -> unit) - -(* Tests if an Ocaml toplevel runs under Coq *) -let is_ocaml_top () = - match !load with - | WithTop _ -> true - |_ -> false - -(* Tests if we can load ML files *) -let has_dynlink = Coq_config.has_natdynlink || not is_native - -(* Runs the toplevel loop of Ocaml *) -let ocaml_toploop () = - match !load with - | WithTop t -> Printexc.catch t.ml_loop () - | _ -> () - -(* Try to interpret load_obj's (internal) errors *) -let report_on_load_obj_error exc = - let x = Obj.repr exc in - (* Try an horrible (fragile) hack to report on Symtable dynlink errors *) - (* (we follow ocaml's Printexc.to_string decoding of exceptions) *) - if Obj.is_block x && String.equal (Obj.magic (Obj.field (Obj.field x 0) 0)) "Symtable.Error" - then - let err_block = Obj.field x 1 in - if Int.equal (Obj.tag err_block) 0 then - (* Symtable.Undefined_global of string *) - str "reference to undefined global " ++ - str (Obj.magic (Obj.field err_block 0)) - else str (Printexc.to_string exc) - else str (Printexc.to_string exc) - -(* Dynamic loading of .cmo/.cma *) - -let ml_load s = - match !load with - | WithTop t -> - (try t.load_obj s; s - with - | e when CErrors.noncritical e -> - let e = CErrors.push e in - match fst e with - | (UserError _ | Failure _ | Not_found as u) -> Exninfo.iraise (u, snd e) - | exc -> - let msg = report_on_load_obj_error exc in - user_err ~hdr:"Mltop.load_object" (str"Cannot link ml-object " ++ - str s ++ str" to Coq code (" ++ msg ++ str ").")) - | WithoutTop -> - try - Dynlink.loadfile s; s - with Dynlink.Error a -> - user_err ~hdr:"Mltop.load_object" - (strbrk "while loading " ++ str s ++ - strbrk ": " ++ str (Dynlink.error_message a)) - -let dir_ml_load s = - match !load with - | WithTop _ -> ml_load s - | WithoutTop -> - let warn = Flags.is_verbose() in - let _,gname = find_file_in_path ~warn !coq_mlpath_copy s in - ml_load gname - -(* Dynamic interpretation of .ml *) -let dir_ml_use s = - match !load with - | WithTop t -> t.use_file s - | _ -> - let moreinfo = - if Dynlink.is_native then " Loading ML code works only in bytecode." - else "" - in - user_err ~hdr:"Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo) - -(* Adds a path to the ML paths *) -let add_ml_dir s = - match !load with - | WithTop t -> t.add_dir s; keep_copy_mlpath s - | WithoutTop when has_dynlink -> keep_copy_mlpath s - | _ -> () - -(* For Rec Add ML Path (-R) *) -let add_rec_ml_dir unix_path = - List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs ~unix_path) - -(* Adding files to Coq and ML loadpath *) - -let warn_cannot_use_directory = - CWarnings.create ~name:"cannot-use-directory" ~category:"filesystem" - (fun d -> - str "Directory " ++ str d ++ - strbrk " cannot be used as a Coq identifier (skipped)") - -let convert_string d = - try Names.Id.of_string d - with UserError _ -> - warn_cannot_use_directory d; - raise Exit - -let warn_cannot_open_path = - CWarnings.create ~name:"cannot-open-path" ~category:"filesystem" - (fun unix_path -> str "Cannot open " ++ str unix_path) - -type add_ml = AddNoML | AddTopML | AddRecML - -let add_rec_path add_ml ~unix_path ~coq_root ~implicit = - if exists_dir unix_path then - let dirs = all_subdirs ~unix_path in - let prefix = Names.DirPath.repr coq_root in - let convert_dirs (lp, cp) = - try - let path = List.rev_map convert_string cp @ prefix in - Some (lp, Names.DirPath.make path) - with Exit -> None - in - let dirs = List.map_filter convert_dirs dirs in - let () = match add_ml with - | AddNoML -> () - | AddTopML -> add_ml_dir unix_path - | AddRecML -> List.iter (fun (lp,_) -> add_ml_dir lp) dirs in - let add (path, dir) = - Loadpath.add_load_path path ~implicit dir in - let () = List.iter add dirs in - Loadpath.add_load_path unix_path ~implicit coq_root - else - warn_cannot_open_path unix_path - -(* convertit un nom quelconque en nom de fichier ou de module *) -let mod_of_name name = - if Filename.check_suffix name ".cmo" then - Filename.chop_suffix name ".cmo" - else - name - -let get_ml_object_suffix name = - if Filename.check_suffix name ".cmo" then - Some ".cmo" - else if Filename.check_suffix name ".cma" then - Some ".cma" - else if Filename.check_suffix name ".cmxs" then - Some ".cmxs" - else - None - -let file_of_name name = - let suffix = get_ml_object_suffix name in - let fail s = - user_err ~hdr:"Mltop.load_object" - (str"File not found on loadpath : " ++ str s ++ str"\n" ++ - str"Loadpath: " ++ str(String.concat ":" !coq_mlpath_copy)) in - if not (Filename.is_relative name) then - if Sys.file_exists name then name else fail name - else if is_native then - let name = match suffix with - | Some ((".cmo"|".cma") as suffix) -> - (Filename.chop_suffix name suffix) ^ ".cmxs" - | Some ".cmxs" -> name - | _ -> name ^ ".cmxs" - in - if is_in_path !coq_mlpath_copy name then name else fail name - else - let (full, base) = match suffix with - | Some ".cmo" | Some ".cma" -> true, name - | Some ".cmxs" -> false, Filename.chop_suffix name ".cmxs" - | _ -> false, name - in - if full then - if is_in_path !coq_mlpath_copy base then base else fail base - else - let name = base ^ ".cma" in - if is_in_path !coq_mlpath_copy name then name else - let name = base ^ ".cmo" in - if is_in_path !coq_mlpath_copy name then name else - fail (base ^ ".cm[ao]") - -(** Is the ML code of the standard library placed into loadable plugins - or statically compiled into coqtop ? For the moment this choice is - made according to the presence of native dynlink : even if bytecode - coqtop could always load plugins, we prefer to have uniformity between - bytecode and native versions. *) - -(* [known_loaded_module] contains the names of the loaded ML modules - * (linked or loaded with load_object). It is used not to load a - * module twice. It is NOT the list of ML modules Coq knows. *) - -let known_loaded_modules = ref String.Map.empty - -let add_known_module mname path = - if not (String.Map.mem mname !known_loaded_modules) || - String.Map.find mname !known_loaded_modules = None then - known_loaded_modules := String.Map.add mname path !known_loaded_modules - -let module_is_known mname = - String.Map.mem mname !known_loaded_modules - -let known_module_path mname = - String.Map.find mname !known_loaded_modules - -(** A plugin is just an ML module with an initialization function. *) - -let known_loaded_plugins = ref String.Map.empty - -let add_known_plugin init name = - add_known_module name None; - known_loaded_plugins := String.Map.add name init !known_loaded_plugins - -let init_known_plugins () = - String.Map.iter (fun _ f -> f()) !known_loaded_plugins - -(** Registering functions to be used at caching time, that is when the Declare - ML module command is issued. *) - -let cache_objs = ref String.Map.empty - -let declare_cache_obj f name = - let objs = try String.Map.find name !cache_objs with Not_found -> [] in - let objs = f :: objs in - cache_objs := String.Map.add name objs !cache_objs - -let perform_cache_obj name = - let objs = try String.Map.find name !cache_objs with Not_found -> [] in - let objs = List.rev objs in - List.iter (fun f -> f ()) objs - -(** ml object = ml module or plugin *) - -let init_ml_object mname = - try String.Map.find mname !known_loaded_plugins () - with Not_found -> () - -let load_ml_object mname ?path fname= - let path = match path with - | None -> dir_ml_load fname - | Some p -> ml_load p in - add_known_module mname (Some path); - init_ml_object mname; - path - -let dir_ml_load m = ignore(dir_ml_load m) -let add_known_module m = add_known_module m None -let load_ml_object_raw fname = dir_ml_load (file_of_name fname) -let load_ml_objects_raw_rex rex = - List.iter (fun (_,fp) -> - let name = file_of_name (Filename.basename fp) in - try dir_ml_load name - with e -> prerr_endline (Printexc.to_string e)) - (System.where_in_path_rex !coq_mlpath_copy rex) - -(* Summary of declared ML Modules *) - -(* List and not String.Set because order is important: most recent first. *) - -let loaded_modules = ref [] -let get_loaded_modules () = List.rev !loaded_modules -let add_loaded_module md path = - if not (List.mem_assoc md !loaded_modules) then - loaded_modules := (md,path) :: !loaded_modules -let reset_loaded_modules () = loaded_modules := [] - -let if_verbose_load verb f name ?path fname = - if not verb then f name ?path fname - else - let info = str "[Loading ML file " ++ str fname ++ str " ..." in - try - let path = f name ?path fname in - Feedback.msg_info (info ++ str " done]"); - path - with reraise -> - Feedback.msg_info (info ++ str " failed]"); - raise reraise - -(** Load a module for the first time (i.e. dynlink it) - or simulate its reload (i.e. doing nothing except maybe - an initialization function). *) - -let trigger_ml_object verb cache reinit ?path name = - if module_is_known name then begin - if reinit then init_ml_object name; - add_loaded_module name (known_module_path name); - if cache then perform_cache_obj name - end else if not has_dynlink then - user_err ~hdr:"Mltop.trigger_ml_object" - (str "Dynamic link not supported (module " ++ str name ++ str ")") - else begin - let file = file_of_name (Option.default name path) in - let path = - if_verbose_load (verb && is_verbose ()) load_ml_object name ?path file in - add_loaded_module name (Some path); - if cache then perform_cache_obj name - end - -let load_ml_object n m = ignore(load_ml_object n m) - -let unfreeze_ml_modules x = - reset_loaded_modules (); - List.iter - (fun (name,path) -> trigger_ml_object false false false ?path name) x - -let _ = - Summary.declare_summary Summary.ml_modules - { Summary.freeze_function = (fun _ -> get_loaded_modules ()); - Summary.unfreeze_function = unfreeze_ml_modules; - Summary.init_function = reset_loaded_modules } - -(* Liboject entries of declared ML Modules *) - -type ml_module_object = { - mlocal : Vernacexpr.locality_flag; - mnames : string list -} - -let cache_ml_objects (_,{mnames=mnames}) = - let iter obj = trigger_ml_object true true true obj in - List.iter iter mnames - -let load_ml_objects _ (_,{mnames=mnames}) = - let iter obj = trigger_ml_object true false true obj in - List.iter iter mnames - -let classify_ml_objects ({mlocal=mlocal} as o) = - if mlocal then Dispose else Substitute o - -let inMLModule : ml_module_object -> obj = - declare_object - {(default_object "ML-MODULE") with - cache_function = cache_ml_objects; - load_function = load_ml_objects; - subst_function = (fun (_,o) -> o); - classify_function = classify_ml_objects } - -let declare_ml_modules local l = - let l = List.map mod_of_name l in - Lib.add_anonymous_leaf ~cache_first:false (inMLModule {mlocal=local; mnames=l}) - -let print_ml_path () = - let l = !coq_mlpath_copy in - str"ML Load Path:" ++ fnl () ++ str" " ++ - hv 0 (prlist_with_sep fnl str l) - -(* Printing of loaded ML modules *) - -let print_ml_modules () = - let l = get_loaded_modules () in - str"Loaded ML Modules: " ++ pr_vertical_list str (List.map fst l) - -let print_gc () = - let stat = Gc.stat () in - let msg = - str "minor words: " ++ real stat.Gc.minor_words ++ fnl () ++ - str "promoted words: " ++ real stat.Gc.promoted_words ++ fnl () ++ - str "major words: " ++ real stat.Gc.major_words ++ fnl () ++ - str "minor_collections: " ++ int stat.Gc.minor_collections ++ fnl () ++ - str "major_collections: " ++ int stat.Gc.major_collections ++ fnl () ++ - str "heap_words: " ++ int stat.Gc.heap_words ++ fnl () ++ - str "heap_chunks: " ++ int stat.Gc.heap_chunks ++ fnl () ++ - str "live_words: " ++ int stat.Gc.live_words ++ fnl () ++ - str "live_blocks: " ++ int stat.Gc.live_blocks ++ fnl () ++ - str "free_words: " ++ int stat.Gc.free_words ++ fnl () ++ - str "free_blocks: " ++ int stat.Gc.free_blocks ++ fnl () ++ - str "largest_free: " ++ int stat.Gc.largest_free ++ fnl () ++ - str "fragments: " ++ int stat.Gc.fragments ++ fnl () ++ - str "compactions: " ++ int stat.Gc.compactions ++ fnl () ++ - str "top_heap_words: " ++ int stat.Gc.top_heap_words ++ fnl () ++ - str "stack_size: " ++ int stat.Gc.stack_size - in - hv 0 msg diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli deleted file mode 100644 index 6633cb9372..0000000000 --- a/toplevel/mltop.mli +++ /dev/null @@ -1,88 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit; - use_file : string -> unit; - add_dir : string -> unit; - ml_loop : unit -> unit } - -(** Sets and initializes a toplevel (if any) *) -val set_top : toplevel -> unit - -(** Are we in a native version of Coq? *) -val is_native : bool - -(** Removes the toplevel (if any) *) -val remove : unit -> unit - -(** Tests if an Ocaml toplevel runs under Coq *) -val is_ocaml_top : unit -> bool - -(** Starts the Ocaml toplevel loop *) -val ocaml_toploop : unit -> unit - -(** {5 ML Dynlink} *) - -(** Tests if we can load ML files *) -val has_dynlink : bool - -(** Dynamic loading of .cmo *) -val dir_ml_load : string -> unit - -(** Dynamic interpretation of .ml *) -val dir_ml_use : string -> unit - -(** Adds a path to the ML paths *) -val add_ml_dir : string -> unit -val add_rec_ml_dir : string -> unit - -type add_ml = AddNoML | AddTopML | AddRecML - -(** Adds a path to the Coq and ML paths *) -val add_rec_path : add_ml -> unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit - -(** List of modules linked to the toplevel *) -val add_known_module : string -> unit -val module_is_known : string -> bool -val load_ml_object : string -> string -> unit -val load_ml_object_raw : string -> unit -val load_ml_objects_raw_rex : Str.regexp -> unit - -(** {5 Initialization functions} *) - -(** Declare a plugin and its initialization function. - A plugin is just an ML module with an initialization function. - Adding a known plugin implies adding it as a known ML module. - The initialization function is granted to be called after Coq is fully - bootstrapped, even if the plugin is statically linked with the toplevel *) -val add_known_plugin : (unit -> unit) -> string -> unit - -(** Calls all initialization functions in a non-specified order *) -val init_known_plugins : unit -> unit - -(** Register a callback that will be called when the module is declared with - the Declare ML Module command. This is useful to define Coq objects at that - time only. Several functions can be defined for one module; they will be - called in the order of declaration, and after the ML module has been - properly initialized. *) -val declare_cache_obj : (unit -> unit) -> string -> unit - -(** {5 Declaring modules} *) - -val declare_ml_modules : Vernacexpr.locality_flag -> string list -> unit - -(** {5 Utilities} *) - -val print_ml_path : unit -> Pp.std_ppcmds -val print_ml_modules : unit -> Pp.std_ppcmds -val print_gc : unit -> Pp.std_ppcmds diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml deleted file mode 100644 index 9ada043171..0000000000 --- a/toplevel/obligations.ml +++ /dev/null @@ -1,1173 +0,0 @@ -open Printf -open Globnames -open Libobject -open Entries -open Decl_kinds -open Declare - -(** - - Get types of existentials ; - - Flatten dependency tree (prefix order) ; - - Replace existentials by De Bruijn indices in term, applied to the right arguments ; - - Apply term prefixed by quantification on "existentials". -*) - -open Term -open Vars -open Names -open Evd -open Pp -open CErrors -open Util - -module NamedDecl = Context.Named.Declaration - -let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> assert false) -let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false) - -let succfix (depth, fixrels) = - (succ depth, List.map succ fixrels) - -let check_evars env evm = - Evar.Map.iter - (fun key evi -> - let (loc,k) = evar_source key evm in - match k with - | Evar_kinds.QuestionMark _ - | Evar_kinds.ImplicitArg (_,_,false) -> () - | _ -> - Pretype_errors.error_unsolvable_implicit ~loc env evm key None) - (Evd.undefined_map evm) - -type oblinfo = - { ev_name: int * Id.t; - ev_hyps: Context.Named.t; - ev_status: bool * Evar_kinds.obligation_definition_status; - ev_chop: int option; - ev_src: Evar_kinds.t Loc.located; - ev_typ: types; - ev_tac: unit Proofview.tactic option; - ev_deps: Int.Set.t } - -(** Substitute evar references in t using De Bruijn indices, - where n binders were passed through. *) - -let subst_evar_constr evs n idf t = - 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 - let rec substrec (depth, fixrels) c = match kind_of_term c with - | Evar (k, args) -> - let { ev_name = (id, idstr) ; - ev_hyps = hyps ; ev_chop = chop } = - try evar_info k - with Not_found -> - anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found") - in - seen := Int.Set.add id !seen; - (* Evar arguments are created in inverse order, - and we must not apply to defined ones (i.e. LetIn's) - *) - let args = - let n = match chop with None -> 0 | Some c -> c in - let (l, r) = List.chop n (List.rev (Array.to_list args)) in - List.rev r - in - let args = - let rec aux hyps args acc = - let open Context.Named.Declaration in - match hyps, args with - (LocalAssum _ :: tlh), (c :: tla) -> - aux tlh tla ((substrec (depth, fixrels) c) :: acc) - | (LocalDef _ :: tlh), (_ :: tla) -> - aux tlh tla acc - | [], [] -> acc - | _, _ -> acc (*failwith "subst_evars: invalid argument"*) - in aux hyps args [] - in - if List.exists - (fun x -> match kind_of_term x with - | Rel n -> Int.List.mem n fixrels - | _ -> false) args - then - transparent := Id.Set.add idstr !transparent; - mkApp (idf idstr, Array.of_list args) - | Fix _ -> - map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c - | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c - in - let t' = substrec (0, []) t in - t', !seen, !transparent - - -(** Substitute variable references in t using De Bruijn indices, - where n binders were passed through. *) -let subst_vars acc n t = - let var_index id = Util.List.index Id.equal id acc in - let rec substrec depth c = match kind_of_term c with - | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c) - | _ -> map_constr_with_binders succ substrec depth c - in - substrec 0 t - -(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) - to a product : forall H1 : t1, ..., forall Hn : tn, concl. - 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 - decl :: tl -> - let t', s, trans = subst_evar_constr evs n mkVar (NamedDecl.get_type decl) in - let t'' = subst_vars acc 0 t' in - let rest, s', trans' = aux (NamedDecl.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 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 (LocalDef (id, c', t'')) rest, - Int.Set.union s'' s', - Id.Set.union trans'' 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 - in aux [] 0 (List.rev hyps) - -let trunc_named_context n ctx = - let len = List.length ctx in - List.firstn (len - n) ctx - -let rec chop_product n t = - if Int.equal n 0 then Some t - else - match kind_of_term t with - | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None - | _ -> None - -let evar_dependencies evm oev = - let one_step deps = - Evar.Set.fold (fun ev s -> - let evi = Evd.find evm ev in - let deps' = evars_of_filtered_evar_info evi in - if Evar.Set.mem oev deps' then - invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ string_of_existential oev) - else Evar.Set.union deps' s) - deps deps - in - let rec aux deps = - let deps' = one_step deps in - if Evar.Set.equal deps deps' then deps - else aux deps' - in aux (Evar.Set.singleton oev) - -let move_after (id, ev, deps as obl) l = - let rec aux restdeps = function - | (id', _, _) as obl' :: tl -> - let restdeps' = Evar.Set.remove id' restdeps in - if Evar.Set.is_empty restdeps' then - obl' :: obl :: tl - else obl' :: aux restdeps' tl - | [] -> [obl] - in aux (Evar.Set.remove id deps) l - -let sort_dependencies evl = - let rec aux l found list = - match l with - | (id, ev, deps) as obl :: tl -> - let found' = Evar.Set.union found (Evar.Set.singleton id) in - if Evar.Set.subset deps found' then - aux tl found' (obl :: list) - else aux (move_after obl tl) found list - | [] -> List.rev list - in aux evl Evar.Set.empty [] - -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.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 - let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in - let sevl = sort_dependencies evl in - let evl = List.map (fun (id, ev, _) -> id, ev) sevl in - let evn = - let i = ref (-1) in - List.rev_map (fun (id, ev) -> incr i; - (id, (!i, Id.of_string - (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i))), - ev)) evl - in - let evts = - (* Remove existential variables in types and build the corresponding products *) - List.fold_right - (fun (id, (n, nstr), ev) l -> - let hyps = Evd.evar_filtered_context ev in - let hyps = trunc_named_context nc_len hyps in - let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in - let evtyp, hyps, chop = - match chop_product fs evtyp with - | Some t -> t, trunc_named_context fs hyps, fs - | None -> evtyp, hyps, 0 - in - let loc, k = evar_source id evm in - let status = match k with - | Evar_kinds.QuestionMark o -> o - | _ -> match status with - | Some o -> o - | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ())) - in - let force_status, status, chop = match status with - | Evar_kinds.Define true as stat -> - if not (Int.equal chop fs) then true, Evar_kinds.Define false, None - else false, stat, Some chop - | s -> false, s, None - in - let info = { ev_name = (n, nstr); - ev_hyps = hyps; ev_status = force_status, status; ev_chop = chop; - ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = None } - in (id, info) :: l) - evn [] - in - let t', _, transparent = (* Substitute evar refs in the term by variables *) - subst_evar_constr evts 0 mkVar t - in - let ty, _, _ = subst_evar_constr evts 0 mkVar ty in - let evars = - List.map (fun (ev, info) -> - let { ev_name = (_, name); ev_status = force_status, status; - ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info - in - let force_status, status = match status with - | Evar_kinds.Define true when Id.Set.mem name transparent -> - true, Evar_kinds.Define false - | _ -> force_status, status - in name, typ, src, (force_status, status), deps, tac) evts - in - let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in - let evmap f c = pi1 (subst_evar_constr evts 0 f c) in - Array.of_list (List.rev evars), (evnames, evmap), t', ty - -let tactics_module = ["Program";"Tactics"] -let safe_init_constant md name () = - Coqlib.check_required_library ("Coq"::md); - Coqlib.gen_constant "Obligations" md name -let hide_obligation = safe_init_constant tactics_module "obligation" - -let pperror cmd = CErrors.user_err ~hdr:"Program" cmd -let error s = pperror (str s) - -let reduce c = - Reductionops.clos_norm_flags CClosure.betaiota (Global.env ()) Evd.empty c - -exception NoObligations of Id.t option - -let explain_no_obligations = function - Some ident -> str "No obligations for program " ++ Id.print ident - | None -> str "No obligations remaining" - -type obligation_info = - (Names.Id.t * Term.types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) - * Int.Set.t * unit Proofview.tactic option) array - -type 'a obligation_body = - | DefinedObl of 'a - | TermObl of constr - -type obligation = - { obl_name : Id.t; - obl_type : types; - obl_location : Evar_kinds.t Loc.located; - obl_body : constant obligation_body option; - obl_status : bool * Evar_kinds.obligation_definition_status; - obl_deps : Int.Set.t; - obl_tac : unit Proofview.tactic option; - } - -type obligations = (obligation array * int) - -type fixpoint_kind = - | IsFixpoint of (Id.t Loc.located option * Constrexpr.recursion_order_expr) list - | IsCoFixpoint - -type notations = (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list - -type program_info_aux = { - prg_name: Id.t; - 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 ; - prg_implicits : (Constrexpr.explicitation * (bool * bool * bool)) list; - prg_notations : notations ; - prg_kind : definition_kind; - 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 CEphemeron.key - -let get_info x = - try CEphemeron.get x - with CEphemeron.InvalidKey -> - CErrors.anomaly Pp.(str "Program obligation can't be accessed by a worker") - -let assumption_message = Declare.assumption_message - -let default_tactic = ref (Proofview.tclUNIT ()) - -(* true = hide obligations *) -let hide_obligations = ref false - -let set_hide_obligations = (:=) hide_obligations -let get_hide_obligations () = !hide_obligations - -open Goptions -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "Hidding of Program obligations"; - optkey = ["Hide";"Obligations"]; - optread = get_hide_obligations; - optwrite = set_hide_obligations; } - -let shrink_obligations = ref true - -let set_shrink_obligations = (:=) shrink_obligations -let get_shrink_obligations () = !shrink_obligations - -let _ = - declare_bool_option - { optsync = true; - optdepr = true; - optname = "Shrinking of Program obligations"; - optkey = ["Shrink";"Obligations"]; - optread = get_shrink_obligations; - optwrite = set_shrink_obligations; } - -let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type - -let get_body obl = - match obl.obl_body with - | None -> None - | Some (DefinedObl c) -> - let ctx = Environ.constant_context (Global.env ()) c in - let pc = (c, Univ.UContext.instance ctx) in - Some (DefinedObl pc) - | Some (TermObl c) -> - Some (TermObl c) - -let get_obligation_body expand obl = - match get_body obl with - | None -> None - | Some c -> - if expand && snd obl.obl_status == Evar_kinds.Expand then - match c with - | DefinedObl pc -> Some (constant_value_in (Global.env ()) pc) - | TermObl c -> Some c - else (match c with - | DefinedObl pc -> Some (mkConstU pc) - | TermObl c -> Some c) - -let obl_substitution expand obls deps = - Int.Set.fold - (fun x acc -> - let xobl = obls.(x) in - match get_obligation_body expand xobl with - | None -> acc - | Some oblb -> (xobl.obl_name, (xobl.obl_type, oblb)) :: acc) - deps [] - -let subst_deps expand obls deps t = - let osubst = obl_substitution expand obls deps in - (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t) - -let rec prod_app t n = - match kind_of_term (Termops.strip_outer_cast t) with - | Prod (_,_,b) -> subst1 n b - | LetIn (_, b, t, b') -> prod_app (subst1 b b') n - | _ -> - user_err ~hdr:"prod_app" - (str"Needed a product, but didn't find one" ++ fnl ()) - - -(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) -let prod_applist t nL = List.fold_left prod_app t nL - -let replace_appvars subst = - let rec aux c = - let f, l = decompose_app c in - if isVar f then - try - let c' = List.map (map_constr aux) l in - let (t, b) = Id.List.assoc (destVar f) subst in - mkApp (delayed_force hide_obligation, - [| prod_applist t c'; applistc b c' |]) - with Not_found -> map_constr aux c - else map_constr aux c - in map_constr aux - -let subst_prog expand obls ints prg = - let subst = obl_substitution expand obls ints in - if get_hide_obligations () then - (replace_appvars subst prg.prg_body, - replace_appvars subst ((* Termops.refresh_universes *) prg.prg_type)) - else - let subst' = List.map (fun (n, (_, b)) -> n, b) subst in - (Vars.replace_vars subst' prg.prg_body, - Vars.replace_vars subst' ((* Termops.refresh_universes *) prg.prg_type)) - -let subst_deps_obl obls obl = - let t' = subst_deps true obls obl.obl_deps obl.obl_type in - { obl with obl_type = t' } - -module ProgMap = Id.Map - -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 [] - -let from_prg : program_info ProgMap.t ref = - Summary.ref ProgMap.empty ~name:"program-tcc-table" - -let close sec = - if not (ProgMap.is_empty !from_prg) then - let keys = map_keys !from_prg in - user_err ~hdr:"Program" - (str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++ - prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++ - (str (if Int.equal (List.length keys) 1 then " has " else " have ") ++ - str "unsolved obligations")) - -let input : program_info ProgMap.t -> obj = - declare_object - { (default_object "Program state") with - cache_function = (fun (na, pi) -> from_prg := pi); - load_function = (fun _ (_, pi) -> from_prg := pi); - discharge_function = (fun _ -> close "section"; None); - classify_function = (fun _ -> close "module"; Dispose) } - -open Evd - -let progmap_remove prg = - Lib.add_anonymous_leaf (input (ProgMap.remove prg.prg_name !from_prg)) - -let progmap_add n prg = - Lib.add_anonymous_leaf (input (ProgMap.add n prg !from_prg)) - -let progmap_replace prg' = - Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !from_prg)) - -let rec intset_to = function - -1 -> Int.Set.empty - | n -> Int.Set.add n (intset_to (pred n)) - -let subst_body expand prg = - let obls, _ = prg.prg_obligations in - let ints = intset_to (pred (Array.length obls)) in - subst_prog expand obls ints prg - -let declare_definition prg = - let body, typ = subst_body true prg in - 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 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 - 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)) - in - Universes.register_universe_binders cst pl; - cst - -open Pp - -let rec lam_index n t acc = - match kind_of_term t with - | Lambda (Name n', _, _) when Id.equal n n' -> - acc - | Lambda (_, _, b) -> - lam_index n b (succ acc) - | _ -> raise Not_found - -let compute_possible_guardness_evidences (n,_) fixbody fixtype = - match n with - | Some (loc, n) -> [lam_index n fixbody 0] - | None -> - (* If recursive argument was not given by user, we try all args. - An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem to worth the effort (except for huge mutual - fixpoints ?) *) - 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 - -let mk_proof c = ((c, Univ.ContextSet.empty), Safe_typing.empty_private_constants) - -let declare_mutual_definition l = - let len = List.length l in - let first = List.hd l in - let fixdefs, fixtypes, fiximps = - List.split3 - (List.map (fun x -> - let subs, typ = (subst_body true x) in - let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in - let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in - x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l) - in -(* let fixdefs = List.map reduce_fix fixdefs in *) - let fixkind = Option.get first.prg_fixkind in - let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in - let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in - let (local,poly,kind) = first.prg_kind in - let fixnames = first.prg_deps in - let opaque = first.prg_opaque in - let kind = if fixkind != IsCoFixpoint then Fixpoint else CoFixpoint in - let indexes, fixdecls = - match fixkind with - | IsFixpoint wfl -> - let possible_indexes = - List.map3 compute_possible_guardness_evidences - wfl fixdefs fixtypes in - let indexes = - Pretyping.search_guard - Loc.ghost (Global.env()) - possible_indexes fixdecls in - Some indexes, - List.map_i (fun i _ -> - mk_proof (mkFix ((indexes,i),fixdecls))) 0 l - | IsCoFixpoint -> - None, - List.map_i (fun i _ -> - mk_proof (mkCoFix (i,fixdecls))) 0 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 *) - List.iter Metasyntax.add_notation_interpretation first.prg_notations; - 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 fix_exn first.prg_hook local gr first.prg_ctx; - List.iter progmap_remove l; kn - -let decompose_lam_prod c ty = - let open Context.Rel.Declaration in - let rec aux ctx c ty = - match kind_of_term c, kind_of_term ty with - | LetIn (x, b, t, c), LetIn (x', b', t', ty) - when eq_constr b b' && eq_constr t t' -> - let ctx' = Context.Rel.add (LocalDef (x,b',t')) ctx in - aux ctx' c ty - | _, LetIn (x', b', t', ty) -> - let ctx' = Context.Rel.add (LocalDef (x',b',t')) ctx in - aux ctx' (lift 1 c) ty - | LetIn (x, b, t, c), _ -> - let ctx' = Context.Rel.add (LocalDef (x,b,t)) ctx in - aux ctx' c (lift 1 ty) - | Lambda (x, b, t), Prod (x', b', t') - (* By invariant, must be convertible *) -> - let ctx' = Context.Rel.add (LocalAssum (x,b')) ctx in - aux ctx' t t' - | Cast (c, _, _), _ -> aux ctx c ty - | _, _ -> ctx, c, ty - in aux Context.Rel.empty c ty - -let shrink_body c ty = - let ctx, b, ty = - match ty with - | None -> - let ctx, b = decompose_lam_assum c in - ctx, b, None - | Some ty -> - let ctx, b, ty = decompose_lam_prod c ty in - ctx, b, Some ty - in - let b', ty', n, args = - List.fold_left (fun (b, ty, i, args) decl -> - if noccurn 1 b && Option.cata (noccurn 1) true ty then - subst1 mkProp b, Option.map (subst1 mkProp) ty, succ i, args - else - let open Context.Rel.Declaration in - let args = if is_local_assum decl then mkRel i :: args else args in - mkLambda_or_LetIn decl b, Option.map (mkProd_or_LetIn decl) ty, - succ i, args) - (b, ty, 1, []) ctx - in ctx, b', ty', Array.of_list args - -let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] - -let add_hint local prg cst = - Hints.add_hints local [Id.to_string prg.prg_name] (unfold_entry cst) - -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 -> false, { obl with obl_body = Some (TermObl body) } - | force, Evar_kinds.Define opaque -> - let opaque = not force && opaque in - let poly = pi2 prg.prg_kind in - let ctx, body, ty, args = - if get_shrink_obligations () && not poly then - shrink_body body ty else [], body, ty, [||] - in - let body = ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in - let ce = - { const_entry_body = Future.from_val ~fix_exn:(fun x -> x) body; - const_entry_secctx = None; - const_entry_type = ty; - const_entry_polymorphic = poly; - const_entry_universes = uctx; - const_entry_opaque = opaque; - const_entry_inline_code = false; - const_entry_feedback = None; - } in - (** ppedrot: seems legit to have obligations as local *) - let constant = Declare.declare_constant obl.obl_name ~local:true - (DefinitionEntry ce,IsProof Property) - in - if not opaque then add_hint false prg constant; - definition_message obl.obl_name; - true, { obl with obl_body = - if poly then - Some (DefinedObl constant) - else - Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) } - -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 -> - assert(Int.equal (Array.length obls) 0); - let n = Nameops.add_suffix n "_obligation" in - [| { obl_name = n; obl_body = None; - obl_location = Loc.ghost, Evar_kinds.InternalHole; obl_type = t; - obl_status = false, Evar_kinds.Expand; obl_deps = Int.Set.empty; - obl_tac = None } |], - mkVar n - | Some b -> - Array.mapi - (fun i (n, t, l, o, d, tac) -> - { obl_name = n ; obl_body = None; - obl_location = l; obl_type = t; obl_status = o; - obl_deps = d; obl_tac = tac }) - obls, b - in - { prg_name = n ; prg_body = b; prg_type = reduce t; - 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; - prg_hook = hook; prg_opaque = opaque; - prg_sign = sign } - -let map_cardinal m = - let i = ref 0 in - ProgMap.iter (fun _ v -> - if snd (CEphemeron.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 (CEphemeron.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 - Some n -> - (try get_info (ProgMap.find n prg_infos) - with Not_found -> raise (NoObligations (Some n))) - | None -> - (let n = map_cardinal prg_infos in - match n with - 0 -> raise (NoObligations None) - | 1 -> get_info (map_first prg_infos) - | _ -> - let progs = Id.Set.elements (ProgMap.domain prg_infos) in - let prog = List.hd progs in - let progs = prlist_with_sep pr_comma Nameops.pr_id progs in - user_err - (str "More than one program with unsolved obligations: " ++ progs - ++ str "; use the \"of\" clause to specify, as in \"Obligation 1 of " ++ Nameops.pr_id prog ++ str "\"")) - -let get_any_prog () = - let prg_infos = !from_prg in - let n = map_cardinal prg_infos in - if n > 0 then get_info (map_first prg_infos) - else raise (NoObligations None) - -let get_prog_err n = - try get_prog n with NoObligations id -> pperror (explain_no_obligations id) - -let get_any_prog_err () = - try get_any_prog () with NoObligations id -> pperror (explain_no_obligations id) - -let obligations_solved prg = Int.equal (snd prg.prg_obligations) 0 - -let all_programs () = - ProgMap.fold (fun k p l -> p :: l) !from_prg [] - -type progress = - | Remain of int - | Dependent - | Defined of global_reference - -let obligations_message rem = - if rem > 0 then - if Int.equal rem 1 then - Flags.if_verbose Feedback.msg_info (int rem ++ str " obligation remaining") - else - Flags.if_verbose Feedback.msg_info (int rem ++ str " obligations remaining") - else - Flags.if_verbose Feedback.msg_info (str "No more obligations remaining") - -let update_obls prg obls rem = - let prg' = { prg with prg_obligations = (obls, rem) } in - progmap_replace prg'; - obligations_message rem; - if rem > 0 then Remain rem - else ( - match prg'.prg_deps with - | [] -> - let kn = declare_definition prg' in - progmap_remove prg'; - Defined kn - | l -> - let progs = List.map (fun x -> get_info (ProgMap.find x !from_prg)) prg'.prg_deps in - if List.for_all (fun x -> obligations_solved x) progs then - let kn = declare_mutual_definition progs in - Defined (ConstRef kn) - else Dependent) - -let is_defined obls x = not (Option.is_empty obls.(x).obl_body) - -let deps_remaining obls deps = - Int.Set.fold - (fun x acc -> - if is_defined obls x then acc - else x :: acc) - deps [] - -let dependencies obls n = - let res = ref Int.Set.empty in - Array.iteri - (fun i obl -> - if not (Int.equal i n) && Int.Set.mem n obl.obl_deps then - res := Int.Set.add i !res) - obls; - !res - -let goal_kind poly = Decl_kinds.Local, poly, Decl_kinds.DefinitionBody Decl_kinds.Definition - -let goal_proof_kind poly = Decl_kinds.Local, poly, Decl_kinds.Proof Decl_kinds.Lemma - -let kind_of_obligation poly o = - match o with - | Evar_kinds.Define false | Evar_kinds.Expand -> goal_kind poly - | _ -> goal_proof_kind poly - -let not_transp_msg = - str "Obligation should be transparent but was declared opaque." ++ spc () ++ - str"Use 'Defined' instead." - -let err_not_transp () = pperror not_transp_msg - -let rec string_of_list sep f = function - [] -> "" - | x :: [] -> f x - | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl - -(* Solve an obligation using tactics, return the corresponding proof term *) - -let solve_by_tac name evi t poly ctx = - let id = name in - let concl = evi.evar_concl in - (* spiwack: the status is dropped. *) - 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 = 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.const_entry_type, Evd.evar_universe_context ctx' - -let obligation_terminator name num guard hook auto pf = - let open Proof_global in - let term = Lemmas.universe_proof_terminator guard hook in - match pf with - | Admitted _ -> apply_terminator term pf - | Proved (opq, id, proof) -> - if not !shrink_obligations then apply_terminator term pf - else - let (_, (entry, uctx, _)) = Pfedit.cook_this_proof proof in - let env = Global.env () in - let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in - let ty = entry.Entries.const_entry_type in - let (body, cstr), eff = Future.force entry.Entries.const_entry_body in - assert(Safe_typing.empty_private_constants = eff); - let sigma = Evd.from_ctx (fst uctx) in - let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in - Inductiveops.control_only_guard (Global.env ()) body; - (** Declare the obligation ourselves and drop the hook *) - let prg = get_info (ProgMap.find name !from_prg) in - let ctx = Evd.evar_universe_context sigma in - let prg = { prg with prg_ctx = ctx } in - let obls, rem = prg.prg_obligations in - let obl = obls.(num) in - let status = - match obl.obl_status, opq with - | (_, Evar_kinds.Expand), Vernacexpr.Opaque _ -> err_not_transp () - | (true, _), Vernacexpr.Opaque _ -> err_not_transp () - | (false, _), Vernacexpr.Opaque _ -> Evar_kinds.Define true - | (_, Evar_kinds.Define true), Vernacexpr.Transparent -> Evar_kinds.Define false - | (_, status), Vernacexpr.Transparent -> status - in - let obl = { obl with obl_status = false, status } in - let uctx = Evd.evar_context_universe_context ctx in - let (_, obl) = declare_obligation prg obl body ty uctx in - let obls = Array.copy obls in - let _ = obls.(num) <- obl in - try - ignore (update_obls prg obls (pred rem)); - if pred rem > 0 then - begin - let deps = dependencies obls num in - if not (Int.Set.is_empty deps) then - ignore (auto (Some name) None deps) - end - with e when CErrors.noncritical e -> - let e = CErrors.push e in - pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e)) - -let obligation_hook prg obl num auto ctx' _ gr = - let obls, rem = prg.prg_obligations in - let cst = match gr with ConstRef cst -> cst | _ -> assert false in - let transparent = evaluable_constant cst (Global.env ()) in - let () = match obl.obl_status with - (true, Evar_kinds.Expand) - | (true, Evar_kinds.Define true) -> - if not transparent then err_not_transp () - | _ -> () -in - let obl = { obl with obl_body = Some (DefinedObl cst) } in - let () = if transparent then add_hint true prg cst in - let obls = Array.copy obls in - let _ = obls.(num) <- obl in - let ctx' = match ctx' with None -> prg.prg_ctx | Some ctx' -> ctx' in - let ctx' = - if not (pi2 prg.prg_kind) (* Not polymorphic *) then - (* The universe context was declared globally, we continue - from the new global environment. *) - 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 - let () = - try ignore (update_obls prg obls (pred rem)) - with e when CErrors.noncritical e -> - let e = CErrors.push e in - pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e)) - in - if pred rem > 0 then begin - let deps = dependencies obls num in - if not (Int.Set.is_empty deps) then - ignore (auto (Some prg.prg_name) None deps) - end - -let rec solve_obligation prg num tac = - let user_num = succ num in - let obls, rem = prg.prg_obligations in - let obl = obls.(num) in - let remaining = deps_remaining obls obl.obl_deps in - let () = - if not (Option.is_empty obl.obl_body) then - pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved."); - if not (List.is_empty remaining) then - pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " - ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) remaining)); - in - let obl = subst_deps_obl obls obl in - let kind = kind_of_obligation (pi2 prg.prg_kind) (snd 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 terminator guard hook = - Proof_global.make_terminator - (obligation_terminator prg.prg_name num guard hook auto) 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 ~terminator hook in - let _ = Pfedit.by !default_tactic in - Option.iter (fun tac -> Pfedit.set_end_tac tac) tac - -and obligation (user_num, name, typ) tac = - let num = pred user_num in - let prg = get_prog_err name in - let obls, rem = prg.prg_obligations in - if num < Array.length obls then - let obl = obls.(num) in - match obl.obl_body with - None -> solve_obligation prg num tac - | Some r -> error "Obligation already solved" - else error (sprintf "Unknown obligation number %i" (succ num)) - - -and solve_obligation_by_tac prg obls i tac = - let obl = obls.(i) in - match obl.obl_body with - | Some _ -> None - | None -> - try - if List.is_empty (deps_remaining obls obl.obl_deps) then - let obl = subst_deps_obl obls obl in - let tac = - match tac with - | Some t -> t - | None -> - match obl.obl_tac with - | Some t -> t - | None -> !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) (Evd.evar_universe_context evd) - in - let uctx = Evd.evar_context_universe_context ctx in - 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 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 - Some {prg with prg_ctx = ctx'}) - else Some prg - else None - with e when CErrors.noncritical e -> - let (e, _) = CErrors.push e in - match e with - | Refiner.FailError (_, s) -> - user_err ~loc:(fst obl.obl_location) ~hdr:"solve_obligation" (Lazy.force s) - | e -> None (* FIXME really ? *) - -and solve_prg_obligations prg ?oblset tac = - let obls, rem = prg.prg_obligations in - let rem = ref rem in - let obls' = Array.copy obls in - let set = ref Int.Set.empty in - let p = match oblset with - | None -> (fun _ -> true) - | Some s -> set := s; - (fun i -> Int.Set.mem i !set) - in - let prgref = ref prg in - let _ = - Array.iteri (fun i x -> - if p i then - match solve_obligation_by_tac !prgref obls' i tac with - | None -> () - | Some prg' -> - prgref := prg'; - let deps = dependencies obls i in - (set := Int.Set.union !set deps; - decr rem)) - obls' - in - update_obls !prgref obls' !rem - -and solve_obligations n tac = - let prg = get_prog_err n in - solve_prg_obligations prg tac - -and solve_all_obligations tac = - ProgMap.iter (fun k v -> ignore(solve_prg_obligations (get_info v) tac)) !from_prg - -and try_solve_obligation n prg tac = - let prg = get_prog prg in - let obls, rem = prg.prg_obligations in - let obls' = Array.copy obls in - match solve_obligation_by_tac prg obls' n tac with - | Some prg' -> ignore(update_obls prg' obls' (pred rem)) - | None -> () - -and try_solve_obligations n tac = - try ignore (solve_obligations n tac) with NoObligations _ -> () - -and auto_solve_obligations n ?oblset tac : progress = - Flags.if_verbose Feedback.msg_info (str "Solving obligations automatically..."); - try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent - -open Pp -let show_obligations_of_prg ?(msg=true) prg = - let n = prg.prg_name in - let obls, rem = prg.prg_obligations in - let showed = ref 5 in - if msg then Feedback.msg_info (int rem ++ str " obligation(s) remaining: "); - Array.iteri (fun i x -> - match x.obl_body with - | None -> - if !showed > 0 then ( - decr showed; - let x = subst_deps_obl obls x in - Feedback.msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ 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 _ -> ()) - obls - -let show_obligations ?(msg=true) n = - let progs = match n with - | None -> all_programs () - | Some n -> - try [ProgMap.find n !from_prg] - with Not_found -> raise (NoObligations (Some n)) - in List.iter (fun x -> show_obligations_of_prg ~msg (get_info x)) progs - -let show_term n = - let prg = get_prog_err n in - let n = prg.prg_name in - (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 ?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 = Id.print n ++ str " has type-checked" 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 Feedback.msg_info (info ++ str "."); - let cst = declare_definition prg in - Defined cst) - else ( - let len = Array.length obls in - let _ = Flags.if_verbose Feedback.msg_info (info ++ str ", generating " ++ int len ++ str " obligation(s)") in - 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 - | _ -> res) - -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 pl (Some b) t ctx deps (Some fixkind) - notations obls imps kind reduce hook - in progmap_add n (CEphemeron.create prg)) l; - let _defined = - List.fold_left (fun finished x -> - if finished then finished - else - let res = auto_solve_obligations (Some x) tactic in - match res with - | Defined _ -> - (* If one definition is turned into a constant, - the whole block is defined. *) true - | _ -> false) - false deps - in () - -let admit_prog prg = - let obls, rem = prg.prg_obligations in - let obls = Array.copy obls in - Array.iteri - (fun i x -> - match x.obl_body with - | None -> - let x = subst_deps_obl obls x in - let ctx = Evd.evar_context_universe_context prg.prg_ctx in - let kn = Declare.declare_constant x.obl_name ~local:true - (ParameterEntry (None,false,(x.obl_type,ctx),None), IsAssumption Conjectural) - in - assumption_message x.obl_name; - obls.(i) <- { x with obl_body = Some (DefinedObl kn) } - | Some _ -> ()) - obls; - ignore(update_obls prg obls 0) - -let rec admit_all_obligations () = - let prg = try Some (get_any_prog ()) with NoObligations _ -> None in - match prg with - | None -> () - | Some prg -> - admit_prog prg; - admit_all_obligations () - -let admit_obligations n = - match n with - | None -> admit_all_obligations () - | Some _ -> - let prg = get_prog_err n in - admit_prog prg - -let next_obligation n tac = - let prg = match n with - | None -> get_any_prog_err () - | Some _ -> get_prog_err n - in - let obls, rem = prg.prg_obligations in - let is_open _ x = Option.is_empty x.obl_body && List.is_empty (deps_remaining obls x.obl_deps) in - let i = match Array.findi is_open obls with - | Some i -> i - | None -> anomaly (Pp.str "Could not find a solvable obligation.") - in - solve_obligation prg i tac - -let init_program () = - Coqlib.check_required_library Coqlib.datatypes_module_name; - Coqlib.check_required_library ["Coq";"Init";"Specif"]; - Coqlib.check_required_library ["Coq";"Program";"Tactics"] - - -let set_program_mode c = - if c then - if !Flags.program_mode then () - else begin - init_program (); - Flags.program_mode := true; - end diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli deleted file mode 100644 index 80b6891447..0000000000 --- a/toplevel/obligations.mli +++ /dev/null @@ -1,113 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* definition_kind -> Univ.universe_context -> Id.t -> - Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref - -val declare_definition_ref : - (Id.t -> definition_kind -> - 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 - -val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t -val sort_dependencies : (Evar.t * evar_info * Evar.Set.t) list -> (Evar.t * evar_info * Evar.Set.t) list - -(* env, id, evars, number of function prototypes to try to clear from - evars contexts, object and type *) -val eterm_obligations : env -> Id.t -> evar_map -> int -> - ?status:Evar_kinds.obligation_definition_status -> constr -> types -> - (Id.t * types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * - unit Proofview.tactic option) array - (* Existential key, obl. name, type as product, - location of the original evar, associated tactic, - status and dependencies as indexes into the array *) - * ((existential_key * Id.t) list * ((Id.t -> constr) -> constr -> constr)) * - constr * types - (* Translations from existential identifiers to obligation identifiers - and for terms with existentials to closed terms, given a - translation from obligation identifiers to constrs, new term, new type *) - -type obligation_info = - (Id.t * Term.types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * unit Proofview.tactic option) array - (* ident, type, location, (opaque or transparent, expand or define), - dependencies, tactic to solve it *) - -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 default_tactic : unit Proofview.tactic ref - -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 -> - ?reduce:(Term.constr -> Term.constr) -> - ?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 - -type fixpoint_kind = - | IsFixpoint of (Id.t Loc.located option * Constrexpr.recursion_order_expr) list - | IsCoFixpoint - -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) -> - ?hook:(Evd.evar_universe_context -> unit) Lemmas.declaration_hook -> ?opaque:bool -> - notations -> - fixpoint_kind -> unit - -val obligation : int * Names.Id.t option * Constrexpr.constr_expr option -> - Genarg.glob_generic_argument option -> unit - -val next_obligation : Names.Id.t option -> Genarg.glob_generic_argument option -> unit - -val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress -(* Number of remaining obligations to be solved for this program *) - -val solve_all_obligations : unit Proofview.tactic option -> unit - -val try_solve_obligation : int -> Names.Id.t option -> unit Proofview.tactic option -> unit - -val try_solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> unit - -val show_obligations : ?msg:bool -> Names.Id.t option -> unit - -val show_term : Names.Id.t option -> std_ppcmds - -val admit_obligations : Names.Id.t option -> unit - -exception NoObligations of Names.Id.t option - -val explain_no_obligations : Names.Id.t option -> Pp.std_ppcmds - -val set_program_mode : bool -> unit diff --git a/toplevel/record.ml b/toplevel/record.ml deleted file mode 100644 index d5faafaf89..0000000000 --- a/toplevel/record.ml +++ /dev/null @@ -1,583 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* !primitive_flag) ; - optwrite = (fun b -> primitive_flag := b) } - -let typeclasses_strict = ref false -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "strict typeclass resolution"; - optkey = ["Typeclasses";"Strict";"Resolution"]; - optread = (fun () -> !typeclasses_strict); - optwrite = (fun b -> typeclasses_strict := b); } - -let typeclasses_unique = ref false -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "unique typeclass instances"; - optkey = ["Typeclasses";"Unique";"Instances"]; - optread = (fun () -> !typeclasses_unique); - optwrite = (fun b -> typeclasses_unique := b); } - -let interp_fields_evars env evars impls_env nots l = - List.fold_left2 - (fun (env, uimpls, params, impls) no ((loc, i), b, t) -> - let t', impl = interp_type_evars_impls env evars ~impls t in - let b' = Option.map (fun x -> fst (interp_casted_constr_evars_impls env evars ~impls x t')) b in - let impls = - match i with - | Anonymous -> impls - | Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method t' impl) impls - 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 d (env, univ) -> - let univ = - if is_local_assum d then - let s = Retyping.get_sort_of env evars (RelDecl.get_type d) in - Univ.sup (univ_of_sort s) univ - else univ - in (push_rel d env, univ)) - l (env, Univ.type0m_univ) - -let binder_of_decl = function - | Vernacexpr.AssumExpr(n,t) -> (n,None,t) - | Vernacexpr.DefExpr(n,c,t) -> (n,Some c, match t with Some c -> c | None -> CHole (fst n, None, Misctypes.IntroAnonymous, None)) - -let binders_of_decls = List.map binder_of_decl - -let typecheck_params_and_fields def id pl t ps nots fs = - let env0 = Global.env () 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 - | Default _, Anonymous -> - user_err ~loc ~hdr:"record" (str "Record parameters must be named") - | _ -> () - in - List.iter - (function LocalRawDef (b, _) -> error default_binder_kind b - | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls - | LocalPattern _ -> assert false) ps - in - let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in - let t', template = match t with - | Some t -> - let env = push_rel_context newps env0 in - let poly = - match t with - | CSort (_, Misctypes.GType []) -> true | _ -> false in - let s = interp_type_evars env evars ~impls:empty_internalization_env t in - let sred = Reductionops.whd_all env !evars s in - (match kind_of_term sred with - | Sort s' -> - (if poly then - match Evd.is_sort_variable !evars s' with - | Some l -> evars := Evd.make_flexible_variable !evars true l; - sred, true - | None -> s, false - else s, false) - | _ -> user_err ~loc:(constr_loc t) (str"Sort expected.")) - | None -> - 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 (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 - let sigma = - 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 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 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 - 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 = Context.Rel.map nf newps in - let newfs = Context.Rel.map nf newfs 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 - -let degenerate_decl decl = - let id = match RelDecl.get_name decl with - | Name id -> id - | Anonymous -> anomaly (Pp.str "Unnamed record variable") in - match decl with - | LocalAssum (_,t) -> (id, LocalAssumEntry t) - | LocalDef (_,b,_) -> (id, LocalDefEntry b) - -type record_error = - | MissingProj of Id.t * Id.t list - | BadTypedProj of Id.t * env * Type_errors.type_error - -let warn_cannot_define_projection = - CWarnings.create ~name:"cannot-define-projection" ~category:"records" - (fun msg -> hov 0 msg) - -(* If a projection is not definable, we throw an error if the user -asked it to be a coercion. Otherwise, we just print an info -message. The user might still want to name the field of the record. *) -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 - (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.") - | BadTypedProj (fi,ctx,te) -> - match te with - | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) -> - (pr_id fi ++ - strbrk" cannot be defined because it is informative and " ++ - Printer.pr_inductive (Global.env()) indsp ++ - strbrk " is not.") - | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) -> - (pr_id fi ++ - strbrk" cannot be defined because it is large and " ++ - Printer.pr_inductive (Global.env()) indsp ++ - strbrk " is not.") - | _ -> - (pr_id fi ++ strbrk " cannot be defined because it is not typable.") - in - if coe then user_err ~hdr:"structure" st; - Flags.if_verbose Feedback.msg_info (hov 0 st) - -type field_status = - | NoProjection of Name.t - | Projection of constr - -exception NotDefinable of record_error - -(* This replaces previous projection bodies in current projection *) -(* Undefined projs are collected and, at least one undefined proj occurs *) -(* in the body of current projection then the latter can not be defined *) -(* [c] is defined in ctxt [[params;fields]] and [l] is an instance of *) -(* [[fields]] defined in ctxt [[params;x:ind]] *) -let subst_projection fid l c = - let lv = List.length l in - let bad_projs = ref [] in - let rec substrec depth c = match kind_of_term c with - | Rel k -> - (* We are in context [[params;fields;x:ind;...depth...]] *) - if k <= depth+1 then - c - else if k-depth-1 <= lv then - match List.nth l (k-depth-2) with - | Projection t -> lift depth t - | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k - | NoProjection Anonymous -> - user_err (str "Field " ++ pr_id fid ++ - str " depends on the " ++ pr_nth (k-depth-1) ++ str - " field which has no name.") - else - mkRel (k-lv) - | _ -> map_constr_with_binders succ substrec depth c - in - let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *) - let c'' = substrec 0 c' in - if not (List.is_empty !bad_projs) then - raise (NotDefinable (MissingProj (fid,List.rev !bad_projs))); - c'' - -let instantiate_possibly_recursive_type indu paramdecls fields = - let subst = List.map_i (fun i _ -> mkRel i) 1 paramdecls in - Termops.substl_rel_context (subst@[mkIndU indu]) fields - -let warn_non_primitive_record = - CWarnings.create ~name:"non-primitive-record" ~category:"record" - (fun (env,indsp) -> - (hov 0 (str "The record " ++ Printer.pr_inductive env indsp ++ - strbrk" could not be defined as a primitive record"))) - -(* We build projections *) -let declare_projections indsp ?(kind=StructureComponent) binder_name coers fieldimpls fields = - let env = Global.env() in - 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 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, 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 - let primitive = - if !primitive_flag then - let is_primitive = - match mib.mind_record with - | Some (Some _) -> true - | Some None | None -> false - in - if not is_primitive then - warn_non_primitive_record (env,indsp); - is_primitive - else false - in - let (_,_,kinds,sp_projs,_) = - List.fold_left3 - (fun (nfi,i,kinds,sp_projs,subst) coe decl impls -> - let fi = RelDecl.get_name decl in - let ti = RelDecl.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 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 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 - let p = mkLambda (x, lift 1 rp, ccl') in - let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in - let ci = Inductiveops.make_case_info env indsp LetStyle in - mkCase (ci, p, mkRel 1, [|branch|]) - in - let proj = - it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in - let projtyp = - it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in - try - let entry = { - const_entry_body = - Future.from_val (Safe_typing.mk_pure_proof proj); - const_entry_secctx = None; - const_entry_type = Some projtyp; - const_entry_polymorphic = poly; - 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 - let k = (DefinitionEntry entry,IsDefinition kind) 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) - in - Declare.definition_message fid; - kn, constr_fip - with Type_errors.TypeError (ctx,te) -> - raise (NotDefinable (BadTypedProj (fid,ctx,te))) - in - let refi = ConstRef kn in - Impargs.maybe_declare_manual_implicits false refi impls; - if coe then begin - 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 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, 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 - | [decl] -> - let env = Environ.empty_named_context_val in - let evm = Sigma.Unsafe.of_evar_map evm in - let Sigma (_, evm, _) = Evarutil.new_pure_evar env evm (RelDecl.get_type decl) in - let evm = Sigma.to_evar_map evm in - evm - | decl::tl -> - let env = Environ.empty_named_context_val in - let evm = Sigma.Unsafe.of_evar_map evm in - let Sigma (ev, evm, _) = Evarutil.new_pure_evar env evm (RelDecl.get_type decl) in - let evm = Sigma.to_evar_map evm in - let new_tl = Util.List.map_i - (fun pos decl -> - RelDecl.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) - -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.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 = - match name with - | None -> Id.of_string (Unicode.lowercase_first_char (Id.to_string id)) - | Some n -> n - in - let mie_ind = - { mind_entry_typename = id; - mind_entry_arity = arity; - mind_entry_template = not poly && template; - mind_entry_consnames = [idbuild]; - mind_entry_lc = [type_constructor] } - in - let mie = - { mind_entry_params = List.map degenerate_decl params; - mind_entry_record = Some (if !primitive_flag then Some binder_name else None); - mind_entry_finite = finite; - mind_entry_inds = [mie_ind]; - 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 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 - let build = ConstructRef cstr in - let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in - Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs); - rsp - -let implicits_of_context ctx = - List.map_i (fun i name -> - let explname = - match name with - | Name n -> Some n - | Anonymous -> None - in ExplByPos (i, explname), (true, true, true)) - 1 (List.rev (Anonymous :: (List.map RelDecl.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 = - let fieldimpls = - (* Make the class implicit in the projections, and the params if applicable. *) - let len = List.length params in - let impls = implicits_of_context params in - List.map (fun x -> impls @ Impargs.lift_implicits (succ len) x) fieldimpls - in - let binder_name = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in - let impl, projs = - match fields with - | [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 = - 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 - 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) - coers priorities - in - let l = List.map3 (fun decl b y -> RelDecl.get_name decl, b, y) - (List.rev fields) coers (Recordops.lookup_projections ind) - in IndRef ind, l - in - let ctx_context = - List.map (fun decl -> - match Typeclasses.class_of_constr (RelDecl.get_type decl) with - | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true) - | None -> None) - params, params - in - let k = - { cl_impl = impl; - cl_strict = !typeclasses_strict; - cl_unique = !typeclasses_unique; - cl_context = ctx_context; - cl_props = fields; - cl_projs = projs } - in - add_class k; impl - - -let add_constant_class cst = - let ty = Universes.unsafe_type_of_global (ConstRef cst) in - let ctx, arity = decompose_prod_assum ty in - let tc = - { cl_impl = ConstRef cst; - cl_context = (List.map (const None) ctx, ctx); - cl_props = [LocalAssum (Anonymous, arity)]; - cl_projs = []; - cl_strict = !typeclasses_strict; - cl_unique = !typeclasses_unique - } - in add_class tc; - set_typeclass_transparency (EvalConstRef cst) false false - -let add_inductive_class ind = - let mind, oneind = Global.lookup_inductive ind in - let k = - let ctx = oneind.mind_arity_ctxt in - let inst = Univ.UContext.instance mind.mind_universes in - let ty = Inductive.type_of_inductive - (push_rel_context ctx (Global.env ())) - ((mind,oneind),inst) - in - { cl_impl = IndRef ind; - cl_context = List.map (const None) ctx, ctx; - cl_props = [LocalAssum (Anonymous, ty)]; - cl_projs = []; - cl_strict = !typeclasses_strict; - cl_unique = !typeclasses_unique } - in add_class k - -let declare_existing_class g = - match g with - | ConstRef x -> add_constant_class x - | IndRef x -> add_inductive_class x - | _ -> user_err ~hdr:"declare_existing_class" - (Pp.str"Unsupported class type, only constants and inductives are allowed") - -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),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 - let extract_name acc = function - Vernacexpr.AssumExpr((_,Name id),_) -> id::acc - | Vernacexpr.DefExpr ((_,Name id),_,_) -> id::acc - | _ -> acc in - let allnames = idstruc::(List.fold_left extract_name [] fs) in - let () = match List.duplicates Id.equal allnames with - | [] -> () - | id :: _ -> user_err (str "Two objects have the same name" ++ spc () ++ quote (Id.print id)) - in - let isnot_class = match kind with Class false -> false | _ -> true in - 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 (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 - let gr = match kind with - | Class def -> - let priorities = List.map (fun id -> {hint_priority = id; hint_pattern = None}) priorities in - let gr = declare_class finite def poly ctx (loc,idstruc) idbuild - implpars params arity template implfs fields is_coe coers priorities sign in - gr - | _ -> - let implfs = List.map - (fun impls -> implpars @ Impargs.lift_implicits - (succ (List.length params)) impls) implfs in - let ind = declare_structure finite poly ctx idstruc - 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/record.mli b/toplevel/record.mli deleted file mode 100644 index c50e577860..0000000000 --- a/toplevel/record.mli +++ /dev/null @@ -1,46 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ?kind:Decl_kinds.definition_object_kind -> Id.t -> - 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 -> Context.Rel.t -> (** params *) constr -> (** arity *) - bool (** template arity ? *) -> - Impargs.manual_explicitation list list -> Context.Rel.t -> (** fields *) - ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t -> - bool -> (** coercion? *) - bool list -> (** field coercions *) - Evd.evar_map -> - inductive - -val definition_structure : - 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 - -val declare_existing_class : global_reference -> unit diff --git a/toplevel/search.ml b/toplevel/search.ml deleted file mode 100644 index e1b56b1319..0000000000 --- a/toplevel/search.ml +++ /dev/null @@ -1,381 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* env -> constr -> bool -type display_function = global_reference -> env -> constr -> unit - -(* This option restricts the output of [SearchPattern ...], -[SearchAbout ...], etc. to the names of the symbols matching the -query, separated by a newline. This type of output is useful for -editors (like emacs), to generate a list of completion candidates -without having to parse thorugh the types of all symbols. *) - -type glob_search_about_item = - | GlobSearchSubPattern of constr_pattern - | GlobSearchString of string - -module SearchBlacklist = - Goptions.MakeStringTable - (struct - let key = ["Search";"Blacklist"] - let title = "Current search blacklist : " - let member_message s b = - str "Search blacklist does " ++ (if b then mt () else str "not ") ++ str "include " ++ str s - let synchronous = true - end) - -(* The functions iter_constructors and iter_declarations implement the behavior - needed for the Coq searching commands. - These functions take as first argument the procedure - that will be called to treat each entry. This procedure receives the name - of the object, the assumptions that will make it possible to print its type, - and the constr term that represent its type. *) - -let iter_constructors indsp u fn env nconstr = - for i = 1 to nconstr do - let typ = Inductiveops.type_of_constructor env ((indsp, i), u) in - fn (ConstructRef (indsp, i)) env typ - done - -let iter_named_context_name_type f = - List.iter (fun decl -> f (NamedDecl.get_id decl) (NamedDecl.get_type decl)) - -(* General search over hypothesis of a goal *) -let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) = - let env = Global.env () in - let iter_hyp idh typ = fn (VarRef idh) env typ in - let evmap,e = Pfedit.get_goal_context glnum in - let pfctxt = named_context e in - iter_named_context_name_type iter_hyp pfctxt - -(* General search over declarations *) -let iter_declarations (fn : global_reference -> env -> constr -> unit) = - let env = Global.env () in - let iter_obj (sp, kn) lobj = match object_tag lobj with - | "VARIABLE" -> - begin try - let decl = Global.lookup_named (basename sp) in - fn (VarRef (NamedDecl.get_id decl)) env (NamedDecl.get_type decl) - with Not_found -> (* we are in a section *) () end - | "CONSTANT" -> - let cst = Global.constant_of_delta_kn kn in - let gr = ConstRef cst in - let typ = Global.type_of_global_unsafe gr in - fn gr env typ - | "INDUCTIVE" -> - let mind = Global.mind_of_delta_kn kn in - let mib = Global.lookup_mind mind in - let iter_packet i mip = - let ind = (mind, i) in - let u = Declareops.inductive_instance mib in - let i = (ind, u) in - let typ = Inductiveops.type_of_inductive env i in - let () = fn (IndRef ind) env typ in - let len = Array.length mip.mind_user_lc in - iter_constructors ind u fn env len - in - Array.iteri iter_packet mib.mind_packets - | _ -> () - in - try Declaremods.iter_all_segments iter_obj - with Not_found -> () - -let generic_search glnumopt fn = - (match glnumopt with - | None -> () - | Some glnum -> iter_hypothesis glnum fn); - iter_declarations fn - -(** This module defines a preference on constrs in the form of a - [compare] function (preferred constr must be big for this - functions, so preferences such as small constr must use a reversed - order). This priority will be used to order search results and - propose first results which are more likely to be relevant to the - query, this is why the type [t] contains the other elements - required of a search. *) -module ConstrPriority = struct - - (* The priority is memoised here. Because of the very localised use - of this module, it is not worth it making a convenient interface. *) - type t = - Globnames.global_reference * Environ.env * Constr.t * priority - and priority = int - - module ConstrSet = CSet.Make(Constr) - - (** A measure of the size of a term *) - let rec size t = - Constr.fold (fun s t -> 1 + s + size t) 0 t - - (** Set of the "symbols" (definitions, inductives, constructors) - which appear in a term. *) - let rec symbols acc t = - let open Constr in - match kind t with - | Const _ | Ind _ | Construct _ -> ConstrSet.add t acc - | _ -> Constr.fold symbols acc t - - (** The number of distinct "symbols" (see {!symbols}) which appear - in a term. *) - let num_symbols t = - ConstrSet.(cardinal (symbols empty t)) - - let priority t : priority = - -(3*(num_symbols t) + size t) - - let compare (_,_,_,p1) (_,_,_,p2) = - compare p1 p2 -end - -module PriorityQueue = Heap.Functional(ConstrPriority) - -let rec iter_priority_queue q fn = - (* use an option to make the function tail recursive. Will be - obsoleted with Ocaml 4.02 with the [match … with | exception …] - syntax. *) - let next = begin - try Some (PriorityQueue.maximum q) - with Heap.EmptyHeap -> None - end in - match next with - | Some (gref,env,t,_) -> - fn gref env t; - iter_priority_queue (PriorityQueue.remove q) fn - | None -> () - -let prioritize_search seq fn = - let acc = ref PriorityQueue.empty in - let iter gref env t = - let p = ConstrPriority.priority t in - acc := PriorityQueue.add (gref,env,t,p) !acc - in - let () = seq iter in - iter_priority_queue !acc fn - -(** Filters *) - -(** This function tries to see whether the conclusion matches a pattern. *) -(** FIXME: this is quite dummy, we may find a more efficient algorithm. *) -let rec pattern_filter pat ref env typ = - let typ = Termops.strip_outer_cast typ in - if Constr_matching.is_matching env Evd.empty pat typ then true - else match kind_of_term typ with - | Prod (_, _, typ) - | LetIn (_, _, _, typ) -> pattern_filter pat ref env typ - | _ -> false - -let rec head_filter pat ref env typ = - let typ = Termops.strip_outer_cast typ in - if Constr_matching.is_matching_head env Evd.empty pat typ then true - else match kind_of_term typ with - | Prod (_, _, typ) - | LetIn (_, _, _, typ) -> head_filter pat ref env typ - | _ -> false - -let full_name_of_reference ref = - let (dir,id) = repr_path (path_of_global ref) in - DirPath.to_string dir ^ "." ^ Id.to_string id - -(** Whether a reference is blacklisted *) -let blacklist_filter_aux () = - let l = SearchBlacklist.elements () in - fun ref env typ -> - let name = full_name_of_reference ref in - let is_not_bl str = not (String.string_contains ~where:name ~what:str) in - List.for_all is_not_bl l - -let module_filter (mods, outside) ref env typ = - let sp = path_of_global ref in - let sl = dirpath sp in - let is_outside md = not (is_dirpath_prefix_of md sl) in - let is_inside md = is_dirpath_prefix_of md sl in - if outside then List.for_all is_outside mods - else List.is_empty mods || List.exists is_inside mods - -let name_of_reference ref = Id.to_string (basename_of_global ref) - -let search_about_filter query gr env typ = match query with -| GlobSearchSubPattern pat -> - Constr_matching.is_matching_appsubterm ~closed:false env Evd.empty pat typ -| GlobSearchString s -> - String.string_contains ~where:(name_of_reference gr) ~what:s - - -(** SearchPattern *) - -let search_pattern gopt pat mods pr_search = - let blacklist_filter = blacklist_filter_aux () in - let filter ref env typ = - module_filter mods ref env typ && - pattern_filter pat ref env typ && - blacklist_filter ref env typ - in - let iter ref env typ = - if filter ref env typ then pr_search ref env typ - in - generic_search gopt iter - -(** SearchRewrite *) - -let eq = Coqlib.glob_eq - -let rewrite_pat1 pat = - PApp (PRef eq, [| PMeta None; pat; PMeta None |]) - -let rewrite_pat2 pat = - PApp (PRef eq, [| PMeta None; PMeta None; pat |]) - -let search_rewrite gopt pat mods pr_search = - let pat1 = rewrite_pat1 pat in - let pat2 = rewrite_pat2 pat in - let blacklist_filter = blacklist_filter_aux () in - let filter ref env typ = - module_filter mods ref env typ && - (pattern_filter pat1 ref env typ || - pattern_filter pat2 ref env typ) && - blacklist_filter ref env typ - in - let iter ref env typ = - if filter ref env typ then pr_search ref env typ - in - generic_search gopt iter - -(** Search *) - -let search_by_head gopt pat mods pr_search = - let blacklist_filter = blacklist_filter_aux () in - let filter ref env typ = - module_filter mods ref env typ && - head_filter pat ref env typ && - blacklist_filter ref env typ - in - let iter ref env typ = - if filter ref env typ then pr_search ref env typ - in - generic_search gopt iter - -(** SearchAbout *) - -let search_about gopt items mods pr_search = - let blacklist_filter = blacklist_filter_aux () in - let filter ref env typ = - let eqb b1 b2 = if b1 then b2 else not b2 in - module_filter mods ref env typ && - List.for_all - (fun (b,i) -> eqb b (search_about_filter i ref env typ)) items && - blacklist_filter ref env typ - in - let iter ref env typ = - if filter ref env typ then pr_search ref env typ - in - generic_search gopt iter - -type search_constraint = - | Name_Pattern of Str.regexp - | Type_Pattern of Pattern.constr_pattern - | SubType_Pattern of Pattern.constr_pattern - | In_Module of Names.DirPath.t - | Include_Blacklist - -type 'a coq_object = { - coq_object_prefix : string list; - coq_object_qualid : string list; - coq_object_object : 'a; -} - -let interface_search = - let rec extract_flags name tpe subtpe mods blacklist = function - | [] -> (name, tpe, subtpe, mods, blacklist) - | (Name_Pattern regexp, b) :: l -> - extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l - | (Type_Pattern pat, b) :: l -> - extract_flags name ((pat, b) :: tpe) subtpe mods blacklist l - | (SubType_Pattern pat, b) :: l -> - extract_flags name tpe ((pat, b) :: subtpe) mods blacklist l - | (In_Module id, b) :: l -> - extract_flags name tpe subtpe ((id, b) :: mods) blacklist l - | (Include_Blacklist, b) :: l -> - extract_flags name tpe subtpe mods b l - in - fun ?glnum flags -> - let (name, tpe, subtpe, mods, blacklist) = - extract_flags [] [] [] [] false flags - in - let blacklist_filter = blacklist_filter_aux () in - let filter_function ref env constr = - let id = Names.Id.to_string (Nametab.basename_of_global ref) in - let path = Libnames.dirpath (Nametab.path_of_global ref) in - let toggle x b = if x then b else not b in - let match_name (regexp, flag) = - toggle (Str.string_match regexp id 0) flag - in - let match_type (pat, flag) = - toggle (Constr_matching.is_matching env Evd.empty pat constr) flag - in - let match_subtype (pat, flag) = - toggle - (Constr_matching.is_matching_appsubterm ~closed:false - env Evd.empty pat constr) flag - in - let match_module (mdl, flag) = - toggle (Libnames.is_dirpath_prefix_of mdl path) flag - in - List.for_all match_name name && - List.for_all match_type tpe && - List.for_all match_subtype subtpe && - List.for_all match_module mods && - (blacklist || blacklist_filter ref env constr) - in - let ans = ref [] in - let print_function ref env constr = - let fullpath = DirPath.repr (Nametab.dirpath_of_global ref) in - let qualid = Nametab.shortest_qualid_of_global Id.Set.empty ref in - let (shortpath, basename) = Libnames.repr_qualid qualid in - let shortpath = DirPath.repr shortpath in - (* [shortpath] is a suffix of [fullpath] and we're looking for the missing - prefix *) - let rec prefix full short accu = match full, short with - | _, [] -> - let full = List.rev_map Id.to_string full in - (full, accu) - | _ :: full, m :: short -> - prefix full short (Id.to_string m :: accu) - | _ -> assert false - in - let (prefix, qualid) = prefix fullpath shortpath [Id.to_string basename] in - let answer = { - coq_object_prefix = prefix; - coq_object_qualid = qualid; - coq_object_object = string_of_ppcmds (pr_lconstr_env env Evd.empty constr); - } in - ans := answer :: !ans; - in - let iter ref env typ = - if filter_function ref env typ then print_function ref env typ - in - let () = generic_search glnum iter in - !ans - -let blacklist_filter ref env typ = - blacklist_filter_aux () ref env typ diff --git a/toplevel/search.mli b/toplevel/search.mli deleted file mode 100644 index c9167c485d..0000000000 --- a/toplevel/search.mli +++ /dev/null @@ -1,84 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* env -> constr -> bool -type display_function = global_reference -> env -> constr -> unit - -(** {6 Generic filter functions} *) - -val blacklist_filter : filter_function -(** Check whether a reference is blacklisted. *) - -val module_filter : DirPath.t list * bool -> filter_function -(** Check whether a reference pertains or not to a set of modules *) - -val search_about_filter : glob_search_about_item -> filter_function -(** Check whether a reference matches a SearchAbout query. *) - -(** {6 Specialized search functions} - -[search_xxx gl pattern modinout] searches the hypothesis of the [gl]th -goal and the global environment for things matching [pattern] and -satisfying module exclude/include clauses of [modinout]. *) - -val search_by_head : int option -> constr_pattern -> DirPath.t list * bool - -> display_function -> unit -val search_rewrite : int option -> constr_pattern -> DirPath.t list * bool - -> display_function -> unit -val search_pattern : int option -> constr_pattern -> DirPath.t list * bool - -> display_function -> unit -val search_about : int option -> (bool * glob_search_about_item) list - -> DirPath.t list * bool -> display_function -> unit - -type search_constraint = - (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) - | Name_Pattern of Str.regexp - (** Whether the object type satisfies a pattern *) - | Type_Pattern of Pattern.constr_pattern - (** Whether some subtype of object type satisfies a pattern *) - | SubType_Pattern of Pattern.constr_pattern - (** Whether the object pertains to a module *) - | In_Module of Names.DirPath.t - (** Bypass the Search blacklist *) - | Include_Blacklist - -type 'a coq_object = { - coq_object_prefix : string list; - coq_object_qualid : string list; - coq_object_object : 'a; -} - -val interface_search : ?glnum:int -> (search_constraint * bool) list -> - string coq_object list - -(** {6 Generic search function} *) - -val generic_search : int option -> display_function -> unit -(** This function iterates over all hypothesis of the goal numbered - [glnum] (if present) and all known declarations. *) - -(** {6 Search function modifiers} *) - -val prioritize_search : (display_function -> unit) -> display_function -> unit -(** [prioritize_search iter] iterates over the values of [iter] (seen - as a sequence of declarations), in a relevance order. This requires to - perform the entire iteration of [iter] before starting streaming. So - [prioritize_search] should not be used for low-latency streaming. *) diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib index d689223639..10bf486476 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -1,19 +1,3 @@ -Himsg -ExplainErr -Class -Locality -Metasyntax -Auto_ind_decl -Search -Indschemes -Obligations -Command -Classes -Record -Assumptions -Vernacinterp -Mltop -Vernacentries Vernac Usage Coqloop diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index c1a659c38d..f914f83b9b 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -343,7 +343,7 @@ let compile verbosely f = let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in Library.save_library_raw lfdv sum lib univs proofs -let compile v f = +let compile v f = ignore(CoqworkmgrApi.get 1); compile v f; CoqworkmgrApi.giveback 1 diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml deleted file mode 100644 index 862a761b23..0000000000 --- a/toplevel/vernacentries.ml +++ /dev/null @@ -1,2258 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Classops.CL_FUN - | SortClass -> Classops.CL_SORT - | RefClass r -> Class.class_of_global (Smartlocate.smart_global ~head:true r) - -let scope_class_of_qualid qid = - Notation.scope_class_of_class (cl_of_qualid qid) - -(*******************) -(* "Show" commands *) - -let show_proof () = - (* spiwack: this would probably be cooler with a bit of polishing. *) - let p = Proof_global.give_me_the_proof () in - let pprf = Proof.partial_proof p in - Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl Printer.pr_constr pprf) - -let show_node () = - (* spiwack: I'm have little clue what this function used to do. I deactivated it, - could, possibly, be cleaned away. (Feb. 2010) *) - () - -let show_thesis () = - Feedback.msg_error (anomaly (Pp.str "TODO") ) - -let show_top_evars () = - (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) - let pfts = get_pftreestate () in - let gls = Proof.V82.subgoals pfts in - let sigma = gls.Evd.sigma in - Feedback.msg_notice (pr_evars_int sigma 1 (Evarutil.non_instantiated sigma)) - -let show_universes () = - let pfts = get_pftreestate () in - let gls = Proof.V82.subgoals pfts in - let sigma = gls.Evd.sigma in - let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in - Feedback.msg_notice (Evd.pr_evar_universe_context (Evd.evar_universe_context sigma)); - Feedback.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 *) - () - -let enable_goal_printing = ref true - -let print_subgoals () = - if !enable_goal_printing && is_verbose () - then begin - Feedback.msg_notice (pr_open_subgoals ()) - end - -let try_print_subgoals () = - try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> () - - - (* Simulate the Intro(s) tactic *) - -let show_intro all = - let pf = get_pftreestate() in - let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in - if not (List.is_empty gls) then begin - let gl = {Evd.it=List.hd gls ; sigma = sigma; } in - let l,_= decompose_prod_assum (Termops.strip_outer_cast (pf_concl gl)) in - if all then - let lid = Tactics.find_intro_names l gl in - Feedback.msg_notice (hov 0 (prlist_with_sep spc pr_id lid)) - else if not (List.is_empty l) then - let n = List.last l in - Feedback.msg_notice (pr_id (List.hd (Tactics.find_intro_names [n] gl))) - end - -(** Prepare a "match" template for a given inductive type. - For each branch of the match, we list the constructor name - followed by enough pattern variables. - [Not_found] is raised if the given string isn't the qualid of - a known inductive type. *) - -let make_cases_aux glob_ref = - match glob_ref with - | Globnames.IndRef i -> - let {Declarations.mind_nparams = np} - , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr } - = Global.lookup_inductive i in - Util.Array.fold_right2 - (fun consname typ l -> - let al = List.rev (fst (decompose_prod typ)) in - let al = Util.List.skipn np al in - let rec rename avoid = function - | [] -> [] - | (n,_)::l -> - let n' = Namegen.next_name_away_with_default (Id.to_string Namegen.default_dependent_ident) n avoid in - Id.to_string n' :: rename (n'::avoid) l in - let al' = rename [] al in - (Id.to_string consname :: al') :: l) - carr tarr [] - | _ -> raise Not_found - -let make_cases s = - let qualified_name = Libnames.qualid_of_string s in - let glob_ref = Nametab.locate qualified_name in - make_cases_aux glob_ref - -(** Textual display of a generic "match" template *) - -let show_match id = - let patterns = - try make_cases_aux (Nametab.global id) - with Not_found -> error "Unknown inductive type." - in - let pr_branch l = - str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>" - in - Feedback.msg_notice (v 1 (str "match # with" ++ fnl () ++ - prlist_with_sep fnl pr_branch patterns ++ fnl () ++ str "end" ++ fnl ())) - -(* "Print" commands *) - -let print_path_entry p = - let dir = pr_dirpath (Loadpath.logical p) in - let path = str (Loadpath.physical p) in - (dir ++ str " " ++ tbrk (0, 0) ++ path) - -let print_loadpath dir = - let l = Loadpath.get_load_paths () in - let l = match dir with - | None -> l - | Some dir -> - let filter p = is_dirpath_prefix_of dir (Loadpath.logical p) in - List.filter filter l - in - Pp.t (str "Logical Path: " ++ - tab () ++ str "Physical path:" ++ fnl () ++ - prlist_with_sep fnl print_path_entry l) - -let print_modules () = - let opened = Library.opened_libraries () - and loaded = Library.loaded_libraries () in - (* we intersect over opened to preserve the order of opened since *) - (* non-commutative operations (e.g. visibility) are done at import time *) - let loaded_opened = List.intersect DirPath.equal opened loaded - and only_loaded = List.subtract DirPath.equal loaded opened in - str"Loaded and imported library files: " ++ - pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++ - str"Loaded and not imported library files: " ++ - pr_vertical_list pr_dirpath only_loaded - - -let print_module r = - let (loc,qid) = qualid_of_reference r in - try - let globdir = Nametab.locate_dir qid in - match globdir with - DirModule (dirpath,(mp,_)) -> - Feedback.msg_notice (Printmod.print_module (Printmod.printable_body dirpath) mp) - | _ -> raise Not_found - with - Not_found -> Feedback.msg_error (str"Unknown Module " ++ pr_qualid qid) - -let print_modtype r = - let (loc,qid) = qualid_of_reference r in - try - let kn = Nametab.locate_modtype qid in - Feedback.msg_notice (Printmod.print_modtype kn) - with Not_found -> - (* Is there a module of this name ? If yes we display its type *) - try - let mp = Nametab.locate_module qid in - Feedback.msg_notice (Printmod.print_module false mp) - with Not_found -> - Feedback.msg_error (str"Unknown Module Type or Module " ++ pr_qualid qid) - -let print_namespace ns = - let ns = List.rev (Names.DirPath.repr ns) in - (* [match_dirpath], [match_modulpath] are helpers for [matches] - which checks whether a constant is in the namespace [ns]. *) - let rec match_dirpath ns = function - | [] -> Some ns - | id::dir -> - begin match match_dirpath ns dir with - | Some [] as y -> y - | Some (a::ns') -> - if Names.Id.equal a id then Some ns' - else None - | None -> None - end - in - let rec match_modulepath ns = function - | MPbound _ -> None (* Not a proper namespace. *) - | MPfile dir -> match_dirpath ns (Names.DirPath.repr dir) - | MPdot (mp,lbl) -> - let id = Names.Label.to_id lbl in - begin match match_modulepath ns mp with - | Some [] as y -> y - | Some (a::ns') -> - if Names.Id.equal a id then Some ns' - else None - | None -> None - end - in - (* [qualified_minus n mp] returns a list of qualifiers representing - [mp] except the [n] first (in the concrete syntax order). The - idea is that if [mp] matches [ns], then [qualified_minus mp - (length ns)] will be the correct representation of [mp] assuming - [ns] is imported. *) - (* precondition: [mp] matches some namespace of length [n] *) - let qualified_minus n mp = - let rec list_of_modulepath = function - | MPbound _ -> assert false (* MPbound never matches *) - | MPfile dir -> Names.DirPath.repr dir - | MPdot (mp,lbl) -> (Names.Label.to_id lbl)::(list_of_modulepath mp) - in - snd (Util.List.chop n (List.rev (list_of_modulepath mp))) - in - let print_list pr l = prlist_with_sep (fun () -> str".") pr l in - let print_kn kn = - (* spiwack: I'm ignoring the dirpath, is that bad? *) - let (mp,_,lbl) = Names.repr_kn kn in - let qn = (qualified_minus (List.length ns) mp)@[Names.Label.to_id lbl] in - print_list pr_id qn - in - let print_constant k body = - (* FIXME: universes *) - let t = Typeops.type_of_constant_type (Global.env ()) body.Declarations.const_type in - print_kn k ++ str":" ++ spc() ++ Printer.pr_type t - in - let matches mp = match match_modulepath ns mp with - | Some [] -> true - | _ -> false in - let constants = (Environ.pre_env (Global.env ())).Pre_env.env_globals.Pre_env.env_constants in - let constants_in_namespace = - Cmap_env.fold (fun c (body,_) acc -> - let kn = user_con c in - if matches (modpath kn) then - acc++fnl()++hov 2 (print_constant kn body) - else - acc - ) constants (str"") - in - Feedback.msg_notice ((print_list pr_id ns)++str":"++fnl()++constants_in_namespace) - -let print_strategy r = - let open Conv_oracle in - let pr_level = function - | Expand -> str "expand" - | Level 0 -> str "transparent" - | Level n -> str "level" ++ spc() ++ int n - | Opaque -> str "opaque" - in - let pr_strategy (ref, lvl) = pr_global ref ++ str " : " ++ pr_level lvl in - let oracle = Environ.oracle (Global.env ()) in - match r with - | None -> - let fold key lvl (vacc, cacc) = match key with - | VarKey id -> ((VarRef id, lvl) :: vacc, cacc) - | ConstKey cst -> (vacc, (ConstRef cst, lvl) :: cacc) - | RelKey _ -> (vacc, cacc) - in - let var_lvl, cst_lvl = fold_strategy fold oracle ([], []) in - let var_msg = - if List.is_empty var_lvl then mt () - else str "Variable strategies" ++ fnl () ++ - hov 0 (prlist_with_sep fnl pr_strategy var_lvl) ++ fnl () - in - let cst_msg = - if List.is_empty cst_lvl then mt () - else str "Constant strategies" ++ fnl () ++ - hov 0 (prlist_with_sep fnl pr_strategy cst_lvl) - in - Feedback.msg_notice (var_msg ++ cst_msg) - | Some r -> - let r = Smartlocate.smart_global r in - let key = match r with - | VarRef id -> VarKey id - | ConstRef cst -> ConstKey cst - | IndRef _ | ConstructRef _ -> error "The reference is not unfoldable" - in - let lvl = get_strategy oracle key in - Feedback.msg_notice (pr_strategy (r, lvl)) - -let dump_universes_gen g s = - let output = open_out s in - let output_constraint, close = - if Filename.check_suffix s ".dot" || Filename.check_suffix s ".gv" then begin - (* the lazy unit is to handle errors while printing the first line *) - let init = lazy (Printf.fprintf output "digraph universes {\n") in - begin fun kind left right -> - let () = Lazy.force init in - match kind with - | Univ.Lt -> - Printf.fprintf output " \"%s\" -> \"%s\" [style=bold];\n" right left - | Univ.Le -> - Printf.fprintf output " \"%s\" -> \"%s\" [style=solid];\n" right left - | Univ.Eq -> - Printf.fprintf output " \"%s\" -> \"%s\" [style=dashed];\n" left right - end, begin fun () -> - if Lazy.is_val init then Printf.fprintf output "}\n"; - close_out output - end - end else begin - begin fun kind left right -> - let kind = match kind with - | Univ.Lt -> "<" - | Univ.Le -> "<=" - | Univ.Eq -> "=" - in Printf.fprintf output "%s %s %s ;\n" left kind right - end, (fun () -> close_out output) - end - in - try - UGraph.dump_universes output_constraint g; - close (); - Feedback.msg_info (str "Universes written to file \"" ++ str s ++ str "\".") - with reraise -> - let reraise = CErrors.push reraise in - close (); - iraise reraise - -(*********************) -(* "Locate" commands *) - -let locate_file f = - let file = Flags.silently Loadpath.locate_file f in - str file - -let msg_found_library = function - | Library.LibLoaded, fulldir, file -> - Feedback.msg_info (hov 0 - (pr_dirpath fulldir ++ strbrk " has been loaded from file " ++ - str file)) - | Library.LibInPath, fulldir, file -> - Feedback.msg_info (hov 0 - (pr_dirpath fulldir ++ strbrk " is bound to file " ++ str file)) - -let err_unmapped_library loc ?from qid = - let dir = fst (repr_qualid qid) in - let prefix = match from with - | None -> str "." - | Some from -> - str " and prefix " ++ pr_dirpath from ++ str "." - in - user_err ~loc - ~hdr:"locate_library" - (strbrk "Cannot find a physical path bound to logical path matching suffix " ++ - pr_dirpath dir ++ prefix) - -let err_notfound_library loc ?from qid = - let prefix = match from with - | None -> str "." - | Some from -> - str " with prefix " ++ pr_dirpath from ++ str "." - in - user_err ~loc ~hdr:"locate_library" - (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) - -let print_located_library r = - let (loc,qid) = qualid_of_reference r in - try msg_found_library (Library.locate_qualified_library ~warn:false qid) - with - | Library.LibUnmappedDir -> err_unmapped_library loc qid - | Library.LibNotFound -> err_notfound_library loc qid - -let smart_global r = - let gr = Smartlocate.smart_global r in - Dumpglob.add_glob (Stdarg.loc_of_or_by_notation loc_of_reference r) gr; - gr - -let dump_global r = - try - let gr = Smartlocate.smart_global r in - Dumpglob.add_glob (Stdarg.loc_of_or_by_notation loc_of_reference r) gr - with e when CErrors.noncritical e -> () -(**********) -(* Syntax *) - -let vernac_syntax_extension locality local = - let local = enforce_module_locality locality local in - Metasyntax.add_syntax_extension local - -let vernac_delimiters sc = function - | Some lr -> Metasyntax.add_delimiters sc lr - | None -> Metasyntax.remove_delimiters sc - -let vernac_bind_scope sc cll = - Metasyntax.add_class_scope sc (List.map scope_class_of_qualid cll) - -let vernac_open_close_scope locality local (b,s) = - let local = enforce_section_locality locality local in - Notation.open_close_scope (local,b,s) - -let vernac_arguments_scope locality r scl = - let local = make_section_locality locality in - Notation.declare_arguments_scope local (smart_global r) scl - -let vernac_infix locality local = - let local = enforce_module_locality locality local in - Metasyntax.add_infix local - -let vernac_notation locality local = - let local = enforce_module_locality locality local in - Metasyntax.add_notation local - -(***********) -(* Gallina *) - -let start_proof_and_print k l hook = - let inference_hook = - if Flags.is_program_mode () then - let hook env sigma ev = - let tac = !Obligations.default_tactic in - let evi = Evd.find sigma ev in - let env = Evd.evar_filtered_env evi in - try - let concl = Evarutil.nf_evars_universes sigma evi.Evd.evar_concl in - if Evarutil.has_undefined_evars sigma concl then raise Exit; - let c, _, ctx = - Pfedit.build_by_tactic env (Evd.evar_universe_context sigma) - concl (Tacticals.New.tclCOMPLETE tac) - in Evd.set_universe_context sigma ctx, c - with Logic_monad.TacticFailure e when Logic.catchable_exception e -> - error "The statement obligations could not be resolved \ - automatically, write a statement definition first." - in Some hook - else None - in - start_proof_com ?inference_hook k l hook - -let no_hook = Lemmas.mk_hook (fun _ _ -> ()) - -let vernac_definition_hook p = function -| Coercion -> Class.add_coercion_hook p -| CanonicalStructure -> - Lemmas.mk_hook (fun _ -> Recordops.declare_canonical_structure) -| SubClass -> Class.add_subclass_hook p -| _ -> no_hook - -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 - | Discharge -> Dumpglob.dump_definition lid true "var" - | Local | Global -> Dumpglob.dump_definition lid false "def" - in - (match def with - | ProveBody (bl,t) -> (* local binders, typ *) - start_proof_and_print (local,p,DefinitionBody k) - [Some (lid,pl), (bl,t,None)] 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 (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 = - let local = enforce_locality_exp locality None in - if Dumpglob.dump () then - List.iter (fun (id, _) -> - match id with - | Some (lid,_) -> Dumpglob.dump_definition lid false "prf" - | None -> ()) l; - if not(refining ()) then - if lettop then - user_err ~hdr:"Vernacentries.StartProof" - (str "Let declarations can only be used in proof editing mode."); - start_proof_and_print (local, p, Proof kind) l no_hook - -let qed_display_script = ref true - -let vernac_end_proof ?proof = function - | Admitted -> save_proof ?proof Admitted - | Proved (_,_) as e -> - if is_verbose () && !qed_display_script && !Flags.coqtop_ui then - Stm.show_script ?proof (); - save_proof ?proof e - - (* A stupid macro that should be replaced by ``Exact c. Save.'' all along - the theories [??] *) - -let vernac_exact_proof c = - (* spiwack: for simplicity I do not enforce that "Proof proof_term" is - called only at the begining of a proof. *) - let status = by (Tactics.exact_proof c) in - save_proof (Vernacexpr.(Proved(Opaque None,None))); - if not status then Feedback.feedback Feedback.AddedAxiom - -let vernac_assumption locality poly (local, kind) l nl = - let local = enforce_locality_exp locality local in - let global = local == Global in - let kind = local, poly, kind in - List.iter (fun (is_coe,(idl,c)) -> - if Dumpglob.dump () then - 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 - if not status then Feedback.feedback Feedback.AddedAxiom - -let vernac_record k poly finite struc binders sort nameopt cfs = - let const = match nameopt with - | 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 (fst (snd struc)) false "rec"; - List.iter (fun (((_, x), _), _) -> - match x with - | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" - | _ -> ()) cfs); - ignore(Record.definition_structure (k,poly,finite,struc,binders,cfs,const,sort)) - -(** When [poly] is true the type is declared polymorphic. When [lo] is true, - then the type is declared private (as per the [Private] keyword). [finite] - indicates whether the type is inductive, co-inductive or - neither. *) -let vernac_inductive poly lo finite indl = - if Dumpglob.dump () then - List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) -> - match cstrs with - | Constructors cstrs -> - Dumpglob.dump_definition lid false "ind"; - List.iter (fun (_, (lid, _)) -> - Dumpglob.dump_definition lid false "constr") cstrs - | _ -> () (* dumping is done by vernac_record (called below) *) ) - indl; - match indl with - | [ ( _ , _ , _ ,(Record|Structure), Constructors _ ),_ ] -> - CErrors.error "The Record keyword is for types defined using the syntax { ... }." - | [ (_ , _ , _ ,Variant, RecordDecl _),_ ] -> - CErrors.error "The Variant keyword does not support syntax { ... }." - | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> - vernac_record (match b with Class _ -> Class false | _ -> b) - poly finite id bl c oc fs - | [ ( id , bl , c , Class _, 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), []) - in vernac_record (Class true) poly finite id bl c None [f] - | [ ( _ , _, _, Class _, Constructors _), [] ] -> - CErrors.error "Inductive classes not supported" - | [ ( id , bl , c , Class _, _), _ :: _ ] -> - CErrors.error "where clause not supported for classes" - | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] -> - CErrors.error "where clause not supported for (co)inductive records" - | _ -> let unpack = function - | ( (false, id) , bl , c , _ , Constructors l ) , ntn -> ( id , bl , c , l ) , ntn - | ( (true,_),_,_,_,Constructors _),_ -> - CErrors.error "Variant types do not handle the \"> Name\" syntax, which is reserved for records. Use the \":>\" syntax on constructors instead." - | _ -> CErrors.error "Cannot handle mutually (co)inductive records." - in - let indl = List.map unpack indl in - do_mutual_inductive indl poly lo finite - -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; - 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; - do_cofixpoint local poly l - -let vernac_scheme l = - if Dumpglob.dump () then - List.iter (fun (lid, s) -> - Option.iter (fun lid -> Dumpglob.dump_definition lid false "def") lid; - match s with - | InductionScheme (_, r, _) - | CaseScheme (_, r, _) - | EqualityScheme r -> dump_global r) l; - Indschemes.do_scheme l - -let vernac_combined_scheme lid l = - if Dumpglob.dump () then - (Dumpglob.dump_definition lid false "def"; - List.iter (fun lid -> dump_global (Misctypes.AN (Ident lid))) l); - Indschemes.do_combined_scheme lid l - -let vernac_universe loc poly l = - if poly && not (Lib.sections_are_opened ()) then - user_err ~loc ~hdr:"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 ~hdr:"vernac_constraint" - (str"Polymorphic universe constraints can only be declared" - ++ str " inside sections, use Monomorphic Constraint instead"); - do_constraint poly l - -(**********************) -(* Modules *) - -let vernac_import export refl = - Library.import_module export (List.map qualid_of_reference refl); - Lib.add_frozen_state () - -let vernac_declare_module export (loc, id) binders_ast mty_ast = - (* We check the state of the system (in section, in module type) - and what module information is supplied *) - if Lib.sections_are_opened () then - error "Modules and Module Types are not allowed inside sections."; - let binders_ast = List.map - (fun (export,idl,ty) -> - if not (Option.is_empty export) then - error "Arguments of a functor declaration cannot be exported. Remove the \"Export\" and \"Import\" keywords from every functor argument." - else (idl,ty)) binders_ast in - let mp = - Declaremods.declare_module Modintern.interp_module_ast - id binders_ast (Enforce mty_ast) [] - in - Dumpglob.dump_moddef loc mp "mod"; - if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared"); - Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export - -let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = - (* We check the state of the system (in section, in module type) - and what module information is supplied *) - if Lib.sections_are_opened () then - error "Modules and Module Types are not allowed inside sections."; - match mexpr_ast_l with - | [] -> - check_no_pending_proofs (); - let binders_ast,argsexport = - List.fold_right - (fun (export,idl,ty) (args,argsexport) -> - (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast - ([],[]) in - let mp = - Declaremods.start_module Modintern.interp_module_ast - export id binders_ast mty_ast_o - in - Dumpglob.dump_moddef loc mp "mod"; - if_verbose Feedback.msg_info - (str "Interactive Module " ++ pr_id id ++ str " started"); - List.iter - (fun (export,id) -> - Option.iter - (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export - ) argsexport - | _::_ -> - let binders_ast = List.map - (fun (export,idl,ty) -> - if not (Option.is_empty export) then - error "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument." - else (idl,ty)) binders_ast in - let mp = - Declaremods.declare_module Modintern.interp_module_ast - id binders_ast mty_ast_o mexpr_ast_l - in - Dumpglob.dump_moddef loc mp "mod"; - if_verbose Feedback.msg_info - (str "Module " ++ pr_id id ++ str " is defined"); - Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) - export - -let vernac_end_module export (loc,id as lid) = - let mp = Declaremods.end_module () in - Dumpglob.dump_modref loc mp "mod"; - if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined"); - Option.iter (fun export -> vernac_import export [Ident lid]) export - -let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = - if Lib.sections_are_opened () then - error "Modules and Module Types are not allowed inside sections."; - - match mty_ast_l with - | [] -> - check_no_pending_proofs (); - let binders_ast,argsexport = - List.fold_right - (fun (export,idl,ty) (args,argsexport) -> - (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast - ([],[]) in - - let mp = - Declaremods.start_modtype Modintern.interp_module_ast - id binders_ast mty_sign - in - Dumpglob.dump_moddef loc mp "modtype"; - if_verbose Feedback.msg_info - (str "Interactive Module Type " ++ pr_id id ++ str " started"); - List.iter - (fun (export,id) -> - Option.iter - (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export - ) argsexport - - | _ :: _ -> - let binders_ast = List.map - (fun (export,idl,ty) -> - if not (Option.is_empty export) then - error "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument." - else (idl,ty)) binders_ast in - let mp = - Declaremods.declare_modtype Modintern.interp_module_ast - id binders_ast mty_sign mty_ast_l - in - Dumpglob.dump_moddef loc mp "modtype"; - if_verbose Feedback.msg_info - (str "Module Type " ++ pr_id id ++ str " is defined") - -let vernac_end_modtype (loc,id) = - let mp = Declaremods.end_modtype () in - Dumpglob.dump_modref loc mp "modtype"; - if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined") - -let vernac_include l = - Declaremods.declare_include Modintern.interp_module_ast l - -(**********************) -(* Gallina extensions *) - -(* Sections *) - -let vernac_begin_section (_, id as lid) = - check_no_pending_proofs (); - Dumpglob.dump_definition lid true "sec"; - Lib.open_section id - -let vernac_end_section (loc,_) = - Dumpglob.dump_reference loc - (DirPath.to_string (Lib.current_dirpath true)) "<>" "sec"; - Lib.close_section () - -let vernac_name_sec_hyp (_,id) set = Proof_using.name_set id set - -(* Dispatcher of the "End" command *) - -let vernac_end_segment (_,id as lid) = - check_no_pending_proofs (); - match Lib.find_opening_node id with - | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid - | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid - | Lib.OpenedSection _ -> vernac_end_section lid - | _ -> assert false - -(* Libraries *) - -let vernac_require from import qidl = - let qidl = List.map qualid_of_reference qidl in - let root = match from with - | None -> None - | Some from -> - let (_, qid) = Libnames.qualid_of_reference from in - let (hd, tl) = Libnames.repr_qualid qid in - Some (Libnames.add_dirpath_suffix hd tl) - in - let locate (loc, qid) = - try - let warn = Flags.is_verbose () in - let (_, dir, f) = Library.locate_qualified_library ?root ~warn qid in - (dir, f) - with - | Library.LibUnmappedDir -> err_unmapped_library loc ?from:root qid - | Library.LibNotFound -> err_notfound_library loc ?from:root qid - in - let modrefl = List.map locate qidl in - if Dumpglob.dump () then - List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl); - Library.require_library_from_dirpath modrefl import - -(* Coercions and canonical structures *) - -let vernac_canonical r = - Recordops.declare_canonical_structure (smart_global r) - -let vernac_coercion locality poly local ref qids qidt = - let local = enforce_locality locality local in - let target = cl_of_qualid qidt in - let source = cl_of_qualid qids in - let ref' = smart_global ref in - Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target; - if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion") - -let vernac_identity_coercion locality poly local id qids qidt = - let local = enforce_locality locality local in - let target = cl_of_qualid qidt in - let source = cl_of_qualid qids in - Class.try_add_new_identity_coercion id ~local poly ~source ~target - -(* Type classes *) - -let vernac_instance abst locality poly sup inst props pri = - let global = not (make_section_locality locality) in - Dumpglob.dump_constraint inst false "inst"; - ignore(Classes.new_instance ~abstract:abst ~global poly sup inst props pri) - -let vernac_context poly l = - if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom - -let vernac_declare_instances locality insts = - let glob = not (make_section_locality locality) in - List.iter (fun (id, info) -> Classes.existing_instance glob id (Some info)) insts - -let vernac_declare_class id = - Record.declare_existing_class (Nametab.global id) - -(***********) -(* Solving *) - -let command_focus = Proof.new_focus_kind () -let focus_command_cond = Proof.no_cond command_focus - - (* 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 - there are no more goals to solve. It cannot be a tactic since - all tactics fail if there are no further goals to prove. *) - -let vernac_solve_existential = instantiate_nth_evar_com - -let vernac_set_end_tac tac = - let open Genintern in - let env = { genv = Global.env (); ltacvars = Id.Set.empty } in - let _, tac = Genintern.generic_intern env tac in - if not (refining ()) then - error "Unknown command of the non proof-editing mode."; - set_end_tac tac - (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) - -let vernac_set_used_variables e = - 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 (NamedDecl.get_id %> Id.equal id) vars) then - user_err ~hdr:"vernac_set_used_variables" - (str "Unknown variable: " ++ pr_id id)) - l; - let _, to_clear = set_used_variables l in - 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 = Tactics.clear to_clear in - fst (solve SelectAll None tac p), () - end - -(*****************************) -(* Auxiliary file management *) - -let expand filename = - Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) filename - -let vernac_add_loadpath implicit pdir ldiropt = - let pdir = expand pdir in - let alias = Option.default Nameops.default_root_prefix ldiropt in - Mltop.add_rec_path Mltop.AddTopML ~unix_path:pdir ~coq_root:alias ~implicit - -let vernac_remove_loadpath path = - Loadpath.remove_load_path (expand path) - - (* Coq syntax for ML or system commands *) - -let vernac_add_ml_path isrec path = - (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (expand path) - -let vernac_declare_ml_module locality l = - let local = make_locality locality in - Mltop.declare_ml_modules local (List.map expand l) - -let vernac_chdir = function - | None -> Feedback.msg_notice (str (Sys.getcwd())) - | Some path -> - begin - try Sys.chdir (expand path) - with Sys_error err -> - (* Cd is typically used to control the output directory of - extraction. A failed Cd could lead to overwriting .ml files - so we make it an error. *) - CErrors.error ("Cd failed: " ^ err) - end; - if_verbose Feedback.msg_info (str (Sys.getcwd())) - - -(********************) -(* State management *) - -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 - -(************) -(* Commands *) - -let vernac_create_hintdb locality id b = - let local = make_module_locality locality in - Hints.create_hint_db local id full_transparent_state b - -let vernac_remove_hints locality dbs ids = - let local = make_module_locality locality in - Hints.remove_hints local dbs (List.map Smartlocate.global_with_alias ids) - -let vernac_hints locality poly local lb h = - let local = enforce_module_locality locality local in - Hints.add_hints local lb (Hints.interp_hints poly h) - -let vernac_syntactic_definition locality lid x local y = - Dumpglob.dump_definition lid false "syndef"; - let local = enforce_module_locality locality local in - Metasyntax.add_syntactic_definition (snd lid) x local y - -let vernac_declare_implicits locality r l = - let local = make_section_locality locality in - match l with - | [] -> - Impargs.declare_implicits local (smart_global r) - | _::_ as imps -> - Impargs.declare_manual_implicits local (smart_global r) ~enriching:false - (List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps) - -let warn_arguments_assert = - CWarnings.create ~name:"arguments-assert" ~category:"vernacular" - (fun sr -> - strbrk "This command is just asserting the names of arguments of " ++ - pr_global sr ++ strbrk". If this is what you want add " ++ - strbrk "': assert' to silence the warning. If you want " ++ - strbrk "to clear implicit arguments add ': clear implicits'. " ++ - strbrk "If you want to clear notation scopes add ': clear scopes'") - -(* [nargs_for_red] is the number of arguments required to trigger reduction, - [args] is the main list of arguments statuses, - [more_implicits] is a list of extra lists of implicit statuses *) -let vernac_arguments locality reference args more_implicits nargs_for_red flags = - let assert_flag = List.mem `Assert flags in - let rename_flag = List.mem `Rename flags in - let clear_scopes_flag = List.mem `ClearScopes flags in - let extra_scopes_flag = List.mem `ExtraScopes flags in - let clear_implicits_flag = List.mem `ClearImplicits flags in - let default_implicits_flag = List.mem `DefaultImplicits flags in - let never_unfold_flag = List.mem `ReductionNeverUnfold flags in - - let err_incompat x y = - error ("Options \""^x^"\" and \""^y^"\" are incompatible.") in - - if assert_flag && rename_flag then - err_incompat "assert" "rename"; - if Option.has_some nargs_for_red && never_unfold_flag then - err_incompat "simpl never" "/"; - if never_unfold_flag && List.mem `ReductionDontExposeCase flags then - err_incompat "simpl never" "simpl nomatch"; - if clear_scopes_flag && extra_scopes_flag then - err_incompat "clear scopes" "extra scopes"; - if clear_implicits_flag && default_implicits_flag then - err_incompat "clear implicits" "default implicits"; - - let sr = smart_global reference in - let inf_names = - let ty = Global.type_of_global_unsafe sr in - Impargs.compute_implicits_names (Global.env ()) ty - in - let prev_names = - try Arguments_renaming.arguments_names sr with Not_found -> inf_names - in - let num_args = List.length inf_names in - assert (Int.equal num_args (List.length prev_names)); - - let names_of args = List.map (fun a -> a.name) args in - - (* Checks *) - - let err_extra_args names = - user_err ~hdr:"vernac_declare_arguments" - (strbrk "Extra arguments: " ++ - prlist_with_sep pr_comma pr_name names ++ str ".") - in - let err_missing_args names = - user_err ~hdr:"vernac_declare_arguments" - (strbrk "The following arguments are not declared: " ++ - prlist_with_sep pr_comma pr_name names ++ str ".") - in - - let rec check_extra_args extra_args = - match extra_args with - | [] -> () - | { notation_scope = None } :: _ -> err_extra_args (names_of extra_args) - | { name = Anonymous; notation_scope = Some _ } :: args -> - check_extra_args args - | _ -> - error "Extra notation scopes can be set on anonymous and explicit arguments only." - in - - let args, scopes = - let scopes = List.map (fun { notation_scope = s } -> s) args in - if List.length args > num_args then - let args, extra_args = List.chop num_args args in - if extra_scopes_flag then - (check_extra_args extra_args; (args, scopes)) - else err_extra_args (names_of extra_args) - else args, scopes - in - - if Option.cata (fun n -> n > num_args) false nargs_for_red then - error "The \"/\" modifier should be put before any extra scope."; - - let scopes_specified = List.exists Option.has_some scopes in - - if scopes_specified && clear_scopes_flag then - error "The \"clear scopes\" flag is incompatible with scope annotations."; - - let names = List.map (fun { name } -> name) args in - let names = names :: List.map (List.map fst) more_implicits in - - let rename_flag_required = ref false in - let example_renaming = ref None in - let save_example_renaming renaming = - rename_flag_required := !rename_flag_required - || not (Name.equal (fst renaming) Anonymous); - if Option.is_empty !example_renaming then - example_renaming := Some renaming - in - - let rec names_union names1 names2 = - match names1, names2 with - | [], [] -> [] - | _ :: _, [] -> names1 - | [], _ :: _ -> names2 - | (Name _ as name) :: names1, Anonymous :: names2 - | Anonymous :: names1, (Name _ as name) :: names2 -> - name :: names_union names1 names2 - | name1 :: names1, name2 :: names2 -> - if Name.equal name1 name2 then - name1 :: names_union names1 names2 - else error "Argument lists should agree on the names they provide." - in - - let names = List.fold_left names_union [] names in - - let rec rename prev_names names = - match prev_names, names with - | [], [] -> [] - | [], _ :: _ -> err_extra_args names - | _ :: _, [] when assert_flag -> - (* Error messages are expressed in terms of original names, not - renamed ones. *) - err_missing_args (List.lastn (List.length prev_names) inf_names) - | _ :: _, [] -> prev_names - | prev :: prev_names, Anonymous :: names -> - prev :: rename prev_names names - | prev :: prev_names, (Name id as name) :: names -> - if not (Name.equal prev name) then save_example_renaming (prev,name); - name :: rename prev_names names - in - - let names = rename prev_names names in - let renaming_specified = Option.has_some !example_renaming in - - if !rename_flag_required && not rename_flag then - user_err ~hdr:"vernac_declare_arguments" - (strbrk "To rename arguments the \"rename\" flag must be specified." - ++ spc () ++ - match !example_renaming with - | None -> mt () - | Some (o,n) -> - str "Argument " ++ pr_name o ++ - str " renamed to " ++ pr_name n ++ str "."); - - let duplicate_names = - List.duplicates Name.equal (List.filter ((!=) Anonymous) names) - in - if not (List.is_empty duplicate_names) then begin - let duplicates = prlist_with_sep pr_comma pr_name duplicate_names in - user_err (strbrk "Some argument names are duplicated: " ++ duplicates) - end; - - (* Parts of this code are overly complicated because the implicit arguments - API is completely crazy: positions (ExplByPos) are elaborated to - names. This is broken by design, since not all arguments have names. So - even though we eventually want to map only positions to implicit statuses, - we have to check whether the corresponding arguments have names, not to - trigger an error in the impargs code. Even better, the names we have to - check are not the current ones (after previous renamings), but the original - ones (inferred from the type). *) - - let implicits = - List.map (fun { name; implicit_status = i } -> (name,i)) args - in - let implicits = implicits :: more_implicits in - - let open Vernacexpr in - let rec build_implicits inf_names implicits = - match inf_names, implicits with - | _, [] -> [] - | _ :: inf_names, (_, NotImplicit) :: implicits -> - build_implicits inf_names implicits - - (* With the current impargs API, it is impossible to make an originally - anonymous argument implicit *) - | Anonymous :: _, (name, _) :: _ -> - user_err ~hdr:"vernac_declare_arguments" - (strbrk"Argument "++ pr_name name ++ - strbrk " cannot be declared implicit.") - - | Name id :: inf_names, (name, impl) :: implicits -> - let max = impl = MaximallyImplicit in - (ExplByName id,max,false) :: build_implicits inf_names implicits - - | _ -> assert false (* already checked in [names_union] *) - in - - let implicits = List.map (build_implicits inf_names) implicits in - let implicits_specified = match implicits with [[]] -> false | _ -> true in - - if implicits_specified && clear_implicits_flag then - error "The \"clear implicits\" flag is incompatible with implicit annotations"; - - if implicits_specified && default_implicits_flag then - error "The \"default implicits\" flag is incompatible with implicit annotations"; - - let rargs = - Util.List.map_filter (function (n, true) -> Some n | _ -> None) - (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 args) - in - - let rec narrow = function - | #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl - | [] -> [] | _ :: tl -> narrow tl - in - let red_flags = narrow flags in - let red_modifiers_specified = - not (List.is_empty rargs) || Option.has_some nargs_for_red - || not (List.is_empty red_flags) - in - - if not (List.is_empty rargs) && never_unfold_flag then - err_incompat "simpl never" "!"; - - - (* Actions *) - - if renaming_specified then begin - let local = make_section_locality locality in - Arguments_renaming.rename_arguments local sr names - end; - - if scopes_specified || clear_scopes_flag then begin - let scopes = List.map (Option.map (fun (o,k) -> - try ignore (Notation.find_scope k); k - with UserError _ -> - Notation.find_delimiters_scope o k)) scopes - in - vernac_arguments_scope locality reference scopes - end; - - if implicits_specified || clear_implicits_flag then - vernac_declare_implicits locality reference implicits; - - if default_implicits_flag then - vernac_declare_implicits locality reference []; - - if red_modifiers_specified then begin - match sr with - | ConstRef _ as c -> - Reductionops.ReductionBehaviour.set - (make_section_locality locality) c - (rargs, Option.default ~-1 nargs_for_red, red_flags) - | _ -> user_err - (strbrk "Modifiers of the behavior of the simpl tactic "++ - strbrk "are relevant for constants only.") - end; - - if not (renaming_specified || - implicits_specified || - scopes_specified || - red_modifiers_specified) && (List.is_empty flags) then - warn_arguments_assert sr - -let default_env () = { - Notation_term.ninterp_var_type = Id.Map.empty; - ninterp_rec_vars = Id.Map.empty; -} - -let vernac_reserve bl = - let sb_decl = (fun (idl,c) -> - 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_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 - -let vernac_generalizable locality = - let local = make_non_locality locality in - Implicit_quantifiers.declare_generalizable local - -let _ = - declare_bool_option - { optsync = false; - optdepr = false; - optname = "silent"; - optkey = ["Silent"]; - optread = is_silent; - optwrite = make_silent } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "implicit arguments"; - optkey = ["Implicit";"Arguments"]; - optread = Impargs.is_implicit_args; - optwrite = Impargs.make_implicit_args } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "strict implicit arguments"; - optkey = ["Strict";"Implicit"]; - optread = Impargs.is_strict_implicit_args; - optwrite = Impargs.make_strict_implicit_args } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "strong strict implicit arguments"; - optkey = ["Strongly";"Strict";"Implicit"]; - optread = Impargs.is_strongly_strict_implicit_args; - optwrite = Impargs.make_strongly_strict_implicit_args } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "contextual implicit arguments"; - optkey = ["Contextual";"Implicit"]; - optread = Impargs.is_contextual_implicit_args; - optwrite = Impargs.make_contextual_implicit_args } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "implicit status of reversible patterns"; - optkey = ["Reversible";"Pattern";"Implicit"]; - optread = Impargs.is_reversible_pattern_implicit_args; - optwrite = Impargs.make_reversible_pattern_implicit_args } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "maximal insertion of implicit"; - optkey = ["Maximal";"Implicit";"Insertion"]; - optread = Impargs.is_maximal_implicit_args; - optwrite = Impargs.make_maximal_implicit_args } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "automatic introduction of variables"; - optkey = ["Automatic";"Introduction"]; - optread = Flags.is_auto_intros; - optwrite = make_auto_intros } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "coercion printing"; - optkey = ["Printing";"Coercions"]; - optread = (fun () -> !Constrextern.print_coercions); - optwrite = (fun b -> Constrextern.print_coercions := b) } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "printing of existential variable instances"; - optkey = ["Printing";"Existential";"Instances"]; - optread = (fun () -> !Detyping.print_evar_arguments); - optwrite = (:=) Detyping.print_evar_arguments } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "implicit arguments printing"; - optkey = ["Printing";"Implicit"]; - optread = (fun () -> !Constrextern.print_implicits); - optwrite = (fun b -> Constrextern.print_implicits := b) } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "implicit arguments defensive printing"; - optkey = ["Printing";"Implicit";"Defensive"]; - optread = (fun () -> !Constrextern.print_implicits_defensive); - optwrite = (fun b -> Constrextern.print_implicits_defensive := b) } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "projection printing using dot notation"; - optkey = ["Printing";"Projections"]; - optread = (fun () -> !Constrextern.print_projections); - optwrite = (fun b -> Constrextern.print_projections := b) } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "notations printing"; - optkey = ["Printing";"Notations"]; - optread = (fun () -> not !Constrextern.print_no_symbol); - optwrite = (fun b -> Constrextern.print_no_symbol := not b) } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "raw printing"; - optkey = ["Printing";"All"]; - optread = (fun () -> !Flags.raw_print); - optwrite = (fun b -> Flags.raw_print := b) } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "record printing"; - optkey = ["Printing";"Records"]; - optread = (fun () -> !Flags.record_print); - optwrite = (fun b -> Flags.record_print := b) } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "use of the program extension"; - optkey = ["Program";"Mode"]; - optread = (fun () -> !Flags.program_mode); - optwrite = (fun b -> Flags.program_mode:=b) } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "universe polymorphism"; - optkey = ["Universe"; "Polymorphism"]; - optread = Flags.is_universe_polymorphism; - optwrite = Flags.make_universe_polymorphism } - -let _ = - declare_int_option - { optsync = true; - optdepr = false; - optname = "the level of inlining during functor application"; - optkey = ["Inline";"Level"]; - optread = (fun () -> Some (Flags.get_inline_level ())); - optwrite = (fun o -> - let lev = Option.default Flags.default_inline_level o in - Flags.set_inline_level lev) } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "kernel term sharing"; - optkey = ["Kernel"; "Term"; "Sharing"]; - optread = (fun () -> !CClosure.share); - optwrite = (fun b -> CClosure.share := b) } - -(* No more undo limit in the new proof engine. - The command still exists for compatibility (e.g. with ProofGeneral) *) - -let _ = - declare_int_option - { optsync = false; - optdepr = true; - optname = "the undo limit (OBSOLETE)"; - optkey = ["Undo"]; - optread = (fun _ -> None); - optwrite = (fun _ -> ()) } - -let _ = - declare_int_option - { optsync = false; - optdepr = false; - optname = "the hypotheses limit"; - optkey = ["Hyps";"Limit"]; - optread = Flags.print_hyps_limit; - optwrite = Flags.set_print_hyps_limit } - -let _ = - declare_int_option - { optsync = true; - optdepr = false; - optname = "the printing depth"; - optkey = ["Printing";"Depth"]; - optread = Pp_control.get_depth_boxes; - optwrite = Pp_control.set_depth_boxes } - -let _ = - declare_int_option - { optsync = true; - optdepr = false; - optname = "the printing width"; - optkey = ["Printing";"Width"]; - optread = Pp_control.get_margin; - optwrite = Pp_control.set_margin } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "printing of universes"; - optkey = ["Printing";"Universes"]; - optread = (fun () -> !Constrextern.print_universes); - optwrite = (fun b -> Constrextern.print_universes:=b) } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "dumping bytecode after compilation"; - optkey = ["Dump";"Bytecode"]; - optread = Flags.get_dump_bytecode; - optwrite = Flags.set_dump_bytecode } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "explicitly parsing implicit arguments"; - optkey = ["Parsing";"Explicit"]; - optread = (fun () -> !Constrintern.parsing_explicit); - optwrite = (fun b -> Constrintern.parsing_explicit := b) } - -let _ = - declare_string_option ~preprocess:CWarnings.normalize_flags_string - { optsync = true; - optdepr = false; - optname = "warnings display"; - optkey = ["Warnings"]; - optread = CWarnings.get_flags; - optwrite = CWarnings.set_flags } - -let vernac_set_strategy locality l = - let local = make_locality locality in - let glob_ref r = - match smart_global r with - | ConstRef sp -> EvalConstRef sp - | VarRef id -> EvalVarRef id - | _ -> error - "cannot set an inductive type or a constructor as transparent" in - let l = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) l in - Redexpr.set_strategy local l - -let vernac_set_opacity locality (v,l) = - let local = make_non_locality locality in - let glob_ref r = - match smart_global r with - | ConstRef sp -> EvalConstRef sp - | VarRef id -> EvalVarRef id - | _ -> error - "cannot set an inductive type or a constructor as transparent" in - let l = List.map glob_ref l in - Redexpr.set_strategy local [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 - -let vernac_set_append_option locality key s = - set_string_option_append_value_gen locality key s - -let vernac_unset_option locality key = - unset_option_value_gen locality key - -let vernac_add_option key lv = - let f = function - | StringRefValue s -> (get_string_table key)#add s - | QualidRefValue locqid -> (get_ref_table key)#add locqid - in - try List.iter f lv with Not_found -> error_undeclared_key key - -let vernac_remove_option key lv = - let f = function - | StringRefValue s -> (get_string_table key)#remove s - | QualidRefValue locqid -> (get_ref_table key)#remove locqid - in - try List.iter f lv with Not_found -> error_undeclared_key key - -let vernac_mem_option key lv = - let f = function - | StringRefValue s -> (get_string_table key)#mem s - | QualidRefValue locqid -> (get_ref_table key)#mem locqid - in - try List.iter f lv with Not_found -> error_undeclared_key key - -let vernac_print_option key = - try (get_ref_table key)#print - with Not_found -> - try (get_string_table key)#print - with Not_found -> - try print_option_value key - with Not_found -> error_undeclared_key key - -let get_current_context_of_args = function - | Some n -> get_goal_context n - | None -> get_current_context () - -let vernac_check_may_eval redexp glopt rc = - let (sigma, env) = get_current_context_of_args glopt in - let sigma', c = interp_open_constr env sigma rc in - let sigma' = Evarconv.solve_unif_constraints_with_heuristics env sigma' in - Evarconv.check_problems_are_solved env sigma'; - let sigma',nf = Evarutil.nf_evars_and_universes 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 = - if Evarutil.has_undefined_evars sigma' c then - Evarutil.j_nf_evar sigma' (Retyping.get_judgment_of env sigma' c) - else - (* OK to call kernel which does not support evars *) - Arguments_renaming.rename_typing env c in - match redexp with - | None -> - let l = Evar.Set.union (Evd.evars_of_term j.Environ.uj_val) (Evd.evars_of_term j.Environ.uj_type) in - let j = { j with Environ.uj_type = Reductionops.nf_betaiota sigma' j.Environ.uj_type } in - Feedback.msg_notice (print_judgment env sigma' j ++ - pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++ - Printer.pr_universe_ctx sigma uctx) - | Some 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 - let evm = Sigma.Unsafe.of_evar_map evm in - let Sigma (c, _, _) = redfun.Reductionops.e_redfun env evm c in - c - in - Feedback.msg_notice (print_eval redfun env sigma' rc j) - -let vernac_declare_reduction locality s r = - let local = make_locality locality in - 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 = - let env = Global.env() in - 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 (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 - Feedback.msg_notice (print_safe_judgment env sigma j) - - -let get_nth_goal n = - let pf = get_pftreestate() in - let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in - let gl = {Evd.it=List.nth gls (n-1) ; sigma = sigma; } in - gl - -exception NoHyp -(* Printing "About" information of a hypothesis of the current goal. - 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 - | None,AN (Ident (_loc,id)) -> (* goal number not given, catch any failure *) - (try get_nth_goal 1,id with _ -> raise NoHyp) - | Some n,AN (Ident (_loc,id)) -> (* goal number given, catch if wong *) - (try get_nth_goal n,id - with - Failure _ -> user_err ~hdr:"print_about_hyp_globs" - (str "No such goal: " ++ int n ++ str ".")) - | _ , _ -> raise NoHyp in - let hyps = pf_hyps gl in - 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 (NamedDecl.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 - - -let vernac_print = let open Feedback in function - | PrintTables -> msg_notice (print_tables ()) - | PrintFullContext-> msg_notice (print_full_context_typ ()) - | PrintSectionContext qid -> msg_notice (print_sec_context_typ qid) - | PrintInspect n -> msg_notice (inspect n) - | PrintGrammar ent -> msg_notice (Metasyntax.pr_grammar ent) - | PrintLoadPath dir -> (* For compatibility ? *) msg_notice (print_loadpath dir) - | PrintModules -> msg_notice (print_modules ()) - | PrintModule qid -> print_module qid - | PrintModuleType qid -> print_modtype qid - | PrintNamespace ns -> print_namespace ns - | PrintMLLoadPath -> msg_notice (Mltop.print_ml_path ()) - | PrintMLModules -> msg_notice (Mltop.print_ml_modules ()) - | PrintDebugGC -> msg_notice (Mltop.print_gc ()) - | PrintName qid -> dump_global qid; msg_notice (print_name qid) - | PrintGraph -> msg_notice (Prettyp.print_graph()) - | PrintClasses -> msg_notice (Prettyp.print_classes()) - | PrintTypeClasses -> msg_notice (Prettyp.print_typeclasses()) - | PrintInstances c -> msg_notice (Prettyp.print_instances (smart_global c)) - | PrintCoercions -> msg_notice (Prettyp.print_coercions()) - | 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, dst) -> - let univ = Global.universes () 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 - begin match dst with - | None -> msg_notice (UGraph.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) - | PrintHintDb -> msg_notice (Hints.pr_searchtable ()) - | PrintScopes -> - msg_notice (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr)) - | PrintScope s -> - msg_notice (Notation.pr_scope (Constrextern.without_symbols pr_lglob_constr) s) - | PrintVisibility s -> - msg_notice (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s) - | PrintAbout (ref_or_by_not,glnumopt) -> - msg_notice (print_about_hyp_globs ref_or_by_not glnumopt) - | PrintImplicit qid -> - dump_global qid; msg_notice (print_impargs qid) - | PrintAssumptions (o,t,r) -> - (* Prints all the axioms and section variables used by a term *) - let gr = smart_global r in - let cstr = printable_constr_of_global gr in - let st = Conv_oracle.get_transp_state (Environ.oracle (Global.env())) in - let nassums = - Assumptions.assumptions st ~add_opaque:o ~add_transparent:t gr cstr in - msg_notice (Printer.pr_assumptionset (Global.env ()) nassums) - | PrintStrategy r -> print_strategy r - -let global_module r = - let (loc,qid) = qualid_of_reference r in - try Nametab.full_name_module qid - with Not_found -> - user_err ~loc ~hdr:"global_module" - (str "Module/section " ++ pr_qualid qid ++ str " not found.") - -let interp_search_restriction = function - | SearchOutside l -> (List.map global_module l, true) - | SearchInside l -> (List.map global_module l, false) - -open Search - -let interp_search_about_item env = - function - | SearchSubPattern pat -> - let _,pat = intern_constr_pattern env pat in - GlobSearchSubPattern pat - | SearchString (s,None) when Id.is_valid s -> - GlobSearchString s - | SearchString (s,sc) -> - try - let ref = - Notation.interp_notation_as_global_reference Loc.ghost - (fun _ -> true) s sc in - GlobSearchSubPattern (Pattern.PRef ref) - with UserError _ -> - user_err ~hdr:"interp_search_about_item" - (str "Unable to interp \"" ++ str s ++ str "\" either as a reference or as an identifier component") - -(* 05f22a5d6d5b8e3e80f1a37321708ce401834430 introduced the - `search_output_name_only` option to avoid excessive printing when - searching. - - The motivation was to make search usable for IDE completion, - however, it is still too slow due to the non-indexed nature of the - underlying search mechanism. - - In the future we should deprecate the option and provide a fast, - indexed name-searching interface. -*) -let search_output_name_only = ref false - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "output-name-only search"; - optkey = ["Search";"Output";"Name";"Only"]; - optread = (fun () -> !search_output_name_only); - optwrite = (:=) search_output_name_only } - -let vernac_search s gopt r = - let r = interp_search_restriction r in - let env,gopt = - match gopt with | None -> - (* 1st goal by default if it exists, otherwise no goal at all *) - (try snd (Pfedit.get_goal_context 1) , Some 1 - with _ -> Global.env (),None) - (* if goal selector is given and wrong, then let exceptions be raised. *) - | Some g -> snd (Pfedit.get_goal_context g) , Some g - in - let get_pattern c = snd (intern_constr_pattern env c) in - let pr_search ref env c = - let pr = pr_global ref in - let pp = if !search_output_name_only - then pr - else begin - let pc = pr_lconstr_env env Evd.empty c in - hov 2 (pr ++ str":" ++ spc () ++ pc) - end - in Feedback.msg_notice pp - in - match s with - | SearchPattern c -> - (Search.search_pattern gopt (get_pattern c) r |> Search.prioritize_search) pr_search - | SearchRewrite c -> - (Search.search_rewrite gopt (get_pattern c) r |> Search.prioritize_search) pr_search - | SearchHead c -> - (Search.search_by_head gopt (get_pattern c) r |> Search.prioritize_search) pr_search - | SearchAbout sl -> - (Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r |> Search.prioritize_search) pr_search - -let vernac_locate = let open Feedback in function - | LocateAny (AN qid) -> msg_notice (print_located_qualid qid) - | LocateTerm (AN qid) -> msg_notice (print_located_term qid) - | LocateAny (ByNotation (_, ntn, sc)) (** TODO : handle Ltac notations *) - | LocateTerm (ByNotation (_, ntn, sc)) -> - msg_notice - (Notation.locate_notation - (Constrextern.without_symbols pr_lglob_constr) ntn sc) - | LocateLibrary qid -> print_located_library qid - | LocateModule qid -> msg_notice (print_located_module qid) - | LocateTactic qid -> msg_notice (print_located_tactic qid) - | LocateFile f -> msg_notice (locate_file f) - -let vernac_register id r = - if Pfedit.refining () then - error "Cannot register a primitive while in proof editing mode."; - let t = (Constrintern.global_reference (snd id)) in - if not (isConst t) then - error "Register inline: a constant is expected"; - let kn = destConst t in - match r with - | RegisterInline -> Global.register_inline (Univ.out_punivs kn) - -(********************) -(* Proof management *) - -let vernac_focus gln = - Proof_global.simple_with_current_proof (fun _ p -> - match gln with - | None -> Proof.focus focus_command_cond () 1 p - | Some 0 -> - CErrors.error "Invalid goal number: 0. Goal numbering starts with 1." - | Some n -> - Proof.focus focus_command_cond () n p) - - (* Unfocuses one step in the focus stack. *) -let vernac_unfocus () = - Proof_global.simple_with_current_proof - (fun _ p -> Proof.unfocus command_focus p ()) - -(* Checks that a proof is fully unfocused. Raises an error if not. *) -let vernac_unfocused () = - let p = Proof_global.give_me_the_proof () in - if Proof.unfocused p then - Feedback.msg_notice (str"The proof is indeed fully unfocused.") - else - error "The proof is not fully unfocused." - - -(* BeginSubproof / EndSubproof. - BeginSubproof (vernac_subproof) focuses on the first goal, or the goal - given as argument. - EndSubproof (vernac_end_subproof) unfocuses from a BeginSubproof, provided - that the proof of the goal has been completed. -*) -let subproof_kind = Proof.new_focus_kind () -let subproof_cond = Proof.done_cond subproof_kind - -let vernac_subproof gln = - Proof_global.simple_with_current_proof (fun _ p -> - match gln with - | None -> Proof.focus subproof_cond () 1 p - | Some n -> Proof.focus subproof_cond () n p) - -let vernac_end_subproof () = - Proof_global.simple_with_current_proof (fun _ p -> - Proof.unfocus subproof_kind p ()) - -let vernac_bullet (bullet:Proof_global.Bullet.t) = - Proof_global.simple_with_current_proof (fun _ p -> - Proof_global.Bullet.put p bullet) - -let vernac_show = let open Feedback in function - | ShowGoal goalref -> - let info = match goalref with - | 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 -> - Constrextern.with_implicits msg_notice (pr_open_subgoals ()) - | ShowGoalImplicitly (Some n) -> - Constrextern.with_implicits msg_notice (pr_nth_open_subgoal n) - | ShowProof -> show_proof () - | ShowNode -> show_node () - | ShowScript -> Stm.show_script () - | ShowExistentials -> show_top_evars () - | ShowUniverses -> show_universes () - | ShowTree -> show_prooftree () - | ShowProofNames -> - msg_notice (pr_sequence pr_id (Pfedit.get_all_proof_names())) - | ShowIntros all -> show_intro all - | ShowMatch id -> show_match id - | ShowThesis -> show_thesis () - - -let vernac_check_guard () = - let pts = get_pftreestate () in - let pfterm = List.hd (Proof.partial_proof pts) in - let message = - try - let { Evd.it=gl ; sigma=sigma } = Proof.V82.top_goal pts in - Inductiveops.control_only_guard (Goal.V82.env sigma gl) - pfterm; - (str "The condition holds up to here") - with UserError(_,s) -> - (str ("Condition violated: ") ++s) - in - Feedback.msg_notice message - -exception End_of_input - -let vernac_load interp fname = - let interp x = - let proof_mode = Proof_global.get_default_proof_mode_name () in - Proof_global.activate_proof_mode proof_mode; - interp x in - let parse_sentence = Flags.with_option Flags.we_are_parsing - (fun po -> - match Pcoq.Gram.entry_parse Pcoq.main_entry po with - | Some x -> x - | None -> raise End_of_input) in - let fname = - Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in - let fname = CUnix.make_suffix fname ".v" in - let input = - let longfname = Loadpath.locate_file fname in - let in_chan = open_utf8_file_in longfname in - Pcoq.Gram.parsable ~file:longfname (Stream.of_channel in_chan) in - try while true do interp (snd (parse_sentence input)) done - with End_of_input -> () - -(* "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. - * loc is the Loc.t of the vernacular command being interpreted. *) -let interp ?proof ~loc locality poly c = - prerr_endline (fun () -> "interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c)); - match c with - (* Done later in this file *) - | VernacLoad _ -> assert false - | VernacFail _ -> assert false - | VernacTime _ -> assert false - | VernacRedirect _ -> assert false - | VernacTimeout _ -> assert false - | VernacStm _ -> assert false - - | VernacError e -> raise e - - (* Syntax *) - | VernacSyntaxExtension (local,sl) -> - vernac_syntax_extension locality local sl - | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr - | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl - | VernacOpenCloseScope (local, s) -> vernac_open_close_scope locality local s - | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope locality qid scl - | VernacInfix (local,mv,qid,sc) -> vernac_infix locality local mv qid sc - | VernacNotation (local,c,infpl,sc) -> - vernac_notation locality local c infpl sc - | VernacNotationAddFormat(n,k,v) -> - Metasyntax.add_notation_extra_printing_rule n k v - - (* Gallina *) - | VernacDefinition (k,lid,d) -> vernac_definition locality poly k lid d - | 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 - | VernacInductive (priv,finite,l) -> vernac_inductive poly priv finite l - | VernacFixpoint (local, l) -> vernac_fixpoint locality poly local l - | 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 loc poly l - | VernacConstraint l -> vernac_constraint loc poly l - - (* Modules *) - | VernacDeclareModule (export,lid,bl,mtyo) -> - vernac_declare_module export lid bl mtyo - | VernacDefineModule (export,lid,bl,mtys,mexprl) -> - vernac_define_module export lid bl mtys mexprl - | VernacDeclareModuleType (lid,bl,mtys,mtyo) -> - vernac_declare_module_type lid bl mtys mtyo - | VernacInclude in_asts -> - vernac_include in_asts - (* Gallina extensions *) - | VernacBeginSection lid -> vernac_begin_section lid - - | VernacEndSegment lid -> vernac_end_segment lid - - | VernacNameSectionHypSet (lid, set) -> vernac_name_sec_hyp lid set - - | VernacRequire (from, export, qidl) -> vernac_require from export qidl - | VernacImport (export,qidl) -> vernac_import export qidl - | VernacCanonical qid -> vernac_canonical qid - | VernacCoercion (local,r,s,t) -> vernac_coercion locality poly local r s t - | VernacIdentityCoercion (local,(_,id),s,t) -> - vernac_identity_coercion locality poly local id s t - - (* Type classes *) - | VernacInstance (abst, sup, inst, props, info) -> - vernac_instance abst locality poly sup inst props info - | VernacContext sup -> vernac_context poly sup - | VernacDeclareInstances insts -> vernac_declare_instances locality insts - | VernacDeclareClass id -> vernac_declare_class id - - (* Solving *) - | VernacSolveExistential (n,c) -> vernac_solve_existential n c - - (* Auxiliary file and library management *) - | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias - | VernacRemoveLoadPath s -> vernac_remove_loadpath s - | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s - | VernacDeclareMLModule l -> vernac_declare_ml_module locality l - | VernacChdir s -> vernac_chdir s - - (* State management *) - | VernacWriteState s -> vernac_write_state s - | VernacRestoreState s -> vernac_restore_state s - - (* Resetting *) - | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm") - | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm") - | VernacBack _ -> anomaly (str "VernacBack not handled by Stm") - | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm") - - (* Commands *) - | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b - | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids - | VernacHints (local,dbnames,hints) -> - vernac_hints locality poly local dbnames hints - | VernacSyntacticDefinition (id,c,local,b) -> - vernac_syntactic_definition locality id c local b - | VernacDeclareImplicits (qid,l) -> - vernac_declare_implicits locality qid l - | VernacArguments (qid, args, more_implicits, nargs, flags) -> - vernac_arguments locality qid args more_implicits nargs flags - | VernacReserve bl -> vernac_reserve bl - | VernacGeneralizable gen -> vernac_generalizable locality gen - | VernacSetOpacity qidl -> vernac_set_opacity locality qidl - | VernacSetStrategy l -> vernac_set_strategy locality l - | VernacSetOption (key,v) -> vernac_set_option locality key v - | VernacSetAppendOption (key,v) -> vernac_set_append_option locality key v - | VernacUnsetOption key -> vernac_unset_option locality key - | VernacRemoveOption (key,v) -> vernac_remove_option key v - | VernacAddOption (key,v) -> vernac_add_option key v - | VernacMemOption (key,v) -> vernac_mem_option key v - | VernacPrintOption key -> vernac_print_option key - | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval r g c - | VernacDeclareReduction (s,r) -> vernac_declare_reduction locality s r - | VernacGlobalCheck c -> vernac_global_check c - | VernacPrint p -> vernac_print p - | VernacSearch (s,g,r) -> vernac_search s g r - | VernacLocate l -> vernac_locate l - | VernacRegister (id, r) -> vernac_register id r - | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n") - - (* The STM should handle that, but LOAD bypasses the STM... *) - | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") - | VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command") - | VernacRestart -> CErrors.user_err (str "Restart cannot be used through the Load command") - | VernacUndo _ -> CErrors.user_err (str "Undo cannot be used through the Load command") - | VernacUndoTo _ -> CErrors.user_err (str "UndoTo cannot be used through the Load command") - | VernacBacktrack _ -> CErrors.user_err (str "Backtrack cannot be used through the Load command") - - (* Proof management *) - | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t,None)] false - | VernacFocus n -> vernac_focus n - | VernacUnfocus -> vernac_unfocus () - | VernacUnfocused -> vernac_unfocused () - | VernacBullet b -> vernac_bullet b - | VernacSubproof n -> vernac_subproof n - | VernacEndSubproof -> vernac_end_subproof () - | VernacShow s -> vernac_show s - | VernacCheckGuard -> vernac_check_guard () - | 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 *) - | VernacToplevelControl e -> raise e - - (* Extensions *) - | VernacExtend (opn,args) -> Vernacinterp.call ?locality (opn,args) - - (* Handled elsewhere *) - | VernacProgram _ - | VernacPolymorphic _ - | VernacLocal _ -> assert false - -(* Vernaculars that take a locality flag *) -let check_vernac_supports_locality c l = - match l, c with - | None, _ -> () - | Some _, ( - VernacOpenCloseScope _ - | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _ - | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ - | VernacAssumption _ | VernacStartTheoremProof _ - | VernacCoercion _ | VernacIdentityCoercion _ - | VernacInstance _ | VernacDeclareInstances _ - | VernacDeclareMLModule _ - | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _ - | VernacSyntacticDefinition _ - | VernacArgumentsScope _ | VernacDeclareImplicits _ | VernacArguments _ - | VernacGeneralizable _ - | VernacSetOpacity _ | VernacSetStrategy _ - | VernacSetOption _ | VernacSetAppendOption _ | VernacUnsetOption _ - | VernacDeclareReduction _ - | VernacExtend _ - | VernacInductive _) -> () - | Some _, _ -> CErrors.error "This command does not support Locality" - -(* Vernaculars that take a polymorphism flag *) -let check_vernac_supports_polymorphism c p = - match p, c with - | None, _ -> () - | Some _, ( - VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ - | VernacAssumption _ | VernacInductive _ - | VernacStartTheoremProof _ - | VernacCoercion _ | VernacIdentityCoercion _ - | VernacInstance _ | VernacDeclareInstances _ - | VernacHints _ | VernacContext _ - | VernacExtend _ | VernacUniverse _ | VernacConstraint _) -> () - | Some _, _ -> CErrors.error "This command does not support Polymorphism" - -let enforce_polymorphism = function - | None -> Flags.is_universe_polymorphism () - | Some b -> Flags.make_polymorphic_flag b; b - -(** A global default timeout, controlled by option "Set Default Timeout n". - Use "Unset Default Timeout" to deactivate it (or set it to 0). *) - -let default_timeout = ref None - -let _ = - Goptions.declare_int_option - { Goptions.optsync = true; - Goptions.optdepr = false; - Goptions.optname = "the default timeout"; - Goptions.optkey = ["Default";"Timeout"]; - Goptions.optread = (fun () -> !default_timeout); - Goptions.optwrite = ((:=) default_timeout) } - -(** When interpreting a command, the current timeout is initially - the default one, but may be modified locally by a Timeout command. *) - -let current_timeout = ref None - -let vernac_timeout f = - match !current_timeout, !default_timeout with - | Some n, _ | None, Some n -> - let f () = f (); current_timeout := None in - Control.timeout n f Timeout - | None, None -> f () - -let restore_timeout () = current_timeout := None - -let locate_if_not_already loc (e, info) = - match Loc.get_loc info with - | None -> (e, Loc.add_loc info loc) - | Some l -> if Loc.is_ghost l then (e, Loc.add_loc info loc) else (e, info) - -exception HasNotFailed -exception HasFailed of std_ppcmds - -let with_fail b f = - if not b then f () - else begin try - (* If the command actually works, ignore its effects on the state. - * Note that error has to be printed in the right state, hence - * within the purified function *) - Future.purify - (fun v -> - try f v; raise HasNotFailed - with - | HasNotFailed as e -> raise e - | e -> - let e = CErrors.push e in - raise (HasFailed (CErrors.iprint - (ExplainErr.process_vernac_interp_error ~allow_uncaught:false ~with_header:false e)))) - () - with e when CErrors.noncritical e -> - let (e, _) = CErrors.push e in - match e with - | HasNotFailed -> - user_err ~hdr:"Fail" (str "The command has not failed!") - | HasFailed msg -> - if is_verbose () || !test_mode || !ide_slave then Feedback.msg_info - (str "The command has indeed failed with message:" ++ fnl () ++ msg) - | _ -> assert false - end - -let interp ?(verbosely=true) ?proof (loc,c) = - let orig_program_mode = Flags.is_program_mode () in - let rec aux ?locality ?polymorphism isprogcmd = function - | VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c - | VernacProgram _ -> CErrors.error "Program mode specified twice" - | VernacLocal (b, c) when Option.is_empty locality -> - aux ~locality:b ?polymorphism isprogcmd c - | VernacPolymorphic (b, c) when polymorphism = None -> - aux ?locality ~polymorphism:b isprogcmd c - | VernacPolymorphic (b, c) -> CErrors.error "Polymorphism specified twice" - | VernacLocal _ -> CErrors.error "Locality specified twice" - | VernacStm (Command c) -> aux ?locality ?polymorphism isprogcmd c - | VernacStm (PGLast c) -> aux ?locality ?polymorphism isprogcmd c - | VernacStm _ -> assert false (* Done by Stm *) - | VernacFail v -> - with_fail true (fun () -> aux ?locality ?polymorphism isprogcmd v) - | VernacTimeout (n,v) -> - current_timeout := Some n; - aux ?locality ?polymorphism isprogcmd v - | VernacRedirect (s, (_,v)) -> - Feedback.with_output_to_file s (aux false) v - | VernacTime (_,v) -> - System.with_time !Flags.time - (aux ?locality ?polymorphism isprogcmd) v; - | VernacLoad (_,fname) -> vernac_load (aux false) fname - | c -> - check_vernac_supports_locality c locality; - check_vernac_supports_polymorphism c polymorphism; - let poly = enforce_polymorphism polymorphism in - Obligations.set_program_mode isprogcmd; - try - vernac_timeout begin fun () -> - 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; - ignore (Flags.use_polymorphic_flag ()) - end - with - | reraise when - (match reraise with - | Timeout -> true - | e -> CErrors.noncritical e) - -> - let e = CErrors.push reraise in - 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 - in - if verbosely then Flags.verbosely (aux false) c - else aux false c - -let () = Hook.set Stm.interp_hook interp -let () = Hook.set Stm.with_fail_hook with_fail diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli deleted file mode 100644 index 7cdc8dd064..0000000000 --- a/toplevel/vernacentries.mli +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit - -(** Vernacular entries *) - -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 - -(** The main interpretation function of vernacular expressions *) -val interp : - ?verbosely:bool -> - ?proof:Proof_global.closed_proof -> - Loc.t * Vernacexpr.vernac_expr -> unit - -(** Print subgoals when the verbose flag is on. - Meant to be used inside vernac commands from plugins. *) - -val print_subgoals : unit -> unit -val try_print_subgoals : unit -> unit - -(** The printing of goals via [print_subgoals] or during - [interp] can be controlled by the following flag. - Used for instance by coqide, since it has its own - goal-fetching mechanism. *) - -val enable_goal_printing : bool ref - -(** Should Qed try to display the proof script ? - True by default, but false in ProofGeneral and coqIDE *) - -val qed_display_script : bool ref - -(** Prepare a "match" template for a given inductive type. - For each branch of the match, we list the constructor name - followed by enough pattern variables. - [Not_found] is raised if the given string isn't the qualid of - a known inductive type. *) - -val make_cases : string -> string list list - -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 - -val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> - Evd.evar_map * Redexpr.red_expr) Hook.t diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml deleted file mode 100644 index f26ef460dd..0000000000 --- a/toplevel/vernacinterp.ml +++ /dev/null @@ -1,77 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit -> unit - -(* Table of vernac entries *) -let vernac_tab = - (Hashtbl.create 51 : - (Vernacexpr.extend_name, deprecation * vernac_command) Hashtbl.t) - -let vinterp_add depr s f = - try - Hashtbl.add vernac_tab s (depr, f) - with Failure _ -> - user_err ~hdr:"vinterp_add" - (str"Cannot add the vernac command " ++ str (fst s) ++ str" twice.") - -let overwriting_vinterp_add s f = - begin - try - let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s - with Not_found -> () - end; - Hashtbl.add vernac_tab s (false, f) - -let vinterp_map s = - try - Hashtbl.find vernac_tab s - with Failure _ | Not_found -> - user_err ~hdr:"Vernac Interpreter" - (str"Cannot find vernac command " ++ str (fst s) ++ str".") - -let vinterp_init () = Hashtbl.clear vernac_tab - -let warn_deprecated_command = - let open CWarnings in - create ~name:"deprecated-command" ~category:"deprecated" - (fun pr -> str "Deprecated vernacular command: " ++ pr) - -(* Interpretation of a vernac command *) - -let call ?locality (opn,converted_args) = - let loc = ref "Looking up command" in - try - let depr, callback = vinterp_map opn in - let () = if depr then - let rules = Egramml.get_extend_vernac_rule opn in - let pr_gram = function - | Egramml.GramTerminal s -> str s - | Egramml.GramNonTerminal _ -> str "_" - in - let pr = pr_sequence pr_gram rules in - warn_deprecated_command pr; - in - loc:= "Checking arguments"; - let hunk = callback converted_args in - loc:= "Executing command"; - Locality.LocalityFixme.set locality; - hunk(); - Locality.LocalityFixme.assert_consumed() - with - | Drop -> raise Drop - | reraise -> - let reraise = CErrors.push reraise in - if !Flags.debug then - Feedback.msg_debug (str"Vernac Interpreter " ++ str !loc); - iraise reraise diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli deleted file mode 100644 index 5149b5416d..0000000000 --- a/toplevel/vernacinterp.mli +++ /dev/null @@ -1,20 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit -> unit - -val vinterp_add : deprecation -> Vernacexpr.extend_name -> - vernac_command -> unit -val overwriting_vinterp_add : - Vernacexpr.extend_name -> vernac_command -> unit - -val vinterp_init : unit -> unit -val call : ?locality:bool -> Vernacexpr.extend_name * Genarg.raw_generic_argument list -> unit diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml new file mode 100644 index 0000000000..8865cd6469 --- /dev/null +++ b/vernac/assumptions.ml @@ -0,0 +1,320 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* raise Not_found + | (l, SFBmodule mb) :: _ when Label.equal l lab -> mb + | _ :: fields -> search_mod_label lab fields + +let rec search_cst_label lab = function + | [] -> raise Not_found + | (l, SFBconst cb) :: _ when Label.equal l lab -> cb + | _ :: fields -> search_cst_label lab fields + +(* TODO: using [empty_delta_resolver] below is probably slightly incorrect. But: + a) I don't see currently what should be used instead + b) this shouldn't be critical for Print Assumption. At worse some + constants will have a canonical name which is non-canonical, + leading to failures in [Global.lookup_constant], but our own + [lookup_constant] should work. +*) + +let rec fields_of_functor f subs mp0 args = function + |NoFunctor a -> f subs mp0 args a + |MoreFunctor (mbid,_,e) -> + match args with + | [] -> assert false (* we should only encounter applied functors *) + | mpa :: args -> + 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 = + try Global.lookup_module mp + with Not_found -> + (* 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 _ -> 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 + with Not_found -> + let l = fields_of_mp mp in + modcache := MPmap.add mp l !modcache; + l + +and fields_of_mp mp = + let mb = lookup_module_in_impl mp in + let fields,inner_mp,subs = fields_of_mb empty_subst mb [] in + let subs = + if mp_eq inner_mp mp then subs + else add_mp inner_mp mp mb.mod_delta subs + in + Modops.subst_structure subs fields + +and fields_of_mb subs mb args = match mb.mod_expr with + |Algebraic expr -> fields_of_expression subs mb.mod_mp args expr + |Struct sign -> fields_of_signature subs mb.mod_mp args sign + |Abstract|FullStruct -> fields_of_signature subs mb.mod_mp args mb.mod_type + +(** The Abstract case above corresponds to [Declare Module] *) + +and fields_of_signature x = + fields_of_functor + (fun subs mp0 args struc -> + assert (List.is_empty args); + (struc, mp0, subs)) x + +and fields_of_expr subs mp0 args = function + |MEident mp -> + let mb = lookup_module_in_impl (subst_mp subs mp) in + fields_of_mb subs mb args + |MEapply (me1,mp2) -> fields_of_expr subs mp0 (mp2::args) me1 + |MEwith _ -> assert false (* no 'with' in [mod_expr] *) + +and fields_of_expression x = fields_of_functor fields_of_expr x + +let lookup_constant_in_impl cst fallback = + try + let mp,dp,lab = repr_kn (canonical_con cst) in + let fields = memoize_fields_of_mp mp in + (* A module found this way is necessarily closed, in particular + our constant cannot be in an opened section : *) + search_cst_label lab fields + with Not_found -> + (* Either: + - The module part of the constant isn't registered yet : + we're still in it, so the [constant_body] found earlier + (if any) was a true axiom. + - The label has not been found in the structure. This is an error *) + match fallback with + | Some cb -> cb + | None -> anomaly (str "Print Assumption: unknown constant " ++ pr_con cst) + +let lookup_constant cst = + try + let cb = Global.lookup_constant cst in + if Declareops.constant_has_body cb then cb + else lookup_constant_in_impl cst (Some cb) + with Not_found -> lookup_constant_in_impl cst None + +(** Graph traversal of an object, collecting on the way the dependencies of + traversed objects *) + +let label_of = function + | ConstRef kn -> pi3 (repr_con kn) + | IndRef (kn,_) + | ConstructRef ((kn,_),_) -> pi3 (repr_mind kn) + | VarRef id -> Label.of_id id + +let rec traverse current ctx accu t = match kind_of_term t with +| Var id -> + let body () = id |> Global.lookup_named |> NamedDecl.get_value in + traverse_object accu body (VarRef id) +| Const (kn, _) -> + let body () = Global.body_of_constant_body (lookup_constant kn) in + traverse_object accu body (ConstRef kn) +| 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 *) + begin match Constr.(kind oty, kind c) with + | 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 + Context.Rel.add (traverse current) ctx accu t + end +| _ -> Termops.fold_constr_with_full_binders + Context.Rel.add (traverse current) ctx accu t + +and traverse_object ?inhabits (curr, data, ax2ty) body obj = + let data, ax2ty = + let already_in = Refmap_env.mem obj data in + match body () with + | None -> + let data = + 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_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) Context.Rel.empty + (Refset_env.empty,data,ax2ty) body in + Refmap_env.add obj contents data, ax2ty + in + (Refset_env.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_env.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.Rel.empty + (Refset_env.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.Rel.add (Context.Rel.Declaration.LocalAssum (ind_name, ind_type)) accu) + Context.Rel.empty 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.(Rel.fold_outside Context.Rel.add ~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_env.add (IndRef ind) contents data in + Array.fold_left_i (fun k data _ -> + Refmap_env.add (ConstructRef (ind, k+1)) contents data + ) data oib.mind_consnames) data mib.mind_packets + in + data, ax2ty + in + (Refset_env.add obj curr, data, ax2ty) + +(** Collects references in a rel_context. *) +and traverse_context current ctx accu ctxt = + snd (Context.Rel.fold_outside (fun decl (ctx, accu) -> + match decl with + | Context.Rel.Declaration.LocalDef (_,c,t) -> + let accu = traverse current ctx (traverse current ctx accu t) c in + let ctx = Context.Rel.add decl ctx in + ctx, accu + | Context.Rel.Declaration.LocalAssum (_,t) -> + let accu = traverse current ctx accu t in + let ctx = Context.Rel.add decl ctx in + ctx, accu) ctxt ~init:(ctx, accu)) + +let traverse current t = + let () = modcache := MPmap.empty in + traverse current Context.Rel.empty (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 + considering terms out of any valid environment, so use with caution. *) +let type_of_constant cb = match cb.Declarations.const_type with +| Declarations.RegularArity ty -> ty +| Declarations.TemplateArity (ctx, arity) -> + Term.mkArity (ctx, Sorts.sort_of_univ arity.Declarations.template_level) + +let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = + let (idts, knst) = st in + (** Only keep the transitive dependencies *) + let (_, graph, ax2ty) = traverse (label_of gr) t in + let fold obj _ accu = match obj with + | VarRef id -> + let decl = Global.lookup_named id in + if is_local_assum decl then + let t = Context.Named.Declaration.get_type decl in + ContextObjectMap.add (Variable id) t accu + else accu + | ConstRef kn -> + let cb = lookup_constant kn in + let accu = + if cb.const_typing_flags.check_guarded then accu + else + let l = try Refmap_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (Guarded kn, l)) Constr.mkProp accu + in + if not (Declareops.constant_has_body cb) || not cb.const_typing_flags.check_universes then + let t = type_of_constant cb in + let l = try Refmap_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (Constant 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 + ContextObjectMap.add (Opaque kn) t accu + else if add_transparent then + let t = type_of_constant cb in + ContextObjectMap.add (Transparent kn) t accu + else + accu + | IndRef (m,_) | ConstructRef ((m,_),_) -> + let mind = Global.lookup_mind m in + if mind.mind_typing_flags.check_guarded then + accu + else + let l = try Refmap_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (Positive m, l)) Constr.mkProp accu + in + Refmap_env.fold fold graph ContextObjectMap.empty diff --git a/vernac/assumptions.mli b/vernac/assumptions.mli new file mode 100644 index 0000000000..0726757839 --- /dev/null +++ b/vernac/assumptions.mli @@ -0,0 +1,31 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr -> + (Refset_env.t * Refset_env.t 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 + {!traverse} also applies. *) +val assumptions : + ?add_opaque:bool -> ?add_transparent:bool -> transparent_state -> + global_reference -> constr -> Term.types ContextObjectMap.t diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml new file mode 100644 index 0000000000..594f2e9449 --- /dev/null +++ b/vernac/auto_ind_decl.ml @@ -0,0 +1,969 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [] + | t::q -> t::(kick_last q) + | [] -> failwith "kick_last" +and aux = function + | (0,l') -> l' + | (n,h::t) -> aux (n-1,t) + | _ -> failwith "quick_chop" + in + if n > (List.length l) then failwith "quick_chop args" + else kick_last (aux (n,l) ) + +let deconstruct_type t = + let l,r = decompose_prod t in + (List.rev_map snd l)@[r] + +exception EqNotFound of inductive * inductive +exception EqUnknown of string +exception UndefinedCst of string +exception InductiveWithProduct +exception InductiveWithSort +exception ParameterWithoutEquality of global_reference +exception NonSingletonProp of inductive +exception DecidabilityMutualNotSupported +exception NoDecidabilityCoInductive + +let dl = Loc.ghost + +let constr_of_global g = lazy (Universes.constr_of_global g) + +(* Some pre declaration of constant we are going to use *) +let bb = constr_of_global Coqlib.glob_bool + +let andb_prop = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb_prop + +let andb_true_intro = fun _ -> + (Coqlib.build_bool_type()).Coqlib.andb_true_intro + +let tt = constr_of_global Coqlib.glob_true + +let ff = constr_of_global Coqlib.glob_false + +let eq = constr_of_global Coqlib.glob_eq + +let sumbool = Coqlib.build_coq_sumbool + +let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb + +let induct_on c = induction false None c None None + +let destruct_on c = destruct false None c None None + +let destruct_on_using c id = + destruct false None c + (Some (dl,IntroOrPattern [[dl,IntroNaming IntroAnonymous]; + [dl,IntroNaming (IntroIdentifier id)]])) + None + +let destruct_on_as c l = + destruct false None c (Some (dl,l)) None + +(* reconstruct the inductive with the correct deBruijn indexes *) +let mkFullInd (ind,u) n = + let mib = Global.lookup_mind (fst ind) in + let nparams = mib.mind_nparams in + let nparrec = mib.mind_nparams_rec in + (* params context divided *) + let lnonparrec,lnamesparrec = + context_chop (nparams-nparrec) mib.mind_params_ctxt in + if nparrec > 0 + then mkApp (mkIndU (ind,u), + Array.of_list(Context.Rel.to_extended_list (nparrec+n) lnamesparrec)) + else mkIndU (ind,u) + +let check_bool_is_defined () = + try let _ = Global.type_of_global_unsafe Coqlib.glob_bool in () + with e when CErrors.noncritical e -> raise (UndefinedCst "bool") + +let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") + +let build_beq_scheme mode kn = + check_bool_is_defined (); + (* fetching global env *) + let env = Global.env() in + (* fetching the mutual inductive body *) + let mib = Global.lookup_mind kn in + (* number of inductives in the mutual *) + let nb_ind = Array.length mib.mind_packets in + (* number of params in the type *) + let nparams = mib.mind_nparams in + let nparrec = mib.mind_nparams_rec in + (* params context divided *) + let lnonparrec,lnamesparrec = + context_chop (nparams-nparrec) mib.mind_params_ctxt in + (* predef coq's boolean type *) + (* rec name *) + let rec_name i =(Id.to_string (Array.get mib.mind_packets i).mind_typename)^ + "_eqrec" + in + (* construct the "fun A B ... N, eqA eqB eqC ... N => fixpoint" part *) + let create_input c = + let myArrow u v = mkArrow u (lift 1 v) + and eqName = function + | Name s -> Id.of_string ("eq_"^(Id.to_string s)) + | Anonymous -> Id.of_string "eq_A" + 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 + incr lift_cnt; + myArrow a (myArrow a (Lazy.force bb)) + ) ext_rel_list in + + let eq_input = List.fold_left2 + ( 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 (RelDecl.get_name decl)) b a ) + c (List.rev eqs_typ) lnamesparrec + in + 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 RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_type decl) a) eq_input lnamesparrec + in + let make_one_eq cur = + let u = Univ.Instance.empty in + let ind = (kn,cur),u (* FIXME *) in + (* current inductive we are working on *) + let cur_packet = mib.mind_packets.(snd (fst ind)) in + (* Inductive toto : [rettyp] := *) + let rettyp = Inductive.type_of_inductive env ((mib,cur_packet),u) in + (* split rettyp in a list without the non rec params and the last -> + e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *) + let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in + (* give a type A, this function tries to find the equality on A declared + previously *) + (* nlist = the number of args (A , B , ... ) + eqA = the deBruijn index of the first eq param + ndx = how much to translate due to the 2nd Case + *) + let compute_A_equality rel_list nlist eqA ndx t = + let lifti = ndx in + 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), Safe_typing.empty_private_constants + | Var x -> + let eid = id_of_string ("eq_"^(string_of_id x)) in + let () = + try ignore (Environ.lookup_named eid env) + with Not_found -> raise (ParameterWithoutEquality (VarRef x)) + in + mkVar eid, 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), Safe_typing.empty_private_constants + else begin + try + let eq, eff = + 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 + Array.of_list eqa, + 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 + if Int.equal (Array.length args) 0 then eq, eff + else mkApp (eq, args), eff + with Not_found -> raise(EqNotFound (ind', fst ind)) + end + | Sort _ -> raise InductiveWithSort + | Prod _ -> raise InductiveWithProduct + | Lambda _-> raise (EqUnknown "abstraction") + | LetIn _ -> raise (EqUnknown "let-in") + | Const kn -> + (match Environ.constant_opt_value_in env kn with + | None -> raise (ParameterWithoutEquality (ConstRef (fst kn))) + | Some c -> aux (applist (c,a))) + | Proj _ -> raise (EqUnknown "projection") + | Construct _ -> raise (EqUnknown "constructor") + | Case _ -> raise (EqUnknown "match") + | CoFix _ -> raise (EqUnknown "cofix") + | Fix _ -> raise (EqUnknown "fix") + | Meta _ -> raise (EqUnknown "meta-variable") + | Evar _ -> raise (EqUnknown "existential variable") + in + aux t + in + (* construct the predicate for the Case part*) + let do_predicate rel_list n = + List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) + (mkLambda (Anonymous, + mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), + (Lazy.force bb))) + (List.rev rettyp_l) in + (* make_one_eq *) + (* do the [| C1 ... => match Y with ... end + ... + 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, + 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 + 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 + let constrsj = constrs (3+nparrec+nb_cstr_args) in + for j=0 to n-1 do + if Int.equal i j then + ar2.(j) <- let cc = (match nb_cstr_args with + | 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 = RelDecl.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) + (nb_cstr_args+ndx+1) + cc + in + eff := Safe_typing.concat_private eff' !eff; + Array.set eqs ndx + (mkApp (eqA, + [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|] + )) + done; + Array.fold_left + (fun a b -> mkApp (andb(),[|b;a|])) + (eqs.(0)) + (Array.sub eqs 1 (nb_cstr_args - 1)) + ) + in + (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) cc + (constrsj.(j).cs_args) + ) + else ar2.(j) <- (List.fold_left (fun a decl -> + mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) (Lazy.force ff) (constrsj.(j).cs_args) ) + done; + + ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) + (mkCase (ci,do_predicate rel_list nb_cstr_args, + mkVar (Id.of_string "Y") ,ar2)) + (constrsi.(i).cs_args)) + done; + mkNamedLambda (Id.of_string "X") (mkFullInd ind (nb_ind-1+1)) ( + mkNamedLambda (Id.of_string "Y") (mkFullInd ind (nb_ind-1+2)) ( + mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))), + !eff + in (* build_beq_scheme *) + 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 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)); + types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) + (mkArrow (mkFullInd ((kn,i),u) 1) (Lazy.force bb)); + let c, eff' = make_one_eq i in + cores.(i) <- c; + 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 + if not (Sorts.List.mem InSet kelim) then + raise (NonSingletonProp (kn,i)); + if mib.mind_finite = Decl_kinds.CoFinite then + raise NoDecidabilityCoInductive; + let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in + create_input fix), + Evd.make_evar_universe_context (Global.env ()) None), + !eff + +let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme + +let _ = beq_scheme_kind_aux := fun () -> beq_scheme_kind + +(* This function tryies to get the [inductive] between a constr + the constr should be Ind i or App(Ind i,[|args|]) +*) +let destruct_ind c = + try let u,v = destApp c in + let indc = destInd u in + indc,v + with DestKO -> let indc = destInd c in + indc,[||] + +(* + In the following, avoid is the list of names to avoid. + If the args of the Inductive type are A1 ... An + then avoid should be + [| lb_An ... lb _A1 (resp. bl_An ... bl_A1) + eq_An .... eq_A1 An ... A1 |] +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 mode lb_scheme_key aavoid narg p q = + let avoid = Array.of_list aavoid in + let do_arg v offset = + try + let x = narg*offset in + let s = destVar v in + let n = Array.length avoid in + let rec find i = + if Id.equal avoid.(n-i) s then avoid.(n-i-x) + else (if i + (* if this happen then the args have to be already declared as a + Parameter*) + ( + let mp,dir,lbl = repr_con (fst (destConst v)) in + mkConst (make_con mp dir (mk_label ( + if Int.equal offset 1 then ("eq_"^(Label.to_string lbl)) + else ((Label.to_string lbl)^"_lb") + ))) + ) + in + 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 = + try + 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 + be improved. *) + let err_msg = + (str "Leibniz->boolean:" ++ + str "You have to declare the" ++ + str "decidability over " ++ + Printer.pr_constr type_of_pq ++ + str " first.") + in + Tacticals.New.tclZEROMSG err_msg + in + lb_type_of_p >>= fun (lb_type_of_p,eff) -> + let lb_args = Array.append (Array.append + (Array.map (fun x -> x) v) + (Array.map (fun x -> do_arg x 1) v)) + (Array.map (fun x -> do_arg x 2) v) + in let app = if Array.equal eq_constr lb_args [||] + then lb_type_of_p else mkApp (lb_type_of_p,lb_args) + in + Tacticals.New.tclTHENLIST [ + Proofview.tclEFFECTS eff; + Equality.replace p q ; apply app ; Auto.default_auto] + end } + +(* used in the bool -> leib side *) +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 + let x = narg*offset in + let s = destVar v in + let n = Array.length avoid in + let rec find i = + if Id.equal avoid.(n-i) s then avoid.(n-i-x) + else (if i + (* if this happen then the args have to be already declared as a + Parameter*) + ( + let mp,dir,lbl = repr_con (fst (destConst v)) in + mkConst (make_con mp dir (mk_label ( + if Int.equal offset 1 then ("eq_"^(Label.to_string lbl)) + else ((Label.to_string lbl)^"_bl") + ))) + ) + in + + let rec aux l1 l2 = + match (l1,l2) with + | (t1::q1,t2::q2) -> + 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 ( + let u,v = try destruct_ind tt1 + (* trick so that the good sequence is returned*) + with e when CErrors.noncritical e -> indu,[||] + in if eq_ind (fst u) ind + then Tacticals.New.tclTHENLIST [Equality.replace t1 t2; Auto.default_auto ; aux q1 q2 ] + else ( + let bl_t1, eff = + try + let c, eff = find_scheme bl_scheme_key (out_punivs u) (*FIXME*) in + mkConst c, eff + with Not_found -> + (* spiwack: the format of this error message should probably + be improved. *) + let err_msg = string_of_ppcmds + (str "boolean->Leibniz:" ++ + str "You have to declare the" ++ + str "decidability over " ++ + Printer.pr_constr tt1 ++ + str " first.") + in + error err_msg + in let bl_args = + Array.append (Array.append + (Array.map (fun x -> x) v) + (Array.map (fun x -> do_arg x 1) v)) + (Array.map (fun x -> do_arg x 2) v ) + in + let app = if Array.equal eq_constr bl_args [||] + then bl_t1 else mkApp (bl_t1,bl_args) + in + Tacticals.New.tclTHENLIST [ + Proofview.tclEFFECTS eff; + Equality.replace_by t1 t2 + (Tacticals.New.tclTHEN (apply app) (Auto.default_auto)) ; + aux q1 q2 ] + ) + ) + end } + | ([],[]) -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclZEROMSG (str "Both side of the equality must have the same arity.") + in + begin try Proofview.tclUNIT (destApp lft) + with DestKO -> Tacticals.New.tclZEROMSG (str "replace failed.") + end >>= fun (ind1,ca1) -> + begin try Proofview.tclUNIT (destApp rgt) + with DestKO -> Tacticals.New.tclZEROMSG (str "replace failed.") + end >>= fun (ind2,ca2) -> + begin try Proofview.tclUNIT (out_punivs (destInd ind1)) + with DestKO -> + begin try Proofview.tclUNIT (fst (fst (destConstruct ind1))) + with DestKO -> Tacticals.New.tclZEROMSG (str "The expected type is an inductive one.") + end + end >>= fun (sp1,i1) -> + begin try Proofview.tclUNIT (out_punivs (destInd ind2)) + with DestKO -> + begin try Proofview.tclUNIT (fst (fst (destConstruct ind2))) + with DestKO -> Tacticals.New.tclZEROMSG (str "The expected type is an inductive one.") + end + end >>= fun (sp2,i2) -> + if not (eq_mind sp1 sp2) || not (Int.equal i1 i2) + then Tacticals.New.tclZEROMSG (str "Eq should be on the same type") + else aux (Array.to_list ca1) (Array.to_list ca2) + +(* + 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 decl -> let s' = + match RelDecl.get_name decl with + Name s -> Id.to_string s + | Anonymous -> "A" in + (Id.of_string s',Id.of_string ("eq_"^s'), + Id.of_string (s'^"_bl"), + Id.of_string (s'^"_lb")) + ::a + ) [] l +(* + build the right eq_I A B.. N eq_A .. eq_N +*) +let eqI ind l = + let list_id = list_id l in + let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@ + (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) + and e, eff = + try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff + with Not_found -> user_err ~hdr:"AutoIndDecl.eqI" + (str "The boolean equality on " ++ pr_mind (fst ind) ++ str " is needed."); + in (if Array.equal eq_constr eA [||] then e else mkApp(e,eA)), eff + +(**********************************************************************) +(* Boolean->Leibniz *) + +open Namegen + +let compute_bl_goal ind lnamesparrec nparrec = + let eqI, eff = eqI ind lnamesparrec in + let list_id = list_id lnamesparrec in + let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in + let create_input c = + let x = next_ident_away (Id.of_string "x") avoid and + y = next_ident_away (Id.of_string "y") avoid in + let bl_typ = List.map (fun (s,seq,_,_) -> + mkNamedProd x (mkVar s) ( + mkNamedProd y (mkVar s) ( + mkArrow + ( mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(mkVar seq,[|mkVar x;mkVar y|]);(Lazy.force tt)|])) + ( mkApp(Lazy.force eq,[|mkVar s;mkVar x;mkVar y|])) + )) + ) list_id in + let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> + mkNamedProd sbl b a + ) c (List.rev list_id) (List.rev bl_typ) in + let eqs_typ = List.map (fun (s,_,_,_) -> + mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,(Lazy.force bb))) + ) list_id in + 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 decl -> mkNamedProd + (match RelDecl.get_name decl with Name s -> s | Anonymous -> next_ident_away (Id.of_string "A") avoid) + (RelDecl.get_type decl) a) eq_input lnamesparrec + in + let n = next_ident_away (Id.of_string "x") avoid and + m = next_ident_away (Id.of_string "y") avoid in + let u = Univ.Instance.empty in + create_input ( + mkNamedProd n (mkFullInd (ind,u) nparrec) ( + mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( + mkArrow + (mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(eqI,[|mkVar n;mkVar m|]);(Lazy.force tt)|])) + (mkApp(Lazy.force eq,[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) + ))), eff + +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 = + ( List.map (fun (s,_,_,_) -> s ) list_id ) @ + ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) @ + ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) + in + let fresh_id s gl = + Tacmach.New.of_old begin fun gsig -> + let fresh = fresh_id (!avoid) s gsig in + avoid := fresh::(!avoid); fresh + end gl + in + 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 + let freshz = fresh_id (Id.of_string "Z") gl in + (* try with *) + Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros; + intro_using freshn ; + induct_on (mkVar freshn); + intro_using freshm; + destruct_on (mkVar freshm); + intro_using freshz; + intros; + Tacticals.New.tclTRY ( + Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) + ); + simpl_in_hyp (freshz,Locus.InHyp); +(* +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 { enter = begin fun gl -> + let fresht = fresh_id (Id.of_string "Z") gl in + destruct_on_as (mkVar freshz) + (IntroOrPattern [[dl,IntroNaming (IntroIdentifier fresht); + dl,IntroNaming (IntroIdentifier freshz)]]) + 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 { enter = begin fun gls -> + let gl = Proofview.Goal.concl gls in + match (kind_of_term gl) with + | App (c,ca) -> ( + match (kind_of_term c) with + | Ind (indeq, u) -> + if eq_gr (IndRef indeq) Coqlib.glob_eq + then + Tacticals.New.tclTHEN + (do_replace_bl mode bl_scheme_key ind + (!avoid) + nparrec (ca.(2)) + (ca.(1))) + Auto.default_auto + else + Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") + | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.") + ) + | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") + end } + + ] + end } + +let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined") + +let side_effect_of_mode = function + | Declare.UserAutomaticRequest -> false + | Declare.InternalTacticRequest -> true + | Declare.UserIndividualRequest -> 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 + user_err + (str "Automatic building of boolean->Leibniz lemmas not supported"); + let ind = (mind,0) in + let nparams = mib.mind_nparams in + let nparrec = mib.mind_nparams_rec in + 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.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) + in + ([|ans|], ctx), eff + +let bl_scheme_kind = declare_mutual_scheme_object "_dec_bl" make_bl_scheme + +let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind + +(**********************************************************************) +(* Leibniz->Boolean *) + +let compute_lb_goal ind lnamesparrec nparrec = + let list_id = list_id lnamesparrec in + let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in + let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in + let eqI, eff = eqI ind lnamesparrec in + let create_input c = + let x = next_ident_away (Id.of_string "x") avoid and + y = next_ident_away (Id.of_string "y") avoid in + let lb_typ = List.map (fun (s,seq,_,_) -> + mkNamedProd x (mkVar s) ( + mkNamedProd y (mkVar s) ( + mkArrow + ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) + ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) + )) + ) list_id in + let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> + mkNamedProd slb b a + ) c (List.rev list_id) (List.rev lb_typ) in + let eqs_typ = List.map (fun (s,_,_,_) -> + mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) + ) list_id in + 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 decl -> mkNamedProd + (match (RelDecl.get_name decl) with Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_type decl) a) eq_input lnamesparrec + in + let n = next_ident_away (Id.of_string "x") avoid and + m = next_ident_away (Id.of_string "y") avoid in + let u = Univ.Instance.empty in + create_input ( + mkNamedProd n (mkFullInd (ind,u) nparrec) ( + mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( + mkArrow + (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar n;mkVar m|])) + (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) + ))), eff + +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 = + ( List.map (fun (s,_,_,_) -> s ) list_id ) @ + ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ + ( List.map (fun (_,_,_,slb) -> slb) list_id ) + in + let fresh_id s gl = + Tacmach.New.of_old begin fun gsig -> + let fresh = fresh_id (!avoid) s gsig in + avoid := fresh::(!avoid); fresh + end gl + in + 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 + let freshz = fresh_id (Id.of_string "Z") gl in + (* try with *) + Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros; + intro_using freshn ; + induct_on (mkVar freshn); + intro_using freshm; + destruct_on (mkVar freshm); + intro_using freshz; + intros; + Tacticals.New.tclTRY ( + Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) + ); + Equality.inj None false None (mkVar freshz,NoBindings); + intros; simpl_in_concl; + Auto.default_auto; + Tacticals.New.tclREPEAT ( + Tacticals.New.tclTHENLIST [apply (andb_true_intro()); + simplest_split ;Auto.default_auto ] + ); + 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 + | App(c,ca) -> (match (kind_of_term ca.(1)) with + | App(c',ca') -> + let n = Array.length ca' in + do_replace_lb mode lb_scheme_key + (!avoid) + nparrec + ca'.(n-2) ca'.(n-1) + | _ -> + Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") + ) + | _ -> + Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") + end } + ] + end } + +let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") + +let make_lb_scheme mode mind = + let mib = Global.lookup_mind mind in + if not (Int.equal (Array.length mib.mind_packets) 1) then + user_err + (str "Automatic building of Leibniz->boolean lemmas not supported"); + let ind = (mind,0) in + let nparams = mib.mind_nparams in + let nparrec = mib.mind_nparams_rec in + let lnonparrec,lnamesparrec = + context_chop (nparams-nparrec) mib.mind_params_ctxt in + let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec 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) + in + ([|ans|], ctx), eff + +let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme + +let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind + +(**********************************************************************) +(* Decidable equality *) + +let check_not_is_defined () = + try ignore (Coqlib.build_coq_not ()) + with e when CErrors.noncritical e -> raise (UndefinedCst "not") + +(* {n=m}+{n<>m} part *) +let compute_dec_goal ind lnamesparrec nparrec = + check_not_is_defined (); + let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in + let list_id = list_id lnamesparrec in + let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in + let create_input c = + let x = next_ident_away (Id.of_string "x") avoid and + y = next_ident_away (Id.of_string "y") avoid in + let lb_typ = List.map (fun (s,seq,_,_) -> + mkNamedProd x (mkVar s) ( + mkNamedProd y (mkVar s) ( + mkArrow + ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) + ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) + )) + ) list_id in + let bl_typ = List.map (fun (s,seq,_,_) -> + mkNamedProd x (mkVar s) ( + mkNamedProd y (mkVar s) ( + mkArrow + ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) + ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) + )) + ) list_id in + + let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> + mkNamedProd slb b a + ) c (List.rev list_id) (List.rev lb_typ) in + let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> + mkNamedProd sbl b a + ) lb_input (List.rev list_id) (List.rev bl_typ) in + + let eqs_typ = List.map (fun (s,_,_,_) -> + mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) + ) list_id in + 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 decl -> mkNamedProd + (match RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_type decl) a) eq_input lnamesparrec + in + let n = next_ident_away (Id.of_string "x") avoid and + m = next_ident_away (Id.of_string "y") avoid in + let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in + create_input ( + mkNamedProd n (mkFullInd ind (2*nparrec)) ( + mkNamedProd m (mkFullInd ind (2*nparrec+1)) ( + mkApp(sumbool(),[|eqnm;mkApp (Coqlib.build_coq_not(),[|eqnm|])|]) + ) + ) + ) + +let compute_dec_tact ind lnamesparrec nparrec = + let eq = Lazy.force eq and tt = Lazy.force tt + and ff = Lazy.force ff and bb = Lazy.force bb in + let list_id = list_id lnamesparrec in + let eqI, eff = eqI ind lnamesparrec in + let avoid = ref [] in + let eqtrue x = mkApp(eq,[|bb;x;tt|]) in + let eqfalse x = mkApp(eq,[|bb;x;ff|]) in + let first_intros = + ( List.map (fun (s,_,_,_) -> s ) list_id ) @ + ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ + ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @ + ( List.map (fun (_,_,_,slb) -> slb) list_id ) + in + let fresh_id s gl = + Tacmach.New.of_old begin fun gsig -> + let fresh = fresh_id (!avoid) s gsig in + avoid := fresh::(!avoid); fresh + end gl + in + 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 + let freshH = fresh_id (Id.of_string "H") gl in + let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in + let arfresh = Array.of_list fresh_first_intros in + let xargs = Array.sub arfresh 0 (2*nparrec) in + begin try + let c, eff = find_scheme bl_scheme_kind ind in + Proofview.tclUNIT (mkConst c,eff) with + Not_found -> + Tacticals.New.tclZEROMSG (str "Error during the decidability part, boolean to leibniz equality is required.") + end >>= fun (blI,eff') -> + begin try + let c, eff = find_scheme lb_scheme_kind ind in + Proofview.tclUNIT (mkConst c,eff) with + Not_found -> + Tacticals.New.tclZEROMSG (str "Error during the decidability part, leibniz to boolean equality is required.") + end >>= fun (lbI,eff'') -> + 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; + intros_using [freshn;freshm]; + (*we do this so we don't have to prove the same goal twice *) + assert_by (Name freshH) ( + mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) + ) + (Tacticals.New.tclTHEN (destruct_on eqbnm) Auto.default_auto); + + 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 *) + Tacticals.New.tclTHENLIST [ + simplest_left; + apply (mkApp(blI,Array.map(fun x->mkVar x) xargs)); + Auto.default_auto + ] + ; + + (*right *) + Proofview.Goal.nf_enter { enter = begin fun gl -> + let freshH3 = fresh_id (Id.of_string "H") gl in + Tacticals.New.tclTHENLIST [ + simplest_right ; + unfold_constr (Lazy.force Coqlib.coq_not_ref); + intro; + Equality.subst_all (); + assert_by (Name freshH3) + (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|])) + (Tacticals.New.tclTHENLIST [ + apply (mkApp(lbI,Array.map (fun x->mkVar x) xargs)); + Auto.default_auto + ]); + Equality.general_rewrite_bindings_in true + Locus.AllOccurrences true false + (List.hd !avoid) + ((mkVar (List.hd (List.tl !avoid))), + NoBindings + ) + true; + Equality.discr_tac false None + ] + end } + ] + end } + ] + end } + +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; + let ind = (mind,0) in + let nparams = mib.mind_nparams in + let nparrec = mib.mind_nparams_rec in + let u = Univ.Instance.empty 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 + 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 + ([|ans|], ctx), Safe_typing.empty_private_constants + +let eq_dec_scheme_kind = + declare_mutual_scheme_object "_eq_dec" make_eq_decidability + +(* The eq_dec_scheme proofs depend on the equality and discr tactics + but the inj tactics, that comes with discr, depends on the + eq_dec_scheme... *) + +let _ = Equality.set_eq_dec_scheme_kind eq_dec_scheme_kind diff --git a/vernac/auto_ind_decl.mli b/vernac/auto_ind_decl.mli new file mode 100644 index 0000000000..60232ba8f4 --- /dev/null +++ b/vernac/auto_ind_decl.mli @@ -0,0 +1,42 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + (Printer.pr_global g ++ str" is already a coercion") + | NotAFunction -> + (Printer.pr_global g ++ str" is not a function") + | NoSource (Some cl) -> + (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of " + ++ Printer.pr_global g) + | NoSource None -> + (str ": cannot find the source class of " ++ Printer.pr_global g) + | ForbiddenSourceClass cl -> + pr_class cl ++ str " cannot be a source class" + | NoTarget -> + (str"Cannot find the target class") + | WrongTarget (clt,cl) -> + (str"Found target class " ++ pr_class cl ++ + str " instead of " ++ pr_class clt) + | NotAClass ref -> + (str "Type of " ++ Printer.pr_global ref ++ + str " does not end with a sort") + +(* Verifications pour l'ajout d'une classe *) + +let check_reference_arity ref = + if not (Reductionops.is_arity (Global.env()) Evd.empty (Global.type_of_global_unsafe ref)) then + raise (CoercionError (NotAClass ref)) + +let check_arity = function + | CL_FUN | CL_SORT -> () + | CL_CONST cst -> check_reference_arity (ConstRef cst) + | CL_PROJ cst -> check_reference_arity (ConstRef cst) + | CL_SECVAR id -> check_reference_arity (VarRef id) + | CL_IND kn -> check_reference_arity (IndRef kn) + +(* Coercions *) + +(* check that the computed target is the provided one *) +let check_target clt = function + | Some cl when not (cl_typ_eq cl clt) -> raise (CoercionError (WrongTarget(clt,cl))) + | _ -> () + +(* condition d'heritage uniforme *) + +let uniform_cond nargs lt = + let rec aux = function + | (0,[]) -> true + | (n,t::l) -> + let t = strip_outer_cast t in + isRel t && Int.equal (destRel t) n && aux ((n-1),l) + | _ -> false + in + aux (nargs,lt) + +let class_of_global = function + | ConstRef sp -> + if Environ.is_projection sp (Global.env ()) + then CL_PROJ sp else CL_CONST sp + | IndRef sp -> CL_IND sp + | VarRef id -> CL_SECVAR id + | ConstructRef _ as c -> + user_err ~hdr:"class_of_global" + (str "Constructors, such as " ++ Printer.pr_global c ++ + str ", cannot be used as a class.") + +(* +lp est la liste (inverse'e) des arguments de la coercion +ids est le nom de la classe source +sps_opt est le sp de la classe source dans le cas des structures +retourne: +la classe source +nbre d'arguments de la classe +le constr de la class +la liste des variables dont depend la classe source +l'indice de la classe source dans la liste lp +*) + +let get_source lp source = + match source with + | None -> + let (cl1,u1,lv1) = + match lp with + | [] -> raise Not_found + | t1::_ -> find_class_type Evd.empty t1 + in + (cl1,u1,lv1,1) + | Some cl -> + let rec aux = function + | [] -> raise Not_found + | t1::lt -> + try + let cl1,u1,lv1 = find_class_type Evd.empty t1 in + if cl_typ_eq cl cl1 then cl1,u1,lv1,(List.length lt+1) + else raise Not_found + with Not_found -> aux lt + in aux (List.rev lp) + +let get_target t ind = + if (ind > 1) then + CL_FUN + else + match pi1 (find_class_type Evd.empty t) with + | CL_CONST p when Environ.is_projection p (Global.env ()) -> + CL_PROJ p + | x -> x + + +let prods_of t = + let rec aux acc d = match kind_of_term d with + | Prod (_,c1,c2) -> aux (c1::acc) c2 + | Cast (c,_,_) -> aux acc c + | _ -> (d,acc) + in + aux [] t + +let strength_of_cl = function + | CL_CONST kn -> `GLOBAL + | CL_SECVAR id -> `LOCAL + | _ -> `GLOBAL + +let strength_of_global = function + | VarRef _ -> `LOCAL + | _ -> `GLOBAL + +let get_strength stre ref cls clt = + let stres = strength_of_cl cls in + let stret = strength_of_cl clt in + let stref = strength_of_global ref in + strength_min [stre;stres;stret;stref] + +let ident_key_of_class = function + | CL_FUN -> "Funclass" + | CL_SORT -> "Sortclass" + | CL_CONST sp | CL_PROJ sp -> Label.to_string (con_label sp) + | CL_IND (sp,_) -> Label.to_string (mind_label sp) + | CL_SECVAR id -> Id.to_string id + +(* Identity coercion *) + +let error_not_transparent source = + user_err ~hdr:"build_id_coercion" + (pr_class source ++ str " must be a transparent constant.") + +let build_id_coercion idf_opt source poly = + let env = Global.env () in + 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 + | None -> error_not_transparent source in + let lams,t = decompose_lam_assum c in + let val_f = + it_mkLambda_or_LetIn + (mkLambda (Name Namegen.default_dependent_ident, + applistc vs (Context.Rel.to_extended_list 0 lams), + mkRel 1)) + lams + in + let typ_f = + it_mkProd_wo_LetIn + (mkProd (Anonymous, applistc vs (Context.Rel.to_extended_list 0 lams), lift 1 t)) + lams + in + (* juste pour verification *) + let _ = + if not + (Reductionops.is_conv_leq env sigma + (Typing.unsafe_type_of env sigma val_f) typ_f) + then + user_err (strbrk + "Cannot be defined as coercion (maybe a bad number of arguments).") + in + let idf = + match idf_opt with + | Some idf -> idf + | None -> + 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:(snd (Evd.universe_context sigma)) + ~inline:true (mkCast (val_f, DEFAULTcast, typ_f))) + in + let decl = (constr_entry, IsDefinition IdentityCoercion) in + let kn = declare_constant idf decl in + ConstRef kn + +let check_source = function +| Some (CL_FUN|CL_SORT as s) -> raise (CoercionError (ForbiddenSourceClass s)) +| _ -> () + +(* +nom de la fonction coercion +strength de f +nom de la classe source (optionnel) +sp de la classe source (dans le cas des structures) +nom de la classe target (optionnel) +booleen "coercion identite'?" + +lorque source est None alors target est None aussi. +*) + +let warn_uniform_inheritance = + CWarnings.create ~name:"uniform-inheritance" ~category:"typechecker" + (fun g -> + Printer.pr_global g ++ + strbrk" does not respect the uniform inheritance condition") + +let add_new_coercion_core coef stre poly source target isid = + check_source source; + let t = Global.type_of_global_unsafe coef in + if coercion_exists coef then raise (CoercionError AlreadyExists); + let tg,lp = prods_of t in + let llp = List.length lp in + if Int.equal llp 0 then raise (CoercionError NotAFunction); + let (cls,us,lvs,ind) = + try + get_source lp source + with Not_found -> + raise (CoercionError (NoSource source)) + in + check_source (Some cls); + if not (uniform_cond (llp-ind) lvs) then + warn_uniform_inheritance coef; + let clt = + try + get_target tg ind + with Not_found -> + raise (CoercionError NoTarget) + in + check_target clt target; + check_arity cls; + check_arity clt; + let local = match get_strength stre coef cls clt with + | `LOCAL -> true + | `GLOBAL -> false + in + declare_coercion coef ~local ~isid ~src:cls ~target:clt ~params:(List.length lvs) + + +let try_add_new_coercion_core ref ~local c d e f = + try add_new_coercion_core ref (loc_of_bool local) c d e f + with CoercionError e -> + user_err ~hdr:"try_add_new_coercion_core" + (explain_coercion_error ref e ++ str ".") + +let try_add_new_coercion ref ~local poly = + try_add_new_coercion_core ref ~local poly None None false + +let try_add_new_coercion_subclass cl ~local poly = + let coe_ref = build_id_coercion None cl poly in + try_add_new_coercion_core coe_ref ~local poly (Some cl) None true + +let try_add_new_coercion_with_target ref ~local poly ~source ~target = + try_add_new_coercion_core ref ~local poly (Some source) (Some target) false + +let try_add_new_identity_coercion id ~local poly ~source ~target = + let ref = build_id_coercion (Some id) source poly in + try_add_new_coercion_core ref ~local poly (Some source) (Some target) true + +let try_add_new_coercion_with_source ref ~local poly ~source = + try_add_new_coercion_core ref ~local poly (Some source) None false + +let add_coercion_hook poly local ref = + let stre = match local with + | Local -> true + | Global -> false + | Discharge -> assert false + in + let () = try_add_new_coercion ref stre poly in + let msg = pr_global_env Id.Set.empty ref ++ str " is now a coercion" in + Flags.if_verbose Feedback.msg_info msg + +let add_coercion_hook poly = Lemmas.mk_hook (add_coercion_hook poly) + +let add_subclass_hook poly local ref = + let stre = match local with + | Local -> true + | Global -> false + | Discharge -> assert false + in + let cl = class_of_global ref in + try_add_new_coercion_subclass cl stre poly + +let add_subclass_hook poly = Lemmas.mk_hook (add_subclass_hook poly) diff --git a/vernac/class.mli b/vernac/class.mli new file mode 100644 index 0000000000..5f9ae28f62 --- /dev/null +++ b/vernac/class.mli @@ -0,0 +1,48 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* local:bool -> + Decl_kinds.polymorphic -> + source:cl_typ -> target:cl_typ -> unit + +(** [try_add_new_coercion ref s] declares [ref], assumed to be of type + [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *) +val try_add_new_coercion : global_reference -> local:bool -> + Decl_kinds.polymorphic -> unit + +(** [try_add_new_coercion_subclass cst s] expects that [cst] denotes a + transparent constant which unfolds to some class [tg]; it declares + an identity coercion from [cst] to [tg], named something like + ["Id_cst_tg"] *) +val try_add_new_coercion_subclass : cl_typ -> local:bool -> + Decl_kinds.polymorphic -> unit + +(** [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion + from [src] to [tg] where the target is inferred from the type of [ref] *) +val try_add_new_coercion_with_source : global_reference -> local:bool -> + Decl_kinds.polymorphic -> source:cl_typ -> unit + +(** [try_add_new_identity_coercion id s src tg] enriches the + environment with a new definition of name [id] declared as an + identity coercion from [src] to [tg] *) +val try_add_new_identity_coercion : Id.t -> local:bool -> + Decl_kinds.polymorphic -> source:cl_typ -> target:cl_typ -> unit + +val add_coercion_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook + +val add_subclass_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook + +val class_of_global : global_reference -> cl_typ diff --git a/vernac/classes.ml b/vernac/classes.ml new file mode 100644 index 0000000000..6512f3defa --- /dev/null +++ b/vernac/classes.ml @@ -0,0 +1,410 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* !refine_instance); + Goptions.optwrite = (fun b -> refine_instance := b) +} + +let typeclasses_db = "typeclass_instances" + +let set_typeclass_transparency c local b = + Hints.add_hints local [typeclasses_db] + (Hints.HintsTransparencyEntry ([c], b)) + +let _ = + Hook.set Typeclasses.add_instance_hint_hook + (fun inst path local info poly -> + let inst' = match inst with IsConstr c -> Hints.IsConstr (c, Univ.ContextSet.empty) + | IsGlobal gr -> Hints.IsGlobRef gr + in + let info = + let open Vernacexpr in + { info with hint_pattern = + Option.map + (Constrintern.intern_constr_pattern (Global.env())) + info.hint_pattern } in + Flags.silently (fun () -> + Hints.add_hints local [typeclasses_db] + (Hints.HintsResolveEntry + [info, poly, false, Hints.PathHints path, inst'])) ()); + Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency; + Hook.set Typeclasses.classes_transparent_state_hook + (fun () -> Hints.Hint_db.transparent_state (Hints.searchtable_map typeclasses_db)) + +open Vernacexpr + +(** TODO: add subinstances *) +let existing_instance glob g info = + let c = global g in + let info = Option.default Hints.empty_hint_info info in + let instance = Global.type_of_global_unsafe c in + let _, r = decompose_prod_assum instance in + match class_of_constr r with + | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob + (*FIXME*) (Flags.use_polymorphic_flag ()) c) + | None -> user_err ~loc:(loc_of_reference g) + ~hdr:"declare_instance" + (Pp.str "Constant does not build instances of a declared type class.") + +let mismatched_params env n m = mismatched_ctx_inst env Parameters n m +let mismatched_props env n m = mismatched_ctx_inst env Properties n m + +(* Declare everything in the parameters as implicit, and the class instance as well *) + +let type_ctx_instance evars env ctx inst subst = + let rec aux (subst, instctx) l = function + decl :: ctx -> + let t' = substl subst (RelDecl.get_type decl) in + let c', 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 = RelDecl.get_name decl, Some c', t' in + aux (c' :: subst, d :: instctx) l ctx + | [] -> subst + in aux (subst, []) inst (List.rev ctx) + +let id_of_class cl = + match cl.cl_impl with + | ConstRef kn -> let _,_,l = repr_con kn in Label.to_id l + | IndRef (kn,i) -> + let mip = (Environ.lookup_mind kn (Global.env ())).Declarations.mind_packets in + mip.(0).Declarations.mind_typename + | _ -> assert false + +open Pp + +let instance_hook k info global imps ?hook cst = + Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps; + Typeclasses.declare_instance (Some info) (not global) cst; + (match hook with Some h -> h cst | None -> ()) + +let declare_instance_constant k info global imps ?hook id pl poly evm term termtype = + let kind = IsDefinition Instance in + let evm = + let levels = Univ.LSet.union (Universes.universes_of_constr termtype) + (Universes.universes_of_constr term) in + 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: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 info global imps ?hook (ConstRef kn); + id + +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 + 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 + | Decl_kinds.Implicit -> + Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false + (fun avoid (clname, _) -> + match clname with + | Some (cl, b) -> + let t = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in + t, avoid + | None -> failwith ("new instance: under-applied typeclass")) + cl + | Explicit -> cl, Id.Set.empty + in + let tclass = + if generalize then CGeneralization (Loc.ghost, Implicit, Some AbsPi, tclass) + else tclass + in + let k, u, cty, ctx', ctx, len, imps, subst = + let impls, ((env', ctx), imps) = interp_context_evars env evars ctx in + let c', imps' = interp_type_evars_impls ~impls env' evars tclass in + let len = List.length ctx in + let imps = imps @ Impargs.lift_implicits len imps' in + let ctx', c = decompose_prod_assum c' in + let ctx'' = ctx' @ ctx in + 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 decl (args, args') -> + 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 + in + let id = + match instid with + Name id -> + let sp = Lib.make_path id in + if Nametab.exists_cci sp then + user_err ~hdr:"new_instance" (Nameops.pr_id id ++ Pp.str " already exists."); + id + | Anonymous -> + let i = Nameops.add_suffix (id_of_class k) "_instance_0" in + Namegen.next_global_ident_away i (Termops.ids_of_context env) + in + let env' = push_rel_context ctx env in + evars := Evarutil.nf_evar_map !evars; + evars := resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env !evars; + let subst = List.map (Evarutil.nf_evar !evars) subst in + if abstract then + begin + let subst = List.fold_left2 + (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 + let nf, subst = Evarutil.e_nf_evars_and_universes evars in + let termtype = + let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in + nf t + in + 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 + (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) + in + Universes.register_universe_binders (ConstRef cst) pl; + instance_hook k pri global imps ?hook (ConstRef cst); id + end + else ( + let props = + match props with + | 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) + | Some (_, t) -> Some (Inr t) + | None -> + if Flags.is_program_mode () then Some (Inl []) + else None + in + let subst = + match props with + | None -> if List.is_empty k.cl_props then Some (Inl subst) else None + | Some (Inr term) -> + let c = interp_casted_constr_evars env' evars term cty in + Some (Inr (c, subst)) + | Some (Inl props) -> + let get_id = + function + | Ident id' -> id' + | Qualid (loc,id') -> (loc, snd (repr_qualid id')) + in + let props, rest = + List.fold_left + (fun (props, rest) decl -> + if is_local_assum decl then + try + let is_id (id', _) = match RelDecl.get_name decl, get_id id' with + | Name id, (_, id') -> Id.equal id id' + | Anonymous, _ -> false + in + let (loc_mid, c) = + List.find is_id rest + in + let rest' = + List.filter (fun v -> not (is_id v)) rest + in + let (loc, mid) = get_id loc_mid in + List.iter (fun (n, _, x) -> + if Name.equal n (Name mid) then + Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x) + k.cl_projs; + c :: props, rest' + with Not_found -> + (CHole (Loc.ghost, None(* Some Evar_kinds.GoalEvar *), Misctypes.IntroAnonymous, None) :: props), rest + else props, rest) + ([], props) k.cl_props + in + match rest with + | (n, _) :: _ -> + unbound_method env' k.cl_impl (get_id n) + | _ -> + Some (Inl (type_ctx_instance evars (push_rel_context ctx' env') + k.cl_props props subst)) + in + let term, termtype = + match subst with + | None -> let termtype = it_mkProd_or_LetIn cty ctx in + None, termtype + | Some (Inl subst) -> + let subst = List.fold_left2 + (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 + let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in + let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in + Some term, termtype + | Some (Inr (def, subst)) -> + let termtype = it_mkProd_or_LetIn cty ctx in + let term = Termops.it_mkLambda_or_LetIn def ctx in + Some term, termtype + in + let _ = + evars := Evarutil.nf_evar_map !evars; + evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals_or_obligations ~fail:true + env !evars; + (* Try resolving fields that are typeclasses automatically. *) + evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false + env !evars + in + let _ = evars := Evarutil.nf_evar_map_undefined !evars in + 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. *) + 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 + declare_instance_constant k pri global imps ?hook id pl + poly evm (Option.get term) termtype + 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 _ = + let cst = match gr with ConstRef kn -> kn | _ -> assert false in + Impargs.declare_manual_implicits false gr ~enriching:false [imps]; + Typeclasses.declare_instance (Some pri) (not global) (ConstRef cst) + in + let obls, constr, typ = + match term with + | Some t -> + let obls, _, constr, typ = + Obligations.eterm_obligations env id evm 0 t termtype + in obls, Some constr, typ + | None -> [||], None, termtype + in + let hook = Lemmas.mk_hook hook in + let ctx = Evd.evar_universe_context evm in + ignore (Obligations.add_definition id ?term:constr + ?pl typ ctx ~kind:(Global,poly,Instance) ~hook obls); + id + else + (Flags.silently + (fun () -> + (* spiwack: it is hard to reorder the actions to do + the pretyping after the proof has opened. As a + consequence, we use the low-level primitives to code + the refinement manually.*) + let gls = List.rev (Evd.future_goals evm) in + let evm = Evd.reset_future_goals evm in + Lemmas.start_proof id kind evm termtype + (Lemmas.mk_hook + (fun _ -> instance_hook k pri global imps ?hook)); + (* spiwack: I don't know what to do with the status here. *) + if not (Option.is_empty term) then + let init_refine = + Tacticals.New.tclTHENLIST [ + Refine.refine { run = fun evm -> Sigma (Option.get term, evm, Sigma.refl) }; + Proofview.Unsafe.tclNEWGOALS gls; + Tactics.New.reduce_after_refine; + ] + in + ignore (Pfedit.by init_refine) + else if Flags.is_auto_intros () then + ignore (Pfedit.by (Tacticals.New.tclDO len Tactics.intro)); + (match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) (); + id) + end + else CErrors.error "Unsolved obligations remaining.") + +let named_of_rel_context l = + let acc, ctx = + List.fold_right + (fun decl (subst, ctx) -> + let id = match RelDecl.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 + +let context poly l = + let env = Global.env() 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.Rel.map subst fullctx 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 + with e when CErrors.noncritical e -> + error "Anonymous variables not allowed in contexts." + 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 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) -> + add_instance (Typeclasses.new_instance tc Hints.empty_hint_info false (*FIXME*) + poly (ConstRef cst)); + status + (* declare_subclasses (ConstRef cst) cl *) + | None -> status + else + let test (x, _) = match x with + | ExplByPos (_, Some id') -> Id.equal id id' + | _ -> false + in + let impl = List.exists test impls in + let decl = (Discharge, poly, Definitional) in + let nstatus = + pi3 (Command.declare_assumption false decl (t, !uctx) [] [] impl + Vernacexpr.NoInline (Loc.ghost, id)) + in + let () = uctx := Univ.ContextSet.empty in + status && nstatus + in List.fold_left fn true (List.rev ctx) diff --git a/vernac/classes.mli b/vernac/classes.mli new file mode 100644 index 0000000000..d2cb788eae --- /dev/null +++ b/vernac/classes.mli @@ -0,0 +1,66 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr_expr list -> Context.Rel.t -> 'a + +val mismatched_props : env -> constr_expr list -> Context.Rel.t -> 'a + +(** Instance declaration *) + +val existing_instance : bool -> reference -> Vernacexpr.hint_info_expr option -> unit +(** globality, reference, optional priority and pattern information *) + +val declare_instance_constant : + typeclass -> + Vernacexpr.hint_info_expr -> (** priority *) + bool -> (** globality *) + Impargs.manual_explicitation list -> (** implicits *) + ?hook:(Globnames.global_reference -> unit) -> + Id.t -> (** name *) + Id.t Loc.located list option -> + bool -> (* polymorphic *) + Evd.evar_map -> (* Universes *) + Constr.t -> (** body *) + Term.types -> (** type *) + Names.Id.t + +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 -> + (bool * constr_expr) option -> + ?generalize:bool -> + ?tac:unit Proofview.tactic -> + ?hook:(Globnames.global_reference -> unit) -> + Vernacexpr.hint_info_expr -> + Id.t + +(** Setting opacity *) + +val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit + +(** For generation on names based on classes only *) + +val id_of_class : typeclass -> Id.t + +(** Context command *) + +(** returns [false] if, for lack of section, it declares an assumption + (unless in a module type). *) +val context : Decl_kinds.polymorphic -> local_binder list -> bool diff --git a/vernac/command.ml b/vernac/command.ml new file mode 100644 index 0000000000..049f58aa26 --- /dev/null +++ b/vernac/command.ml @@ -0,0 +1,1357 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + 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 (LocalDef (x,b,t)) env) sigma f (n-1) c) + | _ -> assert false + +let rec complete_conclusion a cs = function + | CProdN (loc,bl,c) -> CProdN (loc,bl,complete_conclusion a cs c) + | CLetIn (loc,b,t,c) -> CLetIn (loc,b,t,complete_conclusion a cs c) + | CHole (loc, k, _, _) -> + let (has_no_args,name,params) = a in + if not has_no_args then + user_err ~loc + (strbrk"Cannot infer the non constant arguments of the conclusion of " + ++ pr_id cs ++ str "."); + let args = List.map (fun id -> CRef(Ident(loc,id),None)) params in + CAppExpl (loc,(None,Ident(loc,name),None),List.rev args) + | c -> c + +(* Commands of the interface *) + +(* 1| Constant definitions *) + +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 + 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 redfun n body,ctx),eff) } + +let warn_implicits_in_term = + CWarnings.create ~name:"implicits-in-term" ~category:"implicits" + (fun () -> + strbrk "Implicit arguments declaration relies on type." ++ spc () ++ + strbrk "The term declares more implicits than the type here.") + +let interp_definition pl bl p red_option c ctypopt = + let env = Global.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,pl,ce = + match ctypopt with + None -> + let subst = evd_comb0 Evd.nf_univ_variables evdref 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 + 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 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 + let subst = evd_comb0 Evd.nf_univ_variables evdref 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 + let body = nf (it_mkLambda_or_LetIn c ctx) in + let typ = nf (it_mkProd_or_LetIn ty ctx) in + let beq b1 b2 = if b1 then b2 else not b2 in + let impl_eq (x,y,z) (x',y',z') = beq x x' && beq y y' && beq z z' in + (* Check that all implicit arguments inferable from the term + are inferable from the type *) + let chk (key,va) = + impl_eq (List.assoc_f Pervasives.(=) key impsty) va (* FIXME *) + in + if not (try List.for_all chk imps2 with Not_found -> false) + then warn_implicits_in_term (); + 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 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 (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); + ce + +let warn_local_declaration = + CWarnings.create ~name:"local-declaration" ~category:"scope" + (fun (id,kind) -> + pr_id id ++ strbrk " is declared as a local " ++ str kind) + +let get_locality id ~kind = function +| Discharge -> + (** If a Let is defined outside a section, then we consider it as a local definition *) + warn_local_declaration (id,kind); + true +| Local -> true +| Global -> false + +let declare_global_definition ident ce local k pl imps = + let local = get_locality ident ~kind:"definition" 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 + +let declare_definition_hook = ref ignore +let set_declare_definition_hook = (:=) declare_definition_hook +let get_declare_definition_hook () = !declare_definition_hook + +let warn_definition_not_visible = + CWarnings.create ~name:"definition-not-visible" ~category:"implicits" + (fun ident -> + strbrk "Section definition " ++ + pr_id ident ++ strbrk " is not visible from current goals") + +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 () -> + let c = SectionLocalDef ce in + let _ = declare_variable ident (Lib.cwd(), c, IsDefinition k) in + let () = definition_message ident in + let gr = VarRef ident in + let () = maybe_declare_manual_implicits false gr imps in + let () = if Pfedit.refining () then + warn_definition_not_visible ident + in + gr + | Discharge | Local | Global -> + declare_global_definition ident ce local k pl imps in + 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) + +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 + if Flags.is_program_mode () then + let env = Global.env () in + let (c,ctx), sideff = Future.force ce.const_entry_body in + assert(Safe_typing.empty_private_constants = sideff); + assert(Univ.ContextSet.is_empty ctx); + let typ = match ce.const_entry_type with + | Some t -> t + | None -> Retyping.get_type_of env evd c + in + Obligations.check_evars env evd; + let obls, _, c, cty = + 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 ?pl ~implicits:imps ~kind:k ~hook obls) + else let ce = check_definition def in + 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) 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 + let () = assumption_message ident in + let () = + if is_verbose () && Pfedit.refining () then + Feedback.msg_info (str"Variable" ++ spc () ++ pr_id ident ++ + strbrk " is not visible from current goals") + in + let r = VarRef ident in + let () = Typeclasses.declare_instance None true r in + let () = if is_coe then Class.try_add_new_coercion r ~local:true false in + (r,Univ.Instance.empty,true) + +| Global | Local | Discharge -> + let local = get_locality ident ~kind:"axiom" local in + let inl = match nl with + | NoInline -> None + | DefaultInline -> Some (Flags.get_inline_level()) + | InlineAt i -> Some i + in + let ctx = Univ.ContextSet.to_context ctx in + let decl = (ParameterEntry (None,p,(c,ctx),inl), IsAssumption kind) in + 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 + let inst = + if p (* polymorphic *) then Univ.UContext.instance ctx + else Univ.Instance.empty + in + (gr,inst,Lib.is_modtype_strict ()) + +let interp_assumption evdref env impls bl c = + let c = prod_constr_expr c bl in + interp_type_evars_impls env evdref ~impls c + +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) pl 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_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 = + if poly then + (* Separate declarations so that A B : Type puts A and B in different levels. *) + List.fold_right (fun (is_coe,(idl,c)) acc -> + List.fold_right (fun id acc -> + (is_coe, ([id], c)) :: acc) idl acc) + l [] + else l + in + (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) + let _,l = List.fold_map (fun (env,ienv) (is_coe,(idl,c)) -> + let t,imps = interp_assumption evdref env ienv [] c in + let env = + 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 + ((env,ienv),((is_coe,idl),t,imps))) + (env,empty_internalization_env) l + in + let evd = solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref) in + (* The universe constraints come from the whole telescope. *) + let evd = Evd.nf_constraints evd in + let ctx = Evd.universe_context_set evd in + let l = List.map (on_pi2 (nf_evar evd)) l in + pi2 (List.fold_left (fun (subst,status,ctx) ((is_coe,idl),t,imps) -> + let t = replace_vars subst t 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 + in + (subst'@subst, status' && status, + (* The universe constraints are declared with the first declaration only. *) + Univ.ContextSet.empty)) ([],true,ctx) 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 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) pl 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 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 one at a time." in + user_err ~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 *) + +let push_types env idl tl = + List.fold_left2 (fun env id t -> Environ.push_rel (LocalAssum (Name id,t)) env) + 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 +} + +type structured_inductive_expr = + local_binder list * structured_one_inductive_expr list + +let minductive_message warn = function + | [] -> error "No inductive definition." + | [x] -> (pr_id x ++ str " is defined" ++ + if warn then str " as a non-primitive record" else mt()) + | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++ + spc () ++ str "are defined") + +let check_all_names_different indl = + let ind_names = List.map (fun ind -> ind.ind_name) indl in + let cstr_names = List.map_append (fun ind -> List.map fst ind.ind_lc) indl in + let l = List.duplicates Id.equal ind_names in + let () = match l with + | [] -> () + | t :: _ -> raise (InductiveError (SameNamesTypes t)) + in + let l = List.duplicates Id.equal cstr_names in + let () = match l with + | [] -> () + | c :: _ -> raise (InductiveError (SameNamesConstructors (List.hd l))) + in + let l = List.intersect Id.equal ind_names cstr_names in + match l with + | [] -> () + | _ -> raise (InductiveError (SameNamesOverlap l)) + +let mk_mltype_data evdref env assums arity indname = + let is_ml_type = is_sort env !evdref arity in + (is_ml_type,indname,assums) + +let prepare_param = function + | 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. + This is really a hack to stay compatible with the semantics of template polymorphic + inductives which are recognized when a "Type" appears at the end of the conlusion in + the source syntax. *) + +let rec check_anonymous_type ind = + let open Glob_term in + match ind with + | GSort (_, GType []) -> true + | GProd (_, _, _, _, e) + | GLetIn (_, _, _, e) + | GLambda (_, _, _, _, e) + | GApp (_, e, _) + | GCast (_, e, _) -> check_anonymous_type e + | _ -> false + +let make_conclusion_flexible evdref ty poly = + if poly && isArity ty then + let _, concl = destArity ty in + match concl with + | Type u -> + (match Univ.universe_level u with + | Some u -> + evdref := Evd.make_flexible_variable !evdref true u + | None -> ()) + | _ -> () + else () + +let is_impredicative env u = + u = Prop Null || (is_impredicative_set env && u = Prop Pos) + +let interp_ind_arity env evdref ind = + let c = intern_gen IsType env ind.ind_arity in + let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in + let t, impls = understand_tcc_evars env evdref ~expected_type:IsType c, imps in + let pseudo_poly = check_anonymous_type c in + let () = if not (Reduction.is_arity env t) then + user_err ~loc:(constr_loc ind.ind_arity) (str "Not an arity") + in + t, pseudo_poly, impls + +let interp_cstrs evdref env impls mldata arity ind = + let cnames,ctyps = List.split ind.ind_lc in + (* Complete conclusions of constructor types if given in ML-style syntax *) + let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in + (* Interpret the constructor types *) + let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls evdref env ~impls) ctyps') in + (cnames, ctyps'', cimpls) + +let sign_level env evd sign = + fst (List.fold_right + (fun d (lev,env) -> + match d with + | LocalDef _ -> lev, push_rel d env + | LocalAssum _ -> + let s = destSort (Reduction.whd_all env + (nf_evar evd (Retyping.get_type_of env evd (RelDecl.get_type d)))) + in + let u = univ_of_sort s in + (Univ.sup u lev, push_rel d env)) + sign (Univ.type0m_univ,env)) + +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 (LocalAssum (Anonymous, concl) :: ctx)) tys + in sup_list min sorts + +let is_flexible_sort evd u = + match Univ.Universe.level u with + | Some l -> Evd.is_flexible_level evd l + | None -> false + +let inductive_levels env evdref poly arities inds = + let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in + let levels = List.map (fun (x,(ctx,a)) -> + if a = Prop Null then None + else Some (univ_of_sort a)) destarities + in + let cstrs_levels, min_levels, sizes = + CList.split3 + (List.map2 (fun (_,tys,_) (arity,(ctx,du)) -> + let len = List.length tys in + let minlev = Sorts.univ_of_sort du in + let minlev = + if len > 1 && not (is_impredicative env du) then + Univ.sup minlev Univ.type0_univ + else minlev + in + let minlev = + (** Indices contribute. *) + if Indtypes.is_indices_matter () && List.length ctx > 0 then ( + let ilev = sign_level env !evdref ctx in + Univ.sup ilev minlev) + else minlev + in + let clev = extract_level env !evdref minlev tys in + (clev, minlev, len)) inds destarities) + in + (* Take the transitive closure of the system of constructors *) + (* level constraints and remove the recursive dependencies *) + let levels' = Universes.solve_constraints_system (Array.of_list levels) + (Array.of_list cstrs_levels) (Array.of_list min_levels) + in + let evd, arities = + CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> + if is_impredicative env du then + (** Any product is allowed here. *) + evd, arity :: arities + else (** If in a predicative sort, or asked to infer the type, + we take the max of: + - indices (if in indices-matter mode) + - constructors + - Type(1) if there is more than 1 constructor + *) + (** Constructors contribute. *) + let evd = + if Sorts.is_set du then + if not (Evd.check_leq evd cu Univ.type0_univ) then + raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType) + else evd + else evd + (* Evd.set_leq_sort env evd (Type cu) du *) + in + let evd = + if len >= 2 && Univ.is_type0m_univ cu then + (** "Polymorphic" type constraint and more than one constructor, + should not land in Prop. Add constraint only if it would + land in Prop directly (no informative arguments as well). *) + Evd.set_leq_sort env evd (Prop Pos) du + else evd + in + let duu = Sorts.univ_of_sort du in + let evd = + if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then + if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ 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)) + (!evdref,[]) (Array.to_list levels') destarities sizes + in evdref := evd; List.rev arities + +let check_named (loc, na) = match na with +| Name _ -> () +| Anonymous -> + let msg = str "Parameters must be named." in + user_err ~loc msg + + +let check_param = function +| LocalRawDef (na, _) -> check_named na +| LocalRawAssum (nas, Default _, _) -> List.iter check_named nas +| LocalRawAssum (nas, Generalized _, _) -> () +| LocalPattern _ -> assert false + +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 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 + + (* Names of parameters as arguments of the inductive type (defs removed) *) + let assums = List.filter is_local_assum ctx_params in + let params = List.map (RelDecl.get_name %> out_name) assums in + + (* Interpret the arities *) + let arities = List.map (interp_ind_arity env_params evdref) indl in + + let fullarities = List.map (fun (c, _, _) -> it_mkProd_or_LetIn c ctx_params) arities in + let env_ar = push_types env0 indnames fullarities in + let env_ar_params = push_rel_context ctx_params env_ar in + + (* Compute interpretation metadatas *) + let indimpls = List.map (fun (_, _, impls) -> userimpls @ + 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 + + let constructors = + Metasyntax.with_syntax_protection (fun () -> + (* Temporary declaration of notations and scopes *) + List.iter (Metasyntax.set_notation_for_interpretation impls) notations; + (* Interpret the constructor types *) + List.map3 (interp_cstrs env_ar_params evdref impls) mldatas arities indl) + () in + + (* Try further to solve evars, and instantiate them *) + let sigma = solve_remaining_evars all_and_fail_flags env_params !evdref (Evd.empty,!evdref) in + evdref := sigma; + (* Compute renewed arities *) + let nf,_ = e_nf_evars_and_universes evdref 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 _ = List.iter2 (fun ty poly -> make_conclusion_flexible evdref ty poly) arities aritypoly in + let arities = inductive_levels env_ar_params evdref poly arities constructors in + let nf',_ = e_nf_evars_and_universes evdref in + 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 = 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; + 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; + + (* Build the inductive entries *) + let entries = List.map4 (fun ind arity template (cnames,ctypes,cimpls) -> { + mind_entry_typename = ind.ind_name; + mind_entry_arity = arity; + mind_entry_template = template; + mind_entry_consnames = cnames; + mind_entry_lc = ctypes + }) indl arities aritypoly constructors in + let impls = + 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 + in + (* Build the mutual inductive entry *) + { mind_entry_params = List.map prepare_param ctx_params; + mind_entry_record = None; + mind_entry_finite = finite; + mind_entry_inds = entries; + mind_entry_polymorphic = poly; + mind_entry_private = if prv then Some false else None; + mind_entry_universes = uctx; + }, + pl, impls + +(* Very syntactical equality *) +let eq_local_binders bl1 bl2 = + List.equal local_binder_eq bl1 bl2 + +let extract_coercions indl = + let mkqid (_,((_,id),_)) = qualid_of_ident id in + let extract lc = List.filter (fun (iscoe,_) -> iscoe) lc in + List.map mkqid (List.flatten(List.map (fun (_,_,_,lc) -> extract lc) indl)) + +let extract_params indl = + let paramsl = List.map (fun (_,params,_,_) -> params) indl in + match paramsl with + | [] -> anomaly (Pp.str "empty list of inductive types") + | params::paramsl -> + if not (List.for_all (eq_local_binders params) paramsl) then error + "Parameters should be syntactically the same for each inductive type."; + params + +let extract_inductive indl = + 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 + +let extract_mutual_inductive_declaration_components indl = + let indl,ntnl = List.split indl in + let params = extract_params indl in + let coes = extract_coercions indl in + let indl = extract_inductive indl in + (params,indl), coes, List.flatten ntnl + +let is_recursive mie = + let rec is_recursive_constructor lift typ = + match Term.kind_of_term typ with + | Prod (_,arg,rest) -> + Termops.dependent (mkRel lift) arg || + is_recursive_constructor (lift+1) rest + | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest + | _ -> false + in + match mie.mind_entry_inds with + | [ind] -> + let nparams = List.length mie.mind_entry_params in + List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc + | _ -> false + +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 + | BiFinite when is_recursive mie -> + if Option.has_some mie.mind_entry_record then + error "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command." + else + error ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.") + | _ -> () + end; + let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in + 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 + 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 Feedback.msg_info (minductive_message warn_prim names); + if mie.mind_entry_private == None + then declare_default_schemes mind; + mind + +type one_inductive_impls = + Impargs.manual_explicitation list (* for inds *)* + Impargs.manual_explicitation list list (* for constrs *) + +let do_mutual_inductive indl poly prv finite = + let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in + (* Interpret the types *) + 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 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; + (* If positivity is assumed declares itself as unsafe. *) + if Environ.deactivated_guard (Global.env ()) then Feedback.feedback Feedback.AddedAxiom else () + +(* 3c| Fixpoints and co-fixpoints *) + +(* An (unoptimized) function that maps preorders to partial orders... + + Input: a list of associations (x,[y1;...;yn]), all yi distincts + and different of x, meaning x<=y1, ..., x<=yn + + Output: a list of associations (x,Inr [y1;...;yn]), collecting all + distincts yi greater than x, _or_, (x, Inl y) meaning that + x is in the same class as y (in which case, x occurs + nowhere else in the association map) + + partial_order : ('a * 'a list) list -> ('a * ('a,'a list) union) list +*) + +let rec partial_order cmp = function + | [] -> [] + | (x,xge)::rest -> + let rec browse res xge' = function + | [] -> + let res = List.map (function + | (z, Inr zge) when List.mem_f cmp x zge -> + (z, Inr (List.union cmp zge xge')) + | r -> r) res in + (x,Inr xge')::res + | y::xge -> + let rec link y = + try match List.assoc_f cmp y res with + | Inl z -> link z + | Inr yge -> + if List.mem_f cmp x yge then + let res = List.remove_assoc_f cmp y res in + let res = List.map (function + | (z, Inl t) -> + if cmp t y then (z, Inl x) else (z, Inl t) + | (z, Inr zge) -> + if List.mem_f cmp y zge then + (z, Inr (List.add_set cmp x (List.remove cmp y zge))) + else + (z, Inr zge)) res in + browse ((y,Inl x)::res) xge' (List.union cmp xge (List.remove cmp x yge)) + else + browse res (List.add_set cmp y (List.union cmp xge' yge)) xge + with Not_found -> browse res (List.add_set cmp y xge') xge + in link y + in browse (partial_order cmp rest) [] xge + +let non_full_mutual_message x xge y yge isfix rest = + let reason = + if Id.List.mem x yge then + pr_id y ++ str " depends on " ++ pr_id x ++ strbrk " but not conversely" + else if Id.List.mem y xge then + pr_id x ++ str " depends on " ++ pr_id y ++ strbrk " but not conversely" + else + pr_id y ++ str " and " ++ pr_id x ++ strbrk " are not mutually dependent" in + let e = if List.is_empty rest then reason else strbrk "e.g., " ++ reason in + let k = if isfix then "fixpoint" else "cofixpoint" in + let w = + if isfix + then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl() + else mt () in + strbrk "Not a fully mutually defined " ++ str k ++ fnl () ++ + str "(" ++ e ++ str ")." ++ fnl () ++ w + +let warn_non_full_mutual = + CWarnings.create ~name:"non-full-mutual" ~category:"fixpoints" + (fun (x,xge,y,yge,isfix,rest) -> + non_full_mutual_message x xge y yge isfix rest) + +let check_mutuality env isfix fixl = + let names = List.map fst fixl in + let preorder = + List.map (fun (id,def) -> + (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env id' def) names)) + fixl in + let po = partial_order Id.equal preorder in + match List.filter (function (_,Inr _) -> true | _ -> false) po with + | (x,Inr xge)::(y,Inr yge)::rest -> + warn_non_full_mutual (x,xge,y,yge,isfix,rest) + | _ -> () + +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; + fix_type : constr_expr +} + +let interp_fix_context env evdref isfix fix = + let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in + let impl_env, ((env', ctx), imps) = interp_context_evars env evdref before in + let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env ~shift:(List.length before) env' evdref after in + let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in + ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) + +let interp_fix_ccl evdref impls (env,_) fix = + interp_type_evars_impls ~impls env evdref fix.fix_type + +let interp_fix_body env_rec evdref impls (_,ctx) fix ccl = + Option.map (fun body -> + let env = push_rel_context ctx env_rec in + let body = interp_casted_constr_evars env evdref ~impls body ccl in + it_mkLambda_or_LetIn body ctx) fix.fix_body + +let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx + +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 pl imps (Lemmas.mk_hook (fun _ r -> r)) + +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 + let names = List.map (fun id -> Name id) fixnames in + (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) + +(* Jump over let-bindings. *) + +let compute_possible_guardness_evidences (ids,_,na) = + match na with + | Some i -> [i] + | None -> + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual + fixpoints ?) *) + List.interval 0 (List.length ids - 1) + +type recursive_preentry = + Id.t list * constr option list * types list + +(* Wellfounded definition *) + +open Coqlib + +let contrib_name = "Program" +let subtac_dir = [contrib_name] +let fixsub_module = subtac_dir @ ["Wf"] +let tactics_module = subtac_dir @ ["Tactics"] + +let init_reference dir s () = Coqlib.gen_reference "Command" dir s +let init_constant dir s () = Coqlib.gen_constant "Command" dir s +let make_ref l s = init_reference l s +let fix_proto = init_constant tactics_module "fix_proto" +let fix_sub_ref = make_ref fixsub_module "Fix_sub" +let measure_on_R_ref = make_ref fixsub_module "MR" +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.from_fun build_sigma_type + +let make_qref s = Qualid (Loc.ghost, qualid_of_string s) +let lt_ref = make_qref "Init.Peano.lt" + +let rec telescope = function + | [] -> assert false + | [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)) decl -> + let t = RelDecl.get_type decl in + let pred = mkLambda (RelDecl.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 + let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in + (sigty, pred :: tys, (succ k, intro))) + (t, [], (2, mkRel 1)) tl + in + let (last, subst) = List.fold_right2 + (fun pred decl (prev, subst) -> + let t = RelDecl.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, LocalDef (get_name decl, proj1, t) :: subst)) + (List.rev tys) tl (mkRel 1, []) + in ty, (LocalDef (n, last, t) :: subst), constr + + | 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 (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"]; + let env = Global.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 + let top_arity = interp_type_evars top_env evdref arityc in + 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 = 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 + let relty = Typing.unsafe_type_of env !evdref rel in + let relargty = + let error () = + user_err ~loc:(constr_loc r) + ~hdr:"Command.build_wellfounded" + (Printer.pr_constr_env env !evdref rel ++ str " is not an homogeneous binary relation.") + in + try + let ctx, ar = Reductionops.splay_prod_n env !evdref 2 relty in + match ctx, kind_of_term ar with + | [LocalAssum (_,t); LocalAssum (_,u)], Sort (Prop Null) + when Reductionops.is_conv env !evdref t u -> t + | _, _ -> error () + with e when CErrors.noncritical e -> error () + in + let measure = interp_casted_constr_evars binders_env evdref measure relargty in + let wf_rel, wf_rel_fun, measure_fn = + let measure_body, measure = + it_mkLambda_or_LetIn measure letbinders, + it_mkLambda_or_LetIn measure binders + in + let comb = Universes.constr_of_global (delayed_force measure_on_R_ref) in + let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in + let wf_rel_fun x y = + mkApp (rel, [| subst1 x measure_body; + subst1 y measure_body |]) + in wf_rel, wf_rel_fun, measure + 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 = 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 + let proj = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.proj1 in + let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in + let projection = (* in wfarg :: arg :: before *) + mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) + in + let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in + let intern_arity = substl [projection] top_arity_let in + (* 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 = 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 = 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 + 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 = 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 + in + let newimpls = Id.Map.singleton recname + (r, l, impls @ [(Some (Id.of_string "recproof", Impargs.Manual, (true, false)))], + scopes @ [None]) in + interp_casted_constr_evars (push_rel_context ctx env) evdref + ~impls:newimpls body (lift 1 top_arity) + in + let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in + let prop = mkLambda (Name argname, argtyp, top_arity_let) in + let def = + mkApp (Universes.constr_of_global (delayed_force fix_sub_ref), + [| argtyp ; wf_rel ; + Evarutil.e_new_evar env evdref + ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof; + prop |]) + 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 + let binders = nf_evar_context !evdref binders in + let top_arity = Evarutil.nf_evar !evdref top_arity in + let hook, recname, typ = + if List.length binders_rel > 1 then + let name = add_suffix recname "_func" in + 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 ?names:pl !evdref in + (*FIXME poly? *) + 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 + if Impargs.is_implicit_args () || not (List.is_empty impls) then + Impargs.declare_manual_implicits false gr [impls] + in + let typ = it_mkProd_or_LetIn top_arity binders in + hook, name, typ + else + let typ = it_mkProd_or_LetIn top_arity binders_rel in + 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 + in + let hook = Lemmas.mk_hook hook in + let fullcoqc = Evarutil.nf_evar !evdref def in + let fullctyp = Evarutil.nf_evar !evdref typ in + Obligations.check_evars env !evdref; + let evars, _, evars_def, evars_typ = + 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 ?pl + 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 + + (* Interp arities allowing for unresolved types *) + 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 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 + let fixccls,fixcclimps = List.split (List.map3 (interp_fix_ccl evdref) fixctximpenvs fixctxs fixl) in + let fixtypes = List.map2 build_fix_type fixctxs fixccls in + let fixtypes = List.map (nf_evar !evdref) fixtypes in + let fiximps = List.map3 + (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (List.length ctx) cclimps)) + fixctximps fixcclimps fixctxs in + let rec_sign = + List.fold_left2 + (fun env' id t -> + if Flags.is_program_mode () then + let sort = Evarutil.evd_comb1 (Typing.type_of ~refresh:true env) evdref t in + let fixprot = + try + let app = mkApp (delayed_force fix_proto, [|sort; t|]) in + Typing.e_solve_evars env evdref app + with e when CErrors.noncritical e -> t + in + LocalAssum (id,fixprot) :: env' + else LocalAssum (id,t) :: env') + [] fixnames fixtypes + in + let env_rec = push_named_context rec_sign env in + + (* Get interpretation metadatas *) + let impls = compute_internalization_env env Recursive fixnames fixtypes fiximps in + + (* Interp bodies with rollback because temp use of notations/implicit *) + let fixdefs = + Metasyntax.with_syntax_protection (fun () -> + List.iter (Metasyntax.set_notation_for_interpretation impls) notations; + List.map4 + (fun fixctximpenv -> interp_fix_body env_rec evdref (Id.Map.fold Id.Map.add fixctximpenv impls)) + fixctximpenvs fixctxs fixl fixccls) + () in + + (* Instantiate evars and check all are resolved *) + let evd = solve_unif_constraints_with_heuristics env_rec !evdref in + 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 RelDecl.get_name ctx) fixctxs in + + (* Build the fix declaration block *) + (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); + if List.for_all Option.has_some fixdefs then begin + let fixdefs = List.map Option.get fixdefs in + check_mutuality env isfix (List.combine fixnames fixdefs) + end + +let interp_fixpoint l ntns = + let (env,_,pl,evd),fix,info = interp_recursive true l ntns in + check_recursive true env evd fix; + (fix,pl,Evd.evar_universe_context evd,info) + +let interp_cofixpoint l ntns = + let (env,_,pl,evd),fix,info = interp_recursive false l ntns in + check_recursive false env evd fix; + (fix,pl,Evd.evar_universe_context evd,info) + +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 = + 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 + let init_tac = + Option.map (List.map Proofview.V82.tactic) init_tac + 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 + (* We shortcut the proof process *) + let fixdefs = List.map Option.get fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in + let env = Global.env() in + let indexes = search_guard Loc.ghost env indexes fixdecls in + let fiximps = List.map (fun (n,r,p) -> r) fiximps in + 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 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 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; + end; + (* Declare notations *) + List.iter Metasyntax.add_notation_interpretation 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 = + 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 + let init_tac = + Option.map (List.map Proofview.V82.tactic) init_tac + in + 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 *) + 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 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 + 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 + end; + (* Declare notations *) + List.iter Metasyntax.add_notation_interpretation ntns + +let extract_decreasing_argument limit = function + | (na,CStructRec) -> na + | (na,_) when not limit -> na + | _ -> error + "Only structural decreasing is supported for a non-Program Fixpoint" + +let extract_fixpoint_components limit l = + let fixl, ntnl = List.split l in + 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_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),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 + | Some def -> def + | None -> error "Program Fixpoint needs defined bodies." + +let collect_evars_of_term evd c ty = + let evars = Evar.Set.union (Evd.evars_of_term c) (Evd.evars_of_term ty) in + Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) + evars (Evd.from_ctx (Evd.evar_universe_context evd)) + +let do_program_recursive local p fixkind fixl ntns = + let isfix = fixkind != Obligations.IsCoFixpoint in + let (env, rec_sign, pl, evd), fix, info = + interp_recursive isfix fixl ntns + in + (* Program-specific code *) + (* Get the interesting evars, those that were not instanciated *) + let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in + (* Solve remaining evars *) + let evd = nf_evar_map_undefined evd in + let collect_evars id def typ imps = + (* Generalize by the recursive prototypes *) + let def = + nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) + and typ = + nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) + in + let evm = collect_evars_of_term evd def typ in + let evars, _, def, typ = + Obligations.eterm_obligations env id evm + (List.length rec_sign) def typ + in (id, def, typ, imps, evars) + in + let (fixnames,fixdefs,fixtypes) = fix in + let fiximps = List.map pi2 info in + let fixdefs = List.map out_def fixdefs in + let defs = List.map4 collect_evars fixnames fixdefs fixtypes fiximps in + let () = if isfix then begin + let possible_indexes = List.map compute_possible_guardness_evidences info in + let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), + Array.of_list fixtypes, + Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) + in + let indexes = + Pretyping.search_guard + Loc.ghost (Global.env ()) possible_indexes fixdecls in + List.iteri (fun i _ -> + Inductive.check_fix env + ((indexes,i),fixdecls)) + fixl + end in + let ctx = Evd.evar_universe_context evd in + let kind = match fixkind with + | Obligations.IsFixpoint _ -> (local, p, Fixpoint) + | Obligations.IsCoFixpoint -> (local, p, CoFixpoint) + in + 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),pl),_,bl,typ,def),ntn)] -> + let recarg = + match n with + | Some n -> mkIdentC (snd n) + | None -> + user_err ~hdr:"do_program_fixpoint" + (str "Recursive argument required for well-founded fixpoints") + in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn + + | [(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 -> + let fixl,ntns = extract_fixpoint_components true l in + let fixkind = Obligations.IsFixpoint g in + do_program_recursive local poly fixkind fixl ntns + + | _, _ -> + user_err ~hdr:"do_program_fixpoint" + (str "Well-founded fixpoints not allowed in mutually recursive blocks") + +let check_safe () = + let open Declarations in + let flags = Environ.typing_flags (Global.env ()) in + flags.check_universes && flags.check_guarded + +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 (_, _, _, info as fix) = interp_fixpoint fixl ntns in + let possible_indexes = + List.map compute_possible_guardness_evidences info in + declare_fixpoint local poly fix possible_indexes ntns; + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + +let do_cofixpoint local poly l = + let fixl,ntns = extract_cofixpoint_components l in + if Flags.is_program_mode () then + do_program_recursive local poly Obligations.IsCoFixpoint fixl ntns + else + let cofix = interp_cofixpoint fixl ntns in + declare_cofixpoint local poly cofix ntns; + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/vernac/command.mli b/vernac/command.mli new file mode 100644 index 0000000000..616afb91f0 --- /dev/null +++ b/vernac/command.mli @@ -0,0 +1,176 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Id.t Loc.located list -> unit +val do_constraint : polymorphic -> + (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> unit + +(** {6 Hooks for Pcoq} *) + +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 -> 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 -> 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 -> + local_binder list -> red_expr option -> constr_expr -> + constr_expr option -> unit Lemmas.declaration_hook -> unit + +(** {6 Parameters/Assumptions} *) + +(* val interp_assumption : env -> evar_map ref -> *) +(* local_binder list -> constr_expr -> *) +(* types Univ.in_universe_context_set * Impargs.manual_implicits *) + +(** returns [false] if the assumption is neither local to a section, + nor in a module type and meant to be instantiated. *) +val declare_assumption : coercion_flag -> assumption_kind -> + types Univ.in_universe_context_set -> + Universes.universe_binders -> Impargs.manual_implicits -> + bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located -> + global_reference * Univ.Instance.t * bool + +val do_assumptions : locality * polymorphic * assumption_object_kind -> + 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 -> *) +(* Impargs.manual_implicits -> bool -> Vernacexpr.inline -> bool *) + +(** {6 Inductive and coinductive types} *) + +(** Extracting the semantical components out of the raw syntax of mutual + inductive declarations *) + +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 +} + +type structured_inductive_expr = + local_binder list * structured_one_inductive_expr list + +val extract_mutual_inductive_declaration_components : + (one_inductive_expr * decl_notation list) list -> + structured_inductive_expr * (*coercions:*) qualid list * decl_notation list + +(** Typing mutual inductive definitions *) + +type one_inductive_impls = + Impargs.manual_implicits (** for inds *)* + Impargs.manual_implicits list (** for constrs *) + +val interp_mutual_inductive : + structured_inductive_expr -> decl_notation list -> polymorphic -> + private_flag -> Decl_kinds.recursivity_kind -> + 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 -> Universes.universe_binders -> one_inductive_impls list -> + mutual_inductive + +(** Entry points for the vernacular commands Inductive and CoInductive *) + +val do_mutual_inductive : + (one_inductive_expr * decl_notation list) list -> polymorphic -> + private_flag -> Decl_kinds.recursivity_kind -> unit + +(** {6 Fixpoints and cofixpoints} *) + +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; + fix_type : constr_expr +} + +(** Extracting the semantical components out of the raw syntax of + (co)fixpoints declarations *) + +val extract_fixpoint_components : bool -> + (fixpoint_expr * decl_notation list) list -> + structured_fixpoint_expr list * decl_notation list + +val extract_cofixpoint_components : + (cofixpoint_expr * decl_notation list) list -> + structured_fixpoint_expr list * decl_notation list + +(** Typing global fixpoints and cofixpoint_expr *) + +type recursive_preentry = + Id.t list * constr option list * types list + +val interp_fixpoint : + structured_fixpoint_expr list -> decl_notation list -> + 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 * 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 * 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 * lident list option * Evd.evar_universe_context * + (Name.t list * Impargs.manual_implicits * int option) list -> + decl_notation list -> unit + +(** Entry points for the vernacular commands Fixpoint and CoFixpoint *) + +val do_fixpoint : + (* When [false], assume guarded. *) + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit + +val do_cofixpoint : + (* When [false], assume guarded. *) + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit + +(** Utils *) + +val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit + +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/vernac/discharge.ml b/vernac/discharge.ml new file mode 100644 index 0000000000..e24d5e74fb --- /dev/null +++ b/vernac/discharge.ml @@ -0,0 +1,120 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* id, LocalAssumEntry p + | LocalDef (Name id, p,_) -> id, LocalDefEntry p + | _ -> anomaly (Pp.str "Unnamed inductive local variable") + +(* Replace + + Var(y1)..Var(yq):C1..Cq |- Ij:Bj + Var(y1)..Var(yq):C1..Cq; I1..Ip:B1..Bp |- ci : Ti + + by + + |- Ij: (y1..yq:C1..Cq)Bj + I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)] +*) + +let abstract_inductive hyps nparams inds = + let ntyp = List.length inds 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' = + List.map + (function (tname,arity,template,cnames,lc) -> + let lc' = List.map (substl subs) lc in + let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in + let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in + (tname,arity',template,cnames,lc'')) + inds in + let nparams' = nparams + Array.length args in +(* 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 + in + let ind'' = + List.map + (fun (a,arity,template,c,lc) -> + let _, short_arity = decompose_prod_n_assum nparams' arity in + let shortlc = + List.map (fun c -> snd (decompose_prod_n_assum nparams' c)) lc in + { mind_entry_typename = a; + mind_entry_arity = short_arity; + mind_entry_template = template; + mind_entry_consnames = c; + mind_entry_lc = shortlc }) + inds' + in (params',ind'') + +let refresh_polymorphic_type_of_inductive (_,mip) = + match mip.mind_arity with + | RegularArity s -> s.mind_user_arity, false + | TemplateArity ar -> + let ctx = List.rev mip.mind_arity_ctxt in + mkArity (List.rev ctx, Type ar.template_level), true + +let process_inductive (sechyps,abs_ctx) modlist mib = + let nparams = mib.mind_nparams in + let subst, univs = + if mib.mind_polymorphic then + let inst = Univ.UContext.instance mib.mind_universes in + let cstrs = Univ.UContext.constraints mib.mind_universes in + inst, Univ.UContext.make (inst, Univ.subst_instance_constraints inst cstrs) + else Univ.Instance.empty, mib.mind_universes + in + let inds = + Array.map_to_list + (fun mip -> + let ty, template = refresh_polymorphic_type_of_inductive (mib,mip) in + let arity = expmod_constr modlist ty in + let arity = Vars.subst_instance_constr subst arity in + let lc = Array.map + (fun c -> Vars.subst_instance_constr subst (expmod_constr modlist c)) + mip.mind_user_lc + in + (mip.mind_typename, + arity, template, + Array.to_list mip.mind_consnames, + Array.to_list lc)) + mib.mind_packets 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 + let record = match mib.mind_record with + | Some (Some (id, _, _)) -> Some (Some id) + | Some None -> Some None + | None -> None + in + { mind_entry_record = record; + mind_entry_finite = mib.mind_finite; + mind_entry_params = params'; + mind_entry_inds = inds'; + mind_entry_polymorphic = mib.mind_polymorphic; + mind_entry_private = mib.mind_private; + mind_entry_universes = univs; + } diff --git a/vernac/discharge.mli b/vernac/discharge.mli new file mode 100644 index 0000000000..18d1b67766 --- /dev/null +++ b/vernac/discharge.mli @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* work_list -> mutual_inductive_body -> mutual_inductive_entry diff --git a/vernac/doc.tex b/vernac/doc.tex new file mode 100644 index 0000000000..f2550fda11 --- /dev/null +++ b/vernac/doc.tex @@ -0,0 +1,10 @@ + +\newpage +\section*{The Coq toplevel} + +\ocwsection \label{toplevel} +This chapter describes the highest modules of the \Coq\ system. +They are organized as follows: + +\bigskip +\begin{center}\epsfig{file=toplevel.dep.ps,width=\linewidth}\end{center} diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml new file mode 100644 index 0000000000..17897460c0 --- /dev/null +++ b/vernac/explainErr.ml @@ -0,0 +1,129 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* hov 0 (str "Syntax error: " ++ str txt ++ str ".") + | Compat.Token.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") + | CLexer.Error.E err -> hov 0 (str (CLexer.Error.to_string err)) + | Sys_error msg -> hov 0 (str "System error: " ++ guill msg) + | Out_of_memory -> hov 0 (str "Out of memory.") + | Stack_overflow -> hov 0 (str "Stack overflow.") + | Timeout -> hov 0 (str "Timeout!") + | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") + (* Exceptions with pre-evaluated error messages *) + | EvaluatedError (msg,None) -> msg + | EvaluatedError (msg,Some reraise) -> msg ++ CErrors.print reraise + (* Otherwise, not handled here *) + | _ -> raise CErrors.Unhandled + +let _ = CErrors.register_handler explain_exn_default + + +(** Pre-explain a vernac interpretation error *) + +let wrap_vernac_error with_header (exn, info) strm = + if with_header then + let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in + let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in + (e, info) + else + (EvaluatedError (strm, None), info) + +let process_vernac_interp_error with_header exn = match fst exn with + | Univ.UniverseInconsistency i -> + let msg = + if !Constrextern.print_universes then + str "." ++ spc() ++ + Univ.explain_universe_inconsistency Universes.pr_with_global_universes i + else + mt() in + wrap_vernac_error with_header exn (str "Universe inconsistency" ++ msg ++ str ".") + | TypeError(ctx,te) -> + wrap_vernac_error with_header exn (Himsg.explain_type_error ctx Evd.empty te) + | PretypeError(ctx,sigma,te) -> + wrap_vernac_error with_header exn (Himsg.explain_pretype_error ctx sigma te) + | Typeclasses_errors.TypeClassError(env, te) -> + wrap_vernac_error with_header exn (Himsg.explain_typeclass_error env te) + | InductiveError e -> + wrap_vernac_error with_header exn (Himsg.explain_inductive_error e) + | Modops.ModuleTypingError e -> + wrap_vernac_error with_header exn (Himsg.explain_module_error e) + | Modintern.ModuleInternalizationError e -> + wrap_vernac_error with_header exn (Himsg.explain_module_internalization_error e) + | RecursionSchemeError e -> + wrap_vernac_error with_header exn (Himsg.explain_recursion_scheme_error e) + | Cases.PatternMatchingError (env,sigma,e) -> + wrap_vernac_error with_header exn (Himsg.explain_pattern_matching_error env sigma e) + | Tacred.ReductionTacticError e -> + wrap_vernac_error with_header exn (Himsg.explain_reduction_tactic_error e) + | Logic.RefinerError e -> + wrap_vernac_error with_header exn (Himsg.explain_refiner_error e) + | Nametab.GlobalizationError q -> + wrap_vernac_error with_header exn + (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ + spc () ++ str "was not found" ++ + spc () ++ str "in the current" ++ spc () ++ str "environment.") + | Refiner.FailError (i,s) -> + let s = Lazy.force s in + wrap_vernac_error with_header exn + (str "Tactic failure" ++ + (if Pp.is_empty s then s else str ": " ++ s) ++ + if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").") + | AlreadyDeclared msg -> + wrap_vernac_error with_header exn (msg ++ str ".") + | _ -> + exn + +let rec strip_wrapping_exceptions = function + | Logic_monad.TacticFailure e -> + 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 + let () = + if not allow_uncaught && not (CErrors.handled (fst e)) then + let (e, info) = e in + let msg = str "Uncaught exception " ++ str (Printexc.to_string e) in + let err = CErrors.make_anomaly msg in + Util.iraise (err, info) + in + let e' = + try Some (CList.find_map (fun f -> f e) !additional_error_info) + with _ -> None + in + match e' with + | None -> e + | 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/vernac/explainErr.mli b/vernac/explainErr.mli new file mode 100644 index 0000000000..a67c887af3 --- /dev/null +++ b/vernac/explainErr.mli @@ -0,0 +1,21 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ?with_header:bool -> Util.iexn -> Util.iexn + +(** General explain function. Should not be used directly now, + see instead function [Errors.print] and variants *) + +val explain_exn_default : exn -> Pp.std_ppcmds + +val register_additional_error_info : (Util.iexn -> (Pp.std_ppcmds option * Loc.t) option) -> unit diff --git a/vernac/himsg.ml b/vernac/himsg.ml new file mode 100644 index 0000000000..6cff805fc2 --- /dev/null +++ b/vernac/himsg.ml @@ -0,0 +1,1268 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + l := (Vars.substl !l c') :: !l; + env + | _ -> + let t = Vars.substl !l (RelDecl.get_type decl) in + let decl = decl |> RelDecl.map_name (named_hd env t) |> RelDecl.map_value (Vars.substl !l) |> RelDecl.set_type t in + l := (mkRel 1) :: List.map (Vars.lift 1) !l; + push_rel decl env + in + let env = process_rel_context contract_context env in + (env, List.map (Vars.substl !l) lc) + +let contract2 env a b = match contract env [a;b] with + | env, [a;b] -> env,a,b | _ -> assert false + +let contract3 env a b c = match contract env [a;b;c] with + | env, [a;b;c] -> env,a,b,c | _ -> assert false + +let contract4 env a b c d = match contract env [a;b;c;d] with + | env, [a;b;c;d] -> (env,a,b,c),d | _ -> assert false + +let contract1_vect env a v = + match contract env (a :: Array.to_list v) with + | env, a::l -> env,a,Array.of_list l + | _ -> assert false + +let rec contract3' env a b c = function + | OccurCheck (evk,d) -> let x,d = contract4 env a b c d in x,OccurCheck(evk,d) + | NotClean ((evk,args),env',d) -> + let env',d,args = contract1_vect env' d args in + contract3 env a b c,NotClean((evk,args),env',d) + | ConversionFailed (env',t1,t2) -> + let (env',t1,t2) = contract2 env' t1 t2 in + contract3 env a b c, ConversionFailed (env',t1,t2) + | NotSameArgSize | NotSameHead | NoCanonicalStructure + | MetaOccurInBody _ | InstanceNotSameType _ | ProblemBeyondCapabilities + | UnifUnivInconsistency _ as x -> contract3 env a b c, x + | CannotSolveConstraint ((pb,env',t,u),x) -> + let env',t,u = contract2 env' t u in + 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) +let pr_lconstr_env e s c = quote (pr_lconstr_env e s c) +let pr_ljudge_env e s c = let v,t = pr_ljudge_env e s c in (quote v,quote t) + +(** A canonisation procedure for constr such that comparing there + externalisation catches more equalities *) +let canonize_constr c = + (* replaces all the names in binders by [dn] ("default name"), + ensures that [alpha]-equivalent terms will have the same + externalisation. *) + let dn = Name.Anonymous in + let rec canonize_binders c = + match Term.kind_of_term c with + | Prod (_,t,b) -> mkProd(dn,t,b) + | Lambda (_,t,b) -> mkLambda(dn,t,b) + | LetIn (_,u,t,b) -> mkLetIn(dn,u,t,b) + | _ -> Term.map_constr canonize_binders c + in + canonize_binders c + +(** Tries to realize when the two terms, albeit different are printed the same. *) +let display_eq ~flags env sigma t1 t2 = + (* terms are canonized, then their externalisation is compared syntactically *) + let open Constrextern in + let t1 = canonize_constr t1 in + let t2 = canonize_constr t2 in + let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) () in + let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) () in + Constrexpr_ops.constr_expr_eq ct1 ct2 + +(** This function adds some explicit printing flags if the two arguments are + printed alike. *) +let rec pr_explicit_aux env sigma t1 t2 = function +| [] -> + (** no specified flags: default. *) + (quote (Printer.pr_lconstr_env env sigma t1), quote (Printer.pr_lconstr_env env sigma t2)) +| flags :: rem -> + let equal = display_eq ~flags env sigma t1 t2 in + if equal then + (** The two terms are the same from the user point of view *) + pr_explicit_aux env sigma t1 t2 rem + else + let open Constrextern in + let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) () + in + let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) () + in + quote (Ppconstr.pr_lconstr_expr ct1), quote (Ppconstr.pr_lconstr_expr ct2) + +let explicit_flags = + let open Constrextern in + [ []; (** First, try with the current flags *) + [print_implicits]; (** Then with implicit *) + [print_universes]; (** Then with universes *) + [print_universes; print_implicits]; (** With universes AND implicits *) + [print_implicits; print_coercions; print_no_symbol]; (** Then more! *) + [print_universes; print_implicits; print_coercions; print_no_symbol] (** and more! *) ] + +let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags + +let pr_db env i = + try + match env |> lookup_rel i |> 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 = + let pe = pr_ne_context_of (str "In environment") env sigma in + str "Unbound reference: " ++ pe ++ + str "The reference " ++ int n ++ str " is free." + +let explain_unbound_var env v = + let var = pr_id v in + str "No such section variable or assumption: " ++ var ++ str "." + +let explain_not_type env sigma j = + let j = Evarutil.j_nf_evar sigma j in + let pe = pr_ne_context_of (str "In environment") env sigma in + let pc,pt = pr_ljudge_env env sigma j in + pe ++ str "The term" ++ brk(1,1) ++ pc ++ spc () ++ + str "has type" ++ spc () ++ pt ++ spc () ++ + str "which should be Set, Prop or Type." + +let explain_bad_assumption env sigma j = + let pe = pr_ne_context_of (str "In environment") env sigma in + let pc,pt = pr_ljudge_env env sigma j in + pe ++ str "Cannot declare a variable or hypothesis over the term" ++ + brk(1,1) ++ pc ++ spc () ++ str "of type" ++ spc () ++ pt ++ spc () ++ + str "because this term is not a type." + +let explain_reference_variables id c = + (* c is intended to be a global reference *) + let pc = pr_global (Globnames.global_of_constr c) in + pc ++ strbrk " depends on the variable " ++ pr_id id ++ + strbrk " which is not declared in the context." + +let rec pr_disjunction pr = function + | [a] -> pr a + | [a;b] -> pr a ++ str " or" ++ spc () ++ pr b + | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l + | [] -> assert false + +let pr_puniverses f env (c,u) = + f env c ++ + (if Flags.is_universe_polymorphism () && not (Univ.Instance.is_empty u) then + str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)" + else mt()) + +let explain_elim_arity env sigma ind sorts c pj okinds = + let env = make_all_name_different env in + let pi = pr_inductive env (fst ind) in + let pc = pr_lconstr_env env sigma c in + let msg = match okinds with + | Some(kp,ki,explanation) -> + let pki = pr_sort_family ki in + let pkp = pr_sort_family kp in + let explanation = match explanation with + | NonInformativeToInformative -> + "proofs can be eliminated only to build proofs" + | StrongEliminationOnNonSmallType -> + "strong elimination on non-small inductive types leads to paradoxes" + | WrongArity -> + "wrong arity" in + let ppar = pr_disjunction (fun s -> quote (pr_sort_family s)) sorts in + let ppt = pr_lconstr_env env sigma ((strip_prod_assum pj.uj_type)) in + hov 0 + (str "the return type has sort" ++ spc () ++ ppt ++ spc () ++ + str "while it" ++ spc () ++ str "should be " ++ ppar ++ str ".") ++ + fnl () ++ + hov 0 + (str "Elimination of an inductive object of sort " ++ + pki ++ brk(1,0) ++ + str "is not allowed on a predicate in sort " ++ pkp ++ fnl () ++ + str "because" ++ spc () ++ str explanation ++ str ".") + | None -> + str "ill-formed elimination predicate." + in + hov 0 ( + str "Incorrect elimination of" ++ spc () ++ pc ++ spc () ++ + str "in the inductive type" ++ spc () ++ quote pi ++ str ":") ++ + fnl () ++ msg + +let explain_case_not_inductive env sigma cj = + let cj = Evarutil.j_nf_evar sigma cj in + let env = make_all_name_different env in + let pc = pr_lconstr_env env sigma cj.uj_val in + let pct = pr_lconstr_env env sigma cj.uj_type in + match kind_of_term cj.uj_type with + | Evar _ -> + str "Cannot infer a type for this expression." + | _ -> + str "The term" ++ brk(1,1) ++ pc ++ spc () ++ + str "has type" ++ brk(1,1) ++ pct ++ spc () ++ + str "which is not a (co-)inductive type." + +let explain_number_branches env sigma cj expn = + let cj = Evarutil.j_nf_evar sigma cj in + let env = make_all_name_different env in + let pc = pr_lconstr_env env sigma cj.uj_val in + let pct = pr_lconstr_env env sigma cj.uj_type in + str "Matching on term" ++ brk(1,1) ++ pc ++ spc () ++ + str "of type" ++ brk(1,1) ++ pct ++ spc () ++ + str "expects " ++ int expn ++ str " branches." + +let explain_ill_formed_branch env sigma c ci actty expty = + let simp t = Reduction.nf_betaiota env (Evarutil.nf_evar sigma t) in + let c = Evarutil.nf_evar sigma c in + let env = make_all_name_different env in + let pc = pr_lconstr_env env sigma c in + let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in + strbrk "In pattern-matching on term" ++ brk(1,1) ++ pc ++ + spc () ++ strbrk "the branch for constructor" ++ spc () ++ + quote (pr_puniverses pr_constructor env ci) ++ + spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++ + str "which should be" ++ brk(1,1) ++ pe ++ str "." + +let explain_generalization env sigma (name,var) j = + let pe = pr_ne_context_of (str "In environment") env sigma in + let pv = pr_ltype_env env sigma var in + let (pc,pt) = pr_ljudge_env (push_rel_assum (name,var) env) sigma j in + pe ++ str "Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++ + str "over" ++ brk(1,1) ++ pc ++ str "," ++ spc () ++ + str "it has type" ++ spc () ++ pt ++ + spc () ++ str "which should be Set, Prop or Type." + +let explain_unification_error env sigma p1 p2 = function + | None -> mt() + | Some e -> + let rec aux p1 p2 = function + | OccurCheck (evk,rhs) -> + let rhs = Evarutil.nf_evar sigma rhs in + [str "cannot define " ++ quote (pr_existential_key sigma evk) ++ + strbrk " with term " ++ pr_lconstr_env env sigma rhs ++ + strbrk " that would depend on itself"] + | NotClean ((evk,args),env,c) -> + let c = Evarutil.nf_evar sigma c in + let args = Array.map (Evarutil.nf_evar sigma) args in + [str "cannot instantiate " ++ quote (pr_existential_key sigma evk) + ++ strbrk " because " ++ pr_lconstr_env env sigma c ++ + strbrk " is not in its scope" ++ + (if Array.is_empty args then mt() else + strbrk ": available arguments are " ++ + pr_sequence (pr_lconstr_env env sigma) (List.rev (Array.to_list args)))] + | NotSameArgSize | NotSameHead | NoCanonicalStructure -> + (* Error speaks from itself *) [] + | ConversionFailed (env,t1,t2) -> + if Term.eq_constr t1 p1 && Term.eq_constr t2 p2 then [] else + let env = make_all_name_different env in + let t1 = Evarutil.nf_evar sigma t1 in + let t2 = Evarutil.nf_evar sigma t2 in + if not (Term.eq_constr t1 p1) || not (Term.eq_constr t2 p2) then + let t1, t2 = pr_explicit env sigma t1 t2 in + [str "cannot unify " ++ t1 ++ strbrk " and " ++ t2] + else [] + | MetaOccurInBody evk -> + [str "instance for " ++ quote (pr_existential_key sigma evk) ++ + strbrk " refers to a metavariable - please report your example" ++ + strbrk "at " ++ str Coq_config.wwwbugtracker ++ str "."] + | InstanceNotSameType (evk,env,t,u) -> + let t, u = pr_explicit env sigma t u in + [str "unable to find a well-typed instantiation for " ++ + quote (pr_existential_key sigma evk) ++ + strbrk ": cannot ensure that " ++ + t ++ strbrk " is a subtype of " ++ u] + | UnifUnivInconsistency p -> + if !Constrextern.print_universes then + [str "universe inconsistency: " ++ + Univ.explain_universe_inconsistency Universes.pr_with_global_universes p] + else + [str "universe inconsistency"] + | CannotSolveConstraint ((pb,env,t,u),e) -> + let t = Evarutil.nf_evar sigma t in + let u = Evarutil.nf_evar sigma u in + let env = make_all_name_different env in + (strbrk "cannot satisfy constraint " ++ pr_lconstr_env env sigma t ++ + str " == " ++ pr_lconstr_env env sigma u) + :: aux t u e + | ProblemBeyondCapabilities -> + [] + in + match aux p1 p2 e with + | [] -> mt () + | l -> spc () ++ str "(" ++ + prlist_with_sep pr_semicolon (fun x -> x) l ++ str ")" + +let explain_actual_type env sigma j t reason = + let env = make_all_name_different env 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 + let pc = pr_lconstr_env env sigma (Environ.j_val j) in + let (pt, pct) = pr_explicit env sigma t (Environ.j_type j) in + let ppreason = explain_unification_error env sigma j.uj_type t reason in + pe ++ + hov 0 ( + str "The term" ++ brk(1,1) ++ pc ++ spc () ++ + str "has type" ++ brk(1,1) ++ pct ++ spc () ++ + str "while it is expected to have type" ++ brk(1,1) ++ pt ++ + ppreason ++ str ".") + +let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = + 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 + let env = make_all_name_different env in + let actualtyp, exptyp = pr_explicit env sigma actualtyp exptyp in + let nargs = Array.length randl in +(* let pe = pr_ne_context_of (str "in environment") env sigma in*) + let pr,prt = pr_ljudge_env env sigma rator in + let term_string1 = str (String.plural nargs "term") in + let term_string2 = + if nargs>1 then str "The " ++ pr_nth n ++ str " term" else str "This term" + in + let appl = prvect_with_sep fnl + (fun c -> + let pc,pct = pr_ljudge_env env sigma c in + hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl + in + str "Illegal application: " ++ (* pe ++ *) fnl () ++ + str "The term" ++ brk(1,1) ++ pr ++ spc () ++ + str "of type" ++ brk(1,1) ++ prt ++ spc () ++ + str "cannot be applied to the " ++ term_string1 ++ fnl () ++ + str " " ++ v 0 appl ++ fnl () ++ term_string2 ++ str " has type" ++ + brk(1,1) ++ actualtyp ++ spc () ++ + str "which should be coercible to" ++ brk(1,1) ++ + exptyp ++ str "." + +let explain_cant_apply_not_functional env sigma rator randl = + let randl = Evarutil.jv_nf_evar sigma randl in + let rator = Evarutil.j_nf_evar sigma rator in + let env = make_all_name_different env in + let nargs = Array.length randl in +(* let pe = pr_ne_context_of (str "in environment") env sigma in*) + let pr = pr_lconstr_env env sigma rator.uj_val in + let prt = pr_lconstr_env env sigma rator.uj_type in + let appl = prvect_with_sep fnl + (fun c -> + let pc = pr_lconstr_env env sigma c.uj_val in + let pct = pr_lconstr_env env sigma c.uj_type in + hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl + in + str "Illegal application (Non-functional construction): " ++ + (* pe ++ *) fnl () ++ + str "The expression" ++ brk(1,1) ++ pr ++ spc () ++ + str "of type" ++ brk(1,1) ++ prt ++ spc () ++ + str "cannot be applied to the " ++ str (String.plural nargs "term") ++ + fnl () ++ str " " ++ v 0 appl + +let explain_unexpected_type env sigma actual_type expected_type = + let actual_type = Evarutil.nf_evar sigma actual_type in + let expected_type = Evarutil.nf_evar sigma expected_type in + let pract, prexp = pr_explicit env sigma actual_type expected_type in + str "Found type" ++ spc () ++ pract ++ spc () ++ + str "where" ++ spc () ++ prexp ++ str " was expected." + +let explain_not_product env sigma c = + let c = Evarutil.nf_evar sigma c in + let pr = pr_lconstr_env env sigma c in + str "The type of this term is a product" ++ spc () ++ + str "while it is expected to be" ++ + (if is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." + +(* TODO: use the names *) +(* (co)fixpoints *) +let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = + let prt_name i = + match names.(i) with + Name id -> str "Recursive definition of " ++ pr_id id + | Anonymous -> str "The " ++ pr_nth i ++ str " definition" in + + let st = match err with + + (* Fixpoint guard errors *) + | NotEnoughAbstractionInFixBody -> + str "Not enough abstractions in the definition" + | RecursionNotOnInductiveType c -> + str "Recursive definition on" ++ spc () ++ pr_lconstr_env env sigma c ++ + spc () ++ str "which should be an inductive type" + | RecursionOnIllegalTerm(j,(arg_env, arg),le,lt) -> + let arg_env = make_all_name_different arg_env in + let called = + match names.(j) with + Name id -> pr_id id + | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in + let pr_db x = quote (pr_db env x) in + let vars = + match (lt,le) with + ([],[]) -> assert false + | ([],[x]) -> str "a subterm of " ++ pr_db x + | ([],_) -> str "a subterm of the following variables: " ++ + pr_sequence pr_db le + | ([x],_) -> pr_db x + | _ -> + str "one of the following variables: " ++ + pr_sequence pr_db lt in + str "Recursive call to " ++ called ++ spc () ++ + strbrk "has principal argument equal to" ++ spc () ++ + pr_lconstr_env arg_env sigma arg ++ strbrk " instead of " ++ vars + + | NotEnoughArgumentsForFixCall j -> + let called = + match names.(j) with + Name id -> pr_id id + | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in + str "Recursive call to " ++ called ++ str " has not enough arguments" + + (* CoFixpoint guard errors *) + | CodomainNotInductiveType c -> + str "The codomain is" ++ spc () ++ pr_lconstr_env env sigma c ++ spc () ++ + str "which should be a coinductive type" + | NestedRecursiveOccurrences -> + str "Nested recursive occurrences" + | UnguardedRecursiveCall c -> + str "Unguarded recursive call in" ++ spc () ++ pr_lconstr_env env sigma c + | RecCallInTypeOfAbstraction c -> + str "Recursive call forbidden in the domain of an abstraction:" ++ + spc () ++ pr_lconstr_env env sigma c + | RecCallInNonRecArgOfConstructor c -> + str "Recursive call on a non-recursive argument of constructor" ++ + spc () ++ pr_lconstr_env env sigma c + | RecCallInTypeOfDef c -> + str "Recursive call forbidden in the type of a recursive definition" ++ + spc () ++ pr_lconstr_env env sigma c + | RecCallInCaseFun c -> + str "Invalid recursive call in a branch of" ++ + spc () ++ pr_lconstr_env env sigma c + | RecCallInCaseArg c -> + str "Invalid recursive call in the argument of \"match\" in" ++ spc () ++ + pr_lconstr_env env sigma c + | RecCallInCasePred c -> + str "Invalid recursive call in the \"return\" clause of \"match\" in" ++ + spc () ++ pr_lconstr_env env sigma c + | NotGuardedForm c -> + str "Sub-expression " ++ pr_lconstr_env env sigma c ++ + strbrk " not in guarded form (should be a constructor," ++ + strbrk " an abstraction, a match, a cofix or a recursive call)" + | ReturnPredicateNotCoInductive c -> + str "The return clause of the following pattern matching should be" ++ + strbrk " a coinductive type:" ++ + spc () ++ pr_lconstr_env env sigma c + in + prt_name i ++ str " is ill-formed." ++ fnl () ++ + pr_ne_context_of (str "In environment") env sigma ++ + st ++ str "." ++ fnl () ++ + (try (* May fail with unresolved globals. *) + let fixenv = make_all_name_different fixenv in + let pvd = pr_lconstr_env fixenv sigma vdefj.(i).uj_val in + str"Recursive definition is:" ++ spc () ++ pvd ++ str "." + with e when CErrors.noncritical e -> mt ()) + +let explain_ill_typed_rec_body env sigma i names vdefj vargs = + let vdefj = Evarutil.jv_nf_evar sigma vdefj in + let vargs = Array.map (Evarutil.nf_evar sigma) vargs in + let env = make_all_name_different env in + let pvd = pr_lconstr_env env sigma vdefj.(i).uj_val in + let pvdt, pv = pr_explicit env sigma vdefj.(i).uj_type vargs.(i) in + str "The " ++ + (match vdefj with [|_|] -> mt () | _ -> pr_nth (i+1) ++ spc ()) ++ + str "recursive definition" ++ spc () ++ pvd ++ spc () ++ + str "has type" ++ spc () ++ pvdt ++ spc () ++ + str "while it should be" ++ spc () ++ pv ++ str "." + +let explain_cant_find_case_type env sigma c = + let c = Evarutil.nf_evar sigma c in + let env = make_all_name_different env in + let pe = pr_lconstr_env env sigma c in + str "Cannot infer the return type of pattern-matching on" ++ ws 1 ++ + pe ++ str "." + +let explain_occur_check env sigma ev rhs = + let rhs = Evarutil.nf_evar sigma rhs in + let env = make_all_name_different env in + let pt = pr_lconstr_env env sigma rhs in + str "Cannot define " ++ pr_existential_key sigma ev ++ str " with term" ++ + brk(1,1) ++ pt ++ spc () ++ str "that would depend on itself." + +let pr_trailing_ne_context_of env sigma = + if List.is_empty (Environ.rel_context env) && + List.is_empty (Environ.named_context env) + then str "." + else (str " in environment:"++ pr_context_unlimited env sigma) + +let rec explain_evar_kind env sigma evk ty = function + | Evar_kinds.NamedHole id -> + strbrk "the existential variable named " ++ pr_id id + | Evar_kinds.QuestionMark _ -> + strbrk "this placeholder of type " ++ ty + | Evar_kinds.CasesType false -> + strbrk "the type of this pattern-matching problem" + | Evar_kinds.CasesType true -> + strbrk "a subterm of type " ++ ty ++ + strbrk " in the type of this pattern-matching problem" + | Evar_kinds.BinderType (Name id) -> + strbrk "the type of " ++ Nameops.pr_id id + | Evar_kinds.BinderType Anonymous -> + strbrk "the type of this anonymous binder" + | Evar_kinds.ImplicitArg (c,(n,ido),b) -> + let id = Option.get ido in + strbrk "the implicit parameter " ++ pr_id id ++ spc () ++ str "of" ++ + spc () ++ Nametab.pr_global_env Id.Set.empty c ++ + strbrk " whose type is " ++ ty + | Evar_kinds.InternalHole -> strbrk "an internal placeholder of type " ++ ty + | Evar_kinds.TomatchTypeParameter (tyi,n) -> + strbrk "the " ++ pr_nth n ++ + strbrk " argument of the inductive type (" ++ pr_inductive env tyi ++ + strbrk ") of this term" + | Evar_kinds.GoalEvar -> + strbrk "an existential variable of type " ++ ty + | Evar_kinds.ImpossibleCase -> + strbrk "the type of an impossible pattern-matching clause" + | Evar_kinds.MatchingVar _ -> + assert false + | Evar_kinds.VarInstance id -> + strbrk "an instance of type " ++ ty ++ + str " for the variable " ++ pr_id id + | Evar_kinds.SubEvar evk' -> + let evi = Evd.find sigma evk' in + let pc = match evi.evar_body with + | Evar_defined c -> pr_lconstr_env env sigma (Evarutil.nf_evar sigma c) + | Evar_empty -> assert false in + let ty' = Evarutil.nf_evar sigma evi.evar_concl in + pr_existential_key sigma evk ++ str " of type " ++ ty ++ + str " in the partial instance " ++ pc ++ + str " found for " ++ explain_evar_kind env sigma evk' + (pr_lconstr_env env sigma ty') (snd evi.evar_source) + +let explain_typeclass_resolution env sigma evi k = + match Typeclasses.class_of_constr evi.evar_concl with + | Some _ -> + let env = Evd.evar_filtered_env evi in + fnl () ++ str "Could not find an instance for " ++ + pr_lconstr_env env sigma evi.evar_concl ++ + pr_trailing_ne_context_of env sigma + | _ -> mt() + +let explain_placeholder_kind env sigma c e = + match e with + | Some (SeveralInstancesFound n) -> + strbrk " (several distinct possible type class instances found)" + | None -> + match Typeclasses.class_of_constr c with + | Some _ -> strbrk " (no type class instance found)" + | _ -> mt () + +let explain_unsolvable_implicit env sigma evk explain = + let evi = Evarutil.nf_evar_info sigma (Evd.find_undefined sigma evk) in + let env = Evd.evar_filtered_env evi in + let type_of_hole = pr_lconstr_env env sigma evi.evar_concl in + let pe = pr_trailing_ne_context_of env sigma in + strbrk "Cannot infer " ++ + explain_evar_kind env sigma evk type_of_hole (snd evi.evar_source) ++ + explain_placeholder_kind env sigma evi.evar_concl explain ++ pe + +let explain_var_not_found env id = + str "The variable" ++ spc () ++ pr_id id ++ + spc () ++ str "was not found" ++ + spc () ++ str "in the current" ++ spc () ++ str "environment" ++ str "." + +let explain_wrong_case_info env (ind,u) ci = + let pi = pr_inductive (Global.env()) ind in + if eq_ind ci.ci_ind ind then + str "Pattern-matching expression on an object of inductive type" ++ + spc () ++ pi ++ spc () ++ str "has invalid information." + else + let pc = pr_inductive (Global.env()) ci.ci_ind in + str "A term of inductive type" ++ spc () ++ pi ++ spc () ++ + str "was given to a pattern-matching expression on the inductive type" ++ + spc () ++ pc ++ str "." + +let explain_cannot_unify env sigma m n e = + let env = make_all_name_different env in + let m = Evarutil.nf_evar sigma m in + let n = Evarutil.nf_evar sigma n in + let pm, pn = pr_explicit env sigma m n in + let ppreason = explain_unification_error env sigma m n e in + let pe = pr_ne_context_of (str "In environment") env sigma in + pe ++ str "Unable to unify" ++ brk(1,1) ++ pm ++ spc () ++ + str "with" ++ brk(1,1) ++ pn ++ ppreason ++ str "." + +let explain_cannot_unify_local env sigma m n subn = + let pm = pr_lconstr_env env sigma m in + let pn = pr_lconstr_env env sigma n in + let psubn = pr_lconstr_env env sigma subn in + str "Unable to unify" ++ brk(1,1) ++ pm ++ spc () ++ + str "with" ++ brk(1,1) ++ pn ++ spc () ++ str "as" ++ brk(1,1) ++ + psubn ++ str " contains local variables." + +let explain_refiner_cannot_generalize env sigma ty = + str "Cannot find a well-typed generalisation of the goal with type: " ++ + pr_lconstr_env env sigma ty ++ str "." + +let explain_no_occurrence_found env sigma c id = + str "Found no subterm matching " ++ pr_lconstr_env env sigma c ++ + str " in " ++ + (match id with + | Some id -> pr_id id + | None -> str"the current goal") ++ str "." + +let explain_cannot_unify_binding_type env sigma m n = + let pm = pr_lconstr_env env sigma m in + let pn = pr_lconstr_env env sigma n in + str "This binding has type" ++ brk(1,1) ++ pm ++ spc () ++ + str "which should be unifiable with" ++ brk(1,1) ++ pn ++ str "." + +let explain_cannot_find_well_typed_abstraction env sigma p l e = + str "Abstracting over the " ++ + str (String.plural (List.length l) "term") ++ spc () ++ + hov 0 (pr_enum (pr_lconstr_env env sigma) l) ++ spc () ++ + str "leads to a term" ++ spc () ++ pr_lconstr_goal_style_env env sigma p ++ + spc () ++ str "which is ill-typed." ++ + (match e with None -> mt () | Some e -> fnl () ++ str "Reason is: " ++ e) + +let explain_wrong_abstraction_type env sigma na abs expected result = + let ppname = match na with Name id -> pr_id id ++ spc () | _ -> mt () in + str "Cannot instantiate metavariable " ++ ppname ++ strbrk "of type " ++ + pr_lconstr_env env sigma expected ++ strbrk " with abstraction " ++ + pr_lconstr_env env sigma abs ++ strbrk " of incompatible type " ++ + pr_lconstr_env env sigma result ++ str "." + +let explain_abstraction_over_meta _ m n = + strbrk "Too complex unification problem: cannot find a solution for both " ++ + pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "." + +let explain_non_linear_unification env sigma m t = + strbrk "Cannot unambiguously instantiate " ++ + pr_name m ++ str ":" ++ + strbrk " which would require to abstract twice on " ++ + pr_lconstr_env env sigma t ++ str "." + +let explain_unsatisfied_constraints env sigma cst = + strbrk "Unsatisfied constraints: " ++ + Univ.pr_constraints (Evd.pr_evd_level sigma) cst ++ + spc () ++ str "(maybe a bugged tactic)." + +let explain_type_error env sigma err = + let env = make_all_name_different env in + match err with + | UnboundRel n -> + explain_unbound_rel env sigma n + | UnboundVar v -> + explain_unbound_var env v + | NotAType j -> + explain_not_type env sigma j + | BadAssumption c -> + explain_bad_assumption env sigma c + | ReferenceVariables (id,c) -> + explain_reference_variables id c + | ElimArity (ind, aritylst, c, pj, okinds) -> + explain_elim_arity env sigma ind aritylst c pj okinds + | CaseNotInductive cj -> + explain_case_not_inductive env sigma cj + | NumberBranches (cj, n) -> + explain_number_branches env sigma cj n + | IllFormedBranch (c, i, actty, expty) -> + explain_ill_formed_branch env sigma c i actty expty + | Generalization (nvar, c) -> + explain_generalization env sigma nvar c + | ActualType (j, pt) -> + explain_actual_type env sigma j pt None + | CantApplyBadType (t, rator, randl) -> + explain_cant_apply_bad_type env sigma t rator randl + | CantApplyNonFunctional (rator, randl) -> + explain_cant_apply_not_functional env sigma rator randl + | IllFormedRecBody (err, lna, i, fixenv, vdefj) -> + explain_ill_formed_rec_body env sigma err lna i fixenv vdefj + | IllTypedRecBody (i, lna, vdefj, vargs) -> + explain_ill_typed_rec_body env sigma i lna vdefj vargs + | WrongCaseInfo (ind,ci) -> + explain_wrong_case_info env ind ci + | UnsatisfiedConstraints cst -> + explain_unsatisfied_constraints env sigma cst + +let pr_position (cl,pos) = + let clpos = match cl with + | None -> str " of the goal" + | Some (id,Locus.InHyp) -> str " of hypothesis " ++ pr_id id + | Some (id,Locus.InHypTypeOnly) -> str " of the type of hypothesis " ++ pr_id id + | Some (id,Locus.InHypValueOnly) -> str " of the body of hypothesis " ++ pr_id id in + int pos ++ clpos + +let explain_cannot_unify_occurrences env sigma nested ((cl2,pos2),t2) ((cl1,pos1),t1) e = + if nested then + str "Found nested occurrences of the pattern at positions " ++ + int pos1 ++ strbrk " and " ++ pr_position (cl2,pos2) ++ str "." + else + let ppreason = match e with None -> mt() | Some (c1,c2,e) -> explain_unification_error env sigma c1 c2 (Some e) in + str "Found incompatible occurrences of the pattern" ++ str ":" ++ + spc () ++ str "Matched term " ++ pr_lconstr_env env sigma t2 ++ + strbrk " at position " ++ pr_position (cl2,pos2) ++ + strbrk " is not compatible with matched term " ++ + pr_lconstr_env env sigma t1 ++ strbrk " at position " ++ + pr_position (cl1,pos1) ++ ppreason ++ str "." + +let pr_constraints printenv env sigma evars cstrs = + let (ev, evi) = Evar.Map.choose evars in + if Evar.Map.for_all (fun ev' evi' -> + eq_named_context_val evi.evar_hyps evi'.evar_hyps) evars + then + let l = Evar.Map.bindings evars in + let env' = reset_with_named_context evi.evar_hyps env in + let pe = + if printenv then + pr_ne_context_of (str "In environment:") env' sigma + else mt () + in + let evs = + prlist + (fun (ev, evi) -> fnl () ++ pr_existential_key sigma ev ++ + str " : " ++ pr_lconstr_env env' sigma evi.evar_concl ++ fnl ()) l + in + h 0 (pe ++ evs ++ pr_evar_constraints cstrs) + else + let filter evk _ = Evar.Map.mem evk evars in + pr_evar_map_filter ~with_univs:false filter sigma + +let explain_unsatisfiable_constraints env sigma constr comp = + let (_, constraints) = Evd.extract_all_conv_pbs sigma in + let undef = Evd.undefined_map (Evarutil.nf_evar_map_undefined sigma) in + (** Only keep evars that are subject to resolution and members of the given + component. *) + let is_kept evk evi = match comp with + | None -> Typeclasses.is_resolvable evi + | Some comp -> Typeclasses.is_resolvable evi && Evar.Set.mem evk comp + in + let undef = + let m = Evar.Map.filter is_kept undef in + if Evar.Map.is_empty m then undef + else m + in + match constr with + | None -> + str "Unable to satisfy the following constraints:" ++ fnl () ++ + pr_constraints true env sigma undef constraints + | Some (ev, k) -> + let cstr = + let remaining = Evar.Map.remove ev undef in + if not (Evar.Map.is_empty remaining) then + str "With the following constraints:" ++ fnl () ++ + pr_constraints false env sigma remaining constraints + else mt () + in + let info = Evar.Map.find ev undef in + explain_typeclass_resolution env sigma info k ++ fnl () ++ cstr + +let explain_pretype_error env sigma err = + 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 + | ActualTypeNotCoercible (j,t,e) -> + 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 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 + | UnexpectedType (actual,expect) -> + let env, actual, expect = contract2 env actual expect in + explain_unexpected_type env sigma actual expect + | NotProduct c -> explain_not_product env sigma c + | CannotUnify (m,n,e) -> + let env, m, n = contract2 env m n in + explain_cannot_unify env sigma m n e + | CannotUnifyLocal (m,n,sn) -> explain_cannot_unify_local env sigma m n sn + | CannotGeneralize ty -> explain_refiner_cannot_generalize env sigma ty + | NoOccurrenceFound (c, id) -> explain_no_occurrence_found env sigma c id + | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env sigma m n + | CannotFindWellTypedAbstraction (p,l,e) -> + explain_cannot_find_well_typed_abstraction env sigma p l + (Option.map (fun (env',e) -> explain_type_error env' sigma e) e) + | WrongAbstractionType (n,a,t,u) -> + explain_wrong_abstraction_type env sigma n a t u + | AbstractionOverMeta (m,n) -> explain_abstraction_over_meta env m n + | NonLinearUnification (m,c) -> explain_non_linear_unification env sigma m c + | TypingError t -> explain_type_error env sigma t + | CannotUnifyOccurrences (b,c1,c2,e) -> explain_cannot_unify_occurrences env sigma b c1 c2 e + | UnsatisfiableConstraints (c,comp) -> explain_unsatisfiable_constraints env sigma c comp +(* Module errors *) + +open Modops + +let explain_not_match_error = function + | InductiveFieldExpected _ -> + strbrk "an inductive definition is expected" + | DefinitionFieldExpected -> + strbrk "a definition is expected" + | ModuleFieldExpected -> + strbrk "a module is expected" + | ModuleTypeFieldExpected -> + strbrk "a module type is expected" + | NotConvertibleInductiveField id | NotConvertibleConstructorField id -> + str "types given to " ++ pr_id id ++ str " differ" + | NotConvertibleBodyField -> + str "the body of definitions differs" + | NotConvertibleTypeField (env, typ1, typ2) -> + str "expected type" ++ spc () ++ + quote (Printer.safe_pr_lconstr_env env Evd.empty typ2) ++ spc () ++ + str "but found type" ++ spc () ++ + quote (Printer.safe_pr_lconstr_env env Evd.empty typ1) + | NotSameConstructorNamesField -> + str "constructor names differ" + | NotSameInductiveNameInBlockField -> + str "inductive types names differ" + | FiniteInductiveFieldExpected isfinite -> + str "type is expected to be " ++ + str (if isfinite then "coinductive" else "inductive") + | InductiveNumbersFieldExpected n -> + str "number of inductive types differs" + | InductiveParamsNumberField n -> + str "inductive type has not the right number of parameters" + | RecordFieldExpected isrecord -> + str "type is expected " ++ str (if isrecord then "" else "not ") ++ + str "to be a record" + | RecordProjectionsExpected nal -> + (if List.length nal >= 2 then str "expected projection names are " + else str "expected projection name is ") ++ + pr_enum (function Name id -> pr_id id | _ -> str "_") nal + | NotEqualInductiveAliases -> + str "Aliases to inductive types do not match" + | NoTypeConstraintExpected -> + strbrk "a definition whose type is constrained can only be subtype " ++ + strbrk "of a definition whose type is itself constrained" + | PolymorphicStatusExpected b -> + let status b = if b then str"polymorphic" else str"monomorphic" in + str "a " ++ status b ++ str" declaration was expected, but a " ++ + status (not b) ++ str" declaration was found" + | IncompatibleInstances -> + str"polymorphic universe instances do not match" + | IncompatibleUniverses incon -> + str"the universe constraints are inconsistent: " ++ + Univ.explain_universe_inconsistency Universes.pr_with_global_universes incon + | IncompatiblePolymorphism (env, t1, t2) -> + str "conversion of polymorphic values generates additional constraints: " ++ + quote (Printer.safe_pr_lconstr_env env Evd.empty t1) ++ spc () ++ + str "compared to " ++ spc () ++ + quote (Printer.safe_pr_lconstr_env env Evd.empty t2) + | IncompatibleConstraints cst -> + str " the expected (polymorphic) constraints do not imply " ++ + quote (Univ.pr_constraints (Evd.pr_evd_level Evd.empty) cst) + +let explain_signature_mismatch l spec why = + str "Signature components for label " ++ pr_label l ++ + str " do not match:" ++ spc () ++ explain_not_match_error why ++ str "." + +let explain_label_already_declared l = + str "The label " ++ pr_label l ++ str " is already declared." + +let explain_application_to_not_path _ = + strbrk "A module cannot be applied to another module application or " ++ + strbrk "with-expression; you must give a name to the intermediate result " ++ + strbrk "module first." + +let explain_not_a_functor () = + str "Application of a non-functor." + +let explain_is_a_functor () = + str "Illegal use of a functor." + +let explain_incompatible_module_types mexpr1 mexpr2 = + 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." + +let explain_no_such_label l = + str "No such label " ++ pr_label l ++ str "." + +let explain_incompatible_labels l l' = + str "Opening and closing labels are not the same: " ++ + pr_label l ++ str " <> " ++ pr_label l' ++ str "!" + +let explain_not_a_module s = + quote (str s) ++ str " is not a module." + +let explain_not_a_module_type s = + quote (str s) ++ str " is not a module type." + +let explain_not_a_constant l = + quote (pr_label l) ++ str " is not a constant." + +let explain_incorrect_label_constraint l = + str "Incorrect constraint for label " ++ + quote (pr_label l) ++ str "." + +let explain_generative_module_expected l = + 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 " ++ pr_label 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 + | ApplicationToNotPath mexpr -> explain_application_to_not_path mexpr + | NotAFunctor -> explain_not_a_functor () + | IsAFunctor -> explain_is_a_functor () + | IncompatibleModuleTypes (m1,m2) -> explain_incompatible_module_types m1 m2 + | NotEqualModulePaths (mp1,mp2) -> explain_not_equal_module_paths mp1 mp2 + | NoSuchLabel l -> explain_no_such_label l + | IncompatibleLabels (l1,l2) -> explain_incompatible_labels l1 l2 + | NotAModule s -> explain_not_a_module s + | NotAModuleType s -> explain_not_a_module_type s + | NotAConstant l -> explain_not_a_constant l + | 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 *) + +(* +let explain_declaration_not_path _ = + str "Declaration is not a path." + +*) + +let explain_not_module_nor_modtype s = + quote (str s) ++ str " is not a module or module type." + +let explain_incorrect_with_in_module () = + str "The syntax \"with\" is not allowed for modules." + +let explain_incorrect_module_application () = + str "Illegal application to a module type." + +open Modintern + +let explain_module_internalization_error = function + | NotAModuleNorModtype s -> explain_not_module_nor_modtype s + | IncorrectWithInModule -> explain_incorrect_with_in_module () + | IncorrectModuleApplication -> explain_incorrect_module_application () + +(* Typeclass errors *) + +let explain_not_a_class env c = + pr_constr_env env Evd.empty c ++ str" is not a declared type class." + +let explain_unbound_method env cid id = + str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++ + str"of class" ++ spc () ++ pr_global cid ++ str "." + +let pr_constr_exprs exprs = + hv 0 (List.fold_right + (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr d ++ pps) + exprs (mt ())) + +let explain_mismatched_contexts env c i j = + str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++ + hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env Evd.empty j) ++ + fnl () ++ brk (1,1) ++ + hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i) + +let explain_typeclass_error env = function + | NotAClass c -> explain_not_a_class env c + | UnboundMethod (cid, id) -> explain_unbound_method env cid id + | MismatchedContextInstance (c,i,j) -> explain_mismatched_contexts env c i j + +(* Refiner errors *) + +let explain_refiner_bad_type arg ty conclty = + str "Refiner was given an argument" ++ brk(1,1) ++ + pr_lconstr arg ++ spc () ++ + str "of type" ++ brk(1,1) ++ pr_lconstr ty ++ spc () ++ + str "instead of" ++ brk(1,1) ++ pr_lconstr conclty ++ str "." + +let explain_refiner_unresolved_bindings l = + str "Unable to find an instance for the " ++ + str (String.plural (List.length l) "variable") ++ spc () ++ + prlist_with_sep pr_comma pr_name l ++ str"." + +let explain_refiner_cannot_apply t harg = + str "In refiner, a term of type" ++ brk(1,1) ++ + pr_lconstr t ++ spc () ++ str "could not be applied to" ++ brk(1,1) ++ + pr_lconstr harg ++ str "." + +let explain_refiner_not_well_typed c = + str "The term " ++ pr_lconstr c ++ str " is not well-typed." + +let explain_intro_needs_product () = + str "Introduction tactics needs products." + +let explain_does_not_occur_in c hyp = + str "The term" ++ spc () ++ pr_lconstr c ++ spc () ++ + str "does not occur in" ++ spc () ++ pr_id hyp ++ str "." + +let explain_non_linear_proof c = + str "Cannot refine with term" ++ brk(1,1) ++ pr_lconstr c ++ + spc () ++ str "because a metavariable has several occurrences." + +let explain_meta_in_type c = + str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++ + str " of another meta" + +let explain_no_such_hyp id = + str "No such hypothesis: " ++ pr_id id + +let explain_refiner_error = function + | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty + | UnresolvedBindings t -> explain_refiner_unresolved_bindings t + | CannotApply (t,harg) -> explain_refiner_cannot_apply t harg + | NotWellTyped c -> explain_refiner_not_well_typed c + | IntroNeedsProduct -> explain_intro_needs_product () + | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp + | NonLinearProof c -> explain_non_linear_proof c + | MetaInType c -> explain_meta_in_type c + | NoSuchHyp id -> explain_no_such_hyp id + +(* Inductive errors *) + +let error_non_strictly_positive env c v = + let pc = pr_lconstr_env env Evd.empty c in + let pv = pr_lconstr_env env Evd.empty v in + str "Non strictly positive occurrence of " ++ pv ++ str " in" ++ + brk(1,1) ++ pc ++ str "." + +let error_ill_formed_inductive env c v = + let pc = pr_lconstr_env env Evd.empty c in + let pv = pr_lconstr_env env Evd.empty v in + str "Not enough arguments applied to the " ++ pv ++ + str " in" ++ brk(1,1) ++ pc ++ str "." + +let error_ill_formed_constructor env id c v nparams nargs = + let pv = pr_lconstr_env env Evd.empty v in + let atomic = Int.equal (nb_prod c) 0 in + str "The type of constructor" ++ brk(1,1) ++ pr_id id ++ brk(1,1) ++ + str "is not valid;" ++ brk(1,1) ++ + strbrk (if atomic then "it must be " else "its conclusion must be ") ++ + pv ++ + (* warning: because of implicit arguments it is difficult to say which + parameters must be explicitly given *) + (if not (Int.equal nparams 0) then + strbrk " applied to its " ++ str (String.plural nparams "parameter") + else + mt()) ++ + (if not (Int.equal nargs 0) then + str (if not (Int.equal nparams 0) then " and" else " applied") ++ + strbrk " to some " ++ str (String.plural nargs "argument") + else + mt()) ++ str "." + +let pr_ltype_using_barendregt_convention_env env c = + (* Use goal_concl_style as an approximation of Barendregt's convention (?) *) + quote (pr_goal_concl_style_env env Evd.empty c) + +let error_bad_ind_parameters env c n v1 v2 = + let pc = pr_ltype_using_barendregt_convention_env env c in + let pv1 = pr_lconstr_env env Evd.empty v1 in + let pv2 = pr_lconstr_env env Evd.empty v2 in + str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++ + str " as " ++ pr_nth n ++ str " argument in" ++ brk(1,1) ++ pc ++ str "." + +let error_same_names_types id = + str "The name" ++ spc () ++ pr_id id ++ spc () ++ + str "is used more than once." + +let error_same_names_constructors id = + str "The constructor name" ++ spc () ++ pr_id id ++ spc () ++ + str "is used more than once." + +let error_same_names_overlap idl = + strbrk "The following names are used both as type names and constructor " ++ + str "names:" ++ spc () ++ + prlist_with_sep pr_comma pr_id idl ++ str "." + +let error_not_an_arity env c = + str "The type" ++ spc () ++ pr_lconstr_env env Evd.empty c ++ spc () ++ + str "is not an arity." + +let error_bad_entry () = + str "Bad inductive definition." + +let error_large_non_prop_inductive_not_in_type () = + str "Large non-propositional inductive types must be in Type." + +(* Recursion schemes errors *) + +let error_not_allowed_case_analysis isrec kind i = + str (if isrec then "Induction" else "Case analysis") ++ + strbrk " on sort " ++ pr_sort Evd.empty kind ++ + strbrk " is not allowed for inductive definition " ++ + pr_inductive (Global.env()) (fst i) ++ str "." + +let error_not_allowed_dependent_analysis isrec i = + str "Dependent " ++ str (if isrec then "Induction" else "Case analysis") ++ + strbrk " is not allowed for inductive definition " ++ + pr_inductive (Global.env()) i ++ str "." + +let error_not_mutual_in_scheme ind ind' = + if eq_ind ind ind' then + str "The inductive type " ++ pr_inductive (Global.env()) ind ++ + str " occurs twice." + else + str "The inductive types " ++ pr_inductive (Global.env()) ind ++ spc () ++ + str "and" ++ spc () ++ pr_inductive (Global.env()) ind' ++ spc () ++ + str "are not mutually defined." + +(* Inductive constructions errors *) + +let explain_inductive_error = function + | NonPos (env,c,v) -> error_non_strictly_positive env c v + | NotEnoughArgs (env,c,v) -> error_ill_formed_inductive env c v + | NotConstructor (env,id,c,v,n,m) -> + error_ill_formed_constructor env id c v n m + | NonPar (env,c,n,v1,v2) -> error_bad_ind_parameters env c n v1 v2 + | SameNamesTypes id -> error_same_names_types id + | SameNamesConstructors id -> error_same_names_constructors id + | SameNamesOverlap idl -> error_same_names_overlap idl + | NotAnArity (env, c) -> error_not_an_arity env c + | BadEntry -> error_bad_entry () + | LargeNonPropInductiveNotInType -> + error_large_non_prop_inductive_not_in_type () + +(* Recursion schemes errors *) + +let explain_recursion_scheme_error = function + | NotAllowedCaseAnalysis (isrec,k,i) -> + error_not_allowed_case_analysis isrec k i + | NotMutualInScheme (ind,ind')-> error_not_mutual_in_scheme ind ind' + | NotAllowedDependentAnalysis (isrec, i) -> + error_not_allowed_dependent_analysis isrec i + +(* Pattern-matching errors *) + +let explain_bad_pattern env sigma cstr ty = + let env = make_all_name_different env in + let pt = pr_lconstr_env env sigma ty in + let pc = pr_constructor env cstr in + str "Found the constructor " ++ pc ++ brk(1,1) ++ + str "while matching a term of type " ++ pt ++ brk(1,1) ++ + str "which is not an inductive type." + +let explain_bad_constructor env cstr ind = + let pi = pr_inductive env ind in +(* let pc = pr_constructor env cstr in*) + let pt = pr_inductive env (inductive_of_constructor cstr) in + str "Found a constructor of inductive type " ++ pt ++ brk(1,1) ++ + str "while a constructor of " ++ pi ++ brk(1,1) ++ + str "is expected." + +let decline_string n s = + if Int.equal n 0 then str "no " ++ str s ++ str "s" + else if Int.equal n 1 then str "1 " ++ str s + else (int n ++ str " " ++ str s ++ str "s") + +let explain_wrong_numarg_constructor env cstr n = + str "The constructor " ++ pr_constructor env cstr ++ + str " (in type " ++ pr_inductive env (inductive_of_constructor cstr) ++ + str ") expects " ++ decline_string n "argument" ++ str "." + +let explain_wrong_numarg_inductive env ind n = + str "The inductive type " ++ pr_inductive env ind ++ + str " expects " ++ decline_string n "argument" ++ str "." + +let explain_unused_clause env pats = +(* Without localisation + let s = if List.length pats > 1 then "s" else "" in + (str ("Unused clause with pattern"^s) ++ spc () ++ + hov 0 (pr_sequence pr_cases_pattern pats) ++ str ")") +*) + str "This clause is redundant." + +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 (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 + let pr_branch (cstr,typ) = + let cstr,_ = decompose_app cstr in + str "For " ++ pr_lconstr_env env sigma cstr ++ str ": " ++ pr_lconstr_env env sigma typ + in + str "Unable to unify the types found in the branches:" ++ + spc () ++ hov 0 (prlist_with_sep fnl pr_branch (Array.to_list typs)) + +let explain_pattern_matching_error env sigma = function + | BadPattern (c,t) -> + explain_bad_pattern env sigma c t + | BadConstructor (c,ind) -> + explain_bad_constructor env c ind + | WrongNumargConstructor (c,n) -> + explain_wrong_numarg_constructor env c n + | WrongNumargInductive (c,n) -> + explain_wrong_numarg_inductive env c n + | UnusedClause tms -> + explain_unused_clause env tms + | NonExhaustive tms -> + explain_non_exhaustive env tms + | CannotInferPredicate typs -> + explain_cannot_infer_predicate env sigma typs + +let explain_reduction_tactic_error = function + | Tacred.InvalidAbstraction (env,sigma,c,(env',e)) -> + str "The abstracted term" ++ spc () ++ + quote (pr_goal_concl_style_env env sigma c) ++ + spc () ++ str "is not well typed." ++ fnl () ++ + explain_type_error env' Evd.empty e diff --git a/vernac/himsg.mli b/vernac/himsg.mli new file mode 100644 index 0000000000..ced54fd279 --- /dev/null +++ b/vernac/himsg.mli @@ -0,0 +1,42 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Evd.evar_map -> type_error -> std_ppcmds + +val explain_pretype_error : env -> Evd.evar_map -> pretype_error -> std_ppcmds + +val explain_inductive_error : inductive_error -> std_ppcmds + +val explain_typeclass_error : env -> typeclass_error -> Pp.std_ppcmds + +val explain_recursion_scheme_error : recursion_scheme_error -> std_ppcmds + +val explain_refiner_error : refiner_error -> std_ppcmds + +val explain_pattern_matching_error : + env -> Evd.evar_map -> pattern_matching_error -> std_ppcmds + +val explain_reduction_tactic_error : + Tacred.reduction_tactic_error -> std_ppcmds + +val explain_module_error : Modops.module_typing_error -> std_ppcmds + +val explain_module_internalization_error : + Modintern.module_internalization_error -> std_ppcmds diff --git a/vernac/ind_tables.ml b/vernac/ind_tables.ml new file mode 100644 index 0000000000..85d0b6194c --- /dev/null +++ b/vernac/ind_tables.ml @@ -0,0 +1,203 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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 * Safe_typing.private_constants + +type 'a scheme_kind = string + +let scheme_map = Summary.ref Indmap.empty ~name:"Schemes" + +let pr_scheme_kind = Pp.str + +let cache_one_scheme kind (ind,const) = + let map = try Indmap.find ind !scheme_map with Not_found -> String.Map.empty in + scheme_map := Indmap.add ind (String.Map.add kind const map) !scheme_map + +let cache_scheme (_,(kind,l)) = + Array.iter (cache_one_scheme kind) l + +let subst_one_scheme subst (ind,const) = + (* Remark: const is a def: the result of substitution is a constant *) + (subst_ind subst ind,subst_constant subst const) + +let subst_scheme (subst,(kind,l)) = + (kind,Array.map (subst_one_scheme subst) l) + +let discharge_scheme (_,(kind,l)) = + Some (kind,Array.map (fun (ind,const) -> + (Lib.discharge_inductive ind,Lib.discharge_con const)) l) + +let inScheme : string * (inductive * constant) array -> obj = + declare_object {(default_object "SCHEME") with + cache_function = cache_scheme; + load_function = (fun _ -> cache_scheme); + subst_function = subst_scheme; + classify_function = (fun obj -> Substitute obj); + discharge_function = discharge_scheme} + +(**********************************************************************) +(* The table of scheme building functions *) + +type individual +type mutual + +type scheme_object_function = + | MutualSchemeFunction of mutual_scheme_object_function + | IndividualSchemeFunction of individual_scheme_object_function + +let scheme_object_table = + (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t) + +let declare_scheme_object s aux f = + let () = + if not (Id.is_valid ("ind" ^ s)) then + error ("Illegal induction scheme suffix: " ^ s) + in + let key = if String.is_empty aux then s else aux in + try + let _ = Hashtbl.find scheme_object_table key in +(* let aux_msg = if aux="" then "" else " (with key "^aux^")" in*) + user_err ~hdr:"IndTables.declare_scheme_object" + (str "Scheme object " ++ str key ++ str " already declared.") + with Not_found -> + Hashtbl.add scheme_object_table key (s,f); + key + +let declare_mutual_scheme_object s ?(aux="") f = + declare_scheme_object s aux (MutualSchemeFunction f) + +let declare_individual_scheme_object s ?(aux="") f = + declare_scheme_object s aux (IndividualSchemeFunction f) + +(**********************************************************************) +(* Defining/retrieving schemes *) + +let declare_scheme kind indcl = + Lib.add_anonymous_leaf (inScheme (kind,indcl)) + +let () = Declare.set_declare_scheme declare_scheme + +let is_visible_name id = + try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true + with Not_found -> false + +let compute_name internal id = + match internal with + | UserAutomaticRequest | UserIndividualRequest -> id + | InternalTacticRequest -> + Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name + +let define internal id c p univs = + let fd = declare_constant ~internal in + let id = compute_name internal id in + let ctx = Evd.normalize_evar_universe_context univs in + 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), + Safe_typing.empty_private_constants); + const_entry_secctx = None; + const_entry_type = None; + const_entry_polymorphic = p; + const_entry_universes = Evd.evar_context_universe_context ctx; + const_entry_opaque = false; + const_entry_inline_code = false; + const_entry_feedback = None; + } in + let kn = fd id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in + let () = match internal with + | InternalTacticRequest -> () + | _-> definition_message id + in + kn + +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 mode id c mib.mind_polymorphic ctx in + declare_scheme kind [|ind,const|]; + 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 + | _,MutualSchemeFunction f -> assert false + | s,IndividualSchemeFunction f -> + define_individual_scheme_base kind s f mode names ind + +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 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, + Safe_typing.add_private + (Safe_typing.private_con_of_scheme + kind (Global.safe_env()) (Array.to_list schemes)) + eff + +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 mode names mind + +let find_scheme_on_env_too kind ind = + let s = String.Map.find kind (Indmap.find ind !scheme_map) in + s, Safe_typing.add_private + (Safe_typing.private_con_of_scheme + kind (Global.safe_env()) [ind, s]) + Safe_typing.empty_private_constants + +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 + | s,IndividualSchemeFunction f -> + define_individual_scheme_base kind s f mode None ind + | s,MutualSchemeFunction f -> + let ca, eff = define_mutual_scheme_base kind s f mode [] mind in + ca.(i), eff + +let check_scheme kind ind = + try let _ = find_scheme_on_env_too kind ind in true + with Not_found -> false diff --git a/vernac/ind_tables.mli b/vernac/ind_tables.mli new file mode 100644 index 0000000000..20f30d6d16 --- /dev/null +++ b/vernac/ind_tables.mli @@ -0,0 +1,51 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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 * Safe_typing.private_constants + +(** Main functions to register a scheme builder *) + +val declare_mutual_scheme_object : string -> ?aux:string -> + mutual_scheme_object_function -> mutual scheme_kind + +val declare_individual_scheme_object : string -> ?aux:string -> + individual_scheme_object_function -> + individual scheme_kind + +(** Force generation of a (mutually) scheme with possibly user-level names *) + +val define_individual_scheme : individual scheme_kind -> + internal_flag (** internal *) -> + 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 * 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 * Safe_typing.private_constants + +val check_scheme : 'a scheme_kind -> inductive -> bool + + +val pr_scheme_kind : 'a scheme_kind -> Pp.std_ppcmds diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml new file mode 100644 index 0000000000..f7e3f0d954 --- /dev/null +++ b/vernac/indschemes.ml @@ -0,0 +1,530 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* !elim_flag) ; + optwrite = (fun b -> elim_flag := b) } + +let bifinite_elim_flag = ref false +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "automatic declaration of induction schemes for non-recursive types"; + optkey = ["Nonrecursive";"Elimination";"Schemes"]; + optread = (fun () -> !bifinite_elim_flag) ; + optwrite = (fun b -> bifinite_elim_flag := b) } +let _ = + declare_bool_option + { optsync = true; + optdepr = true; (* compatibility 2014-09-03*) + optname = "automatic declaration of induction schemes for non-recursive types"; + optkey = ["Record";"Elimination";"Schemes"]; + optread = (fun () -> !bifinite_elim_flag) ; + optwrite = (fun b -> bifinite_elim_flag := b) } + +let case_flag = ref false +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "automatic declaration of case analysis schemes"; + optkey = ["Case";"Analysis";"Schemes"]; + optread = (fun () -> !case_flag) ; + optwrite = (fun b -> case_flag := b) } + +let eq_flag = ref false +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "automatic declaration of boolean equality"; + optkey = ["Boolean";"Equality";"Schemes"]; + optread = (fun () -> !eq_flag) ; + optwrite = (fun b -> eq_flag := b) } +let _ = (* compatibility *) + declare_bool_option + { optsync = true; + optdepr = true; + optname = "automatic declaration of boolean equality"; + optkey = ["Equality";"Scheme"]; + optread = (fun () -> !eq_flag) ; + optwrite = (fun b -> eq_flag := b) } + +let is_eq_flag () = !eq_flag && Flags.version_strictly_greater Flags.V8_2 + +let eq_dec_flag = ref false +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "automatic declaration of decidable equality"; + optkey = ["Decidable";"Equality";"Schemes"]; + optread = (fun () -> !eq_dec_flag) ; + optwrite = (fun b -> eq_dec_flag := b) } + +let rewriting_flag = ref false +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname ="automatic declaration of rewriting schemes for equality types"; + optkey = ["Rewriting";"Schemes"]; + optread = (fun () -> !rewriting_flag) ; + optwrite = (fun b -> rewriting_flag := b) } + +(* Util *) + +let define id internal ctx c t = + let f = declare_constant ~internal in + let kn = f id + (DefinitionEntry + { const_entry_body = c; + const_entry_secctx = None; + const_entry_type = t; + const_entry_polymorphic = Flags.is_universe_polymorphism (); + const_entry_universes = snd (Evd.universe_context ctx); + const_entry_opaque = false; + const_entry_inline_code = false; + const_entry_feedback = None; + }, + Decl_kinds.IsDefinition Scheme) in + definition_message id; + kn + +(* Boolean equality *) + +let declare_beq_scheme_gen internal names kn = + ignore (define_mutual_scheme beq_scheme_kind internal names kn) + +let alarm what internal msg = + let debug = false in + match internal with + | UserAutomaticRequest + | InternalTacticRequest -> + (if debug then + Feedback.msg_debug + (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 e -> + let e = CErrors.push e in + let msg = match fst e with + | ParameterWithoutEquality cst -> + alarm what internal + (str "Boolean equality not found for parameter " ++ Printer.pr_global cst ++ + str".") + | InductiveWithProduct -> + alarm what internal + (str "Unable to decide equality of functional arguments.") + | InductiveWithSort -> + alarm what internal + (str "Unable to decide equality of type arguments.") + | NonSingletonProp ind -> + alarm what internal + (str "Cannot extract computational content from proposition " ++ + quote (Printer.pr_inductive (Global.env()) ind) ++ str ".") + | EqNotFound (ind',ind) -> + alarm what internal + (str "Boolean equality on " ++ + quote (Printer.pr_inductive (Global.env()) ind') ++ + strbrk " is missing.") + | UndefinedCst s -> + alarm what internal + (strbrk "Required constant " ++ str s ++ str " undefined.") + | AlreadyDeclared msg -> + alarm what internal (msg ++ str ".") + | DecidabilityMutualNotSupported -> + alarm what internal + (str "Decidability lemma for mutual inductive types not supported.") + | EqUnknown s -> + alarm what internal + (str "Found unsupported " ++ str s ++ str " while building Boolean equality.") + | NoDecidabilityCoInductive -> + alarm what internal + (str "Scheme Equality is only for inductive types.") + | e when CErrors.noncritical e -> + alarm what internal + (str "Unexpected error during scheme creation: " ++ CErrors.print e) + | _ -> iraise e + in + match msg with + | None -> () + | Some msg -> iraise (UserError (None, msg), snd e) + +let beq_scheme_msg mind = + let mib = Global.lookup_mind mind in + (* TODO: mutual inductive case *) + str "Boolean equality on " ++ + pr_enum (fun ind -> quote (Printer.pr_inductive (Global.env()) ind)) + (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 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 UserAutomaticRequest [] kn + +let declare_beq_scheme = declare_beq_scheme_with [] + +(* Case analysis schemes *) +let declare_one_case_analysis_scheme ind = + let (mib,mip) = Global.lookup_inductive ind in + let kind = inductive_sort_family mip in + let dep = + if kind == InProp then case_scheme_kind_from_prop + else if not (Inductiveops.has_dependent_elim mib) then + case_scheme_kind_from_type + else case_dep_scheme_kind_from_type in + let kelim = elim_sorts (mib,mip) in + (* in case the inductive has a type elimination, generates only one + 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 UserAutomaticRequest None ind) + +(* Induction/recursion schemes *) + +let kinds_from_prop = + [InType,rect_scheme_kind_from_prop; + InProp,ind_scheme_kind_from_prop; + InSet,rec_scheme_kind_from_prop] + +let kinds_from_type = + [InType,rect_dep_scheme_kind_from_type; + InProp,ind_dep_scheme_kind_from_type; + InSet,rec_dep_scheme_kind_from_type] + +let nondep_kinds_from_type = + [InType,rect_scheme_kind_from_type; + InProp,ind_scheme_kind_from_type; + InSet,rec_scheme_kind_from_type] + +let declare_one_induction_scheme ind = + let (mib,mip) = Global.lookup_inductive ind in + let kind = inductive_sort_family mip in + let from_prop = kind == InProp in + let depelim = Inductiveops.has_dependent_elim mib in + let kelim = elim_sorts (mib,mip) in + let elims = + 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 if depelim then kinds_from_type + else nondep_kinds_from_type) in + List.iter (fun kind -> ignore (define_individual_scheme kind UserAutomaticRequest None ind)) + elims + +let declare_induction_schemes kn = + let mib = Global.lookup_mind kn in + if mib.mind_finite <> Decl_kinds.CoFinite then begin + for i = 0 to Array.length mib.mind_packets - 1 do + declare_one_induction_scheme (kn,i); + done; + end + +(* Decidable equality *) + +let declare_eq_decidability_gen internal names kn = + let mib = Global.lookup_mind kn in + if mib.mind_finite <> Decl_kinds.CoFinite then + ignore (define_mutual_scheme eq_dec_scheme_kind internal names kn) + +let eq_dec_scheme_msg ind = (* TODO: mutual inductive case *) + str "Decidable equality on " ++ quote (Printer.pr_inductive (Global.env()) ind) + +let declare_eq_decidability_scheme_with l kn = + try_declare_scheme (eq_dec_scheme_msg (kn,0)) + 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 UserAutomaticRequest [] kn + +let declare_eq_decidability = declare_eq_decidability_scheme_with [] + +let ignore_error f x = + try ignore (f x) with e when CErrors.noncritical e -> () + +let declare_rewriting_schemes ind = + if Hipattern.is_inductive_equality ind then begin + 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 + 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 UserAutomaticRequest None) ind; + ignore_error + (define_individual_scheme rew_l2r_dep_scheme_kind UserAutomaticRequest None) ind; + ignore_error + (define_individual_scheme rew_l2r_forward_dep_scheme_kind UserAutomaticRequest None) ind + end + +let warn_cannot_build_congruence = + CWarnings.create ~name:"cannot-build-congruence" ~category:"schemes" + (fun () -> + strbrk "Cannot build congruence scheme because eq is not found") + +let declare_congr_scheme ind = + if Hipattern.is_equality_type (mkInd ind) then begin + if + try Coqlib.check_required_library Coqlib.logic_module_name; true + with e when CErrors.noncritical e -> false + then + ignore (define_individual_scheme congr_scheme_kind UserAutomaticRequest None ind) + else + warn_cannot_build_congruence () + end + +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 UserAutomaticRequest None) ind + +(* Scheme command *) + +let smart_global_inductive y = smart_global_inductive y +let rec split_scheme l = + let env = Global.env() in + match l with + | [] -> [],[] + | (Some id,t)::q -> let l1,l2 = split_scheme q in + ( match t with + | InductionScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2 + | CaseScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2 + | EqualityScheme x -> l1,((Some id,smart_global_inductive x)::l2) + ) +(* + if no name has been provided, we build one from the types of the ind +requested +*) + | (None,t)::q -> + let l1,l2 = split_scheme q in + let names inds recs isdep y z = + let ind = smart_global_inductive y in + let sort_of_ind = inductive_sort_family (snd (lookup_mind_specif env ind)) in + let z' = interp_elimination_sort z in + let suffix = ( + match sort_of_ind with + | InProp -> + if isdep then (match z' with + | InProp -> inds ^ "_dep" + | InSet -> recs ^ "_dep" + | InType -> recs ^ "t_dep") + else ( match z' with + | InProp -> inds + | InSet -> recs + | InType -> recs ^ "t" ) + | _ -> + if isdep then (match z' with + | InProp -> inds + | InSet -> recs + | InType -> recs ^ "t" ) + else (match z' with + | InProp -> inds ^ "_nodep" + | InSet -> recs ^ "_nodep" + | InType -> recs ^ "t_nodep") + ) in + let newid = add_suffix (basename_of_global (IndRef ind)) suffix in + let newref = (Loc.ghost,newid) in + ((newref,isdep,ind,z)::l1),l2 + in + match t with + | CaseScheme (x,y,z) -> names "_case" "_case" x y z + | InductionScheme (x,y,z) -> names "_ind" "_rec" x y z + | EqualityScheme x -> l1,((None,smart_global_inductive x)::l2) + + +let do_mutual_induction_scheme lnamedepindsort = + let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort + and env0 = Global.env() in + let sigma, lrecspec, _ = + List.fold_right + (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 = + let decltype = Retyping.get_type_of env0 sigma decl 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 + let _ = List.fold_right2 declare listdecl lrecnames [] in + fixpoint_message None lrecnames + +let get_common_underlying_mutual_inductive = function + | [] -> assert false + | (id,(mind,i as ind))::l as all -> + match List.filter (fun (_,(mind',_)) -> not (eq_mind mind mind')) l with + | (_,ind')::_ -> + raise (RecursionSchemeError (NotMutualInScheme (ind,ind'))) + | [] -> + if not (List.distinct_f Int.compare (List.map snd (List.map snd all))) + then error "A type occurs twice"; + mind, + List.map_filter + (function (Some id,(_,i)) -> Some (i,snd id) | (None,_) -> None) all + +let do_scheme l = + let ischeme,escheme = split_scheme l in +(* we want 1 kind of scheme at a time so we check if the user +tried to declare different schemes at once *) + if not (List.is_empty ischeme) && not (List.is_empty escheme) + then + error "Do not declare equality and induction scheme at the same time." + else ( + if not (List.is_empty ischeme) then do_mutual_induction_scheme ischeme + else + let mind,l = get_common_underlying_mutual_inductive escheme in + declare_beq_scheme_with l mind; + declare_eq_decidability_scheme_with l mind + ) + +(**********************************************************************) +(* Combined scheme *) +(* Matthieu Sozeau, Dec 2006 *) + +let list_split_rev_at index l = + let rec aux i acc = function + hd :: tl when Int.equal i index -> acc, tl + | hd :: tl -> aux (succ i) (hd :: acc) tl + | [] -> failwith "List.split_when: Invalid argument" + in aux 0 [] l + +let fold_left' f = function + [] -> invalid_arg "fold_left'" + | hd :: tl -> List.fold_left f hd tl + +let build_combined_scheme env schemes = + let defs = List.map (fun cst -> (* FIXME *) + 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 = + let (ctx, arity) = decompose_prod ty in + let (_, last) = List.hd ctx in + match kind_of_term last with + | App (ind, args) -> + let ind = destInd ind in + let (_,spec) = Inductive.lookup_mind_specif env (fst ind) in + ctx, ind, spec.mind_nrealargs + | _ -> ctx, destInd last, 0 + in + let (c, t) = List.hd defs in + let ctx, ind, nargs = find_inductive t in + (* Number of clauses, including the predicates quantification *) + let prods = nb_prod t - (nargs + 1) in + let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in + let relargs = rel_vect 0 prods in + let concls = List.rev_map + (fun (cst, t) -> (* FIXME *) + mkApp(mkConstU cst, relargs), + snd (decompose_prod_n prods t)) defs in + let concl_bod, concl_typ = + fold_left' + (fun (accb, acct) (cst, x) -> + mkApp (coqconj, [| x; acct; cst; accb |]), + mkApp (coqand, [| x; acct |])) concls + in + let ctx, _ = + list_split_rev_at prods + (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) + +let do_combined_scheme name schemes = + let csts = + List.map (fun x -> + let refe = Ident x in + let qualid = qualid_of_reference refe in + try Nametab.locate_constant (snd qualid) + with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared.")) + schemes + in + let body,typ = build_combined_scheme (Global.env ()) csts 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] + +(**********************************************************************) + +let map_inductive_block f kn n = for i=0 to n-1 do f (kn,i) done + +let declare_default_schemes kn = + let mib = Global.lookup_mind kn in + let n = Array.length mib.mind_packets in + if !elim_flag && (mib.mind_finite <> BiFinite || !bifinite_elim_flag) + && mib.mind_typing_flags.check_guarded then + declare_induction_schemes kn; + if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n; + if is_eq_flag() then try_declare_beq_scheme kn; + if !eq_dec_flag then try_declare_eq_decidability kn; + if !rewriting_flag then map_inductive_block declare_congr_scheme kn n; + if !rewriting_flag then map_inductive_block declare_sym_scheme kn n; + if !rewriting_flag then map_inductive_block declare_rewriting_schemes kn n diff --git a/vernac/indschemes.mli b/vernac/indschemes.mli new file mode 100644 index 0000000000..e5d79fd514 --- /dev/null +++ b/vernac/indschemes.mli @@ -0,0 +1,49 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit + +val declare_eq_decidability : mutual_inductive -> unit + +(** Build and register a congruence scheme for an equality-like inductive type *) + +val declare_congr_scheme : inductive -> unit + +(** Build and register rewriting schemes for an equality-like inductive type *) + +val declare_rewriting_schemes : inductive -> unit + +(** Mutual Minimality/Induction scheme *) + +val do_mutual_induction_scheme : + (Id.t located * bool * inductive * glob_sort) list -> unit + +(** Main calls to interpret the Scheme command *) + +val do_scheme : (Id.t located option * scheme) list -> unit + +(** Combine a list of schemes into a conjunction of them *) + +val build_combined_scheme : env -> constant list -> constr * types + +val do_combined_scheme : Id.t located -> Id.t located list -> unit + +(** Hook called at each inductive type definition *) + +val declare_default_schemes : mutual_inductive -> unit diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml new file mode 100644 index 0000000000..55f33be399 --- /dev/null +++ b/vernac/lemmas.ml @@ -0,0 +1,557 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Globnames.global_reference -> 'a +let mk_hook hook = hook +let call_hook fix_exn hook l c = + try hook l c + with e when CErrors.noncritical e -> + let e = CErrors.push e in + iraise (fix_exn e) + +(* Support for mutually proved theorems *) + +let retrieve_first_recthm = function + | VarRef id -> + (NamedDecl.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) + | _ -> assert false + +let adjust_guardness_conditions const = function + | [] -> const (* Not a recursive statement *) + | possible_indexes -> + (* Try all combinations... not optimal *) + let env = Global.env() in + { const with const_entry_body = + Future.chain ~greedy:true ~pure:true const.const_entry_body + (fun ((body, ctx), eff) -> + match kind_of_term body with + | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> +(* let possible_indexes = + List.map2 (fun i c -> match i with Some i -> i | None -> + List.interval 0 (List.length ((lam_assum c)))) + lemma_guard (Array.to_list fixdefs) in +*) + let add c cb e = + let exists c e = + 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 = 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 (Safe_typing.side_effects_of_private_constants eff) in + let indexes = + search_guard Loc.ghost env + possible_indexes fixdecls in + (mkFix ((indexes,0),fixdecls), ctx), eff + | _ -> (body, ctx), eff) } + +let find_mutually_recursive_statements thms = + let n = List.length thms in + let inds = List.map (fun (id,(t,impls,annot)) -> + let (hyps,ccl) = decompose_prod_assum t in + let x = (id,(t,impls)) in + match annot with + (* Explicit fixpoint decreasing argument is given *) + | Some (Some (_,id),CStructRec) -> + let i,b,typ = lookup_rel_id id hyps 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.Finite && Option.is_empty b -> + [ind,x,i],[] + | _ -> + error "Decreasing argument is not an inductive assumption.") + (* Unsupported cases *) + | Some (_,(CWfRec _|CMeasureRec _)) -> + error "Only structural decreasing is supported for mutual statements." + (* Cofixpoint or fixpoint w/o explicit decreasing argument *) + | None | Some (None, CStructRec) -> + let whnf_hyp_hds = map_rel_context_in_env + (fun env c -> fst (whd_all_stack env Evd.empty c)) + (Global.env()) hyps in + let ind_hyps = + List.flatten (List.map_i (fun i decl -> + let t = RelDecl.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 && is_local_assum decl -> + [ind,x,i] + | _ -> + []) 0 (List.rev whnf_hyp_hds)) in + let ind_ccl = + let cclenv = push_rel_context hyps (Global.env()) in + let whnf_ccl,_ = whd_all_stack cclenv Evd.empty ccl in + match kind_of_term whnf_ccl with + | Ind ((kn,_ as ind),u) when + let mind = Global.lookup_mind kn in + Int.equal mind.mind_ntypes n && mind.mind_finite == Decl_kinds.CoFinite -> + [ind,x,0] + | _ -> + [] in + ind_hyps,ind_ccl) thms in + let inds_hyps,ind_ccls = List.split inds in + let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> eq_mind kn kn' in + (* Check if all conclusions are coinductive in the same type *) + (* (degenerated cartesian product since there is at most one coind ccl) *) + let same_indccl = + List.cartesians_filter (fun hyp oks -> + if List.for_all (of_same_mutind hyp) oks + then Some (hyp::oks) else None) [] ind_ccls in + let ordered_same_indccl = + List.filter (List.for_all_i (fun i ((kn,j),_,_) -> Int.equal i j) 0) same_indccl in + (* Check if some hypotheses are inductive in the same type *) + let common_same_indhyp = + List.cartesians_filter (fun hyp oks -> + if List.for_all (of_same_mutind hyp) oks + then Some (hyp::oks) else None) [] inds_hyps in + let ordered_inds,finite,guard = + match ordered_same_indccl, common_same_indhyp with + | indccl::rest, _ -> + assert (List.is_empty rest); + (* One occ. of common coind ccls and no common inductive hyps *) + if not (List.is_empty common_same_indhyp) then + if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements."); + flush_all (); + indccl, true, [] + | [], _::_ -> + let () = match same_indccl with + | ind :: _ -> + if List.distinct_f ind_ord (List.map pi1 ind) + then + if_verbose Feedback.msg_info + (strbrk + ("Coinductive statements do not follow the order of "^ + "definition, assuming the proof to be by induction.")); + flush_all () + | _ -> () + in + let possible_guards = List.map (List.map pi3) inds_hyps in + (* assume the largest indices as possible *) + List.last common_same_indhyp, false, possible_guards + | _, [] -> + error + ("Cannot find common (mutual) inductive premises or coinductive" ^ + " conclusions in the statements.") + in + (finite,guard,None), ordered_inds + +let look_for_possibly_mutual_statements = function + | [id,(t,impls,None)] -> + (* One non recursively proved theorem *) + None,[id,(t,impls)],None + | _::_ as thms -> + (* More than one statement and/or an explicit decreasing mark: *) + (* we look for a common inductive hyp or a common coinductive conclusion *) + let recguard,ordered_inds = find_mutually_recursive_statements thms in + let thms = List.map pi2 ordered_inds in + Some recguard,thms, Some (List.map (fun (_,_,i) -> succ i) ordered_inds) + | [] -> anomaly (Pp.str "Empty list of theorems.") + +(* Saving a goal *) + +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 + let k = Kindops.logical_kind_of_goal_kind kind in + let l,r = match locality with + | Discharge when Lib.sections_are_opened () -> + let c = SectionLocalDef const in + let _ = declare_variable id (Lib.cwd(), c, k) in + (Local, VarRef id) + | Local | Global | Discharge -> + let local = match locality with + | Local | Discharge -> true + | Global -> false + in + let kn = + 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 CErrors.noncritical e -> + let e = CErrors.push e in + iraise (fix_exn e) + +let default_thm_id = Id.of_string "Unnamed_thm" + +let compute_proof_name locality = function + | 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) + then + user_err ~loc (pr_id id ++ str " already exists."); + id, pl + | None -> + 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,pl),(t_i,(_,imps))) = + let t_i = norm t_i in + match body with + | None -> + (match locality with + | Discharge -> + let impl = false in (* copy values from Vernacentries *) + let k = IsAssumption Conjectural in + let c = SectionLocalAssum ((t_i,ctx),p,impl) in + let _ = declare_variable id (Lib.cwd(),c,k) in + (Discharge, VarRef id,imps) + | Local | Global -> + let k = IsAssumption Conjectural in + let local = match locality with + | Local -> true + | Global -> false + | Discharge -> assert false + in + let ctx = Univ.ContextSet.to_context ctx in + let decl = (ParameterEntry (None,p,(t_i,ctx),None), k) in + let kn = declare_constant id ~local decl in + (locality,ConstRef kn,imps)) + | Some body -> + let body = norm body in + let k = Kindops.logical_kind_of_goal_kind kind in + let rec body_i t = match kind_of_term t with + | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) + | CoFix (0,decls) -> mkCoFix (i,decls) + | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, body_i t2) + | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t) + | App (t, args) -> mkApp (body_i t, args) + | _ -> anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr body) in + let body_i = body_i body in + match locality with + | Discharge -> + let const = definition_entry ~types:t_i ~opaque:opaq ~poly:p + ~univs:(Univ.ContextSet.to_context ctx) body_i in + let c = SectionLocalDef const in + let _ = declare_variable id (Lib.cwd(), c, k) in + (Discharge,VarRef id,imps) + | Local | Global -> + let ctx = Univ.ContextSet.to_context ctx in + let local = match locality with + | Local -> true + | Global -> false + | Discharge -> assert false + in + let const = + Declare.definition_entry ~types:t_i ~poly:p ~univs:ctx ~opaque:opaq body_i + in + let kn = declare_constant id ~local (DefinitionEntry const, k) in + (locality,ConstRef kn,imps) + +let save_hook = ref ignore +let set_save_hook f = save_hook := f + +let save_named ?export_seff proof = + 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,pl),do_guard,persistence,hook = proof in + check_anonymity id save_ident; + 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,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 pl do_guard + (Global, const.const_entry_polymorphic, Proof kind) hook + +(* Admitted *) + +let warn_let_as_axiom = + CWarnings.create ~name:"let-as-axiom" ~category:"vernacular" + (fun id -> strbrk "Let definition" ++ spc () ++ pr_id id ++ + spc () ++ strbrk "declared as an axiom.") + +let admit (id,k,e) pl hook () = + let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in + let () = match k with + | Global, _, _ -> () + | Local, _, _ | Discharge, _, _ -> warn_let_as_axiom id + 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 *) + +let start_hook = ref ignore +let set_start_hook = (:=) start_hook + + +let get_proof proof do_guard hook opacity = + let (id,(const,univs,persistence)) = + Pfedit.cook_this_proof proof + in + id,{const with const_entry_opaque = opacity},univs,do_guard,persistence,hook + +let check_exist = + List.iter (fun (loc,id) -> + if not (Nametab.exists_cci (Lib.make_path id)) then + user_err ~loc (pr_id id ++ str " does not exist.") + ) + +let universe_proof_terminator compute_guard hook = + let open Proof_global in + make_terminator begin function + | Admitted (id,k,pe,(ctx,pl)) -> + admit (id,k,pe) pl (hook (Some ctx)) (); + Feedback.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 (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 + | Some ((_,id),Some kind) -> + save_anonymous_with_strength ~export_seff proof kind id + end; + check_exist exports + end + +let standard_proof_terminator compute_guard hook = + universe_proof_terminator compute_guard (fun _ -> hook) + +let start_proof id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = + let terminator = match terminator with + | None -> standard_proof_terminator compute_guard hook + | Some terminator -> terminator compute_guard hook + in + let sign = + match sign with + | Some sign -> sign + | None -> initialize_named_context_for_proof () + in + !start_hook c; + Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator + +let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = + let terminator = match terminator with + | None -> universe_proof_terminator compute_guard hook + | Some terminator -> terminator compute_guard hook + in + let sign = + match sign with + | Some sign -> sign + | None -> initialize_named_context_for_proof () + in + !start_hook c; + 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 + | (id,_)::l -> Tactics.mutual_cofix id l 0 + | _ -> assert false + else + (* nl is dummy: it will be recomputed at Qed-time *) + 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 + | (id,n,_)::l -> Tactics.mutual_fix id n l 0 + | _ -> assert false + +let start_proof_with_initialization kind ctx recguard thms snl hook = + let intro_tac (_, (_, (ids, _))) = + Tacticals.New.tclMAP (function + | Name id -> Tactics.intro_mustbe_force id + | Anonymous -> Tactics.intro) (List.rev ids) in + let init_tac,guard = match recguard with + | Some (finite,guard,init_tac) -> + let rec_tac = rec_tac_initializer finite guard thms snl in + Some (match init_tac with + | None -> + if Flags.is_auto_intros () then + Tacticals.New.tclTHENS rec_tac (List.map intro_tac thms) + else + rec_tac + | Some tacl -> + Tacticals.New.tclTHENS rec_tac + (if Flags.is_auto_intros () then + List.map2 (fun tac thm -> Tacticals.New.tclTHEN tac (intro_tac thm)) tacl thms + else + tacl)),guard + | None -> + let () = match thms with [_] -> () | _ -> assert false in + (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,pl),(t,(_,imps)))::other_thms -> + let hook ctx strength ref = + let ctx = match ctx with + | None -> Evd.empty_evar_universe_context + | Some ctx -> ctx + in + let other_thms_data = + if List.is_empty other_thms then [] else + (* there are several theorems defined mutually *) + 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 = 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 + 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 ?pl kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard + +let start_proof_com ?inference_hook kind thms hook = + let env0 = Global.env () 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 + let flags = all_and_fail_flags in + let flags = { flags with use_hook = inference_hook } in + evdref := solve_remaining_evars flags env !evdref (Evd.empty,!evdref); + let ids = List.map RelDecl.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'), + guard))) + thms in + 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 + let () = + match levels with + | None -> () + | Some l -> ignore (Evd.universe_context evd ?names:l) + in + 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 *) + +let keep_admitted_vars = ref true + +let _ = + let open Goptions in + declare_bool_option + { optsync = true; + optdepr = false; + optname = "keep section variables in admitted proofs"; + optkey = ["Keep"; "Admitted"; "Variables"]; + optread = (fun () -> !keep_admitted_vars); + optwrite = (fun b -> keep_admitted_vars := b) } + +let save_proof ?proof = function + | Vernacexpr.Admitted -> + let pe = + let open Proof_global in + match proof with + | Some ({ id; entries; persistence = k; universes }, _) -> + if List.length entries <> 1 then + error "Admitted does not support multiple statements"; + let { const_entry_secctx; const_entry_type } = List.hd entries in + 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 (fst universes) in + let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in + Admitted(id, k, (sec_vars, pi2 k, (typ, ctx), None), universes) + | None -> + let pftree = Pfedit.get_pftreestate () in + let id, k, typ = Pfedit.current_proof_statement () in + let universes = Proof.initial_euctx pftree in + (* This will warn if the proof is complete *) + let pproofs, _univs = + Proof_global.return_proof ~allow_partial:true () in + let sec_vars = + if not !keep_admitted_vars then None + else match Pfedit.get_used_variables(), pproofs with + | Some _ as x, _ -> x + | None, (pproof, _) :: _ -> + let env = Global.env () in + let ids_typ = Environ.global_vars_set env typ in + let ids_def = Environ.global_vars_set env pproof in + Some (Environ.keep_hyps env (Idset.union ids_typ ids_def)) + | _ -> None in + let names = Pfedit.get_universe_binders () in + let evd = Evd.from_ctx universes in + let binders, ctx = Evd.universe_context ?names evd in + Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None), + (universes, Some binders)) + in + Proof_global.apply_terminator (Proof_global.get_terminator ()) pe + | Vernacexpr.Proved (is_opaque,idopt) -> + let (proof_obj,terminator) = + match proof with + | None -> + Proof_global.close_proof ~keep_body_ucst_separate:false (fun x -> x) + | Some proof -> proof + in + (* if the proof is given explicitly, nothing has to be deleted *) + if Option.is_empty proof then Pfedit.delete_current_proof (); + Proof_global.(apply_terminator terminator (Proved (is_opaque,idopt,proof_obj))) + +(* Miscellaneous *) + +let get_current_context () = + Pfedit.get_current_context () + diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli new file mode 100644 index 0000000000..39c089be9f --- /dev/null +++ b/vernac/lemmas.mli @@ -0,0 +1,69 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Globnames.global_reference -> 'a) -> 'a declaration_hook + +val call_hook : + Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> Globnames.global_reference -> 'a + +(** 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 -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> + ?terminator:(lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> + ?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 -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> + ?terminator:(lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator) -> + ?sign:Environ.named_context_val -> types -> + ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> + (Evd.evar_universe_context option -> unit declaration_hook) -> unit + +val start_proof_com : + ?inference_hook:Pretyping.inference_hook -> + 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 * universe_binders option) * + (types * (Name.t list * Impargs.manual_explicitation list))) list + -> int list option -> unit declaration_hook -> unit + +val universe_proof_terminator : + Proof_global.lemma_possible_guards -> + (Evd.evar_universe_context option -> unit declaration_hook) -> + Proof_global.proof_terminator + +val standard_proof_terminator : + Proof_global.lemma_possible_guards -> unit declaration_hook -> + Proof_global.proof_terminator + +(** {6 ... } *) + +(** A hook the next three functions pass to cook_proof *) +val set_save_hook : (Proof.proof -> unit) -> unit + +val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit + + +(** [get_current_context ()] returns the evar context and env of the + current open proof if any, otherwise returns the empty evar context + and the current global env *) + +val get_current_context : unit -> Evd.evar_map * Environ.env diff --git a/vernac/locality.ml b/vernac/locality.ml new file mode 100644 index 0000000000..03640676e6 --- /dev/null +++ b/vernac/locality.ml @@ -0,0 +1,107 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Decl_kinds.Local + | false -> Decl_kinds.Global + +let check_locality locality_flag = + match locality_flag with + | Some b -> + let s = if b then "Local" else "Global" in + CErrors.user_err ~hdr:"Locality.check_locality" + (str "This command does not support the \"" ++ str s ++ str "\" prefix.") + | None -> () + +(** Extracting the locality flag *) + +(* Commands which supported an inlined Local flag *) + +let warn_deprecated_local_syntax = + CWarnings.create ~name:"deprecated-local-syntax" ~category:"deprecated" + (fun () -> + Pp.strbrk "Deprecated syntax: use \"Local\" as a prefix.") + +let enforce_locality_full locality_flag local = + let local = + match locality_flag with + | Some false when local -> + CErrors.error "Cannot be simultaneously Local and Global." + | Some true when local -> + CErrors.error "Use only prefix \"Local\"." + | None -> + if local then begin + warn_deprecated_local_syntax (); + Some true + end else + None + | Some b -> Some b in + local + +(** Positioning locality for commands supporting discharging and export + outside of modules *) + +(* For commands whose default is to discharge and export: + Global is the default and is neutral; + Local in a section deactivates discharge, + Local not in a section deactivates export *) +let make_non_locality = function Some false -> false | _ -> true + +let make_locality = function Some true -> true | _ -> false + +let enforce_locality locality_flag local = + make_locality (enforce_locality_full locality_flag local) + +let enforce_locality_exp locality_flag local = + match locality_flag, local with + | None, Some local -> local + | Some b, None -> local_of_bool b + | None, None -> Decl_kinds.Global + | Some _, Some _ -> CErrors.error "Local non allowed in this case" + +(* For commands whose default is to not discharge but to export: + Global in sections forces discharge, Global not in section is the default; + Local in sections is the default, Local not in section forces non-export *) + +let make_section_locality = + function Some b -> b | None -> Lib.sections_are_opened () + +let enforce_section_locality locality_flag local = + make_section_locality (enforce_locality_full locality_flag local) + +(** Positioning locality for commands supporting export but not discharge *) + +(* For commands whose default is to export (if not in section): + Global in sections is forbidden, Global not in section is neutral; + Local in sections is the default, Local not in section forces non-export *) + +let make_module_locality = function + | Some false -> + if Lib.sections_are_opened () then + CErrors.error + "This command does not support the Global option in sections."; + false + | Some true -> true + | None -> false + +let enforce_module_locality locality_flag local = + make_module_locality (enforce_locality_full locality_flag local) + +module LocalityFixme = struct + let locality = ref None + let set l = locality := l + let consume () = + let l = !locality in + locality := None; + l + let assert_consumed () = check_locality !locality +end diff --git a/vernac/locality.mli b/vernac/locality.mli new file mode 100644 index 0000000000..2ec392eefc --- /dev/null +++ b/vernac/locality.mli @@ -0,0 +1,51 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool -> bool option + +(** * Positioning locality for commands supporting discharging and export + outside of modules *) + +(** For commands whose default is to discharge and export: + Global is the default and is neutral; + Local in a section deactivates discharge, + Local not in a section deactivates export *) + +val make_locality : bool option -> bool +val make_non_locality : bool option -> bool +val enforce_locality : bool option -> bool -> bool +val enforce_locality_exp : + bool option -> Decl_kinds.locality option -> Decl_kinds.locality + +(** For commands whose default is to not discharge but to export: + Global in sections forces discharge, Global not in section is the default; + Local in sections is the default, Local not in section forces non-export *) + +val make_section_locality : bool option -> bool +val enforce_section_locality : bool option -> bool -> bool + +(** * Positioning locality for commands supporting export but not discharge *) + +(** For commands whose default is to export (if not in section): + Global in sections is forbidden, Global not in section is neutral; + Local in sections is the default, Local not in section forces non-export *) + +val make_module_locality : bool option -> bool +val enforce_module_locality : bool option -> bool -> bool + +(* This is the old imperative interface that is still used for + * VernacExtend vernaculars. Time permitting this could be trashed too *) +module LocalityFixme : sig + val set : bool option -> unit + val consume : unit -> bool option + val assert_consumed : unit -> unit +end diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml new file mode 100644 index 0000000000..0aaf6afd7e --- /dev/null +++ b/vernac/metasyntax.ml @@ -0,0 +1,1469 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* obj = + declare_object {(default_object "TOKEN") with + open_function = (fun i o -> if Int.equal i 1 then cache_token o); + cache_function = cache_token; + subst_function = Libobject.ident_subst_function; + classify_function = (fun o -> Substitute o)} + +let add_token_obj s = Lib.add_anonymous_leaf (inToken s) + +(**********************************************************************) +(* Printing grammar entries *) + +let entry_buf = Buffer.create 64 + +type any_entry = AnyEntry : 'a Pcoq.Gram.entry -> any_entry + +let grammars : any_entry list String.Map.t ref = ref String.Map.empty + +let register_grammar name grams = + grammars := String.Map.add name grams !grammars + +let pr_entry e = + let () = Buffer.clear entry_buf in + let ft = Format.formatter_of_buffer entry_buf in + let () = Pcoq.Gram.entry_print ft e in + str (Buffer.contents entry_buf) + +let pr_registered_grammar name = + let gram = try Some (String.Map.find name !grammars) with Not_found -> None in + match gram with + | None -> error "Unknown or unprintable grammar entry." + | Some entries -> + let pr_one (AnyEntry e) = + str "Entry " ++ str (Pcoq.Gram.Entry.name e) ++ str " is" ++ fnl () ++ + pr_entry e + in + prlist pr_one entries + +let pr_grammar = function + | "constr" | "operconstr" | "binder_constr" -> + str "Entry constr is" ++ fnl () ++ + pr_entry Pcoq.Constr.constr ++ + str "and lconstr is" ++ fnl () ++ + pr_entry Pcoq.Constr.lconstr ++ + str "where binder_constr is" ++ fnl () ++ + pr_entry Pcoq.Constr.binder_constr ++ + str "and operconstr is" ++ fnl () ++ + pr_entry Pcoq.Constr.operconstr + | "pattern" -> + pr_entry Pcoq.Constr.pattern + | "vernac" -> + str "Entry vernac is" ++ fnl () ++ + pr_entry Pcoq.Vernac_.vernac ++ + str "Entry command is" ++ fnl () ++ + pr_entry Pcoq.Vernac_.command ++ + str "Entry syntax is" ++ fnl () ++ + pr_entry Pcoq.Vernac_.syntax ++ + str "Entry gallina is" ++ fnl () ++ + pr_entry Pcoq.Vernac_.gallina ++ + str "Entry gallina_ext is" ++ fnl () ++ + pr_entry Pcoq.Vernac_.gallina_ext + | name -> pr_registered_grammar name + +(**********************************************************************) +(* Parse a format (every terminal starting with a letter or a single + quote (except a single quote alone) must be quoted) *) + +let parse_format ((loc, str) : lstring) = + let str = " "^str in + let l = String.length str in + let push_token a = function + | cur::l -> (a::cur)::l + | [] -> [[a]] in + let push_white n l = + if Int.equal n 0 then l else push_token (UnpTerminal (String.make n ' ')) l in + let close_box i b = function + | a::(_::_ as l) -> push_token (UnpBox (b,a)) l + | _ -> error "Non terminated box in format." in + let close_quotation i = + if i < String.length str && str.[i] == '\'' && (Int.equal (i+1) l || str.[i+1] == ' ') + then i+1 + else error "Incorrectly terminated quoted expression." in + let rec spaces n i = + if i < String.length str && str.[i] == ' ' then spaces (n+1) (i+1) + else n in + let rec nonspaces quoted n i = + if i < String.length str && str.[i] != ' ' then + if str.[i] == '\'' && quoted && + (i+1 >= String.length str || str.[i+1] == ' ') + then if Int.equal n 0 then error "Empty quoted token." else n + else nonspaces quoted (n+1) (i+1) + else + if quoted then error "Spaces are not allowed in (quoted) symbols." + else n in + let rec parse_non_format i = + let n = nonspaces false 0 i in + push_token (UnpTerminal (String.sub str i n)) (parse_token (i+n)) + and parse_quoted n i = + if i < String.length str then match str.[i] with + (* Parse " // " *) + | '/' when i <= String.length str && str.[i+1] == '/' -> + (* We forget the useless n spaces... *) + push_token (UnpCut PpFnl) + (parse_token (close_quotation (i+2))) + (* Parse " .. / .. " *) + | '/' when i <= String.length str -> + let p = spaces 0 (i+1) in + push_token (UnpCut (PpBrk (n,p))) + (parse_token (close_quotation (i+p+1))) + | c -> + (* The spaces are real spaces *) + push_white n (match c with + | '[' -> + if i <= String.length str then match str.[i+1] with + (* Parse " [h .. ", *) + | 'h' when i+1 <= String.length str && str.[i+2] == 'v' -> + (parse_box (fun n -> PpHVB n) (i+3)) + (* Parse " [v .. ", *) + | 'v' -> + parse_box (fun n -> PpVB n) (i+2) + (* Parse " [ .. ", *) + | ' ' | '\'' -> + parse_box (fun n -> PpHOVB n) (i+1) + | _ -> error "\"v\", \"hv\", \" \" expected after \"[\" in format." + else error "\"v\", \"hv\" or \" \" expected after \"[\" in format." + (* Parse "]" *) + | ']' -> + ([] :: parse_token (close_quotation (i+1))) + (* Parse a non formatting token *) + | c -> + let n = nonspaces true 0 i in + push_token (UnpTerminal (String.sub str (i-1) (n+2))) + (parse_token (close_quotation (i+n)))) + else + if Int.equal n 0 then [] + else error "Ending spaces non part of a format annotation." + and parse_box box i = + let n = spaces 0 i in + close_box i (box n) (parse_token (close_quotation (i+n))) + and parse_token i = + let n = spaces 0 i in + let i = i+n in + if i < l then match str.[i] with + (* Parse a ' *) + | '\'' when i+1 >= String.length str || str.[i+1] == ' ' -> + push_white (n-1) (push_token (UnpTerminal "'") (parse_token (i+1))) + (* Parse the beginning of a quoted expression *) + | '\'' -> + parse_quoted (n-1) (i+1) + (* Otherwise *) + | _ -> + push_white (n-1) (parse_non_format i) + else push_white n [[]] + in + try + if not (String.is_empty str) then match parse_token 0 with + | [l] -> l + | _ -> error "Box closed without being opened in format." + else + error "Empty format." + with reraise -> + let (e, info) = CErrors.push reraise in + let info = Loc.add_loc info loc in + iraise (e, info) + +(***********************) +(* Analyzing notations *) + +type symbol_token = WhiteSpace of int | String of string + +let split_notation_string str = + let push_token beg i l = + if Int.equal beg i then l else + let s = String.sub str beg (i - beg) in + String s :: l + in + let push_whitespace beg i l = + if Int.equal beg i then l else WhiteSpace (i-beg) :: l + in + let rec loop beg i = + if i < String.length str then + if str.[i] == ' ' then + push_token beg i (loop_on_whitespace (i+1) (i+1)) + else + loop beg (i+1) + else + push_token beg i [] + and loop_on_whitespace beg i = + if i < String.length str then + if str.[i] != ' ' then + push_whitespace beg i (loop i (i+1)) + else + loop_on_whitespace beg (i+1) + else + push_whitespace beg i [] + in + loop 0 0 + +(* Interpret notations with a recursive component *) + +let out_nt = function NonTerminal x -> x | _ -> assert false + +let msg_expected_form_of_recursive_notation = + "In the notation, the special symbol \"..\" must occur in\na configuration of the form \"x symbs .. symbs y\"." + +let rec find_pattern nt xl = function + | Break n as x :: l, Break n' :: l' when Int.equal n n' -> + find_pattern nt (x::xl) (l,l') + | Terminal s as x :: l, Terminal s' :: l' when String.equal s s' -> + find_pattern nt (x::xl) (l,l') + | [], NonTerminal x' :: l' -> + (out_nt nt,x',List.rev xl),l' + | _, Break s :: _ | Break s :: _, _ -> + error ("A break occurs on one side of \"..\" but not on the other side.") + | _, Terminal s :: _ | Terminal s :: _, _ -> + user_err ~hdr:"Metasyntax.find_pattern" + (str "The token \"" ++ str s ++ str "\" occurs on one side of \"..\" but not on the other side.") + | _, [] -> + error msg_expected_form_of_recursive_notation + | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) -> + anomaly (Pp.str "Only Terminal or Break expected on left, non-SProdList on right") + +let rec interp_list_parser hd = function + | [] -> [], List.rev hd + | NonTerminal id :: tl when Id.equal id ldots_var -> + if List.is_empty hd then error msg_expected_form_of_recursive_notation; + let hd = List.rev hd in + let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in + let xyl,tl'' = interp_list_parser [] tl' in + (* We remember each pair of variable denoting a recursive part to *) + (* remove the second copy of it afterwards *) + (x,y)::xyl, SProdList (x,sl) :: tl'' + | (Terminal _ | Break _) as s :: tl -> + if List.is_empty hd then + let yl,tl' = interp_list_parser [] tl in + yl, s :: tl' + else + interp_list_parser (s::hd) tl + | NonTerminal _ as x :: tl -> + let xyl,tl' = interp_list_parser [x] tl in + xyl, List.rev_append hd tl' + | SProdList _ :: _ -> anomaly (Pp.str "Unexpected SProdList in interp_list_parser") + + +(* Find non-terminal tokens of notation *) + +(* To protect alphabetic tokens and quotes from being seen as variables *) +let quote_notation_token x = + let n = String.length x in + let norm = CLexer.is_ident x in + if (n > 0 && norm) || (n > 2 && x.[0] == '\'') then "'"^x^"'" + else x + +let rec raw_analyze_notation_tokens = function + | [] -> [] + | String ".." :: sl -> NonTerminal ldots_var :: raw_analyze_notation_tokens sl + | String "_" :: _ -> error "_ must be quoted." + | String x :: sl when CLexer.is_ident x -> + NonTerminal (Names.Id.of_string x) :: raw_analyze_notation_tokens sl + | String s :: sl -> + Terminal (String.drop_simple_quotes s) :: raw_analyze_notation_tokens sl + | WhiteSpace n :: sl -> + Break n :: raw_analyze_notation_tokens sl + +let is_numeral symbs = + match List.filter (function Break _ -> false | _ -> true) symbs with + | ([Terminal "-"; Terminal x] | [Terminal x]) -> + (try let _ = Bigint.of_string x in true with Failure _ -> false) + | _ -> + false + +let rec get_notation_vars = function + | [] -> [] + | NonTerminal id :: sl -> + let vars = get_notation_vars sl in + if Id.equal id ldots_var then vars else + if Id.List.mem id vars then + user_err ~hdr:"Metasyntax.get_notation_vars" + (str "Variable " ++ pr_id id ++ str " occurs more than once.") + else + id::vars + | (Terminal _ | Break _) :: sl -> get_notation_vars sl + | SProdList _ :: _ -> assert false + +let analyze_notation_tokens l = + let l = raw_analyze_notation_tokens l in + let vars = get_notation_vars l in + let recvars,l = interp_list_parser [] l in + recvars, List.subtract Id.equal vars (List.map snd recvars), l + +let error_not_same_scope x y = + user_err ~hdr:"Metasyntax.error_not_name_scope" + (str "Variables " ++ pr_id x ++ str " and " ++ pr_id y ++ str " must be in the same scope.") + +(**********************************************************************) +(* Build pretty-printing rules *) + +let prec_assoc = function + | RightA -> (L,E) + | LeftA -> (E,L) + | NonA -> (L,L) + +let precedence_of_entry_type from = function + | ETConstr (NumLevel n,BorderProd (_,None)) -> n, Prec n + | ETConstr (NumLevel n,BorderProd (b,Some a)) -> + n, let (lp,rp) = prec_assoc a in if b == Left then lp else rp + | ETConstr (NumLevel n,InternalProd) -> n, Prec n + | ETConstr (NextLevel,_) -> from, L + | _ -> 0, E (* ?? *) + +(* Some breaking examples *) +(* "x = y" : "x /1 = y" (breaks before any symbol) *) +(* "x =S y" : "x /1 =S /1 y" (protect from confusion; each side for symmetry)*) +(* "+ {" : "+ {" may breaks reversibility without space but oth. not elegant *) +(* "x y" : "x spc y" *) +(* "{ x } + { y }" : "{ x } / + { y }" *) +(* "< x , y > { z , t }" : "< x , / y > / { z , / t }" *) + +let starts_with_left_bracket s = + let l = String.length s in not (Int.equal l 0) && + (s.[0] == '{' || s.[0] == '[' || s.[0] == '(') + +let ends_with_right_bracket s = + let l = String.length s in not (Int.equal l 0) && + (s.[l-1] == '}' || s.[l-1] == ']' || s.[l-1] == ')') + +let is_left_bracket s = + starts_with_left_bracket s && not (ends_with_right_bracket s) + +let is_right_bracket s = + not (starts_with_left_bracket s) && ends_with_right_bracket s + +let is_comma s = + let l = String.length s in not (Int.equal l 0) && + (s.[0] == ',' || s.[0] == ';') + +let is_operator s = + let l = String.length s in not (Int.equal l 0) && + (s.[0] == '+' || s.[0] == '*' || s.[0] == '=' || + s.[0] == '-' || s.[0] == '/' || s.[0] == '<' || s.[0] == '>' || + s.[0] == '@' || s.[0] == '\\' || s.[0] == '&' || s.[0] == '~' || s.[0] == '$') + +let is_non_terminal = function + | NonTerminal _ | SProdList _ -> true + | _ -> false + +let is_next_non_terminal = function +| [] -> false +| pr :: _ -> is_non_terminal pr + +let is_next_terminal = function Terminal _ :: _ -> true | _ -> false + +let is_next_break = function Break _ :: _ -> true | _ -> false + +let add_break n l = UnpCut (PpBrk(n,0)) :: l + +let add_break_if_none n = function + | ((UnpCut (PpBrk _) :: _) | []) as l -> l + | 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 + user_err (str "as " ++ pr_id m ++ + str " is a non-closed binder, no such \"" ++ + prlist_with_sep spc pr_token sl + ++ strbrk "\" is allowed to occur.") + +(* Heuristics for building default printing rules *) + +let index_id id l = List.index Id.equal id l + +let make_hunks etyps symbols from = + let vars,typs = List.split etyps in + let rec make = function + | NonTerminal m :: prods -> + let i = index_id m vars in + let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in + let u = UnpMetaVar (i,prec) in + if is_next_non_terminal prods then + u :: add_break_if_none 1 (make prods) + else + u :: make_with_space prods + | Terminal s :: prods when List.exists is_non_terminal prods -> + if (is_comma s || is_operator s) then + (* Always a breakable space after comma or separator *) + UnpTerminal s :: add_break_if_none 1 (make prods) + else if is_right_bracket s && is_next_terminal prods then + (* Always no space after right bracked, but possibly a break *) + UnpTerminal s :: add_break_if_none 0 (make prods) + else if is_left_bracket s && is_next_non_terminal prods then + UnpTerminal s :: make prods + else if not (is_next_break prods) then + (* Add rigid space, no break, unless user asked for something *) + UnpTerminal (s^" ") :: make prods + else + (* Rely on user spaces *) + UnpTerminal s :: make prods + + | Terminal s :: prods -> + (* Separate but do not cut a trailing sequence of terminal *) + (match prods with + | Terminal _ :: _ -> UnpTerminal (s^" ") :: make prods + | _ -> UnpTerminal s :: make prods) + + | Break n :: prods -> + add_break n (make prods) + + | SProdList (m,sl) :: prods -> + let i = index_id m vars in + let typ = List.nth typs (i-1) in + let _,prec = precedence_of_entry_type from typ in + let sl' = + (* If no separator: add a break *) + if List.is_empty sl then add_break 1 [] + (* We add NonTerminal for simulation but remove it afterwards *) + else snd (List.sep_last (make (sl@[NonTerminal m]))) in + let hunk = match typ with + | ETConstr _ -> UnpListMetaVar (i,prec,sl') + | ETBinder isopen -> + check_open_binder isopen sl m; + UnpBinderListMetaVar (i,isopen,sl') + | _ -> assert false in + hunk :: make_with_space prods + + | [] -> [] + + and make_with_space prods = + match prods with + | Terminal s' :: prods'-> + if is_operator s' then + (* A rigid space before operator and a breakable after *) + UnpTerminal (" "^s') :: add_break_if_none 1 (make prods') + else if is_comma s' then + (* No space whatsoever before comma *) + make prods + else if is_right_bracket s' then + make prods + else + (* A breakable space between any other two terminals *) + add_break_if_none 1 (make prods) + | (NonTerminal _ | SProdList _) :: _ -> + (* A breakable space before a non-terminal *) + add_break_if_none 1 (make prods) + | Break _ :: _ -> + (* Rely on user wish *) + make prods + | [] -> [] + + in make symbols + +(* Build default printing rules from explicit format *) + +let error_format () = error "The format does not match the notation." + +let rec split_format_at_ldots hd = function + | UnpTerminal s :: fmt when String.equal s (Id.to_string ldots_var) -> List.rev hd, fmt + | u :: fmt -> + check_no_ldots_in_box u; + split_format_at_ldots (u::hd) fmt + | [] -> raise Exit + +and check_no_ldots_in_box = function + | UnpBox (_,fmt) -> + (try + let _ = split_format_at_ldots [] fmt in + error ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.") + with Exit -> ()) + | _ -> () + +let skip_var_in_recursive_format = function + | UnpTerminal _ :: sl (* skip first var *) -> + (* To do, though not so important: check that the names match + the names in the notation *) + sl + | _ -> error_format () + +let read_recursive_format sl fmt = + let get_head fmt = + let sl = skip_var_in_recursive_format fmt in + try split_format_at_ldots [] sl with Exit -> error_format () in + let rec get_tail = function + | a :: sepfmt, b :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *) + | [], tail -> skip_var_in_recursive_format tail + | _ -> error "The format is not the same on the right and left hand side of the special token \"..\"." in + let slfmt, fmt = get_head fmt in + slfmt, get_tail (slfmt, fmt) + +let hunks_of_format (from,(vars,typs)) symfmt = + let rec aux = function + | symbs, (UnpTerminal s' as u) :: fmt + when String.equal s' (String.make (String.length s') ' ') -> + let symbs, l = aux (symbs,fmt) in symbs, u :: l + | Terminal s :: symbs, (UnpTerminal s') :: fmt + when String.equal s (String.drop_simple_quotes s') -> + let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l + | NonTerminal s :: symbs, UnpTerminal s' :: fmt when Id.equal s (Id.of_string s') -> + let i = index_id s vars in + let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in + let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l + | symbs, UnpBox (a,b) :: fmt -> + let symbs', b' = aux (symbs,b) in + let symbs', l = aux (symbs',fmt) in + symbs', UnpBox (a,b') :: l + | symbs, (UnpCut _ as u) :: fmt -> + let symbs, l = aux (symbs,fmt) in symbs, u :: l + | SProdList (m,sl) :: symbs, fmt -> + let i = index_id m vars in + let typ = List.nth typs (i-1) in + let _,prec = precedence_of_entry_type from typ in + let slfmt,fmt = read_recursive_format sl fmt in + let sl, slfmt = aux (sl,slfmt) in + if not (List.is_empty sl) then error_format (); + let symbs, l = aux (symbs,fmt) in + let hunk = match typ with + | ETConstr _ -> UnpListMetaVar (i,prec,slfmt) + | ETBinder isopen -> + check_open_binder isopen sl m; + UnpBinderListMetaVar (i,isopen,slfmt) + | _ -> assert false in + symbs, hunk :: l + | symbs, [] -> symbs, [] + | _, _ -> error_format () + in + match aux symfmt with + | [], l -> l + | _ -> error_format () + +(**********************************************************************) +(* Build parsing rules *) + +let assoc_of_type n (_,typ) = precedence_of_entry_type n typ + +let is_not_small_constr = function + ETConstr _ -> true + | ETOther("constr","binder_constr") -> true + | _ -> false + +let rec define_keywords_aux = function + | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(IDENT k) :: l + when is_not_small_constr e -> + Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); + CLexer.add_keyword k; + n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l + | n :: l -> n :: define_keywords_aux l + | [] -> [] + + (* Ensure that IDENT articulation terminal symbols are keywords *) +let define_keywords = function + | GramConstrTerminal(IDENT k)::l -> + Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); + CLexer.add_keyword k; + GramConstrTerminal(KEYWORD k) :: define_keywords_aux l + | l -> define_keywords_aux l + +let distribute a ll = List.map (fun l -> a @ l) ll + + (* Expand LIST1(t,sep) into the combination of t and t;sep;LIST1(t,sep) + as many times as expected in [n] argument *) +let rec expand_list_rule typ tkl x n i hds ll = + if Int.equal i n then + let hds = + GramConstrListMark (n,true) :: hds + @ [GramConstrNonTerminal (ETConstrList (typ,tkl), Some x)] in + distribute hds ll + else + let camlp4_message_name = Some (add_suffix x ("_"^string_of_int n)) in + let main = GramConstrNonTerminal (ETConstr typ, camlp4_message_name) in + let tks = List.map (fun x -> GramConstrTerminal x) tkl in + distribute (GramConstrListMark (i+1,false) :: hds @ [main]) ll @ + expand_list_rule typ tkl x n (i+1) (main :: tks @ hds) ll + +let make_production etyps symbols = + let prod = + List.fold_right + (fun t ll -> match t with + | NonTerminal m -> + let typ = List.assoc m etyps in + distribute [GramConstrNonTerminal (typ, Some m)] ll + | Terminal s -> + distribute [GramConstrTerminal (CLexer.terminal s)] ll + | Break _ -> + ll + | SProdList (x,sl) -> + let tkl = List.flatten + (List.map (function Terminal s -> [CLexer.terminal s] + | Break _ -> [] + | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator")) sl) in + match List.assoc x etyps with + | ETConstr typ -> expand_list_rule typ tkl x 1 0 [] ll + | ETBinder o -> + distribute + [GramConstrNonTerminal (ETBinderList (o,tkl), Some x)] ll + | _ -> + error "Components of recursive patterns in notation must be terms or binders.") + symbols [[]] in + List.map define_keywords prod + +let rec find_symbols c_current c_next c_last = function + | [] -> [] + | NonTerminal id :: sl -> + let prec = if not (List.is_empty sl) then c_current else c_last in + (id, prec) :: (find_symbols c_next c_next c_last sl) + | Terminal s :: sl -> find_symbols c_next c_next c_last sl + | Break n :: sl -> find_symbols c_current c_next c_last sl + | SProdList (x,_) :: sl' -> + (x,c_next)::(find_symbols c_next c_next c_last sl') + +let border = function + | (_,ETConstr(_,BorderProd (_,a))) :: _ -> a + | _ -> None + +let recompute_assoc typs = + match border typs, border (List.rev typs) with + | Some LeftA, Some RightA -> assert false + | Some LeftA, _ -> Some LeftA + | _, Some RightA -> Some RightA + | _ -> None + +(**************************************************************************) +(* Registration of syntax extensions (parsing/printing, no interpretation)*) + +let pr_arg_level from = function + | (n,L) when Int.equal n from -> str "at next level" + | (n,E) -> str "at level " ++ int n + | (n,L) -> str "at level below " ++ int n + | (n,Prec m) when Int.equal m n -> str "at level " ++ int n + | (n,_) -> str "Unknown level" + +let pr_level ntn (from,args) = + str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++ + prlist_with_sep pr_comma (pr_arg_level from) args + +let error_incompatible_level ntn oldprec prec = + user_err + (str "Notation " ++ str ntn ++ str " is already defined" ++ spc() ++ + pr_level ntn oldprec ++ + spc() ++ str "while it is now required to be" ++ spc() ++ + pr_level ntn prec ++ str ".") + +type syntax_extension = { + synext_level : Notation.level; + synext_notation : notation; + synext_notgram : notation_grammar; + synext_unparsing : unparsing list; + synext_extra : (string * string) list; + synext_compat : Flags.compat_version option; +} + +let is_active_compat = function +| None -> true +| Some v -> 0 <= Flags.version_compare v !Flags.compat_version + +type syntax_extension_obj = locality_flag * syntax_extension list + +let cache_one_syntax_extension se = + let ntn = se.synext_notation in + let prec = se.synext_level in + let onlyprint = se.synext_notgram.notgram_onlyprinting in + try + let oldprec = Notation.level_of_notation ntn in + if not (Notation.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec + with Not_found -> + if is_active_compat se.synext_compat then begin + (* Reserve the notation level *) + Notation.declare_notation_level ntn prec; + (* Declare the parsing rule *) + if not onlyprint then Egramcoq.extend_constr_grammar prec se.synext_notgram; + (* Declare the notation rule *) + Notation.declare_notation_rule ntn + ~extra:se.synext_extra (se.synext_unparsing, fst prec) se.synext_notgram + end + +let cache_syntax_extension (_, (_, sy)) = + List.iter cache_one_syntax_extension sy + +let subst_parsing_rule subst x = x + +let subst_printing_rule subst x = x + +let subst_syntax_extension (subst, (local, sy)) = + let map sy = { sy with + synext_notgram = subst_parsing_rule subst sy.synext_notgram; + synext_unparsing = subst_printing_rule subst sy.synext_unparsing; + } in + (local, List.map map sy) + +let classify_syntax_definition (local, _ as o) = + if local then Dispose else Substitute o + +let inSyntaxExtension : syntax_extension_obj -> obj = + declare_object {(default_object "SYNTAX-EXTENSION") with + open_function = (fun i o -> if Int.equal i 1 then cache_syntax_extension o); + cache_function = cache_syntax_extension; + subst_function = subst_syntax_extension; + classify_function = classify_syntax_definition} + +(**************************************************************************) +(* Precedences *) + +(* Interpreting user-provided modifiers *) + +(* XXX: We could move this to the parser itself *) +module NotationMods = struct + +type notation_modifier = { + assoc : gram_assoc option; + level : int option; + etyps : (Id.t * simple_constr_prod_entry_key) list; + + (* common to syn_data below *) + only_parsing : bool; + only_printing : bool; + compat : compat_version option; + format : string Loc.located option; + extra : (string * string) list; +} + +let default = { + assoc = None; + level = None; + etyps = []; + only_parsing = false; + only_printing = false; + compat = None; + format = None; + extra = []; +} + +end + +let interp_modifiers modl = let open NotationMods in + let rec interp acc = function + | [] -> acc + | SetEntryType (s,typ) :: l -> + let id = Id.of_string s in + if Id.List.mem_assoc id acc.etyps then + user_err ~hdr:"Metasyntax.interp_modifiers" + (str s ++ str " is already assigned to an entry or constr level."); + interp { acc with etyps = (id,typ) :: acc.etyps; } l + | SetItemLevel ([],n) :: l -> + interp acc l + | SetItemLevel (s::idl,n) :: l -> + let id = Id.of_string s in + if Id.List.mem_assoc id acc.etyps then + user_err ~hdr:"Metasyntax.interp_modifiers" + (str s ++ str " is already assigned to an entry or constr level."); + let typ = ETConstr (n,()) in + interp { acc with etyps = (id,typ)::acc.etyps; } (SetItemLevel (idl,n)::l) + | SetLevel n :: l -> + + interp { acc with level = Some n; } l + | SetAssoc a :: l -> + if not (Option.is_empty acc.assoc) then error "An associativity is given more than once."; + interp { acc with assoc = Some a; } l + | SetOnlyParsing :: l -> + interp { acc with only_parsing = true; } l + | SetOnlyPrinting :: l -> + interp { acc with only_printing = true; } l + | SetCompatVersion v :: l -> + interp { acc with compat = Some v; } l + | SetFormat ("text",s) :: l -> + if not (Option.is_empty acc.format) then error "A format is given more than once."; + interp { acc with format = Some s; } l + | SetFormat (k,(_,s)) :: l -> + interp { acc with extra = (k,s)::acc.extra; } l + in interp default modl + +let check_infix_modifiers modifiers = + let t = (interp_modifiers modifiers).NotationMods.etyps in + if not (List.is_empty t) then + error "Explicit entry level or type unexpected in infix notation." + +let check_useless_entry_types recvars mainvars etyps = + let vars = let (l1,l2) = List.split recvars in l1@l2@mainvars in + match List.filter (fun (x,etyp) -> not (List.mem x vars)) etyps with + | (x,_)::_ -> user_err ~hdr:"Metasyntax.check_useless_entry_types" + (pr_id x ++ str " is unbound in the notation.") + | _ -> () + +let not_a_syntax_modifier = function +| SetOnlyParsing -> true +| SetOnlyPrinting -> true +| SetCompatVersion _ -> true +| _ -> false + +let no_syntax_modifiers mods = List.for_all not_a_syntax_modifier mods + +let is_only_parsing mods = + let test = function SetOnlyParsing -> true | _ -> false in + List.exists test mods + +let is_only_printing mods = + let test = function SetOnlyPrinting -> true | _ -> false in + List.exists test mods + +let get_compat_version mods = + let test = function SetCompatVersion v -> Some v | _ -> None in + try Some (List.find_map test mods) with Not_found -> None + +(* Compute precedences from modifiers (or find default ones) *) + +let set_entry_type etyps (x,typ) = + let typ = try + match List.assoc x etyps, typ with + | ETConstr (n,()), (_,BorderProd (left,_)) -> + ETConstr (n,BorderProd (left,None)) + | ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd) + | (ETPattern | ETName | ETBigint | ETOther _ | + ETReference | ETBinder _ as t), _ -> t + | (ETBinderList _ |ETConstrList _), _ -> assert false + with Not_found -> ETConstr typ + in (x,typ) + +let join_auxiliary_recursive_types recvars etyps = + List.fold_right (fun (x,y) typs -> + let xtyp = try Some (List.assoc x etyps) with Not_found -> None in + let ytyp = try Some (List.assoc y etyps) with Not_found -> None in + match xtyp,ytyp with + | None, None -> typs + | Some _, None -> typs + | None, Some ytyp -> (x,ytyp)::typs + | Some xtyp, Some ytyp when Pervasives.(=) xtyp ytyp -> typs (* FIXME *) + | Some xtyp, Some ytyp -> + user_err + (strbrk "In " ++ pr_id x ++ str " .. " ++ pr_id y ++ + strbrk ", both ends have incompatible types.")) + recvars etyps + +let internalization_type_of_entry_type = function + | ETConstr _ -> NtnInternTypeConstr + | ETBigint | ETReference -> NtnInternTypeConstr + | ETBinder _ -> NtnInternTypeBinder + | ETName -> NtnInternTypeIdent + | ETPattern | ETOther _ -> error "Not supported." + | ETBinderList _ | ETConstrList _ -> assert false + +let set_internalization_type typs = + List.map (fun (_, e) -> internalization_type_of_entry_type e) typs + +let make_internalization_vars recvars mainvars typs = + let maintyps = List.combine mainvars typs in + let extratyps = List.map (fun (x,y) -> (y,List.assoc x maintyps)) recvars in + maintyps @ extratyps + +let make_interpretation_type isrec isonlybinding = function + | NtnInternTypeConstr when isrec -> NtnTypeConstrList + | NtnInternTypeConstr | NtnInternTypeIdent -> + if isonlybinding then NtnTypeOnlyBinder else NtnTypeConstr + | NtnInternTypeBinder when isrec -> NtnTypeBinderList + | NtnInternTypeBinder -> error "Type binder is only for use in recursive notations for binders." + +let make_interpretation_vars recvars allvars = + let eq_subscope (sc1, l1) (sc2, l2) = + Option.equal String.equal sc1 sc2 && + 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 + 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 (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 _ | Break _ -> true | _ -> false) l then + error "A notation must include at least one symbol."; + if (match l with SProdList _ :: _ -> true | _ -> false) then + error "A recursive notation must start with at least one symbol." + +let warn_notation_bound_to_variable = + CWarnings.create ~name:"notation-bound-to-variable" ~category:"parsing" + (fun () -> + strbrk "This notation will not be used for printing as it is bound to a single variable.") + +let warn_non_reversible_notation = + CWarnings.create ~name:"non-reversible-notation" ~category:"parsing" + (fun () -> + strbrk "This notation will not be used for printing as it is not reversible.") + +let is_not_printable onlyparse nonreversible = function +| NVar _ -> + if not onlyparse then warn_notation_bound_to_variable (); + true +| _ -> + if not onlyparse && nonreversible then + (warn_non_reversible_notation (); true) + else onlyparse + +let find_precedence lev etyps symbols = + let first_symbol = + let rec aux = function + | Break _ :: t -> aux t + | h :: t -> h + | [] -> assert false (* rule is known to be productive *) in + aux symbols in + let last_is_terminal () = + let rec aux b = function + | Break _ :: t -> aux b t + | Terminal _ :: t -> aux true t + | _ :: t -> aux false t + | [] -> b in + aux false symbols in + match first_symbol with + | NonTerminal x -> + (try match List.assoc x etyps with + | ETConstr _ -> + error "The level of the leftmost non-terminal cannot be changed." + | ETName | ETBigint | ETReference -> + begin match lev with + | None -> + ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."],0) + | Some 0 -> + ([],0) + | _ -> + error "A notation starting with an atomic expression must be at level 0." + end + | ETPattern | ETBinder _ | ETOther _ -> (* Give a default ? *) + if Option.is_empty lev then + error "Need an explicit level." + else [],Option.get lev + | ETConstrList _ | ETBinderList _ -> + assert false (* internally used in grammar only *) + with Not_found -> + if Option.is_empty lev then + error "A left-recursive notation must have an explicit level." + else [],Option.get lev) + | Terminal _ when last_is_terminal () -> + if Option.is_empty lev then + ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."], 0) + else [],Option.get lev + | _ -> + if Option.is_empty lev then error "Cannot determine the level."; + [],Option.get lev + +let check_curly_brackets_notation_exists () = + try let _ = Notation.level_of_notation "{ _ }" in () + with Not_found -> + error "Notations involving patterns of the form \"{ _ }\" are treated \n\ +specially and require that the notation \"{ _ }\" is already reserved." + +let warn_skip_spaces_curly = + CWarnings.create ~name:"skip-spaces-curly" ~category:"parsing" + (fun () ->strbrk "Skipping spaces inside curly brackets") + +(* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *) +let remove_curly_brackets l = + let rec skip_break acc = function + | Break _ as br :: l -> skip_break (br::acc) l + | l -> List.rev acc, l in + let rec aux deb = function + | [] -> [] + | Terminal "{" as t1 :: l -> + let br,next = skip_break [] l in + (match next with + | NonTerminal _ as x :: l' as l0 -> + let br',next' = skip_break [] l' in + (match next' with + | Terminal "}" as t2 :: l'' as l1 -> + if not (List.equal Notation.symbol_eq l l0) || + not (List.equal Notation.symbol_eq l' l1) then + warn_skip_spaces_curly (); + if deb && List.is_empty l'' then [t1;x;t2] else begin + check_curly_brackets_notation_exists (); + x :: aux false l'' + end + | l1 -> t1 :: br @ x :: br' @ aux false l1) + | l0 -> t1 :: aux false l0) + | x :: l -> x :: aux false l + in aux true l + +module SynData = struct + + (* XXX: Document *) + type syn_data = { + + (* Notation name and location *) + info : notation * notation_location; + + (* Fields coming from the vernac-level modifiers *) + only_parsing : bool; + only_printing : bool; + compat : compat_version option; + format : string Loc.located option; + extra : (string * string) list; + + (* XXX: Callback to printing, must remove *) + msgs : ((std_ppcmds -> unit) * std_ppcmds) list; + + (* Fields for internalization *) + recvars : (Id.t * Id.t) list; + mainvars : Id.List.elt list; + intern_typs : notation_var_internalization_type list; + + (* Notation data for parsing *) + + level : int; + syntax_data : (Id.t * (production_level, production_position) constr_entry_key_gen) list * (* typs *) + symbol list; (* symbols *) + not_data : notation * (* notation *) + (int * parenRelation) list * (* precedence *) + bool; (* needs_squash *) + } + +end + +let compute_syntax_data df modifiers = + let open SynData in + let open NotationMods in + let mods = interp_modifiers modifiers in + let assoc = Option.append mods.assoc (Some NonA) in + let toks = split_notation_string df in + let recvars,mainvars,symbols = analyze_notation_tokens toks in + let _ = check_useless_entry_types recvars mainvars mods.etyps in + + (* Notations for interp and grammar *) + let ntn_for_interp = make_notation_key symbols in + let symbols' = remove_curly_brackets symbols in + let ntn_for_grammar = make_notation_key symbols' in + check_rule_productivity symbols'; + + (* Misc *) + let need_squash = not (List.equal Notation.symbol_eq symbols symbols') in + let msgs,n = find_precedence mods.level mods.etyps symbols' in + let innerlevel = NumLevel 200 in + let typs = + find_symbols + (NumLevel n,BorderProd(Left,assoc)) + (innerlevel,InternalProd) + (NumLevel n,BorderProd(Right,assoc)) + symbols' in + (* To globalize... *) + let etyps = join_auxiliary_recursive_types recvars mods.etyps in + let sy_typs = List.map (set_entry_type etyps) typs in + let prec = List.map (assoc_of_type n) sy_typs in + let i_typs = set_internalization_type sy_typs in + let sy_data = (sy_typs,symbols') in + let sy_fulldata = (ntn_for_grammar,prec,need_squash) in + let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in + let i_data = ntn_for_interp, df' in + + (* Return relevant data for interpretation and for parsing/printing *) + { info = i_data; + + only_parsing = mods.only_parsing; + only_printing = mods.only_printing; + compat = mods.compat; + format = mods.format; + extra = mods.extra; + + msgs; + + recvars; + mainvars; + intern_typs = i_typs; + + level = n; + syntax_data = sy_data; + not_data = sy_fulldata; + } + +let compute_pure_syntax_data df mods = + let open SynData in + let sd = compute_syntax_data df mods in + let msgs = + if sd.only_parsing then + (Feedback.msg_warning ?loc:None, + strbrk "The only parsing modifier has no effect in Reserved Notation.")::sd.msgs + else sd.msgs in + { sd with msgs } + +(**********************************************************************) +(* Registration of notations interpretation *) + +type notation_obj = { + notobj_local : bool; + notobj_scope : scope_name option; + notobj_interp : interpretation; + notobj_onlyparse : bool; + notobj_onlyprint : bool; + notobj_compat : Flags.compat_version option; + notobj_notation : notation * notation_location; +} + +let load_notation _ (_, nobj) = + Option.iter Notation.declare_scope nobj.notobj_scope + +let open_notation i (_, nobj) = + let scope = nobj.notobj_scope in + let (ntn, df) = nobj.notobj_notation in + let pat = nobj.notobj_interp in + let fresh = not (Notation.exists_notation_in_scope scope ntn pat) in + let active = is_active_compat nobj.notobj_compat in + if Int.equal i 1 && fresh && active then begin + (* Declare the interpretation *) + let onlyprint = nobj.notobj_onlyprint in + let () = Notation.declare_notation_interpretation ntn scope pat df ~onlyprint in + (* Declare the uninterpretation *) + if not nobj.notobj_onlyparse then + Notation.declare_uninterpretation (NotationRule (scope, ntn)) pat + end + +let cache_notation o = + load_notation 1 o; + open_notation 1 o + +let subst_notation (subst, nobj) = + { nobj with notobj_interp = subst_interpretation subst nobj.notobj_interp; } + +let classify_notation nobj = + if nobj.notobj_local then Dispose else Substitute nobj + +let inNotation : notation_obj -> obj = + declare_object {(default_object "NOTATION") with + open_function = open_notation; + cache_function = cache_notation; + subst_function = subst_notation; + load_function = load_notation; + classify_function = classify_notation} + +(**********************************************************************) + +let with_lib_stk_protection f x = + let fs = Lib.freeze `No in + try let a = f x in Lib.unfreeze fs; a + with reraise -> + let reraise = CErrors.push reraise in + let () = Lib.unfreeze fs in + iraise reraise + +let with_syntax_protection f x = + with_lib_stk_protection + (Pcoq.with_grammar_rule_protection + (with_notation_protection f)) x + +(**********************************************************************) +(* Recovering existing syntax *) + +let contract_notation ntn = + if String.equal ntn "{ _ }" then ntn else + let rec aux ntn i = + if i <= String.length ntn - 5 then + let ntn' = + if String.is_sub "{ _ }" ntn i && + (i = 0 || ntn.[i-1] = ' ') && + (i = String.length ntn - 5 || ntn.[i+5] = ' ') + then + String.sub ntn 0 i ^ "_" ^ + String.sub ntn (i+5) (String.length ntn -i-5) + else ntn in + aux ntn' (i+1) + else ntn in + aux ntn 0 + +exception NoSyntaxRule + +let recover_syntax ntn = + try + let prec = Notation.level_of_notation ntn in + let pp_rule,_ = Notation.find_notation_printing_rule ntn in + let pp_extra_rules = Notation.find_notation_extra_printing_rules ntn in + let pa_rule = Notation.find_notation_parsing_rules ntn in + { synext_level = prec; + synext_notation = ntn; + synext_notgram = pa_rule; + synext_unparsing = pp_rule; + synext_extra = pp_extra_rules; + synext_compat = None; + } + with Not_found -> + raise NoSyntaxRule + +let recover_squash_syntax sy = + let sq = recover_syntax "{ _ }" in + [sy; sq] + +let recover_notation_syntax rawntn = + let ntn = contract_notation rawntn in + let sy = recover_syntax ntn in + let need_squash = not (String.equal ntn rawntn) in + let rules = if need_squash then recover_squash_syntax sy else [sy] in + sy.synext_notgram.notgram_typs, rules, sy.synext_notgram.notgram_onlyprinting + +(**********************************************************************) +(* Main entry point for building parsing and printing rules *) + +let make_pa_rule i_typs level (typs,symbols) ntn onlyprint = + let assoc = recompute_assoc typs in + let prod = make_production typs symbols in + { notgram_level = level; + notgram_assoc = assoc; + notgram_notation = ntn; + notgram_prods = prod; + notgram_typs = i_typs; + notgram_onlyprinting = onlyprint; + } + +let make_pp_rule level (typs,symbols) fmt = + match fmt with + | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols level)] + | Some fmt -> hunks_of_format (level, List.split typs) (symbols, parse_format fmt) + +(* let make_syntax_rules i_typs (ntn,prec,need_squash) sy_data fmt extra onlyprint compat = *) +let make_syntax_rules (sd : SynData.syn_data) = let open SynData in + let ntn, prec, need_squash = sd.not_data in + let pa_rule = make_pa_rule sd.intern_typs sd.level sd.syntax_data ntn sd.only_printing in + let pp_rule = make_pp_rule sd.level sd.syntax_data sd.format in + let sy = { + synext_level = (sd.level, prec); + synext_notation = ntn; + synext_notgram = pa_rule; + synext_unparsing = pp_rule; + synext_extra = sd.extra; + synext_compat = sd.compat; + } in + (* By construction, the rule for "{ _ }" is declared, but we need to + redeclare it because the file where it is declared needs not be open + when the current file opens (especially in presence of -nois) *) + if need_squash then recover_squash_syntax sy else [sy] + +(**********************************************************************) +(* Main functions about notations *) + +let to_map l = + let fold accu (x, v) = Id.Map.add x v accu in + List.fold_left fold Id.Map.empty l + +let add_notation_in_scope local df c mods scope = + let open SynData in + let sd = compute_syntax_data df mods in + (* Prepare the interpretation *) + (* Prepare the parsing and printing rules *) + let sy_rules = make_syntax_rules sd in + let i_vars = make_internalization_vars sd.recvars sd.mainvars sd.intern_typs in + let nenv = { + ninterp_var_type = to_map i_vars; + ninterp_rec_vars = to_map sd.recvars; + } in + let (acvars, ac, reversible) = interp_notation_constr nenv c in + let interp = make_interpretation_vars sd.recvars acvars in + let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in + let onlyparse = is_not_printable sd.only_parsing (not reversible) ac in + let notation = { + notobj_local = local; + notobj_scope = scope; + notobj_interp = (List.map_filter map i_vars, ac); + (** Order is important here! *) + notobj_onlyparse = onlyparse; + notobj_onlyprint = sd.only_printing; + notobj_compat = sd.compat; + notobj_notation = sd.info; + } in + (* Ready to change the global state *) + Flags.if_verbose (List.iter (fun (f,x) -> f x)) sd.msgs; + Lib.add_anonymous_leaf (inSyntaxExtension (local, sy_rules)); + Lib.add_anonymous_leaf (inNotation notation); + sd.info + +let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat = + let dfs = split_notation_string df in + let recvars,mainvars,symbs = analyze_notation_tokens dfs in + (* Recover types of variables and pa/pp rules; redeclare them if needed *) + let i_typs, onlyprint = if not (is_numeral symbs) then begin + let i_typs,sy_rules,onlyprint' = recover_notation_syntax (make_notation_key symbs) in + let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules)) in + (** If the only printing flag has been explicitly requested, put it back *) + let onlyprint = onlyprint || onlyprint' in + i_typs, onlyprint + end else [], false in + (* Declare interpretation *) + let path = (Lib.library_dp(), Lib.current_dirpath true) in + let df' = (make_notation_key symbs, (path,df)) in + let i_vars = make_internalization_vars recvars mainvars i_typs in + let nenv = { + ninterp_var_type = to_map i_vars; + ninterp_rec_vars = to_map recvars; + } in + let (acvars, ac, reversible) = interp_notation_constr ~impls nenv c in + let interp = make_interpretation_vars recvars acvars in + let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in + let onlyparse = is_not_printable onlyparse (not reversible) ac in + let notation = { + notobj_local = local; + notobj_scope = scope; + notobj_interp = (List.map_filter map i_vars, ac); + (** Order is important here! *) + notobj_onlyparse = onlyparse; + notobj_onlyprint = onlyprint; + notobj_compat = compat; + notobj_notation = df'; + } in + Lib.add_anonymous_leaf (inNotation notation); + df' + +(* Notations without interpretation (Reserved Notation) *) + +let add_syntax_extension local ((loc,df),mods) = let open SynData in + let psd = compute_pure_syntax_data df mods in + let sy_rules = make_syntax_rules {psd with compat = None} in + Flags.if_verbose (List.iter (fun (f,x) -> f x)) psd.msgs; + Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)) + +(* Notations with only interpretation *) + +let add_notation_interpretation ((loc,df),c,sc) = + let df' = add_notation_interpretation_core false df c sc false false None in + Dumpglob.dump_notation (loc,df') sc true + +let set_notation_for_interpretation impls ((_,df),c,sc) = + (try ignore + (silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ()); + with NoSyntaxRule -> + error "Parsing rule for this notation has to be previously declared."); + Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc + +(* Main entry point *) + +let add_notation local c ((loc,df),modifiers) sc = + let df' = + if no_syntax_modifiers modifiers then + (* No syntax data: try to rely on a previously declared rule *) + let onlyparse = is_only_parsing modifiers in + let onlyprint = is_only_printing modifiers in + let compat = get_compat_version modifiers in + try add_notation_interpretation_core local df c sc onlyparse onlyprint compat + with NoSyntaxRule -> + (* Try to determine a default syntax rule *) + add_notation_in_scope local df c modifiers sc + else + (* Declare both syntax and interpretation *) + add_notation_in_scope local df c modifiers sc + in + Dumpglob.dump_notation (loc,df') sc true + +let add_notation_extra_printing_rule df k v = + let notk = + let dfs = split_notation_string df in + let _,_, symbs = analyze_notation_tokens dfs in + make_notation_key symbs in + Notation.add_notation_extra_printing_rule notk k v + +(* Infix notations *) + +let inject_var x = CRef (Ident (Loc.ghost, Id.of_string x),None) + +let add_infix local ((loc,inf),modifiers) pr sc = + check_infix_modifiers modifiers; + (* check the precedence *) + let metas = [inject_var "x"; inject_var "y"] in + let c = mkAppC (pr,metas) in + let df = "x "^(quote_notation_token inf)^" y" in + add_notation local c ((loc,df),modifiers) sc + +(**********************************************************************) +(* Delimiters and classes bound to scopes *) + +type scope_command = + | ScopeDelim of string + | ScopeClasses of scope_class list + | ScopeRemove + +let load_scope_command _ (_,(scope,dlm)) = + Notation.declare_scope scope + +let open_scope_command i (_,(scope,o)) = + if Int.equal i 1 then + match o with + | ScopeDelim dlm -> Notation.declare_delimiters scope dlm + | ScopeClasses cl -> List.iter (Notation.declare_scope_class scope) cl + | ScopeRemove -> Notation.remove_delimiters scope + +let cache_scope_command o = + load_scope_command 1 o; + open_scope_command 1 o + +let subst_scope_command (subst,(scope,o as x)) = match o with + | ScopeClasses cl -> + let cl' = List.map_filter (subst_scope_class subst) cl in + let cl' = + if List.for_all2eq (==) cl cl' then cl + else cl' in + scope, ScopeClasses cl' + | _ -> x + +let inScopeCommand : scope_name * scope_command -> obj = + declare_object {(default_object "DELIMITERS") with + cache_function = cache_scope_command; + open_function = open_scope_command; + load_function = load_scope_command; + subst_function = subst_scope_command; + classify_function = (fun obj -> Substitute obj)} + +let add_delimiters scope key = + Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key)) + +let remove_delimiters scope = + Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeRemove)) + +let add_class_scope scope cl = + Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl)) + +(* Check if abbreviation to a name and avoid early insertion of + maximal implicit arguments *) +let try_interp_name_alias = function + | [], CRef (ref,_) -> intern_reference ref + | _ -> raise Not_found + +let add_syntactic_definition ident (vars,c) local onlyparse = + let nonprintable = ref false in + let vars,pat = + try [], NRef (try_interp_name_alias (vars,c)) + with Not_found -> + let fold accu id = Id.Map.add id NtnInternTypeConstr accu in + let i_vars = List.fold_left fold Id.Map.empty vars in + let nenv = { + ninterp_var_type = i_vars; + ninterp_rec_vars = Id.Map.empty; + } in + let nvars, pat, reversible = interp_notation_constr nenv c in + let () = nonprintable := not reversible 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 + | None when (is_not_printable false !nonprintable pat) -> Some Flags.Current + | p -> p + in + Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat) diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli new file mode 100644 index 0000000000..57c1204022 --- /dev/null +++ b/vernac/metasyntax.mli @@ -0,0 +1,63 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit + +(** Adding a (constr) notation in the environment*) + +val add_infix : locality_flag -> (lstring * syntax_modifier list) -> + constr_expr -> scope_name option -> unit + +val add_notation : locality_flag -> constr_expr -> + (lstring * syntax_modifier list) -> scope_name option -> unit + +val add_notation_extra_printing_rule : string -> string -> string -> unit + +(** Declaring delimiter keys and default scopes *) + +val add_delimiters : scope_name -> string -> unit +val remove_delimiters : scope_name -> unit +val add_class_scope : scope_name -> scope_class list -> unit + +(** Add only the interpretation of a notation that already has pa/pp rules *) + +val add_notation_interpretation : + (lstring * constr_expr * scope_name option) -> unit + +(** Add a notation interpretation for supporting the "where" clause *) + +val set_notation_for_interpretation : Constrintern.internalization_env -> + (lstring * constr_expr * scope_name option) -> unit + +(** Add only the parsing/printing rule of a notation *) + +val add_syntax_extension : + locality_flag -> (lstring * syntax_modifier list) -> unit + +(** Add a syntactic definition (as in "Notation f := ...") *) + +val add_syntactic_definition : Id.t -> Id.t list * constr_expr -> + bool -> Flags.compat_version option -> unit + +(** Print the Camlp4 state of a grammar *) + +val pr_grammar : string -> Pp.std_ppcmds + +type any_entry = AnyEntry : 'a Pcoq.Gram.entry -> any_entry + +val register_grammar : string -> any_entry list -> unit + +val check_infix_modifiers : syntax_modifier list -> unit + +val with_syntax_protection : ('a -> 'b) -> 'a -> 'b diff --git a/vernac/mltop.ml b/vernac/mltop.ml new file mode 100644 index 0000000000..2396cf04a4 --- /dev/null +++ b/vernac/mltop.ml @@ -0,0 +1,447 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit; + use_file : string -> unit; + add_dir : string -> unit; + ml_loop : unit -> unit } + +(* Determines the behaviour of Coq with respect to ML files (compiled + or not) *) +type kind_load = + | WithTop of toplevel + | WithoutTop + +(* Must be always initialized *) +let load = ref WithoutTop + +(* Are we in a native version of Coq? *) +let is_native = Dynlink.is_native + +(* Sets and initializes a toplevel (if any) *) +let set_top toplevel = load := + WithTop toplevel; + Nativelib.load_obj := toplevel.load_obj + +(* Removes the toplevel (if any) *) +let remove () = + load := WithoutTop; + Nativelib.load_obj := (fun x -> () : string -> unit) + +(* Tests if an Ocaml toplevel runs under Coq *) +let is_ocaml_top () = + match !load with + | WithTop _ -> true + |_ -> false + +(* Tests if we can load ML files *) +let has_dynlink = Coq_config.has_natdynlink || not is_native + +(* Runs the toplevel loop of Ocaml *) +let ocaml_toploop () = + match !load with + | WithTop t -> Printexc.catch t.ml_loop () + | _ -> () + +(* Try to interpret load_obj's (internal) errors *) +let report_on_load_obj_error exc = + let x = Obj.repr exc in + (* Try an horrible (fragile) hack to report on Symtable dynlink errors *) + (* (we follow ocaml's Printexc.to_string decoding of exceptions) *) + if Obj.is_block x && String.equal (Obj.magic (Obj.field (Obj.field x 0) 0)) "Symtable.Error" + then + let err_block = Obj.field x 1 in + if Int.equal (Obj.tag err_block) 0 then + (* Symtable.Undefined_global of string *) + str "reference to undefined global " ++ + str (Obj.magic (Obj.field err_block 0)) + else str (Printexc.to_string exc) + else str (Printexc.to_string exc) + +(* Dynamic loading of .cmo/.cma *) + +let ml_load s = + match !load with + | WithTop t -> + (try t.load_obj s; s + with + | e when CErrors.noncritical e -> + let e = CErrors.push e in + match fst e with + | (UserError _ | Failure _ | Not_found as u) -> Exninfo.iraise (u, snd e) + | exc -> + let msg = report_on_load_obj_error exc in + user_err ~hdr:"Mltop.load_object" (str"Cannot link ml-object " ++ + str s ++ str" to Coq code (" ++ msg ++ str ").")) + | WithoutTop -> + try + Dynlink.loadfile s; s + with Dynlink.Error a -> + user_err ~hdr:"Mltop.load_object" + (strbrk "while loading " ++ str s ++ + strbrk ": " ++ str (Dynlink.error_message a)) + +let dir_ml_load s = + match !load with + | WithTop _ -> ml_load s + | WithoutTop -> + let warn = Flags.is_verbose() in + let _,gname = find_file_in_path ~warn !coq_mlpath_copy s in + ml_load gname + +(* Dynamic interpretation of .ml *) +let dir_ml_use s = + match !load with + | WithTop t -> t.use_file s + | _ -> + let moreinfo = + if Dynlink.is_native then " Loading ML code works only in bytecode." + else "" + in + user_err ~hdr:"Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo) + +(* Adds a path to the ML paths *) +let add_ml_dir s = + match !load with + | WithTop t -> t.add_dir s; keep_copy_mlpath s + | WithoutTop when has_dynlink -> keep_copy_mlpath s + | _ -> () + +(* For Rec Add ML Path (-R) *) +let add_rec_ml_dir unix_path = + List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs ~unix_path) + +(* Adding files to Coq and ML loadpath *) + +let warn_cannot_use_directory = + CWarnings.create ~name:"cannot-use-directory" ~category:"filesystem" + (fun d -> + str "Directory " ++ str d ++ + strbrk " cannot be used as a Coq identifier (skipped)") + +let convert_string d = + try Names.Id.of_string d + with UserError _ -> + warn_cannot_use_directory d; + raise Exit + +let warn_cannot_open_path = + CWarnings.create ~name:"cannot-open-path" ~category:"filesystem" + (fun unix_path -> str "Cannot open " ++ str unix_path) + +type add_ml = AddNoML | AddTopML | AddRecML + +let add_rec_path add_ml ~unix_path ~coq_root ~implicit = + if exists_dir unix_path then + let dirs = all_subdirs ~unix_path in + let prefix = Names.DirPath.repr coq_root in + let convert_dirs (lp, cp) = + try + let path = List.rev_map convert_string cp @ prefix in + Some (lp, Names.DirPath.make path) + with Exit -> None + in + let dirs = List.map_filter convert_dirs dirs in + let () = match add_ml with + | AddNoML -> () + | AddTopML -> add_ml_dir unix_path + | AddRecML -> List.iter (fun (lp,_) -> add_ml_dir lp) dirs in + let add (path, dir) = + Loadpath.add_load_path path ~implicit dir in + let () = List.iter add dirs in + Loadpath.add_load_path unix_path ~implicit coq_root + else + warn_cannot_open_path unix_path + +(* convertit un nom quelconque en nom de fichier ou de module *) +let mod_of_name name = + if Filename.check_suffix name ".cmo" then + Filename.chop_suffix name ".cmo" + else + name + +let get_ml_object_suffix name = + if Filename.check_suffix name ".cmo" then + Some ".cmo" + else if Filename.check_suffix name ".cma" then + Some ".cma" + else if Filename.check_suffix name ".cmxs" then + Some ".cmxs" + else + None + +let file_of_name name = + let suffix = get_ml_object_suffix name in + let fail s = + user_err ~hdr:"Mltop.load_object" + (str"File not found on loadpath : " ++ str s ++ str"\n" ++ + str"Loadpath: " ++ str(String.concat ":" !coq_mlpath_copy)) in + if not (Filename.is_relative name) then + if Sys.file_exists name then name else fail name + else if is_native then + let name = match suffix with + | Some ((".cmo"|".cma") as suffix) -> + (Filename.chop_suffix name suffix) ^ ".cmxs" + | Some ".cmxs" -> name + | _ -> name ^ ".cmxs" + in + if is_in_path !coq_mlpath_copy name then name else fail name + else + let (full, base) = match suffix with + | Some ".cmo" | Some ".cma" -> true, name + | Some ".cmxs" -> false, Filename.chop_suffix name ".cmxs" + | _ -> false, name + in + if full then + if is_in_path !coq_mlpath_copy base then base else fail base + else + let name = base ^ ".cma" in + if is_in_path !coq_mlpath_copy name then name else + let name = base ^ ".cmo" in + if is_in_path !coq_mlpath_copy name then name else + fail (base ^ ".cm[ao]") + +(** Is the ML code of the standard library placed into loadable plugins + or statically compiled into coqtop ? For the moment this choice is + made according to the presence of native dynlink : even if bytecode + coqtop could always load plugins, we prefer to have uniformity between + bytecode and native versions. *) + +(* [known_loaded_module] contains the names of the loaded ML modules + * (linked or loaded with load_object). It is used not to load a + * module twice. It is NOT the list of ML modules Coq knows. *) + +let known_loaded_modules = ref String.Map.empty + +let add_known_module mname path = + if not (String.Map.mem mname !known_loaded_modules) || + String.Map.find mname !known_loaded_modules = None then + known_loaded_modules := String.Map.add mname path !known_loaded_modules + +let module_is_known mname = + String.Map.mem mname !known_loaded_modules + +let known_module_path mname = + String.Map.find mname !known_loaded_modules + +(** A plugin is just an ML module with an initialization function. *) + +let known_loaded_plugins = ref String.Map.empty + +let add_known_plugin init name = + add_known_module name None; + known_loaded_plugins := String.Map.add name init !known_loaded_plugins + +let init_known_plugins () = + String.Map.iter (fun _ f -> f()) !known_loaded_plugins + +(** Registering functions to be used at caching time, that is when the Declare + ML module command is issued. *) + +let cache_objs = ref String.Map.empty + +let declare_cache_obj f name = + let objs = try String.Map.find name !cache_objs with Not_found -> [] in + let objs = f :: objs in + cache_objs := String.Map.add name objs !cache_objs + +let perform_cache_obj name = + let objs = try String.Map.find name !cache_objs with Not_found -> [] in + let objs = List.rev objs in + List.iter (fun f -> f ()) objs + +(** ml object = ml module or plugin *) + +let init_ml_object mname = + try String.Map.find mname !known_loaded_plugins () + with Not_found -> () + +let load_ml_object mname ?path fname= + let path = match path with + | None -> dir_ml_load fname + | Some p -> ml_load p in + add_known_module mname (Some path); + init_ml_object mname; + path + +let dir_ml_load m = ignore(dir_ml_load m) +let add_known_module m = add_known_module m None +let load_ml_object_raw fname = dir_ml_load (file_of_name fname) +let load_ml_objects_raw_rex rex = + List.iter (fun (_,fp) -> + let name = file_of_name (Filename.basename fp) in + try dir_ml_load name + with e -> prerr_endline (Printexc.to_string e)) + (System.where_in_path_rex !coq_mlpath_copy rex) + +(* Summary of declared ML Modules *) + +(* List and not String.Set because order is important: most recent first. *) + +let loaded_modules = ref [] +let get_loaded_modules () = List.rev !loaded_modules +let add_loaded_module md path = + if not (List.mem_assoc md !loaded_modules) then + loaded_modules := (md,path) :: !loaded_modules +let reset_loaded_modules () = loaded_modules := [] + +let if_verbose_load verb f name ?path fname = + if not verb then f name ?path fname + else + let info = str "[Loading ML file " ++ str fname ++ str " ..." in + try + let path = f name ?path fname in + Feedback.msg_info (info ++ str " done]"); + path + with reraise -> + Feedback.msg_info (info ++ str " failed]"); + raise reraise + +(** Load a module for the first time (i.e. dynlink it) + or simulate its reload (i.e. doing nothing except maybe + an initialization function). *) + +let trigger_ml_object verb cache reinit ?path name = + if module_is_known name then begin + if reinit then init_ml_object name; + add_loaded_module name (known_module_path name); + if cache then perform_cache_obj name + end else if not has_dynlink then + user_err ~hdr:"Mltop.trigger_ml_object" + (str "Dynamic link not supported (module " ++ str name ++ str ")") + else begin + let file = file_of_name (Option.default name path) in + let path = + if_verbose_load (verb && is_verbose ()) load_ml_object name ?path file in + add_loaded_module name (Some path); + if cache then perform_cache_obj name + end + +let load_ml_object n m = ignore(load_ml_object n m) + +let unfreeze_ml_modules x = + reset_loaded_modules (); + List.iter + (fun (name,path) -> trigger_ml_object false false false ?path name) x + +let _ = + Summary.declare_summary Summary.ml_modules + { Summary.freeze_function = (fun _ -> get_loaded_modules ()); + Summary.unfreeze_function = unfreeze_ml_modules; + Summary.init_function = reset_loaded_modules } + +(* Liboject entries of declared ML Modules *) + +type ml_module_object = { + mlocal : Vernacexpr.locality_flag; + mnames : string list +} + +let cache_ml_objects (_,{mnames=mnames}) = + let iter obj = trigger_ml_object true true true obj in + List.iter iter mnames + +let load_ml_objects _ (_,{mnames=mnames}) = + let iter obj = trigger_ml_object true false true obj in + List.iter iter mnames + +let classify_ml_objects ({mlocal=mlocal} as o) = + if mlocal then Dispose else Substitute o + +let inMLModule : ml_module_object -> obj = + declare_object + {(default_object "ML-MODULE") with + cache_function = cache_ml_objects; + load_function = load_ml_objects; + subst_function = (fun (_,o) -> o); + classify_function = classify_ml_objects } + +let declare_ml_modules local l = + let l = List.map mod_of_name l in + Lib.add_anonymous_leaf ~cache_first:false (inMLModule {mlocal=local; mnames=l}) + +let print_ml_path () = + let l = !coq_mlpath_copy in + str"ML Load Path:" ++ fnl () ++ str" " ++ + hv 0 (prlist_with_sep fnl str l) + +(* Printing of loaded ML modules *) + +let print_ml_modules () = + let l = get_loaded_modules () in + str"Loaded ML Modules: " ++ pr_vertical_list str (List.map fst l) + +let print_gc () = + let stat = Gc.stat () in + let msg = + str "minor words: " ++ real stat.Gc.minor_words ++ fnl () ++ + str "promoted words: " ++ real stat.Gc.promoted_words ++ fnl () ++ + str "major words: " ++ real stat.Gc.major_words ++ fnl () ++ + str "minor_collections: " ++ int stat.Gc.minor_collections ++ fnl () ++ + str "major_collections: " ++ int stat.Gc.major_collections ++ fnl () ++ + str "heap_words: " ++ int stat.Gc.heap_words ++ fnl () ++ + str "heap_chunks: " ++ int stat.Gc.heap_chunks ++ fnl () ++ + str "live_words: " ++ int stat.Gc.live_words ++ fnl () ++ + str "live_blocks: " ++ int stat.Gc.live_blocks ++ fnl () ++ + str "free_words: " ++ int stat.Gc.free_words ++ fnl () ++ + str "free_blocks: " ++ int stat.Gc.free_blocks ++ fnl () ++ + str "largest_free: " ++ int stat.Gc.largest_free ++ fnl () ++ + str "fragments: " ++ int stat.Gc.fragments ++ fnl () ++ + str "compactions: " ++ int stat.Gc.compactions ++ fnl () ++ + str "top_heap_words: " ++ int stat.Gc.top_heap_words ++ fnl () ++ + str "stack_size: " ++ int stat.Gc.stack_size + in + hv 0 msg diff --git a/vernac/mltop.mli b/vernac/mltop.mli new file mode 100644 index 0000000000..6633cb9372 --- /dev/null +++ b/vernac/mltop.mli @@ -0,0 +1,88 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit; + use_file : string -> unit; + add_dir : string -> unit; + ml_loop : unit -> unit } + +(** Sets and initializes a toplevel (if any) *) +val set_top : toplevel -> unit + +(** Are we in a native version of Coq? *) +val is_native : bool + +(** Removes the toplevel (if any) *) +val remove : unit -> unit + +(** Tests if an Ocaml toplevel runs under Coq *) +val is_ocaml_top : unit -> bool + +(** Starts the Ocaml toplevel loop *) +val ocaml_toploop : unit -> unit + +(** {5 ML Dynlink} *) + +(** Tests if we can load ML files *) +val has_dynlink : bool + +(** Dynamic loading of .cmo *) +val dir_ml_load : string -> unit + +(** Dynamic interpretation of .ml *) +val dir_ml_use : string -> unit + +(** Adds a path to the ML paths *) +val add_ml_dir : string -> unit +val add_rec_ml_dir : string -> unit + +type add_ml = AddNoML | AddTopML | AddRecML + +(** Adds a path to the Coq and ML paths *) +val add_rec_path : add_ml -> unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit + +(** List of modules linked to the toplevel *) +val add_known_module : string -> unit +val module_is_known : string -> bool +val load_ml_object : string -> string -> unit +val load_ml_object_raw : string -> unit +val load_ml_objects_raw_rex : Str.regexp -> unit + +(** {5 Initialization functions} *) + +(** Declare a plugin and its initialization function. + A plugin is just an ML module with an initialization function. + Adding a known plugin implies adding it as a known ML module. + The initialization function is granted to be called after Coq is fully + bootstrapped, even if the plugin is statically linked with the toplevel *) +val add_known_plugin : (unit -> unit) -> string -> unit + +(** Calls all initialization functions in a non-specified order *) +val init_known_plugins : unit -> unit + +(** Register a callback that will be called when the module is declared with + the Declare ML Module command. This is useful to define Coq objects at that + time only. Several functions can be defined for one module; they will be + called in the order of declaration, and after the ML module has been + properly initialized. *) +val declare_cache_obj : (unit -> unit) -> string -> unit + +(** {5 Declaring modules} *) + +val declare_ml_modules : Vernacexpr.locality_flag -> string list -> unit + +(** {5 Utilities} *) + +val print_ml_path : unit -> Pp.std_ppcmds +val print_ml_modules : unit -> Pp.std_ppcmds +val print_gc : unit -> Pp.std_ppcmds diff --git a/vernac/obligations.ml b/vernac/obligations.ml new file mode 100644 index 0000000000..c1d9ae48a5 --- /dev/null +++ b/vernac/obligations.ml @@ -0,0 +1,1179 @@ +open Printf +open Globnames +open Libobject +open Entries +open Decl_kinds +open Declare + +(** + - Get types of existentials ; + - Flatten dependency tree (prefix order) ; + - Replace existentials by De Bruijn indices in term, applied to the right arguments ; + - Apply term prefixed by quantification on "existentials". +*) + +open Term +open Vars +open Names +open Evd +open Pp +open CErrors +open Util + +(* EJGA: This should go away, no more need for fix_exn *) +module Stm = struct + let u = (fun x -> x) + let get_fix_exn () = u +end + +module NamedDecl = Context.Named.Declaration + +let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> assert false) +let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false) + +let succfix (depth, fixrels) = + (succ depth, List.map succ fixrels) + +let check_evars env evm = + Evar.Map.iter + (fun key evi -> + let (loc,k) = evar_source key evm in + match k with + | Evar_kinds.QuestionMark _ + | Evar_kinds.ImplicitArg (_,_,false) -> () + | _ -> + Pretype_errors.error_unsolvable_implicit ~loc env evm key None) + (Evd.undefined_map evm) + +type oblinfo = + { ev_name: int * Id.t; + ev_hyps: Context.Named.t; + ev_status: bool * Evar_kinds.obligation_definition_status; + ev_chop: int option; + ev_src: Evar_kinds.t Loc.located; + ev_typ: types; + ev_tac: unit Proofview.tactic option; + ev_deps: Int.Set.t } + +(** Substitute evar references in t using De Bruijn indices, + where n binders were passed through. *) + +let subst_evar_constr evs n idf t = + 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 + let rec substrec (depth, fixrels) c = match kind_of_term c with + | Evar (k, args) -> + let { ev_name = (id, idstr) ; + ev_hyps = hyps ; ev_chop = chop } = + try evar_info k + with Not_found -> + anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found") + in + seen := Int.Set.add id !seen; + (* Evar arguments are created in inverse order, + and we must not apply to defined ones (i.e. LetIn's) + *) + let args = + let n = match chop with None -> 0 | Some c -> c in + let (l, r) = List.chop n (List.rev (Array.to_list args)) in + List.rev r + in + let args = + let rec aux hyps args acc = + let open Context.Named.Declaration in + match hyps, args with + (LocalAssum _ :: tlh), (c :: tla) -> + aux tlh tla ((substrec (depth, fixrels) c) :: acc) + | (LocalDef _ :: tlh), (_ :: tla) -> + aux tlh tla acc + | [], [] -> acc + | _, _ -> acc (*failwith "subst_evars: invalid argument"*) + in aux hyps args [] + in + if List.exists + (fun x -> match kind_of_term x with + | Rel n -> Int.List.mem n fixrels + | _ -> false) args + then + transparent := Id.Set.add idstr !transparent; + mkApp (idf idstr, Array.of_list args) + | Fix _ -> + map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c + | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c + in + let t' = substrec (0, []) t in + t', !seen, !transparent + + +(** Substitute variable references in t using De Bruijn indices, + where n binders were passed through. *) +let subst_vars acc n t = + let var_index id = Util.List.index Id.equal id acc in + let rec substrec depth c = match kind_of_term c with + | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c) + | _ -> map_constr_with_binders succ substrec depth c + in + substrec 0 t + +(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) + to a product : forall H1 : t1, ..., forall Hn : tn, concl. + 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 + decl :: tl -> + let t', s, trans = subst_evar_constr evs n mkVar (NamedDecl.get_type decl) in + let t'' = subst_vars acc 0 t' in + let rest, s', trans' = aux (NamedDecl.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 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 (LocalDef (id, c', t'')) rest, + Int.Set.union s'' s', + Id.Set.union trans'' 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 + in aux [] 0 (List.rev hyps) + +let trunc_named_context n ctx = + let len = List.length ctx in + List.firstn (len - n) ctx + +let rec chop_product n t = + if Int.equal n 0 then Some t + else + match kind_of_term t with + | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None + | _ -> None + +let evar_dependencies evm oev = + let one_step deps = + Evar.Set.fold (fun ev s -> + let evi = Evd.find evm ev in + let deps' = evars_of_filtered_evar_info evi in + if Evar.Set.mem oev deps' then + invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ string_of_existential oev) + else Evar.Set.union deps' s) + deps deps + in + let rec aux deps = + let deps' = one_step deps in + if Evar.Set.equal deps deps' then deps + else aux deps' + in aux (Evar.Set.singleton oev) + +let move_after (id, ev, deps as obl) l = + let rec aux restdeps = function + | (id', _, _) as obl' :: tl -> + let restdeps' = Evar.Set.remove id' restdeps in + if Evar.Set.is_empty restdeps' then + obl' :: obl :: tl + else obl' :: aux restdeps' tl + | [] -> [obl] + in aux (Evar.Set.remove id deps) l + +let sort_dependencies evl = + let rec aux l found list = + match l with + | (id, ev, deps) as obl :: tl -> + let found' = Evar.Set.union found (Evar.Set.singleton id) in + if Evar.Set.subset deps found' then + aux tl found' (obl :: list) + else aux (move_after obl tl) found list + | [] -> List.rev list + in aux evl Evar.Set.empty [] + +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.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 + let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in + let sevl = sort_dependencies evl in + let evl = List.map (fun (id, ev, _) -> id, ev) sevl in + let evn = + let i = ref (-1) in + List.rev_map (fun (id, ev) -> incr i; + (id, (!i, Id.of_string + (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i))), + ev)) evl + in + let evts = + (* Remove existential variables in types and build the corresponding products *) + List.fold_right + (fun (id, (n, nstr), ev) l -> + let hyps = Evd.evar_filtered_context ev in + let hyps = trunc_named_context nc_len hyps in + let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in + let evtyp, hyps, chop = + match chop_product fs evtyp with + | Some t -> t, trunc_named_context fs hyps, fs + | None -> evtyp, hyps, 0 + in + let loc, k = evar_source id evm in + let status = match k with + | Evar_kinds.QuestionMark o -> o + | _ -> match status with + | Some o -> o + | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ())) + in + let force_status, status, chop = match status with + | Evar_kinds.Define true as stat -> + if not (Int.equal chop fs) then true, Evar_kinds.Define false, None + else false, stat, Some chop + | s -> false, s, None + in + let info = { ev_name = (n, nstr); + ev_hyps = hyps; ev_status = force_status, status; ev_chop = chop; + ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = None } + in (id, info) :: l) + evn [] + in + let t', _, transparent = (* Substitute evar refs in the term by variables *) + subst_evar_constr evts 0 mkVar t + in + let ty, _, _ = subst_evar_constr evts 0 mkVar ty in + let evars = + List.map (fun (ev, info) -> + let { ev_name = (_, name); ev_status = force_status, status; + ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info + in + let force_status, status = match status with + | Evar_kinds.Define true when Id.Set.mem name transparent -> + true, Evar_kinds.Define false + | _ -> force_status, status + in name, typ, src, (force_status, status), deps, tac) evts + in + let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in + let evmap f c = pi1 (subst_evar_constr evts 0 f c) in + Array.of_list (List.rev evars), (evnames, evmap), t', ty + +let tactics_module = ["Program";"Tactics"] +let safe_init_constant md name () = + Coqlib.check_required_library ("Coq"::md); + Coqlib.gen_constant "Obligations" md name +let hide_obligation = safe_init_constant tactics_module "obligation" + +let pperror cmd = CErrors.user_err ~hdr:"Program" cmd +let error s = pperror (str s) + +let reduce c = + Reductionops.clos_norm_flags CClosure.betaiota (Global.env ()) Evd.empty c + +exception NoObligations of Id.t option + +let explain_no_obligations = function + Some ident -> str "No obligations for program " ++ Id.print ident + | None -> str "No obligations remaining" + +type obligation_info = + (Names.Id.t * Term.types * Evar_kinds.t Loc.located * + (bool * Evar_kinds.obligation_definition_status) + * Int.Set.t * unit Proofview.tactic option) array + +type 'a obligation_body = + | DefinedObl of 'a + | TermObl of constr + +type obligation = + { obl_name : Id.t; + obl_type : types; + obl_location : Evar_kinds.t Loc.located; + obl_body : constant obligation_body option; + obl_status : bool * Evar_kinds.obligation_definition_status; + obl_deps : Int.Set.t; + obl_tac : unit Proofview.tactic option; + } + +type obligations = (obligation array * int) + +type fixpoint_kind = + | IsFixpoint of (Id.t Loc.located option * Constrexpr.recursion_order_expr) list + | IsCoFixpoint + +type notations = (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list + +type program_info_aux = { + prg_name: Id.t; + 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 ; + prg_implicits : (Constrexpr.explicitation * (bool * bool * bool)) list; + prg_notations : notations ; + prg_kind : definition_kind; + 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 CEphemeron.key + +let get_info x = + try CEphemeron.get x + with CEphemeron.InvalidKey -> + CErrors.anomaly Pp.(str "Program obligation can't be accessed by a worker") + +let assumption_message = Declare.assumption_message + +let default_tactic = ref (Proofview.tclUNIT ()) + +(* true = hide obligations *) +let hide_obligations = ref false + +let set_hide_obligations = (:=) hide_obligations +let get_hide_obligations () = !hide_obligations + +open Goptions +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "Hidding of Program obligations"; + optkey = ["Hide";"Obligations"]; + optread = get_hide_obligations; + optwrite = set_hide_obligations; } + +let shrink_obligations = ref true + +let set_shrink_obligations = (:=) shrink_obligations +let get_shrink_obligations () = !shrink_obligations + +let _ = + declare_bool_option + { optsync = true; + optdepr = true; + optname = "Shrinking of Program obligations"; + optkey = ["Shrink";"Obligations"]; + optread = get_shrink_obligations; + optwrite = set_shrink_obligations; } + +let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type + +let get_body obl = + match obl.obl_body with + | None -> None + | Some (DefinedObl c) -> + let ctx = Environ.constant_context (Global.env ()) c in + let pc = (c, Univ.UContext.instance ctx) in + Some (DefinedObl pc) + | Some (TermObl c) -> + Some (TermObl c) + +let get_obligation_body expand obl = + match get_body obl with + | None -> None + | Some c -> + if expand && snd obl.obl_status == Evar_kinds.Expand then + match c with + | DefinedObl pc -> Some (constant_value_in (Global.env ()) pc) + | TermObl c -> Some c + else (match c with + | DefinedObl pc -> Some (mkConstU pc) + | TermObl c -> Some c) + +let obl_substitution expand obls deps = + Int.Set.fold + (fun x acc -> + let xobl = obls.(x) in + match get_obligation_body expand xobl with + | None -> acc + | Some oblb -> (xobl.obl_name, (xobl.obl_type, oblb)) :: acc) + deps [] + +let subst_deps expand obls deps t = + let osubst = obl_substitution expand obls deps in + (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t) + +let rec prod_app t n = + match kind_of_term (Termops.strip_outer_cast t) with + | Prod (_,_,b) -> subst1 n b + | LetIn (_, b, t, b') -> prod_app (subst1 b b') n + | _ -> + user_err ~hdr:"prod_app" + (str"Needed a product, but didn't find one" ++ fnl ()) + + +(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) +let prod_applist t nL = List.fold_left prod_app t nL + +let replace_appvars subst = + let rec aux c = + let f, l = decompose_app c in + if isVar f then + try + let c' = List.map (map_constr aux) l in + let (t, b) = Id.List.assoc (destVar f) subst in + mkApp (delayed_force hide_obligation, + [| prod_applist t c'; applistc b c' |]) + with Not_found -> map_constr aux c + else map_constr aux c + in map_constr aux + +let subst_prog expand obls ints prg = + let subst = obl_substitution expand obls ints in + if get_hide_obligations () then + (replace_appvars subst prg.prg_body, + replace_appvars subst ((* Termops.refresh_universes *) prg.prg_type)) + else + let subst' = List.map (fun (n, (_, b)) -> n, b) subst in + (Vars.replace_vars subst' prg.prg_body, + Vars.replace_vars subst' ((* Termops.refresh_universes *) prg.prg_type)) + +let subst_deps_obl obls obl = + let t' = subst_deps true obls obl.obl_deps obl.obl_type in + { obl with obl_type = t' } + +module ProgMap = Id.Map + +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 [] + +let from_prg : program_info ProgMap.t ref = + Summary.ref ProgMap.empty ~name:"program-tcc-table" + +let close sec = + if not (ProgMap.is_empty !from_prg) then + let keys = map_keys !from_prg in + user_err ~hdr:"Program" + (str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++ + prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++ + (str (if Int.equal (List.length keys) 1 then " has " else " have ") ++ + str "unsolved obligations")) + +let input : program_info ProgMap.t -> obj = + declare_object + { (default_object "Program state") with + cache_function = (fun (na, pi) -> from_prg := pi); + load_function = (fun _ (_, pi) -> from_prg := pi); + discharge_function = (fun _ -> close "section"; None); + classify_function = (fun _ -> close "module"; Dispose) } + +open Evd + +let progmap_remove prg = + Lib.add_anonymous_leaf (input (ProgMap.remove prg.prg_name !from_prg)) + +let progmap_add n prg = + Lib.add_anonymous_leaf (input (ProgMap.add n prg !from_prg)) + +let progmap_replace prg' = + Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !from_prg)) + +let rec intset_to = function + -1 -> Int.Set.empty + | n -> Int.Set.add n (intset_to (pred n)) + +let subst_body expand prg = + let obls, _ = prg.prg_obligations in + let ints = intset_to (pred (Array.length obls)) in + subst_prog expand obls ints prg + +let declare_definition prg = + let body, typ = subst_body true prg in + 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 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 + 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)) + in + Universes.register_universe_binders cst pl; + cst + +open Pp + +let rec lam_index n t acc = + match kind_of_term t with + | Lambda (Name n', _, _) when Id.equal n n' -> + acc + | Lambda (_, _, b) -> + lam_index n b (succ acc) + | _ -> raise Not_found + +let compute_possible_guardness_evidences (n,_) fixbody fixtype = + match n with + | Some (loc, n) -> [lam_index n fixbody 0] + | None -> + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual + fixpoints ?) *) + 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 + +let mk_proof c = ((c, Univ.ContextSet.empty), Safe_typing.empty_private_constants) + +let declare_mutual_definition l = + let len = List.length l in + let first = List.hd l in + let fixdefs, fixtypes, fiximps = + List.split3 + (List.map (fun x -> + let subs, typ = (subst_body true x) in + let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in + let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in + x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l) + in +(* let fixdefs = List.map reduce_fix fixdefs in *) + let fixkind = Option.get first.prg_fixkind in + let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in + let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in + let (local,poly,kind) = first.prg_kind in + let fixnames = first.prg_deps in + let opaque = first.prg_opaque in + let kind = if fixkind != IsCoFixpoint then Fixpoint else CoFixpoint in + let indexes, fixdecls = + match fixkind with + | IsFixpoint wfl -> + let possible_indexes = + List.map3 compute_possible_guardness_evidences + wfl fixdefs fixtypes in + let indexes = + Pretyping.search_guard + Loc.ghost (Global.env()) + possible_indexes fixdecls in + Some indexes, + List.map_i (fun i _ -> + mk_proof (mkFix ((indexes,i),fixdecls))) 0 l + | IsCoFixpoint -> + None, + List.map_i (fun i _ -> + mk_proof (mkCoFix (i,fixdecls))) 0 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 *) + List.iter Metasyntax.add_notation_interpretation first.prg_notations; + 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 fix_exn first.prg_hook local gr first.prg_ctx; + List.iter progmap_remove l; kn + +let decompose_lam_prod c ty = + let open Context.Rel.Declaration in + let rec aux ctx c ty = + match kind_of_term c, kind_of_term ty with + | LetIn (x, b, t, c), LetIn (x', b', t', ty) + when eq_constr b b' && eq_constr t t' -> + let ctx' = Context.Rel.add (LocalDef (x,b',t')) ctx in + aux ctx' c ty + | _, LetIn (x', b', t', ty) -> + let ctx' = Context.Rel.add (LocalDef (x',b',t')) ctx in + aux ctx' (lift 1 c) ty + | LetIn (x, b, t, c), _ -> + let ctx' = Context.Rel.add (LocalDef (x,b,t)) ctx in + aux ctx' c (lift 1 ty) + | Lambda (x, b, t), Prod (x', b', t') + (* By invariant, must be convertible *) -> + let ctx' = Context.Rel.add (LocalAssum (x,b')) ctx in + aux ctx' t t' + | Cast (c, _, _), _ -> aux ctx c ty + | _, _ -> ctx, c, ty + in aux Context.Rel.empty c ty + +let shrink_body c ty = + let ctx, b, ty = + match ty with + | None -> + let ctx, b = decompose_lam_assum c in + ctx, b, None + | Some ty -> + let ctx, b, ty = decompose_lam_prod c ty in + ctx, b, Some ty + in + let b', ty', n, args = + List.fold_left (fun (b, ty, i, args) decl -> + if noccurn 1 b && Option.cata (noccurn 1) true ty then + subst1 mkProp b, Option.map (subst1 mkProp) ty, succ i, args + else + let open Context.Rel.Declaration in + let args = if is_local_assum decl then mkRel i :: args else args in + mkLambda_or_LetIn decl b, Option.map (mkProd_or_LetIn decl) ty, + succ i, args) + (b, ty, 1, []) ctx + in ctx, b', ty', Array.of_list args + +let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] + +let add_hint local prg cst = + Hints.add_hints local [Id.to_string prg.prg_name] (unfold_entry cst) + +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 -> false, { obl with obl_body = Some (TermObl body) } + | force, Evar_kinds.Define opaque -> + let opaque = not force && opaque in + let poly = pi2 prg.prg_kind in + let ctx, body, ty, args = + if get_shrink_obligations () && not poly then + shrink_body body ty else [], body, ty, [||] + in + let body = ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in + let ce = + { const_entry_body = Future.from_val ~fix_exn:(fun x -> x) body; + const_entry_secctx = None; + const_entry_type = ty; + const_entry_polymorphic = poly; + const_entry_universes = uctx; + const_entry_opaque = opaque; + const_entry_inline_code = false; + const_entry_feedback = None; + } in + (** ppedrot: seems legit to have obligations as local *) + let constant = Declare.declare_constant obl.obl_name ~local:true + (DefinitionEntry ce,IsProof Property) + in + if not opaque then add_hint false prg constant; + definition_message obl.obl_name; + true, { obl with obl_body = + if poly then + Some (DefinedObl constant) + else + Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) } + +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 -> + assert(Int.equal (Array.length obls) 0); + let n = Nameops.add_suffix n "_obligation" in + [| { obl_name = n; obl_body = None; + obl_location = Loc.ghost, Evar_kinds.InternalHole; obl_type = t; + obl_status = false, Evar_kinds.Expand; obl_deps = Int.Set.empty; + obl_tac = None } |], + mkVar n + | Some b -> + Array.mapi + (fun i (n, t, l, o, d, tac) -> + { obl_name = n ; obl_body = None; + obl_location = l; obl_type = t; obl_status = o; + obl_deps = d; obl_tac = tac }) + obls, b + in + { prg_name = n ; prg_body = b; prg_type = reduce t; + 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; + prg_hook = hook; prg_opaque = opaque; + prg_sign = sign } + +let map_cardinal m = + let i = ref 0 in + ProgMap.iter (fun _ v -> + if snd (CEphemeron.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 (CEphemeron.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 + Some n -> + (try get_info (ProgMap.find n prg_infos) + with Not_found -> raise (NoObligations (Some n))) + | None -> + (let n = map_cardinal prg_infos in + match n with + 0 -> raise (NoObligations None) + | 1 -> get_info (map_first prg_infos) + | _ -> + let progs = Id.Set.elements (ProgMap.domain prg_infos) in + let prog = List.hd progs in + let progs = prlist_with_sep pr_comma Nameops.pr_id progs in + user_err + (str "More than one program with unsolved obligations: " ++ progs + ++ str "; use the \"of\" clause to specify, as in \"Obligation 1 of " ++ Nameops.pr_id prog ++ str "\"")) + +let get_any_prog () = + let prg_infos = !from_prg in + let n = map_cardinal prg_infos in + if n > 0 then get_info (map_first prg_infos) + else raise (NoObligations None) + +let get_prog_err n = + try get_prog n with NoObligations id -> pperror (explain_no_obligations id) + +let get_any_prog_err () = + try get_any_prog () with NoObligations id -> pperror (explain_no_obligations id) + +let obligations_solved prg = Int.equal (snd prg.prg_obligations) 0 + +let all_programs () = + ProgMap.fold (fun k p l -> p :: l) !from_prg [] + +type progress = + | Remain of int + | Dependent + | Defined of global_reference + +let obligations_message rem = + if rem > 0 then + if Int.equal rem 1 then + Flags.if_verbose Feedback.msg_info (int rem ++ str " obligation remaining") + else + Flags.if_verbose Feedback.msg_info (int rem ++ str " obligations remaining") + else + Flags.if_verbose Feedback.msg_info (str "No more obligations remaining") + +let update_obls prg obls rem = + let prg' = { prg with prg_obligations = (obls, rem) } in + progmap_replace prg'; + obligations_message rem; + if rem > 0 then Remain rem + else ( + match prg'.prg_deps with + | [] -> + let kn = declare_definition prg' in + progmap_remove prg'; + Defined kn + | l -> + let progs = List.map (fun x -> get_info (ProgMap.find x !from_prg)) prg'.prg_deps in + if List.for_all (fun x -> obligations_solved x) progs then + let kn = declare_mutual_definition progs in + Defined (ConstRef kn) + else Dependent) + +let is_defined obls x = not (Option.is_empty obls.(x).obl_body) + +let deps_remaining obls deps = + Int.Set.fold + (fun x acc -> + if is_defined obls x then acc + else x :: acc) + deps [] + +let dependencies obls n = + let res = ref Int.Set.empty in + Array.iteri + (fun i obl -> + if not (Int.equal i n) && Int.Set.mem n obl.obl_deps then + res := Int.Set.add i !res) + obls; + !res + +let goal_kind poly = Decl_kinds.Local, poly, Decl_kinds.DefinitionBody Decl_kinds.Definition + +let goal_proof_kind poly = Decl_kinds.Local, poly, Decl_kinds.Proof Decl_kinds.Lemma + +let kind_of_obligation poly o = + match o with + | Evar_kinds.Define false | Evar_kinds.Expand -> goal_kind poly + | _ -> goal_proof_kind poly + +let not_transp_msg = + str "Obligation should be transparent but was declared opaque." ++ spc () ++ + str"Use 'Defined' instead." + +let err_not_transp () = pperror not_transp_msg + +let rec string_of_list sep f = function + [] -> "" + | x :: [] -> f x + | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl + +(* Solve an obligation using tactics, return the corresponding proof term *) + +let solve_by_tac name evi t poly ctx = + let id = name in + let concl = evi.evar_concl in + (* spiwack: the status is dropped. *) + 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 = 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.const_entry_type, Evd.evar_universe_context ctx' + +let obligation_terminator name num guard hook auto pf = + let open Proof_global in + let term = Lemmas.universe_proof_terminator guard hook in + match pf with + | Admitted _ -> apply_terminator term pf + | Proved (opq, id, proof) -> + if not !shrink_obligations then apply_terminator term pf + else + let (_, (entry, uctx, _)) = Pfedit.cook_this_proof proof in + let env = Global.env () in + let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in + let ty = entry.Entries.const_entry_type in + let (body, cstr), eff = Future.force entry.Entries.const_entry_body in + assert(Safe_typing.empty_private_constants = eff); + let sigma = Evd.from_ctx (fst uctx) in + let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in + Inductiveops.control_only_guard (Global.env ()) body; + (** Declare the obligation ourselves and drop the hook *) + let prg = get_info (ProgMap.find name !from_prg) in + let ctx = Evd.evar_universe_context sigma in + let prg = { prg with prg_ctx = ctx } in + let obls, rem = prg.prg_obligations in + let obl = obls.(num) in + let status = + match obl.obl_status, opq with + | (_, Evar_kinds.Expand), Vernacexpr.Opaque _ -> err_not_transp () + | (true, _), Vernacexpr.Opaque _ -> err_not_transp () + | (false, _), Vernacexpr.Opaque _ -> Evar_kinds.Define true + | (_, Evar_kinds.Define true), Vernacexpr.Transparent -> Evar_kinds.Define false + | (_, status), Vernacexpr.Transparent -> status + in + let obl = { obl with obl_status = false, status } in + let uctx = Evd.evar_context_universe_context ctx in + let (_, obl) = declare_obligation prg obl body ty uctx in + let obls = Array.copy obls in + let _ = obls.(num) <- obl in + try + ignore (update_obls prg obls (pred rem)); + if pred rem > 0 then + begin + let deps = dependencies obls num in + if not (Int.Set.is_empty deps) then + ignore (auto (Some name) None deps) + end + with e when CErrors.noncritical e -> + let e = CErrors.push e in + pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e)) + +let obligation_hook prg obl num auto ctx' _ gr = + let obls, rem = prg.prg_obligations in + let cst = match gr with ConstRef cst -> cst | _ -> assert false in + let transparent = evaluable_constant cst (Global.env ()) in + let () = match obl.obl_status with + (true, Evar_kinds.Expand) + | (true, Evar_kinds.Define true) -> + if not transparent then err_not_transp () + | _ -> () +in + let obl = { obl with obl_body = Some (DefinedObl cst) } in + let () = if transparent then add_hint true prg cst in + let obls = Array.copy obls in + let _ = obls.(num) <- obl in + let ctx' = match ctx' with None -> prg.prg_ctx | Some ctx' -> ctx' in + let ctx' = + if not (pi2 prg.prg_kind) (* Not polymorphic *) then + (* The universe context was declared globally, we continue + from the new global environment. *) + 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 + let () = + try ignore (update_obls prg obls (pred rem)) + with e when CErrors.noncritical e -> + let e = CErrors.push e in + pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e)) + in + if pred rem > 0 then begin + let deps = dependencies obls num in + if not (Int.Set.is_empty deps) then + ignore (auto (Some prg.prg_name) None deps) + end + +let rec solve_obligation prg num tac = + let user_num = succ num in + let obls, rem = prg.prg_obligations in + let obl = obls.(num) in + let remaining = deps_remaining obls obl.obl_deps in + let () = + if not (Option.is_empty obl.obl_body) then + pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved."); + if not (List.is_empty remaining) then + pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " + ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) remaining)); + in + let obl = subst_deps_obl obls obl in + let kind = kind_of_obligation (pi2 prg.prg_kind) (snd 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 terminator guard hook = + Proof_global.make_terminator + (obligation_terminator prg.prg_name num guard hook auto) 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 ~terminator hook in + let _ = Pfedit.by !default_tactic in + Option.iter (fun tac -> Pfedit.set_end_tac tac) tac + +and obligation (user_num, name, typ) tac = + let num = pred user_num in + let prg = get_prog_err name in + let obls, rem = prg.prg_obligations in + if num < Array.length obls then + let obl = obls.(num) in + match obl.obl_body with + None -> solve_obligation prg num tac + | Some r -> error "Obligation already solved" + else error (sprintf "Unknown obligation number %i" (succ num)) + + +and solve_obligation_by_tac prg obls i tac = + let obl = obls.(i) in + match obl.obl_body with + | Some _ -> None + | None -> + try + if List.is_empty (deps_remaining obls obl.obl_deps) then + let obl = subst_deps_obl obls obl in + let tac = + match tac with + | Some t -> t + | None -> + match obl.obl_tac with + | Some t -> t + | None -> !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) (Evd.evar_universe_context evd) + in + let uctx = Evd.evar_context_universe_context ctx in + 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 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 + Some {prg with prg_ctx = ctx'}) + else Some prg + else None + with e when CErrors.noncritical e -> + let (e, _) = CErrors.push e in + match e with + | Refiner.FailError (_, s) -> + user_err ~loc:(fst obl.obl_location) ~hdr:"solve_obligation" (Lazy.force s) + | e -> None (* FIXME really ? *) + +and solve_prg_obligations prg ?oblset tac = + let obls, rem = prg.prg_obligations in + let rem = ref rem in + let obls' = Array.copy obls in + let set = ref Int.Set.empty in + let p = match oblset with + | None -> (fun _ -> true) + | Some s -> set := s; + (fun i -> Int.Set.mem i !set) + in + let prgref = ref prg in + let _ = + Array.iteri (fun i x -> + if p i then + match solve_obligation_by_tac !prgref obls' i tac with + | None -> () + | Some prg' -> + prgref := prg'; + let deps = dependencies obls i in + (set := Int.Set.union !set deps; + decr rem)) + obls' + in + update_obls !prgref obls' !rem + +and solve_obligations n tac = + let prg = get_prog_err n in + solve_prg_obligations prg tac + +and solve_all_obligations tac = + ProgMap.iter (fun k v -> ignore(solve_prg_obligations (get_info v) tac)) !from_prg + +and try_solve_obligation n prg tac = + let prg = get_prog prg in + let obls, rem = prg.prg_obligations in + let obls' = Array.copy obls in + match solve_obligation_by_tac prg obls' n tac with + | Some prg' -> ignore(update_obls prg' obls' (pred rem)) + | None -> () + +and try_solve_obligations n tac = + try ignore (solve_obligations n tac) with NoObligations _ -> () + +and auto_solve_obligations n ?oblset tac : progress = + Flags.if_verbose Feedback.msg_info (str "Solving obligations automatically..."); + try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent + +open Pp +let show_obligations_of_prg ?(msg=true) prg = + let n = prg.prg_name in + let obls, rem = prg.prg_obligations in + let showed = ref 5 in + if msg then Feedback.msg_info (int rem ++ str " obligation(s) remaining: "); + Array.iteri (fun i x -> + match x.obl_body with + | None -> + if !showed > 0 then ( + decr showed; + let x = subst_deps_obl obls x in + Feedback.msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ 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 _ -> ()) + obls + +let show_obligations ?(msg=true) n = + let progs = match n with + | None -> all_programs () + | Some n -> + try [ProgMap.find n !from_prg] + with Not_found -> raise (NoObligations (Some n)) + in List.iter (fun x -> show_obligations_of_prg ~msg (get_info x)) progs + +let show_term n = + let prg = get_prog_err n in + let n = prg.prg_name in + (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 ?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 = Id.print n ++ str " has type-checked" 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 Feedback.msg_info (info ++ str "."); + let cst = declare_definition prg in + Defined cst) + else ( + let len = Array.length obls in + let _ = Flags.if_verbose Feedback.msg_info (info ++ str ", generating " ++ int len ++ str " obligation(s)") in + 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 + | _ -> res) + +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 pl (Some b) t ctx deps (Some fixkind) + notations obls imps kind reduce hook + in progmap_add n (CEphemeron.create prg)) l; + let _defined = + List.fold_left (fun finished x -> + if finished then finished + else + let res = auto_solve_obligations (Some x) tactic in + match res with + | Defined _ -> + (* If one definition is turned into a constant, + the whole block is defined. *) true + | _ -> false) + false deps + in () + +let admit_prog prg = + let obls, rem = prg.prg_obligations in + let obls = Array.copy obls in + Array.iteri + (fun i x -> + match x.obl_body with + | None -> + let x = subst_deps_obl obls x in + let ctx = Evd.evar_context_universe_context prg.prg_ctx in + let kn = Declare.declare_constant x.obl_name ~local:true + (ParameterEntry (None,false,(x.obl_type,ctx),None), IsAssumption Conjectural) + in + assumption_message x.obl_name; + obls.(i) <- { x with obl_body = Some (DefinedObl kn) } + | Some _ -> ()) + obls; + ignore(update_obls prg obls 0) + +let rec admit_all_obligations () = + let prg = try Some (get_any_prog ()) with NoObligations _ -> None in + match prg with + | None -> () + | Some prg -> + admit_prog prg; + admit_all_obligations () + +let admit_obligations n = + match n with + | None -> admit_all_obligations () + | Some _ -> + let prg = get_prog_err n in + admit_prog prg + +let next_obligation n tac = + let prg = match n with + | None -> get_any_prog_err () + | Some _ -> get_prog_err n + in + let obls, rem = prg.prg_obligations in + let is_open _ x = Option.is_empty x.obl_body && List.is_empty (deps_remaining obls x.obl_deps) in + let i = match Array.findi is_open obls with + | Some i -> i + | None -> anomaly (Pp.str "Could not find a solvable obligation.") + in + solve_obligation prg i tac + +let init_program () = + Coqlib.check_required_library Coqlib.datatypes_module_name; + Coqlib.check_required_library ["Coq";"Init";"Specif"]; + Coqlib.check_required_library ["Coq";"Program";"Tactics"] + + +let set_program_mode c = + if c then + if !Flags.program_mode then () + else begin + init_program (); + Flags.program_mode := true; + end diff --git a/vernac/obligations.mli b/vernac/obligations.mli new file mode 100644 index 0000000000..80b6891447 --- /dev/null +++ b/vernac/obligations.mli @@ -0,0 +1,113 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* definition_kind -> Univ.universe_context -> Id.t -> + Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref + +val declare_definition_ref : + (Id.t -> definition_kind -> + 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 + +val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t +val sort_dependencies : (Evar.t * evar_info * Evar.Set.t) list -> (Evar.t * evar_info * Evar.Set.t) list + +(* env, id, evars, number of function prototypes to try to clear from + evars contexts, object and type *) +val eterm_obligations : env -> Id.t -> evar_map -> int -> + ?status:Evar_kinds.obligation_definition_status -> constr -> types -> + (Id.t * types * Evar_kinds.t Loc.located * + (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * + unit Proofview.tactic option) array + (* Existential key, obl. name, type as product, + location of the original evar, associated tactic, + status and dependencies as indexes into the array *) + * ((existential_key * Id.t) list * ((Id.t -> constr) -> constr -> constr)) * + constr * types + (* Translations from existential identifiers to obligation identifiers + and for terms with existentials to closed terms, given a + translation from obligation identifiers to constrs, new term, new type *) + +type obligation_info = + (Id.t * Term.types * Evar_kinds.t Loc.located * + (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * unit Proofview.tactic option) array + (* ident, type, location, (opaque or transparent, expand or define), + dependencies, tactic to solve it *) + +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 default_tactic : unit Proofview.tactic ref + +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 -> + ?reduce:(Term.constr -> Term.constr) -> + ?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 + +type fixpoint_kind = + | IsFixpoint of (Id.t Loc.located option * Constrexpr.recursion_order_expr) list + | IsCoFixpoint + +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) -> + ?hook:(Evd.evar_universe_context -> unit) Lemmas.declaration_hook -> ?opaque:bool -> + notations -> + fixpoint_kind -> unit + +val obligation : int * Names.Id.t option * Constrexpr.constr_expr option -> + Genarg.glob_generic_argument option -> unit + +val next_obligation : Names.Id.t option -> Genarg.glob_generic_argument option -> unit + +val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress +(* Number of remaining obligations to be solved for this program *) + +val solve_all_obligations : unit Proofview.tactic option -> unit + +val try_solve_obligation : int -> Names.Id.t option -> unit Proofview.tactic option -> unit + +val try_solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> unit + +val show_obligations : ?msg:bool -> Names.Id.t option -> unit + +val show_term : Names.Id.t option -> std_ppcmds + +val admit_obligations : Names.Id.t option -> unit + +exception NoObligations of Names.Id.t option + +val explain_no_obligations : Names.Id.t option -> Pp.std_ppcmds + +val set_program_mode : bool -> unit diff --git a/vernac/record.ml b/vernac/record.ml new file mode 100644 index 0000000000..d5faafaf89 --- /dev/null +++ b/vernac/record.ml @@ -0,0 +1,583 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* !primitive_flag) ; + optwrite = (fun b -> primitive_flag := b) } + +let typeclasses_strict = ref false +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "strict typeclass resolution"; + optkey = ["Typeclasses";"Strict";"Resolution"]; + optread = (fun () -> !typeclasses_strict); + optwrite = (fun b -> typeclasses_strict := b); } + +let typeclasses_unique = ref false +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "unique typeclass instances"; + optkey = ["Typeclasses";"Unique";"Instances"]; + optread = (fun () -> !typeclasses_unique); + optwrite = (fun b -> typeclasses_unique := b); } + +let interp_fields_evars env evars impls_env nots l = + List.fold_left2 + (fun (env, uimpls, params, impls) no ((loc, i), b, t) -> + let t', impl = interp_type_evars_impls env evars ~impls t in + let b' = Option.map (fun x -> fst (interp_casted_constr_evars_impls env evars ~impls x t')) b in + let impls = + match i with + | Anonymous -> impls + | Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method t' impl) impls + 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 d (env, univ) -> + let univ = + if is_local_assum d then + let s = Retyping.get_sort_of env evars (RelDecl.get_type d) in + Univ.sup (univ_of_sort s) univ + else univ + in (push_rel d env, univ)) + l (env, Univ.type0m_univ) + +let binder_of_decl = function + | Vernacexpr.AssumExpr(n,t) -> (n,None,t) + | Vernacexpr.DefExpr(n,c,t) -> (n,Some c, match t with Some c -> c | None -> CHole (fst n, None, Misctypes.IntroAnonymous, None)) + +let binders_of_decls = List.map binder_of_decl + +let typecheck_params_and_fields def id pl t ps nots fs = + let env0 = Global.env () 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 + | Default _, Anonymous -> + user_err ~loc ~hdr:"record" (str "Record parameters must be named") + | _ -> () + in + List.iter + (function LocalRawDef (b, _) -> error default_binder_kind b + | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls + | LocalPattern _ -> assert false) ps + in + let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in + let t', template = match t with + | Some t -> + let env = push_rel_context newps env0 in + let poly = + match t with + | CSort (_, Misctypes.GType []) -> true | _ -> false in + let s = interp_type_evars env evars ~impls:empty_internalization_env t in + let sred = Reductionops.whd_all env !evars s in + (match kind_of_term sred with + | Sort s' -> + (if poly then + match Evd.is_sort_variable !evars s' with + | Some l -> evars := Evd.make_flexible_variable !evars true l; + sred, true + | None -> s, false + else s, false) + | _ -> user_err ~loc:(constr_loc t) (str"Sort expected.")) + | None -> + 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 (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 + let sigma = + 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 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 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 + 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 = Context.Rel.map nf newps in + let newfs = Context.Rel.map nf newfs 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 + +let degenerate_decl decl = + let id = match RelDecl.get_name decl with + | Name id -> id + | Anonymous -> anomaly (Pp.str "Unnamed record variable") in + match decl with + | LocalAssum (_,t) -> (id, LocalAssumEntry t) + | LocalDef (_,b,_) -> (id, LocalDefEntry b) + +type record_error = + | MissingProj of Id.t * Id.t list + | BadTypedProj of Id.t * env * Type_errors.type_error + +let warn_cannot_define_projection = + CWarnings.create ~name:"cannot-define-projection" ~category:"records" + (fun msg -> hov 0 msg) + +(* If a projection is not definable, we throw an error if the user +asked it to be a coercion. Otherwise, we just print an info +message. The user might still want to name the field of the record. *) +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 + (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.") + | BadTypedProj (fi,ctx,te) -> + match te with + | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) -> + (pr_id fi ++ + strbrk" cannot be defined because it is informative and " ++ + Printer.pr_inductive (Global.env()) indsp ++ + strbrk " is not.") + | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) -> + (pr_id fi ++ + strbrk" cannot be defined because it is large and " ++ + Printer.pr_inductive (Global.env()) indsp ++ + strbrk " is not.") + | _ -> + (pr_id fi ++ strbrk " cannot be defined because it is not typable.") + in + if coe then user_err ~hdr:"structure" st; + Flags.if_verbose Feedback.msg_info (hov 0 st) + +type field_status = + | NoProjection of Name.t + | Projection of constr + +exception NotDefinable of record_error + +(* This replaces previous projection bodies in current projection *) +(* Undefined projs are collected and, at least one undefined proj occurs *) +(* in the body of current projection then the latter can not be defined *) +(* [c] is defined in ctxt [[params;fields]] and [l] is an instance of *) +(* [[fields]] defined in ctxt [[params;x:ind]] *) +let subst_projection fid l c = + let lv = List.length l in + let bad_projs = ref [] in + let rec substrec depth c = match kind_of_term c with + | Rel k -> + (* We are in context [[params;fields;x:ind;...depth...]] *) + if k <= depth+1 then + c + else if k-depth-1 <= lv then + match List.nth l (k-depth-2) with + | Projection t -> lift depth t + | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k + | NoProjection Anonymous -> + user_err (str "Field " ++ pr_id fid ++ + str " depends on the " ++ pr_nth (k-depth-1) ++ str + " field which has no name.") + else + mkRel (k-lv) + | _ -> map_constr_with_binders succ substrec depth c + in + let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *) + let c'' = substrec 0 c' in + if not (List.is_empty !bad_projs) then + raise (NotDefinable (MissingProj (fid,List.rev !bad_projs))); + c'' + +let instantiate_possibly_recursive_type indu paramdecls fields = + let subst = List.map_i (fun i _ -> mkRel i) 1 paramdecls in + Termops.substl_rel_context (subst@[mkIndU indu]) fields + +let warn_non_primitive_record = + CWarnings.create ~name:"non-primitive-record" ~category:"record" + (fun (env,indsp) -> + (hov 0 (str "The record " ++ Printer.pr_inductive env indsp ++ + strbrk" could not be defined as a primitive record"))) + +(* We build projections *) +let declare_projections indsp ?(kind=StructureComponent) binder_name coers fieldimpls fields = + let env = Global.env() in + 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 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, 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 + let primitive = + if !primitive_flag then + let is_primitive = + match mib.mind_record with + | Some (Some _) -> true + | Some None | None -> false + in + if not is_primitive then + warn_non_primitive_record (env,indsp); + is_primitive + else false + in + let (_,_,kinds,sp_projs,_) = + List.fold_left3 + (fun (nfi,i,kinds,sp_projs,subst) coe decl impls -> + let fi = RelDecl.get_name decl in + let ti = RelDecl.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 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 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 + let p = mkLambda (x, lift 1 rp, ccl') in + let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in + let ci = Inductiveops.make_case_info env indsp LetStyle in + mkCase (ci, p, mkRel 1, [|branch|]) + in + let proj = + it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in + let projtyp = + it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in + try + let entry = { + const_entry_body = + Future.from_val (Safe_typing.mk_pure_proof proj); + const_entry_secctx = None; + const_entry_type = Some projtyp; + const_entry_polymorphic = poly; + 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 + let k = (DefinitionEntry entry,IsDefinition kind) 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) + in + Declare.definition_message fid; + kn, constr_fip + with Type_errors.TypeError (ctx,te) -> + raise (NotDefinable (BadTypedProj (fid,ctx,te))) + in + let refi = ConstRef kn in + Impargs.maybe_declare_manual_implicits false refi impls; + if coe then begin + 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 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, 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 + | [decl] -> + let env = Environ.empty_named_context_val in + let evm = Sigma.Unsafe.of_evar_map evm in + let Sigma (_, evm, _) = Evarutil.new_pure_evar env evm (RelDecl.get_type decl) in + let evm = Sigma.to_evar_map evm in + evm + | decl::tl -> + let env = Environ.empty_named_context_val in + let evm = Sigma.Unsafe.of_evar_map evm in + let Sigma (ev, evm, _) = Evarutil.new_pure_evar env evm (RelDecl.get_type decl) in + let evm = Sigma.to_evar_map evm in + let new_tl = Util.List.map_i + (fun pos decl -> + RelDecl.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) + +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.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 = + match name with + | None -> Id.of_string (Unicode.lowercase_first_char (Id.to_string id)) + | Some n -> n + in + let mie_ind = + { mind_entry_typename = id; + mind_entry_arity = arity; + mind_entry_template = not poly && template; + mind_entry_consnames = [idbuild]; + mind_entry_lc = [type_constructor] } + in + let mie = + { mind_entry_params = List.map degenerate_decl params; + mind_entry_record = Some (if !primitive_flag then Some binder_name else None); + mind_entry_finite = finite; + mind_entry_inds = [mie_ind]; + 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 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 + let build = ConstructRef cstr in + let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in + Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs); + rsp + +let implicits_of_context ctx = + List.map_i (fun i name -> + let explname = + match name with + | Name n -> Some n + | Anonymous -> None + in ExplByPos (i, explname), (true, true, true)) + 1 (List.rev (Anonymous :: (List.map RelDecl.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 = + let fieldimpls = + (* Make the class implicit in the projections, and the params if applicable. *) + let len = List.length params in + let impls = implicits_of_context params in + List.map (fun x -> impls @ Impargs.lift_implicits (succ len) x) fieldimpls + in + let binder_name = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in + let impl, projs = + match fields with + | [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 = + 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 + 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) + coers priorities + in + let l = List.map3 (fun decl b y -> RelDecl.get_name decl, b, y) + (List.rev fields) coers (Recordops.lookup_projections ind) + in IndRef ind, l + in + let ctx_context = + List.map (fun decl -> + match Typeclasses.class_of_constr (RelDecl.get_type decl) with + | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true) + | None -> None) + params, params + in + let k = + { cl_impl = impl; + cl_strict = !typeclasses_strict; + cl_unique = !typeclasses_unique; + cl_context = ctx_context; + cl_props = fields; + cl_projs = projs } + in + add_class k; impl + + +let add_constant_class cst = + let ty = Universes.unsafe_type_of_global (ConstRef cst) in + let ctx, arity = decompose_prod_assum ty in + let tc = + { cl_impl = ConstRef cst; + cl_context = (List.map (const None) ctx, ctx); + cl_props = [LocalAssum (Anonymous, arity)]; + cl_projs = []; + cl_strict = !typeclasses_strict; + cl_unique = !typeclasses_unique + } + in add_class tc; + set_typeclass_transparency (EvalConstRef cst) false false + +let add_inductive_class ind = + let mind, oneind = Global.lookup_inductive ind in + let k = + let ctx = oneind.mind_arity_ctxt in + let inst = Univ.UContext.instance mind.mind_universes in + let ty = Inductive.type_of_inductive + (push_rel_context ctx (Global.env ())) + ((mind,oneind),inst) + in + { cl_impl = IndRef ind; + cl_context = List.map (const None) ctx, ctx; + cl_props = [LocalAssum (Anonymous, ty)]; + cl_projs = []; + cl_strict = !typeclasses_strict; + cl_unique = !typeclasses_unique } + in add_class k + +let declare_existing_class g = + match g with + | ConstRef x -> add_constant_class x + | IndRef x -> add_inductive_class x + | _ -> user_err ~hdr:"declare_existing_class" + (Pp.str"Unsupported class type, only constants and inductives are allowed") + +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),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 + let extract_name acc = function + Vernacexpr.AssumExpr((_,Name id),_) -> id::acc + | Vernacexpr.DefExpr ((_,Name id),_,_) -> id::acc + | _ -> acc in + let allnames = idstruc::(List.fold_left extract_name [] fs) in + let () = match List.duplicates Id.equal allnames with + | [] -> () + | id :: _ -> user_err (str "Two objects have the same name" ++ spc () ++ quote (Id.print id)) + in + let isnot_class = match kind with Class false -> false | _ -> true in + 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 (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 + let gr = match kind with + | Class def -> + let priorities = List.map (fun id -> {hint_priority = id; hint_pattern = None}) priorities in + let gr = declare_class finite def poly ctx (loc,idstruc) idbuild + implpars params arity template implfs fields is_coe coers priorities sign in + gr + | _ -> + let implfs = List.map + (fun impls -> implpars @ Impargs.lift_implicits + (succ (List.length params)) impls) implfs in + let ind = declare_structure finite poly ctx idstruc + 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/vernac/record.mli b/vernac/record.mli new file mode 100644 index 0000000000..c50e577860 --- /dev/null +++ b/vernac/record.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ?kind:Decl_kinds.definition_object_kind -> Id.t -> + 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 -> Context.Rel.t -> (** params *) constr -> (** arity *) + bool (** template arity ? *) -> + Impargs.manual_explicitation list list -> Context.Rel.t -> (** fields *) + ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t -> + bool -> (** coercion? *) + bool list -> (** field coercions *) + Evd.evar_map -> + inductive + +val definition_structure : + 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 + +val declare_existing_class : global_reference -> unit diff --git a/vernac/search.ml b/vernac/search.ml new file mode 100644 index 0000000000..e1b56b1319 --- /dev/null +++ b/vernac/search.ml @@ -0,0 +1,381 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* env -> constr -> bool +type display_function = global_reference -> env -> constr -> unit + +(* This option restricts the output of [SearchPattern ...], +[SearchAbout ...], etc. to the names of the symbols matching the +query, separated by a newline. This type of output is useful for +editors (like emacs), to generate a list of completion candidates +without having to parse thorugh the types of all symbols. *) + +type glob_search_about_item = + | GlobSearchSubPattern of constr_pattern + | GlobSearchString of string + +module SearchBlacklist = + Goptions.MakeStringTable + (struct + let key = ["Search";"Blacklist"] + let title = "Current search blacklist : " + let member_message s b = + str "Search blacklist does " ++ (if b then mt () else str "not ") ++ str "include " ++ str s + let synchronous = true + end) + +(* The functions iter_constructors and iter_declarations implement the behavior + needed for the Coq searching commands. + These functions take as first argument the procedure + that will be called to treat each entry. This procedure receives the name + of the object, the assumptions that will make it possible to print its type, + and the constr term that represent its type. *) + +let iter_constructors indsp u fn env nconstr = + for i = 1 to nconstr do + let typ = Inductiveops.type_of_constructor env ((indsp, i), u) in + fn (ConstructRef (indsp, i)) env typ + done + +let iter_named_context_name_type f = + List.iter (fun decl -> f (NamedDecl.get_id decl) (NamedDecl.get_type decl)) + +(* General search over hypothesis of a goal *) +let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) = + let env = Global.env () in + let iter_hyp idh typ = fn (VarRef idh) env typ in + let evmap,e = Pfedit.get_goal_context glnum in + let pfctxt = named_context e in + iter_named_context_name_type iter_hyp pfctxt + +(* General search over declarations *) +let iter_declarations (fn : global_reference -> env -> constr -> unit) = + let env = Global.env () in + let iter_obj (sp, kn) lobj = match object_tag lobj with + | "VARIABLE" -> + begin try + let decl = Global.lookup_named (basename sp) in + fn (VarRef (NamedDecl.get_id decl)) env (NamedDecl.get_type decl) + with Not_found -> (* we are in a section *) () end + | "CONSTANT" -> + let cst = Global.constant_of_delta_kn kn in + let gr = ConstRef cst in + let typ = Global.type_of_global_unsafe gr in + fn gr env typ + | "INDUCTIVE" -> + let mind = Global.mind_of_delta_kn kn in + let mib = Global.lookup_mind mind in + let iter_packet i mip = + let ind = (mind, i) in + let u = Declareops.inductive_instance mib in + let i = (ind, u) in + let typ = Inductiveops.type_of_inductive env i in + let () = fn (IndRef ind) env typ in + let len = Array.length mip.mind_user_lc in + iter_constructors ind u fn env len + in + Array.iteri iter_packet mib.mind_packets + | _ -> () + in + try Declaremods.iter_all_segments iter_obj + with Not_found -> () + +let generic_search glnumopt fn = + (match glnumopt with + | None -> () + | Some glnum -> iter_hypothesis glnum fn); + iter_declarations fn + +(** This module defines a preference on constrs in the form of a + [compare] function (preferred constr must be big for this + functions, so preferences such as small constr must use a reversed + order). This priority will be used to order search results and + propose first results which are more likely to be relevant to the + query, this is why the type [t] contains the other elements + required of a search. *) +module ConstrPriority = struct + + (* The priority is memoised here. Because of the very localised use + of this module, it is not worth it making a convenient interface. *) + type t = + Globnames.global_reference * Environ.env * Constr.t * priority + and priority = int + + module ConstrSet = CSet.Make(Constr) + + (** A measure of the size of a term *) + let rec size t = + Constr.fold (fun s t -> 1 + s + size t) 0 t + + (** Set of the "symbols" (definitions, inductives, constructors) + which appear in a term. *) + let rec symbols acc t = + let open Constr in + match kind t with + | Const _ | Ind _ | Construct _ -> ConstrSet.add t acc + | _ -> Constr.fold symbols acc t + + (** The number of distinct "symbols" (see {!symbols}) which appear + in a term. *) + let num_symbols t = + ConstrSet.(cardinal (symbols empty t)) + + let priority t : priority = + -(3*(num_symbols t) + size t) + + let compare (_,_,_,p1) (_,_,_,p2) = + compare p1 p2 +end + +module PriorityQueue = Heap.Functional(ConstrPriority) + +let rec iter_priority_queue q fn = + (* use an option to make the function tail recursive. Will be + obsoleted with Ocaml 4.02 with the [match … with | exception …] + syntax. *) + let next = begin + try Some (PriorityQueue.maximum q) + with Heap.EmptyHeap -> None + end in + match next with + | Some (gref,env,t,_) -> + fn gref env t; + iter_priority_queue (PriorityQueue.remove q) fn + | None -> () + +let prioritize_search seq fn = + let acc = ref PriorityQueue.empty in + let iter gref env t = + let p = ConstrPriority.priority t in + acc := PriorityQueue.add (gref,env,t,p) !acc + in + let () = seq iter in + iter_priority_queue !acc fn + +(** Filters *) + +(** This function tries to see whether the conclusion matches a pattern. *) +(** FIXME: this is quite dummy, we may find a more efficient algorithm. *) +let rec pattern_filter pat ref env typ = + let typ = Termops.strip_outer_cast typ in + if Constr_matching.is_matching env Evd.empty pat typ then true + else match kind_of_term typ with + | Prod (_, _, typ) + | LetIn (_, _, _, typ) -> pattern_filter pat ref env typ + | _ -> false + +let rec head_filter pat ref env typ = + let typ = Termops.strip_outer_cast typ in + if Constr_matching.is_matching_head env Evd.empty pat typ then true + else match kind_of_term typ with + | Prod (_, _, typ) + | LetIn (_, _, _, typ) -> head_filter pat ref env typ + | _ -> false + +let full_name_of_reference ref = + let (dir,id) = repr_path (path_of_global ref) in + DirPath.to_string dir ^ "." ^ Id.to_string id + +(** Whether a reference is blacklisted *) +let blacklist_filter_aux () = + let l = SearchBlacklist.elements () in + fun ref env typ -> + let name = full_name_of_reference ref in + let is_not_bl str = not (String.string_contains ~where:name ~what:str) in + List.for_all is_not_bl l + +let module_filter (mods, outside) ref env typ = + let sp = path_of_global ref in + let sl = dirpath sp in + let is_outside md = not (is_dirpath_prefix_of md sl) in + let is_inside md = is_dirpath_prefix_of md sl in + if outside then List.for_all is_outside mods + else List.is_empty mods || List.exists is_inside mods + +let name_of_reference ref = Id.to_string (basename_of_global ref) + +let search_about_filter query gr env typ = match query with +| GlobSearchSubPattern pat -> + Constr_matching.is_matching_appsubterm ~closed:false env Evd.empty pat typ +| GlobSearchString s -> + String.string_contains ~where:(name_of_reference gr) ~what:s + + +(** SearchPattern *) + +let search_pattern gopt pat mods pr_search = + let blacklist_filter = blacklist_filter_aux () in + let filter ref env typ = + module_filter mods ref env typ && + pattern_filter pat ref env typ && + blacklist_filter ref env typ + in + let iter ref env typ = + if filter ref env typ then pr_search ref env typ + in + generic_search gopt iter + +(** SearchRewrite *) + +let eq = Coqlib.glob_eq + +let rewrite_pat1 pat = + PApp (PRef eq, [| PMeta None; pat; PMeta None |]) + +let rewrite_pat2 pat = + PApp (PRef eq, [| PMeta None; PMeta None; pat |]) + +let search_rewrite gopt pat mods pr_search = + let pat1 = rewrite_pat1 pat in + let pat2 = rewrite_pat2 pat in + let blacklist_filter = blacklist_filter_aux () in + let filter ref env typ = + module_filter mods ref env typ && + (pattern_filter pat1 ref env typ || + pattern_filter pat2 ref env typ) && + blacklist_filter ref env typ + in + let iter ref env typ = + if filter ref env typ then pr_search ref env typ + in + generic_search gopt iter + +(** Search *) + +let search_by_head gopt pat mods pr_search = + let blacklist_filter = blacklist_filter_aux () in + let filter ref env typ = + module_filter mods ref env typ && + head_filter pat ref env typ && + blacklist_filter ref env typ + in + let iter ref env typ = + if filter ref env typ then pr_search ref env typ + in + generic_search gopt iter + +(** SearchAbout *) + +let search_about gopt items mods pr_search = + let blacklist_filter = blacklist_filter_aux () in + let filter ref env typ = + let eqb b1 b2 = if b1 then b2 else not b2 in + module_filter mods ref env typ && + List.for_all + (fun (b,i) -> eqb b (search_about_filter i ref env typ)) items && + blacklist_filter ref env typ + in + let iter ref env typ = + if filter ref env typ then pr_search ref env typ + in + generic_search gopt iter + +type search_constraint = + | Name_Pattern of Str.regexp + | Type_Pattern of Pattern.constr_pattern + | SubType_Pattern of Pattern.constr_pattern + | In_Module of Names.DirPath.t + | Include_Blacklist + +type 'a coq_object = { + coq_object_prefix : string list; + coq_object_qualid : string list; + coq_object_object : 'a; +} + +let interface_search = + let rec extract_flags name tpe subtpe mods blacklist = function + | [] -> (name, tpe, subtpe, mods, blacklist) + | (Name_Pattern regexp, b) :: l -> + extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l + | (Type_Pattern pat, b) :: l -> + extract_flags name ((pat, b) :: tpe) subtpe mods blacklist l + | (SubType_Pattern pat, b) :: l -> + extract_flags name tpe ((pat, b) :: subtpe) mods blacklist l + | (In_Module id, b) :: l -> + extract_flags name tpe subtpe ((id, b) :: mods) blacklist l + | (Include_Blacklist, b) :: l -> + extract_flags name tpe subtpe mods b l + in + fun ?glnum flags -> + let (name, tpe, subtpe, mods, blacklist) = + extract_flags [] [] [] [] false flags + in + let blacklist_filter = blacklist_filter_aux () in + let filter_function ref env constr = + let id = Names.Id.to_string (Nametab.basename_of_global ref) in + let path = Libnames.dirpath (Nametab.path_of_global ref) in + let toggle x b = if x then b else not b in + let match_name (regexp, flag) = + toggle (Str.string_match regexp id 0) flag + in + let match_type (pat, flag) = + toggle (Constr_matching.is_matching env Evd.empty pat constr) flag + in + let match_subtype (pat, flag) = + toggle + (Constr_matching.is_matching_appsubterm ~closed:false + env Evd.empty pat constr) flag + in + let match_module (mdl, flag) = + toggle (Libnames.is_dirpath_prefix_of mdl path) flag + in + List.for_all match_name name && + List.for_all match_type tpe && + List.for_all match_subtype subtpe && + List.for_all match_module mods && + (blacklist || blacklist_filter ref env constr) + in + let ans = ref [] in + let print_function ref env constr = + let fullpath = DirPath.repr (Nametab.dirpath_of_global ref) in + let qualid = Nametab.shortest_qualid_of_global Id.Set.empty ref in + let (shortpath, basename) = Libnames.repr_qualid qualid in + let shortpath = DirPath.repr shortpath in + (* [shortpath] is a suffix of [fullpath] and we're looking for the missing + prefix *) + let rec prefix full short accu = match full, short with + | _, [] -> + let full = List.rev_map Id.to_string full in + (full, accu) + | _ :: full, m :: short -> + prefix full short (Id.to_string m :: accu) + | _ -> assert false + in + let (prefix, qualid) = prefix fullpath shortpath [Id.to_string basename] in + let answer = { + coq_object_prefix = prefix; + coq_object_qualid = qualid; + coq_object_object = string_of_ppcmds (pr_lconstr_env env Evd.empty constr); + } in + ans := answer :: !ans; + in + let iter ref env typ = + if filter_function ref env typ then print_function ref env typ + in + let () = generic_search glnum iter in + !ans + +let blacklist_filter ref env typ = + blacklist_filter_aux () ref env typ diff --git a/vernac/search.mli b/vernac/search.mli new file mode 100644 index 0000000000..c9167c485d --- /dev/null +++ b/vernac/search.mli @@ -0,0 +1,84 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* env -> constr -> bool +type display_function = global_reference -> env -> constr -> unit + +(** {6 Generic filter functions} *) + +val blacklist_filter : filter_function +(** Check whether a reference is blacklisted. *) + +val module_filter : DirPath.t list * bool -> filter_function +(** Check whether a reference pertains or not to a set of modules *) + +val search_about_filter : glob_search_about_item -> filter_function +(** Check whether a reference matches a SearchAbout query. *) + +(** {6 Specialized search functions} + +[search_xxx gl pattern modinout] searches the hypothesis of the [gl]th +goal and the global environment for things matching [pattern] and +satisfying module exclude/include clauses of [modinout]. *) + +val search_by_head : int option -> constr_pattern -> DirPath.t list * bool + -> display_function -> unit +val search_rewrite : int option -> constr_pattern -> DirPath.t list * bool + -> display_function -> unit +val search_pattern : int option -> constr_pattern -> DirPath.t list * bool + -> display_function -> unit +val search_about : int option -> (bool * glob_search_about_item) list + -> DirPath.t list * bool -> display_function -> unit + +type search_constraint = + (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) + | Name_Pattern of Str.regexp + (** Whether the object type satisfies a pattern *) + | Type_Pattern of Pattern.constr_pattern + (** Whether some subtype of object type satisfies a pattern *) + | SubType_Pattern of Pattern.constr_pattern + (** Whether the object pertains to a module *) + | In_Module of Names.DirPath.t + (** Bypass the Search blacklist *) + | Include_Blacklist + +type 'a coq_object = { + coq_object_prefix : string list; + coq_object_qualid : string list; + coq_object_object : 'a; +} + +val interface_search : ?glnum:int -> (search_constraint * bool) list -> + string coq_object list + +(** {6 Generic search function} *) + +val generic_search : int option -> display_function -> unit +(** This function iterates over all hypothesis of the goal numbered + [glnum] (if present) and all known declarations. *) + +(** {6 Search function modifiers} *) + +val prioritize_search : (display_function -> unit) -> display_function -> unit +(** [prioritize_search iter] iterates over the values of [iter] (seen + as a sequence of declarations), in a relevance order. This requires to + perform the entire iteration of [iter] before starting streaming. So + [prioritize_search] should not be used for low-latency streaming. *) diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib new file mode 100644 index 0000000000..94ef54f70f --- /dev/null +++ b/vernac/vernac.mllib @@ -0,0 +1,17 @@ +Lemmas +Himsg +ExplainErr +Class +Locality +Metasyntax +Auto_ind_decl +Search +Indschemes +Obligations +Command +Classes +Record +Assumptions +Vernacinterp +Mltop +Vernacentries diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml new file mode 100644 index 0000000000..15f89e4b86 --- /dev/null +++ b/vernac/vernacentries.ml @@ -0,0 +1,2271 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Classops.CL_FUN + | SortClass -> Classops.CL_SORT + | RefClass r -> Class.class_of_global (Smartlocate.smart_global ~head:true r) + +let scope_class_of_qualid qid = + Notation.scope_class_of_class (cl_of_qualid qid) + +(*******************) +(* "Show" commands *) + +let show_proof () = + (* spiwack: this would probably be cooler with a bit of polishing. *) + let p = Proof_global.give_me_the_proof () in + let pprf = Proof.partial_proof p in + Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl Printer.pr_constr pprf) + +let show_node () = + (* spiwack: I'm have little clue what this function used to do. I deactivated it, + could, possibly, be cleaned away. (Feb. 2010) *) + () + +let show_thesis () = + Feedback.msg_error (anomaly (Pp.str "TODO") ) + +let show_top_evars () = + (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) + let pfts = get_pftreestate () in + let gls = Proof.V82.subgoals pfts in + let sigma = gls.Evd.sigma in + Feedback.msg_notice (pr_evars_int sigma 1 (Evarutil.non_instantiated sigma)) + +let show_universes () = + let pfts = get_pftreestate () in + let gls = Proof.V82.subgoals pfts in + let sigma = gls.Evd.sigma in + let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in + Feedback.msg_notice (Evd.pr_evar_universe_context (Evd.evar_universe_context sigma)); + Feedback.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 *) + () + +let enable_goal_printing = ref true + +let print_subgoals () = + if !enable_goal_printing && is_verbose () + then begin + Feedback.msg_notice (pr_open_subgoals ()) + end + +let try_print_subgoals () = + try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> () + + + (* Simulate the Intro(s) tactic *) + +let show_intro all = + let pf = get_pftreestate() in + let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in + if not (List.is_empty gls) then begin + let gl = {Evd.it=List.hd gls ; sigma = sigma; } in + let l,_= decompose_prod_assum (Termops.strip_outer_cast (pf_concl gl)) in + if all then + let lid = Tactics.find_intro_names l gl in + Feedback.msg_notice (hov 0 (prlist_with_sep spc pr_id lid)) + else if not (List.is_empty l) then + let n = List.last l in + Feedback.msg_notice (pr_id (List.hd (Tactics.find_intro_names [n] gl))) + end + +(** Prepare a "match" template for a given inductive type. + For each branch of the match, we list the constructor name + followed by enough pattern variables. + [Not_found] is raised if the given string isn't the qualid of + a known inductive type. *) + +let make_cases_aux glob_ref = + match glob_ref with + | Globnames.IndRef i -> + let {Declarations.mind_nparams = np} + , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr } + = Global.lookup_inductive i in + Util.Array.fold_right2 + (fun consname typ l -> + let al = List.rev (fst (decompose_prod typ)) in + let al = Util.List.skipn np al in + let rec rename avoid = function + | [] -> [] + | (n,_)::l -> + let n' = Namegen.next_name_away_with_default (Id.to_string Namegen.default_dependent_ident) n avoid in + Id.to_string n' :: rename (n'::avoid) l in + let al' = rename [] al in + (Id.to_string consname :: al') :: l) + carr tarr [] + | _ -> raise Not_found + +let make_cases s = + let qualified_name = Libnames.qualid_of_string s in + let glob_ref = Nametab.locate qualified_name in + make_cases_aux glob_ref + +(** Textual display of a generic "match" template *) + +let show_match id = + let patterns = + try make_cases_aux (Nametab.global id) + with Not_found -> error "Unknown inductive type." + in + let pr_branch l = + str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>" + in + Feedback.msg_notice (v 1 (str "match # with" ++ fnl () ++ + prlist_with_sep fnl pr_branch patterns ++ fnl () ++ str "end" ++ fnl ())) + +(* "Print" commands *) + +let print_path_entry p = + let dir = pr_dirpath (Loadpath.logical p) in + let path = str (Loadpath.physical p) in + (dir ++ str " " ++ tbrk (0, 0) ++ path) + +let print_loadpath dir = + let l = Loadpath.get_load_paths () in + let l = match dir with + | None -> l + | Some dir -> + let filter p = is_dirpath_prefix_of dir (Loadpath.logical p) in + List.filter filter l + in + Pp.t (str "Logical Path: " ++ + tab () ++ str "Physical path:" ++ fnl () ++ + prlist_with_sep fnl print_path_entry l) + +let print_modules () = + let opened = Library.opened_libraries () + and loaded = Library.loaded_libraries () in + (* we intersect over opened to preserve the order of opened since *) + (* non-commutative operations (e.g. visibility) are done at import time *) + let loaded_opened = List.intersect DirPath.equal opened loaded + and only_loaded = List.subtract DirPath.equal loaded opened in + str"Loaded and imported library files: " ++ + pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++ + str"Loaded and not imported library files: " ++ + pr_vertical_list pr_dirpath only_loaded + + +let print_module r = + let (loc,qid) = qualid_of_reference r in + try + let globdir = Nametab.locate_dir qid in + match globdir with + DirModule (dirpath,(mp,_)) -> + Feedback.msg_notice (Printmod.print_module (Printmod.printable_body dirpath) mp) + | _ -> raise Not_found + with + Not_found -> Feedback.msg_error (str"Unknown Module " ++ pr_qualid qid) + +let print_modtype r = + let (loc,qid) = qualid_of_reference r in + try + let kn = Nametab.locate_modtype qid in + Feedback.msg_notice (Printmod.print_modtype kn) + with Not_found -> + (* Is there a module of this name ? If yes we display its type *) + try + let mp = Nametab.locate_module qid in + Feedback.msg_notice (Printmod.print_module false mp) + with Not_found -> + Feedback.msg_error (str"Unknown Module Type or Module " ++ pr_qualid qid) + +let print_namespace ns = + let ns = List.rev (Names.DirPath.repr ns) in + (* [match_dirpath], [match_modulpath] are helpers for [matches] + which checks whether a constant is in the namespace [ns]. *) + let rec match_dirpath ns = function + | [] -> Some ns + | id::dir -> + begin match match_dirpath ns dir with + | Some [] as y -> y + | Some (a::ns') -> + if Names.Id.equal a id then Some ns' + else None + | None -> None + end + in + let rec match_modulepath ns = function + | MPbound _ -> None (* Not a proper namespace. *) + | MPfile dir -> match_dirpath ns (Names.DirPath.repr dir) + | MPdot (mp,lbl) -> + let id = Names.Label.to_id lbl in + begin match match_modulepath ns mp with + | Some [] as y -> y + | Some (a::ns') -> + if Names.Id.equal a id then Some ns' + else None + | None -> None + end + in + (* [qualified_minus n mp] returns a list of qualifiers representing + [mp] except the [n] first (in the concrete syntax order). The + idea is that if [mp] matches [ns], then [qualified_minus mp + (length ns)] will be the correct representation of [mp] assuming + [ns] is imported. *) + (* precondition: [mp] matches some namespace of length [n] *) + let qualified_minus n mp = + let rec list_of_modulepath = function + | MPbound _ -> assert false (* MPbound never matches *) + | MPfile dir -> Names.DirPath.repr dir + | MPdot (mp,lbl) -> (Names.Label.to_id lbl)::(list_of_modulepath mp) + in + snd (Util.List.chop n (List.rev (list_of_modulepath mp))) + in + let print_list pr l = prlist_with_sep (fun () -> str".") pr l in + let print_kn kn = + (* spiwack: I'm ignoring the dirpath, is that bad? *) + let (mp,_,lbl) = Names.repr_kn kn in + let qn = (qualified_minus (List.length ns) mp)@[Names.Label.to_id lbl] in + print_list pr_id qn + in + let print_constant k body = + (* FIXME: universes *) + let t = Typeops.type_of_constant_type (Global.env ()) body.Declarations.const_type in + print_kn k ++ str":" ++ spc() ++ Printer.pr_type t + in + let matches mp = match match_modulepath ns mp with + | Some [] -> true + | _ -> false in + let constants = (Environ.pre_env (Global.env ())).Pre_env.env_globals.Pre_env.env_constants in + let constants_in_namespace = + Cmap_env.fold (fun c (body,_) acc -> + let kn = user_con c in + if matches (modpath kn) then + acc++fnl()++hov 2 (print_constant kn body) + else + acc + ) constants (str"") + in + Feedback.msg_notice ((print_list pr_id ns)++str":"++fnl()++constants_in_namespace) + +let print_strategy r = + let open Conv_oracle in + let pr_level = function + | Expand -> str "expand" + | Level 0 -> str "transparent" + | Level n -> str "level" ++ spc() ++ int n + | Opaque -> str "opaque" + in + let pr_strategy (ref, lvl) = pr_global ref ++ str " : " ++ pr_level lvl in + let oracle = Environ.oracle (Global.env ()) in + match r with + | None -> + let fold key lvl (vacc, cacc) = match key with + | VarKey id -> ((VarRef id, lvl) :: vacc, cacc) + | ConstKey cst -> (vacc, (ConstRef cst, lvl) :: cacc) + | RelKey _ -> (vacc, cacc) + in + let var_lvl, cst_lvl = fold_strategy fold oracle ([], []) in + let var_msg = + if List.is_empty var_lvl then mt () + else str "Variable strategies" ++ fnl () ++ + hov 0 (prlist_with_sep fnl pr_strategy var_lvl) ++ fnl () + in + let cst_msg = + if List.is_empty cst_lvl then mt () + else str "Constant strategies" ++ fnl () ++ + hov 0 (prlist_with_sep fnl pr_strategy cst_lvl) + in + Feedback.msg_notice (var_msg ++ cst_msg) + | Some r -> + let r = Smartlocate.smart_global r in + let key = match r with + | VarRef id -> VarKey id + | ConstRef cst -> ConstKey cst + | IndRef _ | ConstructRef _ -> error "The reference is not unfoldable" + in + let lvl = get_strategy oracle key in + Feedback.msg_notice (pr_strategy (r, lvl)) + +let dump_universes_gen g s = + let output = open_out s in + let output_constraint, close = + if Filename.check_suffix s ".dot" || Filename.check_suffix s ".gv" then begin + (* the lazy unit is to handle errors while printing the first line *) + let init = lazy (Printf.fprintf output "digraph universes {\n") in + begin fun kind left right -> + let () = Lazy.force init in + match kind with + | Univ.Lt -> + Printf.fprintf output " \"%s\" -> \"%s\" [style=bold];\n" right left + | Univ.Le -> + Printf.fprintf output " \"%s\" -> \"%s\" [style=solid];\n" right left + | Univ.Eq -> + Printf.fprintf output " \"%s\" -> \"%s\" [style=dashed];\n" left right + end, begin fun () -> + if Lazy.is_val init then Printf.fprintf output "}\n"; + close_out output + end + end else begin + begin fun kind left right -> + let kind = match kind with + | Univ.Lt -> "<" + | Univ.Le -> "<=" + | Univ.Eq -> "=" + in Printf.fprintf output "%s %s %s ;\n" left kind right + end, (fun () -> close_out output) + end + in + try + UGraph.dump_universes output_constraint g; + close (); + Feedback.msg_info (str "Universes written to file \"" ++ str s ++ str "\".") + with reraise -> + let reraise = CErrors.push reraise in + close (); + iraise reraise + +(*********************) +(* "Locate" commands *) + +let locate_file f = + let file = Flags.silently Loadpath.locate_file f in + str file + +let msg_found_library = function + | Library.LibLoaded, fulldir, file -> + Feedback.msg_info (hov 0 + (pr_dirpath fulldir ++ strbrk " has been loaded from file " ++ + str file)) + | Library.LibInPath, fulldir, file -> + Feedback.msg_info (hov 0 + (pr_dirpath fulldir ++ strbrk " is bound to file " ++ str file)) + +let err_unmapped_library loc ?from qid = + let dir = fst (repr_qualid qid) in + let prefix = match from with + | None -> str "." + | Some from -> + str " and prefix " ++ pr_dirpath from ++ str "." + in + user_err ~loc + ~hdr:"locate_library" + (strbrk "Cannot find a physical path bound to logical path matching suffix " ++ + pr_dirpath dir ++ prefix) + +let err_notfound_library loc ?from qid = + let prefix = match from with + | None -> str "." + | Some from -> + str " with prefix " ++ pr_dirpath from ++ str "." + in + user_err ~loc ~hdr:"locate_library" + (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) + +let print_located_library r = + let (loc,qid) = qualid_of_reference r in + try msg_found_library (Library.locate_qualified_library ~warn:false qid) + with + | Library.LibUnmappedDir -> err_unmapped_library loc qid + | Library.LibNotFound -> err_notfound_library loc qid + +let smart_global r = + let gr = Smartlocate.smart_global r in + Dumpglob.add_glob (Stdarg.loc_of_or_by_notation loc_of_reference r) gr; + gr + +let dump_global r = + try + let gr = Smartlocate.smart_global r in + Dumpglob.add_glob (Stdarg.loc_of_or_by_notation loc_of_reference r) gr + with e when CErrors.noncritical e -> () +(**********) +(* Syntax *) + +let vernac_syntax_extension locality local = + let local = enforce_module_locality locality local in + Metasyntax.add_syntax_extension local + +let vernac_delimiters sc = function + | Some lr -> Metasyntax.add_delimiters sc lr + | None -> Metasyntax.remove_delimiters sc + +let vernac_bind_scope sc cll = + Metasyntax.add_class_scope sc (List.map scope_class_of_qualid cll) + +let vernac_open_close_scope locality local (b,s) = + let local = enforce_section_locality locality local in + Notation.open_close_scope (local,b,s) + +let vernac_arguments_scope locality r scl = + let local = make_section_locality locality in + Notation.declare_arguments_scope local (smart_global r) scl + +let vernac_infix locality local = + let local = enforce_module_locality locality local in + Metasyntax.add_infix local + +let vernac_notation locality local = + let local = enforce_module_locality locality local in + Metasyntax.add_notation local + +(***********) +(* Gallina *) + +let start_proof_and_print k l hook = + let inference_hook = + if Flags.is_program_mode () then + let hook env sigma ev = + let tac = !Obligations.default_tactic in + let evi = Evd.find sigma ev in + let env = Evd.evar_filtered_env evi in + try + let concl = Evarutil.nf_evars_universes sigma evi.Evd.evar_concl in + if Evarutil.has_undefined_evars sigma concl then raise Exit; + let c, _, ctx = + Pfedit.build_by_tactic env (Evd.evar_universe_context sigma) + concl (Tacticals.New.tclCOMPLETE tac) + in Evd.set_universe_context sigma ctx, c + with Logic_monad.TacticFailure e when Logic.catchable_exception e -> + error "The statement obligations could not be resolved \ + automatically, write a statement definition first." + in Some hook + else None + in + start_proof_com ?inference_hook k l hook + +let no_hook = Lemmas.mk_hook (fun _ _ -> ()) + +let vernac_definition_hook p = function +| Coercion -> Class.add_coercion_hook p +| CanonicalStructure -> + Lemmas.mk_hook (fun _ -> Recordops.declare_canonical_structure) +| SubClass -> Class.add_subclass_hook p +| _ -> no_hook + +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 + | Discharge -> Dumpglob.dump_definition lid true "var" + | Local | Global -> Dumpglob.dump_definition lid false "def" + in + (match def with + | ProveBody (bl,t) -> (* local binders, typ *) + start_proof_and_print (local,p,DefinitionBody k) + [Some (lid,pl), (bl,t,None)] 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 (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 = + let local = enforce_locality_exp locality None in + if Dumpglob.dump () then + List.iter (fun (id, _) -> + match id with + | Some (lid,_) -> Dumpglob.dump_definition lid false "prf" + | None -> ()) l; + if not(refining ()) then + if lettop then + user_err ~hdr:"Vernacentries.StartProof" + (str "Let declarations can only be used in proof editing mode."); + start_proof_and_print (local, p, Proof kind) l no_hook + +let qed_display_script = ref true + +let vernac_end_proof ?proof = function + | Admitted -> save_proof ?proof Admitted + | Proved (_,_) as e -> + (* + if is_verbose () && !qed_display_script && !Flags.coqtop_ui then + Stm.show_script ?proof (); + *) + save_proof ?proof e + + (* A stupid macro that should be replaced by ``Exact c. Save.'' all along + the theories [??] *) + +let vernac_exact_proof c = + (* spiwack: for simplicity I do not enforce that "Proof proof_term" is + called only at the begining of a proof. *) + let status = by (Tactics.exact_proof c) in + save_proof (Vernacexpr.(Proved(Opaque None,None))); + if not status then Feedback.feedback Feedback.AddedAxiom + +let vernac_assumption locality poly (local, kind) l nl = + let local = enforce_locality_exp locality local in + let global = local == Global in + let kind = local, poly, kind in + List.iter (fun (is_coe,(idl,c)) -> + if Dumpglob.dump () then + 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 + if not status then Feedback.feedback Feedback.AddedAxiom + +let vernac_record k poly finite struc binders sort nameopt cfs = + let const = match nameopt with + | 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 (fst (snd struc)) false "rec"; + List.iter (fun (((_, x), _), _) -> + match x with + | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" + | _ -> ()) cfs); + ignore(Record.definition_structure (k,poly,finite,struc,binders,cfs,const,sort)) + +(** When [poly] is true the type is declared polymorphic. When [lo] is true, + then the type is declared private (as per the [Private] keyword). [finite] + indicates whether the type is inductive, co-inductive or + neither. *) +let vernac_inductive poly lo finite indl = + if Dumpglob.dump () then + List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) -> + match cstrs with + | Constructors cstrs -> + Dumpglob.dump_definition lid false "ind"; + List.iter (fun (_, (lid, _)) -> + Dumpglob.dump_definition lid false "constr") cstrs + | _ -> () (* dumping is done by vernac_record (called below) *) ) + indl; + match indl with + | [ ( _ , _ , _ ,(Record|Structure), Constructors _ ),_ ] -> + CErrors.error "The Record keyword is for types defined using the syntax { ... }." + | [ (_ , _ , _ ,Variant, RecordDecl _),_ ] -> + CErrors.error "The Variant keyword does not support syntax { ... }." + | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> + vernac_record (match b with Class _ -> Class false | _ -> b) + poly finite id bl c oc fs + | [ ( id , bl , c , Class _, 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), []) + in vernac_record (Class true) poly finite id bl c None [f] + | [ ( _ , _, _, Class _, Constructors _), [] ] -> + CErrors.error "Inductive classes not supported" + | [ ( id , bl , c , Class _, _), _ :: _ ] -> + CErrors.error "where clause not supported for classes" + | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] -> + CErrors.error "where clause not supported for (co)inductive records" + | _ -> let unpack = function + | ( (false, id) , bl , c , _ , Constructors l ) , ntn -> ( id , bl , c , l ) , ntn + | ( (true,_),_,_,_,Constructors _),_ -> + CErrors.error "Variant types do not handle the \"> Name\" syntax, which is reserved for records. Use the \":>\" syntax on constructors instead." + | _ -> CErrors.error "Cannot handle mutually (co)inductive records." + in + let indl = List.map unpack indl in + do_mutual_inductive indl poly lo finite + +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; + 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; + do_cofixpoint local poly l + +let vernac_scheme l = + if Dumpglob.dump () then + List.iter (fun (lid, s) -> + Option.iter (fun lid -> Dumpglob.dump_definition lid false "def") lid; + match s with + | InductionScheme (_, r, _) + | CaseScheme (_, r, _) + | EqualityScheme r -> dump_global r) l; + Indschemes.do_scheme l + +let vernac_combined_scheme lid l = + if Dumpglob.dump () then + (Dumpglob.dump_definition lid false "def"; + List.iter (fun lid -> dump_global (Misctypes.AN (Ident lid))) l); + Indschemes.do_combined_scheme lid l + +let vernac_universe loc poly l = + if poly && not (Lib.sections_are_opened ()) then + user_err ~loc ~hdr:"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 ~hdr:"vernac_constraint" + (str"Polymorphic universe constraints can only be declared" + ++ str " inside sections, use Monomorphic Constraint instead"); + do_constraint poly l + +(**********************) +(* Modules *) + +let vernac_import export refl = + Library.import_module export (List.map qualid_of_reference refl); + Lib.add_frozen_state () + +let vernac_declare_module export (loc, id) binders_ast mty_ast = + (* We check the state of the system (in section, in module type) + and what module information is supplied *) + if Lib.sections_are_opened () then + error "Modules and Module Types are not allowed inside sections."; + let binders_ast = List.map + (fun (export,idl,ty) -> + if not (Option.is_empty export) then + error "Arguments of a functor declaration cannot be exported. Remove the \"Export\" and \"Import\" keywords from every functor argument." + else (idl,ty)) binders_ast in + let mp = + Declaremods.declare_module Modintern.interp_module_ast + id binders_ast (Enforce mty_ast) [] + in + Dumpglob.dump_moddef loc mp "mod"; + if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared"); + Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export + +let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = + (* We check the state of the system (in section, in module type) + and what module information is supplied *) + if Lib.sections_are_opened () then + error "Modules and Module Types are not allowed inside sections."; + match mexpr_ast_l with + | [] -> + check_no_pending_proofs (); + let binders_ast,argsexport = + List.fold_right + (fun (export,idl,ty) (args,argsexport) -> + (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast + ([],[]) in + let mp = + Declaremods.start_module Modintern.interp_module_ast + export id binders_ast mty_ast_o + in + Dumpglob.dump_moddef loc mp "mod"; + if_verbose Feedback.msg_info + (str "Interactive Module " ++ pr_id id ++ str " started"); + List.iter + (fun (export,id) -> + Option.iter + (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export + ) argsexport + | _::_ -> + let binders_ast = List.map + (fun (export,idl,ty) -> + if not (Option.is_empty export) then + error "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument." + else (idl,ty)) binders_ast in + let mp = + Declaremods.declare_module Modintern.interp_module_ast + id binders_ast mty_ast_o mexpr_ast_l + in + Dumpglob.dump_moddef loc mp "mod"; + if_verbose Feedback.msg_info + (str "Module " ++ pr_id id ++ str " is defined"); + Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) + export + +let vernac_end_module export (loc,id as lid) = + let mp = Declaremods.end_module () in + Dumpglob.dump_modref loc mp "mod"; + if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined"); + Option.iter (fun export -> vernac_import export [Ident lid]) export + +let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = + if Lib.sections_are_opened () then + error "Modules and Module Types are not allowed inside sections."; + + match mty_ast_l with + | [] -> + check_no_pending_proofs (); + let binders_ast,argsexport = + List.fold_right + (fun (export,idl,ty) (args,argsexport) -> + (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast + ([],[]) in + + let mp = + Declaremods.start_modtype Modintern.interp_module_ast + id binders_ast mty_sign + in + Dumpglob.dump_moddef loc mp "modtype"; + if_verbose Feedback.msg_info + (str "Interactive Module Type " ++ pr_id id ++ str " started"); + List.iter + (fun (export,id) -> + Option.iter + (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export + ) argsexport + + | _ :: _ -> + let binders_ast = List.map + (fun (export,idl,ty) -> + if not (Option.is_empty export) then + error "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument." + else (idl,ty)) binders_ast in + let mp = + Declaremods.declare_modtype Modintern.interp_module_ast + id binders_ast mty_sign mty_ast_l + in + Dumpglob.dump_moddef loc mp "modtype"; + if_verbose Feedback.msg_info + (str "Module Type " ++ pr_id id ++ str " is defined") + +let vernac_end_modtype (loc,id) = + let mp = Declaremods.end_modtype () in + Dumpglob.dump_modref loc mp "modtype"; + if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined") + +let vernac_include l = + Declaremods.declare_include Modintern.interp_module_ast l + +(**********************) +(* Gallina extensions *) + +(* Sections *) + +let vernac_begin_section (_, id as lid) = + check_no_pending_proofs (); + Dumpglob.dump_definition lid true "sec"; + Lib.open_section id + +let vernac_end_section (loc,_) = + Dumpglob.dump_reference loc + (DirPath.to_string (Lib.current_dirpath true)) "<>" "sec"; + Lib.close_section () + +let vernac_name_sec_hyp (_,id) set = Proof_using.name_set id set + +(* Dispatcher of the "End" command *) + +let vernac_end_segment (_,id as lid) = + check_no_pending_proofs (); + match Lib.find_opening_node id with + | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid + | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid + | Lib.OpenedSection _ -> vernac_end_section lid + | _ -> assert false + +(* Libraries *) + +let vernac_require from import qidl = + let qidl = List.map qualid_of_reference qidl in + let root = match from with + | None -> None + | Some from -> + let (_, qid) = Libnames.qualid_of_reference from in + let (hd, tl) = Libnames.repr_qualid qid in + Some (Libnames.add_dirpath_suffix hd tl) + in + let locate (loc, qid) = + try + let warn = Flags.is_verbose () in + let (_, dir, f) = Library.locate_qualified_library ?root ~warn qid in + (dir, f) + with + | Library.LibUnmappedDir -> err_unmapped_library loc ?from:root qid + | Library.LibNotFound -> err_notfound_library loc ?from:root qid + in + let modrefl = List.map locate qidl in + if Dumpglob.dump () then + List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl); + Library.require_library_from_dirpath modrefl import + +(* Coercions and canonical structures *) + +let vernac_canonical r = + Recordops.declare_canonical_structure (smart_global r) + +let vernac_coercion locality poly local ref qids qidt = + let local = enforce_locality locality local in + let target = cl_of_qualid qidt in + let source = cl_of_qualid qids in + let ref' = smart_global ref in + Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target; + if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion") + +let vernac_identity_coercion locality poly local id qids qidt = + let local = enforce_locality locality local in + let target = cl_of_qualid qidt in + let source = cl_of_qualid qids in + Class.try_add_new_identity_coercion id ~local poly ~source ~target + +(* Type classes *) + +let vernac_instance abst locality poly sup inst props pri = + let global = not (make_section_locality locality) in + Dumpglob.dump_constraint inst false "inst"; + ignore(Classes.new_instance ~abstract:abst ~global poly sup inst props pri) + +let vernac_context poly l = + if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom + +let vernac_declare_instances locality insts = + let glob = not (make_section_locality locality) in + List.iter (fun (id, info) -> Classes.existing_instance glob id (Some info)) insts + +let vernac_declare_class id = + Record.declare_existing_class (Nametab.global id) + +(***********) +(* Solving *) + +let command_focus = Proof.new_focus_kind () +let focus_command_cond = Proof.no_cond command_focus + + (* 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 + there are no more goals to solve. It cannot be a tactic since + all tactics fail if there are no further goals to prove. *) + +let vernac_solve_existential = instantiate_nth_evar_com + +let vernac_set_end_tac tac = + let open Genintern in + let env = { genv = Global.env (); ltacvars = Id.Set.empty } in + let _, tac = Genintern.generic_intern env tac in + if not (refining ()) then + error "Unknown command of the non proof-editing mode."; + set_end_tac tac + (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) + +let vernac_set_used_variables e = + 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 (NamedDecl.get_id %> Id.equal id) vars) then + user_err ~hdr:"vernac_set_used_variables" + (str "Unknown variable: " ++ pr_id id)) + l; + let _, to_clear = set_used_variables l in + 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 = Tactics.clear to_clear in + fst (solve SelectAll None tac p), () + end + +(*****************************) +(* Auxiliary file management *) + +let expand filename = + Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) filename + +let vernac_add_loadpath implicit pdir ldiropt = + let pdir = expand pdir in + let alias = Option.default Nameops.default_root_prefix ldiropt in + Mltop.add_rec_path Mltop.AddTopML ~unix_path:pdir ~coq_root:alias ~implicit + +let vernac_remove_loadpath path = + Loadpath.remove_load_path (expand path) + + (* Coq syntax for ML or system commands *) + +let vernac_add_ml_path isrec path = + (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (expand path) + +let vernac_declare_ml_module locality l = + let local = make_locality locality in + Mltop.declare_ml_modules local (List.map expand l) + +let vernac_chdir = function + | None -> Feedback.msg_notice (str (Sys.getcwd())) + | Some path -> + begin + try Sys.chdir (expand path) + with Sys_error err -> + (* Cd is typically used to control the output directory of + extraction. A failed Cd could lead to overwriting .ml files + so we make it an error. *) + CErrors.error ("Cd failed: " ^ err) + end; + if_verbose Feedback.msg_info (str (Sys.getcwd())) + + +(********************) +(* State management *) + +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 + +(************) +(* Commands *) + +let vernac_create_hintdb locality id b = + let local = make_module_locality locality in + Hints.create_hint_db local id full_transparent_state b + +let vernac_remove_hints locality dbs ids = + let local = make_module_locality locality in + Hints.remove_hints local dbs (List.map Smartlocate.global_with_alias ids) + +let vernac_hints locality poly local lb h = + let local = enforce_module_locality locality local in + Hints.add_hints local lb (Hints.interp_hints poly h) + +let vernac_syntactic_definition locality lid x local y = + Dumpglob.dump_definition lid false "syndef"; + let local = enforce_module_locality locality local in + Metasyntax.add_syntactic_definition (snd lid) x local y + +let vernac_declare_implicits locality r l = + let local = make_section_locality locality in + match l with + | [] -> + Impargs.declare_implicits local (smart_global r) + | _::_ as imps -> + Impargs.declare_manual_implicits local (smart_global r) ~enriching:false + (List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps) + +let warn_arguments_assert = + CWarnings.create ~name:"arguments-assert" ~category:"vernacular" + (fun sr -> + strbrk "This command is just asserting the names of arguments of " ++ + pr_global sr ++ strbrk". If this is what you want add " ++ + strbrk "': assert' to silence the warning. If you want " ++ + strbrk "to clear implicit arguments add ': clear implicits'. " ++ + strbrk "If you want to clear notation scopes add ': clear scopes'") + +(* [nargs_for_red] is the number of arguments required to trigger reduction, + [args] is the main list of arguments statuses, + [more_implicits] is a list of extra lists of implicit statuses *) +let vernac_arguments locality reference args more_implicits nargs_for_red flags = + let assert_flag = List.mem `Assert flags in + let rename_flag = List.mem `Rename flags in + let clear_scopes_flag = List.mem `ClearScopes flags in + let extra_scopes_flag = List.mem `ExtraScopes flags in + let clear_implicits_flag = List.mem `ClearImplicits flags in + let default_implicits_flag = List.mem `DefaultImplicits flags in + let never_unfold_flag = List.mem `ReductionNeverUnfold flags in + + let err_incompat x y = + error ("Options \""^x^"\" and \""^y^"\" are incompatible.") in + + if assert_flag && rename_flag then + err_incompat "assert" "rename"; + if Option.has_some nargs_for_red && never_unfold_flag then + err_incompat "simpl never" "/"; + if never_unfold_flag && List.mem `ReductionDontExposeCase flags then + err_incompat "simpl never" "simpl nomatch"; + if clear_scopes_flag && extra_scopes_flag then + err_incompat "clear scopes" "extra scopes"; + if clear_implicits_flag && default_implicits_flag then + err_incompat "clear implicits" "default implicits"; + + let sr = smart_global reference in + let inf_names = + let ty = Global.type_of_global_unsafe sr in + Impargs.compute_implicits_names (Global.env ()) ty + in + let prev_names = + try Arguments_renaming.arguments_names sr with Not_found -> inf_names + in + let num_args = List.length inf_names in + assert (Int.equal num_args (List.length prev_names)); + + let names_of args = List.map (fun a -> a.name) args in + + (* Checks *) + + let err_extra_args names = + user_err ~hdr:"vernac_declare_arguments" + (strbrk "Extra arguments: " ++ + prlist_with_sep pr_comma pr_name names ++ str ".") + in + let err_missing_args names = + user_err ~hdr:"vernac_declare_arguments" + (strbrk "The following arguments are not declared: " ++ + prlist_with_sep pr_comma pr_name names ++ str ".") + in + + let rec check_extra_args extra_args = + match extra_args with + | [] -> () + | { notation_scope = None } :: _ -> err_extra_args (names_of extra_args) + | { name = Anonymous; notation_scope = Some _ } :: args -> + check_extra_args args + | _ -> + error "Extra notation scopes can be set on anonymous and explicit arguments only." + in + + let args, scopes = + let scopes = List.map (fun { notation_scope = s } -> s) args in + if List.length args > num_args then + let args, extra_args = List.chop num_args args in + if extra_scopes_flag then + (check_extra_args extra_args; (args, scopes)) + else err_extra_args (names_of extra_args) + else args, scopes + in + + if Option.cata (fun n -> n > num_args) false nargs_for_red then + error "The \"/\" modifier should be put before any extra scope."; + + let scopes_specified = List.exists Option.has_some scopes in + + if scopes_specified && clear_scopes_flag then + error "The \"clear scopes\" flag is incompatible with scope annotations."; + + let names = List.map (fun { name } -> name) args in + let names = names :: List.map (List.map fst) more_implicits in + + let rename_flag_required = ref false in + let example_renaming = ref None in + let save_example_renaming renaming = + rename_flag_required := !rename_flag_required + || not (Name.equal (fst renaming) Anonymous); + if Option.is_empty !example_renaming then + example_renaming := Some renaming + in + + let rec names_union names1 names2 = + match names1, names2 with + | [], [] -> [] + | _ :: _, [] -> names1 + | [], _ :: _ -> names2 + | (Name _ as name) :: names1, Anonymous :: names2 + | Anonymous :: names1, (Name _ as name) :: names2 -> + name :: names_union names1 names2 + | name1 :: names1, name2 :: names2 -> + if Name.equal name1 name2 then + name1 :: names_union names1 names2 + else error "Argument lists should agree on the names they provide." + in + + let names = List.fold_left names_union [] names in + + let rec rename prev_names names = + match prev_names, names with + | [], [] -> [] + | [], _ :: _ -> err_extra_args names + | _ :: _, [] when assert_flag -> + (* Error messages are expressed in terms of original names, not + renamed ones. *) + err_missing_args (List.lastn (List.length prev_names) inf_names) + | _ :: _, [] -> prev_names + | prev :: prev_names, Anonymous :: names -> + prev :: rename prev_names names + | prev :: prev_names, (Name id as name) :: names -> + if not (Name.equal prev name) then save_example_renaming (prev,name); + name :: rename prev_names names + in + + let names = rename prev_names names in + let renaming_specified = Option.has_some !example_renaming in + + if !rename_flag_required && not rename_flag then + user_err ~hdr:"vernac_declare_arguments" + (strbrk "To rename arguments the \"rename\" flag must be specified." + ++ spc () ++ + match !example_renaming with + | None -> mt () + | Some (o,n) -> + str "Argument " ++ pr_name o ++ + str " renamed to " ++ pr_name n ++ str "."); + + let duplicate_names = + List.duplicates Name.equal (List.filter ((!=) Anonymous) names) + in + if not (List.is_empty duplicate_names) then begin + let duplicates = prlist_with_sep pr_comma pr_name duplicate_names in + user_err (strbrk "Some argument names are duplicated: " ++ duplicates) + end; + + (* Parts of this code are overly complicated because the implicit arguments + API is completely crazy: positions (ExplByPos) are elaborated to + names. This is broken by design, since not all arguments have names. So + even though we eventually want to map only positions to implicit statuses, + we have to check whether the corresponding arguments have names, not to + trigger an error in the impargs code. Even better, the names we have to + check are not the current ones (after previous renamings), but the original + ones (inferred from the type). *) + + let implicits = + List.map (fun { name; implicit_status = i } -> (name,i)) args + in + let implicits = implicits :: more_implicits in + + let open Vernacexpr in + let rec build_implicits inf_names implicits = + match inf_names, implicits with + | _, [] -> [] + | _ :: inf_names, (_, NotImplicit) :: implicits -> + build_implicits inf_names implicits + + (* With the current impargs API, it is impossible to make an originally + anonymous argument implicit *) + | Anonymous :: _, (name, _) :: _ -> + user_err ~hdr:"vernac_declare_arguments" + (strbrk"Argument "++ pr_name name ++ + strbrk " cannot be declared implicit.") + + | Name id :: inf_names, (name, impl) :: implicits -> + let max = impl = MaximallyImplicit in + (ExplByName id,max,false) :: build_implicits inf_names implicits + + | _ -> assert false (* already checked in [names_union] *) + in + + let implicits = List.map (build_implicits inf_names) implicits in + let implicits_specified = match implicits with [[]] -> false | _ -> true in + + if implicits_specified && clear_implicits_flag then + error "The \"clear implicits\" flag is incompatible with implicit annotations"; + + if implicits_specified && default_implicits_flag then + error "The \"default implicits\" flag is incompatible with implicit annotations"; + + let rargs = + Util.List.map_filter (function (n, true) -> Some n | _ -> None) + (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 args) + in + + let rec narrow = function + | #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl + | [] -> [] | _ :: tl -> narrow tl + in + let red_flags = narrow flags in + let red_modifiers_specified = + not (List.is_empty rargs) || Option.has_some nargs_for_red + || not (List.is_empty red_flags) + in + + if not (List.is_empty rargs) && never_unfold_flag then + err_incompat "simpl never" "!"; + + + (* Actions *) + + if renaming_specified then begin + let local = make_section_locality locality in + Arguments_renaming.rename_arguments local sr names + end; + + if scopes_specified || clear_scopes_flag then begin + let scopes = List.map (Option.map (fun (o,k) -> + try ignore (Notation.find_scope k); k + with UserError _ -> + Notation.find_delimiters_scope o k)) scopes + in + vernac_arguments_scope locality reference scopes + end; + + if implicits_specified || clear_implicits_flag then + vernac_declare_implicits locality reference implicits; + + if default_implicits_flag then + vernac_declare_implicits locality reference []; + + if red_modifiers_specified then begin + match sr with + | ConstRef _ as c -> + Reductionops.ReductionBehaviour.set + (make_section_locality locality) c + (rargs, Option.default ~-1 nargs_for_red, red_flags) + | _ -> user_err + (strbrk "Modifiers of the behavior of the simpl tactic "++ + strbrk "are relevant for constants only.") + end; + + if not (renaming_specified || + implicits_specified || + scopes_specified || + red_modifiers_specified) && (List.is_empty flags) then + warn_arguments_assert sr + +let default_env () = { + Notation_term.ninterp_var_type = Id.Map.empty; + ninterp_rec_vars = Id.Map.empty; +} + +let vernac_reserve bl = + let sb_decl = (fun (idl,c) -> + 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_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 + +let vernac_generalizable locality = + let local = make_non_locality locality in + Implicit_quantifiers.declare_generalizable local + +let _ = + declare_bool_option + { optsync = false; + optdepr = false; + optname = "silent"; + optkey = ["Silent"]; + optread = is_silent; + optwrite = make_silent } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "implicit arguments"; + optkey = ["Implicit";"Arguments"]; + optread = Impargs.is_implicit_args; + optwrite = Impargs.make_implicit_args } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "strict implicit arguments"; + optkey = ["Strict";"Implicit"]; + optread = Impargs.is_strict_implicit_args; + optwrite = Impargs.make_strict_implicit_args } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "strong strict implicit arguments"; + optkey = ["Strongly";"Strict";"Implicit"]; + optread = Impargs.is_strongly_strict_implicit_args; + optwrite = Impargs.make_strongly_strict_implicit_args } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "contextual implicit arguments"; + optkey = ["Contextual";"Implicit"]; + optread = Impargs.is_contextual_implicit_args; + optwrite = Impargs.make_contextual_implicit_args } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "implicit status of reversible patterns"; + optkey = ["Reversible";"Pattern";"Implicit"]; + optread = Impargs.is_reversible_pattern_implicit_args; + optwrite = Impargs.make_reversible_pattern_implicit_args } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "maximal insertion of implicit"; + optkey = ["Maximal";"Implicit";"Insertion"]; + optread = Impargs.is_maximal_implicit_args; + optwrite = Impargs.make_maximal_implicit_args } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "automatic introduction of variables"; + optkey = ["Automatic";"Introduction"]; + optread = Flags.is_auto_intros; + optwrite = make_auto_intros } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "coercion printing"; + optkey = ["Printing";"Coercions"]; + optread = (fun () -> !Constrextern.print_coercions); + optwrite = (fun b -> Constrextern.print_coercions := b) } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "printing of existential variable instances"; + optkey = ["Printing";"Existential";"Instances"]; + optread = (fun () -> !Detyping.print_evar_arguments); + optwrite = (:=) Detyping.print_evar_arguments } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "implicit arguments printing"; + optkey = ["Printing";"Implicit"]; + optread = (fun () -> !Constrextern.print_implicits); + optwrite = (fun b -> Constrextern.print_implicits := b) } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "implicit arguments defensive printing"; + optkey = ["Printing";"Implicit";"Defensive"]; + optread = (fun () -> !Constrextern.print_implicits_defensive); + optwrite = (fun b -> Constrextern.print_implicits_defensive := b) } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "projection printing using dot notation"; + optkey = ["Printing";"Projections"]; + optread = (fun () -> !Constrextern.print_projections); + optwrite = (fun b -> Constrextern.print_projections := b) } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "notations printing"; + optkey = ["Printing";"Notations"]; + optread = (fun () -> not !Constrextern.print_no_symbol); + optwrite = (fun b -> Constrextern.print_no_symbol := not b) } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "raw printing"; + optkey = ["Printing";"All"]; + optread = (fun () -> !Flags.raw_print); + optwrite = (fun b -> Flags.raw_print := b) } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "record printing"; + optkey = ["Printing";"Records"]; + optread = (fun () -> !Flags.record_print); + optwrite = (fun b -> Flags.record_print := b) } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "use of the program extension"; + optkey = ["Program";"Mode"]; + optread = (fun () -> !Flags.program_mode); + optwrite = (fun b -> Flags.program_mode:=b) } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "universe polymorphism"; + optkey = ["Universe"; "Polymorphism"]; + optread = Flags.is_universe_polymorphism; + optwrite = Flags.make_universe_polymorphism } + +let _ = + declare_int_option + { optsync = true; + optdepr = false; + optname = "the level of inlining during functor application"; + optkey = ["Inline";"Level"]; + optread = (fun () -> Some (Flags.get_inline_level ())); + optwrite = (fun o -> + let lev = Option.default Flags.default_inline_level o in + Flags.set_inline_level lev) } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "kernel term sharing"; + optkey = ["Kernel"; "Term"; "Sharing"]; + optread = (fun () -> !CClosure.share); + optwrite = (fun b -> CClosure.share := b) } + +(* No more undo limit in the new proof engine. + The command still exists for compatibility (e.g. with ProofGeneral) *) + +let _ = + declare_int_option + { optsync = false; + optdepr = true; + optname = "the undo limit (OBSOLETE)"; + optkey = ["Undo"]; + optread = (fun _ -> None); + optwrite = (fun _ -> ()) } + +let _ = + declare_int_option + { optsync = false; + optdepr = false; + optname = "the hypotheses limit"; + optkey = ["Hyps";"Limit"]; + optread = Flags.print_hyps_limit; + optwrite = Flags.set_print_hyps_limit } + +let _ = + declare_int_option + { optsync = true; + optdepr = false; + optname = "the printing depth"; + optkey = ["Printing";"Depth"]; + optread = Pp_control.get_depth_boxes; + optwrite = Pp_control.set_depth_boxes } + +let _ = + declare_int_option + { optsync = true; + optdepr = false; + optname = "the printing width"; + optkey = ["Printing";"Width"]; + optread = Pp_control.get_margin; + optwrite = Pp_control.set_margin } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "printing of universes"; + optkey = ["Printing";"Universes"]; + optread = (fun () -> !Constrextern.print_universes); + optwrite = (fun b -> Constrextern.print_universes:=b) } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "dumping bytecode after compilation"; + optkey = ["Dump";"Bytecode"]; + optread = Flags.get_dump_bytecode; + optwrite = Flags.set_dump_bytecode } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "explicitly parsing implicit arguments"; + optkey = ["Parsing";"Explicit"]; + optread = (fun () -> !Constrintern.parsing_explicit); + optwrite = (fun b -> Constrintern.parsing_explicit := b) } + +let _ = + declare_string_option ~preprocess:CWarnings.normalize_flags_string + { optsync = true; + optdepr = false; + optname = "warnings display"; + optkey = ["Warnings"]; + optread = CWarnings.get_flags; + optwrite = CWarnings.set_flags } + +let vernac_set_strategy locality l = + let local = make_locality locality in + let glob_ref r = + match smart_global r with + | ConstRef sp -> EvalConstRef sp + | VarRef id -> EvalVarRef id + | _ -> error + "cannot set an inductive type or a constructor as transparent" in + let l = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) l in + Redexpr.set_strategy local l + +let vernac_set_opacity locality (v,l) = + let local = make_non_locality locality in + let glob_ref r = + match smart_global r with + | ConstRef sp -> EvalConstRef sp + | VarRef id -> EvalVarRef id + | _ -> error + "cannot set an inductive type or a constructor as transparent" in + let l = List.map glob_ref l in + Redexpr.set_strategy local [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 + +let vernac_set_append_option locality key s = + set_string_option_append_value_gen locality key s + +let vernac_unset_option locality key = + unset_option_value_gen locality key + +let vernac_add_option key lv = + let f = function + | StringRefValue s -> (get_string_table key)#add s + | QualidRefValue locqid -> (get_ref_table key)#add locqid + in + try List.iter f lv with Not_found -> error_undeclared_key key + +let vernac_remove_option key lv = + let f = function + | StringRefValue s -> (get_string_table key)#remove s + | QualidRefValue locqid -> (get_ref_table key)#remove locqid + in + try List.iter f lv with Not_found -> error_undeclared_key key + +let vernac_mem_option key lv = + let f = function + | StringRefValue s -> (get_string_table key)#mem s + | QualidRefValue locqid -> (get_ref_table key)#mem locqid + in + try List.iter f lv with Not_found -> error_undeclared_key key + +let vernac_print_option key = + try (get_ref_table key)#print + with Not_found -> + try (get_string_table key)#print + with Not_found -> + try print_option_value key + with Not_found -> error_undeclared_key key + +let get_current_context_of_args = function + | Some n -> get_goal_context n + | None -> get_current_context () + +let vernac_check_may_eval redexp glopt rc = + let (sigma, env) = get_current_context_of_args glopt in + let sigma', c = interp_open_constr env sigma rc in + let sigma' = Evarconv.solve_unif_constraints_with_heuristics env sigma' in + Evarconv.check_problems_are_solved env sigma'; + let sigma',nf = Evarutil.nf_evars_and_universes 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 = + if Evarutil.has_undefined_evars sigma' c then + Evarutil.j_nf_evar sigma' (Retyping.get_judgment_of env sigma' c) + else + (* OK to call kernel which does not support evars *) + Arguments_renaming.rename_typing env c in + match redexp with + | None -> + let l = Evar.Set.union (Evd.evars_of_term j.Environ.uj_val) (Evd.evars_of_term j.Environ.uj_type) in + let j = { j with Environ.uj_type = Reductionops.nf_betaiota sigma' j.Environ.uj_type } in + Feedback.msg_notice (print_judgment env sigma' j ++ + pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++ + Printer.pr_universe_ctx sigma uctx) + | Some 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 + let evm = Sigma.Unsafe.of_evar_map evm in + let Sigma (c, _, _) = redfun.Reductionops.e_redfun env evm c in + c + in + Feedback.msg_notice (print_eval redfun env sigma' rc j) + +let vernac_declare_reduction locality s r = + let local = make_locality locality in + 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 = + let env = Global.env() in + 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 (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 + Feedback.msg_notice (print_safe_judgment env sigma j) + + +let get_nth_goal n = + let pf = get_pftreestate() in + let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in + let gl = {Evd.it=List.nth gls (n-1) ; sigma = sigma; } in + gl + +exception NoHyp +(* Printing "About" information of a hypothesis of the current goal. + 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 + | None,AN (Ident (_loc,id)) -> (* goal number not given, catch any failure *) + (try get_nth_goal 1,id with _ -> raise NoHyp) + | Some n,AN (Ident (_loc,id)) -> (* goal number given, catch if wong *) + (try get_nth_goal n,id + with + Failure _ -> user_err ~hdr:"print_about_hyp_globs" + (str "No such goal: " ++ int n ++ str ".")) + | _ , _ -> raise NoHyp in + let hyps = pf_hyps gl in + 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 (NamedDecl.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 + + +let vernac_print = let open Feedback in function + | PrintTables -> msg_notice (print_tables ()) + | PrintFullContext-> msg_notice (print_full_context_typ ()) + | PrintSectionContext qid -> msg_notice (print_sec_context_typ qid) + | PrintInspect n -> msg_notice (inspect n) + | PrintGrammar ent -> msg_notice (Metasyntax.pr_grammar ent) + | PrintLoadPath dir -> (* For compatibility ? *) msg_notice (print_loadpath dir) + | PrintModules -> msg_notice (print_modules ()) + | PrintModule qid -> print_module qid + | PrintModuleType qid -> print_modtype qid + | PrintNamespace ns -> print_namespace ns + | PrintMLLoadPath -> msg_notice (Mltop.print_ml_path ()) + | PrintMLModules -> msg_notice (Mltop.print_ml_modules ()) + | PrintDebugGC -> msg_notice (Mltop.print_gc ()) + | PrintName qid -> dump_global qid; msg_notice (print_name qid) + | PrintGraph -> msg_notice (Prettyp.print_graph()) + | PrintClasses -> msg_notice (Prettyp.print_classes()) + | PrintTypeClasses -> msg_notice (Prettyp.print_typeclasses()) + | PrintInstances c -> msg_notice (Prettyp.print_instances (smart_global c)) + | PrintCoercions -> msg_notice (Prettyp.print_coercions()) + | 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, dst) -> + let univ = Global.universes () 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 + begin match dst with + | None -> msg_notice (UGraph.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) + | PrintHintDb -> msg_notice (Hints.pr_searchtable ()) + | PrintScopes -> + msg_notice (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr)) + | PrintScope s -> + msg_notice (Notation.pr_scope (Constrextern.without_symbols pr_lglob_constr) s) + | PrintVisibility s -> + msg_notice (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s) + | PrintAbout (ref_or_by_not,glnumopt) -> + msg_notice (print_about_hyp_globs ref_or_by_not glnumopt) + | PrintImplicit qid -> + dump_global qid; msg_notice (print_impargs qid) + | PrintAssumptions (o,t,r) -> + (* Prints all the axioms and section variables used by a term *) + let gr = smart_global r in + let cstr = printable_constr_of_global gr in + let st = Conv_oracle.get_transp_state (Environ.oracle (Global.env())) in + let nassums = + Assumptions.assumptions st ~add_opaque:o ~add_transparent:t gr cstr in + msg_notice (Printer.pr_assumptionset (Global.env ()) nassums) + | PrintStrategy r -> print_strategy r + +let global_module r = + let (loc,qid) = qualid_of_reference r in + try Nametab.full_name_module qid + with Not_found -> + user_err ~loc ~hdr:"global_module" + (str "Module/section " ++ pr_qualid qid ++ str " not found.") + +let interp_search_restriction = function + | SearchOutside l -> (List.map global_module l, true) + | SearchInside l -> (List.map global_module l, false) + +open Search + +let interp_search_about_item env = + function + | SearchSubPattern pat -> + let _,pat = intern_constr_pattern env pat in + GlobSearchSubPattern pat + | SearchString (s,None) when Id.is_valid s -> + GlobSearchString s + | SearchString (s,sc) -> + try + let ref = + Notation.interp_notation_as_global_reference Loc.ghost + (fun _ -> true) s sc in + GlobSearchSubPattern (Pattern.PRef ref) + with UserError _ -> + user_err ~hdr:"interp_search_about_item" + (str "Unable to interp \"" ++ str s ++ str "\" either as a reference or as an identifier component") + +(* 05f22a5d6d5b8e3e80f1a37321708ce401834430 introduced the + `search_output_name_only` option to avoid excessive printing when + searching. + + The motivation was to make search usable for IDE completion, + however, it is still too slow due to the non-indexed nature of the + underlying search mechanism. + + In the future we should deprecate the option and provide a fast, + indexed name-searching interface. +*) +let search_output_name_only = ref false + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "output-name-only search"; + optkey = ["Search";"Output";"Name";"Only"]; + optread = (fun () -> !search_output_name_only); + optwrite = (:=) search_output_name_only } + +let vernac_search s gopt r = + let r = interp_search_restriction r in + let env,gopt = + match gopt with | None -> + (* 1st goal by default if it exists, otherwise no goal at all *) + (try snd (Pfedit.get_goal_context 1) , Some 1 + with _ -> Global.env (),None) + (* if goal selector is given and wrong, then let exceptions be raised. *) + | Some g -> snd (Pfedit.get_goal_context g) , Some g + in + let get_pattern c = snd (intern_constr_pattern env c) in + let pr_search ref env c = + let pr = pr_global ref in + let pp = if !search_output_name_only + then pr + else begin + let pc = pr_lconstr_env env Evd.empty c in + hov 2 (pr ++ str":" ++ spc () ++ pc) + end + in Feedback.msg_notice pp + in + match s with + | SearchPattern c -> + (Search.search_pattern gopt (get_pattern c) r |> Search.prioritize_search) pr_search + | SearchRewrite c -> + (Search.search_rewrite gopt (get_pattern c) r |> Search.prioritize_search) pr_search + | SearchHead c -> + (Search.search_by_head gopt (get_pattern c) r |> Search.prioritize_search) pr_search + | SearchAbout sl -> + (Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r |> Search.prioritize_search) pr_search + +let vernac_locate = let open Feedback in function + | LocateAny (AN qid) -> msg_notice (print_located_qualid qid) + | LocateTerm (AN qid) -> msg_notice (print_located_term qid) + | LocateAny (ByNotation (_, ntn, sc)) (** TODO : handle Ltac notations *) + | LocateTerm (ByNotation (_, ntn, sc)) -> + msg_notice + (Notation.locate_notation + (Constrextern.without_symbols pr_lglob_constr) ntn sc) + | LocateLibrary qid -> print_located_library qid + | LocateModule qid -> msg_notice (print_located_module qid) + | LocateTactic qid -> msg_notice (print_located_tactic qid) + | LocateFile f -> msg_notice (locate_file f) + +let vernac_register id r = + if Pfedit.refining () then + error "Cannot register a primitive while in proof editing mode."; + let t = (Constrintern.global_reference (snd id)) in + if not (isConst t) then + error "Register inline: a constant is expected"; + let kn = destConst t in + match r with + | RegisterInline -> Global.register_inline (Univ.out_punivs kn) + +(********************) +(* Proof management *) + +let vernac_focus gln = + Proof_global.simple_with_current_proof (fun _ p -> + match gln with + | None -> Proof.focus focus_command_cond () 1 p + | Some 0 -> + CErrors.error "Invalid goal number: 0. Goal numbering starts with 1." + | Some n -> + Proof.focus focus_command_cond () n p) + + (* Unfocuses one step in the focus stack. *) +let vernac_unfocus () = + Proof_global.simple_with_current_proof + (fun _ p -> Proof.unfocus command_focus p ()) + +(* Checks that a proof is fully unfocused. Raises an error if not. *) +let vernac_unfocused () = + let p = Proof_global.give_me_the_proof () in + if Proof.unfocused p then + Feedback.msg_notice (str"The proof is indeed fully unfocused.") + else + error "The proof is not fully unfocused." + + +(* BeginSubproof / EndSubproof. + BeginSubproof (vernac_subproof) focuses on the first goal, or the goal + given as argument. + EndSubproof (vernac_end_subproof) unfocuses from a BeginSubproof, provided + that the proof of the goal has been completed. +*) +let subproof_kind = Proof.new_focus_kind () +let subproof_cond = Proof.done_cond subproof_kind + +let vernac_subproof gln = + Proof_global.simple_with_current_proof (fun _ p -> + match gln with + | None -> Proof.focus subproof_cond () 1 p + | Some n -> Proof.focus subproof_cond () n p) + +let vernac_end_subproof () = + Proof_global.simple_with_current_proof (fun _ p -> + Proof.unfocus subproof_kind p ()) + +let vernac_bullet (bullet:Proof_global.Bullet.t) = + Proof_global.simple_with_current_proof (fun _ p -> + Proof_global.Bullet.put p bullet) + +let vernac_show = let open Feedback in function + | ShowGoal goalref -> + let info = match goalref with + | 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 -> + Constrextern.with_implicits msg_notice (pr_open_subgoals ()) + | ShowGoalImplicitly (Some n) -> + Constrextern.with_implicits msg_notice (pr_nth_open_subgoal n) + | ShowProof -> show_proof () + | ShowNode -> show_node () + | ShowScript -> (* Stm.show_script () *) () + | ShowExistentials -> show_top_evars () + | ShowUniverses -> show_universes () + | ShowTree -> show_prooftree () + | ShowProofNames -> + msg_notice (pr_sequence pr_id (Pfedit.get_all_proof_names())) + | ShowIntros all -> show_intro all + | ShowMatch id -> show_match id + | ShowThesis -> show_thesis () + + +let vernac_check_guard () = + let pts = get_pftreestate () in + let pfterm = List.hd (Proof.partial_proof pts) in + let message = + try + let { Evd.it=gl ; sigma=sigma } = Proof.V82.top_goal pts in + Inductiveops.control_only_guard (Goal.V82.env sigma gl) + pfterm; + (str "The condition holds up to here") + with UserError(_,s) -> + (str ("Condition violated: ") ++s) + in + Feedback.msg_notice message + +exception End_of_input + +(* XXX: This won't properly set the proof mode, as of today, it is + controlled by the STM. Thus, we would need access information from + the classifier. The proper fix is to move it to the STM, however, + the way the proof mode is set there makes the task non trivial + without a considerable amount of refactoring. + *) +let vernac_load interp fname = + let interp x = + let proof_mode = Proof_global.get_default_proof_mode_name () in + Proof_global.activate_proof_mode proof_mode; + interp x in + let parse_sentence = Flags.with_option Flags.we_are_parsing + (fun po -> + match Pcoq.Gram.entry_parse Pcoq.main_entry po with + | Some x -> x + | None -> raise End_of_input) in + let fname = + Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in + let fname = CUnix.make_suffix fname ".v" in + let input = + let longfname = Loadpath.locate_file fname in + let in_chan = open_utf8_file_in longfname in + Pcoq.Gram.parsable ~file:longfname (Stream.of_channel in_chan) in + try while true do interp (snd (parse_sentence input)) done + with End_of_input -> () + +(* "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. + * loc is the Loc.t of the vernacular command being interpreted. *) +let interp ?proof ~loc locality poly c = + prerr_endline (fun () -> "interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c)); + match c with + (* The below vernac are candidates for removal from the main type + and to be put into a new doc_command datatype: *) + + | VernacLoad _ -> assert false + + (* Done later in this file *) + | VernacFail _ -> assert false + | VernacTime _ -> assert false + | VernacRedirect _ -> assert false + | VernacTimeout _ -> assert false + | VernacStm _ -> assert false + + (* The STM should handle that, but LOAD bypasses the STM... *) + | VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command") + | VernacRestart -> CErrors.user_err (str "Restart cannot be used through the Load command") + | VernacUndo _ -> CErrors.user_err (str "Undo cannot be used through the Load command") + | VernacUndoTo _ -> CErrors.user_err (str "UndoTo cannot be used through the Load command") + | VernacBacktrack _ -> CErrors.user_err (str "Backtrack cannot be used through the Load command") + + (* Toplevel control *) + | VernacToplevelControl e -> raise e + + (* Resetting *) + | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm") + | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm") + | VernacBack _ -> anomaly (str "VernacBack not handled by Stm") + | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm") + + (* Horrible Hack that should die. *) + | VernacError e -> raise e + + (* This one is possible to handle here *) + | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") + + (* Handled elsewhere *) + | VernacProgram _ + | VernacPolymorphic _ + | VernacLocal _ -> assert false + + (* Syntax *) + | VernacSyntaxExtension (local,sl) -> + vernac_syntax_extension locality local sl + | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr + | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl + | VernacOpenCloseScope (local, s) -> vernac_open_close_scope locality local s + | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope locality qid scl + | VernacInfix (local,mv,qid,sc) -> vernac_infix locality local mv qid sc + | VernacNotation (local,c,infpl,sc) -> + vernac_notation locality local c infpl sc + | VernacNotationAddFormat(n,k,v) -> + Metasyntax.add_notation_extra_printing_rule n k v + + (* Gallina *) + | VernacDefinition (k,lid,d) -> vernac_definition locality poly k lid d + | 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 + | VernacInductive (priv,finite,l) -> vernac_inductive poly priv finite l + | VernacFixpoint (local, l) -> vernac_fixpoint locality poly local l + | 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 loc poly l + | VernacConstraint l -> vernac_constraint loc poly l + + (* Modules *) + | VernacDeclareModule (export,lid,bl,mtyo) -> + vernac_declare_module export lid bl mtyo + | VernacDefineModule (export,lid,bl,mtys,mexprl) -> + vernac_define_module export lid bl mtys mexprl + | VernacDeclareModuleType (lid,bl,mtys,mtyo) -> + vernac_declare_module_type lid bl mtys mtyo + | VernacInclude in_asts -> + vernac_include in_asts + (* Gallina extensions *) + | VernacBeginSection lid -> vernac_begin_section lid + + | VernacEndSegment lid -> vernac_end_segment lid + + | VernacNameSectionHypSet (lid, set) -> vernac_name_sec_hyp lid set + + | VernacRequire (from, export, qidl) -> vernac_require from export qidl + | VernacImport (export,qidl) -> vernac_import export qidl + | VernacCanonical qid -> vernac_canonical qid + | VernacCoercion (local,r,s,t) -> vernac_coercion locality poly local r s t + | VernacIdentityCoercion (local,(_,id),s,t) -> + vernac_identity_coercion locality poly local id s t + + (* Type classes *) + | VernacInstance (abst, sup, inst, props, info) -> + vernac_instance abst locality poly sup inst props info + | VernacContext sup -> vernac_context poly sup + | VernacDeclareInstances insts -> vernac_declare_instances locality insts + | VernacDeclareClass id -> vernac_declare_class id + + (* Solving *) + | VernacSolveExistential (n,c) -> vernac_solve_existential n c + + (* Auxiliary file and library management *) + | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias + | VernacRemoveLoadPath s -> vernac_remove_loadpath s + | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s + | VernacDeclareMLModule l -> vernac_declare_ml_module locality l + | VernacChdir s -> vernac_chdir s + + (* State management *) + | VernacWriteState s -> vernac_write_state s + | VernacRestoreState s -> vernac_restore_state s + + (* Commands *) + | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b + | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids + | VernacHints (local,dbnames,hints) -> + vernac_hints locality poly local dbnames hints + | VernacSyntacticDefinition (id,c,local,b) -> + vernac_syntactic_definition locality id c local b + | VernacDeclareImplicits (qid,l) -> + vernac_declare_implicits locality qid l + | VernacArguments (qid, args, more_implicits, nargs, flags) -> + vernac_arguments locality qid args more_implicits nargs flags + | VernacReserve bl -> vernac_reserve bl + | VernacGeneralizable gen -> vernac_generalizable locality gen + | VernacSetOpacity qidl -> vernac_set_opacity locality qidl + | VernacSetStrategy l -> vernac_set_strategy locality l + | VernacSetOption (key,v) -> vernac_set_option locality key v + | VernacSetAppendOption (key,v) -> vernac_set_append_option locality key v + | VernacUnsetOption key -> vernac_unset_option locality key + | VernacRemoveOption (key,v) -> vernac_remove_option key v + | VernacAddOption (key,v) -> vernac_add_option key v + | VernacMemOption (key,v) -> vernac_mem_option key v + | VernacPrintOption key -> vernac_print_option key + | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval r g c + | VernacDeclareReduction (s,r) -> vernac_declare_reduction locality s r + | VernacGlobalCheck c -> vernac_global_check c + | VernacPrint p -> vernac_print p + | VernacSearch (s,g,r) -> vernac_search s g r + | VernacLocate l -> vernac_locate l + | VernacRegister (id, r) -> vernac_register id r + | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n") + + (* Proof management *) + | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t,None)] false + | VernacFocus n -> vernac_focus n + | VernacUnfocus -> vernac_unfocus () + | VernacUnfocused -> vernac_unfocused () + | VernacBullet b -> vernac_bullet b + | VernacSubproof n -> vernac_subproof n + | VernacEndSubproof -> vernac_end_subproof () + | VernacShow s -> vernac_show s + | VernacCheckGuard -> vernac_check_guard () + | 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 + + (* Extensions *) + | VernacExtend (opn,args) -> Vernacinterp.call ?locality (opn,args) + +(* Vernaculars that take a locality flag *) +let check_vernac_supports_locality c l = + match l, c with + | None, _ -> () + | Some _, ( + VernacOpenCloseScope _ + | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _ + | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ + | VernacAssumption _ | VernacStartTheoremProof _ + | VernacCoercion _ | VernacIdentityCoercion _ + | VernacInstance _ | VernacDeclareInstances _ + | VernacDeclareMLModule _ + | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _ + | VernacSyntacticDefinition _ + | VernacArgumentsScope _ | VernacDeclareImplicits _ | VernacArguments _ + | VernacGeneralizable _ + | VernacSetOpacity _ | VernacSetStrategy _ + | VernacSetOption _ | VernacSetAppendOption _ | VernacUnsetOption _ + | VernacDeclareReduction _ + | VernacExtend _ + | VernacInductive _) -> () + | Some _, _ -> CErrors.error "This command does not support Locality" + +(* Vernaculars that take a polymorphism flag *) +let check_vernac_supports_polymorphism c p = + match p, c with + | None, _ -> () + | Some _, ( + VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ + | VernacAssumption _ | VernacInductive _ + | VernacStartTheoremProof _ + | VernacCoercion _ | VernacIdentityCoercion _ + | VernacInstance _ | VernacDeclareInstances _ + | VernacHints _ | VernacContext _ + | VernacExtend _ | VernacUniverse _ | VernacConstraint _) -> () + | Some _, _ -> CErrors.error "This command does not support Polymorphism" + +let enforce_polymorphism = function + | None -> Flags.is_universe_polymorphism () + | Some b -> Flags.make_polymorphic_flag b; b + +(** A global default timeout, controlled by option "Set Default Timeout n". + Use "Unset Default Timeout" to deactivate it (or set it to 0). *) + +let default_timeout = ref None + +let _ = + Goptions.declare_int_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "the default timeout"; + Goptions.optkey = ["Default";"Timeout"]; + Goptions.optread = (fun () -> !default_timeout); + Goptions.optwrite = ((:=) default_timeout) } + +(** When interpreting a command, the current timeout is initially + the default one, but may be modified locally by a Timeout command. *) + +let current_timeout = ref None + +let vernac_timeout f = + match !current_timeout, !default_timeout with + | Some n, _ | None, Some n -> + let f () = f (); current_timeout := None in + Control.timeout n f Timeout + | None, None -> f () + +let restore_timeout () = current_timeout := None + +let locate_if_not_already loc (e, info) = + match Loc.get_loc info with + | None -> (e, Loc.add_loc info loc) + | Some l -> if Loc.is_ghost l then (e, Loc.add_loc info loc) else (e, info) + +exception HasNotFailed +exception HasFailed of std_ppcmds + +let with_fail b f = + if not b then f () + else begin try + (* If the command actually works, ignore its effects on the state. + * Note that error has to be printed in the right state, hence + * within the purified function *) + Future.purify + (fun v -> + try f v; raise HasNotFailed + with + | HasNotFailed as e -> raise e + | e -> + let e = CErrors.push e in + raise (HasFailed (CErrors.iprint + (ExplainErr.process_vernac_interp_error ~allow_uncaught:false ~with_header:false e)))) + () + with e when CErrors.noncritical e -> + let (e, _) = CErrors.push e in + match e with + | HasNotFailed -> + user_err ~hdr:"Fail" (str "The command has not failed!") + | HasFailed msg -> + if is_verbose () || !test_mode || !ide_slave then Feedback.msg_info + (str "The command has indeed failed with message:" ++ fnl () ++ msg) + | _ -> assert false + end + +let interp ?(verbosely=true) ?proof (loc,c) = + let orig_program_mode = Flags.is_program_mode () in + let rec aux ?locality ?polymorphism isprogcmd = function + | VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c + | VernacProgram _ -> CErrors.error "Program mode specified twice" + | VernacLocal (b, c) when Option.is_empty locality -> + aux ~locality:b ?polymorphism isprogcmd c + | VernacPolymorphic (b, c) when polymorphism = None -> + aux ?locality ~polymorphism:b isprogcmd c + | VernacPolymorphic (b, c) -> CErrors.error "Polymorphism specified twice" + | VernacLocal _ -> CErrors.error "Locality specified twice" + | VernacStm (Command c) -> aux ?locality ?polymorphism isprogcmd c + | VernacStm (PGLast c) -> aux ?locality ?polymorphism isprogcmd c + | VernacStm _ -> assert false (* Done by Stm *) + | VernacFail v -> + with_fail true (fun () -> aux ?locality ?polymorphism isprogcmd v) + | VernacTimeout (n,v) -> + current_timeout := Some n; + aux ?locality ?polymorphism isprogcmd v + | VernacRedirect (s, (_,v)) -> + Feedback.with_output_to_file s (aux false) v + | VernacTime (_,v) -> + System.with_time !Flags.time + (aux ?locality ?polymorphism isprogcmd) v; + | VernacLoad (_,fname) -> vernac_load (aux false) fname + | c -> + check_vernac_supports_locality c locality; + check_vernac_supports_polymorphism c polymorphism; + let poly = enforce_polymorphism polymorphism in + Obligations.set_program_mode isprogcmd; + try + vernac_timeout begin fun () -> + 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; + ignore (Flags.use_polymorphic_flag ()) + end + with + | reraise when + (match reraise with + | Timeout -> true + | e -> CErrors.noncritical e) + -> + let e = CErrors.push reraise in + 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 + in + if verbosely then Flags.verbosely (aux false) c + else aux false c diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli new file mode 100644 index 0000000000..7cdc8dd064 --- /dev/null +++ b/vernac/vernacentries.mli @@ -0,0 +1,66 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit + +(** Vernacular entries *) + +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 + +(** The main interpretation function of vernacular expressions *) +val interp : + ?verbosely:bool -> + ?proof:Proof_global.closed_proof -> + Loc.t * Vernacexpr.vernac_expr -> unit + +(** Print subgoals when the verbose flag is on. + Meant to be used inside vernac commands from plugins. *) + +val print_subgoals : unit -> unit +val try_print_subgoals : unit -> unit + +(** The printing of goals via [print_subgoals] or during + [interp] can be controlled by the following flag. + Used for instance by coqide, since it has its own + goal-fetching mechanism. *) + +val enable_goal_printing : bool ref + +(** Should Qed try to display the proof script ? + True by default, but false in ProofGeneral and coqIDE *) + +val qed_display_script : bool ref + +(** Prepare a "match" template for a given inductive type. + For each branch of the match, we list the constructor name + followed by enough pattern variables. + [Not_found] is raised if the given string isn't the qualid of + a known inductive type. *) + +val make_cases : string -> string list list + +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 + +val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> + Evd.evar_map * Redexpr.red_expr) Hook.t diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml new file mode 100644 index 0000000000..f26ef460dd --- /dev/null +++ b/vernac/vernacinterp.ml @@ -0,0 +1,77 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit -> unit + +(* Table of vernac entries *) +let vernac_tab = + (Hashtbl.create 51 : + (Vernacexpr.extend_name, deprecation * vernac_command) Hashtbl.t) + +let vinterp_add depr s f = + try + Hashtbl.add vernac_tab s (depr, f) + with Failure _ -> + user_err ~hdr:"vinterp_add" + (str"Cannot add the vernac command " ++ str (fst s) ++ str" twice.") + +let overwriting_vinterp_add s f = + begin + try + let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s + with Not_found -> () + end; + Hashtbl.add vernac_tab s (false, f) + +let vinterp_map s = + try + Hashtbl.find vernac_tab s + with Failure _ | Not_found -> + user_err ~hdr:"Vernac Interpreter" + (str"Cannot find vernac command " ++ str (fst s) ++ str".") + +let vinterp_init () = Hashtbl.clear vernac_tab + +let warn_deprecated_command = + let open CWarnings in + create ~name:"deprecated-command" ~category:"deprecated" + (fun pr -> str "Deprecated vernacular command: " ++ pr) + +(* Interpretation of a vernac command *) + +let call ?locality (opn,converted_args) = + let loc = ref "Looking up command" in + try + let depr, callback = vinterp_map opn in + let () = if depr then + let rules = Egramml.get_extend_vernac_rule opn in + let pr_gram = function + | Egramml.GramTerminal s -> str s + | Egramml.GramNonTerminal _ -> str "_" + in + let pr = pr_sequence pr_gram rules in + warn_deprecated_command pr; + in + loc:= "Checking arguments"; + let hunk = callback converted_args in + loc:= "Executing command"; + Locality.LocalityFixme.set locality; + hunk(); + Locality.LocalityFixme.assert_consumed() + with + | Drop -> raise Drop + | reraise -> + let reraise = CErrors.push reraise in + if !Flags.debug then + Feedback.msg_debug (str"Vernac Interpreter " ++ str !loc); + iraise reraise diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli new file mode 100644 index 0000000000..5149b5416d --- /dev/null +++ b/vernac/vernacinterp.mli @@ -0,0 +1,20 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit -> unit + +val vinterp_add : deprecation -> Vernacexpr.extend_name -> + vernac_command -> unit +val overwriting_vinterp_add : + Vernacexpr.extend_name -> vernac_command -> unit + +val vinterp_init : unit -> unit +val call : ?locality:bool -> Vernacexpr.extend_name * Genarg.raw_generic_argument list -> unit -- cgit v1.2.3 From fc6e78be83cef6e9b249ca146ef749ba90eb802c Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 23 Jan 2017 22:21:11 +0100 Subject: [stm] Reenable Show Script command. We extend `Stm.vernac_interp` so it can handle the commands it should by level. This reenables `Show Script` handling, and this interpretation function should handle more commands in the future such as Load. However note that we must first refactor the parsing state handling a bit and remove the legacy `Stm.interp` before that. --- stm/stm.ml | 274 +++++++++++++++++++++++++----------------------- stm/stm.mli | 1 - vernac/vernacentries.ml | 11 +- 3 files changed, 143 insertions(+), 143 deletions(-) diff --git a/stm/stm.ml b/stm/stm.ml index be3e841cb9..1cd6209aa4 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -103,38 +103,6 @@ let may_pierce_opaque = function | { expr = VernacExtend (("ExtractionInductive",_), _) } -> true | _ -> false -(* Wrapper for Vernacentries.interp to set the feedback id *) -(* It is currently called 19 times, this number should be certainly - reduced... *) -let stm_vernac_interp ?proof id ?route { verbose; loc; expr } = - (* The Stm will gain the capability to interpret commmads affecting - the whole document state, such as backtrack, etc... so we start - to design the stm command interpreter now *) - set_id_for_feedback ?route (State id); - Aux_file.record_in_aux_set_at loc; - (* We need to check if a command should be filtered from - * vernac_entries, as it cannot handle it. This should go away in - * future refactorings. - *) - let rec is_filtered_command = function - | VernacResetName _ | VernacResetInitial | VernacBack _ - | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ - | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true - | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> is_filtered_command e - | _ -> false - in - let aux_interp cmd = - if is_filtered_command cmd then - prerr_endline (fun () -> "ignoring " ^ Pp.string_of_ppcmds(pr_vernac expr)) - else match cmd with - | expr -> - prerr_endline (fun () -> "interpreting " ^ Pp.string_of_ppcmds(pr_vernac expr)); - try Vernacentries.interp ?verbosely:(Some verbose) ?proof (loc, expr) - with e -> - let e = CErrors.push e in - iraise Hooks.(call_process_error_once e) - in aux_interp expr - (* Wrapper for Vernac.parse_sentence to set the feedback id *) let indentation_of_string s = let len = String.length s in @@ -920,6 +888,127 @@ end = struct (* {{{ *) end (* }}} *) +(* indentation code for Show Script, initially contributed + * by D. de Rauglaudre. Should be moved away. + *) + +module ShowScript = struct + +let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) = + (* ng1 : number of goals remaining at the current level (before cmd) + ngl1 : stack of previous levels with their remaining goals + ng : number of goals after the execution of cmd + beginend : special indentation stack for { } *) + let ngprev = List.fold_left (+) ng1 ngl1 in + let new_ngl = + if ng > ngprev then + (* We've branched *) + (ng - ngprev + 1, ng1 - 1 :: ngl1) + else if ng < ngprev then + (* A subgoal have been solved. Let's compute the new current level + by discarding all levels with 0 remaining goals. *) + let rec loop = function + | (0, ng2::ngl2) -> loop (ng2,ngl2) + | p -> p + in loop (ng1-1, ngl1) + else + (* Standard case, same goal number as before *) + (ng1, ngl1) + in + (* When a subgoal have been solved, separate this block by an empty line *) + let new_nl = (ng < ngprev) + in + (* Indentation depth *) + let ind = List.length ngl1 + in + (* Some special handling of bullets and { }, to get a nicer display *) + let pred n = max 0 (n-1) in + let ind, nl, new_beginend = match cmd with + | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend + | VernacEndSubproof -> List.hd beginend, false, List.tl beginend + | VernacBullet _ -> pred ind, nl, beginend + | _ -> ind, nl, beginend + in + let pp = + (if nl then fnl () else mt ()) ++ + (hov (ind+1) (str (String.make ind ' ') ++ Ppvernac.pr_vernac cmd)) + in + (new_ngl, new_nl, new_beginend, pp :: ppl) + +let get_script prf = + let branch, test = + match prf with + | None -> VCS.Branch.master, fun _ -> true + | Some name -> VCS.current_branch (),fun nl -> nl=[] || List.mem name nl in + let rec find acc id = + if Stateid.equal id Stateid.initial || + Stateid.equal id Stateid.dummy then acc else + let view = VCS.visit id in + match view.step with + | `Fork((_,_,_,ns), _) when test ns -> acc + | `Qed (qed, proof) -> find [qed.qast.expr, (VCS.get_info id).n_goals] proof + | `Sideff (`Ast (x,_)) -> + find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next + | `Sideff (`Id id) -> find acc id + | `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *) + find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next + | `Cmd _ -> find acc view.next + | `Alias (id,_) -> find acc id + | `Fork _ -> find acc view.next + in + find [] (VCS.get_branch_pos branch) + +let show_script ?proof () = + try + let prf = + try match proof with + | None -> Some (Pfedit.get_current_proof_name ()) + | Some (p,_) -> Some (p.Proof_global.id) + with Proof_global.NoCurrentProof -> None + in + let cmds = get_script prf in + let _,_,_,indented_cmds = + List.fold_left indent_script_item ((1,[]),false,[],[]) cmds + in + let indented_cmds = List.rev (indented_cmds) in + msg_notice (v 0 (prlist_with_sep fnl (fun x -> x) indented_cmds)) + with Vcs_aux.Expired -> () + +end + +(* Wrapper for Vernacentries.interp to set the feedback id *) +(* It is currently called 19 times, this number should be certainly + reduced... *) +let stm_vernac_interp ?proof id ?route { verbose; loc; expr } = + (* The Stm will gain the capability to interpret commmads affecting + the whole document state, such as backtrack, etc... so we start + to design the stm command interpreter now *) + set_id_for_feedback ?route (State id); + Aux_file.record_in_aux_set_at loc; + (* We need to check if a command should be filtered from + * vernac_entries, as it cannot handle it. This should go away in + * future refactorings. + *) + let rec is_filtered_command = function + | VernacResetName _ | VernacResetInitial | VernacBack _ + | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ + | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true + | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> is_filtered_command e + | _ -> false + in + let aux_interp cmd = + if is_filtered_command cmd then + prerr_endline (fun () -> "ignoring " ^ Pp.string_of_ppcmds(pr_vernac expr)) + else match cmd with + | VernacShow ShowScript -> ShowScript.show_script () + | expr -> + prerr_endline (fun () -> "interpreting " ^ Pp.string_of_ppcmds(pr_vernac expr)); + try Vernacentries.interp ?verbosely:(Some verbose) ?proof (loc, expr) + with e -> + let e = CErrors.push e in + iraise Hooks.(call_process_error_once e) + in aux_interp expr + (****************************** CRUFT *****************************************) (******************************************************************************) @@ -1330,7 +1419,7 @@ end = struct (* {{{ *) Proof_global.close_future_proof stop (Future.from_val ~fix_exn p) in let terminator = (* The one sent by master is an InvalidKey *) Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in - vernac_interp stop + stm_vernac_interp stop ~proof:(pobject, terminator) { verbose = false; loc; indentation = 0; strlen = 0; expr = (VernacEndProof (Proved (Opaque None,None))) }) in @@ -1472,7 +1561,7 @@ end = struct (* {{{ *) (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) Reach.known_state ~cache:`No start; - vernac_interp stop ~proof + stm_vernac_interp stop ~proof { verbose = false; loc; indentation = 0; strlen = 0; expr = (VernacEndProof (Proved (Opaque None,None))) }; `OK proof @@ -1723,7 +1812,7 @@ end = struct (* {{{ *) else begin 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; + stm_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 -> RespNoProgress @@ -1852,7 +1941,7 @@ end = struct (* {{{ *) VCS.print (); Reach.known_state ~cache:`No r_where; try - vernac_interp r_for { r_what with verbose = true }; + stm_vernac_interp r_for { r_what with verbose = true }; feedback ~id:(State r_for) Processed with e when CErrors.noncritical e -> let e = CErrors.push e in @@ -2061,7 +2150,7 @@ let known_state ?(redefine_qed=false) ~cache id = Proof_global.with_current_proof (fun _ p -> feedback ~id:(State id) Feedback.AddedAxiom; fst (Pfedit.solve Vernacexpr.SelectAll None tac p), ()); - Option.iter (fun expr -> vernac_interp id { + Option.iter (fun expr -> stm_vernac_interp id { verbose = true; loc = Loc.ghost; expr; indentation = 0; strlen = 0 }) recovery_command @@ -2140,24 +2229,24 @@ let known_state ?(redefine_qed=false) ~cache id = resilient_tactic id cblock (fun () -> reach view.next; Hooks.(call tactic_being_run true); - vernac_interp id x; + stm_vernac_interp id x; Hooks.(call tactic_being_run false)); if eff then update_global_env () ), (if eff then `Yes else cache), true | `Cmd { cast = x; ceff = eff } -> (fun () -> resilient_command reach view.next; - vernac_interp id x; + stm_vernac_interp id x; if eff then update_global_env () ), (if eff then `Yes else cache), true | `Fork ((x,_,_,_), None) -> (fun () -> resilient_command reach view.next; - vernac_interp id x; + stm_vernac_interp id x; wall_clock_last_fork := Unix.gettimeofday () ), `Yes, true | `Fork ((x,_,_,_), Some prev) -> (fun () -> (* nested proof *) reach ~cache:`Shallow prev; reach view.next; - (try vernac_interp id x; + (try stm_vernac_interp id x; with e when CErrors.noncritical e -> let (e, info) = CErrors.push e in let info = Stateid.add info ~valid:prev id in @@ -2207,14 +2296,14 @@ let known_state ?(redefine_qed=false) ~cache id = Proof_global.close_future_proof ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; - vernac_interp id ~proof x; + stm_vernac_interp id ~proof x; feedback ~id:(State id) Incomplete | { VCS.kind = `Master }, _ -> assert false end; Proof_global.discard_all () ), (if redefine_qed then `No else `Yes), true | `Sync (name, _, `Immediate) -> (fun () -> - reach eop; vernac_interp id x; Proof_global.discard_all () + reach eop; stm_vernac_interp id x; Proof_global.discard_all () ), `Yes, true | `Sync (name, pua, reason) -> (fun () -> log_processing_sync id name reason; @@ -2235,7 +2324,7 @@ let known_state ?(redefine_qed=false) ~cache id = if keep != VtKeepAsAxiom then reach view.next; let wall_clock2 = Unix.gettimeofday () in - vernac_interp id ?proof x; + stm_vernac_interp id ?proof x; let wall_clock3 = Unix.gettimeofday () in Aux_file.record_in_aux_at x.loc "proof_check_time" (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2)); @@ -2251,7 +2340,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; update_global_env () + reach view.next; stm_vernac_interp id x; update_global_env () ), cache, true | `Sideff (`Id origin) -> (fun () -> reach view.next; @@ -2439,7 +2528,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty " classified as: " ^ string_of_vernac_classification c); match c with (* PG stuff *) - | VtStm(VtPG,false), VtNow -> vernac_interp Stateid.dummy x; `Ok + | VtStm(VtPG,false), VtNow -> stm_vernac_interp Stateid.dummy x; `Ok | VtStm(VtPG,_), _ -> anomaly(str "PG command in script or VtLater") (* Joining various parts of the document *) | VtStm (VtJoinDocument, b), VtNow -> join (); `Ok @@ -2483,13 +2572,13 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty (* Query *) | VtQuery (false,(report_id,route)), VtNow when tty = true -> finish (); - (try Future.purify (vernac_interp report_id ~route) + (try Future.purify (stm_vernac_interp report_id ~route) {x with verbose = true } with e when CErrors.noncritical e -> let e = CErrors.push e in iraise (State.exn_on ~valid:Stateid.dummy report_id e)); `Ok | VtQuery (false,(report_id,route)), VtNow -> - (try vernac_interp report_id ~route x + (try stm_vernac_interp report_id ~route x with e -> let e = CErrors.push e in iraise (State.exn_on ~valid:Stateid.dummy report_id e)); `Ok @@ -2562,7 +2651,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty (* Side effect on all branches *) | VtUnknown, _ when expr = VernacToplevelControl Drop -> - vernac_interp (VCS.get_branch_pos head) x; `Ok + stm_vernac_interp (VCS.get_branch_pos head) x; `Ok | VtSideff l, w -> let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in @@ -2588,7 +2677,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty VCS.checkout VCS.Branch.master; let mid = VCS.get_branch_pos VCS.Branch.master in Reach.known_state ~cache:(interactive ()) mid; - vernac_interp id x; + stm_vernac_interp id x; (* Vernac x may or may not start a proof *) if not in_proof && Proof_global.there_are_pending_proofs () then begin @@ -2618,7 +2707,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty begin match expr with | VernacStm (PGLast _) -> if not (VCS.Branch.equal head VCS.Branch.master) then - vernac_interp Stateid.dummy + stm_vernac_interp Stateid.dummy { verbose = true; loc = Loc.ghost; indentation = 0; strlen = 0; expr = VernacShow (ShowGoal OpenSubgoals) } | _ -> () @@ -2868,89 +2957,6 @@ let get_all_proof_names () = let get_current_proof_name () = Option.map unmangle (proofname (VCS.current_branch ())) -let get_script prf = - let branch, test = - match prf with - | None -> VCS.Branch.master, fun _ -> true - | Some name -> VCS.current_branch (),fun nl -> nl=[] || List.mem name nl in - let rec find acc id = - if Stateid.equal id Stateid.initial || - Stateid.equal id Stateid.dummy then acc else - let view = VCS.visit id in - match view.step with - | `Fork((_,_,_,ns), _) when test ns -> acc - | `Qed (qed, proof) -> find [qed.qast.expr, (VCS.get_info id).n_goals] proof - | `Sideff (`Ast (x,_)) -> - find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next - | `Sideff (`Id id) -> find acc id - | `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *) - find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next - | `Cmd _ -> find acc view.next - | `Alias (id,_) -> find acc id - | `Fork _ -> find acc view.next - in - find [] (VCS.get_branch_pos branch) - -(* indentation code for Show Script, initially contributed - by D. de Rauglaudre *) - -let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) = - (* ng1 : number of goals remaining at the current level (before cmd) - ngl1 : stack of previous levels with their remaining goals - ng : number of goals after the execution of cmd - beginend : special indentation stack for { } *) - let ngprev = List.fold_left (+) ng1 ngl1 in - let new_ngl = - if ng > ngprev then - (* We've branched *) - (ng - ngprev + 1, ng1 - 1 :: ngl1) - else if ng < ngprev then - (* A subgoal have been solved. Let's compute the new current level - by discarding all levels with 0 remaining goals. *) - let rec loop = function - | (0, ng2::ngl2) -> loop (ng2,ngl2) - | p -> p - in loop (ng1-1, ngl1) - else - (* Standard case, same goal number as before *) - (ng1, ngl1) - in - (* When a subgoal have been solved, separate this block by an empty line *) - let new_nl = (ng < ngprev) - in - (* Indentation depth *) - let ind = List.length ngl1 - in - (* Some special handling of bullets and { }, to get a nicer display *) - let pred n = max 0 (n-1) in - let ind, nl, new_beginend = match cmd with - | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend - | VernacEndSubproof -> List.hd beginend, false, List.tl beginend - | VernacBullet _ -> pred ind, nl, beginend - | _ -> ind, nl, beginend - in - let pp = - (if nl then fnl () else mt ()) ++ - (hov (ind+1) (str (String.make ind ' ') ++ Ppvernac.pr_vernac cmd)) - in - (new_ngl, new_nl, new_beginend, pp :: ppl) - -let show_script ?proof () = - try - let prf = - try match proof with - | None -> Some (Pfedit.get_current_proof_name ()) - | Some (p,_) -> Some (p.Proof_global.id) - with Proof_global.NoCurrentProof -> None - in - let cmds = get_script prf in - let _,_,_,indented_cmds = - List.fold_left indent_script_item ((1,[]),false,[],[]) cmds - in - let indented_cmds = List.rev (indented_cmds) in - msg_notice (v 0 (prlist_with_sep fnl (fun x -> x) indented_cmds)) - with Vcs_aux.Expired -> () - (* Export hooks *) let state_computed_hook = Hooks.state_computed_hook let state_ready_hook = Hooks.state_ready_hook diff --git a/stm/stm.mli b/stm/stm.mli index 36341a5d51..5d0d05d411 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -213,7 +213,6 @@ val interp : bool -> vernac_expr located -> unit val current_proof_depth : unit -> int val get_all_proof_names : unit -> Id.t list val get_current_proof_name : unit -> Id.t option -val show_script : ?proof:Proof_global.closed_proof -> unit -> unit (* Hooks to be set by other Coq components in order to break file cycles *) val process_error_hook : Future.fix_exn Hook.t diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 15f89e4b86..0bf81e7e58 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -515,13 +515,8 @@ let vernac_start_proof locality p kind l lettop = let qed_display_script = ref true let vernac_end_proof ?proof = function - | Admitted -> save_proof ?proof Admitted - | Proved (_,_) as e -> - (* - if is_verbose () && !qed_display_script && !Flags.coqtop_ui then - Stm.show_script ?proof (); - *) - save_proof ?proof e + | Admitted -> save_proof ?proof Admitted + | Proved (_,_) as e -> save_proof ?proof e (* A stupid macro that should be replaced by ``Exact c. Save.'' all along the theories [??] *) @@ -1870,6 +1865,7 @@ let vernac_bullet (bullet:Proof_global.Bullet.t) = Proof_global.Bullet.put p bullet) let vernac_show = let open Feedback in function + | ShowScript -> assert false (* Only the stm knows the script *) | ShowGoal goalref -> let info = match goalref with | OpenSubgoals -> pr_open_subgoals () @@ -1884,7 +1880,6 @@ let vernac_show = let open Feedback in function Constrextern.with_implicits msg_notice (pr_nth_open_subgoal n) | ShowProof -> show_proof () | ShowNode -> show_node () - | ShowScript -> (* Stm.show_script () *) () | ShowExistentials -> show_top_evars () | ShowUniverses -> show_universes () | ShowTree -> show_prooftree () -- cgit v1.2.3 From 3d2680a97a1ab9d85c4672217ec7957ce390bca1 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 23 Jan 2017 22:25:57 +0100 Subject: [cosmetic] Reorder makefile as suggested by @herbelin --- Makefile.common | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Makefile.common b/Makefile.common index 2c55d76cc8..2cf4d01695 100644 --- a/Makefile.common +++ b/Makefile.common @@ -53,9 +53,9 @@ INSTALLSH:=./install.sh MKDIR:=install -d CORESRCDIRS:=\ - config lib kernel kernel/byterun library \ - proofs tactics pretyping interp stm \ - toplevel parsing printing intf engine ltac vernac + config lib kernel intf kernel/byterun library \ + engine pretyping interp proofs parsing printing \ + tactics vernac stm toplevel ltac PLUGINDIRS:=\ omega romega micromega quote \ -- cgit v1.2.3 From 4db82417bdda1f9b0c7ea6ba9f6d71c03cc07eba Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 23 Jan 2017 22:48:38 +0100 Subject: [stm] Remove unused legacy stm interface. --- stm/stm.ml | 3 --- stm/stm.mli | 1 - 2 files changed, 4 deletions(-) diff --git a/stm/stm.ml b/stm/stm.ml index 1cd6209aa4..fd1cefa8d1 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2954,9 +2954,6 @@ let proofname b = match VCS.get_branch b with let get_all_proof_names () = List.map unmangle (List.map_filter proofname (VCS.branches ())) -let get_current_proof_name () = - Option.map unmangle (proofname (VCS.current_branch ())) - (* Export hooks *) let state_computed_hook = Hooks.state_computed_hook let state_ready_hook = Hooks.state_ready_hook diff --git a/stm/stm.mli b/stm/stm.mli index 5d0d05d411..0f0a3c4e13 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -212,7 +212,6 @@ val interp : bool -> vernac_expr located -> unit (* Queries for backward compatibility *) val current_proof_depth : unit -> int val get_all_proof_names : unit -> Id.t list -val get_current_proof_name : unit -> Id.t option (* Hooks to be set by other Coq components in order to break file cycles *) val process_error_hook : Future.fix_exn Hook.t -- cgit v1.2.3 From 888d4be3ea2a45cff416fd8896276cfa8fc00518 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 10 Feb 2017 11:07:10 +0100 Subject: Make Obligations see fix_exn --- stm/stm.ml | 1 + vernac/obligations.ml | 12 ++++-------- vernac/obligations.mli | 6 ++++++ 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/stm/stm.ml b/stm/stm.ml index fd1cefa8d1..e698d1c72e 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2961,5 +2961,6 @@ let parse_error_hook = Hooks.parse_error_hook let forward_feedback_hook = Hooks.forward_feedback_hook let process_error_hook = Hooks.process_error_hook let unreachable_state_hook = Hooks.unreachable_state_hook +let () = Hook.set Obligations.stm_get_fix_exn (fun () -> !State.fix_exn_ref) let tactic_being_run_hook = Hooks.tactic_being_run_hook (* vim:set foldmethod=marker: *) diff --git a/vernac/obligations.ml b/vernac/obligations.ml index c1d9ae48a5..6f3921903b 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -20,17 +20,13 @@ open Pp open CErrors open Util -(* EJGA: This should go away, no more need for fix_exn *) -module Stm = struct - let u = (fun x -> x) - let get_fix_exn () = u -end - module NamedDecl = Context.Named.Declaration let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> assert false) let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false) +let get_fix_exn, stm_get_fix_exn = Hook.make () + let succfix (depth, fixrels) = (succ depth, List.map succ fixrels) @@ -491,7 +487,7 @@ 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 fix_exn = Hook.get get_fix_exn () in let pl, ctx = Evd.universe_context ?names:prg.prg_pl (Evd.from_ctx prg.prg_ctx) in let ce = @@ -572,7 +568,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 fix_exn = Hook.get get_fix_exn () in let kns = List.map4 (!declare_fix_ref ~opaque (local, poly, kind) ctx) fixnames fixdecls fixtypes fiximps in (* Declare notations *) diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 80b6891447..11366fe91b 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -24,6 +24,12 @@ val declare_definition_ref : Safe_typing.private_constants Entries.definition_entry -> Impargs.manual_implicits -> global_reference Lemmas.declaration_hook -> global_reference) ref +(* This is a hack to make it possible for Obligations to craft a Qed + * behind the scenes. The fix_exn the Stm attaches to the Future proof + * is not available here, so we provide a side channel to get it *) +val stm_get_fix_exn : (unit -> Exninfo.iexn -> Exninfo.iexn) Hook.t + + val check_evars : env -> evar_map -> unit val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t -- cgit v1.2.3 From 30a2def37ecdeeed24325089a0b0ca264100389c Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 7 Feb 2017 19:37:15 +0100 Subject: [travis] [External CI] Factor out math-comp installs. We make math-comp overlays easier, we also start structuring the scripts a bit more. --- dev/ci/ci-common.sh | 43 +++++++++++++++++++++++++++++++++++++++++++ dev/ci/ci-compcert.sh | 2 +- dev/ci/ci-coquelicot.sh | 21 ++------------------- dev/ci/ci-fiat-crypto.sh | 5 +---- dev/ci/ci-flocq.sh | 2 +- dev/ci/ci-geocoq.sh | 2 +- dev/ci/ci-hott.sh | 2 +- dev/ci/ci-iris-coq.sh | 24 +++--------------------- dev/ci/ci-math-classes.sh | 4 ++-- dev/ci/ci-math-comp.sh | 10 +++++----- dev/ci/ci-metacoq.sh | 4 ++-- dev/ci/ci-tlc.sh | 2 +- 12 files changed, 63 insertions(+), 58 deletions(-) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 2a6601e045..087572e47d 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -4,3 +4,46 @@ set -xe export PATH=`pwd`/bin:$PATH ls `pwd`/bin + +# Maybe we should just use Ruby... +mathcomp_CI_BRANCH=master +mathcomp_CI_GITURL=https://github.com/math-comp/math-comp.git + +# git_checkout branch +git_checkout() +{ + local _BRANCH=${1} + local _URL=${2} + local _DEST=${3} + + echo "Checking out ${_DEST}" + git clone --depth 1 -b ${_BRANCH} ${_URL} ${_DEST} + ( cd ${3} && echo "${_DEST}: `git log -1 --format='%s | %H | %cd | %aN'`" ) +} + +checkout_mathcomp() +{ + git_checkout ${mathcomp_CI_BRANCH} ${mathcomp_CI_GITURL} ${1} +} + +# this installs just the ssreflect library of math-comp +install_ssreflect() +{ + echo 'Installing ssreflect' && echo -en 'travis_fold:start:ssr.install\\r' + + checkout_mathcomp math-comp + ( cd math-comp/mathcomp && \ + sed -i.bak '/ssrtest/d' Make && \ + sed -i.bak '/odd_order/d' Make && \ + sed -i.bak '/all\/all.v/d' Make && \ + sed -i.bak '/character/d' Make && \ + sed -i.bak '/real_closed/d' Make && \ + sed -i.bak '/solvable/d' Make && \ + sed -i.bak '/field/d' Make && \ + sed -i.bak '/fingroup/d' Make && \ + sed -i.bak '/algebra/d' Make && \ + make Makefile.coq && make -f Makefile.coq -j ${NJOBS} all && make install ) + + echo -en 'travis_fold:end:ssr.install\\r' + +} diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index d4023c9165..d4d503278a 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -4,7 +4,7 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh opam install -j ${NJOBS} -y menhir -git clone --depth 3 -b coq-8.6 https://github.com/maximedenes/CompCert.git +git_checkout coq-8.6 https://github.com/maximedenes/CompCert.git CompCert # Patch to avoid the upper version limit ( cd CompCert && sed -i.bak 's/8.6)/8.6|trunk)/' configure && ./configure x86_32-linux && make -j ${NJOBS} ) diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh index 4a23e51be6..94bd5e468f 100755 --- a/dev/ci/ci-coquelicot.sh +++ b/dev/ci/ci-coquelicot.sh @@ -4,26 +4,9 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git clone --depth 3 https://github.com/math-comp/math-comp.git - -# coquelicot just needs mathcomp -( cd math-comp/mathcomp && \ - sed -i.bak '/ssrtest/d' Make && \ - sed -i.bak '/odd_order/d' Make && \ - sed -i.bak '/all\/all.v/d' Make && \ - sed -i.bak '/character/d' Make && \ - sed -i.bak '/real_closed/d' Make && \ - sed -i.bak '/solvable/d' Make && \ - sed -i.bak '/field/d' Make && \ - sed -i.bak '/fingroup/d' Make && \ - sed -i.bak '/algebra/d' Make && \ - make -j ${NJOBS} && make install ) - -# Setup ssr -# echo "Add ML Path \"`pwd`/math-comp/mathcomp/\"." > ${HOME}/.coqrc -# echo "Add LoadPath \"`pwd`/math-comp/mathcomp/\" as mathcomp." >> ${HOME}/.coqrc +install_ssreflect # Setup coquelicot -git clone --depth 3 https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git +git_checkout master https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git coquelicot ( cd coquelicot && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh index c594f83603..c669195ddd 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat-crypto.sh @@ -4,9 +4,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git clone --depth 3 https://github.com/mit-plv/fiat-crypto.git +git_checkout master https://github.com/mit-plv/fiat-crypto.git fiat-crypto ( cd fiat-crypto && make -j ${NJOBS} ) - -# ( cd corn && make -j ${NJOBS} ) - diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh index b9cf649a1a..345924e40a 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -4,6 +4,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git clone --depth 3 https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git +git_checkout master https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git flocq ( cd flocq && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index 589a826e02..ce870e52b5 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -7,7 +7,7 @@ source ${ci_dir}/ci-common.sh GeoCoq_CI_BRANCH=master GeoCoq_CI_GITURL=https://github.com/GeoCoq/GeoCoq.git -git clone --depth 1 -b ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} +git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} GeoCoq ( cd GeoCoq && \ ./configure.sh && \ diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 8f82ba9f21..aaffc9d484 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git clone --depth 3 -b mz-8.6 https://github.com/ejgallego/HoTT.git +git_checkout mz-8.6 https://github.com/ejgallego/HoTT.git HoTT ( cd HoTT && ./autogen.sh && ./configure && make -j ${NJOBS} ) diff --git a/dev/ci/ci-iris-coq.sh b/dev/ci/ci-iris-coq.sh index e97e2c19e3..c21af976f4 100755 --- a/dev/ci/ci-iris-coq.sh +++ b/dev/ci/ci-iris-coq.sh @@ -4,32 +4,14 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -# XXX: Refactor into install-ssreflect -git clone --depth 1 https://github.com/math-comp/math-comp.git - -# coquelicot just needs mathcomp -( cd math-comp/mathcomp && \ - sed -i.bak '/ssrtest/d' Make && \ - sed -i.bak '/odd_order/d' Make && \ - sed -i.bak '/all\/all.v/d' Make && \ - sed -i.bak '/character/d' Make && \ - sed -i.bak '/real_closed/d' Make && \ - sed -i.bak '/solvable/d' Make && \ - sed -i.bak '/field/d' Make && \ - sed -i.bak '/fingroup/d' Make && \ - sed -i.bak '/algebra/d' Make && \ - make -j ${NJOBS} && make install ) - -# Setup ssr = This doesn't work as coq_makefile will pass -q to coqc :S :S -# echo "Add ML Path \"`pwd`/math-comp/mathcomp/\"." > ${HOME}/.coqrc -# echo "Add LoadPath \"`pwd`/math-comp/mathcomp/\" as mathcomp." >> ${HOME}/.coqrc +install_ssreflect # Setup stdpp -git clone --depth 1 https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git +git_checkout master https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git coq-stdpp ( cd coq-stdpp && make -j ${NJOBS} && make install ) # Setup Iris -git clone --depth 1 https://gitlab.mpi-sws.org/FP/iris-coq.git +git_checkout master https://gitlab.mpi-sws.org/FP/iris-coq.git iris-coq ( cd iris-coq && make -j ${NJOBS} ) diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math-classes.sh index 9127c18951..4450dc0710 100755 --- a/dev/ci/ci-math-classes.sh +++ b/dev/ci/ci-math-classes.sh @@ -4,9 +4,9 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git clone --depth 1 -b v8.6 https://github.com/math-classes/math-classes.git +git_checkout v8.6 https://github.com/math-classes/math-classes.git math-classes ( cd math-classes && make -j ${NJOBS} && make install ) -git clone --depth 1 -b v8.6 https://github.com/c-corn/corn.git +git_checkout v8.6 https://github.com/c-corn/corn.git corn ( cd corn && make -j ${NJOBS} ) diff --git a/dev/ci/ci-math-comp.sh b/dev/ci/ci-math-comp.sh index b833792419..2eb150cb52 100755 --- a/dev/ci/ci-math-comp.sh +++ b/dev/ci/ci-math-comp.sh @@ -4,10 +4,10 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git clone --depth 3 https://github.com/math-comp/math-comp.git +checkout_mathcomp math-comp # odd_order takes too much time for travis. -( cd math-comp/mathcomp && \ - sed -i.bak '/PFsection/d' Make && \ - sed -i.bak '/stripped_odd_order_theorem/d' Make && \ - make Makefile.coq && make -f Makefile.coq -j ${NJOBS} all ) +( cd math-comp/mathcomp && \ + sed -i.bak '/PFsection/d' Make && \ + sed -i.bak '/stripped_odd_order_theorem/d' Make && \ + make Makefile.coq && make -f Makefile.coq -j ${NJOBS} all ) diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh index 9a9bd3648b..91a33695b0 100755 --- a/dev/ci/ci-metacoq.sh +++ b/dev/ci/ci-metacoq.sh @@ -6,11 +6,11 @@ source ${ci_dir}/ci-common.sh # MetaCoq + UniCoq -git clone --depth 1 https://github.com/unicoq/unicoq.git +git_checkout master https://github.com/unicoq/unicoq.git unicoq ( cd unicoq && coq_makefile -f Make -o Makefile && make -j ${NJOBS} && make install ) -git clone --depth 1 https://github.com/MetaCoq/MetaCoq.git +git_checkout master https://github.com/MetaCoq/MetaCoq.git MetaCoq ( cd MetaCoq && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} ) diff --git a/dev/ci/ci-tlc.sh b/dev/ci/ci-tlc.sh index 2161a11461..b946324924 100755 --- a/dev/ci/ci-tlc.sh +++ b/dev/ci/ci-tlc.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git clone https://gforge.inria.fr/git/tlc/tlc.git +git_checkout master https://gforge.inria.fr/git/tlc/tlc.git tlc ( cd tlc && make -j ${NJOBS} ) -- cgit v1.2.3 From 575bbed527977aee520a3954a196f5b59ae947c5 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Sat, 11 Feb 2017 02:06:01 +0100 Subject: [travis] [External CI] CompCert official 8.6 support + UniMath --- .travis.yml | 1 + Makefile.ci | 7 ++++--- dev/ci/ci-common.sh | 3 +++ dev/ci/ci-compcert.sh | 5 ++++- dev/ci/ci-unimath.sh | 15 +++++++++++++++ 5 files changed, 27 insertions(+), 4 deletions(-) create mode 100755 dev/ci/ci-unimath.sh diff --git a/.travis.yml b/.travis.yml index 188e446007..de16f2d0b4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -36,6 +36,7 @@ env: - TEST_TARGET="ci-math-classes" - TEST_TARGET="ci-math-comp" - TEST_TARGET="ci-sf" + - TEST_TARGET="ci-unimath" # Not ready yet for 8.7 # - TEST_TARGET="ci-metacoq" # - TEST_TARGET="ci-tlc" diff --git a/Makefile.ci b/Makefile.ci index 040144e6e8..e4b5832f60 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -1,6 +1,7 @@ -CI_TARGETS=ci-all ci-hott ci-math-comp ci-compcert ci-sf ci-cpdt \ - ci-color ci-math-classes ci-tlc ci-fiat-crypto \ - ci-coquelicot ci-flocq ci-iris-coq ci-metacoq ci-geocoq +CI_TARGETS=ci-all ci-hott ci-math-comp ci-compcert ci-sf ci-cpdt \ + ci-color ci-math-classes ci-tlc ci-fiat-crypto \ + ci-coquelicot ci-flocq ci-iris-coq ci-metacoq ci-geocoq \ + ci-unimath .PHONY: $(CI_TARGETS) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 087572e47d..412da626fd 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -2,7 +2,10 @@ set -xe +# Coq's tools need an ending slash :S, we should fix them. +export COQBIN=`pwd`/bin/ export PATH=`pwd`/bin:$PATH + ls `pwd`/bin # Maybe we should just use Ruby... diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index d4d503278a..ec09389f8e 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -3,8 +3,11 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh +CompCert_CI_BRANCH=master +CompCert_CI_GITURL=https://github.com/AbsInt/CompCert.git + opam install -j ${NJOBS} -y menhir -git_checkout coq-8.6 https://github.com/maximedenes/CompCert.git CompCert +git_checkout ${CompCert_CI_BRANCH} ${CompCert_CI_GITURL} CompCert # Patch to avoid the upper version limit ( cd CompCert && sed -i.bak 's/8.6)/8.6|trunk)/' configure && ./configure x86_32-linux && make -j ${NJOBS} ) diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh new file mode 100755 index 0000000000..15e619acbb --- /dev/null +++ b/dev/ci/ci-unimath.sh @@ -0,0 +1,15 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +UniMath_CI_BRANCH=master +UniMath_CI_GITURL=https://github.com/UniMath/UniMath.git + +git_checkout ${UniMath_CI_BRANCH} ${UniMath_CI_GITURL} UniMath + +( cd UniMath && \ + sed -i.bak '/Folds/d' Makefile && \ + sed -i.bak '/HomologicalAlgebra/d' Makefile && \ + make -j ${NJOBS} BUILD_COQ=no ) + -- cgit v1.2.3 From 55cb913f029308e97bd262fc18d4338f404e7561 Mon Sep 17 00:00:00 2001 From: Ralf Jung Date: Tue, 14 Feb 2017 12:35:39 +0100 Subject: don't require printing-only notation to be productive --- parsing/g_prim.ml4 | 5 ++++- parsing/g_vernac.ml4 | 2 +- parsing/pcoq.ml | 1 + parsing/pcoq.mli | 1 + test-suite/success/Notations.v | 4 ++++ toplevel/metasyntax.ml | 13 +++++++------ 6 files changed, 18 insertions(+), 8 deletions(-) diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index b90e06cd3e..a38043d0c0 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -34,7 +34,7 @@ GEXTEND Gram GLOBAL: bigint natural integer identref name ident var preident fullyqualid qualid reference dirpath ne_lstring - ne_string string pattern_ident pattern_identref by_notation smart_global; + ne_string string lstring pattern_ident pattern_identref by_notation smart_global; preident: [ [ s = IDENT -> s ] ] ; @@ -106,6 +106,9 @@ GEXTEND Gram string: [ [ s = STRING -> s ] ] ; + lstring: + [ [ s = string -> (!@loc, s) ] ] + ; integer: [ [ i = INT -> my_int_of_string (!@loc) i | "-"; i = INT -> - my_int_of_string (!@loc) i ] ] diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index e61be53a99..0c4dbcc8d5 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1122,7 +1122,7 @@ GEXTEND Gram idl = LIST0 ident; ":="; c = constr; b = only_parsing -> VernacSyntacticDefinition (id,(idl,c),local,b) - | IDENT "Notation"; local = obsolete_locality; s = ne_lstring; ":="; + | IDENT "Notation"; local = obsolete_locality; s = lstring; ":="; c = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 7dc02190ea..007a6c767f 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -267,6 +267,7 @@ module Prim = let integer = gec_gen "integer" let bigint = Gram.entry_create "Prim.bigint" let string = gec_gen "string" + let lstring = Gram.entry_create "Prim.lstring" let reference = make_gen_entry uprim "reference" let by_notation = Gram.entry_create "by_notation" let smart_global = Gram.entry_create "smart_global" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 37165f6ceb..fc1727fc1c 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -137,6 +137,7 @@ module Prim : val bigint : Bigint.bigint Gram.entry val integer : int Gram.entry val string : string Gram.entry + val lstring : string located Gram.entry val qualid : qualid located Gram.entry val fullyqualid : Id.t list located Gram.entry val reference : reference Gram.entry diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index 07bbb60c40..32baeaa570 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -128,3 +128,7 @@ Notation " |- {{ a }} b" := (a=b) (no associativity, at level 10). Goal True. {{ exact I. }} Qed. + +(* Check that we can have notations without any symbol iff they are "only printing". *) +Fail Notation "" := (@nil). +Notation "" := (@nil) (only printing). diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 008d5cf9f5..ccb9c99d78 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -903,8 +903,8 @@ let find_precedence lev etyps symbols = let first_symbol = let rec aux = function | Break _ :: t -> aux t - | h :: t -> h - | [] -> assert false (* rule is known to be productive *) in + | h :: t -> Some h + | [] -> None in aux symbols in let last_is_terminal () = let rec aux b = function @@ -914,7 +914,8 @@ let find_precedence lev etyps symbols = | [] -> b in aux false symbols in match first_symbol with - | NonTerminal x -> + | None -> [],0 + | Some (NonTerminal x) -> (try match List.assoc x etyps with | ETConstr _ -> error "The level of the leftmost non-terminal cannot be changed." @@ -937,11 +938,11 @@ let find_precedence lev etyps symbols = if Option.is_empty lev then error "A left-recursive notation must have an explicit level." else [],Option.get lev) - | Terminal _ when last_is_terminal () -> + | Some (Terminal _) when last_is_terminal () -> if Option.is_empty lev then ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."], 0) else [],Option.get lev - | _ -> + | Some _ -> if Option.is_empty lev then error "Cannot determine the level."; [],Option.get lev @@ -991,7 +992,7 @@ let compute_syntax_data df modifiers = let symbols' = remove_curly_brackets symbols in let need_squash = not (List.equal Notation.symbol_eq symbols symbols') in let ntn_for_grammar = make_notation_key symbols' in - check_rule_productivity symbols'; + if not onlyprint then check_rule_productivity symbols'; let msgs,n = find_precedence n etyps symbols' in let innerlevel = NumLevel 200 in let typs = -- cgit v1.2.3 From 8ce49dd1b436a17c4ee29c2893133829daac75f0 Mon Sep 17 00:00:00 2001 From: Ralf Jung Date: Tue, 14 Feb 2017 12:36:15 +0100 Subject: reject notations that are both 'only printing' and 'only parsing' --- test-suite/success/Notations.v | 3 +++ toplevel/metasyntax.ml | 1 + 2 files changed, 4 insertions(+) diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index 32baeaa570..52acad7460 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -132,3 +132,6 @@ Qed. (* Check that we can have notations without any symbol iff they are "only printing". *) Fail Notation "" := (@nil). Notation "" := (@nil) (only printing). + +(* Check that a notation cannot be neither parsing nor printing. *) +Fail Notation "'foobarkeyword'" := (@nil) (only parsing, only printing). diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index ccb9c99d78..e90d638d03 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -984,6 +984,7 @@ let remove_curly_brackets l = let compute_syntax_data df modifiers = let (assoc,n,etyps,onlyparse,onlyprint,compat,fmt,extra) = interp_modifiers modifiers in + if onlyprint && onlyparse then error "A notation cannot be both 'only printing' and 'only parsing'."; let assoc = match assoc with None -> (* default *) Some NonA | a -> a in let toks = split_notation_string df in let (recvars,mainvars,symbols) = analyze_notation_tokens toks in -- cgit v1.2.3 From e6127d1f65a761a27c80b81c0f1bc5fca2b74af8 Mon Sep 17 00:00:00 2001 From: Tej Chajed Date: Thu, 16 Feb 2017 10:24:15 -0500 Subject: [cleanup] Change Id.t option to Name.t in TacFun --- dev/doc/changes.txt | 3 +++ grammar/q_util.mli | 2 ++ grammar/q_util.mlp | 4 ++++ grammar/tacextend.mlp | 2 +- ltac/g_auto.ml4 | 1 + ltac/g_class.ml4 | 1 + ltac/g_eqdecide.ml4 | 1 + ltac/g_ltac.ml4 | 9 +++++---- ltac/pptactic.ml | 4 +--- ltac/tacentries.ml | 5 +---- ltac/tacexpr.mli | 2 +- ltac/tacintern.ml | 6 ++---- ltac/tacinterp.ml | 10 +++++----- ltac/tacinterp.mli | 2 +- ltac/tauto.ml | 2 +- plugins/nsatz/g_nsatz.ml4 | 2 ++ plugins/setoid_ring/newring.ml | 12 ++++++------ plugins/ssrmatching/ssrmatching.ml4 | 2 +- 18 files changed, 39 insertions(+), 31 deletions(-) diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index f54f3fcc8e..2a083b360f 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -40,6 +40,9 @@ important things: - Some printing functions were moved from Pptactic to Pputils - A part of Tacexpr has been moved to Tactypes +The TacFun tactic expression constructor now takes a `Name.t list` for the +variable list rather than an `Id.t option list`. + ** Error handling ** - All error functions now take an optional parameter `?loc:Loc.t`. For diff --git a/grammar/q_util.mli b/grammar/q_util.mli index a5e36e47bc..37ec1d56a4 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -41,6 +41,8 @@ val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr +val mlexpr_of_name : ('a -> MLast.expr) -> 'a option -> MLast.expr + val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> user_symbol -> MLast.expr val type_of_user_symbol : user_symbol -> argument_type diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp index 919ca3ad7b..0dd096ef72 100644 --- a/grammar/q_util.mlp +++ b/grammar/q_util.mlp @@ -58,6 +58,10 @@ let mlexpr_of_option f = function | None -> <:expr< None >> | Some e -> <:expr< Some $f e$ >> +let mlexpr_of_name f = function + | None -> <:expr< Anonymous >> + | Some e -> <:expr< Name $f e$ >> + let symbol_of_string s = <:expr< Extend.Atoken (CLexer.terminal $str:s$) >> let rec mlexpr_of_prod_entry_key f = function diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index fe864ed405..8605dda3a0 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -88,7 +88,7 @@ let declare_tactic loc s c cl = match cl with add any grammar nor printing rule and add it as a true Ltac definition. *) let patt = make_patt rem in let vars = List.map make_var rem in - let vars = mlexpr_of_list (mlexpr_of_option mlexpr_of_ident) vars in + let vars = mlexpr_of_list (mlexpr_of_name mlexpr_of_ident) vars in let entry = mlexpr_of_string s in 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 diff --git a/ltac/g_auto.ml4 b/ltac/g_auto.ml4 index a37cf306e1..f32548cd36 100644 --- a/ltac/g_auto.ml4 +++ b/ltac/g_auto.ml4 @@ -16,6 +16,7 @@ open Pcoq.Constr open Pltac open Hints open Tacexpr +open Names DECLARE PLUGIN "g_auto" diff --git a/ltac/g_class.ml4 b/ltac/g_class.ml4 index a28132a4b0..ca9537c824 100644 --- a/ltac/g_class.ml4 +++ b/ltac/g_class.ml4 @@ -13,6 +13,7 @@ open Class_tactics open Pltac open Stdarg open Tacarg +open Names DECLARE PLUGIN "g_class" diff --git a/ltac/g_eqdecide.ml4 b/ltac/g_eqdecide.ml4 index 905653281c..679aa11272 100644 --- a/ltac/g_eqdecide.ml4 +++ b/ltac/g_eqdecide.ml4 @@ -15,6 +15,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) open Eqdecide +open Names DECLARE PLUGIN "g_eqdecide" diff --git a/ltac/g_ltac.ml4 b/ltac/g_ltac.ml4 index 54229bb2ae..aab5687465 100644 --- a/ltac/g_ltac.ml4 +++ b/ltac/g_ltac.ml4 @@ -17,6 +17,7 @@ open Misctypes open Genarg open Genredexpr open Tok (* necessary for camlp4 *) +open Names open Pcoq open Pcoq.Constr @@ -226,8 +227,8 @@ GEXTEND Gram | "multimatch" -> General ] ] ; input_fun: - [ [ "_" -> None - | l = ident -> Some l ] ] + [ [ "_" -> Anonymous + | l = ident -> Name l ] ] ; let_clause: [ [ id = identref; ":="; te = tactic_expr -> @@ -499,8 +500,8 @@ let pr_tacdef_body tacdef_body = | Tacexpr.TacFun (idl,b) -> idl,b | _ -> [], body in id ++ - prlist (function None -> str " _" - | Some id -> spc () ++ Nameops.pr_id id) idl + prlist (function Anonymous -> str " _" + | Name id -> spc () ++ Nameops.pr_id id) idl ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++ Pptactic.pr_raw_tactic body diff --git a/ltac/pptactic.ml b/ltac/pptactic.ml index fccee6e40a..6f4ef37b44 100644 --- a/ltac/pptactic.ml +++ b/ltac/pptactic.ml @@ -574,9 +574,7 @@ module Make str "=>" ++ brk (1,4) ++ pr t)) | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t - let pr_funvar = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id + let pr_funvar n = spc () ++ pr_name n let pr_let_clause k pr (id,(bl,t)) = hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++ diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml index 2e2b55be74..75edf150e3 100644 --- a/ltac/tacentries.ml +++ b/ltac/tacentries.ml @@ -504,10 +504,7 @@ let print_ltacs () = | Tacexpr.TacFun (l, t) -> (l, t) | _ -> ([], body) in - let pr_ltac_fun_arg = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id - in + let pr_ltac_fun_arg n = spc () ++ pr_name n in hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) in Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) diff --git a/ltac/tacexpr.mli b/ltac/tacexpr.mli index 9c25a16457..e23992a807 100644 --- a/ltac/tacexpr.mli +++ b/ltac/tacexpr.mli @@ -282,7 +282,7 @@ constraint 'a = < > and 'a gen_tactic_fun_ast = - Id.t option list * 'a gen_tactic_expr + Name.t list * 'a gen_tactic_expr constraint 'a = < term:'t; diff --git a/ltac/tacintern.ml b/ltac/tacintern.ml index 763e0dc22e..3292c8353a 100644 --- a/ltac/tacintern.ml +++ b/ltac/tacintern.ml @@ -646,7 +646,7 @@ 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 + let lfun = List.fold_left name_cons ist.ltacvars var in (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body) and intern_tacarg strict onlytac ist = function @@ -722,9 +722,7 @@ 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 pr_ltac_fun_arg n = spc () ++ pr_name n let print_ltac id = try diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml index 32bcdfb6a4..adc393d2ce 100644 --- a/ltac/tacinterp.ml +++ b/ltac/tacinterp.ml @@ -120,7 +120,7 @@ let combine_appl appl1 appl2 = (* Values for interpretation *) type tacvalue = | VFun of appl*ltac_trace * value Id.Map.t * - Id.t option list * glob_tactic_expr + Name.t list * glob_tactic_expr | VRec of value Id.Map.t ref * glob_tactic_expr let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = @@ -1087,8 +1087,8 @@ let head_with_value (lvar,lval) = | ([],[]) -> (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)) + | Anonymous -> head_with_value_rec lacc (tvr,tve) + | Name v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) | (vr,[]) -> (lacc,vr,[]) | ([],ve) -> (lacc,[],ve) in @@ -2119,8 +2119,8 @@ let lift_constr_tac_to_ml_tac vars tac = let env = Proofview.Goal.env gl in let sigma = project gl in let map = function - | None -> None - | Some id -> + | Anonymous -> None + | Name id -> let c = Id.Map.find id ist.lfun in try Some (coerce_to_closed_constr env c) with CannotCoerceTo ty -> diff --git a/ltac/tacinterp.mli b/ltac/tacinterp.mli index 6f64981eff..adbd1d32be 100644 --- a/ltac/tacinterp.mli +++ b/ltac/tacinterp.mli @@ -115,7 +115,7 @@ val error_ltac_variable : Loc.t -> Id.t -> (** 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 -> +val lift_constr_tac_to_ml_tac : Name.t list -> (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic val default_ist : unit -> Geninterp.interp_sign diff --git a/ltac/tauto.ml b/ltac/tauto.ml index 756958c2f0..fb05fd7d0e 100644 --- a/ltac/tauto.ml +++ b/ltac/tauto.ml @@ -259,7 +259,7 @@ let with_flags flags _ ist = 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 ids = List.map (fun id -> Name 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 diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4 index 5f906a8dad..fda7c0fa83 100644 --- a/plugins/nsatz/g_nsatz.ml4 +++ b/plugins/nsatz/g_nsatz.ml4 @@ -10,6 +10,8 @@ DECLARE PLUGIN "nsatz_plugin" (*i camlp4deps: "grammar/grammar.cma" i*) +open Names + DECLARE PLUGIN "nsatz_plugin" TACTIC EXTEND nsatz_compute diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 657efe175b..d1f3bd6d35 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -122,7 +122,7 @@ let closed_term_ast l = mltac_index = 0; } in let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in - TacFun([Some(Id.of_string"t")], + TacFun([Name(Id.of_string"t")], TacML(Loc.ghost,tacname, [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None)); TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)])) @@ -205,7 +205,7 @@ let exec_tactic env evd n f args = 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, [TacGeneric n]) in - let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in + let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in (** Evaluate the whole result *) let gl = dummy_goal env evd in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in @@ -722,8 +722,8 @@ let ltac_ring_structure e = 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 = tacarg (TacFun([None],e.ring_pre_tac)) in - let posttac = tacarg (TacFun([None],e.ring_post_tac)) in + let pretac = tacarg (TacFun([Anonymous],e.ring_pre_tac)) in + let posttac = tacarg (TacFun([Anonymous],e.ring_post_tac)) in [req;sth;ext;morph;th;cst_tac;pow_tac; lemma1;lemma2;pretac;posttac] @@ -994,8 +994,8 @@ let ltac_field_structure e = 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 = tacarg (TacFun([None],e.field_pre_tac)) in - let posttac = tacarg (TacFun([None],e.field_post_tac)) in + let pretac = tacarg (TacFun([Anonymous],e.field_pre_tac)) in + let posttac = tacarg (TacFun([Anonymous],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] diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index fc988a2c5f..ea14bc00a9 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -1411,7 +1411,7 @@ let () = let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in let () = Tacenv.register_ml_tactic name [|mltac|] in let tac = - TacFun ([Some (Id.of_string "pattern")], + TacFun ([Name (Id.of_string "pattern")], TacML (Loc.ghost, { mltac_name = name; mltac_index = 0 }, [])) in let obj () = Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in -- cgit v1.2.3 From 7707396c5010d88c3d0be6ecee816d8da7ed0ee0 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 16 Feb 2017 21:55:14 +0100 Subject: Fixing #5339 (anomaly with 'pat in record parameters). --- toplevel/record.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/toplevel/record.ml b/toplevel/record.ml index b8dcf81fde..8d35e5a3da 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -108,7 +108,8 @@ let typecheck_params_and_fields def id pl t ps nots fs = List.iter (function LocalRawDef (b, _) -> error default_binder_kind b | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls - | LocalPattern _ -> assert false) ps + | LocalPattern (loc,_,_) -> + Loc.raise loc (Stream.Error "pattern with quote not allowed in record parameters.")) ps in let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in let t', template = match t with -- cgit v1.2.3 From 653de32139ecee3114779a5ee2961c58793889e5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 6 Oct 2016 16:59:27 +0200 Subject: Ltac as a plugin. This commit is essentially moving files around. In particular, the corresponding plugin still relies on a mllib file rather than a mlpack one. Otherwise, this causes link-time issues for third-party plugins depending on modules defined in the Ltac plugin. --- Makefile.common | 10 +- Makefile.dev | 7 +- dev/ocamldebug-coq.run | 2 +- ltac/coretactics.ml4 | 329 ----- ltac/evar_tactics.ml | 93 -- ltac/evar_tactics.mli | 19 - ltac/extraargs.ml4 | 389 ------ ltac/extraargs.mli | 78 -- ltac/extratactics.ml4 | 1097 ---------------- ltac/extratactics.mli | 14 - ltac/g_auto.ml4 | 228 ---- ltac/g_class.ml4 | 120 -- ltac/g_eqdecide.ml4 | 27 - ltac/g_ltac.ml4 | 526 -------- ltac/g_obligations.ml4 | 161 --- ltac/g_rewrite.ml4 | 274 ---- ltac/g_tactic.ml4 | 665 ---------- ltac/ltac.mllib | 27 - ltac/pltac.ml | 65 - ltac/pltac.mli | 38 - ltac/pptactic.ml | 1361 -------------------- ltac/pptactic.mli | 67 - ltac/pptacticsig.mli | 81 -- ltac/profile_ltac.ml | 420 ------- ltac/profile_ltac.mli | 48 - ltac/profile_ltac_tactics.ml4 | 40 - ltac/rewrite.ml | 2223 --------------------------------- ltac/rewrite.mli | 117 -- ltac/tacarg.ml | 26 - ltac/tacarg.mli | 27 - ltac/taccoerce.ml | 343 ----- ltac/taccoerce.mli | 96 -- ltac/tacentries.ml | 525 -------- ltac/tacentries.mli | 64 - ltac/tacenv.ml | 143 --- ltac/tacenv.mli | 75 -- ltac/tacexpr.mli | 396 ------ ltac/tacintern.ml | 812 ------------ ltac/tacintern.mli | 64 - ltac/tacinterp.ml | 2157 -------------------------------- ltac/tacinterp.mli | 122 -- ltac/tacsubst.ml | 308 ----- ltac/tacsubst.mli | 30 - ltac/tactic_debug.ml | 422 ------- ltac/tactic_debug.mli | 80 -- ltac/tactic_matching.ml | 377 ------ ltac/tactic_matching.mli | 49 - ltac/tactic_option.ml | 51 - ltac/tactic_option.mli | 15 - ltac/tauto.ml | 279 ----- ltac/tauto.mli | 0 plugins/ltac/Ltac.v | 0 plugins/ltac/coretactics.ml4 | 329 +++++ plugins/ltac/evar_tactics.ml | 93 ++ plugins/ltac/evar_tactics.mli | 19 + plugins/ltac/extraargs.ml4 | 389 ++++++ plugins/ltac/extraargs.mli | 78 ++ plugins/ltac/extratactics.ml4 | 1097 ++++++++++++++++ plugins/ltac/extratactics.mli | 14 + plugins/ltac/g_auto.ml4 | 228 ++++ plugins/ltac/g_class.ml4 | 120 ++ plugins/ltac/g_eqdecide.ml4 | 27 + plugins/ltac/g_ltac.ml4 | 526 ++++++++ plugins/ltac/g_obligations.ml4 | 161 +++ plugins/ltac/g_rewrite.ml4 | 274 ++++ plugins/ltac/g_tactic.ml4 | 665 ++++++++++ plugins/ltac/ltac_plugin.mllib | 27 + plugins/ltac/pltac.ml | 65 + plugins/ltac/pltac.mli | 38 + plugins/ltac/pptactic.ml | 1361 ++++++++++++++++++++ plugins/ltac/pptactic.mli | 67 + plugins/ltac/pptacticsig.mli | 81 ++ plugins/ltac/profile_ltac.ml | 420 +++++++ plugins/ltac/profile_ltac.mli | 48 + plugins/ltac/profile_ltac_tactics.ml4 | 40 + plugins/ltac/rewrite.ml | 2223 +++++++++++++++++++++++++++++++++ plugins/ltac/rewrite.mli | 117 ++ plugins/ltac/tacarg.ml | 26 + plugins/ltac/tacarg.mli | 27 + plugins/ltac/taccoerce.ml | 343 +++++ plugins/ltac/taccoerce.mli | 96 ++ plugins/ltac/tacentries.ml | 525 ++++++++ plugins/ltac/tacentries.mli | 64 + plugins/ltac/tacenv.ml | 143 +++ plugins/ltac/tacenv.mli | 75 ++ plugins/ltac/tacexpr.mli | 396 ++++++ plugins/ltac/tacintern.ml | 812 ++++++++++++ plugins/ltac/tacintern.mli | 64 + plugins/ltac/tacinterp.ml | 2157 ++++++++++++++++++++++++++++++++ plugins/ltac/tacinterp.mli | 122 ++ plugins/ltac/tacsubst.ml | 308 +++++ plugins/ltac/tacsubst.mli | 30 + plugins/ltac/tactic_debug.ml | 422 +++++++ plugins/ltac/tactic_debug.mli | 80 ++ plugins/ltac/tactic_matching.ml | 377 ++++++ plugins/ltac/tactic_matching.mli | 49 + plugins/ltac/tactic_option.ml | 51 + plugins/ltac/tactic_option.mli | 15 + plugins/ltac/tauto.ml | 279 +++++ plugins/ltac/tauto.mli | 0 plugins/ltac/vo.itarget | 1 + theories/Init/Notations.v | 3 + toplevel/coqtop.ml | 2 - 103 files changed, 14982 insertions(+), 14979 deletions(-) delete mode 100644 ltac/coretactics.ml4 delete mode 100644 ltac/evar_tactics.ml delete mode 100644 ltac/evar_tactics.mli delete mode 100644 ltac/extraargs.ml4 delete mode 100644 ltac/extraargs.mli delete mode 100644 ltac/extratactics.ml4 delete mode 100644 ltac/extratactics.mli delete mode 100644 ltac/g_auto.ml4 delete mode 100644 ltac/g_class.ml4 delete mode 100644 ltac/g_eqdecide.ml4 delete mode 100644 ltac/g_ltac.ml4 delete mode 100644 ltac/g_obligations.ml4 delete mode 100644 ltac/g_rewrite.ml4 delete mode 100644 ltac/g_tactic.ml4 delete mode 100644 ltac/ltac.mllib delete mode 100644 ltac/pltac.ml delete mode 100644 ltac/pltac.mli delete mode 100644 ltac/pptactic.ml delete mode 100644 ltac/pptactic.mli delete mode 100644 ltac/pptacticsig.mli delete mode 100644 ltac/profile_ltac.ml delete mode 100644 ltac/profile_ltac.mli delete mode 100644 ltac/profile_ltac_tactics.ml4 delete mode 100644 ltac/rewrite.ml delete mode 100644 ltac/rewrite.mli delete mode 100644 ltac/tacarg.ml delete mode 100644 ltac/tacarg.mli delete mode 100644 ltac/taccoerce.ml delete mode 100644 ltac/taccoerce.mli delete mode 100644 ltac/tacentries.ml delete mode 100644 ltac/tacentries.mli delete mode 100644 ltac/tacenv.ml delete mode 100644 ltac/tacenv.mli delete mode 100644 ltac/tacexpr.mli delete mode 100644 ltac/tacintern.ml delete mode 100644 ltac/tacintern.mli delete mode 100644 ltac/tacinterp.ml delete mode 100644 ltac/tacinterp.mli delete mode 100644 ltac/tacsubst.ml delete mode 100644 ltac/tacsubst.mli delete mode 100644 ltac/tactic_debug.ml delete mode 100644 ltac/tactic_debug.mli delete mode 100644 ltac/tactic_matching.ml delete mode 100644 ltac/tactic_matching.mli delete mode 100644 ltac/tactic_option.ml delete mode 100644 ltac/tactic_option.mli delete mode 100644 ltac/tauto.ml delete mode 100644 ltac/tauto.mli create mode 100644 plugins/ltac/Ltac.v create mode 100644 plugins/ltac/coretactics.ml4 create mode 100644 plugins/ltac/evar_tactics.ml create mode 100644 plugins/ltac/evar_tactics.mli create mode 100644 plugins/ltac/extraargs.ml4 create mode 100644 plugins/ltac/extraargs.mli create mode 100644 plugins/ltac/extratactics.ml4 create mode 100644 plugins/ltac/extratactics.mli create mode 100644 plugins/ltac/g_auto.ml4 create mode 100644 plugins/ltac/g_class.ml4 create mode 100644 plugins/ltac/g_eqdecide.ml4 create mode 100644 plugins/ltac/g_ltac.ml4 create mode 100644 plugins/ltac/g_obligations.ml4 create mode 100644 plugins/ltac/g_rewrite.ml4 create mode 100644 plugins/ltac/g_tactic.ml4 create mode 100644 plugins/ltac/ltac_plugin.mllib create mode 100644 plugins/ltac/pltac.ml create mode 100644 plugins/ltac/pltac.mli create mode 100644 plugins/ltac/pptactic.ml create mode 100644 plugins/ltac/pptactic.mli create mode 100644 plugins/ltac/pptacticsig.mli create mode 100644 plugins/ltac/profile_ltac.ml create mode 100644 plugins/ltac/profile_ltac.mli create mode 100644 plugins/ltac/profile_ltac_tactics.ml4 create mode 100644 plugins/ltac/rewrite.ml create mode 100644 plugins/ltac/rewrite.mli create mode 100644 plugins/ltac/tacarg.ml create mode 100644 plugins/ltac/tacarg.mli create mode 100644 plugins/ltac/taccoerce.ml create mode 100644 plugins/ltac/taccoerce.mli create mode 100644 plugins/ltac/tacentries.ml create mode 100644 plugins/ltac/tacentries.mli create mode 100644 plugins/ltac/tacenv.ml create mode 100644 plugins/ltac/tacenv.mli create mode 100644 plugins/ltac/tacexpr.mli create mode 100644 plugins/ltac/tacintern.ml create mode 100644 plugins/ltac/tacintern.mli create mode 100644 plugins/ltac/tacinterp.ml create mode 100644 plugins/ltac/tacinterp.mli create mode 100644 plugins/ltac/tacsubst.ml create mode 100644 plugins/ltac/tacsubst.mli create mode 100644 plugins/ltac/tactic_debug.ml create mode 100644 plugins/ltac/tactic_debug.mli create mode 100644 plugins/ltac/tactic_matching.ml create mode 100644 plugins/ltac/tactic_matching.mli create mode 100644 plugins/ltac/tactic_option.ml create mode 100644 plugins/ltac/tactic_option.mli create mode 100644 plugins/ltac/tauto.ml create mode 100644 plugins/ltac/tauto.mli create mode 100644 plugins/ltac/vo.itarget diff --git a/Makefile.common b/Makefile.common index 2cf4d01695..df705034e7 100644 --- a/Makefile.common +++ b/Makefile.common @@ -55,14 +55,14 @@ MKDIR:=install -d CORESRCDIRS:=\ config lib kernel intf kernel/byterun library \ engine pretyping interp proofs parsing printing \ - tactics vernac stm toplevel ltac + tactics vernac stm toplevel PLUGINDIRS:=\ omega romega micromega quote \ setoid_ring extraction fourier \ cc funind firstorder derive \ rtauto nsatz syntax decl_mode btauto \ - ssrmatching + ssrmatching ltac SRCDIRS:=\ $(CORESRCDIRS) \ @@ -77,14 +77,13 @@ 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 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 vernac/vernac.cma \ - stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma ltac/ltac.cma + stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma @@ -120,6 +119,7 @@ OTHERSYNTAXCMO:=$(addprefix plugins/syntax/, \ string_syntax_plugin.cmo ) DECLMODECMO:=plugins/decl_mode/decl_mode_plugin.cmo DERIVECMO:=plugins/derive/derive_plugin.cmo +LTACCMO:=plugins/ltac/ltac_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ @@ -127,7 +127,7 @@ PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ $(FOURIERCMO) $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(NATSYNTAXCMO) $(OTHERSYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) + $(DERIVECMO) $(SSRMATCHINGCMO) $(LTACCMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) diff --git a/Makefile.dev b/Makefile.dev index 8c1812da18..ea6b8b9194 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -121,10 +121,9 @@ pretyping: pretyping/pretyping.cma highparsing: parsing/highparsing.cma stm: stm/stm.cma toplevel: toplevel/toplevel.cma -ltac: ltac/ltac.cma .PHONY: lib kernel byterun library proofs tactics interp parsing pretyping -.PHONY: engine highparsing stm toplevel ltac +.PHONY: engine highparsing stm toplevel ###################### ### 3) theories files @@ -183,6 +182,7 @@ RTAUTOVO:=$(filter plugins/rtauto/%, $(PLUGINSVO)) EXTRACTIONVO:=$(filter plugins/extraction/%, $(PLUGINSVO)) CCVO:= DERIVEVO:=$(filter plugins/derive/%, $(PLUGINSVO)) +LTACVO:=$(filter plugins/ltac/%, $(PLUGINSVO)) omega: $(OMEGAVO) $(OMEGACMO) $(ROMEGAVO) $(ROMEGACMO) micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT) @@ -194,9 +194,10 @@ funind: $(FUNINDCMO) $(FUNINDVO) cc: $(CCVO) $(CCCMO) rtauto: $(RTAUTOVO) $(RTAUTOCMO) btauto: $(BTAUTOVO) $(BTAUTOCMO) +ltac: $(LTACVO) $(LTACCMO) .PHONY: omega micromega setoid_ring nsatz extraction -.PHONY: fourier funind cc rtauto btauto +.PHONY: fourier funind cc rtauto btauto ltac ################################# ### Misc other development rules diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index 46caca8d6f..23ad1fc017 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -32,6 +32,6 @@ exec $OCAMLDEBUG \ -I $COQTOP/plugins/ring -I $COQTOP/plugins/romega \ -I $COQTOP/plugins/rtauto -I $COQTOP/plugins/setoid_ring \ -I $COQTOP/plugins/subtac -I $COQTOP/plugins/syntax \ - -I $COQTOP/plugins/xml \ + -I $COQTOP/plugins/xml -I $COQTOP/plugins/ltac \ -I $COQTOP/ide \ "$@" diff --git a/ltac/coretactics.ml4 b/ltac/coretactics.ml4 deleted file mode 100644 index 28ff6df838..0000000000 --- a/ltac/coretactics.ml4 +++ /dev/null @@ -1,329 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ Tactics.intros_reflexivity ] -END - -TACTIC EXTEND exact - [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] -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) ] -> [ Tactics.exact_no_check c ] -END - -TACTIC EXTEND vm_cast_no_check - [ "vm_cast_no_check" constr(c) ] -> [ Tactics.vm_cast_no_check c ] -END - -TACTIC EXTEND native_cast_no_check - [ "native_cast_no_check" constr(c) ] -> [ 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 (fun c -> Tactics.specialize c None) - ] -| [ "specialize" constr_with_bindings(c) "as" intropattern(ipat) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c (Some ipat)) - ] -END - -TACTIC EXTEND symmetry - [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] -END - -TACTIC EXTEND symmetry_in -| [ "symmetry" "in" in_clause(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 - -TACTIC EXTEND intro -| [ "intro" ] -> [ Tactics.intro_move None MoveLast ] -| [ "intro" ident(id) ] -> [ Tactics.intro_move (Some id) MoveLast ] -| [ "intro" ident(id) "at" "top" ] -> [ Tactics.intro_move (Some id) MoveFirst ] -| [ "intro" ident(id) "at" "bottom" ] -> [ Tactics.intro_move (Some id) MoveLast ] -| [ "intro" ident(id) "after" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveAfter h) ] -| [ "intro" ident(id) "before" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveBefore h) ] -| [ "intro" "at" "top" ] -> [ Tactics.intro_move None MoveFirst ] -| [ "intro" "at" "bottom" ] -> [ Tactics.intro_move None MoveLast ] -| [ "intro" "after" hyp(h) ] -> [ Tactics.intro_move None (MoveAfter h) ] -| [ "intro" "before" hyp(h) ] -> [ Tactics.intro_move None (MoveBefore h) ] -END - -(** Move *) - -TACTIC EXTEND move - [ "move" hyp(id) "at" "top" ] -> [ Tactics.move_hyp id MoveFirst ] -| [ "move" hyp(id) "at" "bottom" ] -> [ Tactics.move_hyp id MoveLast ] -| [ "move" hyp(id) "after" hyp(h) ] -> [ Tactics.move_hyp id (MoveAfter h) ] -| [ "move" hyp(id) "before" hyp(h) ] -> [ Tactics.move_hyp id (MoveBefore h) ] -END - -(** Rename *) - -TACTIC EXTEND rename -| [ "rename" ne_rename_list_sep(ids, ",") ] -> [ Tactics.rename_hyp ids ] -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 - -(** Double induction *) - -TACTIC EXTEND double_induction - [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> - [ Elim.h_double_induction h1 h2 ] -END - -(* Admit *) - -TACTIC EXTEND admit - [ "admit" ] -> [ Proofview.give_up ] -END - -(* Fix *) - -TACTIC EXTEND fix - [ "fix" natural(n) ] -> [ Tactics.fix None n ] -| [ "fix" ident(id) natural(n) ] -> [ Tactics.fix (Some id) n ] -END - -(* Cofix *) - -TACTIC EXTEND cofix - [ "cofix" ] -> [ Tactics.cofix None ] -| [ "cofix" ident(id) ] -> [ Tactics.cofix (Some id) ] -END - -(* Clear *) - -TACTIC EXTEND clear - [ "clear" hyp_list(ids) ] -> [ - if List.is_empty ids then Tactics.keep [] - else 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) ] -> [ 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); - "intros", TacIntroPattern (false,[]); - ] - 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/evar_tactics.ml b/ltac/evar_tactics.ml deleted file mode 100644 index c5b26e6d56..0000000000 --- a/ltac/evar_tactics.ml +++ /dev/null @@ -1,93 +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 (NamedDecl.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 deleted file mode 100644 index e67540c055..0000000000 --- a/ltac/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/ltac/extraargs.ml4 b/ltac/extraargs.ml4 deleted file mode 100644 index 53b726432c..0000000000 --- a/ltac/extraargs.ml4 +++ /dev/null @@ -1,389 +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 - CErrors.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 - TYPED AS int list - PRINTED BY pr_int_list_full - - INTERPRETED BY interp_occs - GLOBALIZED BY glob_occs - SUBSTITUTED BY subst_occs - - RAW_PRINTED BY pr_occurrences - 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_PRINTED BY pr_gen - 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 - TYPED AS glob - PRINTED BY pr_globc - - INTERPRETED BY interp_glob - GLOBALIZED BY glob_glob - SUBSTITUTED BY subst_glob - - RAW_PRINTED BY pr_gen - GLOB_PRINTED BY pr_gen - [ lconstr(c) ] -> [ c ] -END - -let interp_casted_constr ist gl c = - interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c - -ARGUMENT EXTEND casted_constr - TYPED AS constr - PRINTED BY pr_gen - INTERPRETED BY interp_casted_constr - [ constr(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_PRINTED BY pr_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 - -let pr_rename _ _ _ (n, m) = Nameops.pr_id n ++ str " into " ++ Nameops.pr_id m - -ARGUMENT EXTEND rename - TYPED AS ident * ident - PRINTED BY pr_rename -| [ ident(n) "into" ident(m) ] -> [ (n, m) ] -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 - -let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl -let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl -let in_clause' = Pltac.in_clause - -ARGUMENT EXTEND in_clause - TYPED AS clause_dft_concl - PRINTED BY pr_in_top_clause - RAW_TYPED AS clause_dft_concl - RAW_PRINTED BY pr_in_clause - GLOB_TYPED AS clause_dft_concl - GLOB_PRINTED BY pr_in_clause -| [ in_clause'(cl) ] -> [ cl ] -END - -(* 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" - | Retroknowledge.Int31Constructor -> assert false - | Retroknowledge.Int31PlusC -> str "plusc" - | Retroknowledge.Int31PlusCarryC -> str "pluscarryc" - | Retroknowledge.Int31Minus -> str "minus" - | Retroknowledge.Int31MinusC -> str "minusc" - | Retroknowledge.Int31MinusCarryC -> str "minuscarryc" - | Retroknowledge.Int31TimesC -> str "timesc" - | Retroknowledge.Int31Div21 -> str "div21" - | Retroknowledge.Int31Div -> str "div" - | Retroknowledge.Int31Diveucl -> str "diveucl" - | Retroknowledge.Int31AddMulDiv -> str "addmuldiv" - | Retroknowledge.Int31Compare -> str "compare" - | Retroknowledge.Int31Head0 -> str "head0" - | Retroknowledge.Int31Tail0 -> str "tail0" - | Retroknowledge.Int31Lor -> str "lor" - | Retroknowledge.Int31Land -> str "land" - | Retroknowledge.Int31Lxor -> str "lxor" - -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) ++ - spc () ++ str "in " ++ qs 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 deleted file mode 100644 index b12187e18a..0000000000 --- a/ltac/extraargs.mli +++ /dev/null @@ -1,78 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.std_ppcmds - -val wit_rename : (Id.t * Id.t) Genarg.uniform_genarg_type - -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 wit_casted_constr : - (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, - Geninterp.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 - -val wit_in_clause : - (Id.t Loc.located Locus.clause_expr, - Id.t Loc.located Locus.clause_expr, - Id.t Locus.clause_expr) Genarg.genarg_type diff --git a/ltac/extratactics.ml4 b/ltac/extratactics.ml4 deleted file mode 100644 index 1223f6eb4b..0000000000 --- a/ltac/extratactics.ml4 +++ /dev/null @@ -1,1097 +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 = Pltac.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 mytclWithHoles tac with_evars c = - Proofview.Goal.enter { enter = begin fun gl -> - let env = Tacmach.New.pf_env gl in - let sigma = Tacmach.New.project gl in - let sigma',c = Tactics.force_destruction_arg with_evars env sigma c in - Tacticals.New.tclWITHHOLES with_evars (tac with_evars (Some c)) sigma' - end } - -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 - [ "simplify_eq" ] -> [ dEq false None ] -| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq false c ] -END -TACTIC EXTEND esimplify_eq -| [ "esimplify_eq" ] -> [ dEq true None ] -| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq true c ] -END - -let discr_main c = elimOnConstrWithHoles discr_tac false c - -TACTIC EXTEND discriminate -| [ "discriminate" ] -> [ discr_tac false None ] -| [ "discriminate" destruction_arg(c) ] -> - [ mytclWithHoles discr_tac false c ] -END -TACTIC EXTEND ediscriminate -| [ "ediscriminate" ] -> [ discr_tac true None ] -| [ "ediscriminate" destruction_arg(c) ] -> - [ mytclWithHoles discr_tac true c ] -END - -let discrHyp id = - Proofview.tclEVARMAP >>= fun sigma -> - discr_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } - -let injection_main with_evars c = - elimOnConstrWithHoles (injClause None) with_evars c - -TACTIC EXTEND injection -| [ "injection" ] -> [ injClause None false None ] -| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) false c ] -END -TACTIC EXTEND einjection -| [ "einjection" ] -> [ injClause None true None ] -| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) true c ] -END -TACTIC EXTEND injection_as -| [ "injection" "as" intropattern_list(ipat)] -> - [ injClause (Some ipat) false None ] -| [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause (Some ipat)) false c ] -END -TACTIC EXTEND einjection_as -| [ "einjection" "as" intropattern_list(ipat)] -> - [ injClause (Some ipat) true None ] -| [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause (Some ipat)) true c ] -END -TACTIC EXTEND simple_injection -| [ "simple" "injection" ] -> [ simpleInjClause false None ] -| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles simpleInjClause false c ] -END - -let injHyp id = - Proofview.tclEVARMAP >>= fun sigma -> - injection_main false { 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 : Geninterp.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 (** This is a global universe context that shouldn't be - refreshed at every use of the hint, declare it globally. *) - (Declare.declare_universe_context false ctx; - Univ.ContextSet.empty) - 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 - -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 - let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in - (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) - -let add_hints_iff l2r lc n bl = - let l = Locality.LocalityFixme.consume () in - Hints.add_hints (Locality.make_module_locality l) 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 constr_flags = { - Pretyping.use_typeclasses = true; - Pretyping.solve_unification_constraints = true; - Pretyping.use_hook = Some Pfedit.solve_by_implicit_tactic; - Pretyping.fail_evar = false; - Pretyping.expand_evars = true } - -let refine_tac ist simple with_classes 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 = - { constr_flags with Pretyping.use_typeclasses = with_classes } in - let expected_type = Pretyping.OfType concl 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:true 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 true c ] -END - -TACTIC EXTEND simple_refine -| [ "simple" "refine" uconstr(c) ] -> - [ refine_tac ist true true c ] -END - -TACTIC EXTEND notcs_refine -| [ "notypeclasses" "refine" uconstr(c) ] -> - [ refine_tac ist false false c ] -END - -TACTIC EXTEND notcs_simple_refine -| [ "simple" "notypeclasses" "refine" uconstr(c) ] -> - [ refine_tac ist true false c ] -END - -(* Solve unification constraints using heuristics or fail if any remain *) -TACTIC EXTEND solve_constraints -[ "solve_constraints" ] -> [ Refine.solve_constraints ] -END - -(**********************************************************************) -(* Inversion lemmas (Leminv) *) - -open Inv -open Leminv - -let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater - -VERNAC ARGUMENT EXTEND sort -| [ "Set" ] -> [ GSet ] -| [ "Prop" ] -> [ GProp ] -| [ "Type" ] -> [ GType [] ] -END - -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 - -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 - -let cache_implicit_tactic (_,tac) = match tac with - | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac) - | None -> Pfedit.clear_implicit_tactic () - -let subst_implicit_tactic (subst,tac) = - Option.map (Tacsubst.subst_tactic subst) tac - -let inImplicitTactic : glob_tactic_expr option -> obj = - declare_object {(default_object "IMPLICIT-TACTIC") with - open_function = (fun i o -> if Int.equal i 1 then cache_implicit_tactic o); - cache_function = cache_implicit_tactic; - subst_function = subst_implicit_tactic; - classify_function = (fun o -> Dispose)} - -let declare_implicit_tactic tac = - Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac))) - -let clear_implicit_tactic () = - Lib.add_anonymous_leaf (inImplicitTactic None) - -VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF -| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ declare_implicit_tactic tac ] -| [ "Clear" "Implicit" "Tactic" ] -> [ 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) ] -> [ 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) = CErrors.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 CErrors.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 - [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) ] -> - [ Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> - match Evarutil.kind_of_term_upto sigma x with - | Evar _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar") - end - ] -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;; - -TACTIC EXTEND is_ind -| [ "is_ind" constr(x) ] -> - [ match kind_of_term x with - | Ind _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") ] -END;; - -TACTIC EXTEND is_constructor -| [ "is_constructor" constr(x) ] -> - [ match kind_of_term x with - | Construct _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") ] -END;; - -TACTIC EXTEND is_proj -| [ "is_proj" constr(x) ] -> - [ match kind_of_term x with - | Proj _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") ] -END;; - -TACTIC EXTEND is_const -| [ "is_const" constr(x) ] -> - [ match kind_of_term x with - | Const _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") ] -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" ] - => [ Vernac_classifier.classify_as_proofstep ] - -> [ 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" ] - => [ Vernac_classifier.classify_as_proofstep ] - -> [ 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 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 (Pputils.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 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_PRINTED BY pr_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" ] -> [ Feedback.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 deleted file mode 100644 index 18334dafe7..0000000000 --- a/ltac/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/ltac/g_auto.ml4 b/ltac/g_auto.ml4 deleted file mode 100644 index a37cf306e1..0000000000 --- a/ltac/g_auto.ml4 +++ /dev/null @@ -1,228 +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; - solve_unification_constraints = 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 - -let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr -let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr c) -let pr_auto_using _ _ _ = Pptactic.pr_auto_using Printer.pr_closed_glob - -ARGUMENT EXTEND auto_using - TYPED AS uconstr_list - PRINTED BY pr_auto_using - RAW_TYPED AS uconstr_list - RAW_PRINTED BY pr_auto_using_raw - GLOB_TYPED AS uconstr_list - GLOB_PRINTED BY pr_auto_using_glob -| [ "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_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_reference -let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global -let glob_hints_path_atom ist = Hints.glob_hints_path_atom - -ARGUMENT EXTEND hints_path_atom - PRINTED BY pr_hints_path_atom - - GLOBALIZED BY glob_hints_path_atom - - RAW_PRINTED BY pr_pre_hints_path_atom - GLOB_PRINTED BY pr_hints_path_atom -| [ ne_global_list(g) ] -> [ Hints.PathHints g ] -| [ "_" ] -> [ Hints.PathAny ] -END - -let pr_hints_path prc prx pry c = Hints.pp_hints_path c -let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_reference c -let glob_hints_path ist = Hints.glob_hints_path - -ARGUMENT EXTEND hints_path -PRINTED BY pr_hints_path - -GLOBALIZED BY glob_hints_path -RAW_PRINTED BY pr_pre_hints_path -GLOB_PRINTED BY pr_hints_path - -| [ "(" hints_path(p) ")" ] -> [ p ] -| [ hints_path(p) "*" ] -> [ Hints.PathStar p ] -| [ "emp" ] -> [ Hints.PathEmpty ] -| [ "eps" ] -> [ Hints.PathEpsilon ] -| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] -| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] -| [ hints_path(p) hints_path(q) ] -> [ Hints.PathSeq (p, q) ] -END - -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 (Hints.glob_hints_path 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 deleted file mode 100644 index a28132a4b0..0000000000 --- a/ltac/g_class.ml4 +++ /dev/null @@ -1,120 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - 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_search_strategy _prc _prlc _prt = function - | Some Dfs -> Pp.str "dfs" - | Some Bfs -> Pp.str "bfs" - | None -> Pp.mt () - -ARGUMENT EXTEND eauto_search_strategy PRINTED BY pr_search_strategy -| [ "(bfs)" ] -> [ Some Bfs ] -| [ "(dfs)" ] -> [ Some Dfs ] -| [ ] -> [ None ] -END - -(* true = All transparent, false = Opaque if possible *) - -VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF - | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> [ - set_typeclasses_debug d; - Option.iter set_typeclasses_strategy s; - set_typeclasses_depth depth - ] -END - -(** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *) -TACTIC EXTEND typeclasses_eauto - | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] -> - [ typeclasses_eauto ~strategy:Bfs ~depth:d l ] - | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> - [ typeclasses_eauto ~depth:d l ] - | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> [ - typeclasses_eauto ~only_classes:true ~depth:d [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 - -(** TODO: DEPRECATE *) -(* A progress test that allows to see if the evars have changed *) -open Term -open Proofview.Goal -open Proofview.Notations - -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 (Pp.str"No progress made (modulo evars)") - else Proofview.tclUNIT () - end } - in t <*> check - end } - -TACTIC EXTEND progress_evars - [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] -END diff --git a/ltac/g_eqdecide.ml4 b/ltac/g_eqdecide.ml4 deleted file mode 100644 index 905653281c..0000000000 --- a/ltac/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/ltac/g_ltac.ml4 b/ltac/g_ltac.ml4 deleted file mode 100644 index 54229bb2ae..0000000000 --- a/ltac/g_ltac.ml4 +++ /dev/null @@ -1,526 +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 Stdarg.wit_intro_pattern) pat -let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c -let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac - -let reference_to_id = function - | Libnames.Ident (loc, id) -> (loc, id) - | Libnames.Qualid (loc,_) -> - CErrors.user_err ~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 - e - -let toplevel_selector = new_entry "vernac:toplevel_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 *) - -let hint = G_proofs.hint - -let warn_deprecated_appcontext = - CWarnings.create ~name:"deprecated-appcontext" ~category:"deprecated" - (fun () -> strbrk "appcontext is deprecated and will be removed " ++ - strbrk "in a future version") - -GEXTEND Gram - GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint - tactic_mode constr_may_eval constr_eval toplevel_selector - operconstr; - - 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) - | sel = selector; ta = tactic_expr -> TacSelect (sel, ta) ] -(*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 - | c = Constr.constr -> (match c with CRef (r,None) -> Reference r | c -> ConstrMayEval (ConstrTerm c)) - (* Unambiguous 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; "]" -> - warn_deprecated_appcontext ~loc:!@loc (); - 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 Tacexpr.TacticRedefinition (name, TacFun (it, body)) - else - let id = reference_to_id name in - Tacexpr.TacticDefinition (id, TacFun (it, body)) - | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> - if redef then Tacexpr.TacticRedefinition (name, body) - else - let id = reference_to_id name in - Tacexpr.TacticDefinition (id, body) - ] ] - ; - tactic: - [ [ tac = tactic_expr -> tac ] ] - ; - - range_selector: - [ [ n = natural ; "-" ; m = natural -> (n, m) - | n = natural -> (n, n) ] ] - ; - (* We unfold a range selectors list once so that we can make a special case - * for a unique SelectNth selector. *) - range_selector_or_nth: - [ [ n = natural ; "-" ; m = natural; - l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - SelectList ((n, m) :: Option.default [] l) - | n = natural; - l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ] - ; - selector_body: - [ [ l = range_selector_or_nth -> l - | test_bracket_ident; "["; id = ident; "]" -> SelectId id ] ] - ; - selector: - [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] - ; - toplevel_selector: - [ [ sel = selector_body; ":" -> sel - | IDENT "all"; ":" -> SelectAll ] ] - ; - tactic_mode: - [ [ g = OPT toplevel_selector; tac = G_vernac.subgoal_command -> tac g ] ] - ; - command: - [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; - l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> - Vernacexpr.VernacProof (Some (in_tac ta), G_proofs.hint_proof_using G_vernac.section_subset_expr l) - | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; - ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] -> - Vernacexpr.VernacProof (ta,Some l) ] ] - ; - hint: - [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; - tac = Pltac.tactic -> - Vernacexpr.HintsExtern (n,c, in_tac tac) ] ] - ; - operconstr: LEVEL "0" - [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> - let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in - CHole (!@loc, None, IntroAnonymous, Some arg) ] ] - ; - END - -open Stdarg -open Tacarg -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 | SelectList _ -> 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 Feedback.feedback Feedback.AddedAxiom - -let pr_range_selector (i, j) = - if Int.equal i j then int i - else int i ++ str "-" ++ int j - -let pr_ltac_selector = function -| SelectNth i -> int i ++ str ":" -| SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ - str "]" ++ str ":" -| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" -| SelectAll -> str "all" ++ str ":" - -VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector -| [ toplevel_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 (* Bug: a space is inserted before "..." *) str ".." else mt () - -VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default -| [ "." ] -> [ false ] -| [ "..." ] -> [ true ] -END - -let is_anonymous_abstract = function - | TacAbstract (_,None) -> true - | TacSolve [TacAbstract (_,None)] -> true - | _ -> false -let rm_abstract = function - | TacAbstract (t,_) -> t - | TacSolve [TacAbstract (t,_)] -> TacSolve [t] - | x -> x -let is_explicit_terminator = function TacSolve _ -> true | _ -> false - -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) ] => - [ - let anon_abstracting_tac = is_anonymous_abstract t in - let solving_tac = is_explicit_terminator t in - let parallel = `Yes (solving_tac,anon_abstracting_tac) in - let pbr = if solving_tac then Some "par" else None in - VtProofStep{ parallel = parallel; proof_block_detection = pbr }, - VtLater - ] -> [ - let t = rm_abstract t in - 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 -| Tacentries.TacTerm s -> quote (str s) -| Tacentries.TacNonTerm (_, (arg, sep), id) -> - let sep = match sep with - | 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) ] -> [ Tacentries.TacTerm s ] -| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> - [ Tacentries.TacNonTerm (loc, (Names.Id.to_string nt, sep), p) ] -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) ] -> - [ Feedback.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 - -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 - -VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY -| [ "Print" "Ltac" "Signatures" ] -> [ Tacentries.print_ltacs () ] -END diff --git a/ltac/g_obligations.ml4 b/ltac/g_obligations.ml4 deleted file mode 100644 index d286a58708..0000000000 --- a/ltac/g_obligations.ml4 +++ /dev/null @@ -1,161 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - snd (get_default_tactic ()) - end in - Obligations.default_tactic := tac - -let with_tac f tac = - let env = { Genintern.genv = Global.env (); ltacvars = Names.Id.Set.empty } in - let tac = match tac with - | None -> None - | Some tac -> - let tac = Genarg.in_gen (Genarg.rawwit wit_ltac) tac in - let _, tac = Genintern.generic_intern env tac in - Some tac - in - f 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 = Pltac - -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 obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac -let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac - -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" ] -> [ - Feedback.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) ] -> [ Feedback.msg_info (show_term (Some name)) ] -| [ "Preterm" ] -> [ Feedback.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 deleted file mode 100644 index b1c4f58eb8..0000000000 --- a/ltac/g_rewrite.ml4 +++ /dev/null @@ -1,274 +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 prc prlc _ (s : raw_strategy) = - let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_reference, prc) in - Rewrite.pr_strategy prc prr s -let pr_glob_strategy prc prlc _ (s : glob_strategy) = - let prr = Pptactic.pr_red_expr - (Ppconstr.pr_constr_expr, - Ppconstr.pr_lconstr_expr, - Pputils.pr_or_by_notation Libnames.pr_reference, - Ppconstr.pr_constr_expr) - in - Rewrite.pr_strategy prc prr s - -ARGUMENT EXTEND rewstrategy - PRINTED BY pr_strategy - - INTERPRETED BY interp_strategy - GLOBALIZED BY glob_strategy - SUBSTITUTED BY subst_strategy - - RAW_PRINTED BY pr_raw_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)) - -TACTIC EXTEND rewrite_strat -| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] -| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] -| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ] -| [ "rewrite_db" preident(db) ] -> [ 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 - | _ -> Proofview.V82.of_tactic (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) ] - -> [ cl_rewrite_clause c o AllOccurrences None ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> - [ cl_rewrite_clause c o AllOccurrences (Some id) ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> - [ cl_rewrite_clause c o (occurrences_of occ) None ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> - [ 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)] -> - [ 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) - -let () = - let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in - let printer _ _ _ _ = Pp.str "" in - Pptactic.declare_extra_genarg_pprule wit_binders raw_printer printer printer - -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) ] -> [ Feedback.msg_notice (Autorewrite.print_rewrite_hintdb s) ] -END diff --git a/ltac/g_tactic.ml4 b/ltac/g_tactic.ml4 deleted file mode 100644 index 685c07c9a8..0000000000 --- a/ltac/g_tactic.ml4 +++ /dev/null @@ -1,665 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* "; "<-" ; "by" ] -let _ = List.iter CLexer.add_keyword tactic_kw - -let err () = raise Stream.Failure - -(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) -(* admissible notation "(x t)" *) -let test_lpar_id_coloneq = - 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 ()) - -(* 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" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD "(" -> - (match get_tok (stream_nth 1 strm) with - | IDENT _ | INT _ -> - (match get_tok (stream_nth 2 strm) with - | KEYWORD ":=" -> () - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) - -(* idem for (x:t) *) -let test_lpar_id_colon = - Gram.Entry.of_parser "lpar_id_colon" - (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 (x1..xn:t) [n^2 complexity but exceptional use] *) -let check_for_coloneq = - Gram.Entry.of_parser "lpar_id_colon" - (fun strm -> - let rec skip_to_rpar p n = - match get_tok (List.last (Stream.npeek n strm)) with - | KEYWORD "(" -> skip_to_rpar (p+1) (n+1) - | KEYWORD ")" -> if Int.equal p 0 then n+1 else skip_to_rpar (p-1) (n+1) - | KEYWORD "." -> err () - | _ -> skip_to_rpar p (n+1) in - let rec skip_names n = - match get_tok (List.last (Stream.npeek n strm)) with - | IDENT _ | KEYWORD "_" -> skip_names (n+1) - | KEYWORD ":" -> skip_to_rpar 0 (n+1) (* skip a constr *) - | _ -> err () in - let rec skip_binders n = - match get_tok (List.last (Stream.npeek n strm)) with - | KEYWORD "(" -> skip_binders (skip_names (n+1)) - | IDENT _ | KEYWORD "_" -> skip_binders (n+1) - | KEYWORD ":=" -> () - | _ -> err () in - match get_tok (stream_nth 0 strm) with - | KEYWORD "(" -> skip_binders 2 - | _ -> err ()) - -let lookup_at_as_comma = - Gram.Entry.of_parser "lookup_at_as_comma" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD (","|"at"|"as") -> () - | _ -> err ()) - -open Constr -open Prim -open Pltac - -let mk_fix_tac (loc,id,bl,ann,ty) = - let n = - match bl,ann with - [([_],_,_)], None -> 1 - | _, Some x -> - let ids = List.map snd (List.flatten (List.map pi1 bl)) in - (try List.index Names.Name.equal (snd x) ids - with Not_found -> error "No such fix variable.") - | _ -> error "Cannot guess decreasing argument of fix." in - (id,n,CProdN(loc,bl,ty)) - -let mk_cofix_tac (loc,id,bl,ann,ty) = - let _ = Option.map (fun (aloc,_) -> - user_err ~loc:aloc - ~hdr:"Constr:mk_cofix_tac" - (Pp.str"Annotation forbidden in cofix expression.")) ann in - (id,CProdN(loc,bl,ty)) - -(* Functions overloaded by quotifier *) -let destruction_arg_of_constr (c,lbind as clbind) = match lbind with - | NoBindings -> - begin - try ElimOnIdent (Constrexpr_ops.constr_loc c,snd(Constrexpr_ops.coerce_to_id c)) - with e when CErrors.noncritical e -> ElimOnConstr clbind - end - | _ -> ElimOnConstr clbind - -let mkTacCase with_evar = function - | [(clear,ElimOnConstr cl),(None,None),None],None -> - TacCase (with_evar,(clear,cl)) - (* Reinterpret numbers as a notation for terms *) - | [(clear,ElimOnAnonHyp n),(None,None),None],None -> - TacCase (with_evar, - (clear,(CPrim (Loc.ghost, Numeral (Bigint.of_int n)), - NoBindings))) - (* Reinterpret ident as notations for variables in the context *) - (* because we don't know if they are quantified or not *) - | [(clear,ElimOnIdent id),(None,None),None],None -> - TacCase (with_evar,(clear,(CRef (Ident id,None),NoBindings))) - | ic -> - if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic) - then - error "Use of numbers as direct arguments of 'case' is not supported."; - TacInductionDestruct (false,with_evar,ic) - -let rec mkCLambdaN_simple_loc loc bll c = - match bll with - | ((loc1,_)::_ as idl,bk,t) :: bll -> - CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (Loc.merge loc1 loc) bll c) - | ([],_,_) :: bll -> mkCLambdaN_simple_loc loc bll c - | [] -> c - -let mkCLambdaN_simple bl c = match bl with - | [] -> c - | h :: _ -> - let loc = Loc.merge (fst (List.hd (pi1 h))) (Constrexpr_ops.constr_loc c) in - mkCLambdaN_simple_loc loc bl c - -let loc_of_ne_list l = Loc.merge (fst (List.hd l)) (fst (List.last l)) - -let map_int_or_var f = function - | ArgArg x -> ArgArg (f x) - | ArgVar _ as y -> y - -let all_concl_occs_clause = { onhyps=Some[]; concl_occs=AllOccurrences } - -let merge_occurrences loc cl = function - | None -> - if Locusops.clause_with_generic_occurrences cl then (None, cl) - else - user_err ~loc (str "Found an \"at\" clause without \"with\" clause.") - | Some (occs, p) -> - let ans = match occs with - | AllOccurrences -> cl - | _ -> - begin match cl with - | { onhyps = Some []; concl_occs = AllOccurrences } -> - { onhyps = Some []; concl_occs = occs } - | { onhyps = Some [(AllOccurrences, id), l]; concl_occs = NoOccurrences } -> - { cl with onhyps = Some [(occs, id), l] } - | _ -> - if Locusops.clause_with_generic_occurrences cl then - user_err ~loc (str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") - else - user_err ~loc (str "Cannot use clause \"at\" twice.") - end - in - (Some p, ans) - -let warn_deprecated_eqn_syntax = - CWarnings.create ~name:"deprecated-eqn-syntax" ~category:"deprecated" - (fun arg -> strbrk (Printf.sprintf "Syntax \"_eqn:%s\" is deprecated. Please use \"eqn:%s\" instead." arg arg)) - -(* Auxiliary grammar rules *) - -open Vernac_ - -GEXTEND Gram - GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis - bindings red_expr int_or_var open_constr uconstr - simple_intropattern in_clause clause_dft_concl hypident destruction_arg; - - int_or_var: - [ [ n = integer -> ArgArg n - | id = identref -> ArgVar id ] ] - ; - nat_or_var: - [ [ n = natural -> ArgArg n - | id = identref -> ArgVar id ] ] - ; - (* An identifier or a quotation meta-variable *) - id_or_meta: - [ [ id = identref -> id ] ] - ; - open_constr: - [ [ c = constr -> c ] ] - ; - uconstr: - [ [ c = constr -> c ] ] - ; - destruction_arg: - [ [ n = natural -> (None,ElimOnAnonHyp n) - | test_lpar_id_rpar; c = constr_with_bindings -> - (Some false,destruction_arg_of_constr c) - | c = constr_with_bindings_arg -> on_snd destruction_arg_of_constr c - ] ] - ; - constr_with_bindings_arg: - [ [ ">"; c = constr_with_bindings -> (Some true,c) - | c = constr_with_bindings -> (None,c) ] ] - ; - quantified_hypothesis: - [ [ id = ident -> NamedHyp id - | n = natural -> AnonHyp n ] ] - ; - conversion: - [ [ c = constr -> (None, c) - | c1 = constr; "with"; c2 = constr -> (Some (AllOccurrences,c1),c2) - | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr -> - (Some (occs,c1), c2) ] ] - ; - occs_nums: - [ [ nl = LIST1 nat_or_var -> OnlyOccurrences nl - | "-"; n = nat_or_var; nl = LIST0 int_or_var -> - (* have used int_or_var instead of nat_or_var for compatibility *) - AllOccurrencesBut (List.map (map_int_or_var abs) (n::nl)) ] ] - ; - occs: - [ [ "at"; occs = occs_nums -> occs | -> AllOccurrences ] ] - ; - pattern_occ: - [ [ c = constr; nl = occs -> (nl,c) ] ] - ; - ref_or_pattern_occ: - (* If a string, it is interpreted as a ref - (anyway a Coq string does not reduce) *) - [ [ c = smart_global; nl = occs -> nl,Inl c - | c = constr; nl = occs -> nl,Inr c ] ] - ; - unfold_occ: - [ [ c = smart_global; nl = occs -> (nl,c) ] ] - ; - intropatterns: - [ [ l = LIST0 nonsimple_intropattern -> l ]] - ; - ne_intropatterns: - [ [ l = LIST1 nonsimple_intropattern -> l ]] - ; - or_and_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> IntroOrPattern tc - | "()" -> IntroAndPattern [] - | "("; si = simple_intropattern; ")" -> IntroAndPattern [si] - | "("; si = simple_intropattern; ","; - 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 (IntroAndPattern (pairify q))))] - in IntroAndPattern (pairify (si::tc)) ] ] - ; - equality_intropattern: - [ [ "->" -> IntroRewrite true - | "<-" -> IntroRewrite false - | "[="; tc = intropatterns; "]" -> IntroInjection tc ] ] - ; - naming_intropattern: - [ [ prefix = pattern_ident -> IntroFresh prefix - | "?" -> IntroAnonymous - | id = ident -> IntroIdentifier id ] ] - ; - nonsimple_intropattern: - [ [ l = simple_intropattern -> l - | "*" -> !@loc, IntroForthcoming true - | "**" -> !@loc, IntroForthcoming false ]] - ; - simple_intropattern: - [ [ 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 - 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 = naming_intropattern -> !@loc, IntroNaming pat ] ] - ; - simple_binding: - [ [ "("; id = ident; ":="; c = lconstr; ")" -> (!@loc, NamedHyp id, c) - | "("; n = natural; ":="; c = lconstr; ")" -> (!@loc, AnonHyp n, c) ] ] - ; - bindings: - [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> - ExplicitBindings bl - | bl = LIST1 constr -> ImplicitBindings bl ] ] - ; - constr_with_bindings: - [ [ c = constr; l = with_bindings -> (c, l) ] ] - ; - with_bindings: - [ [ "with"; bl = bindings -> bl | -> NoBindings ] ] - ; - red_flags: - [ [ IDENT "beta" -> [FBeta] - | IDENT "iota" -> [FMatch;FFix;FCofix] - | IDENT "match" -> [FMatch] - | IDENT "fix" -> [FFix] - | IDENT "cofix" -> [FCofix] - | IDENT "zeta" -> [FZeta] - | IDENT "delta"; d = delta_flag -> [d] - ] ] - ; - delta_flag: - [ [ "-"; "["; idl = LIST1 smart_global; "]" -> FDeltaBut idl - | "["; idl = LIST1 smart_global; "]" -> FConst idl - | -> FDeltaBut [] - ] ] - ; - strategy_flag: - [ [ s = LIST1 red_flags -> Redops.make_red_flag (List.flatten s) - | d = delta_flag -> all_with d - ] ] - ; - red_expr: - [ [ 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 - | s = IDENT -> ExtraRedExpr s ] ] - ; - hypident: - [ [ id = id_or_meta -> - id,InHyp - | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> - id,InHypTypeOnly - | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> - id,InHypValueOnly - ] ] - ; - hypident_occ: - [ [ (id,l)=hypident; occs=occs -> ((occs,id),l) ] ] - ; - in_clause: - [ [ "*"; occs=occs -> - {onhyps=None; concl_occs=occs} - | "*"; "|-"; occs=concl_occ -> - {onhyps=None; concl_occs=occs} - | hl=LIST0 hypident_occ SEP","; "|-"; occs=concl_occ -> - {onhyps=Some hl; concl_occs=occs} - | hl=LIST0 hypident_occ SEP"," -> - {onhyps=Some hl; concl_occs=NoOccurrences} ] ] - ; - clause_dft_concl: - [ [ "in"; cl = in_clause -> cl - | occs=occs -> {onhyps=Some[]; concl_occs=occs} - | -> all_concl_occs_clause ] ] - ; - clause_dft_all: - [ [ "in"; cl = in_clause -> cl - | -> {onhyps=None; concl_occs=AllOccurrences} ] ] - ; - opt_clause: - [ [ "in"; cl = in_clause -> Some cl - | "at"; occs = occs_nums -> Some {onhyps=Some[]; concl_occs=occs} - | -> None ] ] - ; - concl_occ: - [ [ "*"; occs = occs -> occs - | -> NoOccurrences ] ] - ; - in_hyp_list: - [ [ "in"; idl = LIST1 id_or_meta -> idl - | -> [] ] ] - ; - in_hyp_as: - [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) - | -> None ] ] - ; - orient: - [ [ "->" -> true - | "<-" -> false - | -> true ]] - ; - simple_binder: - [ [ na=name -> ([na],Default Explicit,CHole (!@loc, Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None)) - | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c) - ] ] - ; - fixdecl: - [ [ "("; id = ident; bl=LIST0 simple_binder; ann=fixannot; - ":"; ty=lconstr; ")" -> (!@loc, id, bl, ann, ty) ] ] - ; - fixannot: - [ [ "{"; IDENT "struct"; id=name; "}" -> Some id - | -> None ] ] - ; - cofixdecl: - [ [ "("; id = ident; bl=LIST0 simple_binder; ":"; ty=lconstr; ")" -> - (!@loc, id, bl, None, ty) ] ] - ; - bindings_with_parameters: - [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; - ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ] - ; - eliminator: - [ [ "using"; el = constr_with_bindings -> el ] ] - ; - as_ipat: - [ [ "as"; ipat = simple_intropattern -> Some ipat - | -> None ] ] - ; - or_and_intropattern_loc: - [ [ ipat = or_and_intropattern -> ArgArg (!@loc,ipat) - | locid = identref -> ArgVar locid ] ] - ; - as_or_and_ipat: - [ [ "as"; ipat = or_and_intropattern_loc -> Some ipat - | -> None ] ] - ; - eqn_ipat: - [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (!@loc, pat) - | IDENT "_eqn"; ":"; pat = naming_intropattern -> - let loc = !@loc in - warn_deprecated_eqn_syntax ~loc "H"; Some (loc, pat) - | IDENT "_eqn" -> - let loc = !@loc in - warn_deprecated_eqn_syntax ~loc "?"; Some (loc, IntroAnonymous) - | -> None ] ] - ; - as_name: - [ [ "as"; id = ident -> Names.Name id | -> Names.Anonymous ] ] - ; - by_tactic: - [ [ "by"; tac = tactic_expr LEVEL "3" -> Some tac - | -> None ] ] - ; - rewriter : - [ [ "!"; c = constr_with_bindings_arg -> (RepeatPlus,c) - | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,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_arg -> (Precisely 1, c) - ] ] - ; - oriented_rewriter : - [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ] - ; - induction_clause: - [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; - cl = opt_clause -> (c,(eq,pat),cl) ] ] - ; - induction_clause_list: - [ [ ic = LIST1 induction_clause SEP ","; el = OPT eliminator; - cl_tolerance = opt_clause -> - (* Condition for accepting "in" at the end by compatibility *) - match ic,el,cl_tolerance with - | [c,pat,None],Some _,Some _ -> ([c,pat,cl_tolerance],el) - | _,_,Some _ -> err () - | _,_,None -> (ic,el) ]] - ; - simple_tactic: - [ [ - (* Basic tactics *) - IDENT "intros"; pl = ne_intropatterns -> - TacAtom (!@loc, TacIntroPattern (false,pl)) - | IDENT "intros" -> - TacAtom (!@loc, TacIntroPattern (false,[!@loc,IntroForthcoming false])) - | IDENT "eintros"; pl = ne_intropatterns -> - TacAtom (!@loc, TacIntroPattern (true,pl)) - - | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,false,cl,inhyp)) - | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,true,cl,inhyp)) - | IDENT "simple"; IDENT "apply"; - cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,false,cl,inhyp)) - | IDENT "simple"; IDENT "eapply"; - cl = LIST1 constr_with_bindings_arg SEP","; - inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,true,cl,inhyp)) - | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - TacAtom (!@loc, TacElim (false,cl,el)) - | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - 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"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> - TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd)) - | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> - TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd)) - - | IDENT "pose"; (id,b) = bindings_with_parameters -> - TacAtom (!@loc, TacLetTac (Names.Name id,b,Locusops.nowhere,true,None)) - | IDENT "pose"; b = constr; na = as_name -> - TacAtom (!@loc, TacLetTac (na,b,Locusops.nowhere,true,None)) - | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> - TacAtom (!@loc, TacLetTac (Names.Name id,c,p,true,None)) - | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> - TacAtom (!@loc, TacLetTac (na,c,p,true,None)) - | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; - p = clause_dft_all -> - TacAtom (!@loc, TacLetTac (na,c,p,false,e)) - - (* Alternative syntax for "pose proof c as id" *) - | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; - c = lconstr; ")" -> - TacAtom (!@loc, TacAssert (true,None,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) - - (* Alternative syntax for "assert c as id by tac" *) - | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> - TacAtom (!@loc, TacAssert (true,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) - - (* Alternative syntax for "enough c as id by tac" *) - | IDENT "enough"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> - TacAtom (!@loc, TacAssert (false,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) - - | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (!@loc, TacAssert (true,Some tac,ipat,c)) - | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - TacAtom (!@loc, TacAssert (true,None,ipat,c)) - | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (!@loc, TacAssert (false,Some tac,ipat,c)) - - | IDENT "generalize"; c = constr -> - TacAtom (!@loc, TacGeneralize [((AllOccurrences,c),Names.Anonymous)]) - | IDENT "generalize"; c = constr; l = LIST1 constr -> - let gen_everywhere c = ((AllOccurrences,c),Names.Anonymous) in - TacAtom (!@loc, TacGeneralize (List.map gen_everywhere (c::l))) - | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs; - na = as_name; - l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] -> - TacAtom (!@loc, TacGeneralize (((nl,c),na)::l)) - - (* Derived basic tactics *) - | IDENT "induction"; ic = induction_clause_list -> - TacAtom (!@loc, TacInductionDestruct (true,false,ic)) - | IDENT "einduction"; ic = induction_clause_list -> - TacAtom (!@loc, TacInductionDestruct(true,true,ic)) - | IDENT "destruct"; icl = induction_clause_list -> - TacAtom (!@loc, TacInductionDestruct(false,false,icl)) - | IDENT "edestruct"; icl = induction_clause_list -> - TacAtom (!@loc, TacInductionDestruct(false,true,icl)) - - (* Equality and inversion *) - | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t)) - | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (true,l,cl,t)) - | IDENT "dependent"; k = - [ IDENT "simple"; IDENT "inversion" -> SimpleInversion - | IDENT "inversion" -> FullInversion - | IDENT "inversion_clear" -> FullInversionClear ]; - hyp = quantified_hypothesis; - ids = as_or_and_ipat; co = OPT ["with"; c = constr -> c] -> - TacAtom (!@loc, TacInversion (DepInversion (k,co,ids),hyp)) - | IDENT "simple"; IDENT "inversion"; - hyp = quantified_hypothesis; ids = as_or_and_ipat; - cl = in_hyp_list -> - TacAtom (!@loc, TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) - | IDENT "inversion"; - hyp = quantified_hypothesis; ids = as_or_and_ipat; - cl = in_hyp_list -> - TacAtom (!@loc, TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) - | IDENT "inversion_clear"; - hyp = quantified_hypothesis; ids = as_or_and_ipat; - cl = in_hyp_list -> - TacAtom (!@loc, TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) - | IDENT "inversion"; hyp = quantified_hypothesis; - "using"; c = constr; cl = in_hyp_list -> - TacAtom (!@loc, TacInversion (InversionUsing (c,cl), hyp)) - - (* Conversion *) - | 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 - TacAtom (!@loc, TacChange (p,c,cl)) - ] ] - ; -END;; diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib deleted file mode 100644 index af1c7149da..0000000000 --- a/ltac/ltac.mllib +++ /dev/null @@ -1,27 +0,0 @@ -Tacarg -Pptactic -Pltac -Taccoerce -Tacsubst -Tacenv -Tactic_debug -Tacintern -Tacentries -Profile_ltac -Tactic_matching -Tacinterp -Evar_tactics -Tactic_option -Extraargs -G_obligations -Coretactics -Extratactics -Profile_ltac_tactics -G_auto -G_class -Rewrite -G_rewrite -Tauto -G_eqdecide -G_tactic -G_ltac diff --git a/ltac/pltac.ml b/ltac/pltac.ml deleted file mode 100644 index 1d21118ae8..0000000000 --- a/ltac/pltac.ml +++ /dev/null @@ -1,65 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Gram.entry table *) -(* Typically for tactic user extensions *) -let open_constr = - make_gen_entry utactic "open_constr" -let constr_with_bindings = - make_gen_entry utactic "constr_with_bindings" -let bindings = - make_gen_entry utactic "bindings" -let hypident = Gram.entry_create "hypident" -let constr_may_eval = make_gen_entry utactic "constr_may_eval" -let constr_eval = make_gen_entry utactic "constr_eval" -let uconstr = - make_gen_entry utactic "uconstr" -let quantified_hypothesis = - make_gen_entry utactic "quantified_hypothesis" -let destruction_arg = make_gen_entry utactic "destruction_arg" -let int_or_var = make_gen_entry utactic "int_or_var" -let simple_intropattern = - make_gen_entry utactic "simple_intropattern" -let in_clause = make_gen_entry utactic "in_clause" -let clause_dft_concl = - make_gen_entry utactic "clause" - - -(* Main entries for ltac *) -let tactic_arg = Gram.entry_create "tactic:tactic_arg" -let tactic_expr = make_gen_entry utactic "tactic_expr" -let binder_tactic = make_gen_entry utactic "binder_tactic" - -let tactic = make_gen_entry utactic "tactic" - -(* Main entry for quotations *) -let tactic_eoi = eoi_entry tactic - -let () = - let open Stdarg in - let open Tacarg in - register_grammar wit_int_or_var (int_or_var); - register_grammar wit_intro_pattern (simple_intropattern); - register_grammar wit_quant_hyp (quantified_hypothesis); - register_grammar wit_uconstr (uconstr); - register_grammar wit_open_constr (open_constr); - register_grammar wit_constr_with_bindings (constr_with_bindings); - register_grammar wit_bindings (bindings); - register_grammar wit_tactic (tactic); - register_grammar wit_ltac (tactic); - register_grammar wit_clause_dft_concl (clause_dft_concl); - register_grammar wit_destruction_arg (destruction_arg); - () diff --git a/ltac/pltac.mli b/ltac/pltac.mli deleted file mode 100644 index 810e1ec39a..0000000000 --- a/ltac/pltac.mli +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds - -type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> std_ppcmds) -> - (glob_constr_and_expr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds - -type 'a extra_genarg_printer = - (Term.constr -> std_ppcmds) -> - (Term.constr -> std_ppcmds) -> - (tolerability -> Val.t -> std_ppcmds) -> - 'a -> std_ppcmds - -module Make - (Ppconstr : Ppconstrsig.Pp) - (Taggers : sig - val tag_keyword - : std_ppcmds -> std_ppcmds - val tag_primitive - : std_ppcmds -> std_ppcmds - val tag_string - : std_ppcmds -> std_ppcmds - val tag_glob_tactic_expr - : glob_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_glob_atomic_tactic_expr - : glob_atomic_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_raw_tactic_expr - : raw_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_raw_atomic_tactic_expr - : raw_atomic_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_atomic_tactic_expr - : atomic_tactic_expr -> std_ppcmds -> std_ppcmds - end) -= struct - - open Taggers - - let keyword x = tag_keyword (str x) - let primitive x = tag_primitive (str x) - - let has_type (Val.Dyn (tag, x)) t = match Val.eq tag t with - | None -> false - | Some _ -> true - - let unbox : type a. Val.t -> a Val.typ -> a= fun (Val.Dyn (tag, x)) t -> - match Val.eq tag t with - | None -> assert false - | Some Refl -> x - - let rec pr_value lev v : std_ppcmds = - if has_type v Val.typ_list then - pr_sequence (fun x -> pr_value lev x) (unbox v Val.typ_list) - else if has_type v Val.typ_opt then - pr_opt_no_spc (fun x -> pr_value lev x) (unbox v Val.typ_opt) - else if has_type v Val.typ_pair then - let (v1, v2) = unbox v Val.typ_pair in - str "(" ++ pr_value lev v1 ++ str ", " ++ pr_value lev v2 ++ str ")" - else - let Val.Dyn (tag, x) = v in - let name = Val.repr tag 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_tag (Topwit wit) with - | Val.Base t -> - begin match Val.eq t tag with - | None -> default - | Some Refl -> Genprint.generic_top_print (in_gen (Topwit wit) x) - end - | _ -> default - - let pr_with_occurrences pr c = pr_with_occurrences pr keyword c - let pr_red_expr pr c = pr_red_expr pr keyword c - - let pr_may_eval test prc prlc pr2 pr3 = function - | ConstrEval (r,c) -> - hov 0 - (keyword "eval" ++ brk (1,1) ++ - pr_red_expr (prc,prlc,pr2,pr3) r ++ spc () ++ - keyword "in" ++ spc() ++ prc c) - | ConstrContext ((_,id),c) -> - hov 0 - (keyword "context" ++ spc () ++ pr_id id ++ spc () ++ - str "[ " ++ prlc c ++ str " ]") - | ConstrTypeOf c -> - hov 1 (keyword "type of" ++ spc() ++ prc c) - | ConstrTerm c when test c -> - h 0 (str "(" ++ prc c ++ str ")") - | ConstrTerm c -> - prc c - - let pr_may_eval a = - pr_may_eval (fun _ -> false) a - - let pr_arg pr x = spc () ++ pr x - - let pr_and_short_name pr (c,_) = pr c - - let pr_or_by_notation f = function - | AN v -> f v - | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc - - let pr_located pr (loc,x) = pr x - - let pr_evaluable_reference = function - | EvalVarRef id -> pr_id id - | EvalConstRef sp -> pr_global (Globnames.ConstRef sp) - - let pr_quantified_hypothesis = function - | AnonHyp n -> int n - | NamedHyp id -> pr_id id - - let pr_binding prc = function - | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c) - | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) - - let pr_bindings prc prlc = function - | ImplicitBindings l -> - brk (1,1) ++ keyword "with" ++ brk (1,1) ++ - hv 0 (prlist_with_sep spc prc l) - | ExplicitBindings l -> - brk (1,1) ++ keyword "with" ++ brk (1,1) ++ - hv 0 (prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l) - | NoBindings -> mt () - - let pr_bindings_no_with prc prlc = function - | ImplicitBindings l -> - brk (0,1) ++ - prlist_with_sep spc prc l - | ExplicitBindings l -> - brk (0,1) ++ - prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | NoBindings -> mt () - - let pr_clear_flag clear_flag pp x = - match clear_flag with - | Some false -> surround (pp x) - | Some true -> str ">" ++ pp x - | None -> pp x - - let pr_with_bindings prc prlc (c,bl) = - prc c ++ pr_bindings prc prlc bl - - let pr_with_bindings_arg prc prlc (clear_flag,c) = - pr_clear_flag clear_flag (pr_with_bindings prc prlc) c - - let pr_with_constr prc = function - | None -> mt () - | Some c -> spc () ++ hov 1 (keyword "with" ++ spc () ++ prc c) - - let pr_message_token prid = function - | MsgString s -> tag_string (qs s) - | MsgInt n -> int n - | MsgIdent id -> prid id - - let pr_fresh_ids = - prlist (fun s -> spc() ++ pr_or_var (fun s -> tag_string (qs s)) s) - - let with_evars ev s = if ev then "e" ^ s else s - - let rec tacarg_using_rule_token pr_gen = function - | [] -> [] - | TacTerm s :: l -> keyword s :: tacarg_using_rule_token pr_gen l - | TacNonTerm (_, (symb, arg), _) :: l -> - pr_gen symb arg :: tacarg_using_rule_token pr_gen l - - let pr_tacarg_using_rule pr_gen l = - let l = match l with - | TacTerm s :: l -> - (** 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 - | _ -> tacarg_using_rule_token pr_gen l - in - pr_sequence (fun x -> x) l - - let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l = - let name = - str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++ - str "@" ++ int i - in - let args = match l with - | [] -> mt () - | _ -> spc() ++ pr_sequence pr_gen l - in - str "<" ++ name ++ str ">" ++ args - - let rec pr_user_symbol = function - | Extend.Ulist1 tkn -> "ne_" ^ pr_user_symbol tkn ^ "_list" - | Extend.Ulist1sep (tkn, _) -> "ne_" ^ pr_user_symbol tkn ^ "_list" - | Extend.Ulist0 tkn -> pr_user_symbol tkn ^ "_list" - | Extend.Ulist0sep (tkn, _) -> pr_user_symbol tkn ^ "_list" - | Extend.Uopt tkn -> pr_user_symbol tkn ^ "_opt" - | Extend.Uentry tag -> - let ArgT.Any tag = tag in - ArgT.repr tag - | Extend.Uentryl (tkn, lvl) -> "tactic" ^ string_of_int lvl - - let pr_alias_key key = - try - let prods = (KNmap.find key !prnotation_tab).pptac_prods in - let rec pr = function - | TacTerm s -> primitive s - | TacNonTerm (_, symb, _) -> str (Printf.sprintf "(%s)" (pr_user_symbol symb)) - in - pr_sequence pr prods - with Not_found -> - KerName.print key - - let pr_alias_gen pr_gen lev key l = - try - let pp = KNmap.find key !prnotation_tab in - let rec pack prods args = match prods, args with - | [], [] -> [] - | TacTerm s :: prods, args -> TacTerm s :: pack prods args - | TacNonTerm (loc, symb, id) :: prods, arg :: args -> - TacNonTerm (loc, (symb, arg), id) :: pack prods args - | _ -> raise Not_found - in - let prods = pack pp.pptac_prods l in - let p = pr_tacarg_using_rule pr_gen prods in - if pp.pptac_level > lev then surround p else p - with Not_found -> - let pr arg = str "_" in - KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)" - - let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.ghost, arg)) - - let is_genarg tag wit = - let ArgT.Any tag = tag in - argument_type_eq (ArgumentType (ExtraArg tag)) wit - - let get_list : type l. l generic_argument -> l generic_argument list option = - function (GenArg (wit, arg)) -> match wit with - | Rawwit (ListArg wit) -> Some (List.map (in_gen (rawwit wit)) arg) - | Glbwit (ListArg wit) -> Some (List.map (in_gen (glbwit wit)) arg) - | _ -> None - - let get_opt : type l. l generic_argument -> l generic_argument option option = - function (GenArg (wit, arg)) -> match wit with - | Rawwit (OptArg wit) -> Some (Option.map (in_gen (rawwit wit)) arg) - | Glbwit (OptArg wit) -> Some (Option.map (in_gen (glbwit wit)) arg) - | _ -> None - - let rec pr_any_arg : type l. (_ -> l generic_argument -> std_ppcmds) -> _ -> l generic_argument -> std_ppcmds = - fun prtac symb arg -> match symb with - | Extend.Uentry tag when is_genarg tag (genarg_tag arg) -> prtac (1, Any) arg - | Extend.Ulist1 s | Extend.Ulist0 s -> - begin match get_list arg with - | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" - | Some l -> pr_sequence (pr_any_arg prtac s) l - end - | Extend.Ulist1sep (s, sep) | Extend.Ulist0sep (s, sep) -> - begin match get_list arg with - | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" - | Some l -> prlist_with_sep (fun () -> str sep) (pr_any_arg prtac s) l - end - | Extend.Uopt s -> - begin match get_opt arg with - | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" - | Some l -> pr_opt (pr_any_arg prtac s) l - end - | Extend.Uentry _ | Extend.Uentryl _ -> - str "ltac:(" ++ prtac (1, Any) arg ++ str ")" - - let rec pr_targ prtac symb arg = match symb with - | Extend.Uentry tag when is_genarg tag (ArgumentType wit_tactic) -> - prtac (1, Any) arg - | Extend.Uentryl (_, l) -> prtac (l, Any) arg - | _ -> - match arg with - | TacGeneric arg -> - let pr l arg = prtac l (TacGeneric arg) in - pr_any_arg pr symb arg - | _ -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" - - let pr_raw_extend_rec prc prlc prtac prpat = - pr_extend_gen (pr_farg prtac) - let pr_glob_extend_rec prc prlc prtac prpat = - pr_extend_gen (pr_farg prtac) - - let pr_raw_alias prc prlc prtac prpat lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args - let pr_glob_alias prc prlc prtac prpat lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args - - (**********************************************************************) - (* The tactic printer *) - - let strip_prod_binders_expr n ty = - let rec strip_ty acc n ty = - match ty with - Constrexpr.CProdN(_,bll,a) -> - let nb = - List.fold_left (fun i (nal,_,_) -> i + List.length nal) 0 bll in - let bll = List.map (fun (x, _, y) -> x, y) bll in - if nb >= n then (List.rev (bll@acc)), a - else strip_ty (bll@acc) (n-nb) a - | _ -> error "Cannot translate fix tactic: not enough products" in - strip_ty [] n ty - - let pr_ltac_or_var pr = function - | ArgArg x -> pr x - | ArgVar (loc,id) -> pr_with_comments loc (pr_id id) - - let pr_ltac_constant kn = - if !Flags.in_debugger then pr_kn kn - else try - pr_qualid (Nametab.shortest_qualid_of_tactic kn) - with Not_found -> (* local tactic not accessible anymore *) - str "<" ++ pr_kn kn ++ str ">" - - let pr_evaluable_reference_env env = function - | EvalVarRef id -> pr_id id - | EvalConstRef sp -> - Nametab.pr_global_env (Termops.vars_of_env env) (Globnames.ConstRef sp) - - let pr_esubst prc l = - let pr_qhyp = function - (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")" - | (_,NamedHyp id,c) -> - str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")" - in - prlist_with_sep spc pr_qhyp l - - let pr_bindings_gen for_ex prc prlc = function - | ImplicitBindings l -> - spc () ++ - hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++ - prlist_with_sep spc prc l) - | ExplicitBindings l -> - spc () ++ - hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++ - pr_esubst prlc l) - | NoBindings -> mt () - - let pr_bindings prc prlc = pr_bindings_gen false prc prlc - - let pr_with_bindings prc prlc (c,bl) = - hov 1 (prc c ++ pr_bindings prc prlc bl) - - let pr_as_disjunctive_ipat prc ipatl = - keyword "as" ++ spc () ++ - pr_or_var (fun (loc,p) -> Miscprint.pr_or_and_intro_pattern prc p) ipatl - - let pr_eqn_ipat (_,ipat) = keyword "eqn:" ++ Miscprint.pr_intro_pattern_naming ipat - - let pr_with_induction_names prc = function - | None, None -> mt () - | Some eqpat, None -> hov 1 (pr_eqn_ipat eqpat) - | None, Some ipat -> hov 1 (pr_as_disjunctive_ipat prc ipat) - | Some eqpat, Some ipat -> - hov 1 (pr_as_disjunctive_ipat prc ipat ++ spc () ++ pr_eqn_ipat eqpat) - - let pr_as_intro_pattern prc ipat = - spc () ++ hov 1 (keyword "as" ++ spc () ++ Miscprint.pr_intro_pattern prc ipat) - - let pr_with_inversion_names prc = function - | None -> mt () - | Some ipat -> pr_as_disjunctive_ipat prc ipat - - let pr_as_ipat prc = function - | None -> mt () - | Some ipat -> pr_as_intro_pattern prc ipat - - let pr_as_name = function - | Anonymous -> mt () - | Name id -> spc () ++ keyword "as" ++ spc () ++ pr_lident (Loc.ghost,id) - - let pr_pose_as_style prc na c = - spc() ++ prc c ++ pr_as_name na - - let pr_pose prc prlc na c = match na with - | Anonymous -> spc() ++ prc c - | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c) - - let pr_assertion prc prdc _prlc ipat c = match ipat with - (* Use this "optimisation" or use only the general case ? - | IntroIdentifier id -> - spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c) - *) - | ipat -> - spc() ++ prc c ++ pr_as_ipat prdc ipat - - let pr_assumption prc prdc prlc ipat c = match ipat with - (* Use this "optimisation" or use only the general case ?*) - (* it seems that this "optimisation" is somehow more natural *) - | Some (_,IntroNaming (IntroIdentifier id)) -> - spc() ++ surround (pr_id id ++ str " :" ++ spc() ++ prlc c) - | ipat -> - spc() ++ prc c ++ pr_as_ipat prdc ipat - - let pr_by_tactic prt = function - | Some tac -> keyword "by" ++ spc () ++ prt tac - | None -> mt() - - let pr_hyp_location pr_id = function - | occs, InHyp -> pr_with_occurrences pr_id occs - | occs, InHypTypeOnly -> - pr_with_occurrences (fun id -> - str "(" ++ keyword "type of" ++ spc () ++ pr_id id ++ str ")" - ) occs - | occs, InHypValueOnly -> - pr_with_occurrences (fun id -> - str "(" ++ keyword "value of" ++ spc () ++ pr_id id ++ str ")" - ) occs - - let pr_in pp = hov 0 (keyword "in" ++ pp) - - let pr_simple_hyp_clause pr_id = function - | [] -> mt () - | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l) - - let pr_in_hyp_as prc pr_id = function - | None -> mt () - | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat - - let pr_in_clause pr_id = function - | { onhyps=None; concl_occs=NoOccurrences } -> - (str "* |-") - | { onhyps=None; concl_occs=occs } -> - (pr_with_occurrences (fun () -> str "*") (occs,())) - | { onhyps=Some l; concl_occs=NoOccurrences } -> - prlist_with_sep (fun () -> str ", ") (pr_hyp_location pr_id) l - | { onhyps=Some l; concl_occs=occs } -> - let pr_occs = pr_with_occurrences (fun () -> str" |- *") (occs,()) in - (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs) - - let pr_clauses default_is_concl pr_id = function - | { onhyps=Some []; concl_occs=occs } - when (match default_is_concl with Some true -> true | _ -> false) -> - pr_with_occurrences mt (occs,()) - | { onhyps=None; concl_occs=AllOccurrences } - when (match default_is_concl with Some false -> true | _ -> false) -> mt () - | { onhyps=None; concl_occs=NoOccurrences } -> - pr_in (str " * |-") - | { onhyps=None; concl_occs=occs } -> - pr_in (pr_with_occurrences (fun () -> str " *") (occs,())) - | { onhyps=Some l; concl_occs=occs } -> - let pr_occs = match occs with - | NoOccurrences -> mt () - | _ -> pr_with_occurrences (fun () -> str" |- *") (occs,()) - in - pr_in - (prlist_with_sep (fun () -> str",") - (fun id -> spc () ++ pr_hyp_location pr_id id) l ++ pr_occs) - - let pr_orient b = if b then mt () else str "<- " - - let pr_multi = function - | Precisely 1 -> mt () - | Precisely n -> int n ++ str "!" - | UpTo n -> int n ++ str "?" - | RepeatStar -> str "?" - | RepeatPlus -> str "!" - - let pr_core_destruction_arg prc prlc = function - | ElimOnConstr c -> pr_with_bindings prc prlc c - | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id) - | ElimOnAnonHyp n -> int n - - let pr_destruction_arg prc prlc (clear_flag,h) = - pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h - - let pr_inversion_kind = function - | SimpleInversion -> primitive "simple inversion" - | FullInversion -> primitive "inversion" - | FullInversionClear -> primitive "inversion_clear" - - let pr_range_selector (i, j) = - if Int.equal i j then int i - else int i ++ str "-" ++ int j - - let pr_goal_selector = function - | SelectNth i -> int i ++ str ":" - | SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ - str "]" ++ str ":" - | SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" - | SelectAll -> str "all" ++ str ":" - - let pr_lazy = function - | General -> keyword "multi" - | Select -> keyword "lazy" - | Once -> mt () - - let pr_match_pattern pr_pat = function - | Term a -> pr_pat a - | Subterm (b,None,a) -> - (** ppedrot: we don't make difference between [appcontext] and [context] - anymore, and the interpretation is governed by a flag instead. *) - keyword "context" ++ str" [ " ++ pr_pat a ++ str " ]" - | Subterm (b,Some id,a) -> - keyword "context" ++ spc () ++ pr_id id ++ str "[ " ++ pr_pat a ++ str " ]" - - let pr_match_hyps pr_pat = function - | Hyp (nal,mp) -> - pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp - | Def (nal,mv,mp) -> - pr_lname nal ++ str ":=" ++ pr_match_pattern pr_pat mv - ++ str ":" ++ pr_match_pattern pr_pat mp - - let pr_match_rule m pr pr_pat = function - | Pat ([],mp,t) when m -> - pr_match_pattern pr_pat mp ++ - spc () ++ str "=>" ++ brk (1,4) ++ pr t - (* - | Pat (rl,mp,t) -> - hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl ++ - (if rl <> [] then spc () else mt ()) ++ - hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ - str "=>" ++ brk (1,4) ++ pr t)) - *) - | Pat (rl,mp,t) -> - hov 0 ( - hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl) ++ - (if not (List.is_empty rl) then spc () else mt ()) ++ - hov 0 ( - str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ - str "=>" ++ brk (1,4) ++ pr t)) - | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t - - let pr_funvar = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id - - let pr_let_clause k pr (id,(bl,t)) = - hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++ - str " :=" ++ brk (1,1) ++ pr (TacArg (Loc.ghost,t))) - - let pr_let_clauses recflag pr = function - | hd::tl -> - hv 0 - (pr_let_clause (if recflag then "let rec" else "let") pr hd ++ - prlist (fun t -> spc () ++ pr_let_clause "with" pr t) tl) - | [] -> anomaly (Pp.str "LetIn must declare at least one binding") - - let pr_seq_body pr tl = - hv 0 (str "[ " ++ - prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ - str " ]") - - let pr_dispatch pr tl = - hv 0 (str "[>" ++ - prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ - str " ]") - - let pr_opt_tactic pr = function - | TacId [] -> mt () - | t -> pr t - - let pr_tac_extend_gen pr tf tm tl = - prvect_with_sep mt (fun t -> pr t ++ spc () ++ str "| ") tf ++ - pr_opt_tactic pr tm ++ str ".." ++ - prvect_with_sep mt (fun t -> spc () ++ str "| " ++ pr t) tl - - let pr_then_gen pr tf tm tl = - hv 0 (str "[ " ++ - pr_tac_extend_gen pr tf tm tl ++ - str " ]") - - let pr_tac_extend pr tf tm tl = - hv 0 (str "[>" ++ - pr_tac_extend_gen pr tf tm tl ++ - str " ]") - - let pr_hintbases = function - | None -> keyword "with" ++ str" *" - | Some [] -> mt () - | Some l -> hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l) - - let pr_auto_using prc = function - | [] -> mt () - | l -> hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l) - - let pr_then () = str ";" - - let ltop = (5,E) - let lseq = 4 - let ltactical = 3 - let lorelse = 2 - let llet = 5 - let lfun = 5 - let lcomplete = 1 - let labstract = 3 - let lmatch = 1 - let latom = 0 - let lcall = 1 - let leval = 1 - let ltatom = 1 - let linfo = 5 - - let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq - - (** A printer for tactics that polymorphically works on the three - "raw", "glob" and "typed" levels *) - - type 'a printer = { - pr_tactic : tolerability -> 'tacexpr -> std_ppcmds; - pr_constr : 'trm -> std_ppcmds; - pr_lconstr : 'trm -> std_ppcmds; - pr_dconstr : 'dtrm -> std_ppcmds; - pr_pattern : 'pat -> std_ppcmds; - pr_lpattern : 'pat -> std_ppcmds; - pr_constant : 'cst -> std_ppcmds; - pr_reference : 'ref -> std_ppcmds; - pr_name : 'nam -> std_ppcmds; - pr_generic : 'lev generic_argument -> 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 = < - term :'trm; - dterm :'dtrm; - pattern :'pat; - constant :'cst; - reference :'ref; - name :'nam; - tacexpr :'tacexpr; - level :'lev - > - - 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 - 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 (false,[]) -> primitive "intros" - | TacIntroPattern (true,[]) -> primitive "eintros" - | t -> str "(" ++ pr_atom1 t ++ str ")" - ) - - (* Main tactic printer *) - and pr_atom1 a = tag_atom a (match a with - (* Basic tactics *) - | TacIntroPattern (ev,[]) as t -> - pr_atom0 t - | TacIntroPattern (ev,(_::_ as p)) -> - hov 1 (primitive (if ev then "eintros" else "intros") ++ spc () ++ - prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p) - | 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_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) 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 (h,ids,cl) -> - pr_destruction_arg pr.pr_dconstr pr.pr_dconstr h ++ - pr_non_empty_arg (pr_with_induction_names pr.pr_dconstr) ids ++ - pr_opt (pr_clauses None pr.pr_name) cl) l ++ - pr_opt pr_eliminator el - ) - - (* 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,tac) -> - 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 - ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac - ) - | TacInversion (DepInversion (k,c,ids),hyp) -> - hov 1 ( - primitive "dependent " ++ pr_inversion_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_inversion_kind k ++ spc () - ++ pr_quantified_hypothesis hyp - ++ pr_non_empty_arg (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 - - 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 - | TacAbstract (t,None) -> - keyword "abstract " ++ pr_tac (labstract,L) t, labstract - | TacAbstract (t,Some s) -> - hov 0 ( - keyword "abstract" - ++ str" (" ++ pr_tac (labstract,L) t ++ str")" ++ spc () - ++ keyword "using" ++ spc () ++ pr_id s), - labstract - | TacLetIn (recflag,llc,u) -> - let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in - v 0 - (hv 0 ( - pr_let_clauses recflag (pr_tac ltop) llc - ++ spc () ++ keyword "in" - ) ++ fnl () ++ pr_tac (llet,E) u), - llet - | TacMatch (lz,t,lrul) -> - hov 0 ( - pr_lazy lz ++ keyword "match" ++ spc () - ++ pr_tac ltop t ++ spc () ++ keyword "with" - ++ prlist (fun r -> - fnl () ++ str "| " - ++ pr_match_rule true (pr_tac ltop) pr.pr_lpattern r - ) lrul - ++ fnl() ++ keyword "end"), - lmatch - | TacMatchGoal (lz,lr,lrul) -> - hov 0 ( - pr_lazy lz - ++ keyword (if lr then "match reverse goal with" else "match goal with") - ++ prlist (fun r -> - fnl () ++ str "| " - ++ pr_match_rule false (pr_tac ltop) pr.pr_lpattern r - ) lrul ++ fnl() ++ keyword "end"), - lmatch - | TacFun (lvar,body) -> - hov 2 ( - keyword "fun" - ++ prlist pr_funvar lvar ++ str " =>" ++ spc () - ++ pr_tac (lfun,E) body), - lfun - | TacThens (t,tl) -> - hov 1 ( - pr_tac (lseq,E) t ++ pr_then () ++ spc () - ++ pr_seq_body (pr_opt_tactic (pr_tac ltop)) tl), - lseq - | TacThen (t1,t2) -> - hov 1 ( - pr_tac (lseq,E) t1 ++ pr_then () ++ spc () - ++ pr_tac (lseq,L) t2), - lseq - | TacDispatch tl -> - pr_dispatch (pr_tac ltop) tl, lseq - | TacExtendTac (tf,t,tr) -> - pr_tac_extend (pr_tac ltop) tf t tr , lseq - | TacThens3parts (t1,tf,t2,tl) -> - hov 1 ( - pr_tac (lseq,E) t1 ++ pr_then () ++ spc () - ++ pr_then_gen (pr_tac ltop) tf t2 tl), - lseq - | TacTry t -> - hov 1 ( - keyword "try" ++ spc () ++ pr_tac (ltactical,E) t), - ltactical - | TacDo (n,t) -> - hov 1 ( - str "do" ++ spc () - ++ pr_or_var int n ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacTimeout (n,t) -> - hov 1 ( - keyword "timeout " - ++ pr_or_var int n ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacTime (s,t) -> - hov 1 ( - keyword "time" - ++ pr_opt str s ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacRepeat t -> - hov 1 ( - keyword "repeat" ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacProgress t -> - hov 1 ( - keyword "progress" ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacShowHyps t -> - hov 1 ( - keyword "infoH" ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacInfo t -> - hov 1 ( - keyword "info" ++ spc () - ++ pr_tac (ltactical,E) t), - linfo - | TacOr (t1,t2) -> - hov 1 ( - pr_tac (lorelse,L) t1 ++ spc () - ++ str "+" ++ brk (1,1) - ++ pr_tac (lorelse,E) t2), - lorelse - | TacOnce t -> - hov 1 ( - keyword "once" ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacExactlyOnce t -> - hov 1 ( - keyword "exactly_once" ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacIfThenCatch (t,tt,te) -> - hov 1 ( - str"tryif" ++ spc() ++ pr_tac (ltactical,E) t ++ brk(1,1) ++ - str"then" ++ spc() ++ pr_tac (ltactical,E) tt ++ brk(1,1) ++ - str"else" ++ spc() ++ pr_tac (ltactical,E) te ++ brk(1,1)), - ltactical - | TacOrelse (t1,t2) -> - hov 1 ( - pr_tac (lorelse,L) t1 ++ spc () - ++ str "||" ++ brk (1,1) - ++ pr_tac (lorelse,E) t2), - lorelse - | TacFail (g,n,l) -> - let arg = - match n with - | ArgArg 0 -> mt () - | _ -> pr_arg (pr_or_var int) n - in - let name = - match g with - | TacGlobal -> keyword "gfail" - | TacLocal -> keyword "fail" - in - hov 1 ( - name ++ arg - ++ prlist (pr_arg (pr_message_token pr.pr_name)) l), - latom - | TacFirst tl -> - keyword "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet - | TacSolve tl -> - keyword "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet - | TacComplete t -> - pr_tac (lcomplete,E) t, lcomplete - | TacSelect (s, tac) -> pr_goal_selector s ++ spc () ++ pr_tac ltop tac, latom - | 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_atom pr strip_prod_binders tag_atom t)), ltatom - | TacArg(_,Tacexp e) -> - pr.pr_tactic (latom,E) e, latom - | TacArg(_,ConstrMayEval (ConstrTerm c)) -> - keyword "constr:" ++ pr.pr_constr c, latom - | TacArg(_,ConstrMayEval c) -> - pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval - | TacArg(_,TacFreshId l) -> - primitive "fresh" ++ pr_fresh_ids l, latom - | TacArg(_,TacGeneric arg) -> - pr.pr_generic arg, latom - | TacArg(_,TacCall(loc,f,[])) -> - pr.pr_reference f, latom - | TacArg(_,TacCall(loc,f,l)) -> - pr_with_comments loc (hov 1 ( - pr.pr_reference f ++ spc () - ++ prlist_with_sep spc pr_tacarg l)), - lcall - | TacArg (_,a) -> - pr_tacarg a, latom - | 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 l), latom - ) - in - if prec_less prec inherited then strm - else str"(" ++ strm ++ str")" - - and pr_tacarg = function - | Reference r -> - pr.pr_reference r - | ConstrMayEval c -> - pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c - | TacFreshId l -> - keyword "fresh" ++ pr_fresh_ids l - | TacPretype c -> - keyword "type_term" ++ pr.pr_constr c - | TacNumgoals -> - keyword "numgoals" - | (TacCall _|Tacexp _ | TacGeneric _) as a -> - hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.ghost,a)))) - - in pr_tac - - let strip_prod_binders_glob_constr n (ty,_) = - let rec strip_ty acc n ty = - if Int.equal n 0 then (List.rev acc, (ty,None)) else - match ty with - Glob_term.GProd(loc,na,Explicit,a,b) -> - strip_ty (([Loc.ghost,na],(a,None))::acc) (n-1) b - | _ -> error "Cannot translate fix tactic: not enough products" in - strip_ty [] n ty - - let raw_printers = - (strip_prod_binders_expr) - - let rec pr_raw_tactic_level n (t:raw_tactic_expr) = - let pr = { - pr_tactic = pr_raw_tactic_level; - pr_constr = pr_constr_expr; - pr_dconstr = pr_constr_expr; - pr_lconstr = pr_lconstr_expr; - pr_pattern = pr_constr_pattern_expr; - pr_lpattern = pr_lconstr_pattern_expr; - pr_constant = pr_or_by_notation pr_reference; - pr_reference = pr_reference; - pr_name = pr_lident; - pr_generic = (fun arg -> Pputils.pr_raw_generic (Global.env ()) arg); - 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 - pr raw_printers - tag_raw_atomic_tactic_expr tag_raw_tactic_expr - n t - - let pr_raw_tactic = pr_raw_tactic_level ltop - - let pr_and_constr_expr pr (c,_) = pr c - - let pr_pat_and_constr_expr pr (_,(c,_),_) = pr c - - let pr_glob_tactic_level env n t = - let glob_printers = - (strip_prod_binders_glob_constr) - in - let rec prtac n (t:glob_tactic_expr) = - let pr = { - pr_tactic = prtac; - pr_constr = 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); - pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env); - 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 = (fun arg -> Pputils.pr_glb_generic (Global.env ()) arg); - 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 - (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)); - } in - make_pr_tac - pr glob_printers - tag_glob_atomic_tactic_expr tag_glob_tactic_expr - n t - in - prtac n t - - let pr_glob_tactic env = pr_glob_tactic_level env ltop - - let strip_prod_binders_constr n ty = - let rec strip_ty acc n ty = - if n=0 then (List.rev acc, ty) else - match Term.kind_of_term ty with - Term.Prod(na,a,b) -> - strip_ty (([Loc.ghost,na],a)::acc) (n-1) b - | _ -> error "Cannot translate fix tactic: not enough products" in - strip_ty [] n ty - - let pr_atomic_tactic_level env n t = - let prtac n (t:atomic_tactic_expr) = - let pr = { - 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; - pr_pattern = pr_constr_pattern_env env Evd.empty; - pr_lpattern = pr_lconstr_pattern_env env Evd.empty; - pr_constant = pr_evaluable_reference_env env; - pr_reference = pr_located pr_ltac_constant; - pr_name = pr_id; - (** Those are not used by the atomic printer *) - pr_generic = (fun _ -> assert false); - pr_extend = (fun _ _ _ -> assert false); - pr_alias = (fun _ _ _ -> assert false); - } - in - pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t - in - prtac n t - - let pr_raw_generic = Pputils.pr_raw_generic - - let pr_glb_generic = Pputils.pr_glb_generic - - 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_alias pr lev key args = - pr_alias_gen (fun _ arg -> pr arg) lev key args - - let pr_extend pr lev ml args = - pr_extend_gen pr lev ml args - - let pr_atomic_tactic env = pr_atomic_tactic_level env ltop - -end - -module Tag = -struct - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["tactic"; "keyword"] - - let primitive = - let style = Terminal.make ~fg_color:`LIGHT_GREEN () in - Ppstyle.make ~style ["tactic"; "primitive"] - - let string = - let style = Terminal.make ~fg_color:`LIGHT_RED () in - Ppstyle.make ~style ["tactic"; "string"] - -end - -include Make (Ppconstr) (struct - let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s - let do_not_tag _ x = x - let tag_keyword = tag Tag.keyword - let tag_primitive = tag Tag.primitive - let tag_string = tag Tag.string - let tag_glob_tactic_expr = do_not_tag - 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_atomic_tactic_expr = do_not_tag -end) - -let declare_extra_genarg_pprule wit - (f : 'a raw_extra_genarg_printer) - (g : 'b glob_extra_genarg_printer) - (h : 'c extra_genarg_printer) = - begin match wit with - | ExtraArg s -> () - | _ -> error "Can declare a pretty-printing rule only for extra argument types." - end; - let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in - let g x = - let env = Global.env () in - g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x - in - let h x = - let env = Global.env () in - h (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) (fun _ _ -> str "") x - in - Genprint.register_print0 wit f g h - -(** Registering *) - -let run_delayed c = - Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma } - -let run_delayed_destruction_arg = function (* HH: Using Evd.empty looks suspicious *) - | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (fst (run_delayed g)) - | clear_flag,ElimOnAnonHyp n as x -> x - | clear_flag,ElimOnIdent id as x -> x - -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 wit_int_or_var - (pr_or_var int) (pr_or_var int) int; - Genprint.register_print0 wit_ref - pr_reference (pr_or_var (pr_located pr_global)) pr_global; - Genprint.register_print0 wit_ident - pr_id pr_id pr_id; - Genprint.register_print0 wit_var - (pr_located pr_id) (pr_located pr_id) pr_id; - Genprint.register_print0 - 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 (fst (run_delayed c)))); - Genprint.register_print0 - wit_clause_dft_concl - (pr_clauses (Some true) pr_lident) - (pr_clauses (Some true) pr_lident) - (pr_clauses (Some true) (fun id -> pr_lident (Loc.ghost,id))) - ; - Genprint.register_print0 - wit_constr - Ppconstr.pr_constr_expr - (fun (c, _) -> Printer.pr_glob_constr c) - Printer.pr_constr - ; - Genprint.register_print0 - wit_uconstr - Ppconstr.pr_constr_expr - (fun (c,_) -> Printer.pr_glob_constr c) - Printer.pr_closed_glob - ; - Genprint.register_print0 - wit_open_constr - Ppconstr.pr_constr_expr - (fun (c, _) -> Printer.pr_glob_constr c) - Printer.pr_constr - ; - Genprint.register_print0 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_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_red_expr (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern)); - Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; - Genprint.register_print0 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 it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it))); - Genprint.register_print0 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 it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it))); - Genprint.register_print0 Tacarg.wit_destruction_arg - (pr_destruction_arg pr_constr_expr pr_lconstr_expr) - (pr_destruction_arg (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun it -> pr_destruction_arg pr_constr pr_lconstr (run_delayed_destruction_arg 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; - Genprint.register_print0 Stdarg.wit_pre_ident str str str; - Genprint.register_print0 Stdarg.wit_string pr_string pr_string pr_string - -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 - open Ppannotation - open Genarg - let do_not_tag _ x = x - let tag e s = Pp.tag (Pp.Tag.inj e tag) s - let tag_keyword = tag AKeyword - let tag_primitive = tag AKeyword - let tag_string = do_not_tag () - let tag_glob_tactic_expr e = tag (AGlbGenArg (in_gen (glbwit wit_ltac) e)) - let tag_glob_atomic_tactic_expr = do_not_tag - let tag_raw_tactic_expr e = tag (ARawGenArg (in_gen (rawwit wit_ltac) e)) - let tag_raw_atomic_tactic_expr = do_not_tag - let tag_atomic_tactic_expr = do_not_tag - end) - -end diff --git a/ltac/pptactic.mli b/ltac/pptactic.mli deleted file mode 100644 index 86e3ea5484..0000000000 --- a/ltac/pptactic.mli +++ /dev/null @@ -1,67 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds - -type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> std_ppcmds) -> - (glob_constr_and_expr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds - -type 'a extra_genarg_printer = - (Term.constr -> std_ppcmds) -> - (Term.constr -> std_ppcmds) -> - (tolerability -> Val.t -> std_ppcmds) -> - 'a -> std_ppcmds - -val declare_extra_genarg_pprule : - ('a, 'b, 'c) genarg_type -> - 'a raw_extra_genarg_printer -> - 'b glob_extra_genarg_printer -> - 'c extra_genarg_printer -> unit - -type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list - -type pp_tactic = { - pptac_level : int; - pptac_prods : grammar_terminals; -} - -val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit - -(** The default pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as raw strings. *) -include Pptacticsig.Pp - -(** The rich pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as annotated strings. The annotations can be - retrieved using {!RichPp.rich_pp}. Their definitions are - located in {!Ppannotation.t}. *) -module Richpp : Pptacticsig.Pp - -val ltop : tolerability diff --git a/ltac/pptacticsig.mli b/ltac/pptacticsig.mli deleted file mode 100644 index 74ddd377ad..0000000000 --- a/ltac/pptacticsig.mli +++ /dev/null @@ -1,81 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds - val pr_red_expr : - ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> - ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds - val pr_may_eval : - ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds - - val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds - - val pr_in_clause : - ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds - - val pr_clauses : bool option -> - ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds - - val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds - - val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds - - val pr_raw_extend: env -> int -> - ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds - - val pr_glob_extend: env -> int -> - ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds - - val pr_extend : - (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds - - val pr_alias_key : Names.KerName.t -> std_ppcmds - - val pr_alias : (Val.t -> std_ppcmds) -> - int -> Names.KerName.t -> Val.t list -> std_ppcmds - - val pr_alias_key : Names.KerName.t -> std_ppcmds - - val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds - - val pr_raw_tactic : raw_tactic_expr -> std_ppcmds - - val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds - - val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds - - val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds - - val pr_hintbases : string list option -> std_ppcmds - - val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds - - val pr_bindings : - ('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 - - val pr_value : tolerability -> Val.t -> std_ppcmds - -end diff --git a/ltac/profile_ltac.ml b/ltac/profile_ltac.ml deleted file mode 100644 index 2514ededb0..0000000000 --- a/ltac/profile_ltac.ml +++ /dev/null @@ -1,420 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* strbrk "Ltac Profiler cannot yet handle backtracking \ - into multi-success tactics; profiling results may be wildly inaccurate.") - -let warn_encountered_multi_success_backtracking () = - if !encountered_multi_success_backtracking then - warn_profile_backtracking () - -let encounter_multi_success_backtracking () = - if not !encountered_multi_success_backtracking - then begin - encountered_multi_success_backtracking := true; - warn_encountered_multi_success_backtracking () - end - - -(* *************** tree data structure for profiling ****************** *) - -type treenode = { - name : M.key; - total : float; - local : float; - ncalls : int; - max_total : float; - children : treenode M.t -} - -let empty_treenode name = { - name; - total = 0.0; - local = 0.0; - ncalls = 0; - max_total = 0.0; - children = M.empty; -} - -let root = "root" - -module Local = Summary.Local - -let stack = Local.ref ~name:"LtacProf-stack" [empty_treenode root] - -let reset_profile_tmp () = - Local.(stack := [empty_treenode root]); - encountered_multi_success_backtracking := false - -(* ************** XML Serialization ********************* *) - -let rec of_ltacprof_tactic (name, t) = - assert (String.equal name t.name); - let open Xml_datatype in - let total = string_of_float t.total in - let local = string_of_float t.local in - let ncalls = string_of_int t.ncalls in - let max_total = string_of_float t.max_total in - let children = List.map of_ltacprof_tactic (M.bindings t.children) in - Element ("ltacprof_tactic", - [ ("name", name); ("total",total); ("local",local); - ("ncalls",ncalls); ("max_total",max_total)], - children) - -let of_ltacprof_results t = - let open Xml_datatype in - assert(String.equal t.name root); - let children = List.map of_ltacprof_tactic (M.bindings t.children) in - Element ("ltacprof", [("total_time", string_of_float t.total)], children) - -let rec to_ltacprof_tactic m xml = - let open Xml_datatype in - match xml with - | Element ("ltacprof_tactic", - [("name", name); ("total",total); ("local",local); - ("ncalls",ncalls); ("max_total",max_total)], xs) -> - let node = { - name; - total = float_of_string total; - local = float_of_string local; - ncalls = int_of_string ncalls; - max_total = float_of_string max_total; - children = List.fold_left to_ltacprof_tactic M.empty xs; - } in - M.add name node m - | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof_tactic XML") - -let to_ltacprof_results xml = - let open Xml_datatype in - match xml with - | Element ("ltacprof", [("total_time", t)], xs) -> - { name = root; - total = float_of_string t; - ncalls = 0; - max_total = 0.0; - local = 0.0; - children = List.fold_left to_ltacprof_tactic M.empty xs } - | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof XML") - -let feedback_results results = - Feedback.(feedback - (Custom (Loc.dummy_loc, "ltacprof_results", of_ltacprof_results results))) - -(* ************** pretty printing ************************************* *) - -let format_sec x = (Printf.sprintf "%.3fs" x) -let format_ratio x = (Printf.sprintf "%.1f%%" (100. *. x)) -let padl n s = ws (max 0 (n - utf8_length s)) ++ str s -let padr n s = str s ++ ws (max 0 (n - utf8_length s)) -let padr_with c n s = - let ulength = utf8_length s in - str (utf8_sub s 0 n) ++ str (String.make (max 0 (n - ulength)) c) - -let rec list_iter_is_last f = function - | [] -> [] - | [x] -> [f true x] - | x :: xs -> f false x :: list_iter_is_last f xs - -let header = - str " tactic local total calls max " ++ - fnl () ++ - str "────────────────────────────────────────┴──────┴──────┴───────┴─────────┘" ++ - fnl () - -let rec print_node ~filter all_total indent prefix (s, e) = - h 0 ( - padr_with '-' 40 (prefix ^ s ^ " ") - ++ padl 7 (format_ratio (e.local /. all_total)) - ++ padl 7 (format_ratio (e.total /. all_total)) - ++ padl 8 (string_of_int e.ncalls) - ++ padl 10 (format_sec (e.max_total)) - ) ++ - fnl () ++ - print_table ~filter all_total indent false e.children - -and print_table ~filter all_total indent first_level table = - let fold _ n l = - let s, total = n.name, n.total in - if filter s total then (s, n) :: l else l in - let ls = M.fold fold table [] in - match ls with - | [s, n] when not first_level -> - v 0 (print_node ~filter all_total indent (indent ^ "└") (s, n)) - | _ -> - let ls = - List.sort (fun (_, { total = s1 }) (_, { total = s2}) -> - compare s2 s1) ls in - let iter is_last = - let sep0 = if first_level then "" else if is_last then " " else " │" in - let sep1 = if first_level then "─" else if is_last then " └─" else " ├─" in - print_node ~filter all_total (indent ^ sep0) (indent ^ sep1) - in - prlist (fun pr -> pr) (list_iter_is_last iter ls) - -let to_string ~filter ?(cutoff=0.0) node = - let tree = node.children in - let all_total = M.fold (fun _ { total } a -> total +. a) node.children 0.0 in - let flat_tree = - let global = ref M.empty in - let find_tactic tname l = - try M.find tname !global - with Not_found -> - let e = empty_treenode tname in - global := M.add tname e !global; - e in - let add_tactic tname stats = global := M.add tname stats !global in - let sum_stats add_total - { name; total = t1; local = l1; ncalls = n1; max_total = m1 } - { total = t2; local = l2; ncalls = n2; max_total = m2 } = { - name; - total = if add_total then t1 +. t2 else t1; - local = l1 +. l2; - ncalls = n1 + n2; - max_total = if add_total then max m1 m2 else m1; - children = M.empty; - } in - let rec cumulate table = - let iter _ ({ name; children } as statistics) = - if filter name then begin - let stats' = find_tactic name global in - add_tactic name (sum_stats true stats' statistics); - end; - cumulate children - in - M.iter iter table - in - cumulate tree; - !global - in - warn_encountered_multi_success_backtracking (); - let filter s n = filter s && (all_total <= 0.0 || n /. all_total >= cutoff /. 100.0) in - let msg = - h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++ - fnl () ++ - fnl () ++ - header ++ - print_table ~filter all_total "" true flat_tree ++ - fnl () ++ - header ++ - print_table ~filter all_total "" true tree - in - msg - -(* ******************** profiling code ************************************** *) - -let get_child name node = - try M.find name node.children - with Not_found -> empty_treenode name - -let time () = - let times = Unix.times () in - times.Unix.tms_utime +. times.Unix.tms_stime - -let string_of_call ck = - let s = - string_of_ppcmds - (match ck with - | Tacexpr.LtacNotationCall s -> Pptactic.pr_alias_key s - | Tacexpr.LtacNameCall cst -> Pptactic.pr_ltac_constant cst - | Tacexpr.LtacVarCall (id, t) -> Nameops.pr_id id - | Tacexpr.LtacAtomCall te -> - (Pptactic.pr_glob_tactic (Global.env ()) - (Tacexpr.TacAtom (Loc.ghost, te))) - | Tacexpr.LtacConstrInterp (c, _) -> - pr_glob_constr_env (Global.env ()) c - | Tacexpr.LtacMLCall te -> - (Pptactic.pr_glob_tactic (Global.env ()) - te) - ) in - for i = 0 to String.length s - 1 do if s.[i] = '\n' then s.[i] <- ' ' done; - let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in - CString.strip s - -let rec merge_sub_tree name tree acc = - try - let t = M.find name acc in - let t = { - name; - total = t.total +. tree.total; - ncalls = t.ncalls + tree.ncalls; - local = t.local +. tree.local; - max_total = max t.max_total tree.max_total; - children = M.fold merge_sub_tree tree.children t.children; - } in - M.add name t acc - with Not_found -> M.add name tree acc - -let merge_roots ?(disjoint=true) t1 t2 = - assert(String.equal t1.name t2.name); - { name = t1.name; - ncalls = t1.ncalls + t2.ncalls; - local = if disjoint then t1.local +. t2.local else t1.local; - total = if disjoint then t1.total +. t2.total else t1.total; - max_total = if disjoint then max t1.max_total t2.max_total else t1.max_total; - children = - M.fold merge_sub_tree t2.children t1.children } - -let rec find_in_stack what acc = function - | [] -> None - | { name } as x :: rest when String.equal name what -> Some(acc, x, rest) - | { name } as x :: rest -> find_in_stack what (x :: acc) rest - -let exit_tactic start_time c = - let diff = time () -. start_time in - match Local.(!stack) with - | [] | [_] -> - (* oops, our stack is invalid *) - encounter_multi_success_backtracking (); - reset_profile_tmp () - | node :: (parent :: rest as full_stack) -> - let name = string_of_call c in - if not (String.equal name node.name) then - (* oops, our stack is invalid *) - encounter_multi_success_backtracking (); - let node = { node with - total = node.total +. diff; - local = node.local +. diff; - ncalls = node.ncalls + 1; - max_total = max node.max_total diff; - } in - (* updating the stack *) - let parent = - match find_in_stack node.name [] full_stack with - | None -> - (* no rec-call, we graft the subtree *) - let parent = { parent with - local = parent.local -. diff; - children = M.add node.name node parent.children } in - Local.(stack := parent :: rest); - parent - | Some(to_update, self, rest) -> - (* we coalesce the rec-call and update the lower stack *) - let self = merge_roots ~disjoint:false self node in - let updated_stack = - List.fold_left (fun s x -> - (try M.find x.name (List.hd s).children - with Not_found -> x) :: s) (self :: rest) to_update in - Local.(stack := updated_stack); - List.hd Local.(!stack) - in - (* Calls are over, we reset the stack and send back data *) - if rest == [] && get_profiling () then begin - assert(String.equal root parent.name); - reset_profile_tmp (); - feedback_results parent - end - -let tclFINALLY tac (finally : unit Proofview.tactic) = - let open Proofview.Notations in - Proofview.tclIFCATCH - tac - (fun v -> finally <*> Proofview.tclUNIT v) - (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn) - -let do_profile s call_trace tac = - let open Proofview.Notations in - Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> - if !is_profiling then - match call_trace, Local.(!stack) with - | (_, c) :: _, parent :: rest -> - let name = string_of_call c in - let node = get_child name parent in - Local.(stack := node :: parent :: rest); - Some (time ()) - | _ :: _, [] -> assert false - | _ -> None - else None)) >>= function - | Some start_time -> - tclFINALLY - tac - (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> - (match call_trace with - | (_, c) :: _ -> exit_tactic start_time c - | [] -> ())))) - | None -> tac - -(* ************** Accumulation of data from workers ************************* *) - -let get_local_profiling_results () = List.hd Local.(!stack) - -module SM = Map.Make(Stateid.Self) - -let data = ref SM.empty - -let _ = - Feedback.(add_feeder (function - | { id = State s; contents = Custom (_, "ltacprof_results", xml) } -> - let results = to_ltacprof_results xml in - let other_results = (* Multi success can cause this *) - try SM.find s !data - with Not_found -> empty_treenode root in - data := SM.add s (merge_roots results other_results) !data - | _ -> ())) - -let reset_profile () = - reset_profile_tmp (); - data := SM.empty - -(* ******************** *) - -let print_results_filter ~cutoff ~filter = - let valid id _ = Stm.state_of_id id <> `Expired in - data := SM.filter valid !data; - let results = - SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in - let results = merge_roots results Local.(CList.last !stack) in - Feedback.msg_notice (to_string ~cutoff ~filter results) -;; - -let print_results ~cutoff = - print_results_filter ~cutoff ~filter:(fun _ -> true) - -let print_results_tactic tactic = - print_results_filter ~cutoff:!Flags.profile_ltac_cutoff ~filter:(fun s -> - String.(equal tactic (sub (s ^ ".") 0 (min (1+length s) (length tactic))))) - -let do_print_results_at_close () = - if get_profiling () then print_results ~cutoff:!Flags.profile_ltac_cutoff - -let _ = Declaremods.append_end_library_hook do_print_results_at_close - -let _ = - let open Goptions in - declare_bool_option - { optsync = true; - optdepr = false; - optname = "Ltac Profiling"; - optkey = ["Ltac"; "Profiling"]; - optread = get_profiling; - optwrite = set_profiling } diff --git a/ltac/profile_ltac.mli b/ltac/profile_ltac.mli deleted file mode 100644 index e5e2e41975..0000000000 --- a/ltac/profile_ltac.mli +++ /dev/null @@ -1,48 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ('a * Tacexpr.ltac_call_kind) list -> - 'b Proofview.tactic -> 'b Proofview.tactic - -val set_profiling : bool -> unit - -(* Cut off results < than specified cutoff *) -val print_results : cutoff:float -> unit - -val print_results_tactic : string -> unit - -val reset_profile : unit -> unit - -val do_print_results_at_close : unit -> unit - -(* The collected statistics for a tactic. The timing data is collected over all - * instances of a given tactic from its parent. E.g. if tactic 'aaa' calls - * 'foo' twice, then 'aaa' will contain just one entry for 'foo' with the - * statistics of the two invocations combined, and also combined over all - * invocations of 'aaa'. - * total: time spent running this tactic and its subtactics (seconds) - * local: time spent running this tactic, minus its subtactics (seconds) - * ncalls: the number of invocations of this tactic that have been made - * max_total: the greatest running time of a single invocation (seconds) - *) -type treenode = { - name : CString.Map.key; - total : float; - local : float; - ncalls : int; - max_total : float; - children : treenode CString.Map.t -} - -(* Returns the profiling results known by the current process *) -val get_local_profiling_results : unit -> treenode -val feedback_results : treenode -> unit - diff --git a/ltac/profile_ltac_tactics.ml4 b/ltac/profile_ltac_tactics.ml4 deleted file mode 100644 index 8cb76d81c5..0000000000 --- a/ltac/profile_ltac_tactics.ml4 +++ /dev/null @@ -1,40 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* set_profiling b)) - -TACTIC EXTEND start_ltac_profiling -| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ] -END - -TACTIC EXTEND stop_profiling -| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ] -END - -VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF - [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ] -END - -VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY -| [ "Show" "Ltac" "Profile" ] -> [ print_results ~cutoff:!Flags.profile_ltac_cutoff ] -| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> [ print_results ~cutoff:(float_of_int n) ] -END - -VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY - [ "Show" "Ltac" "Profile" string(s) ] -> [ print_results_tactic s ] -END diff --git a/ltac/rewrite.ml b/ltac/rewrite.ml deleted file mode 100644 index 3c5a109c0d..0000000000 --- a/ltac/rewrite.ml +++ /dev/null @@ -1,2223 +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_all 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_all 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_all 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 evars 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 CErrors.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 eq_pb (ty, env, x, y as pb) (ty', env', x', y' as pb') = - pb == pb' || (ty == ty' && Constr.equal x x' && Constr.equal y y') - -let problem_inclusion x y = - List.for_all (fun pb -> List.exists (fun pb' -> eq_pb pb pb') y) x - -let evd_convertible env evd x y = - try - (* Unfortunately, the_conv_x might say they are unifiable even if some - unsolvable constraints remain, so we check that this unification - does not introduce any new problem. *) - let _, pbs = Evd.extract_all_conv_pbs evd in - let evd' = Evarconv.the_conv_x env x y evd in - let _, pbs' = Evd.extract_all_conv_pbs evd' in - if evd' == evd || problem_inclusion pbs' pbs then Some evd' - else None - with e when CErrors.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 = true; - Unification.modulo_delta = ts; - Unification.modulo_delta_types = full_transparent_state; - 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 ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in - let solve_tac = match tac with - | Genarg.GenArg (Genarg.Glbwit tag, tac) -> - Ftactic.run (Geninterp.interp tag ist tac) (fun _ -> Proofview.tclUNIT ()) - in - let solve_tac = tclCOMPLETE solve_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 = 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 - 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 CErrors.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 CErrors.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 (sigma, rew) = refresh_hypinfo env sigma c in - unify_eqn rew l2r flags env (sigma, cstrs) None t - 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 (CClosure.RedFlags.mkflags [CClosure.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 - user_err ~hdr:"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 (NamedDecl.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 (NamedDecl.get_id %> Id.equal id) ctx in - let nc = match before with - | [] -> assert false - | d :: rem -> insert_dependent env (LocalAssum (NamedDecl.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 = NamedDecl.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 - (** For compatibility *) - let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in - let beta = Tactics.reduct_in_concl (beta_red, DEFAULTcast) in - let beta_hyp id = Tactics.reduct_in_hyp beta_red (id, InHyp) 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 = tclTHENLIST [ - Refine.refine ~unsafe:false { run = fun h -> Sigma.here p h }; - Proofview.Unsafe.tclNEWGOALS gls; - ] in - Proofview.Unsafe.tclEVARS undef <*> - tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) - | Some id, None -> - Proofview.Unsafe.tclEVARS undef <*> - convert_hyp_no_check (LocalAssum (id, newt)) <*> - beta_hyp id - | 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 - 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 <*> 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 (); Proofview.tclUNIT () - with e when CErrors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Setoid library not loaded") - -let cl_rewrite_clause_strat progress strat clause = - tactic_init_setoid () <*> - (if progress then Proofview.tclPROGRESS else fun x -> x) - (Proofview.tclOR - (cl_rewrite_clause_newtac ~progress strat clause) - (fun (e, info) -> match e with - | RewriteFailure e -> - tclZEROMSG (str"setoid rewrite failed: " ++ e) - | Refiner.FailError (n, pp) -> - tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) - | e -> Proofview.tclZERO ~info e)) - -(** Setoid rewriting when called with "setoid_rewrite" *) -let cl_rewrite_clause l left2right occs clause = - let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in - cl_rewrite_clause_strat true strat clause - -(** 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 pr_ustrategy = function -| Subterms -> str "subterms" -| Subterm -> str "subterm" -| Innermost -> str "innermost" -| Outermost -> str "outermost" -| Bottomup -> str "bottomup" -| Topdown -> str "topdown" -| Progress -> str "progress" -| Try -> str "try" -| Any -> str "any" -| Repeat -> str "repeat" - -let paren p = str "(" ++ p ++ str ")" - -let rec pr_strategy prc prr = function -| StratId -> str "id" -| StratFail -> str "fail" -| StratRefl -> str "refl" -| StratUnary (s, str) -> - pr_ustrategy s ++ spc () ++ paren (pr_strategy prc prr str) -| StratBinary (Choice, str1, str2) -> - str "choice" ++ spc () ++ paren (pr_strategy prc prr str1) ++ spc () ++ - paren (pr_strategy prc prr str2) -| StratBinary (Compose, str1, str2) -> - pr_strategy prc prr str1 ++ str ";" ++ spc () ++ pr_strategy prc prr str2 -| StratConstr (c, true) -> prc c -| StratConstr (c, false) -> str "<-" ++ spc () ++ prc c -| StratTerms cl -> str "terms" ++ spc () ++ pr_sequence prc cl -| StratHints (old, id) -> - let cmd = if old then "old_hints" else "hints" in - str cmd ++ spc () ++ str id -| StratEval r -> str "eval" ++ spc () ++ prr r -| StratFold c -> str "fold" ++ spc () ++ prc 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 ~refine:false Hints.empty_hint_info - -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 sigma,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 sigma, typ = Typing.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 env sigma m = - 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 evd = Evd.nf_constraints evd in - let m = Evarutil.nf_evars_universes evd morph in - Pretyping.check_evars env Evd.empty evd m; - Evd.evar_universe_context evd, 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 env = Global.env () in - let evd = Evd.from_env env in - let uctx, instance = build_morphism_signature env evd m in - if Lib.is_modtype () then - let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id - (Entries.ParameterEntry - (None,poly,(instance,Evd.evar_context_universe_context uctx),None), - Decl_kinds.IsAssumption Decl_kinds.Logical) - in - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info 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) Hints.empty_hint_info - 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.from_ctx uctx) 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) Hints.empty_hint_info) - -(** 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 = Tacmach.New.project gl in - let env = Tacmach.New.pf_env gl in - let sigma, hi = decompose_applied_relation env evars (c,l) in - let but = match clause with - | Some id -> Tacmach.New.pf_get_hyp_typ id gl - | None -> Evarutil.nf_evar evars (Tacmach.New.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 = - Proofview.Goal.nf_enter { enter = begin fun 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 = Tacmach.New.project gl in - tactic_init_setoid () <*> - Proofview.tclOR - (tclPROGRESS - (tclTHEN - (Proofview.Unsafe.tclEVARS evd) - (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) - (fun (e, info) -> match e with - | RewriteFailure e -> - tclFAIL 0 (str"setoid rewrite failed: " ++ e) - | e -> Proofview.tclZERO ~info e) - end } - -let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite - -(** [setoid_]{reflexivity,symmetry,transitivity} tactics *) - -let not_declared env ty rel = - 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 (sigma, t) = Typing.type_of env sigma rel in - let car = RelDecl.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 = - (tclTHEN (Proofview.Unsafe.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 (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 -> 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 -> eapply proof - | Some c -> 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 - (tclTHENLAST - (Tactics.assert_after_replacing id new_hyp) - (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 deleted file mode 100644 index 35c4483513..0000000000 --- a/ltac/rewrite.mli +++ /dev/null @@ -1,117 +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 - -val pr_strategy : ('a -> Pp.std_ppcmds) -> ('b -> Pp.std_ppcmds) -> - ('a, 'b) strategy_ast -> Pp.std_ppcmds - -(** Entry point for user-level "rewrite_strat" *) -val cl_rewrite_clause_strat : strategy -> Id.t option -> unit Proofview.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 -> unit Proofview.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/tacarg.ml b/ltac/tacarg.ml deleted file mode 100644 index 42552c4846..0000000000 --- a/ltac/tacarg.ml +++ /dev/null @@ -1,26 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -| _ -> assert false - -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.typ -> 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 = Val.t - -let normalize v = v - -let of_constr c = in_gen (topwit wit_constr) c - -let to_constr v = - let v = normalize v in - if has_type v (topwit wit_constr) then - let c = out_gen (topwit wit_constr) v in - Some c - else if has_type v (topwit wit_constr_under_binders) then - let vars, c = out_gen (topwit wit_constr_under_binders) v in - match vars with [] -> Some c | _ -> None - else None - -let of_uconstr c = in_gen (topwit wit_uconstr) c - -let to_uconstr v = - let v = normalize v in - if has_type v (topwit wit_uconstr) then - Some (out_gen (topwit wit_uconstr) v) - else None - -let of_int i = in_gen (topwit wit_int) i - -let to_int v = - let v = normalize v in - if has_type v (topwit wit_int) then - Some (out_gen (topwit wit_int) v) - else None - -let to_list v = prj Val.typ_list v - -let to_option v = prj Val.typ_opt v - -let to_pair v = prj Val.typ_pair v - -end - -let is_variable env id = - Id.List.mem id (Termops.ids_of_named_context (Environ.named_context env)) - -(* 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) - -(* Gives the constr corresponding to a Constr_context tactic_arg *) -let coerce_to_constr_context v = - let v = Value.normalize v in - if has_type v (topwit wit_constr_context) then - out_gen (topwit wit_constr_context) v - else raise (CannotCoerceTo "a term context") - -(* Interprets an identifier which must be fresh *) -let coerce_var_to_ident fresh env v = - let v = Value.normalize v in - let fail () = raise (CannotCoerceTo "a fresh identifier") in - if has_type v (topwit wit_intro_pattern) then - match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) -> id - | _ -> fail () - else if has_type v (topwit wit_var) then - out_gen (topwit wit_var) v - else match Value.to_constr v with - | None -> fail () - | Some c -> - (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *) - if isVar c && not (fresh && is_variable env (destVar c)) then - destVar c - else fail () - - -(* Interprets, if possible, a constr to an identifier which may not - be fresh but suitable to be given to the fresh tactic. Works for - vars, constants, inductive, constructors and sorts. *) -let coerce_to_ident_not_fresh g env v = -let id_of_name = function - | Names.Anonymous -> Id.of_string "x" - | Names.Name x -> x in - let v = Value.normalize v in - let fail () = raise (CannotCoerceTo "an identifier") in - if has_type v (topwit wit_intro_pattern) then - match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) -> id - | _ -> fail () - else if has_type v (topwit wit_var) then - out_gen (topwit wit_var) v - else - match Value.to_constr v with - | None -> fail () - | Some c -> - match Constr.kind c with - | Var id -> id - | Meta m -> id_of_name (Evd.meta_name g m) - | Evar (kn,_) -> - begin match Evd.evar_ident kn g with - | None -> fail () - | Some id -> id - end - | Const (cst,_) -> Label.to_id (Constant.label cst) - | Construct (cstr,_) -> - let ref = Globnames.ConstructRef cstr in - let basename = Nametab.basename_of_global ref in - basename - | Ind (ind,_) -> - let ref = Globnames.IndRef ind in - let basename = Nametab.basename_of_global ref in - basename - | Sort s -> - begin - match s with - | Prop _ -> Label.to_id (Label.make "Prop") - | Type _ -> Label.to_id (Label.make "Type") - end - | _ -> fail() - - -let coerce_to_intro_pattern env v = - let v = Value.normalize v in - if has_type v (topwit wit_intro_pattern) then - snd (out_gen (topwit wit_intro_pattern) v) - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - IntroNaming (IntroIdentifier id) - else match Value.to_constr v with - | Some c when isVar c -> - (* This happens e.g. in definitions like "Tac H = clear H; intro H" *) - (* but also in "destruct H as (H,H')" *) - IntroNaming (IntroIdentifier (destVar c)) - | _ -> raise (CannotCoerceTo "an introduction pattern") - -let coerce_to_intro_pattern_naming env v = - match coerce_to_intro_pattern env v with - | IntroNaming pat -> pat - | _ -> raise (CannotCoerceTo "a naming introduction pattern") - -let coerce_to_hint_base v = - let v = Value.normalize v in - if has_type v (topwit wit_intro_pattern) then - match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) -> Id.to_string id - | _ -> raise (CannotCoerceTo "a hint base name") - else raise (CannotCoerceTo "a hint base name") - -let coerce_to_int v = - let v = Value.normalize v in - if has_type v (topwit wit_int) then - out_gen (topwit wit_int) v - else raise (CannotCoerceTo "an integer") - -let coerce_to_constr env v = - let v = Value.normalize v in - let fail () = raise (CannotCoerceTo "a term") in - if has_type v (topwit wit_intro_pattern) then - match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) -> - (try ([], constr_of_id env id) with Not_found -> fail ()) - | _ -> fail () - else if has_type v (topwit wit_constr) then - let c = out_gen (topwit wit_constr) v in - ([], c) - else if has_type v (topwit wit_constr_under_binders) then - out_gen (topwit wit_constr_under_binders) v - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - (try [], constr_of_id env id with Not_found -> fail ()) - else fail () - -let coerce_to_uconstr env v = - let v = Value.normalize v in - if has_type v (topwit wit_uconstr) then - out_gen (topwit wit_uconstr) v - else - raise (CannotCoerceTo "an untyped term") - -let coerce_to_closed_constr env v = - let ids,c = coerce_to_constr env v in - let () = if not (List.is_empty ids) then raise (CannotCoerceTo "a term") in - c - -let coerce_to_evaluable_ref env v = - let fail () = raise (CannotCoerceTo "an evaluable reference") in - let v = Value.normalize v in - let ev = - if has_type v (topwit wit_intro_pattern) then - match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) when is_variable env id -> EvalVarRef id - | _ -> fail () - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - if Id.List.mem id (Termops.ids_of_context env) then EvalVarRef id - else fail () - else if has_type v (topwit wit_ref) then - let open Globnames in - let r = out_gen (topwit wit_ref) v in - match r with - | VarRef var -> EvalVarRef var - | ConstRef c -> EvalConstRef c - | IndRef _ | ConstructRef _ -> fail () - else - match Value.to_constr v with - | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c)) - | Some c when isVar c -> EvalVarRef (destVar c) - | _ -> fail () - in if Tacred.is_evaluable env ev then ev else fail () - -let coerce_to_constr_list env v = - let v = Value.to_list v in - match v with - | Some l -> - let map v = coerce_to_closed_constr env v in - List.map map l - | None -> raise (CannotCoerceTo "a term list") - -let coerce_to_intro_pattern_list loc env v = - match Value.to_list v with - | None -> raise (CannotCoerceTo "an intro pattern list") - | Some l -> - let map v = (loc, coerce_to_intro_pattern env v) in - List.map map l - -let coerce_to_hyp env v = - let fail () = raise (CannotCoerceTo "a variable") in - let v = Value.normalize v in - if has_type v (topwit wit_intro_pattern) then - match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) when is_variable env id -> id - | _ -> fail () - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - if is_variable env id then id else fail () - else match Value.to_constr v with - | Some c when isVar c -> destVar c - | _ -> fail () - -let coerce_to_hyp_list env v = - let v = Value.to_list v in - match v with - | Some l -> - let map n = coerce_to_hyp env n in - List.map map l - | None -> raise (CannotCoerceTo "a variable list") - -(* Interprets a qualified name *) -let coerce_to_reference env v = - let v = Value.normalize v in - match Value.to_constr v with - | Some c -> - begin - try Globnames.global_of_constr c - with Not_found -> raise (CannotCoerceTo "a reference") - end - | None -> raise (CannotCoerceTo "a reference") - -(* Quantified named or numbered hypothesis or hypothesis in context *) -(* (as in Inversion) *) -let coerce_to_quantified_hypothesis v = - 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) -> NamedHyp id - | _ -> raise (CannotCoerceTo "a quantified hypothesis") - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - NamedHyp id - else if has_type v (topwit wit_int) then - AnonHyp (out_gen (topwit wit_int) v) - else match Value.to_constr v with - | Some c when isVar c -> NamedHyp (destVar c) - | _ -> raise (CannotCoerceTo "a quantified hypothesis") - -(* Quantified named or numbered hypothesis or hypothesis in context *) -(* (as in Inversion) *) -let coerce_to_decl_or_quant_hyp env v = - let v = Value.normalize v in - if has_type v (topwit wit_int) then - AnonHyp (out_gen (topwit wit_int) v) - else - try coerce_to_quantified_hypothesis v - with CannotCoerceTo _ -> - raise (CannotCoerceTo "a declared or quantified hypothesis") - -let coerce_to_int_or_var_list v = - match Value.to_list v with - | None -> raise (CannotCoerceTo "an int list") - | Some l -> - let map n = ArgArg (coerce_to_int n) in - List.map map l diff --git a/ltac/taccoerce.mli b/ltac/taccoerce.mli deleted file mode 100644 index 0b67f8726e..0000000000 --- a/ltac/taccoerce.mli +++ /dev/null @@ -1,96 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t - (** Eliminated the leading dynamic type casts. *) - - val of_constr : constr -> t - val to_constr : t -> constr option - val of_uconstr : Glob_term.closed_glob_constr -> t - val to_uconstr : t -> Glob_term.closed_glob_constr option - val of_int : int -> t - val to_int : t -> int option - val to_list : t -> t list option - val to_option : t -> t option option - val to_pair : t -> (t * t) option -end - -(** {5 Coercion functions} *) - -val coerce_to_constr_context : Value.t -> constr - -val coerce_var_to_ident : bool -> Environ.env -> Value.t -> Id.t - -val coerce_to_ident_not_fresh : Evd.evar_map -> 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_hint_base : Value.t -> string - -val coerce_to_int : Value.t -> int - -val coerce_to_constr : Environ.env -> Value.t -> constr_under_binders - -val coerce_to_uconstr : Environ.env -> Value.t -> Glob_term.closed_glob_constr - -val coerce_to_closed_constr : Environ.env -> Value.t -> constr - -val coerce_to_evaluable_ref : - Environ.env -> Value.t -> evaluable_global_reference - -val coerce_to_constr_list : Environ.env -> Value.t -> constr list - -val coerce_to_intro_pattern_list : - Loc.t -> Environ.env -> Value.t -> Tacexpr.intro_patterns - -val coerce_to_hyp : Environ.env -> Value.t -> Id.t - -val coerce_to_hyp_list : Environ.env -> Value.t -> Id.t list - -val coerce_to_reference : Environ.env -> Value.t -> Globnames.global_reference - -val coerce_to_quantified_hypothesis : Value.t -> quantified_hypothesis - -val coerce_to_decl_or_quant_hyp : Environ.env -> Value.t -> quantified_hypothesis - -val coerce_to_int_or_var_list : Value.t -> int or_var list - -(** {5 Missing generic arguments} *) - -val wit_constr_context : (Empty.t, Empty.t, constr) genarg_type - -val wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) genarg_type diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml deleted file mode 100644 index 2e2b55be74..0000000000 --- a/ltac/tacentries.ml +++ /dev/null @@ -1,525 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* entry_name - -(** 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 Tacarg.wit_tactic, Aself) - else if check_lvl (n + 1) then EntryName (rawwit Tacarg.wit_tactic, Anext) - else EntryName (rawwit Tacarg.wit_tactic, atactic n) - -let get_separator = function -| None -> error "Missing separator." -| Some sep -> 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 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)) 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)) 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)) 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)) 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 - Uentryl ("tactic", n) - else - Uentry s - -let arg_list = function Rawwit t -> Rawwit (ListArg t) -let arg_opt = function Rawwit t -> Rawwit (OptArg t) - -let interp_entry_name interp symb = - let rec eval = function - | Ulist1 e -> Ulist1 (eval e) - | Ulist1sep (e, sep) -> Ulist1sep (eval e, sep) - | Ulist0 e -> Ulist0 (eval e) - | Ulist0sep (e, sep) -> Ulist0sep (eval e, sep) - | Uopt e -> Uopt (eval e) - | Uentry s -> Uentry (interp s None) - | Uentryl (s, n) -> Uentryl (interp s (Some n), n) - in - eval symb - -(**********************************************************************) -(** Grammar declaration for Tactic Notation (Coq level) *) - -let get_tactic_entry n = - if Int.equal n 0 then - Pltac.simple_tactic, None - else if Int.equal n 5 then - Pltac.binder_tactic, None - else if 1<=n && n<5 then - Pltac.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 : Pptactic.grammar_terminals; -} - -(* Declaration of the tactic grammar rule *) - -let head_is_ident tg = match tg.tacgram_prods with -| TacTerm _ :: _ -> true -| _ -> false - -let rec prod_item_of_symbol lev = function -| Extend.Ulist1 s -> - let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist1 e) -| Extend.Ulist0 s -> - let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist0 e) -| Extend.Ulist1sep (s, sep) -> - let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist1sep (e, Atoken (CLexer.terminal sep))) -| Extend.Ulist0sep (s, sep) -> - let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist0sep (e, Atoken (CLexer.terminal sep))) -| Extend.Uopt s -> - let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (OptArg typ), Aopt e) -| Extend.Uentry arg -> - let ArgT.Any tag = arg in - let wit = ExtraArg tag in - EntryName (Rawwit wit, Extend.Aentry (genarg_grammar wit)) -| Extend.Uentryl (s, n) -> - let ArgT.Any tag = s in - assert (coincide (ArgT.repr tag) "tactic" 0); - get_tacentry n lev - -(** Tactic grammar extensions *) - -let add_tactic_entry (kn, ml, tg) state = - let open Tacexpr in - let entry, pos = get_tactic_entry tg.tacgram_level in - let mkact loc l = - let map arg = - (** HACK to handle especially the tactic(...) entry *) - let wit = Genarg.rawwit Tacarg.wit_tactic in - if Genarg.has_type arg wit && not ml then - Tacexp (Genarg.out_gen wit arg) - else - TacGeneric arg - in - let l = List.map map l 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 map = function - | TacTerm s -> GramTerminal s - | TacNonTerm (loc, s, _) -> - let EntryName (typ, e) = prod_item_of_symbol tg.tacgram_level s in - GramNonTerminal (loc, typ, e) - in - let prods = List.map map tg.tacgram_prods in - let rules = make_rule mkact prods in - let r = ExtendRule (entry, None, (pos, [(None, None, [rules])])) in - ([r], state) - -let tactic_grammar = - create_grammar_command "TacticGrammar" add_tactic_entry - -let extend_tactic_grammar kn ml ntn = extend_grammar_command tactic_grammar (kn, ml, ntn) - -(**********************************************************************) -(* Tactic Notation *) - -let entry_names = ref String.Map.empty - -let register_tactic_notation_entry name entry = - let entry = match entry with - | ExtraArg arg -> ArgT.Any arg - | _ -> assert false - in - entry_names := String.Map.add name entry !entry_names - -let interp_prod_item = function - | TacTerm s -> TacTerm s - | TacNonTerm (loc, (nt, sep), id) -> - let symbol = parse_user_entry nt sep in - let interp s = function - | None -> - if String.Map.mem s !entry_names then String.Map.find s !entry_names - else begin match ArgT.name s with - | None -> error ("Unknown entry "^s^".") - | Some arg -> arg - end - | Some n -> - (** FIXME: do better someday *) - assert (String.equal s "tactic"); - begin match Tacarg.wit_tactic with - | ExtraArg tag -> ArgT.Any tag - | _ -> assert false - end - in - let symbol = interp_entry_name interp symbol in - TacNonTerm (loc, symbol, id) - -let make_fresh_key = - let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in - fun prods -> - let cur = incr id; !id in - let map = function - | TacTerm s -> s - | TacNonTerm _ -> "#" - in - let prods = String.concat "_" (List.map map prods) in - (** We embed the hash of the kernel name in the label so that the identifier - should be mostly unique. This ensures that including two modules - together won't confuse the corresponding labels. *) - let hash = (cur lxor (ModPath.hash (Lib.current_mp ()))) land 0x7FFFFFFF in - let lbl = Id.of_string_soft (Printf.sprintf "%s_%08X" prods hash) in - Lib.make_kn lbl - -type tactic_grammar_obj = { - tacobj_key : KerName.t; - tacobj_local : locality_flag; - tacobj_tacgram : tactic_grammar; - tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; - tacobj_forml : bool; -} - -let pprule pa = { - Pptactic.pptac_level = pa.tacgram_level; - pptac_prods = pa.tacgram_prods; -} - -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; - extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram; - Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram) - -let open_tactic_notation i (_, tobj) = - let key = tobj.tacobj_key in - if Int.equal i 1 && not tobj.tacobj_local then - extend_tactic_grammar key tobj.tacobj_forml 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 (pprule tobj.tacobj_tacgram); - if Int.equal i 1 && not tobj.tacobj_local then - extend_tactic_grammar key tobj.tacobj_forml 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_glob_tactic_notation local n prods forml ids tac = - let parule = { - tacgram_level = n; - tacgram_prods = prods; - } in - let tacobj = { - tacobj_key = make_fresh_key prods; - tacobj_local = local; - tacobj_tacgram = parule; - tacobj_body = (ids, tac); - tacobj_forml = forml; - } in - Lib.add_anonymous_leaf (inTacticGrammar tacobj) - -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 prods in - let tac = Tacintern.glob_tactic_env ids (Global.env()) e in - add_glob_tactic_notation local n prods false ids tac - -(**********************************************************************) -(* ML Tactic entries *) - -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 - | TacTerm s :: rem -> (s, rem) - | _ -> assert false (** Not handled by the ML extension syntax *) - in - let empty_value = function - | TacTerm s -> raise NonEmptyArgument - | TacNonTerm (_, symb, _) -> - let EntryName (typ, e) = prod_item_of_symbol 0 symb in - 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 add_ml_tactic_notation name prods = - let len = List.length prods in - let iter i prods = - let open Tacexpr in - let get_id = function - | TacTerm s -> None - | TacNonTerm (_, _, id) -> Some id - in - let ids = List.map_filter get_id prods in - let entry = { mltac_name = name; mltac_index = len - i - 1 } in - let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in - let tac = TacML (Loc.ghost, entry, List.map map ids) in - add_glob_tactic_notation false 0 prods true ids tac - in - List.iteri iter (List.rev prods); - extend_atomic_tactic name prods - -(**********************************************************************) -(** 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 e - | Some l -> Aentryl (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 (CLexer.terminal name)), - Atoken (CLexer.terminal ":")), - Atoken (CLexer.terminal "(")), - entry), - Atoken (CLexer.terminal ")")) - in - let action _ v _ _ _ loc = cast (loc, v) in - let gram = (level, assoc, [Rule (rule, action)]) in - Pcoq.grammar_extend Pltac.tactic_arg None (None, [gram]) - -(** 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 warn_unusable_identifier = - CWarnings.create ~name:"unusable-identifier" ~category:"parsing" - (fun id -> strbrk "The Ltac name" ++ spc () ++ pr_id id ++ spc () ++ - strbrk "may be unusable because of a conflict with a notation.") - -let register_ltac local tacl = - let map tactic_body = - match tactic_body with - | Tacexpr.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 - CErrors.user_err ~loc - (str "There is already an Ltac named " ++ id_pp ++ str".") - in - let is_shadowed = - try - match Pcoq.parse_string Pltac.tactic (Id.to_string id) with - | Tacexpr.TacArg _ -> false - | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) - with e when CErrors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) - in - let () = if is_shadowed then warn_unusable_identifier id in - NewTac id, body - | Tacexpr.TacticRedefinition (ident, body) -> - let loc = loc_of_reference ident in - let kn = - try Nametab.locate_tactic (snd (qualid_of_reference ident)) - with Not_found -> - CErrors.user_err ~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 Feedback.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 Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined") - in - List.iter iter defs - -(** Queries *) - -let print_ltacs () = - let entries = KNmap.bindings (Tacenv.ltac_entries ()) in - let sort (kn1, _) (kn2, _) = KerName.compare kn1 kn2 in - let entries = List.sort sort entries in - let map (kn, entry) = - let qid = - try Some (Nametab.shortest_qualid_of_tactic kn) - with Not_found -> None - in - match qid with - | None -> None - | Some qid -> Some (qid, entry.Tacenv.tac_body) - in - let entries = List.map_filter map entries in - let pr_entry (qid, body) = - let (l, t) = match body with - | Tacexpr.TacFun (l, t) -> (l, t) - | _ -> ([], body) - in - let pr_ltac_fun_arg = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id - in - hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) - in - Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) - -(** Grammar *) - -let () = - let open Metasyntax in - let entries = [ - AnyEntry Pltac.tactic_expr; - AnyEntry Pltac.binder_tactic; - AnyEntry Pltac.simple_tactic; - AnyEntry Pltac.tactic_arg; - ] in - register_grammar "tactic" entries diff --git a/ltac/tacentries.mli b/ltac/tacentries.mli deleted file mode 100644 index 969c118fb5..0000000000 --- a/ltac/tacentries.mli +++ /dev/null @@ -1,64 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Tacexpr.tacdef_body list -> unit -(** Adds new Ltac definitions to the environment. *) - -(** {5 Tactic Notations} *) - -type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr = -| TacTerm of string -| TacNonTerm of Loc.t * 'a * Names.Id.t - -type raw_argument = string * string option -(** An argument type as provided in Tactic notations, i.e. a string like - "ne_foo_list_opt" together with a separator that only makes sense in the - "_sep" cases. *) - -type argument = Genarg.ArgT.any Extend.user_symbol -(** A fully resolved argument type given as an AST with generic arguments on the - leaves. *) - -val add_tactic_notation : - locality_flag -> int -> raw_argument grammar_tactic_prod_item_expr list -> - raw_tactic_expr -> unit -(** [add_tactic_notation local level prods expr] adds a tactic notation in the - environment at level [level] with locality [local] made of the grammar - productions [prods] and returning the body [expr] *) - -val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type -> unit -(** Register an argument under a given entry name for tactic notations. When - translating [raw_argument] into [argument], atomic names will be first - looked up according to names registered through this function and fallback - to finding an argument by name (as in {!Genarg}) if there is none - matching. *) - -val add_ml_tactic_notation : ml_tactic_name -> - argument grammar_tactic_prod_item_expr list list -> unit -(** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND - ML-side macro. *) - -(** {5 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]. *) - -(** {5 Queries} *) - -val print_ltacs : unit -> unit -(** Display the list of ltac definitions currently available. *) diff --git a/ltac/tacenv.ml b/ltac/tacenv.ml deleted file mode 100644 index e3c2b4ad51..0000000000 --- a/ltac/tacenv.ml +++ /dev/null @@ -1,143 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* CErrors.anomaly (str "Unknown tactic alias: " ++ KerName.print key) - -let check_alias key = KNmap.mem key !alias_map - -(** ML tactic extensions (TacML) *) - -type ml_tactic = - Geninterp.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 - tac_tab := MLTacMap.remove s !tac_tab - else - CErrors.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 -> - CErrors.user_err - (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 deleted file mode 100644 index 94e14223aa..0000000000 --- a/ltac/tacenv.mli +++ /dev/null @@ -1,75 +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/ltac/tacexpr.mli b/ltac/tacexpr.mli deleted file mode 100644 index 9c25a16457..0000000000 --- a/ltac/tacexpr.mli +++ /dev/null @@ -1,396 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'r Sigma.t -> ('a, 'r) Sigma.sigma } - -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 -type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr located -type intro_pattern_naming = intro_pattern_naming_expr located - -(** Generic expressions for atomic tactics *) - -type 'a gen_atomic_tactic_expr = - (* Basic tactics *) - | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr located list - | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * - ('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 - | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list - | TacMutualCofix of Id.t * (Id.t * 'trm) list - | TacAssert of - bool * 'tacexpr option option * - 'dtrm intro_pattern_expr located option * 'trm - | TacGeneralize of ('trm with_occurrences * Name.t) list - | TacLetTac of Name.t * 'trm * 'nam clause_expr * letin_flag * - intro_pattern_naming_expr located option - - (* Derived basic tactics *) - | TacInductionDestruct of - rec_flag * evars_flag * ('trm,'dtrm,'nam) induction_clause_list - - (* Conversion *) - | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr - | TacChange of 'pat option * 'dtrm * 'nam clause_expr - - (* Equality and inversion *) - | TacRewrite of evars_flag * - (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * - (* spiwack: using ['dtrm] here is a small hack, may not be - stable by a change in the representation of delayed - terms. Because, in fact, it is the whole "with_bindings" - which is delayed. But because the "t" level for ['dtrm] is - uninterpreted, it works fine here too, and avoid more - disruption of this file. *) - 'tacexpr option - | TacInversion of ('trm,'dtrm,'nam) inversion_strength * quantified_hypothesis - -constraint 'a = < - term:'trm; - dterm: 'dtrm; - pattern:'pat; - constant:'cst; - reference:'ref; - name:'nam; - tacexpr:'tacexpr; - level:'lev -> - -(** Possible arguments of a tactic definition *) - -type 'a gen_tactic_arg = - | TacGeneric of 'lev generic_argument - | ConstrMayEval of ('trm,'cst,'pat) may_eval - | Reference of 'ref - | TacCall of Loc.t * 'ref * - 'a gen_tactic_arg list - | TacFreshId of string or_var list - | Tacexp of 'tacexpr - | TacPretype of 'trm - | TacNumgoals - -constraint 'a = < - term:'trm; - dterm: 'dtrm; - pattern:'pat; - constant:'cst; - reference:'ref; - name:'nam; - tacexpr:'tacexpr; - level:'lev -> - -(** Generic ltac expressions. - 't : terms, 'p : patterns, 'c : constants, 'i : inductive, - 'r : ltac refs, 'n : idents, 'l : levels *) - -and 'a gen_tactic_expr = - | TacAtom of Loc.t * 'a gen_atomic_tactic_expr - | TacThen of - 'a gen_tactic_expr * - 'a gen_tactic_expr - | TacDispatch of - 'a gen_tactic_expr list - | TacExtendTac of - 'a gen_tactic_expr array * - 'a gen_tactic_expr * - 'a gen_tactic_expr array - | TacThens of - 'a gen_tactic_expr * - 'a gen_tactic_expr list - | TacThens3parts of - 'a gen_tactic_expr * - 'a gen_tactic_expr array * - 'a gen_tactic_expr * - 'a gen_tactic_expr array - | TacFirst of 'a gen_tactic_expr list - | TacComplete of 'a gen_tactic_expr - | TacSolve of 'a gen_tactic_expr list - | TacTry of 'a gen_tactic_expr - | TacOr of - 'a gen_tactic_expr * - 'a gen_tactic_expr - | TacOnce of - 'a gen_tactic_expr - | TacExactlyOnce of - 'a gen_tactic_expr - | TacIfThenCatch of - 'a gen_tactic_expr * - 'a gen_tactic_expr * - 'a gen_tactic_expr - | TacOrelse of - 'a gen_tactic_expr * - 'a gen_tactic_expr - | TacDo of int or_var * 'a gen_tactic_expr - | TacTimeout of int or_var * 'a gen_tactic_expr - | TacTime of string option * 'a gen_tactic_expr - | TacRepeat of 'a gen_tactic_expr - | TacProgress of 'a gen_tactic_expr - | TacShowHyps of 'a gen_tactic_expr - | TacAbstract of - 'a gen_tactic_expr * Id.t option - | TacId of 'n message_token list - | TacFail of global_flag * int or_var * 'n message_token list - | TacInfo of 'a gen_tactic_expr - | TacLetIn of rec_flag * - (Id.t located * 'a gen_tactic_arg) list * - 'a gen_tactic_expr - | TacMatch of lazy_flag * - 'a gen_tactic_expr * - ('p,'a gen_tactic_expr) match_rule list - | TacMatchGoal of lazy_flag * direction_flag * - ('p,'a gen_tactic_expr) match_rule list - | TacFun of 'a gen_tactic_fun_ast - | TacArg of 'a gen_tactic_arg located - | TacSelect of goal_selector * '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 * 'a gen_tactic_arg list - -constraint 'a = < - term:'t; - dterm: 'dtrm; - pattern:'p; - constant:'c; - reference:'r; - name:'n; - tacexpr:'tacexpr; - level:'l -> - -and 'a gen_tactic_fun_ast = - Id.t option list * 'a gen_tactic_expr - -constraint 'a = < - term:'t; - dterm: 'dtrm; - pattern:'p; - constant:'c; - reference:'r; - name:'n; - tacexpr:'te; - level:'l -> - -(** Globalized tactics *) - -type g_trm = glob_constr_and_expr -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 - -type g_dispatch = < - term:g_trm; - dterm:g_trm; - pattern:g_pat; - constant:g_cst; - reference:g_ref; - name:g_nam; - tacexpr:glob_tactic_expr; - level:glevel -> - -and glob_tactic_expr = - g_dispatch gen_tactic_expr - -type glob_atomic_tactic_expr = - g_dispatch gen_atomic_tactic_expr - -type glob_tactic_arg = - g_dispatch gen_tactic_arg - -(** Raw tactics *) - -type r_trm = constr_expr -type r_pat = constr_pattern_expr -type r_cst = reference or_by_notation -type r_ref = reference -type r_nam = Id.t located -type r_lev = rlevel - -type r_dispatch = < - term:r_trm; - dterm:r_trm; - pattern:r_pat; - constant:r_cst; - reference:r_ref; - name:r_nam; - tacexpr:raw_tactic_expr; - level:rlevel -> - -and raw_tactic_expr = - r_dispatch gen_tactic_expr - -type raw_atomic_tactic_expr = - r_dispatch gen_atomic_tactic_expr - -type raw_tactic_arg = - r_dispatch gen_tactic_arg - -(** Interpreted tactics *) - -type t_trm = Term.constr -type t_pat = constr_pattern -type t_cst = evaluable_global_reference -type t_ref = ltac_constant located -type t_nam = Id.t - -type t_dispatch = < - term:t_trm; - dterm:g_trm; - pattern:t_pat; - constant:t_cst; - reference:t_ref; - name:t_nam; - tacexpr:unit; - level:tlevel -> - -type atomic_tactic_expr = - t_dispatch gen_atomic_tactic_expr - -(** Misc *) - -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 - -type 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 *) diff --git a/ltac/tacintern.ml b/ltac/tacintern.ml deleted file mode 100644 index 763e0dc22e..0000000000 --- a/ltac/tacintern.ml +++ /dev/null @@ -1,812 +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 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 (snd 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 (snd (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 (snd (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 (snd (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_destruction_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 (snd 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 (glob,_ as c) = intern_constr_gen true false ist pc in - let bound_names = Glob_ops.bound_glob_vars glob in - metas,(bound_names,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 *) - let (glob,_ as c) = intern_constr_gen true false ist p in - let bound_names = Glob_ops.bound_glob_vars glob in - (bound_names,c,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)) - | _ -> - let bound_names = Glob_ops.bound_glob_vars c in - Inr (bound_names,(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 CErrors.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 CErrors.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:false ~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 ?(as_type=false) 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 ~as_type 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 - ~hdr:"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} - -(* 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 (ev,l) -> - TacIntroPattern (ev,List.map (intern_intro_pattern lf ist) l) - | 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 (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_destruction_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)) - (* 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 ~as_type:true 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 - | TacSelect (sel, tac) -> - ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac) - - (* 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 ?(as_type=false) = function - | (All tc)::tl -> - All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist ~as_type tl) - | (Pat (rl,mp,tc))::tl -> - let {ltacvars=lfun; genv=env} = ist in - let lfun',metas1,hyps = intern_match_goal_hyps ist ~as_type lfun rl in - let ido,metas2,pat = intern_pattern ist ~as_type 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 ~as_type 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 -> - user_err ~hdr:"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 intern_ltac ist tac = - Flags.with_option strict_check (fun () -> intern_pure_tactic ist tac) () - -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_ltac); - 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_destruction_arg (lift intern_destruction_arg); - () - -(** Substitution for notations containing tactic-in-terms *) - -let notation_subst bindings tac = - let fold id c accu = - let loc = Glob_ops.loc_of_glob_constr (fst c) in - let c = ConstrMayEval (ConstrTerm c) in - ((loc, id), c) :: accu - in - let bindings = Id.Map.fold fold bindings [] in - (** This is theoretically not correct due to potential variable capture, but - Ltac has no true variables so one cannot simply substitute *) - TacLetIn (false, bindings, tac) - -let () = Genintern.register_ntn_subst0 wit_tactic notation_subst diff --git a/ltac/tacintern.mli b/ltac/tacintern.mli deleted file mode 100644 index 71ca354fa1..0000000000 --- a/ltac/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/ltac/tacinterp.ml b/ltac/tacinterp.ml deleted file mode 100644 index 32bcdfb6a4..0000000000 --- a/ltac/tacinterp.ml +++ /dev/null @@ -1,2157 +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 - let t' = match val_tag wit with - | Val.Base t' -> t' - | _ -> assert false (** not used in this module *) - in - match Val.eq t t' with - | None -> false - | Some Refl -> true - -let prj : type a. a Val.typ -> 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_list tag v = - let tag = match tag with Val.Base tag -> tag | _ -> assert false in - Val.Dyn (Val.typ_list, List.map (fun x -> Val.Dyn (tag, x)) v) -let in_gen wit v = - let t = match val_tag wit with - | Val.Base t -> t - | _ -> assert false (** not used in this module *) - in - Val.Dyn (t, v) -let out_gen wit v = - let t = match val_tag wit with - | Val.Base t -> t - | _ -> assert false (** not used in this module *) - in - match prj t 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.pr 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 = - let Val.Dyn (tag, _) = arg in - 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 -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) = - let wit = Genarg.create_arg "tacvalue" in - let () = register_val0 wit None in - wit - -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 = Pptactic.pr_value Pptactic.ltop v in - let Val.Dyn (tag, _) = v in - let tag = Val.pr tag in - user_err (str "Type error: value " ++ pr_v ++ str " is a " ++ tag - ++ str " while type " ++ Val.pr wit ++ str " was expected.") - - let unbox wit v ans = match ans with - | None -> cast_error wit v - | Some x -> x - - let rec prj : type a. a Val.tag -> Val.t -> a = fun tag v -> match tag with - | Val.List tag -> List.map (fun v -> prj tag v) (unbox Val.typ_list v (to_list v)) - | Val.Opt tag -> Option.map (fun v -> prj tag v) (unbox Val.typ_opt v (to_option v)) - | Val.Pair (tag1, tag2) -> - let (x, y) = unbox Val.typ_pair v (to_pair v) in - (prj tag1 x, prj tag2 y) - | Val.Base t -> - let Val.Dyn (t', x) = v in - match Val.eq t t' with - | None -> cast_error t v - | Some Refl -> x - - let rec tag_of_arg : type a b c. (a, b, c) genarg_type -> c Val.tag = fun wit -> match wit with - | ExtraArg _ -> val_tag wit - | ListArg t -> Val.List (tag_of_arg t) - | OptArg t -> Val.Opt (tag_of_arg t) - | PairArg (t1, t2) -> Val.Pair (tag_of_arg t1, tag_of_arg t2) - - let val_cast arg v = prj (tag_of_arg arg) v - - let cast (Topwit wit) v = val_cast wit v - -end - -let print_top_val env v = Pptactic.pr_value Pptactic.ltop v - -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 (CErrors.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 CErrors.noncritical e -> - let e = CErrors.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 *) - -(* Some of the code further down depends on the fact that push_trace does not modify sigma (the evar map) *) -let push_trace call ist = match TacStore.get ist.extra f_trace with -| None -> Proofview.tclUNIT [call] -| Some trace -> Proofview.tclUNIT (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 - push_trace(loc,LtacVarCall (id,t)) ist >>= fun trace -> - let ans = VFun (appl,trace,lfun,it,b) in - Proofview.tclUNIT (of_tacvalue ans) - | _ -> Proofview.tclUNIT v - else Proofview.tclUNIT 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 - (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 (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_var_to_ident false env) ist (Some (env,sigma)) (dloc,id) - with Not_found -> id - -(* 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) ~hdr:"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 (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 (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 (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 extract_ident ist env sigma id = - try try_interp_ltac_var (coerce_to_ident_not_fresh sigma env) - ist (Some (env,sigma)) (dloc,id) - with Not_found -> id in - 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 (extract_ident ist env sigma id)) l) in - let s = if CLexer.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_var_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 - (* Jason Gross: To avoid unnecessary modifications to tacinterp, as - suggested by Arnaud Spiwack, we run push_trace immediately. We do - this with the kludge of an empty proofview, and rely on the - invariant that running the tactic returned by push_trace does - not modify sigma. *) - let (_, dummy_proofview) = Proofview.init sigma [] in - let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist) dummy_proofview 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; - solve_unification_constraints = 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; - solve_unification_constraints = true; - use_hook = Some solve_by_implicit_tactic; - fail_evar = false; - expand_evars = true } - -let open_constr_no_classes_flags = { - use_typeclasses = false; - solve_unification_constraints = true; - use_hook = Some solve_by_implicit_tactic; - fail_evar = false; - expand_evars = true } - -let pure_open_constr_flags = { - use_typeclasses = false; - solve_unification_constraints = 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 *) -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 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 (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 ~hdr:"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 = CErrors.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 = CErrors.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 if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_id id) 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) - | _ -> - user_err ~loc (str "Cannot coerce to a disjunctive/conjunctive 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_destruction_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 - (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 ~hdr:"interp_destruction_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 (bvars,(glob,_),pat as c) = - if use_types then - (bvars,interp_typed_pattern ist env sigma c) - else - (bvars,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 ~hdr:"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 - | [] -> [] - -let warn_deprecated_info = - CWarnings.create ~name:"deprecated-info-tactical" ~category:"deprecated" - (fun () -> - 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.") - -(* 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 - push_trace(loc,call) ist >>= fun trace -> - Profile_ltac.do_profile "eval_tactic:2" trace - (catch_error_tac trace (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 (interp_ident ist (pf_env gl) (project 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 -> - warn_deprecated_info (); - eval_tactic ist tac - | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_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 - Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> - 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) -> - push_trace (loc,LtacMLCall tac) ist >>= fun trace -> - 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 - let open Ftactic in - force_vrec ist v >>= begin fun v -> - Ftactic.lift (propagate_trace ist loc id v) >>= fun v -> - 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 - push_trace loc_info ist >>= fun trace -> - let extra = TacStore.set extra f_trace trace 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 - Profile_ltac.do_profile "tactic_of_value" trace (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) in - Ftactic.List.map map x >>= fun l -> - Ftactic.return (Val.Dyn (Val.typ_list, l)) - | OptArg wit -> - begin match x with - | None -> Ftactic.return (Val.Dyn (Val.typ_opt, None)) - | Some x -> - interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> - Ftactic.return (Val.Dyn (Val.typ_opt, Some x)) - end - | 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 -> - Ftactic.return (Val.Dyn (Val.typ_pair, (p, q))) - | ExtraArg s -> - Geninterp.interp wit ist 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 = in_list (val_tag wit_constr) lc in - Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) - end } - -and interp_genarg_var_list ist x = - Ftactic.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 - let lc = in_list (val_tag wit_var) lc in - Ftactic.return 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_atomic_tactic env 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 (ev,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 ev - (name_atomic ~env - (TacIntroPattern (ev,l)) - (* spiwack: print uninterpreted, not sure if it is the - expected behaviour. *) - (Tactics.intro_patterns ev l')) sigma - 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) = 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 = 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) = 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 = 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 (Option.map (interp_tactic ist)) t in - Tacticals.New.tclWITHHOLES false - (name_atomic ~env - (TacAssert(b,Option.map (Option.map ignore) 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) - (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) = interp_constr ist env sigma 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_destruction_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 } - - (* Conversion *) - | TacReduce (r,cl) -> - 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 } - | 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 - 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 - let op = interp_typed_pattern ist env sigma op in - let to_catch = function Not_found -> true | e -> CErrors.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 *) -> - user_err (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) - 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,Option.map ignore 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) = interp_constr ist env sigma 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 - -(* 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 register_interp0 wit f = - let open Ftactic.Notations in - let interp ist v = - f ist v >>= fun v -> Ftactic.return (Val.inject (val_tag wit) v) - in - Geninterp.register_interp0 wit interp - -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; - 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.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 interp_destruction_arg' ist c = Ftactic.nf_enter { enter = begin fun gl -> - Ftactic.return (interp_destruction_arg ist gl c) -end } - -let () = - register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); - register_interp0 wit_ref (lift interp_reference); - register_interp0 wit_ident (lift interp_ident); - register_interp0 wit_var (lift interp_hyp); - register_interp0 wit_intro_pattern (lifts interp_intro_pattern); - register_interp0 wit_clause_dft_concl (lift interp_clause); - register_interp0 wit_constr (lifts interp_constr); - register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v); - register_interp0 wit_red_expr (lifts interp_red_expr); - register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); - register_interp0 wit_open_constr (lifts interp_open_constr); - register_interp0 wit_bindings interp_bindings'; - register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; - register_interp0 wit_destruction_arg interp_destruction_arg'; - () - -let () = - let interp ist tac = Ftactic.return (Value.of_closure ist tac) in - register_interp0 wit_tactic interp - -let () = - let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in - register_interp0 wit_ltac interp - -let () = - 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 _ = - let open Goptions in - declare_bool_option - { optsync = false; - optdepr = false; - optname = "Ltac debug"; - optkey = ["Debug";"Ltac"]; - 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 deleted file mode 100644 index 6f64981eff..0000000000 --- a/ltac/tacinterp.mli +++ /dev/null @@ -1,122 +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 -> Geninterp.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 - -(** 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_constr_gen : Pretyping.typing_constraint -> interp_sign -> - Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Evd.evar_map * constr - -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 deleted file mode 100644 index 55de583613..0000000000 --- a/ltac/tacsubst.ml +++ /dev/null @@ -1,308 +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_destruction_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 - Feedback.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 (bvars,c,p) = - (bvars,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 (ev,l) -> TacIntroPattern (ev,List.map (subst_intro_pattern subst) l) - | 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 (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_destruction_arg subst c, ids, cls) l in - let el' = Option.map (subst_glob_with_bindings subst) el in - TacInductionDestruct (isrec,ev,(l',el')) - - (* 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) - | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac) - - (* 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_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_destruction_arg subst_destruction_arg; - () diff --git a/ltac/tacsubst.mli b/ltac/tacsubst.mli deleted file mode 100644 index c1bf272579..0000000000 --- a/ltac/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/ltac/tactic_debug.ml b/ltac/tactic_debug.ml deleted file mode 100644 index 5cbddc7f64..0000000000 --- a/ltac/tactic_debug.ml +++ /dev/null @@ -1,422 +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 = - CErrors.print (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))) - -let explain_logic_error_no_anomaly e = - CErrors.print_no_report - (fst (ExplainErr.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) :: _ -> not (Tacenv.is_ltac_for_ml_tactic f) - | (_, Tacexpr.LtacNotationCall f) :: _ -> true - | (_, Tacexpr.LtacAtomCall _) :: _ -> 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 (Pptactic.pr_alias_key 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 () - | [a] -> hov 0 (str "Ltac call to " ++ pr_call a ++ str " failed.") - | _ -> - 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 _ as tac) :: (_,Tacexpr.LtacMLCall _) :: _ -> - (* Case of an ML defined tactic with entry of the form <<"foo" args>> *) - (* see tacextend.mlp *) - [tac] - | (_,Tacexpr.LtacMLCall _ as tac) :: _ -> [tac] - | t :: tail -> t :: aux tail - | [] -> [] in - List.rev (aux (List.rev trace)) - -let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2 - -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, if finer_loc eloc loc then eloc else loc - else - (* We entered a primitive tactic, we don't display trace but - report on the finest location *) - let best_loc = - (* trace is with innermost call coming first *) - let rec aux best_loc = function - | (loc,_)::tail -> - if Loc.is_ghost best_loc || - not (Loc.is_ghost loc) && finer_loc loc best_loc - then - aux loc tail - else - aux best_loc tail - | [] -> best_loc in - aux eloc 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 () = ExplainErr.register_additional_error_info get_ltac_trace diff --git a/ltac/tactic_debug.mli b/ltac/tactic_debug.mli deleted file mode 100644 index 520fb41eff..0000000000 --- a/ltac/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/ltac/tactic_matching.ml b/ltac/tactic_matching.ml deleted file mode 100644 index ef45ee47e1..0000000000 --- a/ltac/tactic_matching.ml +++ /dev/null @@ -1,377 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - Constr_matching.bound_ident_map * Pattern.extended_patvar_map = - fun (l, lc) -> (l, Id.Map.map (fun c -> [], c) lc) - - -(** Adds a binding to a {!Id.Map.t} if the identifier is [Some id] *) -let id_map_try_add id x m = - match id with - | Some id -> Id.Map.add id x m - | None -> m - -(** Adds a binding to a {!Id.Map.t} if the name is [Name id] *) -let id_map_try_add_name id x m = - match id with - | Name id -> Id.Map.add id x m - | Anonymous -> m - -(** Takes the union of two {!Id.Map.t}. If there is conflict, - the binding of the right-hand argument shadows that of the left-hand - argument. *) -let id_map_right_biased_union m1 m2 = - if Id.Map.is_empty m1 then m2 (** Don't reconstruct the whole map *) - else Id.Map.fold Id.Map.add m2 m1 - -(** Tests whether the substitution [s] is empty. *) -let is_empty_subst (ln,lm) = - Id.Map.(is_empty ln && is_empty lm) - -(** {6 Non-linear patterns} *) - - -(** The patterns of Ltac are not necessarily linear. Non-linear - pattern are partially handled by the {!Matching} module, however - goal patterns are not primitive to {!Matching}, hence we must deal - with non-linearity between hypotheses and conclusion. Subterms are - considered equal up to the equality implemented in - [equal_instances]. *) -(* spiwack: it doesn't seem to be quite the same rule for non-linear - term patterns and non-linearity between hypotheses and/or - conclusion. Indeed, in [Matching], matching is made modulo - syntactic equality, and here we merge modulo conversion. It may be - a good idea to have an entry point of [Matching] with a partial - substitution as argument instead of merging substitution here. That - would ensure consistency. *) -let equal_instances env sigma (ctx',c') (ctx,c) = - (* How to compare instances? Do we want the terms to be convertible? - unifiable? Do we want the universe levels to be relevant? - (historically, conv_x is used) *) - CList.equal Id.equal ctx ctx' && Reductionops.is_conv env sigma c' c - - -(** Merges two substitutions. Raises [Not_coherent_metas] when - encountering two instances of the same metavariable which are not - equal according to {!equal_instances}. *) -exception Not_coherent_metas -let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) = - let merge id oc1 oc2 = match oc1, oc2 with - | None, None -> None - | None, Some c | Some c, None -> Some c - | Some c1, Some c2 -> - if equal_instances env sigma c1 c2 then Some c1 - else raise Not_coherent_metas - in - let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 in - (** ppedrot: Is that even correct? *) - let merged = ln +++ ln1 in - (merged, Id.Map.merge merge lcm lm) - -let matching_error = - CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") - -let imatching_error = (matching_error, Exninfo.null) - -(** A functor is introduced to share the environment and the - evar_map. They do not change and it would be a pity to introduce - closures everywhere just for the occasional calls to - {!equal_instances}. *) -module type StaticEnvironment = sig - val env : Environ.env - val sigma : Evd.evar_map -end -module PatternMatching (E:StaticEnvironment) = struct - - - (** {6 The pattern-matching monad } *) - - - (** To focus on the algorithmic portion of pattern-matching, the - bookkeeping is relegated to a monad: the composition of the - bactracking monad of {!IStream.t} with a "writer" effect. *) - (* spiwack: as we don't benefit from the various stream optimisations - of Haskell, it may be costly to give the monad in direct style such as - here. We may want to use some continuation passing style. *) - type 'a tac = 'a Proofview.tactic - type 'a m = { stream : 'r. ('a -> unit t -> 'r tac) -> unit t -> 'r tac } - - (** The empty substitution. *) - let empty_subst = Id.Map.empty , Id.Map.empty - - (** Composes two substitutions using {!verify_metas_coherence}. It - must be a monoid with neutral element {!empty_subst}. Raises - [Not_coherent_metas] when composition cannot be achieved. *) - let subst_prod s1 s2 = - if is_empty_subst s1 then s2 - else if is_empty_subst s2 then s1 - else verify_metas_coherence E.env E.sigma s1 s2 - - (** The empty context substitution. *) - let empty_context_subst = Id.Map.empty - - (** Compose two context substitutions, in case of conflict the - right hand substitution shadows the left hand one. *) - let context_subst_prod = id_map_right_biased_union - - (** The empty term substitution. *) - let empty_term_subst = Id.Map.empty - - (** Compose two terms substitutions, in case of conflict the - right hand substitution shadows the left hand one. *) - let term_subst_prod = id_map_right_biased_union - - (** Merge two writers (and ignore the first value component). *) - let merge m1 m2 = - try Some { - subst = subst_prod m1.subst m2.subst; - context = context_subst_prod m1.context m2.context; - terms = term_subst_prod m1.terms m2.terms; - lhs = m2.lhs; - } - with Not_coherent_metas -> None - - (** Monadic [return]: returns a single success with empty substitutions. *) - let return (type a) (lhs:a) : a m = - { stream = fun k ctx -> k lhs ctx } - - (** Monadic bind: each success of [x] is replaced by the successes - of [f x]. The substitutions of [x] and [f x] are composed, - dropping the apparent successes when the substitutions are not - coherent. *) - let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m = - { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx } - - (** A variant of [(>>=)] when the first argument returns [unit]. *) - let (<*>) (type a) (m:unit m) (y:a m) : a m = - { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } - - (** Failure of the pattern-matching monad: no success. *) - let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } - - let run (m : 'a m) = - let ctx = { - subst = empty_subst ; - context = empty_context_subst ; - terms = empty_term_subst ; - lhs = (); - } in - let eval lhs ctx = Proofview.tclUNIT { ctx with lhs } in - m.stream eval ctx - - (** Chooses in a list, in the same order as the list *) - let rec pick (l:'a list) (e, info) : 'a m = match l with - | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } - | x :: l -> - { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) } - - let pick l = pick l imatching_error - - (** Declares a subsitution, a context substitution and a term substitution. *) - let put subst context terms : unit m = - let s = { subst ; context ; terms ; lhs = () } in - { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } - - (** Declares a substitution. *) - let put_subst subst : unit m = put subst empty_context_subst empty_term_subst - - (** Declares a term substitution. *) - let put_terms terms : unit m = put empty_subst empty_context_subst terms - - - - (** {6 Pattern-matching} *) - - - (** [wildcard_match_term lhs] matches a term against a wildcard - pattern ([_ => lhs]). It has a single success with an empty - substitution. *) - let wildcard_match_term = return - - (** [pattern_match_term refresh pat term lhs] returns the possible - matchings of [term] with the pattern [pat => lhs]. If refresh is - true, refreshes the universes of [term]. *) - let pattern_match_term refresh pat term lhs = -(* let term = if refresh then Termops.refresh_universes_strict term else term in *) - match pat with - | Term p -> - begin - try - put_subst (Constr_matching.extended_matches E.env E.sigma p term) <*> - return lhs - with Constr_matching.PatternMatchingFailure -> fail - end - | Subterm (with_app_context,id_ctxt,p) -> - - let rec map s (e, info) = - { stream = fun k ctx -> match IStream.peek s with - | IStream.Nil -> Proofview.tclZERO ~info e - | IStream.Cons ({ Constr_matching.m_sub ; m_ctx }, s) -> - let subst = adjust m_sub in - let context = id_map_try_add id_ctxt m_ctx Id.Map.empty in - let terms = empty_term_subst in - let nctx = { subst ; context ; terms ; lhs = () } in - match merge ctx nctx with - | None -> (map s (e, info)).stream k ctx - | Some nctx -> Proofview.tclOR (k lhs nctx) (fun e -> (map s e).stream k ctx) - } - in - map (Constr_matching.match_subterm_gen E.env E.sigma with_app_context p term) imatching_error - - - (** [rule_match_term term rule] matches the term [term] with the - matching rule [rule]. *) - let rule_match_term term = function - | All lhs -> wildcard_match_term lhs - | Pat ([],pat,lhs) -> pattern_match_term false pat term lhs - | Pat _ -> - (** Rules with hypotheses, only work in match goal. *) - fail - - (** [match_term term rules] matches the term [term] with the set of - matching rules [rules].*) - let rec match_term (e, info) term rules = match rules with - | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } - | r :: rules -> - { stream = fun k ctx -> - let head = rule_match_term term r in - let tail e = match_term e term rules in - Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx) - } - - - (** [hyp_match_type hypname pat hyps] matches a single - hypothesis pattern [hypname:pat] against the hypotheses in - [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 decl -> - let id = NamedDecl.get_id decl in - let refresh = is_local_def decl in - pattern_match_term refresh pat (NamedDecl.get_type decl) () <*> - put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> - return id - - (** [hyp_match_type hypname bodypat typepat hyps] matches a single - hypothesis pattern [hypname := bodypat : typepat] against the - hypotheses in [hyps].Tries the hypotheses in order. For each - success returns the name of the matched hypothesis. *) - let hyp_match_body_and_type hypname bodypat typepat hyps = - pick hyps >>= function - | 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 - | LocalAssum (id,hyp) -> fail - - (** [hyp_match pat hyps] dispatches to - {!hyp_match_type} or {!hyp_match_body_and_type} depending on whether - [pat] is [Hyp _] or [Def _]. *) - let hyp_match pat hyps = - match pat with - | Hyp ((_,hypname),typepat) -> - hyp_match_type hypname typepat hyps - | Def ((_,hypname),bodypat,typepat) -> - hyp_match_body_and_type hypname bodypat typepat hyps - - (** [hyp_pattern_list_match pats hyps lhs], matches the list of - patterns [pats] against the hypotheses in [hyps], and eventually - returns [lhs]. *) - let rec hyp_pattern_list_match pats hyps lhs = - match pats with - | pat::pats -> - hyp_match pat hyps >>= fun matched_hyp -> - (* spiwack: alternatively it is possible to return the list - with the matched hypothesis removed directly in - [hyp_match]. *) - let select_matched_hyp decl = Id.equal (NamedDecl.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 - - (** [rule_match_goal hyps concl rule] matches the rule [rule] - against the goal [hyps|-concl]. *) - let rule_match_goal hyps concl = function - | All lhs -> wildcard_match_term lhs - | Pat (hyppats,conclpat,lhs) -> - (* the rules are applied from the topmost one (in the concrete - syntax) to the bottommost. *) - let hyppats = List.rev hyppats in - pattern_match_term false conclpat concl () <*> - hyp_pattern_list_match hyppats hyps lhs - - (** [match_goal hyps concl rules] matches the goal [hyps|-concl] - with the set of matching rules [rules]. *) - let rec match_goal (e, info) hyps concl rules = match rules with - | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } - | r :: rules -> - { stream = fun k ctx -> - let head = rule_match_goal hyps concl r in - let tail e = match_goal e hyps concl rules in - Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx) - } - -end - -(** [match_term env sigma term rules] matches the term [term] with the - set of matching rules [rules]. The environment [env] and the - evar_map [sigma] are not currently used, but avoid code - duplication. *) -let match_term env sigma term rules = - let module E = struct - let env = env - let sigma = sigma - end in - let module M = PatternMatching(E) in - M.run (M.match_term imatching_error term rules) - - -(** [match_goal env sigma hyps concl rules] matches the goal - [hyps|-concl] with the set of matching rules [rules]. The - environment [env] and the evar_map [sigma] are used to check - convertibility for pattern variables shared between hypothesis - patterns or the conclusion pattern. *) -let match_goal env sigma hyps concl rules = - let module E = struct - let env = env - let sigma = sigma - end in - let module M = PatternMatching(E) in - M.run (M.match_goal imatching_error hyps concl rules) diff --git a/ltac/tactic_matching.mli b/ltac/tactic_matching.mli deleted file mode 100644 index 090207bcc3..0000000000 --- a/ltac/tactic_matching.mli +++ /dev/null @@ -1,49 +0,0 @@ - (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - Evd.evar_map -> - Term.constr -> - (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 - [hyps|-concl] with the set of matching rules [rules]. The - environment [env] and the evar_map [sigma] are used to check - convertibility for pattern variables shared between hypothesis - patterns or the conclusion pattern. *) -val match_goal: - Environ.env -> - Evd.evar_map -> - 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/ltac/tactic_option.ml b/ltac/tactic_option.ml deleted file mode 100644 index a5ba3b8371..0000000000 --- a/ltac/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/ltac/tactic_option.mli b/ltac/tactic_option.mli deleted file mode 100644 index ed759a76db..0000000000 --- a/ltac/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/ltac/tauto.ml b/ltac/tauto.ml deleted file mode 100644 index 756958c2f0..0000000000 --- a/ltac/tauto.ml +++ /dev/null @@ -1,279 +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 tag_tauto_flags : tauto_flags Val.typ = Val.create "tauto_flags" - -let assoc_flags ist : tauto_flags = - let Val.Dyn (tag, v) = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in - match Val.eq tag tag_tauto_flags with - | None -> assert false - | Some Refl -> v - -(* 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 (Some tac) - in - Proofview.tclINDEPENDENT (Tactics.forward true tac None c) - -let apply c = Tactics.apply c - -let clear id = Tactics.clear [id] - -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 (tag_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 deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/plugins/ltac/Ltac.v b/plugins/ltac/Ltac.v new file mode 100644 index 0000000000..e69de29bb2 diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4 new file mode 100644 index 0000000000..28ff6df838 --- /dev/null +++ b/plugins/ltac/coretactics.ml4 @@ -0,0 +1,329 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ Tactics.intros_reflexivity ] +END + +TACTIC EXTEND exact + [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] +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) ] -> [ Tactics.exact_no_check c ] +END + +TACTIC EXTEND vm_cast_no_check + [ "vm_cast_no_check" constr(c) ] -> [ Tactics.vm_cast_no_check c ] +END + +TACTIC EXTEND native_cast_no_check + [ "native_cast_no_check" constr(c) ] -> [ 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 (fun c -> Tactics.specialize c None) + ] +| [ "specialize" constr_with_bindings(c) "as" intropattern(ipat) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c (Some ipat)) + ] +END + +TACTIC EXTEND symmetry + [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] +END + +TACTIC EXTEND symmetry_in +| [ "symmetry" "in" in_clause(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 + +TACTIC EXTEND intro +| [ "intro" ] -> [ Tactics.intro_move None MoveLast ] +| [ "intro" ident(id) ] -> [ Tactics.intro_move (Some id) MoveLast ] +| [ "intro" ident(id) "at" "top" ] -> [ Tactics.intro_move (Some id) MoveFirst ] +| [ "intro" ident(id) "at" "bottom" ] -> [ Tactics.intro_move (Some id) MoveLast ] +| [ "intro" ident(id) "after" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveAfter h) ] +| [ "intro" ident(id) "before" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveBefore h) ] +| [ "intro" "at" "top" ] -> [ Tactics.intro_move None MoveFirst ] +| [ "intro" "at" "bottom" ] -> [ Tactics.intro_move None MoveLast ] +| [ "intro" "after" hyp(h) ] -> [ Tactics.intro_move None (MoveAfter h) ] +| [ "intro" "before" hyp(h) ] -> [ Tactics.intro_move None (MoveBefore h) ] +END + +(** Move *) + +TACTIC EXTEND move + [ "move" hyp(id) "at" "top" ] -> [ Tactics.move_hyp id MoveFirst ] +| [ "move" hyp(id) "at" "bottom" ] -> [ Tactics.move_hyp id MoveLast ] +| [ "move" hyp(id) "after" hyp(h) ] -> [ Tactics.move_hyp id (MoveAfter h) ] +| [ "move" hyp(id) "before" hyp(h) ] -> [ Tactics.move_hyp id (MoveBefore h) ] +END + +(** Rename *) + +TACTIC EXTEND rename +| [ "rename" ne_rename_list_sep(ids, ",") ] -> [ Tactics.rename_hyp ids ] +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 + +(** Double induction *) + +TACTIC EXTEND double_induction + [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> + [ Elim.h_double_induction h1 h2 ] +END + +(* Admit *) + +TACTIC EXTEND admit + [ "admit" ] -> [ Proofview.give_up ] +END + +(* Fix *) + +TACTIC EXTEND fix + [ "fix" natural(n) ] -> [ Tactics.fix None n ] +| [ "fix" ident(id) natural(n) ] -> [ Tactics.fix (Some id) n ] +END + +(* Cofix *) + +TACTIC EXTEND cofix + [ "cofix" ] -> [ Tactics.cofix None ] +| [ "cofix" ident(id) ] -> [ Tactics.cofix (Some id) ] +END + +(* Clear *) + +TACTIC EXTEND clear + [ "clear" hyp_list(ids) ] -> [ + if List.is_empty ids then Tactics.keep [] + else 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) ] -> [ 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); + "intros", TacIntroPattern (false,[]); + ] + 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/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml new file mode 100644 index 0000000000..c5b26e6d56 --- /dev/null +++ b/plugins/ltac/evar_tactics.ml @@ -0,0 +1,93 @@ +(************************************************************************) +(* 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 (NamedDecl.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/plugins/ltac/evar_tactics.mli b/plugins/ltac/evar_tactics.mli new file mode 100644 index 0000000000..e67540c055 --- /dev/null +++ b/plugins/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/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 new file mode 100644 index 0000000000..53b726432c --- /dev/null +++ b/plugins/ltac/extraargs.ml4 @@ -0,0 +1,389 @@ +(************************************************************************) +(* 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 + CErrors.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 + TYPED AS int list + PRINTED BY pr_int_list_full + + INTERPRETED BY interp_occs + GLOBALIZED BY glob_occs + SUBSTITUTED BY subst_occs + + RAW_PRINTED BY pr_occurrences + 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_PRINTED BY pr_gen + 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 + TYPED AS glob + PRINTED BY pr_globc + + INTERPRETED BY interp_glob + GLOBALIZED BY glob_glob + SUBSTITUTED BY subst_glob + + RAW_PRINTED BY pr_gen + GLOB_PRINTED BY pr_gen + [ lconstr(c) ] -> [ c ] +END + +let interp_casted_constr ist gl c = + interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c + +ARGUMENT EXTEND casted_constr + TYPED AS constr + PRINTED BY pr_gen + INTERPRETED BY interp_casted_constr + [ constr(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_PRINTED BY pr_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 + +let pr_rename _ _ _ (n, m) = Nameops.pr_id n ++ str " into " ++ Nameops.pr_id m + +ARGUMENT EXTEND rename + TYPED AS ident * ident + PRINTED BY pr_rename +| [ ident(n) "into" ident(m) ] -> [ (n, m) ] +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 + +let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl +let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl +let in_clause' = Pltac.in_clause + +ARGUMENT EXTEND in_clause + TYPED AS clause_dft_concl + PRINTED BY pr_in_top_clause + RAW_TYPED AS clause_dft_concl + RAW_PRINTED BY pr_in_clause + GLOB_TYPED AS clause_dft_concl + GLOB_PRINTED BY pr_in_clause +| [ in_clause'(cl) ] -> [ cl ] +END + +(* 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" + | Retroknowledge.Int31Constructor -> assert false + | Retroknowledge.Int31PlusC -> str "plusc" + | Retroknowledge.Int31PlusCarryC -> str "pluscarryc" + | Retroknowledge.Int31Minus -> str "minus" + | Retroknowledge.Int31MinusC -> str "minusc" + | Retroknowledge.Int31MinusCarryC -> str "minuscarryc" + | Retroknowledge.Int31TimesC -> str "timesc" + | Retroknowledge.Int31Div21 -> str "div21" + | Retroknowledge.Int31Div -> str "div" + | Retroknowledge.Int31Diveucl -> str "diveucl" + | Retroknowledge.Int31AddMulDiv -> str "addmuldiv" + | Retroknowledge.Int31Compare -> str "compare" + | Retroknowledge.Int31Head0 -> str "head0" + | Retroknowledge.Int31Tail0 -> str "tail0" + | Retroknowledge.Int31Lor -> str "lor" + | Retroknowledge.Int31Land -> str "land" + | Retroknowledge.Int31Lxor -> str "lxor" + +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) ++ + spc () ++ str "in " ++ qs 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/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli new file mode 100644 index 0000000000..b12187e18a --- /dev/null +++ b/plugins/ltac/extraargs.mli @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Pp.std_ppcmds + +val wit_rename : (Id.t * Id.t) Genarg.uniform_genarg_type + +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 wit_casted_constr : + (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, + Geninterp.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 + +val wit_in_clause : + (Id.t Loc.located Locus.clause_expr, + Id.t Loc.located Locus.clause_expr, + Id.t Locus.clause_expr) Genarg.genarg_type diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 new file mode 100644 index 0000000000..1223f6eb4b --- /dev/null +++ b/plugins/ltac/extratactics.ml4 @@ -0,0 +1,1097 @@ +(************************************************************************) +(* 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 = Pltac.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 mytclWithHoles tac with_evars c = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Tacmach.New.pf_env gl in + let sigma = Tacmach.New.project gl in + let sigma',c = Tactics.force_destruction_arg with_evars env sigma c in + Tacticals.New.tclWITHHOLES with_evars (tac with_evars (Some c)) sigma' + end } + +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 + [ "simplify_eq" ] -> [ dEq false None ] +| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq false c ] +END +TACTIC EXTEND esimplify_eq +| [ "esimplify_eq" ] -> [ dEq true None ] +| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq true c ] +END + +let discr_main c = elimOnConstrWithHoles discr_tac false c + +TACTIC EXTEND discriminate +| [ "discriminate" ] -> [ discr_tac false None ] +| [ "discriminate" destruction_arg(c) ] -> + [ mytclWithHoles discr_tac false c ] +END +TACTIC EXTEND ediscriminate +| [ "ediscriminate" ] -> [ discr_tac true None ] +| [ "ediscriminate" destruction_arg(c) ] -> + [ mytclWithHoles discr_tac true c ] +END + +let discrHyp id = + Proofview.tclEVARMAP >>= fun sigma -> + discr_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } + +let injection_main with_evars c = + elimOnConstrWithHoles (injClause None) with_evars c + +TACTIC EXTEND injection +| [ "injection" ] -> [ injClause None false None ] +| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) false c ] +END +TACTIC EXTEND einjection +| [ "einjection" ] -> [ injClause None true None ] +| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) true c ] +END +TACTIC EXTEND injection_as +| [ "injection" "as" intropattern_list(ipat)] -> + [ injClause (Some ipat) false None ] +| [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] -> + [ mytclWithHoles (injClause (Some ipat)) false c ] +END +TACTIC EXTEND einjection_as +| [ "einjection" "as" intropattern_list(ipat)] -> + [ injClause (Some ipat) true None ] +| [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] -> + [ mytclWithHoles (injClause (Some ipat)) true c ] +END +TACTIC EXTEND simple_injection +| [ "simple" "injection" ] -> [ simpleInjClause false None ] +| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles simpleInjClause false c ] +END + +let injHyp id = + Proofview.tclEVARMAP >>= fun sigma -> + injection_main false { 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 : Geninterp.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 (** This is a global universe context that shouldn't be + refreshed at every use of the hint, declare it globally. *) + (Declare.declare_universe_context false ctx; + Univ.ContextSet.empty) + 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 + +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 + let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in + (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) + +let add_hints_iff l2r lc n bl = + let l = Locality.LocalityFixme.consume () in + Hints.add_hints (Locality.make_module_locality l) 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 constr_flags = { + Pretyping.use_typeclasses = true; + Pretyping.solve_unification_constraints = true; + Pretyping.use_hook = Some Pfedit.solve_by_implicit_tactic; + Pretyping.fail_evar = false; + Pretyping.expand_evars = true } + +let refine_tac ist simple with_classes 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 = + { constr_flags with Pretyping.use_typeclasses = with_classes } in + let expected_type = Pretyping.OfType concl 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:true 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 true c ] +END + +TACTIC EXTEND simple_refine +| [ "simple" "refine" uconstr(c) ] -> + [ refine_tac ist true true c ] +END + +TACTIC EXTEND notcs_refine +| [ "notypeclasses" "refine" uconstr(c) ] -> + [ refine_tac ist false false c ] +END + +TACTIC EXTEND notcs_simple_refine +| [ "simple" "notypeclasses" "refine" uconstr(c) ] -> + [ refine_tac ist true false c ] +END + +(* Solve unification constraints using heuristics or fail if any remain *) +TACTIC EXTEND solve_constraints +[ "solve_constraints" ] -> [ Refine.solve_constraints ] +END + +(**********************************************************************) +(* Inversion lemmas (Leminv) *) + +open Inv +open Leminv + +let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater + +VERNAC ARGUMENT EXTEND sort +| [ "Set" ] -> [ GSet ] +| [ "Prop" ] -> [ GProp ] +| [ "Type" ] -> [ GType [] ] +END + +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 + +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 + +let cache_implicit_tactic (_,tac) = match tac with + | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac) + | None -> Pfedit.clear_implicit_tactic () + +let subst_implicit_tactic (subst,tac) = + Option.map (Tacsubst.subst_tactic subst) tac + +let inImplicitTactic : glob_tactic_expr option -> obj = + declare_object {(default_object "IMPLICIT-TACTIC") with + open_function = (fun i o -> if Int.equal i 1 then cache_implicit_tactic o); + cache_function = cache_implicit_tactic; + subst_function = subst_implicit_tactic; + classify_function = (fun o -> Dispose)} + +let declare_implicit_tactic tac = + Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac))) + +let clear_implicit_tactic () = + Lib.add_anonymous_leaf (inImplicitTactic None) + +VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF +| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ declare_implicit_tactic tac ] +| [ "Clear" "Implicit" "Tactic" ] -> [ 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) ] -> [ 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) = CErrors.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 CErrors.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 + [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) ] -> + [ Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> + match Evarutil.kind_of_term_upto sigma x with + | Evar _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar") + end + ] +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;; + +TACTIC EXTEND is_ind +| [ "is_ind" constr(x) ] -> + [ match kind_of_term x with + | Ind _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") ] +END;; + +TACTIC EXTEND is_constructor +| [ "is_constructor" constr(x) ] -> + [ match kind_of_term x with + | Construct _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") ] +END;; + +TACTIC EXTEND is_proj +| [ "is_proj" constr(x) ] -> + [ match kind_of_term x with + | Proj _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") ] +END;; + +TACTIC EXTEND is_const +| [ "is_const" constr(x) ] -> + [ match kind_of_term x with + | Const _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") ] +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" ] + => [ Vernac_classifier.classify_as_proofstep ] + -> [ 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" ] + => [ Vernac_classifier.classify_as_proofstep ] + -> [ 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 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 (Pputils.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 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_PRINTED BY pr_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" ] -> [ Feedback.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/plugins/ltac/extratactics.mli b/plugins/ltac/extratactics.mli new file mode 100644 index 0000000000..18334dafe7 --- /dev/null +++ b/plugins/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/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 new file mode 100644 index 0000000000..a37cf306e1 --- /dev/null +++ b/plugins/ltac/g_auto.ml4 @@ -0,0 +1,228 @@ +(************************************************************************) +(* 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; + solve_unification_constraints = 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 + +let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr +let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr c) +let pr_auto_using _ _ _ = Pptactic.pr_auto_using Printer.pr_closed_glob + +ARGUMENT EXTEND auto_using + TYPED AS uconstr_list + PRINTED BY pr_auto_using + RAW_TYPED AS uconstr_list + RAW_PRINTED BY pr_auto_using_raw + GLOB_TYPED AS uconstr_list + GLOB_PRINTED BY pr_auto_using_glob +| [ "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_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_reference +let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global +let glob_hints_path_atom ist = Hints.glob_hints_path_atom + +ARGUMENT EXTEND hints_path_atom + PRINTED BY pr_hints_path_atom + + GLOBALIZED BY glob_hints_path_atom + + RAW_PRINTED BY pr_pre_hints_path_atom + GLOB_PRINTED BY pr_hints_path_atom +| [ ne_global_list(g) ] -> [ Hints.PathHints g ] +| [ "_" ] -> [ Hints.PathAny ] +END + +let pr_hints_path prc prx pry c = Hints.pp_hints_path c +let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_reference c +let glob_hints_path ist = Hints.glob_hints_path + +ARGUMENT EXTEND hints_path +PRINTED BY pr_hints_path + +GLOBALIZED BY glob_hints_path +RAW_PRINTED BY pr_pre_hints_path +GLOB_PRINTED BY pr_hints_path + +| [ "(" hints_path(p) ")" ] -> [ p ] +| [ hints_path(p) "*" ] -> [ Hints.PathStar p ] +| [ "emp" ] -> [ Hints.PathEmpty ] +| [ "eps" ] -> [ Hints.PathEpsilon ] +| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] +| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] +| [ hints_path(p) hints_path(q) ] -> [ Hints.PathSeq (p, q) ] +END + +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 (Hints.glob_hints_path 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/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4 new file mode 100644 index 0000000000..a28132a4b0 --- /dev/null +++ b/plugins/ltac/g_class.ml4 @@ -0,0 +1,120 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + 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_search_strategy _prc _prlc _prt = function + | Some Dfs -> Pp.str "dfs" + | Some Bfs -> Pp.str "bfs" + | None -> Pp.mt () + +ARGUMENT EXTEND eauto_search_strategy PRINTED BY pr_search_strategy +| [ "(bfs)" ] -> [ Some Bfs ] +| [ "(dfs)" ] -> [ Some Dfs ] +| [ ] -> [ None ] +END + +(* true = All transparent, false = Opaque if possible *) + +VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF + | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> [ + set_typeclasses_debug d; + Option.iter set_typeclasses_strategy s; + set_typeclasses_depth depth + ] +END + +(** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *) +TACTIC EXTEND typeclasses_eauto + | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] -> + [ typeclasses_eauto ~strategy:Bfs ~depth:d l ] + | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> + [ typeclasses_eauto ~depth:d l ] + | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> [ + typeclasses_eauto ~only_classes:true ~depth:d [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 + +(** TODO: DEPRECATE *) +(* A progress test that allows to see if the evars have changed *) +open Term +open Proofview.Goal +open Proofview.Notations + +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 (Pp.str"No progress made (modulo evars)") + else Proofview.tclUNIT () + end } + in t <*> check + end } + +TACTIC EXTEND progress_evars + [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] +END diff --git a/plugins/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.ml4 new file mode 100644 index 0000000000..905653281c --- /dev/null +++ b/plugins/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/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 new file mode 100644 index 0000000000..54229bb2ae --- /dev/null +++ b/plugins/ltac/g_ltac.ml4 @@ -0,0 +1,526 @@ +(************************************************************************) +(* 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 Stdarg.wit_intro_pattern) pat +let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c +let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac + +let reference_to_id = function + | Libnames.Ident (loc, id) -> (loc, id) + | Libnames.Qualid (loc,_) -> + CErrors.user_err ~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 + e + +let toplevel_selector = new_entry "vernac:toplevel_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 *) + +let hint = G_proofs.hint + +let warn_deprecated_appcontext = + CWarnings.create ~name:"deprecated-appcontext" ~category:"deprecated" + (fun () -> strbrk "appcontext is deprecated and will be removed " ++ + strbrk "in a future version") + +GEXTEND Gram + GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint + tactic_mode constr_may_eval constr_eval toplevel_selector + operconstr; + + 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) + | sel = selector; ta = tactic_expr -> TacSelect (sel, ta) ] +(*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 + | c = Constr.constr -> (match c with CRef (r,None) -> Reference r | c -> ConstrMayEval (ConstrTerm c)) + (* Unambiguous 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; "]" -> + warn_deprecated_appcontext ~loc:!@loc (); + 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 Tacexpr.TacticRedefinition (name, TacFun (it, body)) + else + let id = reference_to_id name in + Tacexpr.TacticDefinition (id, TacFun (it, body)) + | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> + if redef then Tacexpr.TacticRedefinition (name, body) + else + let id = reference_to_id name in + Tacexpr.TacticDefinition (id, body) + ] ] + ; + tactic: + [ [ tac = tactic_expr -> tac ] ] + ; + + range_selector: + [ [ n = natural ; "-" ; m = natural -> (n, m) + | n = natural -> (n, n) ] ] + ; + (* We unfold a range selectors list once so that we can make a special case + * for a unique SelectNth selector. *) + range_selector_or_nth: + [ [ n = natural ; "-" ; m = natural; + l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> + SelectList ((n, m) :: Option.default [] l) + | n = natural; + l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> + Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ] + ; + selector_body: + [ [ l = range_selector_or_nth -> l + | test_bracket_ident; "["; id = ident; "]" -> SelectId id ] ] + ; + selector: + [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] + ; + toplevel_selector: + [ [ sel = selector_body; ":" -> sel + | IDENT "all"; ":" -> SelectAll ] ] + ; + tactic_mode: + [ [ g = OPT toplevel_selector; tac = G_vernac.subgoal_command -> tac g ] ] + ; + command: + [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; + l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> + Vernacexpr.VernacProof (Some (in_tac ta), G_proofs.hint_proof_using G_vernac.section_subset_expr l) + | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; + ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] -> + Vernacexpr.VernacProof (ta,Some l) ] ] + ; + hint: + [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; + tac = Pltac.tactic -> + Vernacexpr.HintsExtern (n,c, in_tac tac) ] ] + ; + operconstr: LEVEL "0" + [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> + let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in + CHole (!@loc, None, IntroAnonymous, Some arg) ] ] + ; + END + +open Stdarg +open Tacarg +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 | SelectList _ -> 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 Feedback.feedback Feedback.AddedAxiom + +let pr_range_selector (i, j) = + if Int.equal i j then int i + else int i ++ str "-" ++ int j + +let pr_ltac_selector = function +| SelectNth i -> int i ++ str ":" +| SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ + str "]" ++ str ":" +| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" +| SelectAll -> str "all" ++ str ":" + +VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector +| [ toplevel_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 (* Bug: a space is inserted before "..." *) str ".." else mt () + +VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default +| [ "." ] -> [ false ] +| [ "..." ] -> [ true ] +END + +let is_anonymous_abstract = function + | TacAbstract (_,None) -> true + | TacSolve [TacAbstract (_,None)] -> true + | _ -> false +let rm_abstract = function + | TacAbstract (t,_) -> t + | TacSolve [TacAbstract (t,_)] -> TacSolve [t] + | x -> x +let is_explicit_terminator = function TacSolve _ -> true | _ -> false + +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) ] => + [ + let anon_abstracting_tac = is_anonymous_abstract t in + let solving_tac = is_explicit_terminator t in + let parallel = `Yes (solving_tac,anon_abstracting_tac) in + let pbr = if solving_tac then Some "par" else None in + VtProofStep{ parallel = parallel; proof_block_detection = pbr }, + VtLater + ] -> [ + let t = rm_abstract t in + 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 +| Tacentries.TacTerm s -> quote (str s) +| Tacentries.TacNonTerm (_, (arg, sep), id) -> + let sep = match sep with + | 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) ] -> [ Tacentries.TacTerm s ] +| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> + [ Tacentries.TacNonTerm (loc, (Names.Id.to_string nt, sep), p) ] +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) ] -> + [ Feedback.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 + +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 + +VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY +| [ "Print" "Ltac" "Signatures" ] -> [ Tacentries.print_ltacs () ] +END diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4 new file mode 100644 index 0000000000..d286a58708 --- /dev/null +++ b/plugins/ltac/g_obligations.ml4 @@ -0,0 +1,161 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + snd (get_default_tactic ()) + end in + Obligations.default_tactic := tac + +let with_tac f tac = + let env = { Genintern.genv = Global.env (); ltacvars = Names.Id.Set.empty } in + let tac = match tac with + | None -> None + | Some tac -> + let tac = Genarg.in_gen (Genarg.rawwit wit_ltac) tac in + let _, tac = Genintern.generic_intern env tac in + Some tac + in + f 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 = Pltac + +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 obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac +let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac + +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" ] -> [ + Feedback.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) ] -> [ Feedback.msg_info (show_term (Some name)) ] +| [ "Preterm" ] -> [ Feedback.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/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 new file mode 100644 index 0000000000..b1c4f58eb8 --- /dev/null +++ b/plugins/ltac/g_rewrite.ml4 @@ -0,0 +1,274 @@ +(************************************************************************) +(* 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 prc prlc _ (s : raw_strategy) = + let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_reference, prc) in + Rewrite.pr_strategy prc prr s +let pr_glob_strategy prc prlc _ (s : glob_strategy) = + let prr = Pptactic.pr_red_expr + (Ppconstr.pr_constr_expr, + Ppconstr.pr_lconstr_expr, + Pputils.pr_or_by_notation Libnames.pr_reference, + Ppconstr.pr_constr_expr) + in + Rewrite.pr_strategy prc prr s + +ARGUMENT EXTEND rewstrategy + PRINTED BY pr_strategy + + INTERPRETED BY interp_strategy + GLOBALIZED BY glob_strategy + SUBSTITUTED BY subst_strategy + + RAW_PRINTED BY pr_raw_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)) + +TACTIC EXTEND rewrite_strat +| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] +| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] +| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ] +| [ "rewrite_db" preident(db) ] -> [ 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 + | _ -> Proofview.V82.of_tactic (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) ] + -> [ cl_rewrite_clause c o AllOccurrences None ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> + [ cl_rewrite_clause c o AllOccurrences (Some id) ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> + [ cl_rewrite_clause c o (occurrences_of occ) None ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> + [ 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)] -> + [ 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) + +let () = + let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in + let printer _ _ _ _ = Pp.str "" in + Pptactic.declare_extra_genarg_pprule wit_binders raw_printer printer printer + +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) ] -> [ Feedback.msg_notice (Autorewrite.print_rewrite_hintdb s) ] +END diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 new file mode 100644 index 0000000000..685c07c9a8 --- /dev/null +++ b/plugins/ltac/g_tactic.ml4 @@ -0,0 +1,665 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* "; "<-" ; "by" ] +let _ = List.iter CLexer.add_keyword tactic_kw + +let err () = raise Stream.Failure + +(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) +(* admissible notation "(x t)" *) +let test_lpar_id_coloneq = + 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 ()) + +(* 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" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ | INT _ -> + (match get_tok (stream_nth 2 strm) with + | KEYWORD ":=" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + +(* idem for (x:t) *) +let test_lpar_id_colon = + Gram.Entry.of_parser "lpar_id_colon" + (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 (x1..xn:t) [n^2 complexity but exceptional use] *) +let check_for_coloneq = + Gram.Entry.of_parser "lpar_id_colon" + (fun strm -> + let rec skip_to_rpar p n = + match get_tok (List.last (Stream.npeek n strm)) with + | KEYWORD "(" -> skip_to_rpar (p+1) (n+1) + | KEYWORD ")" -> if Int.equal p 0 then n+1 else skip_to_rpar (p-1) (n+1) + | KEYWORD "." -> err () + | _ -> skip_to_rpar p (n+1) in + let rec skip_names n = + match get_tok (List.last (Stream.npeek n strm)) with + | IDENT _ | KEYWORD "_" -> skip_names (n+1) + | KEYWORD ":" -> skip_to_rpar 0 (n+1) (* skip a constr *) + | _ -> err () in + let rec skip_binders n = + match get_tok (List.last (Stream.npeek n strm)) with + | KEYWORD "(" -> skip_binders (skip_names (n+1)) + | IDENT _ | KEYWORD "_" -> skip_binders (n+1) + | KEYWORD ":=" -> () + | _ -> err () in + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> skip_binders 2 + | _ -> err ()) + +let lookup_at_as_comma = + Gram.Entry.of_parser "lookup_at_as_comma" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD (","|"at"|"as") -> () + | _ -> err ()) + +open Constr +open Prim +open Pltac + +let mk_fix_tac (loc,id,bl,ann,ty) = + let n = + match bl,ann with + [([_],_,_)], None -> 1 + | _, Some x -> + let ids = List.map snd (List.flatten (List.map pi1 bl)) in + (try List.index Names.Name.equal (snd x) ids + with Not_found -> error "No such fix variable.") + | _ -> error "Cannot guess decreasing argument of fix." in + (id,n,CProdN(loc,bl,ty)) + +let mk_cofix_tac (loc,id,bl,ann,ty) = + let _ = Option.map (fun (aloc,_) -> + user_err ~loc:aloc + ~hdr:"Constr:mk_cofix_tac" + (Pp.str"Annotation forbidden in cofix expression.")) ann in + (id,CProdN(loc,bl,ty)) + +(* Functions overloaded by quotifier *) +let destruction_arg_of_constr (c,lbind as clbind) = match lbind with + | NoBindings -> + begin + try ElimOnIdent (Constrexpr_ops.constr_loc c,snd(Constrexpr_ops.coerce_to_id c)) + with e when CErrors.noncritical e -> ElimOnConstr clbind + end + | _ -> ElimOnConstr clbind + +let mkTacCase with_evar = function + | [(clear,ElimOnConstr cl),(None,None),None],None -> + TacCase (with_evar,(clear,cl)) + (* Reinterpret numbers as a notation for terms *) + | [(clear,ElimOnAnonHyp n),(None,None),None],None -> + TacCase (with_evar, + (clear,(CPrim (Loc.ghost, Numeral (Bigint.of_int n)), + NoBindings))) + (* Reinterpret ident as notations for variables in the context *) + (* because we don't know if they are quantified or not *) + | [(clear,ElimOnIdent id),(None,None),None],None -> + TacCase (with_evar,(clear,(CRef (Ident id,None),NoBindings))) + | ic -> + if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic) + then + error "Use of numbers as direct arguments of 'case' is not supported."; + TacInductionDestruct (false,with_evar,ic) + +let rec mkCLambdaN_simple_loc loc bll c = + match bll with + | ((loc1,_)::_ as idl,bk,t) :: bll -> + CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (Loc.merge loc1 loc) bll c) + | ([],_,_) :: bll -> mkCLambdaN_simple_loc loc bll c + | [] -> c + +let mkCLambdaN_simple bl c = match bl with + | [] -> c + | h :: _ -> + let loc = Loc.merge (fst (List.hd (pi1 h))) (Constrexpr_ops.constr_loc c) in + mkCLambdaN_simple_loc loc bl c + +let loc_of_ne_list l = Loc.merge (fst (List.hd l)) (fst (List.last l)) + +let map_int_or_var f = function + | ArgArg x -> ArgArg (f x) + | ArgVar _ as y -> y + +let all_concl_occs_clause = { onhyps=Some[]; concl_occs=AllOccurrences } + +let merge_occurrences loc cl = function + | None -> + if Locusops.clause_with_generic_occurrences cl then (None, cl) + else + user_err ~loc (str "Found an \"at\" clause without \"with\" clause.") + | Some (occs, p) -> + let ans = match occs with + | AllOccurrences -> cl + | _ -> + begin match cl with + | { onhyps = Some []; concl_occs = AllOccurrences } -> + { onhyps = Some []; concl_occs = occs } + | { onhyps = Some [(AllOccurrences, id), l]; concl_occs = NoOccurrences } -> + { cl with onhyps = Some [(occs, id), l] } + | _ -> + if Locusops.clause_with_generic_occurrences cl then + user_err ~loc (str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") + else + user_err ~loc (str "Cannot use clause \"at\" twice.") + end + in + (Some p, ans) + +let warn_deprecated_eqn_syntax = + CWarnings.create ~name:"deprecated-eqn-syntax" ~category:"deprecated" + (fun arg -> strbrk (Printf.sprintf "Syntax \"_eqn:%s\" is deprecated. Please use \"eqn:%s\" instead." arg arg)) + +(* Auxiliary grammar rules *) + +open Vernac_ + +GEXTEND Gram + GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis + bindings red_expr int_or_var open_constr uconstr + simple_intropattern in_clause clause_dft_concl hypident destruction_arg; + + int_or_var: + [ [ n = integer -> ArgArg n + | id = identref -> ArgVar id ] ] + ; + nat_or_var: + [ [ n = natural -> ArgArg n + | id = identref -> ArgVar id ] ] + ; + (* An identifier or a quotation meta-variable *) + id_or_meta: + [ [ id = identref -> id ] ] + ; + open_constr: + [ [ c = constr -> c ] ] + ; + uconstr: + [ [ c = constr -> c ] ] + ; + destruction_arg: + [ [ n = natural -> (None,ElimOnAnonHyp n) + | test_lpar_id_rpar; c = constr_with_bindings -> + (Some false,destruction_arg_of_constr c) + | c = constr_with_bindings_arg -> on_snd destruction_arg_of_constr c + ] ] + ; + constr_with_bindings_arg: + [ [ ">"; c = constr_with_bindings -> (Some true,c) + | c = constr_with_bindings -> (None,c) ] ] + ; + quantified_hypothesis: + [ [ id = ident -> NamedHyp id + | n = natural -> AnonHyp n ] ] + ; + conversion: + [ [ c = constr -> (None, c) + | c1 = constr; "with"; c2 = constr -> (Some (AllOccurrences,c1),c2) + | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr -> + (Some (occs,c1), c2) ] ] + ; + occs_nums: + [ [ nl = LIST1 nat_or_var -> OnlyOccurrences nl + | "-"; n = nat_or_var; nl = LIST0 int_or_var -> + (* have used int_or_var instead of nat_or_var for compatibility *) + AllOccurrencesBut (List.map (map_int_or_var abs) (n::nl)) ] ] + ; + occs: + [ [ "at"; occs = occs_nums -> occs | -> AllOccurrences ] ] + ; + pattern_occ: + [ [ c = constr; nl = occs -> (nl,c) ] ] + ; + ref_or_pattern_occ: + (* If a string, it is interpreted as a ref + (anyway a Coq string does not reduce) *) + [ [ c = smart_global; nl = occs -> nl,Inl c + | c = constr; nl = occs -> nl,Inr c ] ] + ; + unfold_occ: + [ [ c = smart_global; nl = occs -> (nl,c) ] ] + ; + intropatterns: + [ [ l = LIST0 nonsimple_intropattern -> l ]] + ; + ne_intropatterns: + [ [ l = LIST1 nonsimple_intropattern -> l ]] + ; + or_and_intropattern: + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> IntroOrPattern tc + | "()" -> IntroAndPattern [] + | "("; si = simple_intropattern; ")" -> IntroAndPattern [si] + | "("; si = simple_intropattern; ","; + 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 (IntroAndPattern (pairify q))))] + in IntroAndPattern (pairify (si::tc)) ] ] + ; + equality_intropattern: + [ [ "->" -> IntroRewrite true + | "<-" -> IntroRewrite false + | "[="; tc = intropatterns; "]" -> IntroInjection tc ] ] + ; + naming_intropattern: + [ [ prefix = pattern_ident -> IntroFresh prefix + | "?" -> IntroAnonymous + | id = ident -> IntroIdentifier id ] ] + ; + nonsimple_intropattern: + [ [ l = simple_intropattern -> l + | "*" -> !@loc, IntroForthcoming true + | "**" -> !@loc, IntroForthcoming false ]] + ; + simple_intropattern: + [ [ 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 + 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 = naming_intropattern -> !@loc, IntroNaming pat ] ] + ; + simple_binding: + [ [ "("; id = ident; ":="; c = lconstr; ")" -> (!@loc, NamedHyp id, c) + | "("; n = natural; ":="; c = lconstr; ")" -> (!@loc, AnonHyp n, c) ] ] + ; + bindings: + [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> + ExplicitBindings bl + | bl = LIST1 constr -> ImplicitBindings bl ] ] + ; + constr_with_bindings: + [ [ c = constr; l = with_bindings -> (c, l) ] ] + ; + with_bindings: + [ [ "with"; bl = bindings -> bl | -> NoBindings ] ] + ; + red_flags: + [ [ IDENT "beta" -> [FBeta] + | IDENT "iota" -> [FMatch;FFix;FCofix] + | IDENT "match" -> [FMatch] + | IDENT "fix" -> [FFix] + | IDENT "cofix" -> [FCofix] + | IDENT "zeta" -> [FZeta] + | IDENT "delta"; d = delta_flag -> [d] + ] ] + ; + delta_flag: + [ [ "-"; "["; idl = LIST1 smart_global; "]" -> FDeltaBut idl + | "["; idl = LIST1 smart_global; "]" -> FConst idl + | -> FDeltaBut [] + ] ] + ; + strategy_flag: + [ [ s = LIST1 red_flags -> Redops.make_red_flag (List.flatten s) + | d = delta_flag -> all_with d + ] ] + ; + red_expr: + [ [ 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 + | s = IDENT -> ExtraRedExpr s ] ] + ; + hypident: + [ [ id = id_or_meta -> + id,InHyp + | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> + id,InHypTypeOnly + | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> + id,InHypValueOnly + ] ] + ; + hypident_occ: + [ [ (id,l)=hypident; occs=occs -> ((occs,id),l) ] ] + ; + in_clause: + [ [ "*"; occs=occs -> + {onhyps=None; concl_occs=occs} + | "*"; "|-"; occs=concl_occ -> + {onhyps=None; concl_occs=occs} + | hl=LIST0 hypident_occ SEP","; "|-"; occs=concl_occ -> + {onhyps=Some hl; concl_occs=occs} + | hl=LIST0 hypident_occ SEP"," -> + {onhyps=Some hl; concl_occs=NoOccurrences} ] ] + ; + clause_dft_concl: + [ [ "in"; cl = in_clause -> cl + | occs=occs -> {onhyps=Some[]; concl_occs=occs} + | -> all_concl_occs_clause ] ] + ; + clause_dft_all: + [ [ "in"; cl = in_clause -> cl + | -> {onhyps=None; concl_occs=AllOccurrences} ] ] + ; + opt_clause: + [ [ "in"; cl = in_clause -> Some cl + | "at"; occs = occs_nums -> Some {onhyps=Some[]; concl_occs=occs} + | -> None ] ] + ; + concl_occ: + [ [ "*"; occs = occs -> occs + | -> NoOccurrences ] ] + ; + in_hyp_list: + [ [ "in"; idl = LIST1 id_or_meta -> idl + | -> [] ] ] + ; + in_hyp_as: + [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) + | -> None ] ] + ; + orient: + [ [ "->" -> true + | "<-" -> false + | -> true ]] + ; + simple_binder: + [ [ na=name -> ([na],Default Explicit,CHole (!@loc, Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None)) + | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c) + ] ] + ; + fixdecl: + [ [ "("; id = ident; bl=LIST0 simple_binder; ann=fixannot; + ":"; ty=lconstr; ")" -> (!@loc, id, bl, ann, ty) ] ] + ; + fixannot: + [ [ "{"; IDENT "struct"; id=name; "}" -> Some id + | -> None ] ] + ; + cofixdecl: + [ [ "("; id = ident; bl=LIST0 simple_binder; ":"; ty=lconstr; ")" -> + (!@loc, id, bl, None, ty) ] ] + ; + bindings_with_parameters: + [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; + ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ] + ; + eliminator: + [ [ "using"; el = constr_with_bindings -> el ] ] + ; + as_ipat: + [ [ "as"; ipat = simple_intropattern -> Some ipat + | -> None ] ] + ; + or_and_intropattern_loc: + [ [ ipat = or_and_intropattern -> ArgArg (!@loc,ipat) + | locid = identref -> ArgVar locid ] ] + ; + as_or_and_ipat: + [ [ "as"; ipat = or_and_intropattern_loc -> Some ipat + | -> None ] ] + ; + eqn_ipat: + [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (!@loc, pat) + | IDENT "_eqn"; ":"; pat = naming_intropattern -> + let loc = !@loc in + warn_deprecated_eqn_syntax ~loc "H"; Some (loc, pat) + | IDENT "_eqn" -> + let loc = !@loc in + warn_deprecated_eqn_syntax ~loc "?"; Some (loc, IntroAnonymous) + | -> None ] ] + ; + as_name: + [ [ "as"; id = ident -> Names.Name id | -> Names.Anonymous ] ] + ; + by_tactic: + [ [ "by"; tac = tactic_expr LEVEL "3" -> Some tac + | -> None ] ] + ; + rewriter : + [ [ "!"; c = constr_with_bindings_arg -> (RepeatPlus,c) + | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,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_arg -> (Precisely 1, c) + ] ] + ; + oriented_rewriter : + [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ] + ; + induction_clause: + [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; + cl = opt_clause -> (c,(eq,pat),cl) ] ] + ; + induction_clause_list: + [ [ ic = LIST1 induction_clause SEP ","; el = OPT eliminator; + cl_tolerance = opt_clause -> + (* Condition for accepting "in" at the end by compatibility *) + match ic,el,cl_tolerance with + | [c,pat,None],Some _,Some _ -> ([c,pat,cl_tolerance],el) + | _,_,Some _ -> err () + | _,_,None -> (ic,el) ]] + ; + simple_tactic: + [ [ + (* Basic tactics *) + IDENT "intros"; pl = ne_intropatterns -> + TacAtom (!@loc, TacIntroPattern (false,pl)) + | IDENT "intros" -> + TacAtom (!@loc, TacIntroPattern (false,[!@loc,IntroForthcoming false])) + | IDENT "eintros"; pl = ne_intropatterns -> + TacAtom (!@loc, TacIntroPattern (true,pl)) + + | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,false,cl,inhyp)) + | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,true,cl,inhyp)) + | IDENT "simple"; IDENT "apply"; + cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,false,cl,inhyp)) + | IDENT "simple"; IDENT "eapply"; + cl = LIST1 constr_with_bindings_arg SEP","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,true,cl,inhyp)) + | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> + TacAtom (!@loc, TacElim (false,cl,el)) + | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> + 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"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> + TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd)) + | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> + TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd)) + + | IDENT "pose"; (id,b) = bindings_with_parameters -> + TacAtom (!@loc, TacLetTac (Names.Name id,b,Locusops.nowhere,true,None)) + | IDENT "pose"; b = constr; na = as_name -> + TacAtom (!@loc, TacLetTac (na,b,Locusops.nowhere,true,None)) + | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> + TacAtom (!@loc, TacLetTac (Names.Name id,c,p,true,None)) + | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> + TacAtom (!@loc, TacLetTac (na,c,p,true,None)) + | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; + p = clause_dft_all -> + TacAtom (!@loc, TacLetTac (na,c,p,false,e)) + + (* Alternative syntax for "pose proof c as id" *) + | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; + c = lconstr; ")" -> + TacAtom (!@loc, TacAssert (true,None,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + + (* Alternative syntax for "assert c as id by tac" *) + | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + TacAtom (!@loc, TacAssert (true,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + + (* Alternative syntax for "enough c as id by tac" *) + | IDENT "enough"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + TacAtom (!@loc, TacAssert (false,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + + | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> + TacAtom (!@loc, TacAssert (true,Some tac,ipat,c)) + | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> + TacAtom (!@loc, TacAssert (true,None,ipat,c)) + | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> + TacAtom (!@loc, TacAssert (false,Some tac,ipat,c)) + + | IDENT "generalize"; c = constr -> + TacAtom (!@loc, TacGeneralize [((AllOccurrences,c),Names.Anonymous)]) + | IDENT "generalize"; c = constr; l = LIST1 constr -> + let gen_everywhere c = ((AllOccurrences,c),Names.Anonymous) in + TacAtom (!@loc, TacGeneralize (List.map gen_everywhere (c::l))) + | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs; + na = as_name; + l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] -> + TacAtom (!@loc, TacGeneralize (((nl,c),na)::l)) + + (* Derived basic tactics *) + | IDENT "induction"; ic = induction_clause_list -> + TacAtom (!@loc, TacInductionDestruct (true,false,ic)) + | IDENT "einduction"; ic = induction_clause_list -> + TacAtom (!@loc, TacInductionDestruct(true,true,ic)) + | IDENT "destruct"; icl = induction_clause_list -> + TacAtom (!@loc, TacInductionDestruct(false,false,icl)) + | IDENT "edestruct"; icl = induction_clause_list -> + TacAtom (!@loc, TacInductionDestruct(false,true,icl)) + + (* Equality and inversion *) + | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; + cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t)) + | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; + cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (true,l,cl,t)) + | IDENT "dependent"; k = + [ IDENT "simple"; IDENT "inversion" -> SimpleInversion + | IDENT "inversion" -> FullInversion + | IDENT "inversion_clear" -> FullInversionClear ]; + hyp = quantified_hypothesis; + ids = as_or_and_ipat; co = OPT ["with"; c = constr -> c] -> + TacAtom (!@loc, TacInversion (DepInversion (k,co,ids),hyp)) + | IDENT "simple"; IDENT "inversion"; + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + TacAtom (!@loc, TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) + | IDENT "inversion"; + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + TacAtom (!@loc, TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) + | IDENT "inversion_clear"; + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + TacAtom (!@loc, TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) + | IDENT "inversion"; hyp = quantified_hypothesis; + "using"; c = constr; cl = in_hyp_list -> + TacAtom (!@loc, TacInversion (InversionUsing (c,cl), hyp)) + + (* Conversion *) + | 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 + TacAtom (!@loc, TacChange (p,c,cl)) + ] ] + ; +END;; diff --git a/plugins/ltac/ltac_plugin.mllib b/plugins/ltac/ltac_plugin.mllib new file mode 100644 index 0000000000..af1c7149da --- /dev/null +++ b/plugins/ltac/ltac_plugin.mllib @@ -0,0 +1,27 @@ +Tacarg +Pptactic +Pltac +Taccoerce +Tacsubst +Tacenv +Tactic_debug +Tacintern +Tacentries +Profile_ltac +Tactic_matching +Tacinterp +Evar_tactics +Tactic_option +Extraargs +G_obligations +Coretactics +Extratactics +Profile_ltac_tactics +G_auto +G_class +Rewrite +G_rewrite +Tauto +G_eqdecide +G_tactic +G_ltac diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml new file mode 100644 index 0000000000..1d21118ae8 --- /dev/null +++ b/plugins/ltac/pltac.ml @@ -0,0 +1,65 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Gram.entry table *) +(* Typically for tactic user extensions *) +let open_constr = + make_gen_entry utactic "open_constr" +let constr_with_bindings = + make_gen_entry utactic "constr_with_bindings" +let bindings = + make_gen_entry utactic "bindings" +let hypident = Gram.entry_create "hypident" +let constr_may_eval = make_gen_entry utactic "constr_may_eval" +let constr_eval = make_gen_entry utactic "constr_eval" +let uconstr = + make_gen_entry utactic "uconstr" +let quantified_hypothesis = + make_gen_entry utactic "quantified_hypothesis" +let destruction_arg = make_gen_entry utactic "destruction_arg" +let int_or_var = make_gen_entry utactic "int_or_var" +let simple_intropattern = + make_gen_entry utactic "simple_intropattern" +let in_clause = make_gen_entry utactic "in_clause" +let clause_dft_concl = + make_gen_entry utactic "clause" + + +(* Main entries for ltac *) +let tactic_arg = Gram.entry_create "tactic:tactic_arg" +let tactic_expr = make_gen_entry utactic "tactic_expr" +let binder_tactic = make_gen_entry utactic "binder_tactic" + +let tactic = make_gen_entry utactic "tactic" + +(* Main entry for quotations *) +let tactic_eoi = eoi_entry tactic + +let () = + let open Stdarg in + let open Tacarg in + register_grammar wit_int_or_var (int_or_var); + register_grammar wit_intro_pattern (simple_intropattern); + register_grammar wit_quant_hyp (quantified_hypothesis); + register_grammar wit_uconstr (uconstr); + register_grammar wit_open_constr (open_constr); + register_grammar wit_constr_with_bindings (constr_with_bindings); + register_grammar wit_bindings (bindings); + register_grammar wit_tactic (tactic); + register_grammar wit_ltac (tactic); + register_grammar wit_clause_dft_concl (clause_dft_concl); + register_grammar wit_destruction_arg (destruction_arg); + () diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli new file mode 100644 index 0000000000..810e1ec39a --- /dev/null +++ b/plugins/ltac/pltac.mli @@ -0,0 +1,38 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + (tolerability -> raw_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a glob_extra_genarg_printer = + (glob_constr_and_expr -> std_ppcmds) -> + (glob_constr_and_expr -> std_ppcmds) -> + (tolerability -> glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a extra_genarg_printer = + (Term.constr -> std_ppcmds) -> + (Term.constr -> std_ppcmds) -> + (tolerability -> Val.t -> std_ppcmds) -> + 'a -> std_ppcmds + +module Make + (Ppconstr : Ppconstrsig.Pp) + (Taggers : sig + val tag_keyword + : std_ppcmds -> std_ppcmds + val tag_primitive + : std_ppcmds -> std_ppcmds + val tag_string + : std_ppcmds -> std_ppcmds + val tag_glob_tactic_expr + : glob_tactic_expr -> std_ppcmds -> std_ppcmds + val tag_glob_atomic_tactic_expr + : glob_atomic_tactic_expr -> std_ppcmds -> std_ppcmds + val tag_raw_tactic_expr + : raw_tactic_expr -> std_ppcmds -> std_ppcmds + val tag_raw_atomic_tactic_expr + : raw_atomic_tactic_expr -> std_ppcmds -> std_ppcmds + val tag_atomic_tactic_expr + : atomic_tactic_expr -> std_ppcmds -> std_ppcmds + end) += struct + + open Taggers + + let keyword x = tag_keyword (str x) + let primitive x = tag_primitive (str x) + + let has_type (Val.Dyn (tag, x)) t = match Val.eq tag t with + | None -> false + | Some _ -> true + + let unbox : type a. Val.t -> a Val.typ -> a= fun (Val.Dyn (tag, x)) t -> + match Val.eq tag t with + | None -> assert false + | Some Refl -> x + + let rec pr_value lev v : std_ppcmds = + if has_type v Val.typ_list then + pr_sequence (fun x -> pr_value lev x) (unbox v Val.typ_list) + else if has_type v Val.typ_opt then + pr_opt_no_spc (fun x -> pr_value lev x) (unbox v Val.typ_opt) + else if has_type v Val.typ_pair then + let (v1, v2) = unbox v Val.typ_pair in + str "(" ++ pr_value lev v1 ++ str ", " ++ pr_value lev v2 ++ str ")" + else + let Val.Dyn (tag, x) = v in + let name = Val.repr tag 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_tag (Topwit wit) with + | Val.Base t -> + begin match Val.eq t tag with + | None -> default + | Some Refl -> Genprint.generic_top_print (in_gen (Topwit wit) x) + end + | _ -> default + + let pr_with_occurrences pr c = pr_with_occurrences pr keyword c + let pr_red_expr pr c = pr_red_expr pr keyword c + + let pr_may_eval test prc prlc pr2 pr3 = function + | ConstrEval (r,c) -> + hov 0 + (keyword "eval" ++ brk (1,1) ++ + pr_red_expr (prc,prlc,pr2,pr3) r ++ spc () ++ + keyword "in" ++ spc() ++ prc c) + | ConstrContext ((_,id),c) -> + hov 0 + (keyword "context" ++ spc () ++ pr_id id ++ spc () ++ + str "[ " ++ prlc c ++ str " ]") + | ConstrTypeOf c -> + hov 1 (keyword "type of" ++ spc() ++ prc c) + | ConstrTerm c when test c -> + h 0 (str "(" ++ prc c ++ str ")") + | ConstrTerm c -> + prc c + + let pr_may_eval a = + pr_may_eval (fun _ -> false) a + + let pr_arg pr x = spc () ++ pr x + + let pr_and_short_name pr (c,_) = pr c + + let pr_or_by_notation f = function + | AN v -> f v + | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc + + let pr_located pr (loc,x) = pr x + + let pr_evaluable_reference = function + | EvalVarRef id -> pr_id id + | EvalConstRef sp -> pr_global (Globnames.ConstRef sp) + + let pr_quantified_hypothesis = function + | AnonHyp n -> int n + | NamedHyp id -> pr_id id + + let pr_binding prc = function + | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c) + | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) + + let pr_bindings prc prlc = function + | ImplicitBindings l -> + brk (1,1) ++ keyword "with" ++ brk (1,1) ++ + hv 0 (prlist_with_sep spc prc l) + | ExplicitBindings l -> + brk (1,1) ++ keyword "with" ++ brk (1,1) ++ + hv 0 (prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l) + | NoBindings -> mt () + + let pr_bindings_no_with prc prlc = function + | ImplicitBindings l -> + brk (0,1) ++ + prlist_with_sep spc prc l + | ExplicitBindings l -> + brk (0,1) ++ + prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l + | NoBindings -> mt () + + let pr_clear_flag clear_flag pp x = + match clear_flag with + | Some false -> surround (pp x) + | Some true -> str ">" ++ pp x + | None -> pp x + + let pr_with_bindings prc prlc (c,bl) = + prc c ++ pr_bindings prc prlc bl + + let pr_with_bindings_arg prc prlc (clear_flag,c) = + pr_clear_flag clear_flag (pr_with_bindings prc prlc) c + + let pr_with_constr prc = function + | None -> mt () + | Some c -> spc () ++ hov 1 (keyword "with" ++ spc () ++ prc c) + + let pr_message_token prid = function + | MsgString s -> tag_string (qs s) + | MsgInt n -> int n + | MsgIdent id -> prid id + + let pr_fresh_ids = + prlist (fun s -> spc() ++ pr_or_var (fun s -> tag_string (qs s)) s) + + let with_evars ev s = if ev then "e" ^ s else s + + let rec tacarg_using_rule_token pr_gen = function + | [] -> [] + | TacTerm s :: l -> keyword s :: tacarg_using_rule_token pr_gen l + | TacNonTerm (_, (symb, arg), _) :: l -> + pr_gen symb arg :: tacarg_using_rule_token pr_gen l + + let pr_tacarg_using_rule pr_gen l = + let l = match l with + | TacTerm s :: l -> + (** 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 + | _ -> tacarg_using_rule_token pr_gen l + in + pr_sequence (fun x -> x) l + + let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l = + let name = + str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++ + str "@" ++ int i + in + let args = match l with + | [] -> mt () + | _ -> spc() ++ pr_sequence pr_gen l + in + str "<" ++ name ++ str ">" ++ args + + let rec pr_user_symbol = function + | Extend.Ulist1 tkn -> "ne_" ^ pr_user_symbol tkn ^ "_list" + | Extend.Ulist1sep (tkn, _) -> "ne_" ^ pr_user_symbol tkn ^ "_list" + | Extend.Ulist0 tkn -> pr_user_symbol tkn ^ "_list" + | Extend.Ulist0sep (tkn, _) -> pr_user_symbol tkn ^ "_list" + | Extend.Uopt tkn -> pr_user_symbol tkn ^ "_opt" + | Extend.Uentry tag -> + let ArgT.Any tag = tag in + ArgT.repr tag + | Extend.Uentryl (tkn, lvl) -> "tactic" ^ string_of_int lvl + + let pr_alias_key key = + try + let prods = (KNmap.find key !prnotation_tab).pptac_prods in + let rec pr = function + | TacTerm s -> primitive s + | TacNonTerm (_, symb, _) -> str (Printf.sprintf "(%s)" (pr_user_symbol symb)) + in + pr_sequence pr prods + with Not_found -> + KerName.print key + + let pr_alias_gen pr_gen lev key l = + try + let pp = KNmap.find key !prnotation_tab in + let rec pack prods args = match prods, args with + | [], [] -> [] + | TacTerm s :: prods, args -> TacTerm s :: pack prods args + | TacNonTerm (loc, symb, id) :: prods, arg :: args -> + TacNonTerm (loc, (symb, arg), id) :: pack prods args + | _ -> raise Not_found + in + let prods = pack pp.pptac_prods l in + let p = pr_tacarg_using_rule pr_gen prods in + if pp.pptac_level > lev then surround p else p + with Not_found -> + let pr arg = str "_" in + KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)" + + let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.ghost, arg)) + + let is_genarg tag wit = + let ArgT.Any tag = tag in + argument_type_eq (ArgumentType (ExtraArg tag)) wit + + let get_list : type l. l generic_argument -> l generic_argument list option = + function (GenArg (wit, arg)) -> match wit with + | Rawwit (ListArg wit) -> Some (List.map (in_gen (rawwit wit)) arg) + | Glbwit (ListArg wit) -> Some (List.map (in_gen (glbwit wit)) arg) + | _ -> None + + let get_opt : type l. l generic_argument -> l generic_argument option option = + function (GenArg (wit, arg)) -> match wit with + | Rawwit (OptArg wit) -> Some (Option.map (in_gen (rawwit wit)) arg) + | Glbwit (OptArg wit) -> Some (Option.map (in_gen (glbwit wit)) arg) + | _ -> None + + let rec pr_any_arg : type l. (_ -> l generic_argument -> std_ppcmds) -> _ -> l generic_argument -> std_ppcmds = + fun prtac symb arg -> match symb with + | Extend.Uentry tag when is_genarg tag (genarg_tag arg) -> prtac (1, Any) arg + | Extend.Ulist1 s | Extend.Ulist0 s -> + begin match get_list arg with + | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + | Some l -> pr_sequence (pr_any_arg prtac s) l + end + | Extend.Ulist1sep (s, sep) | Extend.Ulist0sep (s, sep) -> + begin match get_list arg with + | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + | Some l -> prlist_with_sep (fun () -> str sep) (pr_any_arg prtac s) l + end + | Extend.Uopt s -> + begin match get_opt arg with + | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + | Some l -> pr_opt (pr_any_arg prtac s) l + end + | Extend.Uentry _ | Extend.Uentryl _ -> + str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + + let rec pr_targ prtac symb arg = match symb with + | Extend.Uentry tag when is_genarg tag (ArgumentType wit_tactic) -> + prtac (1, Any) arg + | Extend.Uentryl (_, l) -> prtac (l, Any) arg + | _ -> + match arg with + | TacGeneric arg -> + let pr l arg = prtac l (TacGeneric arg) in + pr_any_arg pr symb arg + | _ -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + + let pr_raw_extend_rec prc prlc prtac prpat = + pr_extend_gen (pr_farg prtac) + let pr_glob_extend_rec prc prlc prtac prpat = + pr_extend_gen (pr_farg prtac) + + let pr_raw_alias prc prlc prtac prpat lev key args = + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args + let pr_glob_alias prc prlc prtac prpat lev key args = + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args + + (**********************************************************************) + (* The tactic printer *) + + let strip_prod_binders_expr n ty = + let rec strip_ty acc n ty = + match ty with + Constrexpr.CProdN(_,bll,a) -> + let nb = + List.fold_left (fun i (nal,_,_) -> i + List.length nal) 0 bll in + let bll = List.map (fun (x, _, y) -> x, y) bll in + if nb >= n then (List.rev (bll@acc)), a + else strip_ty (bll@acc) (n-nb) a + | _ -> error "Cannot translate fix tactic: not enough products" in + strip_ty [] n ty + + let pr_ltac_or_var pr = function + | ArgArg x -> pr x + | ArgVar (loc,id) -> pr_with_comments loc (pr_id id) + + let pr_ltac_constant kn = + if !Flags.in_debugger then pr_kn kn + else try + pr_qualid (Nametab.shortest_qualid_of_tactic kn) + with Not_found -> (* local tactic not accessible anymore *) + str "<" ++ pr_kn kn ++ str ">" + + let pr_evaluable_reference_env env = function + | EvalVarRef id -> pr_id id + | EvalConstRef sp -> + Nametab.pr_global_env (Termops.vars_of_env env) (Globnames.ConstRef sp) + + let pr_esubst prc l = + let pr_qhyp = function + (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")" + | (_,NamedHyp id,c) -> + str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")" + in + prlist_with_sep spc pr_qhyp l + + let pr_bindings_gen for_ex prc prlc = function + | ImplicitBindings l -> + spc () ++ + hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++ + prlist_with_sep spc prc l) + | ExplicitBindings l -> + spc () ++ + hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++ + pr_esubst prlc l) + | NoBindings -> mt () + + let pr_bindings prc prlc = pr_bindings_gen false prc prlc + + let pr_with_bindings prc prlc (c,bl) = + hov 1 (prc c ++ pr_bindings prc prlc bl) + + let pr_as_disjunctive_ipat prc ipatl = + keyword "as" ++ spc () ++ + pr_or_var (fun (loc,p) -> Miscprint.pr_or_and_intro_pattern prc p) ipatl + + let pr_eqn_ipat (_,ipat) = keyword "eqn:" ++ Miscprint.pr_intro_pattern_naming ipat + + let pr_with_induction_names prc = function + | None, None -> mt () + | Some eqpat, None -> hov 1 (pr_eqn_ipat eqpat) + | None, Some ipat -> hov 1 (pr_as_disjunctive_ipat prc ipat) + | Some eqpat, Some ipat -> + hov 1 (pr_as_disjunctive_ipat prc ipat ++ spc () ++ pr_eqn_ipat eqpat) + + let pr_as_intro_pattern prc ipat = + spc () ++ hov 1 (keyword "as" ++ spc () ++ Miscprint.pr_intro_pattern prc ipat) + + let pr_with_inversion_names prc = function + | None -> mt () + | Some ipat -> pr_as_disjunctive_ipat prc ipat + + let pr_as_ipat prc = function + | None -> mt () + | Some ipat -> pr_as_intro_pattern prc ipat + + let pr_as_name = function + | Anonymous -> mt () + | Name id -> spc () ++ keyword "as" ++ spc () ++ pr_lident (Loc.ghost,id) + + let pr_pose_as_style prc na c = + spc() ++ prc c ++ pr_as_name na + + let pr_pose prc prlc na c = match na with + | Anonymous -> spc() ++ prc c + | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c) + + let pr_assertion prc prdc _prlc ipat c = match ipat with + (* Use this "optimisation" or use only the general case ? + | IntroIdentifier id -> + spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c) + *) + | ipat -> + spc() ++ prc c ++ pr_as_ipat prdc ipat + + let pr_assumption prc prdc prlc ipat c = match ipat with + (* Use this "optimisation" or use only the general case ?*) + (* it seems that this "optimisation" is somehow more natural *) + | Some (_,IntroNaming (IntroIdentifier id)) -> + spc() ++ surround (pr_id id ++ str " :" ++ spc() ++ prlc c) + | ipat -> + spc() ++ prc c ++ pr_as_ipat prdc ipat + + let pr_by_tactic prt = function + | Some tac -> keyword "by" ++ spc () ++ prt tac + | None -> mt() + + let pr_hyp_location pr_id = function + | occs, InHyp -> pr_with_occurrences pr_id occs + | occs, InHypTypeOnly -> + pr_with_occurrences (fun id -> + str "(" ++ keyword "type of" ++ spc () ++ pr_id id ++ str ")" + ) occs + | occs, InHypValueOnly -> + pr_with_occurrences (fun id -> + str "(" ++ keyword "value of" ++ spc () ++ pr_id id ++ str ")" + ) occs + + let pr_in pp = hov 0 (keyword "in" ++ pp) + + let pr_simple_hyp_clause pr_id = function + | [] -> mt () + | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l) + + let pr_in_hyp_as prc pr_id = function + | None -> mt () + | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat + + let pr_in_clause pr_id = function + | { onhyps=None; concl_occs=NoOccurrences } -> + (str "* |-") + | { onhyps=None; concl_occs=occs } -> + (pr_with_occurrences (fun () -> str "*") (occs,())) + | { onhyps=Some l; concl_occs=NoOccurrences } -> + prlist_with_sep (fun () -> str ", ") (pr_hyp_location pr_id) l + | { onhyps=Some l; concl_occs=occs } -> + let pr_occs = pr_with_occurrences (fun () -> str" |- *") (occs,()) in + (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs) + + let pr_clauses default_is_concl pr_id = function + | { onhyps=Some []; concl_occs=occs } + when (match default_is_concl with Some true -> true | _ -> false) -> + pr_with_occurrences mt (occs,()) + | { onhyps=None; concl_occs=AllOccurrences } + when (match default_is_concl with Some false -> true | _ -> false) -> mt () + | { onhyps=None; concl_occs=NoOccurrences } -> + pr_in (str " * |-") + | { onhyps=None; concl_occs=occs } -> + pr_in (pr_with_occurrences (fun () -> str " *") (occs,())) + | { onhyps=Some l; concl_occs=occs } -> + let pr_occs = match occs with + | NoOccurrences -> mt () + | _ -> pr_with_occurrences (fun () -> str" |- *") (occs,()) + in + pr_in + (prlist_with_sep (fun () -> str",") + (fun id -> spc () ++ pr_hyp_location pr_id id) l ++ pr_occs) + + let pr_orient b = if b then mt () else str "<- " + + let pr_multi = function + | Precisely 1 -> mt () + | Precisely n -> int n ++ str "!" + | UpTo n -> int n ++ str "?" + | RepeatStar -> str "?" + | RepeatPlus -> str "!" + + let pr_core_destruction_arg prc prlc = function + | ElimOnConstr c -> pr_with_bindings prc prlc c + | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id) + | ElimOnAnonHyp n -> int n + + let pr_destruction_arg prc prlc (clear_flag,h) = + pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h + + let pr_inversion_kind = function + | SimpleInversion -> primitive "simple inversion" + | FullInversion -> primitive "inversion" + | FullInversionClear -> primitive "inversion_clear" + + let pr_range_selector (i, j) = + if Int.equal i j then int i + else int i ++ str "-" ++ int j + + let pr_goal_selector = function + | SelectNth i -> int i ++ str ":" + | SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ + str "]" ++ str ":" + | SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" + | SelectAll -> str "all" ++ str ":" + + let pr_lazy = function + | General -> keyword "multi" + | Select -> keyword "lazy" + | Once -> mt () + + let pr_match_pattern pr_pat = function + | Term a -> pr_pat a + | Subterm (b,None,a) -> + (** ppedrot: we don't make difference between [appcontext] and [context] + anymore, and the interpretation is governed by a flag instead. *) + keyword "context" ++ str" [ " ++ pr_pat a ++ str " ]" + | Subterm (b,Some id,a) -> + keyword "context" ++ spc () ++ pr_id id ++ str "[ " ++ pr_pat a ++ str " ]" + + let pr_match_hyps pr_pat = function + | Hyp (nal,mp) -> + pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp + | Def (nal,mv,mp) -> + pr_lname nal ++ str ":=" ++ pr_match_pattern pr_pat mv + ++ str ":" ++ pr_match_pattern pr_pat mp + + let pr_match_rule m pr pr_pat = function + | Pat ([],mp,t) when m -> + pr_match_pattern pr_pat mp ++ + spc () ++ str "=>" ++ brk (1,4) ++ pr t + (* + | Pat (rl,mp,t) -> + hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl ++ + (if rl <> [] then spc () else mt ()) ++ + hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ + str "=>" ++ brk (1,4) ++ pr t)) + *) + | Pat (rl,mp,t) -> + hov 0 ( + hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl) ++ + (if not (List.is_empty rl) then spc () else mt ()) ++ + hov 0 ( + str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ + str "=>" ++ brk (1,4) ++ pr t)) + | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t + + let pr_funvar = function + | None -> spc () ++ str "_" + | Some id -> spc () ++ pr_id id + + let pr_let_clause k pr (id,(bl,t)) = + hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++ + str " :=" ++ brk (1,1) ++ pr (TacArg (Loc.ghost,t))) + + let pr_let_clauses recflag pr = function + | hd::tl -> + hv 0 + (pr_let_clause (if recflag then "let rec" else "let") pr hd ++ + prlist (fun t -> spc () ++ pr_let_clause "with" pr t) tl) + | [] -> anomaly (Pp.str "LetIn must declare at least one binding") + + let pr_seq_body pr tl = + hv 0 (str "[ " ++ + prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ + str " ]") + + let pr_dispatch pr tl = + hv 0 (str "[>" ++ + prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ + str " ]") + + let pr_opt_tactic pr = function + | TacId [] -> mt () + | t -> pr t + + let pr_tac_extend_gen pr tf tm tl = + prvect_with_sep mt (fun t -> pr t ++ spc () ++ str "| ") tf ++ + pr_opt_tactic pr tm ++ str ".." ++ + prvect_with_sep mt (fun t -> spc () ++ str "| " ++ pr t) tl + + let pr_then_gen pr tf tm tl = + hv 0 (str "[ " ++ + pr_tac_extend_gen pr tf tm tl ++ + str " ]") + + let pr_tac_extend pr tf tm tl = + hv 0 (str "[>" ++ + pr_tac_extend_gen pr tf tm tl ++ + str " ]") + + let pr_hintbases = function + | None -> keyword "with" ++ str" *" + | Some [] -> mt () + | Some l -> hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l) + + let pr_auto_using prc = function + | [] -> mt () + | l -> hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l) + + let pr_then () = str ";" + + let ltop = (5,E) + let lseq = 4 + let ltactical = 3 + let lorelse = 2 + let llet = 5 + let lfun = 5 + let lcomplete = 1 + let labstract = 3 + let lmatch = 1 + let latom = 0 + let lcall = 1 + let leval = 1 + let ltatom = 1 + let linfo = 5 + + let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq + + (** A printer for tactics that polymorphically works on the three + "raw", "glob" and "typed" levels *) + + type 'a printer = { + pr_tactic : tolerability -> 'tacexpr -> std_ppcmds; + pr_constr : 'trm -> std_ppcmds; + pr_lconstr : 'trm -> std_ppcmds; + pr_dconstr : 'dtrm -> std_ppcmds; + pr_pattern : 'pat -> std_ppcmds; + pr_lpattern : 'pat -> std_ppcmds; + pr_constant : 'cst -> std_ppcmds; + pr_reference : 'ref -> std_ppcmds; + pr_name : 'nam -> std_ppcmds; + pr_generic : 'lev generic_argument -> 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 = < + term :'trm; + dterm :'dtrm; + pattern :'pat; + constant :'cst; + reference :'ref; + name :'nam; + tacexpr :'tacexpr; + level :'lev + > + + 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 + 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 (false,[]) -> primitive "intros" + | TacIntroPattern (true,[]) -> primitive "eintros" + | t -> str "(" ++ pr_atom1 t ++ str ")" + ) + + (* Main tactic printer *) + and pr_atom1 a = tag_atom a (match a with + (* Basic tactics *) + | TacIntroPattern (ev,[]) as t -> + pr_atom0 t + | TacIntroPattern (ev,(_::_ as p)) -> + hov 1 (primitive (if ev then "eintros" else "intros") ++ spc () ++ + prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p) + | 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_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) 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 (h,ids,cl) -> + pr_destruction_arg pr.pr_dconstr pr.pr_dconstr h ++ + pr_non_empty_arg (pr_with_induction_names pr.pr_dconstr) ids ++ + pr_opt (pr_clauses None pr.pr_name) cl) l ++ + pr_opt pr_eliminator el + ) + + (* 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,tac) -> + 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 + ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac + ) + | TacInversion (DepInversion (k,c,ids),hyp) -> + hov 1 ( + primitive "dependent " ++ pr_inversion_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_inversion_kind k ++ spc () + ++ pr_quantified_hypothesis hyp + ++ pr_non_empty_arg (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 + + 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 + | TacAbstract (t,None) -> + keyword "abstract " ++ pr_tac (labstract,L) t, labstract + | TacAbstract (t,Some s) -> + hov 0 ( + keyword "abstract" + ++ str" (" ++ pr_tac (labstract,L) t ++ str")" ++ spc () + ++ keyword "using" ++ spc () ++ pr_id s), + labstract + | TacLetIn (recflag,llc,u) -> + let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in + v 0 + (hv 0 ( + pr_let_clauses recflag (pr_tac ltop) llc + ++ spc () ++ keyword "in" + ) ++ fnl () ++ pr_tac (llet,E) u), + llet + | TacMatch (lz,t,lrul) -> + hov 0 ( + pr_lazy lz ++ keyword "match" ++ spc () + ++ pr_tac ltop t ++ spc () ++ keyword "with" + ++ prlist (fun r -> + fnl () ++ str "| " + ++ pr_match_rule true (pr_tac ltop) pr.pr_lpattern r + ) lrul + ++ fnl() ++ keyword "end"), + lmatch + | TacMatchGoal (lz,lr,lrul) -> + hov 0 ( + pr_lazy lz + ++ keyword (if lr then "match reverse goal with" else "match goal with") + ++ prlist (fun r -> + fnl () ++ str "| " + ++ pr_match_rule false (pr_tac ltop) pr.pr_lpattern r + ) lrul ++ fnl() ++ keyword "end"), + lmatch + | TacFun (lvar,body) -> + hov 2 ( + keyword "fun" + ++ prlist pr_funvar lvar ++ str " =>" ++ spc () + ++ pr_tac (lfun,E) body), + lfun + | TacThens (t,tl) -> + hov 1 ( + pr_tac (lseq,E) t ++ pr_then () ++ spc () + ++ pr_seq_body (pr_opt_tactic (pr_tac ltop)) tl), + lseq + | TacThen (t1,t2) -> + hov 1 ( + pr_tac (lseq,E) t1 ++ pr_then () ++ spc () + ++ pr_tac (lseq,L) t2), + lseq + | TacDispatch tl -> + pr_dispatch (pr_tac ltop) tl, lseq + | TacExtendTac (tf,t,tr) -> + pr_tac_extend (pr_tac ltop) tf t tr , lseq + | TacThens3parts (t1,tf,t2,tl) -> + hov 1 ( + pr_tac (lseq,E) t1 ++ pr_then () ++ spc () + ++ pr_then_gen (pr_tac ltop) tf t2 tl), + lseq + | TacTry t -> + hov 1 ( + keyword "try" ++ spc () ++ pr_tac (ltactical,E) t), + ltactical + | TacDo (n,t) -> + hov 1 ( + str "do" ++ spc () + ++ pr_or_var int n ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacTimeout (n,t) -> + hov 1 ( + keyword "timeout " + ++ pr_or_var int n ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacTime (s,t) -> + hov 1 ( + keyword "time" + ++ pr_opt str s ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacRepeat t -> + hov 1 ( + keyword "repeat" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacProgress t -> + hov 1 ( + keyword "progress" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacShowHyps t -> + hov 1 ( + keyword "infoH" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacInfo t -> + hov 1 ( + keyword "info" ++ spc () + ++ pr_tac (ltactical,E) t), + linfo + | TacOr (t1,t2) -> + hov 1 ( + pr_tac (lorelse,L) t1 ++ spc () + ++ str "+" ++ brk (1,1) + ++ pr_tac (lorelse,E) t2), + lorelse + | TacOnce t -> + hov 1 ( + keyword "once" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacExactlyOnce t -> + hov 1 ( + keyword "exactly_once" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacIfThenCatch (t,tt,te) -> + hov 1 ( + str"tryif" ++ spc() ++ pr_tac (ltactical,E) t ++ brk(1,1) ++ + str"then" ++ spc() ++ pr_tac (ltactical,E) tt ++ brk(1,1) ++ + str"else" ++ spc() ++ pr_tac (ltactical,E) te ++ brk(1,1)), + ltactical + | TacOrelse (t1,t2) -> + hov 1 ( + pr_tac (lorelse,L) t1 ++ spc () + ++ str "||" ++ brk (1,1) + ++ pr_tac (lorelse,E) t2), + lorelse + | TacFail (g,n,l) -> + let arg = + match n with + | ArgArg 0 -> mt () + | _ -> pr_arg (pr_or_var int) n + in + let name = + match g with + | TacGlobal -> keyword "gfail" + | TacLocal -> keyword "fail" + in + hov 1 ( + name ++ arg + ++ prlist (pr_arg (pr_message_token pr.pr_name)) l), + latom + | TacFirst tl -> + keyword "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet + | TacSolve tl -> + keyword "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet + | TacComplete t -> + pr_tac (lcomplete,E) t, lcomplete + | TacSelect (s, tac) -> pr_goal_selector s ++ spc () ++ pr_tac ltop tac, latom + | 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_atom pr strip_prod_binders tag_atom t)), ltatom + | TacArg(_,Tacexp e) -> + pr.pr_tactic (latom,E) e, latom + | TacArg(_,ConstrMayEval (ConstrTerm c)) -> + keyword "constr:" ++ pr.pr_constr c, latom + | TacArg(_,ConstrMayEval c) -> + pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval + | TacArg(_,TacFreshId l) -> + primitive "fresh" ++ pr_fresh_ids l, latom + | TacArg(_,TacGeneric arg) -> + pr.pr_generic arg, latom + | TacArg(_,TacCall(loc,f,[])) -> + pr.pr_reference f, latom + | TacArg(_,TacCall(loc,f,l)) -> + pr_with_comments loc (hov 1 ( + pr.pr_reference f ++ spc () + ++ prlist_with_sep spc pr_tacarg l)), + lcall + | TacArg (_,a) -> + pr_tacarg a, latom + | 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 l), latom + ) + in + if prec_less prec inherited then strm + else str"(" ++ strm ++ str")" + + and pr_tacarg = function + | Reference r -> + pr.pr_reference r + | ConstrMayEval c -> + pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c + | TacFreshId l -> + keyword "fresh" ++ pr_fresh_ids l + | TacPretype c -> + keyword "type_term" ++ pr.pr_constr c + | TacNumgoals -> + keyword "numgoals" + | (TacCall _|Tacexp _ | TacGeneric _) as a -> + hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.ghost,a)))) + + in pr_tac + + let strip_prod_binders_glob_constr n (ty,_) = + let rec strip_ty acc n ty = + if Int.equal n 0 then (List.rev acc, (ty,None)) else + match ty with + Glob_term.GProd(loc,na,Explicit,a,b) -> + strip_ty (([Loc.ghost,na],(a,None))::acc) (n-1) b + | _ -> error "Cannot translate fix tactic: not enough products" in + strip_ty [] n ty + + let raw_printers = + (strip_prod_binders_expr) + + let rec pr_raw_tactic_level n (t:raw_tactic_expr) = + let pr = { + pr_tactic = pr_raw_tactic_level; + pr_constr = pr_constr_expr; + pr_dconstr = pr_constr_expr; + pr_lconstr = pr_lconstr_expr; + pr_pattern = pr_constr_pattern_expr; + pr_lpattern = pr_lconstr_pattern_expr; + pr_constant = pr_or_by_notation pr_reference; + pr_reference = pr_reference; + pr_name = pr_lident; + pr_generic = (fun arg -> Pputils.pr_raw_generic (Global.env ()) arg); + 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 + pr raw_printers + tag_raw_atomic_tactic_expr tag_raw_tactic_expr + n t + + let pr_raw_tactic = pr_raw_tactic_level ltop + + let pr_and_constr_expr pr (c,_) = pr c + + let pr_pat_and_constr_expr pr (_,(c,_),_) = pr c + + let pr_glob_tactic_level env n t = + let glob_printers = + (strip_prod_binders_glob_constr) + in + let rec prtac n (t:glob_tactic_expr) = + let pr = { + pr_tactic = prtac; + pr_constr = 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); + pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env); + 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 = (fun arg -> Pputils.pr_glb_generic (Global.env ()) arg); + 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 + (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)); + } in + make_pr_tac + pr glob_printers + tag_glob_atomic_tactic_expr tag_glob_tactic_expr + n t + in + prtac n t + + let pr_glob_tactic env = pr_glob_tactic_level env ltop + + let strip_prod_binders_constr n ty = + let rec strip_ty acc n ty = + if n=0 then (List.rev acc, ty) else + match Term.kind_of_term ty with + Term.Prod(na,a,b) -> + strip_ty (([Loc.ghost,na],a)::acc) (n-1) b + | _ -> error "Cannot translate fix tactic: not enough products" in + strip_ty [] n ty + + let pr_atomic_tactic_level env n t = + let prtac n (t:atomic_tactic_expr) = + let pr = { + 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; + pr_pattern = pr_constr_pattern_env env Evd.empty; + pr_lpattern = pr_lconstr_pattern_env env Evd.empty; + pr_constant = pr_evaluable_reference_env env; + pr_reference = pr_located pr_ltac_constant; + pr_name = pr_id; + (** Those are not used by the atomic printer *) + pr_generic = (fun _ -> assert false); + pr_extend = (fun _ _ _ -> assert false); + pr_alias = (fun _ _ _ -> assert false); + } + in + pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t + in + prtac n t + + let pr_raw_generic = Pputils.pr_raw_generic + + let pr_glb_generic = Pputils.pr_glb_generic + + 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_alias pr lev key args = + pr_alias_gen (fun _ arg -> pr arg) lev key args + + let pr_extend pr lev ml args = + pr_extend_gen pr lev ml args + + let pr_atomic_tactic env = pr_atomic_tactic_level env ltop + +end + +module Tag = +struct + let keyword = + let style = Terminal.make ~bold:true () in + Ppstyle.make ~style ["tactic"; "keyword"] + + let primitive = + let style = Terminal.make ~fg_color:`LIGHT_GREEN () in + Ppstyle.make ~style ["tactic"; "primitive"] + + let string = + let style = Terminal.make ~fg_color:`LIGHT_RED () in + Ppstyle.make ~style ["tactic"; "string"] + +end + +include Make (Ppconstr) (struct + let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s + let do_not_tag _ x = x + let tag_keyword = tag Tag.keyword + let tag_primitive = tag Tag.primitive + let tag_string = tag Tag.string + let tag_glob_tactic_expr = do_not_tag + 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_atomic_tactic_expr = do_not_tag +end) + +let declare_extra_genarg_pprule wit + (f : 'a raw_extra_genarg_printer) + (g : 'b glob_extra_genarg_printer) + (h : 'c extra_genarg_printer) = + begin match wit with + | ExtraArg s -> () + | _ -> error "Can declare a pretty-printing rule only for extra argument types." + end; + let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in + let g x = + let env = Global.env () in + g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x + in + let h x = + let env = Global.env () in + h (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) (fun _ _ -> str "") x + in + Genprint.register_print0 wit f g h + +(** Registering *) + +let run_delayed c = + Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma } + +let run_delayed_destruction_arg = function (* HH: Using Evd.empty looks suspicious *) + | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (fst (run_delayed g)) + | clear_flag,ElimOnAnonHyp n as x -> x + | clear_flag,ElimOnIdent id as x -> x + +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 wit_int_or_var + (pr_or_var int) (pr_or_var int) int; + Genprint.register_print0 wit_ref + pr_reference (pr_or_var (pr_located pr_global)) pr_global; + Genprint.register_print0 wit_ident + pr_id pr_id pr_id; + Genprint.register_print0 wit_var + (pr_located pr_id) (pr_located pr_id) pr_id; + Genprint.register_print0 + 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 (fst (run_delayed c)))); + Genprint.register_print0 + wit_clause_dft_concl + (pr_clauses (Some true) pr_lident) + (pr_clauses (Some true) pr_lident) + (pr_clauses (Some true) (fun id -> pr_lident (Loc.ghost,id))) + ; + Genprint.register_print0 + wit_constr + Ppconstr.pr_constr_expr + (fun (c, _) -> Printer.pr_glob_constr c) + Printer.pr_constr + ; + Genprint.register_print0 + wit_uconstr + Ppconstr.pr_constr_expr + (fun (c,_) -> Printer.pr_glob_constr c) + Printer.pr_closed_glob + ; + Genprint.register_print0 + wit_open_constr + Ppconstr.pr_constr_expr + (fun (c, _) -> Printer.pr_glob_constr c) + Printer.pr_constr + ; + Genprint.register_print0 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_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_red_expr (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern)); + Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; + Genprint.register_print0 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 it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it))); + Genprint.register_print0 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 it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it))); + Genprint.register_print0 Tacarg.wit_destruction_arg + (pr_destruction_arg pr_constr_expr pr_lconstr_expr) + (pr_destruction_arg (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) + (fun it -> pr_destruction_arg pr_constr pr_lconstr (run_delayed_destruction_arg 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; + Genprint.register_print0 Stdarg.wit_pre_ident str str str; + Genprint.register_print0 Stdarg.wit_string pr_string pr_string pr_string + +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 + open Ppannotation + open Genarg + let do_not_tag _ x = x + let tag e s = Pp.tag (Pp.Tag.inj e tag) s + let tag_keyword = tag AKeyword + let tag_primitive = tag AKeyword + let tag_string = do_not_tag () + let tag_glob_tactic_expr e = tag (AGlbGenArg (in_gen (glbwit wit_ltac) e)) + let tag_glob_atomic_tactic_expr = do_not_tag + let tag_raw_tactic_expr e = tag (ARawGenArg (in_gen (rawwit wit_ltac) e)) + let tag_raw_atomic_tactic_expr = do_not_tag + let tag_atomic_tactic_expr = do_not_tag + end) + +end diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli new file mode 100644 index 0000000000..86e3ea5484 --- /dev/null +++ b/plugins/ltac/pptactic.mli @@ -0,0 +1,67 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + (tolerability -> raw_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a glob_extra_genarg_printer = + (glob_constr_and_expr -> std_ppcmds) -> + (glob_constr_and_expr -> std_ppcmds) -> + (tolerability -> glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a extra_genarg_printer = + (Term.constr -> std_ppcmds) -> + (Term.constr -> std_ppcmds) -> + (tolerability -> Val.t -> std_ppcmds) -> + 'a -> std_ppcmds + +val declare_extra_genarg_pprule : + ('a, 'b, 'c) genarg_type -> + 'a raw_extra_genarg_printer -> + 'b glob_extra_genarg_printer -> + 'c extra_genarg_printer -> unit + +type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list + +type pp_tactic = { + pptac_level : int; + pptac_prods : grammar_terminals; +} + +val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit + +(** The default pretty-printers produce {!Pp.std_ppcmds} that are + interpreted as raw strings. *) +include Pptacticsig.Pp + +(** The rich pretty-printers produce {!Pp.std_ppcmds} that are + interpreted as annotated strings. The annotations can be + retrieved using {!RichPp.rich_pp}. Their definitions are + located in {!Ppannotation.t}. *) +module Richpp : Pptacticsig.Pp + +val ltop : tolerability diff --git a/plugins/ltac/pptacticsig.mli b/plugins/ltac/pptacticsig.mli new file mode 100644 index 0000000000..74ddd377ad --- /dev/null +++ b/plugins/ltac/pptacticsig.mli @@ -0,0 +1,81 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds + val pr_red_expr : + ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> + ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds + val pr_may_eval : + ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds + + val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds + + val pr_in_clause : + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + + val pr_clauses : bool option -> + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + + val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds + + val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds + + val pr_raw_extend: env -> int -> + ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds + + val pr_glob_extend: env -> int -> + ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds + + val pr_extend : + (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds + + val pr_alias_key : Names.KerName.t -> std_ppcmds + + val pr_alias : (Val.t -> std_ppcmds) -> + int -> Names.KerName.t -> Val.t list -> std_ppcmds + + val pr_alias_key : Names.KerName.t -> std_ppcmds + + val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds + + val pr_raw_tactic : raw_tactic_expr -> std_ppcmds + + val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds + + val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds + + val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds + + val pr_hintbases : string list option -> std_ppcmds + + val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds + + val pr_bindings : + ('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 + + val pr_value : tolerability -> Val.t -> std_ppcmds + +end diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml new file mode 100644 index 0000000000..2514ededb0 --- /dev/null +++ b/plugins/ltac/profile_ltac.ml @@ -0,0 +1,420 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* strbrk "Ltac Profiler cannot yet handle backtracking \ + into multi-success tactics; profiling results may be wildly inaccurate.") + +let warn_encountered_multi_success_backtracking () = + if !encountered_multi_success_backtracking then + warn_profile_backtracking () + +let encounter_multi_success_backtracking () = + if not !encountered_multi_success_backtracking + then begin + encountered_multi_success_backtracking := true; + warn_encountered_multi_success_backtracking () + end + + +(* *************** tree data structure for profiling ****************** *) + +type treenode = { + name : M.key; + total : float; + local : float; + ncalls : int; + max_total : float; + children : treenode M.t +} + +let empty_treenode name = { + name; + total = 0.0; + local = 0.0; + ncalls = 0; + max_total = 0.0; + children = M.empty; +} + +let root = "root" + +module Local = Summary.Local + +let stack = Local.ref ~name:"LtacProf-stack" [empty_treenode root] + +let reset_profile_tmp () = + Local.(stack := [empty_treenode root]); + encountered_multi_success_backtracking := false + +(* ************** XML Serialization ********************* *) + +let rec of_ltacprof_tactic (name, t) = + assert (String.equal name t.name); + let open Xml_datatype in + let total = string_of_float t.total in + let local = string_of_float t.local in + let ncalls = string_of_int t.ncalls in + let max_total = string_of_float t.max_total in + let children = List.map of_ltacprof_tactic (M.bindings t.children) in + Element ("ltacprof_tactic", + [ ("name", name); ("total",total); ("local",local); + ("ncalls",ncalls); ("max_total",max_total)], + children) + +let of_ltacprof_results t = + let open Xml_datatype in + assert(String.equal t.name root); + let children = List.map of_ltacprof_tactic (M.bindings t.children) in + Element ("ltacprof", [("total_time", string_of_float t.total)], children) + +let rec to_ltacprof_tactic m xml = + let open Xml_datatype in + match xml with + | Element ("ltacprof_tactic", + [("name", name); ("total",total); ("local",local); + ("ncalls",ncalls); ("max_total",max_total)], xs) -> + let node = { + name; + total = float_of_string total; + local = float_of_string local; + ncalls = int_of_string ncalls; + max_total = float_of_string max_total; + children = List.fold_left to_ltacprof_tactic M.empty xs; + } in + M.add name node m + | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof_tactic XML") + +let to_ltacprof_results xml = + let open Xml_datatype in + match xml with + | Element ("ltacprof", [("total_time", t)], xs) -> + { name = root; + total = float_of_string t; + ncalls = 0; + max_total = 0.0; + local = 0.0; + children = List.fold_left to_ltacprof_tactic M.empty xs } + | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof XML") + +let feedback_results results = + Feedback.(feedback + (Custom (Loc.dummy_loc, "ltacprof_results", of_ltacprof_results results))) + +(* ************** pretty printing ************************************* *) + +let format_sec x = (Printf.sprintf "%.3fs" x) +let format_ratio x = (Printf.sprintf "%.1f%%" (100. *. x)) +let padl n s = ws (max 0 (n - utf8_length s)) ++ str s +let padr n s = str s ++ ws (max 0 (n - utf8_length s)) +let padr_with c n s = + let ulength = utf8_length s in + str (utf8_sub s 0 n) ++ str (String.make (max 0 (n - ulength)) c) + +let rec list_iter_is_last f = function + | [] -> [] + | [x] -> [f true x] + | x :: xs -> f false x :: list_iter_is_last f xs + +let header = + str " tactic local total calls max " ++ + fnl () ++ + str "────────────────────────────────────────┴──────┴──────┴───────┴─────────┘" ++ + fnl () + +let rec print_node ~filter all_total indent prefix (s, e) = + h 0 ( + padr_with '-' 40 (prefix ^ s ^ " ") + ++ padl 7 (format_ratio (e.local /. all_total)) + ++ padl 7 (format_ratio (e.total /. all_total)) + ++ padl 8 (string_of_int e.ncalls) + ++ padl 10 (format_sec (e.max_total)) + ) ++ + fnl () ++ + print_table ~filter all_total indent false e.children + +and print_table ~filter all_total indent first_level table = + let fold _ n l = + let s, total = n.name, n.total in + if filter s total then (s, n) :: l else l in + let ls = M.fold fold table [] in + match ls with + | [s, n] when not first_level -> + v 0 (print_node ~filter all_total indent (indent ^ "└") (s, n)) + | _ -> + let ls = + List.sort (fun (_, { total = s1 }) (_, { total = s2}) -> + compare s2 s1) ls in + let iter is_last = + let sep0 = if first_level then "" else if is_last then " " else " │" in + let sep1 = if first_level then "─" else if is_last then " └─" else " ├─" in + print_node ~filter all_total (indent ^ sep0) (indent ^ sep1) + in + prlist (fun pr -> pr) (list_iter_is_last iter ls) + +let to_string ~filter ?(cutoff=0.0) node = + let tree = node.children in + let all_total = M.fold (fun _ { total } a -> total +. a) node.children 0.0 in + let flat_tree = + let global = ref M.empty in + let find_tactic tname l = + try M.find tname !global + with Not_found -> + let e = empty_treenode tname in + global := M.add tname e !global; + e in + let add_tactic tname stats = global := M.add tname stats !global in + let sum_stats add_total + { name; total = t1; local = l1; ncalls = n1; max_total = m1 } + { total = t2; local = l2; ncalls = n2; max_total = m2 } = { + name; + total = if add_total then t1 +. t2 else t1; + local = l1 +. l2; + ncalls = n1 + n2; + max_total = if add_total then max m1 m2 else m1; + children = M.empty; + } in + let rec cumulate table = + let iter _ ({ name; children } as statistics) = + if filter name then begin + let stats' = find_tactic name global in + add_tactic name (sum_stats true stats' statistics); + end; + cumulate children + in + M.iter iter table + in + cumulate tree; + !global + in + warn_encountered_multi_success_backtracking (); + let filter s n = filter s && (all_total <= 0.0 || n /. all_total >= cutoff /. 100.0) in + let msg = + h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++ + fnl () ++ + fnl () ++ + header ++ + print_table ~filter all_total "" true flat_tree ++ + fnl () ++ + header ++ + print_table ~filter all_total "" true tree + in + msg + +(* ******************** profiling code ************************************** *) + +let get_child name node = + try M.find name node.children + with Not_found -> empty_treenode name + +let time () = + let times = Unix.times () in + times.Unix.tms_utime +. times.Unix.tms_stime + +let string_of_call ck = + let s = + string_of_ppcmds + (match ck with + | Tacexpr.LtacNotationCall s -> Pptactic.pr_alias_key s + | Tacexpr.LtacNameCall cst -> Pptactic.pr_ltac_constant cst + | Tacexpr.LtacVarCall (id, t) -> Nameops.pr_id id + | Tacexpr.LtacAtomCall te -> + (Pptactic.pr_glob_tactic (Global.env ()) + (Tacexpr.TacAtom (Loc.ghost, te))) + | Tacexpr.LtacConstrInterp (c, _) -> + pr_glob_constr_env (Global.env ()) c + | Tacexpr.LtacMLCall te -> + (Pptactic.pr_glob_tactic (Global.env ()) + te) + ) in + for i = 0 to String.length s - 1 do if s.[i] = '\n' then s.[i] <- ' ' done; + let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in + CString.strip s + +let rec merge_sub_tree name tree acc = + try + let t = M.find name acc in + let t = { + name; + total = t.total +. tree.total; + ncalls = t.ncalls + tree.ncalls; + local = t.local +. tree.local; + max_total = max t.max_total tree.max_total; + children = M.fold merge_sub_tree tree.children t.children; + } in + M.add name t acc + with Not_found -> M.add name tree acc + +let merge_roots ?(disjoint=true) t1 t2 = + assert(String.equal t1.name t2.name); + { name = t1.name; + ncalls = t1.ncalls + t2.ncalls; + local = if disjoint then t1.local +. t2.local else t1.local; + total = if disjoint then t1.total +. t2.total else t1.total; + max_total = if disjoint then max t1.max_total t2.max_total else t1.max_total; + children = + M.fold merge_sub_tree t2.children t1.children } + +let rec find_in_stack what acc = function + | [] -> None + | { name } as x :: rest when String.equal name what -> Some(acc, x, rest) + | { name } as x :: rest -> find_in_stack what (x :: acc) rest + +let exit_tactic start_time c = + let diff = time () -. start_time in + match Local.(!stack) with + | [] | [_] -> + (* oops, our stack is invalid *) + encounter_multi_success_backtracking (); + reset_profile_tmp () + | node :: (parent :: rest as full_stack) -> + let name = string_of_call c in + if not (String.equal name node.name) then + (* oops, our stack is invalid *) + encounter_multi_success_backtracking (); + let node = { node with + total = node.total +. diff; + local = node.local +. diff; + ncalls = node.ncalls + 1; + max_total = max node.max_total diff; + } in + (* updating the stack *) + let parent = + match find_in_stack node.name [] full_stack with + | None -> + (* no rec-call, we graft the subtree *) + let parent = { parent with + local = parent.local -. diff; + children = M.add node.name node parent.children } in + Local.(stack := parent :: rest); + parent + | Some(to_update, self, rest) -> + (* we coalesce the rec-call and update the lower stack *) + let self = merge_roots ~disjoint:false self node in + let updated_stack = + List.fold_left (fun s x -> + (try M.find x.name (List.hd s).children + with Not_found -> x) :: s) (self :: rest) to_update in + Local.(stack := updated_stack); + List.hd Local.(!stack) + in + (* Calls are over, we reset the stack and send back data *) + if rest == [] && get_profiling () then begin + assert(String.equal root parent.name); + reset_profile_tmp (); + feedback_results parent + end + +let tclFINALLY tac (finally : unit Proofview.tactic) = + let open Proofview.Notations in + Proofview.tclIFCATCH + tac + (fun v -> finally <*> Proofview.tclUNIT v) + (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn) + +let do_profile s call_trace tac = + let open Proofview.Notations in + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> + if !is_profiling then + match call_trace, Local.(!stack) with + | (_, c) :: _, parent :: rest -> + let name = string_of_call c in + let node = get_child name parent in + Local.(stack := node :: parent :: rest); + Some (time ()) + | _ :: _, [] -> assert false + | _ -> None + else None)) >>= function + | Some start_time -> + tclFINALLY + tac + (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> + (match call_trace with + | (_, c) :: _ -> exit_tactic start_time c + | [] -> ())))) + | None -> tac + +(* ************** Accumulation of data from workers ************************* *) + +let get_local_profiling_results () = List.hd Local.(!stack) + +module SM = Map.Make(Stateid.Self) + +let data = ref SM.empty + +let _ = + Feedback.(add_feeder (function + | { id = State s; contents = Custom (_, "ltacprof_results", xml) } -> + let results = to_ltacprof_results xml in + let other_results = (* Multi success can cause this *) + try SM.find s !data + with Not_found -> empty_treenode root in + data := SM.add s (merge_roots results other_results) !data + | _ -> ())) + +let reset_profile () = + reset_profile_tmp (); + data := SM.empty + +(* ******************** *) + +let print_results_filter ~cutoff ~filter = + let valid id _ = Stm.state_of_id id <> `Expired in + data := SM.filter valid !data; + let results = + SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in + let results = merge_roots results Local.(CList.last !stack) in + Feedback.msg_notice (to_string ~cutoff ~filter results) +;; + +let print_results ~cutoff = + print_results_filter ~cutoff ~filter:(fun _ -> true) + +let print_results_tactic tactic = + print_results_filter ~cutoff:!Flags.profile_ltac_cutoff ~filter:(fun s -> + String.(equal tactic (sub (s ^ ".") 0 (min (1+length s) (length tactic))))) + +let do_print_results_at_close () = + if get_profiling () then print_results ~cutoff:!Flags.profile_ltac_cutoff + +let _ = Declaremods.append_end_library_hook do_print_results_at_close + +let _ = + let open Goptions in + declare_bool_option + { optsync = true; + optdepr = false; + optname = "Ltac Profiling"; + optkey = ["Ltac"; "Profiling"]; + optread = get_profiling; + optwrite = set_profiling } diff --git a/plugins/ltac/profile_ltac.mli b/plugins/ltac/profile_ltac.mli new file mode 100644 index 0000000000..e5e2e41975 --- /dev/null +++ b/plugins/ltac/profile_ltac.mli @@ -0,0 +1,48 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ('a * Tacexpr.ltac_call_kind) list -> + 'b Proofview.tactic -> 'b Proofview.tactic + +val set_profiling : bool -> unit + +(* Cut off results < than specified cutoff *) +val print_results : cutoff:float -> unit + +val print_results_tactic : string -> unit + +val reset_profile : unit -> unit + +val do_print_results_at_close : unit -> unit + +(* The collected statistics for a tactic. The timing data is collected over all + * instances of a given tactic from its parent. E.g. if tactic 'aaa' calls + * 'foo' twice, then 'aaa' will contain just one entry for 'foo' with the + * statistics of the two invocations combined, and also combined over all + * invocations of 'aaa'. + * total: time spent running this tactic and its subtactics (seconds) + * local: time spent running this tactic, minus its subtactics (seconds) + * ncalls: the number of invocations of this tactic that have been made + * max_total: the greatest running time of a single invocation (seconds) + *) +type treenode = { + name : CString.Map.key; + total : float; + local : float; + ncalls : int; + max_total : float; + children : treenode CString.Map.t +} + +(* Returns the profiling results known by the current process *) +val get_local_profiling_results : unit -> treenode +val feedback_results : treenode -> unit + diff --git a/plugins/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.ml4 new file mode 100644 index 0000000000..8cb76d81c5 --- /dev/null +++ b/plugins/ltac/profile_ltac_tactics.ml4 @@ -0,0 +1,40 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* set_profiling b)) + +TACTIC EXTEND start_ltac_profiling +| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ] +END + +TACTIC EXTEND stop_profiling +| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ] +END + +VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF + [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ] +END + +VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY +| [ "Show" "Ltac" "Profile" ] -> [ print_results ~cutoff:!Flags.profile_ltac_cutoff ] +| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> [ print_results ~cutoff:(float_of_int n) ] +END + +VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY + [ "Show" "Ltac" "Profile" string(s) ] -> [ print_results_tactic s ] +END diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml new file mode 100644 index 0000000000..3c5a109c0d --- /dev/null +++ b/plugins/ltac/rewrite.ml @@ -0,0 +1,2223 @@ +(************************************************************************) +(* 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_all 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_all 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_all 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 evars 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 CErrors.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 eq_pb (ty, env, x, y as pb) (ty', env', x', y' as pb') = + pb == pb' || (ty == ty' && Constr.equal x x' && Constr.equal y y') + +let problem_inclusion x y = + List.for_all (fun pb -> List.exists (fun pb' -> eq_pb pb pb') y) x + +let evd_convertible env evd x y = + try + (* Unfortunately, the_conv_x might say they are unifiable even if some + unsolvable constraints remain, so we check that this unification + does not introduce any new problem. *) + let _, pbs = Evd.extract_all_conv_pbs evd in + let evd' = Evarconv.the_conv_x env x y evd in + let _, pbs' = Evd.extract_all_conv_pbs evd' in + if evd' == evd || problem_inclusion pbs' pbs then Some evd' + else None + with e when CErrors.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 = true; + Unification.modulo_delta = ts; + Unification.modulo_delta_types = full_transparent_state; + 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 ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + let solve_tac = match tac with + | Genarg.GenArg (Genarg.Glbwit tag, tac) -> + Ftactic.run (Geninterp.interp tag ist tac) (fun _ -> Proofview.tclUNIT ()) + in + let solve_tac = tclCOMPLETE solve_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 = 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 + 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 CErrors.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 CErrors.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 (sigma, rew) = refresh_hypinfo env sigma c in + unify_eqn rew l2r flags env (sigma, cstrs) None t + 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 (CClosure.RedFlags.mkflags [CClosure.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 + user_err ~hdr:"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 (NamedDecl.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 (NamedDecl.get_id %> Id.equal id) ctx in + let nc = match before with + | [] -> assert false + | d :: rem -> insert_dependent env (LocalAssum (NamedDecl.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 = NamedDecl.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 + (** For compatibility *) + let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in + let beta = Tactics.reduct_in_concl (beta_red, DEFAULTcast) in + let beta_hyp id = Tactics.reduct_in_hyp beta_red (id, InHyp) 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 = tclTHENLIST [ + Refine.refine ~unsafe:false { run = fun h -> Sigma.here p h }; + Proofview.Unsafe.tclNEWGOALS gls; + ] in + Proofview.Unsafe.tclEVARS undef <*> + tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) + | Some id, None -> + Proofview.Unsafe.tclEVARS undef <*> + convert_hyp_no_check (LocalAssum (id, newt)) <*> + beta_hyp id + | 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 + 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 <*> 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 (); Proofview.tclUNIT () + with e when CErrors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Setoid library not loaded") + +let cl_rewrite_clause_strat progress strat clause = + tactic_init_setoid () <*> + (if progress then Proofview.tclPROGRESS else fun x -> x) + (Proofview.tclOR + (cl_rewrite_clause_newtac ~progress strat clause) + (fun (e, info) -> match e with + | RewriteFailure e -> + tclZEROMSG (str"setoid rewrite failed: " ++ e) + | Refiner.FailError (n, pp) -> + tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) + | e -> Proofview.tclZERO ~info e)) + +(** Setoid rewriting when called with "setoid_rewrite" *) +let cl_rewrite_clause l left2right occs clause = + let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in + cl_rewrite_clause_strat true strat clause + +(** 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 pr_ustrategy = function +| Subterms -> str "subterms" +| Subterm -> str "subterm" +| Innermost -> str "innermost" +| Outermost -> str "outermost" +| Bottomup -> str "bottomup" +| Topdown -> str "topdown" +| Progress -> str "progress" +| Try -> str "try" +| Any -> str "any" +| Repeat -> str "repeat" + +let paren p = str "(" ++ p ++ str ")" + +let rec pr_strategy prc prr = function +| StratId -> str "id" +| StratFail -> str "fail" +| StratRefl -> str "refl" +| StratUnary (s, str) -> + pr_ustrategy s ++ spc () ++ paren (pr_strategy prc prr str) +| StratBinary (Choice, str1, str2) -> + str "choice" ++ spc () ++ paren (pr_strategy prc prr str1) ++ spc () ++ + paren (pr_strategy prc prr str2) +| StratBinary (Compose, str1, str2) -> + pr_strategy prc prr str1 ++ str ";" ++ spc () ++ pr_strategy prc prr str2 +| StratConstr (c, true) -> prc c +| StratConstr (c, false) -> str "<-" ++ spc () ++ prc c +| StratTerms cl -> str "terms" ++ spc () ++ pr_sequence prc cl +| StratHints (old, id) -> + let cmd = if old then "old_hints" else "hints" in + str cmd ++ spc () ++ str id +| StratEval r -> str "eval" ++ spc () ++ prr r +| StratFold c -> str "fold" ++ spc () ++ prc 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 ~refine:false Hints.empty_hint_info + +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 sigma,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 sigma, typ = Typing.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 env sigma m = + 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 evd = Evd.nf_constraints evd in + let m = Evarutil.nf_evars_universes evd morph in + Pretyping.check_evars env Evd.empty evd m; + Evd.evar_universe_context evd, 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 env = Global.env () in + let evd = Evd.from_env env in + let uctx, instance = build_morphism_signature env evd m in + if Lib.is_modtype () then + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id + (Entries.ParameterEntry + (None,poly,(instance,Evd.evar_context_universe_context uctx),None), + Decl_kinds.IsAssumption Decl_kinds.Logical) + in + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info 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) Hints.empty_hint_info + 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.from_ctx uctx) 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) Hints.empty_hint_info) + +(** 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 = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in + let sigma, hi = decompose_applied_relation env evars (c,l) in + let but = match clause with + | Some id -> Tacmach.New.pf_get_hyp_typ id gl + | None -> Evarutil.nf_evar evars (Tacmach.New.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 = + Proofview.Goal.nf_enter { enter = begin fun 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 = Tacmach.New.project gl in + tactic_init_setoid () <*> + Proofview.tclOR + (tclPROGRESS + (tclTHEN + (Proofview.Unsafe.tclEVARS evd) + (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) + (fun (e, info) -> match e with + | RewriteFailure e -> + tclFAIL 0 (str"setoid rewrite failed: " ++ e) + | e -> Proofview.tclZERO ~info e) + end } + +let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite + +(** [setoid_]{reflexivity,symmetry,transitivity} tactics *) + +let not_declared env ty rel = + 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 (sigma, t) = Typing.type_of env sigma rel in + let car = RelDecl.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 = + (tclTHEN (Proofview.Unsafe.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 (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 -> 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 -> eapply proof + | Some c -> 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 + (tclTHENLAST + (Tactics.assert_after_replacing id new_hyp) + (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/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli new file mode 100644 index 0000000000..35c4483513 --- /dev/null +++ b/plugins/ltac/rewrite.mli @@ -0,0 +1,117 @@ +(************************************************************************) +(* 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 + +val pr_strategy : ('a -> Pp.std_ppcmds) -> ('b -> Pp.std_ppcmds) -> + ('a, 'b) strategy_ast -> Pp.std_ppcmds + +(** Entry point for user-level "rewrite_strat" *) +val cl_rewrite_clause_strat : strategy -> Id.t option -> unit Proofview.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 -> unit Proofview.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/plugins/ltac/tacarg.ml b/plugins/ltac/tacarg.ml new file mode 100644 index 0000000000..42552c4846 --- /dev/null +++ b/plugins/ltac/tacarg.ml @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t +| _ -> assert false + +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.typ -> 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 = Val.t + +let normalize v = v + +let of_constr c = in_gen (topwit wit_constr) c + +let to_constr v = + let v = normalize v in + if has_type v (topwit wit_constr) then + let c = out_gen (topwit wit_constr) v in + Some c + else if has_type v (topwit wit_constr_under_binders) then + let vars, c = out_gen (topwit wit_constr_under_binders) v in + match vars with [] -> Some c | _ -> None + else None + +let of_uconstr c = in_gen (topwit wit_uconstr) c + +let to_uconstr v = + let v = normalize v in + if has_type v (topwit wit_uconstr) then + Some (out_gen (topwit wit_uconstr) v) + else None + +let of_int i = in_gen (topwit wit_int) i + +let to_int v = + let v = normalize v in + if has_type v (topwit wit_int) then + Some (out_gen (topwit wit_int) v) + else None + +let to_list v = prj Val.typ_list v + +let to_option v = prj Val.typ_opt v + +let to_pair v = prj Val.typ_pair v + +end + +let is_variable env id = + Id.List.mem id (Termops.ids_of_named_context (Environ.named_context env)) + +(* 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) + +(* Gives the constr corresponding to a Constr_context tactic_arg *) +let coerce_to_constr_context v = + let v = Value.normalize v in + if has_type v (topwit wit_constr_context) then + out_gen (topwit wit_constr_context) v + else raise (CannotCoerceTo "a term context") + +(* Interprets an identifier which must be fresh *) +let coerce_var_to_ident fresh env v = + let v = Value.normalize v in + let fail () = raise (CannotCoerceTo "a fresh identifier") in + if has_type v (topwit wit_intro_pattern) then + match out_gen (topwit wit_intro_pattern) v with + | _, IntroNaming (IntroIdentifier id) -> id + | _ -> fail () + else if has_type v (topwit wit_var) then + out_gen (topwit wit_var) v + else match Value.to_constr v with + | None -> fail () + | Some c -> + (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *) + if isVar c && not (fresh && is_variable env (destVar c)) then + destVar c + else fail () + + +(* Interprets, if possible, a constr to an identifier which may not + be fresh but suitable to be given to the fresh tactic. Works for + vars, constants, inductive, constructors and sorts. *) +let coerce_to_ident_not_fresh g env v = +let id_of_name = function + | Names.Anonymous -> Id.of_string "x" + | Names.Name x -> x in + let v = Value.normalize v in + let fail () = raise (CannotCoerceTo "an identifier") in + if has_type v (topwit wit_intro_pattern) then + match out_gen (topwit wit_intro_pattern) v with + | _, IntroNaming (IntroIdentifier id) -> id + | _ -> fail () + else if has_type v (topwit wit_var) then + out_gen (topwit wit_var) v + else + match Value.to_constr v with + | None -> fail () + | Some c -> + match Constr.kind c with + | Var id -> id + | Meta m -> id_of_name (Evd.meta_name g m) + | Evar (kn,_) -> + begin match Evd.evar_ident kn g with + | None -> fail () + | Some id -> id + end + | Const (cst,_) -> Label.to_id (Constant.label cst) + | Construct (cstr,_) -> + let ref = Globnames.ConstructRef cstr in + let basename = Nametab.basename_of_global ref in + basename + | Ind (ind,_) -> + let ref = Globnames.IndRef ind in + let basename = Nametab.basename_of_global ref in + basename + | Sort s -> + begin + match s with + | Prop _ -> Label.to_id (Label.make "Prop") + | Type _ -> Label.to_id (Label.make "Type") + end + | _ -> fail() + + +let coerce_to_intro_pattern env v = + let v = Value.normalize v in + if has_type v (topwit wit_intro_pattern) then + snd (out_gen (topwit wit_intro_pattern) v) + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + IntroNaming (IntroIdentifier id) + else match Value.to_constr v with + | Some c when isVar c -> + (* This happens e.g. in definitions like "Tac H = clear H; intro H" *) + (* but also in "destruct H as (H,H')" *) + IntroNaming (IntroIdentifier (destVar c)) + | _ -> raise (CannotCoerceTo "an introduction pattern") + +let coerce_to_intro_pattern_naming env v = + match coerce_to_intro_pattern env v with + | IntroNaming pat -> pat + | _ -> raise (CannotCoerceTo "a naming introduction pattern") + +let coerce_to_hint_base v = + let v = Value.normalize v in + if has_type v (topwit wit_intro_pattern) then + match out_gen (topwit wit_intro_pattern) v with + | _, IntroNaming (IntroIdentifier id) -> Id.to_string id + | _ -> raise (CannotCoerceTo "a hint base name") + else raise (CannotCoerceTo "a hint base name") + +let coerce_to_int v = + let v = Value.normalize v in + if has_type v (topwit wit_int) then + out_gen (topwit wit_int) v + else raise (CannotCoerceTo "an integer") + +let coerce_to_constr env v = + let v = Value.normalize v in + let fail () = raise (CannotCoerceTo "a term") in + if has_type v (topwit wit_intro_pattern) then + match out_gen (topwit wit_intro_pattern) v with + | _, IntroNaming (IntroIdentifier id) -> + (try ([], constr_of_id env id) with Not_found -> fail ()) + | _ -> fail () + else if has_type v (topwit wit_constr) then + let c = out_gen (topwit wit_constr) v in + ([], c) + else if has_type v (topwit wit_constr_under_binders) then + out_gen (topwit wit_constr_under_binders) v + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + (try [], constr_of_id env id with Not_found -> fail ()) + else fail () + +let coerce_to_uconstr env v = + let v = Value.normalize v in + if has_type v (topwit wit_uconstr) then + out_gen (topwit wit_uconstr) v + else + raise (CannotCoerceTo "an untyped term") + +let coerce_to_closed_constr env v = + let ids,c = coerce_to_constr env v in + let () = if not (List.is_empty ids) then raise (CannotCoerceTo "a term") in + c + +let coerce_to_evaluable_ref env v = + let fail () = raise (CannotCoerceTo "an evaluable reference") in + let v = Value.normalize v in + let ev = + if has_type v (topwit wit_intro_pattern) then + match out_gen (topwit wit_intro_pattern) v with + | _, IntroNaming (IntroIdentifier id) when is_variable env id -> EvalVarRef id + | _ -> fail () + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + if Id.List.mem id (Termops.ids_of_context env) then EvalVarRef id + else fail () + else if has_type v (topwit wit_ref) then + let open Globnames in + let r = out_gen (topwit wit_ref) v in + match r with + | VarRef var -> EvalVarRef var + | ConstRef c -> EvalConstRef c + | IndRef _ | ConstructRef _ -> fail () + else + match Value.to_constr v with + | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c)) + | Some c when isVar c -> EvalVarRef (destVar c) + | _ -> fail () + in if Tacred.is_evaluable env ev then ev else fail () + +let coerce_to_constr_list env v = + let v = Value.to_list v in + match v with + | Some l -> + let map v = coerce_to_closed_constr env v in + List.map map l + | None -> raise (CannotCoerceTo "a term list") + +let coerce_to_intro_pattern_list loc env v = + match Value.to_list v with + | None -> raise (CannotCoerceTo "an intro pattern list") + | Some l -> + let map v = (loc, coerce_to_intro_pattern env v) in + List.map map l + +let coerce_to_hyp env v = + let fail () = raise (CannotCoerceTo "a variable") in + let v = Value.normalize v in + if has_type v (topwit wit_intro_pattern) then + match out_gen (topwit wit_intro_pattern) v with + | _, IntroNaming (IntroIdentifier id) when is_variable env id -> id + | _ -> fail () + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + if is_variable env id then id else fail () + else match Value.to_constr v with + | Some c when isVar c -> destVar c + | _ -> fail () + +let coerce_to_hyp_list env v = + let v = Value.to_list v in + match v with + | Some l -> + let map n = coerce_to_hyp env n in + List.map map l + | None -> raise (CannotCoerceTo "a variable list") + +(* Interprets a qualified name *) +let coerce_to_reference env v = + let v = Value.normalize v in + match Value.to_constr v with + | Some c -> + begin + try Globnames.global_of_constr c + with Not_found -> raise (CannotCoerceTo "a reference") + end + | None -> raise (CannotCoerceTo "a reference") + +(* Quantified named or numbered hypothesis or hypothesis in context *) +(* (as in Inversion) *) +let coerce_to_quantified_hypothesis v = + 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) -> NamedHyp id + | _ -> raise (CannotCoerceTo "a quantified hypothesis") + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + NamedHyp id + else if has_type v (topwit wit_int) then + AnonHyp (out_gen (topwit wit_int) v) + else match Value.to_constr v with + | Some c when isVar c -> NamedHyp (destVar c) + | _ -> raise (CannotCoerceTo "a quantified hypothesis") + +(* Quantified named or numbered hypothesis or hypothesis in context *) +(* (as in Inversion) *) +let coerce_to_decl_or_quant_hyp env v = + let v = Value.normalize v in + if has_type v (topwit wit_int) then + AnonHyp (out_gen (topwit wit_int) v) + else + try coerce_to_quantified_hypothesis v + with CannotCoerceTo _ -> + raise (CannotCoerceTo "a declared or quantified hypothesis") + +let coerce_to_int_or_var_list v = + match Value.to_list v with + | None -> raise (CannotCoerceTo "an int list") + | Some l -> + let map n = ArgArg (coerce_to_int n) in + List.map map l diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli new file mode 100644 index 0000000000..0b67f8726e --- /dev/null +++ b/plugins/ltac/taccoerce.mli @@ -0,0 +1,96 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t + (** Eliminated the leading dynamic type casts. *) + + val of_constr : constr -> t + val to_constr : t -> constr option + val of_uconstr : Glob_term.closed_glob_constr -> t + val to_uconstr : t -> Glob_term.closed_glob_constr option + val of_int : int -> t + val to_int : t -> int option + val to_list : t -> t list option + val to_option : t -> t option option + val to_pair : t -> (t * t) option +end + +(** {5 Coercion functions} *) + +val coerce_to_constr_context : Value.t -> constr + +val coerce_var_to_ident : bool -> Environ.env -> Value.t -> Id.t + +val coerce_to_ident_not_fresh : Evd.evar_map -> 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_hint_base : Value.t -> string + +val coerce_to_int : Value.t -> int + +val coerce_to_constr : Environ.env -> Value.t -> constr_under_binders + +val coerce_to_uconstr : Environ.env -> Value.t -> Glob_term.closed_glob_constr + +val coerce_to_closed_constr : Environ.env -> Value.t -> constr + +val coerce_to_evaluable_ref : + Environ.env -> Value.t -> evaluable_global_reference + +val coerce_to_constr_list : Environ.env -> Value.t -> constr list + +val coerce_to_intro_pattern_list : + Loc.t -> Environ.env -> Value.t -> Tacexpr.intro_patterns + +val coerce_to_hyp : Environ.env -> Value.t -> Id.t + +val coerce_to_hyp_list : Environ.env -> Value.t -> Id.t list + +val coerce_to_reference : Environ.env -> Value.t -> Globnames.global_reference + +val coerce_to_quantified_hypothesis : Value.t -> quantified_hypothesis + +val coerce_to_decl_or_quant_hyp : Environ.env -> Value.t -> quantified_hypothesis + +val coerce_to_int_or_var_list : Value.t -> int or_var list + +(** {5 Missing generic arguments} *) + +val wit_constr_context : (Empty.t, Empty.t, constr) genarg_type + +val wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) genarg_type diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml new file mode 100644 index 0000000000..2e2b55be74 --- /dev/null +++ b/plugins/ltac/tacentries.ml @@ -0,0 +1,525 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* entry_name + +(** 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 Tacarg.wit_tactic, Aself) + else if check_lvl (n + 1) then EntryName (rawwit Tacarg.wit_tactic, Anext) + else EntryName (rawwit Tacarg.wit_tactic, atactic n) + +let get_separator = function +| None -> error "Missing separator." +| Some sep -> 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 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)) 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)) 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)) 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)) 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 + Uentryl ("tactic", n) + else + Uentry s + +let arg_list = function Rawwit t -> Rawwit (ListArg t) +let arg_opt = function Rawwit t -> Rawwit (OptArg t) + +let interp_entry_name interp symb = + let rec eval = function + | Ulist1 e -> Ulist1 (eval e) + | Ulist1sep (e, sep) -> Ulist1sep (eval e, sep) + | Ulist0 e -> Ulist0 (eval e) + | Ulist0sep (e, sep) -> Ulist0sep (eval e, sep) + | Uopt e -> Uopt (eval e) + | Uentry s -> Uentry (interp s None) + | Uentryl (s, n) -> Uentryl (interp s (Some n), n) + in + eval symb + +(**********************************************************************) +(** Grammar declaration for Tactic Notation (Coq level) *) + +let get_tactic_entry n = + if Int.equal n 0 then + Pltac.simple_tactic, None + else if Int.equal n 5 then + Pltac.binder_tactic, None + else if 1<=n && n<5 then + Pltac.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 : Pptactic.grammar_terminals; +} + +(* Declaration of the tactic grammar rule *) + +let head_is_ident tg = match tg.tacgram_prods with +| TacTerm _ :: _ -> true +| _ -> false + +let rec prod_item_of_symbol lev = function +| Extend.Ulist1 s -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (ListArg typ), Alist1 e) +| Extend.Ulist0 s -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (ListArg typ), Alist0 e) +| Extend.Ulist1sep (s, sep) -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (ListArg typ), Alist1sep (e, Atoken (CLexer.terminal sep))) +| Extend.Ulist0sep (s, sep) -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (ListArg typ), Alist0sep (e, Atoken (CLexer.terminal sep))) +| Extend.Uopt s -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (OptArg typ), Aopt e) +| Extend.Uentry arg -> + let ArgT.Any tag = arg in + let wit = ExtraArg tag in + EntryName (Rawwit wit, Extend.Aentry (genarg_grammar wit)) +| Extend.Uentryl (s, n) -> + let ArgT.Any tag = s in + assert (coincide (ArgT.repr tag) "tactic" 0); + get_tacentry n lev + +(** Tactic grammar extensions *) + +let add_tactic_entry (kn, ml, tg) state = + let open Tacexpr in + let entry, pos = get_tactic_entry tg.tacgram_level in + let mkact loc l = + let map arg = + (** HACK to handle especially the tactic(...) entry *) + let wit = Genarg.rawwit Tacarg.wit_tactic in + if Genarg.has_type arg wit && not ml then + Tacexp (Genarg.out_gen wit arg) + else + TacGeneric arg + in + let l = List.map map l 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 map = function + | TacTerm s -> GramTerminal s + | TacNonTerm (loc, s, _) -> + let EntryName (typ, e) = prod_item_of_symbol tg.tacgram_level s in + GramNonTerminal (loc, typ, e) + in + let prods = List.map map tg.tacgram_prods in + let rules = make_rule mkact prods in + let r = ExtendRule (entry, None, (pos, [(None, None, [rules])])) in + ([r], state) + +let tactic_grammar = + create_grammar_command "TacticGrammar" add_tactic_entry + +let extend_tactic_grammar kn ml ntn = extend_grammar_command tactic_grammar (kn, ml, ntn) + +(**********************************************************************) +(* Tactic Notation *) + +let entry_names = ref String.Map.empty + +let register_tactic_notation_entry name entry = + let entry = match entry with + | ExtraArg arg -> ArgT.Any arg + | _ -> assert false + in + entry_names := String.Map.add name entry !entry_names + +let interp_prod_item = function + | TacTerm s -> TacTerm s + | TacNonTerm (loc, (nt, sep), id) -> + let symbol = parse_user_entry nt sep in + let interp s = function + | None -> + if String.Map.mem s !entry_names then String.Map.find s !entry_names + else begin match ArgT.name s with + | None -> error ("Unknown entry "^s^".") + | Some arg -> arg + end + | Some n -> + (** FIXME: do better someday *) + assert (String.equal s "tactic"); + begin match Tacarg.wit_tactic with + | ExtraArg tag -> ArgT.Any tag + | _ -> assert false + end + in + let symbol = interp_entry_name interp symbol in + TacNonTerm (loc, symbol, id) + +let make_fresh_key = + let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in + fun prods -> + let cur = incr id; !id in + let map = function + | TacTerm s -> s + | TacNonTerm _ -> "#" + in + let prods = String.concat "_" (List.map map prods) in + (** We embed the hash of the kernel name in the label so that the identifier + should be mostly unique. This ensures that including two modules + together won't confuse the corresponding labels. *) + let hash = (cur lxor (ModPath.hash (Lib.current_mp ()))) land 0x7FFFFFFF in + let lbl = Id.of_string_soft (Printf.sprintf "%s_%08X" prods hash) in + Lib.make_kn lbl + +type tactic_grammar_obj = { + tacobj_key : KerName.t; + tacobj_local : locality_flag; + tacobj_tacgram : tactic_grammar; + tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; + tacobj_forml : bool; +} + +let pprule pa = { + Pptactic.pptac_level = pa.tacgram_level; + pptac_prods = pa.tacgram_prods; +} + +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; + extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram; + Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram) + +let open_tactic_notation i (_, tobj) = + let key = tobj.tacobj_key in + if Int.equal i 1 && not tobj.tacobj_local then + extend_tactic_grammar key tobj.tacobj_forml 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 (pprule tobj.tacobj_tacgram); + if Int.equal i 1 && not tobj.tacobj_local then + extend_tactic_grammar key tobj.tacobj_forml 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_glob_tactic_notation local n prods forml ids tac = + let parule = { + tacgram_level = n; + tacgram_prods = prods; + } in + let tacobj = { + tacobj_key = make_fresh_key prods; + tacobj_local = local; + tacobj_tacgram = parule; + tacobj_body = (ids, tac); + tacobj_forml = forml; + } in + Lib.add_anonymous_leaf (inTacticGrammar tacobj) + +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 prods in + let tac = Tacintern.glob_tactic_env ids (Global.env()) e in + add_glob_tactic_notation local n prods false ids tac + +(**********************************************************************) +(* ML Tactic entries *) + +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 + | TacTerm s :: rem -> (s, rem) + | _ -> assert false (** Not handled by the ML extension syntax *) + in + let empty_value = function + | TacTerm s -> raise NonEmptyArgument + | TacNonTerm (_, symb, _) -> + let EntryName (typ, e) = prod_item_of_symbol 0 symb in + 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 add_ml_tactic_notation name prods = + let len = List.length prods in + let iter i prods = + let open Tacexpr in + let get_id = function + | TacTerm s -> None + | TacNonTerm (_, _, id) -> Some id + in + let ids = List.map_filter get_id prods in + let entry = { mltac_name = name; mltac_index = len - i - 1 } in + let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in + let tac = TacML (Loc.ghost, entry, List.map map ids) in + add_glob_tactic_notation false 0 prods true ids tac + in + List.iteri iter (List.rev prods); + extend_atomic_tactic name prods + +(**********************************************************************) +(** 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 e + | Some l -> Aentryl (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 (CLexer.terminal name)), + Atoken (CLexer.terminal ":")), + Atoken (CLexer.terminal "(")), + entry), + Atoken (CLexer.terminal ")")) + in + let action _ v _ _ _ loc = cast (loc, v) in + let gram = (level, assoc, [Rule (rule, action)]) in + Pcoq.grammar_extend Pltac.tactic_arg None (None, [gram]) + +(** 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 warn_unusable_identifier = + CWarnings.create ~name:"unusable-identifier" ~category:"parsing" + (fun id -> strbrk "The Ltac name" ++ spc () ++ pr_id id ++ spc () ++ + strbrk "may be unusable because of a conflict with a notation.") + +let register_ltac local tacl = + let map tactic_body = + match tactic_body with + | Tacexpr.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 + CErrors.user_err ~loc + (str "There is already an Ltac named " ++ id_pp ++ str".") + in + let is_shadowed = + try + match Pcoq.parse_string Pltac.tactic (Id.to_string id) with + | Tacexpr.TacArg _ -> false + | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) + with e when CErrors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) + in + let () = if is_shadowed then warn_unusable_identifier id in + NewTac id, body + | Tacexpr.TacticRedefinition (ident, body) -> + let loc = loc_of_reference ident in + let kn = + try Nametab.locate_tactic (snd (qualid_of_reference ident)) + with Not_found -> + CErrors.user_err ~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 Feedback.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 Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined") + in + List.iter iter defs + +(** Queries *) + +let print_ltacs () = + let entries = KNmap.bindings (Tacenv.ltac_entries ()) in + let sort (kn1, _) (kn2, _) = KerName.compare kn1 kn2 in + let entries = List.sort sort entries in + let map (kn, entry) = + let qid = + try Some (Nametab.shortest_qualid_of_tactic kn) + with Not_found -> None + in + match qid with + | None -> None + | Some qid -> Some (qid, entry.Tacenv.tac_body) + in + let entries = List.map_filter map entries in + let pr_entry (qid, body) = + let (l, t) = match body with + | Tacexpr.TacFun (l, t) -> (l, t) + | _ -> ([], body) + in + let pr_ltac_fun_arg = function + | None -> spc () ++ str "_" + | Some id -> spc () ++ pr_id id + in + hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) + in + Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) + +(** Grammar *) + +let () = + let open Metasyntax in + let entries = [ + AnyEntry Pltac.tactic_expr; + AnyEntry Pltac.binder_tactic; + AnyEntry Pltac.simple_tactic; + AnyEntry Pltac.tactic_arg; + ] in + register_grammar "tactic" entries diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli new file mode 100644 index 0000000000..969c118fb5 --- /dev/null +++ b/plugins/ltac/tacentries.mli @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tacexpr.tacdef_body list -> unit +(** Adds new Ltac definitions to the environment. *) + +(** {5 Tactic Notations} *) + +type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr = +| TacTerm of string +| TacNonTerm of Loc.t * 'a * Names.Id.t + +type raw_argument = string * string option +(** An argument type as provided in Tactic notations, i.e. a string like + "ne_foo_list_opt" together with a separator that only makes sense in the + "_sep" cases. *) + +type argument = Genarg.ArgT.any Extend.user_symbol +(** A fully resolved argument type given as an AST with generic arguments on the + leaves. *) + +val add_tactic_notation : + locality_flag -> int -> raw_argument grammar_tactic_prod_item_expr list -> + raw_tactic_expr -> unit +(** [add_tactic_notation local level prods expr] adds a tactic notation in the + environment at level [level] with locality [local] made of the grammar + productions [prods] and returning the body [expr] *) + +val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type -> unit +(** Register an argument under a given entry name for tactic notations. When + translating [raw_argument] into [argument], atomic names will be first + looked up according to names registered through this function and fallback + to finding an argument by name (as in {!Genarg}) if there is none + matching. *) + +val add_ml_tactic_notation : ml_tactic_name -> + argument grammar_tactic_prod_item_expr list list -> unit +(** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND + ML-side macro. *) + +(** {5 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]. *) + +(** {5 Queries} *) + +val print_ltacs : unit -> unit +(** Display the list of ltac definitions currently available. *) diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml new file mode 100644 index 0000000000..e3c2b4ad51 --- /dev/null +++ b/plugins/ltac/tacenv.ml @@ -0,0 +1,143 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* CErrors.anomaly (str "Unknown tactic alias: " ++ KerName.print key) + +let check_alias key = KNmap.mem key !alias_map + +(** ML tactic extensions (TacML) *) + +type ml_tactic = + Geninterp.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 + tac_tab := MLTacMap.remove s !tac_tab + else + CErrors.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 -> + CErrors.user_err + (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/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli new file mode 100644 index 0000000000..94e14223aa --- /dev/null +++ b/plugins/ltac/tacenv.mli @@ -0,0 +1,75 @@ +(************************************************************************) +(* 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/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli new file mode 100644 index 0000000000..9c25a16457 --- /dev/null +++ b/plugins/ltac/tacexpr.mli @@ -0,0 +1,396 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'r Sigma.t -> ('a, 'r) Sigma.sigma } + +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 +type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr located +type intro_pattern_naming = intro_pattern_naming_expr located + +(** Generic expressions for atomic tactics *) + +type 'a gen_atomic_tactic_expr = + (* Basic tactics *) + | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr located list + | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * + ('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 + | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list + | TacMutualCofix of Id.t * (Id.t * 'trm) list + | TacAssert of + bool * 'tacexpr option option * + 'dtrm intro_pattern_expr located option * 'trm + | TacGeneralize of ('trm with_occurrences * Name.t) list + | TacLetTac of Name.t * 'trm * 'nam clause_expr * letin_flag * + intro_pattern_naming_expr located option + + (* Derived basic tactics *) + | TacInductionDestruct of + rec_flag * evars_flag * ('trm,'dtrm,'nam) induction_clause_list + + (* Conversion *) + | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr + | TacChange of 'pat option * 'dtrm * 'nam clause_expr + + (* Equality and inversion *) + | TacRewrite of evars_flag * + (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * + (* spiwack: using ['dtrm] here is a small hack, may not be + stable by a change in the representation of delayed + terms. Because, in fact, it is the whole "with_bindings" + which is delayed. But because the "t" level for ['dtrm] is + uninterpreted, it works fine here too, and avoid more + disruption of this file. *) + 'tacexpr option + | TacInversion of ('trm,'dtrm,'nam) inversion_strength * quantified_hypothesis + +constraint 'a = < + term:'trm; + dterm: 'dtrm; + pattern:'pat; + constant:'cst; + reference:'ref; + name:'nam; + tacexpr:'tacexpr; + level:'lev +> + +(** Possible arguments of a tactic definition *) + +type 'a gen_tactic_arg = + | TacGeneric of 'lev generic_argument + | ConstrMayEval of ('trm,'cst,'pat) may_eval + | Reference of 'ref + | TacCall of Loc.t * 'ref * + 'a gen_tactic_arg list + | TacFreshId of string or_var list + | Tacexp of 'tacexpr + | TacPretype of 'trm + | TacNumgoals + +constraint 'a = < + term:'trm; + dterm: 'dtrm; + pattern:'pat; + constant:'cst; + reference:'ref; + name:'nam; + tacexpr:'tacexpr; + level:'lev +> + +(** Generic ltac expressions. + 't : terms, 'p : patterns, 'c : constants, 'i : inductive, + 'r : ltac refs, 'n : idents, 'l : levels *) + +and 'a gen_tactic_expr = + | TacAtom of Loc.t * 'a gen_atomic_tactic_expr + | TacThen of + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacDispatch of + 'a gen_tactic_expr list + | TacExtendTac of + 'a gen_tactic_expr array * + 'a gen_tactic_expr * + 'a gen_tactic_expr array + | TacThens of + 'a gen_tactic_expr * + 'a gen_tactic_expr list + | TacThens3parts of + 'a gen_tactic_expr * + 'a gen_tactic_expr array * + 'a gen_tactic_expr * + 'a gen_tactic_expr array + | TacFirst of 'a gen_tactic_expr list + | TacComplete of 'a gen_tactic_expr + | TacSolve of 'a gen_tactic_expr list + | TacTry of 'a gen_tactic_expr + | TacOr of + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacOnce of + 'a gen_tactic_expr + | TacExactlyOnce of + 'a gen_tactic_expr + | TacIfThenCatch of + 'a gen_tactic_expr * + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacOrelse of + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacDo of int or_var * 'a gen_tactic_expr + | TacTimeout of int or_var * 'a gen_tactic_expr + | TacTime of string option * 'a gen_tactic_expr + | TacRepeat of 'a gen_tactic_expr + | TacProgress of 'a gen_tactic_expr + | TacShowHyps of 'a gen_tactic_expr + | TacAbstract of + 'a gen_tactic_expr * Id.t option + | TacId of 'n message_token list + | TacFail of global_flag * int or_var * 'n message_token list + | TacInfo of 'a gen_tactic_expr + | TacLetIn of rec_flag * + (Id.t located * 'a gen_tactic_arg) list * + 'a gen_tactic_expr + | TacMatch of lazy_flag * + 'a gen_tactic_expr * + ('p,'a gen_tactic_expr) match_rule list + | TacMatchGoal of lazy_flag * direction_flag * + ('p,'a gen_tactic_expr) match_rule list + | TacFun of 'a gen_tactic_fun_ast + | TacArg of 'a gen_tactic_arg located + | TacSelect of goal_selector * '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 * 'a gen_tactic_arg list + +constraint 'a = < + term:'t; + dterm: 'dtrm; + pattern:'p; + constant:'c; + reference:'r; + name:'n; + tacexpr:'tacexpr; + level:'l +> + +and 'a gen_tactic_fun_ast = + Id.t option list * 'a gen_tactic_expr + +constraint 'a = < + term:'t; + dterm: 'dtrm; + pattern:'p; + constant:'c; + reference:'r; + name:'n; + tacexpr:'te; + level:'l +> + +(** Globalized tactics *) + +type g_trm = glob_constr_and_expr +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 + +type g_dispatch = < + term:g_trm; + dterm:g_trm; + pattern:g_pat; + constant:g_cst; + reference:g_ref; + name:g_nam; + tacexpr:glob_tactic_expr; + level:glevel +> + +and glob_tactic_expr = + g_dispatch gen_tactic_expr + +type glob_atomic_tactic_expr = + g_dispatch gen_atomic_tactic_expr + +type glob_tactic_arg = + g_dispatch gen_tactic_arg + +(** Raw tactics *) + +type r_trm = constr_expr +type r_pat = constr_pattern_expr +type r_cst = reference or_by_notation +type r_ref = reference +type r_nam = Id.t located +type r_lev = rlevel + +type r_dispatch = < + term:r_trm; + dterm:r_trm; + pattern:r_pat; + constant:r_cst; + reference:r_ref; + name:r_nam; + tacexpr:raw_tactic_expr; + level:rlevel +> + +and raw_tactic_expr = + r_dispatch gen_tactic_expr + +type raw_atomic_tactic_expr = + r_dispatch gen_atomic_tactic_expr + +type raw_tactic_arg = + r_dispatch gen_tactic_arg + +(** Interpreted tactics *) + +type t_trm = Term.constr +type t_pat = constr_pattern +type t_cst = evaluable_global_reference +type t_ref = ltac_constant located +type t_nam = Id.t + +type t_dispatch = < + term:t_trm; + dterm:g_trm; + pattern:t_pat; + constant:t_cst; + reference:t_ref; + name:t_nam; + tacexpr:unit; + level:tlevel +> + +type atomic_tactic_expr = + t_dispatch gen_atomic_tactic_expr + +(** Misc *) + +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 + +type 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 *) diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml new file mode 100644 index 0000000000..763e0dc22e --- /dev/null +++ b/plugins/ltac/tacintern.ml @@ -0,0 +1,812 @@ +(************************************************************************) +(* 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 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 (snd 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 (snd (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 (snd (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 (snd (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_destruction_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 (snd 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 (glob,_ as c) = intern_constr_gen true false ist pc in + let bound_names = Glob_ops.bound_glob_vars glob in + metas,(bound_names,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 *) + let (glob,_ as c) = intern_constr_gen true false ist p in + let bound_names = Glob_ops.bound_glob_vars glob in + (bound_names,c,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)) + | _ -> + let bound_names = Glob_ops.bound_glob_vars c in + Inr (bound_names,(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 CErrors.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 CErrors.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:false ~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 ?(as_type=false) 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 ~as_type 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 + ~hdr:"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} + +(* 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 (ev,l) -> + TacIntroPattern (ev,List.map (intern_intro_pattern lf ist) l) + | 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 (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_destruction_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)) + (* 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 ~as_type:true 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 + | TacSelect (sel, tac) -> + ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac) + + (* 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 ?(as_type=false) = function + | (All tc)::tl -> + All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist ~as_type tl) + | (Pat (rl,mp,tc))::tl -> + let {ltacvars=lfun; genv=env} = ist in + let lfun',metas1,hyps = intern_match_goal_hyps ist ~as_type lfun rl in + let ido,metas2,pat = intern_pattern ist ~as_type 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 ~as_type 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 -> + user_err ~hdr:"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 intern_ltac ist tac = + Flags.with_option strict_check (fun () -> intern_pure_tactic ist tac) () + +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_ltac); + 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_destruction_arg (lift intern_destruction_arg); + () + +(** Substitution for notations containing tactic-in-terms *) + +let notation_subst bindings tac = + let fold id c accu = + let loc = Glob_ops.loc_of_glob_constr (fst c) in + let c = ConstrMayEval (ConstrTerm c) in + ((loc, id), c) :: accu + in + let bindings = Id.Map.fold fold bindings [] in + (** This is theoretically not correct due to potential variable capture, but + Ltac has no true variables so one cannot simply substitute *) + TacLetIn (false, bindings, tac) + +let () = Genintern.register_ntn_subst0 wit_tactic notation_subst diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli new file mode 100644 index 0000000000..71ca354fa1 --- /dev/null +++ b/plugins/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/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml new file mode 100644 index 0000000000..32bcdfb6a4 --- /dev/null +++ b/plugins/ltac/tacinterp.ml @@ -0,0 +1,2157 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* a typed_abstract_argument_type -> bool = fun v wit -> + let Val.Dyn (t, _) = v in + let t' = match val_tag wit with + | Val.Base t' -> t' + | _ -> assert false (** not used in this module *) + in + match Val.eq t t' with + | None -> false + | Some Refl -> true + +let prj : type a. a Val.typ -> 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_list tag v = + let tag = match tag with Val.Base tag -> tag | _ -> assert false in + Val.Dyn (Val.typ_list, List.map (fun x -> Val.Dyn (tag, x)) v) +let in_gen wit v = + let t = match val_tag wit with + | Val.Base t -> t + | _ -> assert false (** not used in this module *) + in + Val.Dyn (t, v) +let out_gen wit v = + let t = match val_tag wit with + | Val.Base t -> t + | _ -> assert false (** not used in this module *) + in + match prj t 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.pr 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 = + let Val.Dyn (tag, _) = arg in + 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 +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) = + let wit = Genarg.create_arg "tacvalue" in + let () = register_val0 wit None in + wit + +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 = Pptactic.pr_value Pptactic.ltop v in + let Val.Dyn (tag, _) = v in + let tag = Val.pr tag in + user_err (str "Type error: value " ++ pr_v ++ str " is a " ++ tag + ++ str " while type " ++ Val.pr wit ++ str " was expected.") + + let unbox wit v ans = match ans with + | None -> cast_error wit v + | Some x -> x + + let rec prj : type a. a Val.tag -> Val.t -> a = fun tag v -> match tag with + | Val.List tag -> List.map (fun v -> prj tag v) (unbox Val.typ_list v (to_list v)) + | Val.Opt tag -> Option.map (fun v -> prj tag v) (unbox Val.typ_opt v (to_option v)) + | Val.Pair (tag1, tag2) -> + let (x, y) = unbox Val.typ_pair v (to_pair v) in + (prj tag1 x, prj tag2 y) + | Val.Base t -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> cast_error t v + | Some Refl -> x + + let rec tag_of_arg : type a b c. (a, b, c) genarg_type -> c Val.tag = fun wit -> match wit with + | ExtraArg _ -> val_tag wit + | ListArg t -> Val.List (tag_of_arg t) + | OptArg t -> Val.Opt (tag_of_arg t) + | PairArg (t1, t2) -> Val.Pair (tag_of_arg t1, tag_of_arg t2) + + let val_cast arg v = prj (tag_of_arg arg) v + + let cast (Topwit wit) v = val_cast wit v + +end + +let print_top_val env v = Pptactic.pr_value Pptactic.ltop v + +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 (CErrors.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 CErrors.noncritical e -> + let e = CErrors.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 *) + +(* Some of the code further down depends on the fact that push_trace does not modify sigma (the evar map) *) +let push_trace call ist = match TacStore.get ist.extra f_trace with +| None -> Proofview.tclUNIT [call] +| Some trace -> Proofview.tclUNIT (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 + push_trace(loc,LtacVarCall (id,t)) ist >>= fun trace -> + let ans = VFun (appl,trace,lfun,it,b) in + Proofview.tclUNIT (of_tacvalue ans) + | _ -> Proofview.tclUNIT v + else Proofview.tclUNIT 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 + (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 (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_var_to_ident false env) ist (Some (env,sigma)) (dloc,id) + with Not_found -> id + +(* 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) ~hdr:"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 (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 (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 (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 extract_ident ist env sigma id = + try try_interp_ltac_var (coerce_to_ident_not_fresh sigma env) + ist (Some (env,sigma)) (dloc,id) + with Not_found -> id in + 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 (extract_ident ist env sigma id)) l) in + let s = if CLexer.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_var_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 + (* Jason Gross: To avoid unnecessary modifications to tacinterp, as + suggested by Arnaud Spiwack, we run push_trace immediately. We do + this with the kludge of an empty proofview, and rely on the + invariant that running the tactic returned by push_trace does + not modify sigma. *) + let (_, dummy_proofview) = Proofview.init sigma [] in + let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist) dummy_proofview 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; + solve_unification_constraints = 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; + solve_unification_constraints = true; + use_hook = Some solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true } + +let open_constr_no_classes_flags = { + use_typeclasses = false; + solve_unification_constraints = true; + use_hook = Some solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true } + +let pure_open_constr_flags = { + use_typeclasses = false; + solve_unification_constraints = 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 *) +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 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 (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 ~hdr:"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 = CErrors.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 = CErrors.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 if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_id id) 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) + | _ -> + user_err ~loc (str "Cannot coerce to a disjunctive/conjunctive 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_destruction_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 + (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 ~hdr:"interp_destruction_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 (bvars,(glob,_),pat as c) = + if use_types then + (bvars,interp_typed_pattern ist env sigma c) + else + (bvars,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 ~hdr:"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 + | [] -> [] + +let warn_deprecated_info = + CWarnings.create ~name:"deprecated-info-tactical" ~category:"deprecated" + (fun () -> + 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.") + +(* 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 + push_trace(loc,call) ist >>= fun trace -> + Profile_ltac.do_profile "eval_tactic:2" trace + (catch_error_tac trace (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 (interp_ident ist (pf_env gl) (project 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 -> + warn_deprecated_info (); + eval_tactic ist tac + | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_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 + Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> + 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) -> + push_trace (loc,LtacMLCall tac) ist >>= fun trace -> + 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 + let open Ftactic in + force_vrec ist v >>= begin fun v -> + Ftactic.lift (propagate_trace ist loc id v) >>= fun v -> + 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 + push_trace loc_info ist >>= fun trace -> + let extra = TacStore.set extra f_trace trace 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 + Profile_ltac.do_profile "tactic_of_value" trace (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) in + Ftactic.List.map map x >>= fun l -> + Ftactic.return (Val.Dyn (Val.typ_list, l)) + | OptArg wit -> + begin match x with + | None -> Ftactic.return (Val.Dyn (Val.typ_opt, None)) + | Some x -> + interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> + Ftactic.return (Val.Dyn (Val.typ_opt, Some x)) + end + | 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 -> + Ftactic.return (Val.Dyn (Val.typ_pair, (p, q))) + | ExtraArg s -> + Geninterp.interp wit ist 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 = in_list (val_tag wit_constr) lc in + Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) + end } + +and interp_genarg_var_list ist x = + Ftactic.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 + let lc = in_list (val_tag wit_var) lc in + Ftactic.return 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_atomic_tactic env 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 (ev,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 ev + (name_atomic ~env + (TacIntroPattern (ev,l)) + (* spiwack: print uninterpreted, not sure if it is the + expected behaviour. *) + (Tactics.intro_patterns ev l')) sigma + 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) = 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 = 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) = 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 = 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 (Option.map (interp_tactic ist)) t in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacAssert(b,Option.map (Option.map ignore) 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) + (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) = interp_constr ist env sigma 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_destruction_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 } + + (* Conversion *) + | TacReduce (r,cl) -> + 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 } + | 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 + 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 + let op = interp_typed_pattern ist env sigma op in + let to_catch = function Not_found -> true | e -> CErrors.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 *) -> + user_err (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) + 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,Option.map ignore 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) = interp_constr ist env sigma 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 + +(* 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 register_interp0 wit f = + let open Ftactic.Notations in + let interp ist v = + f ist v >>= fun v -> Ftactic.return (Val.inject (val_tag wit) v) + in + Geninterp.register_interp0 wit interp + +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; + 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.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 interp_destruction_arg' ist c = Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (interp_destruction_arg ist gl c) +end } + +let () = + register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); + register_interp0 wit_ref (lift interp_reference); + register_interp0 wit_ident (lift interp_ident); + register_interp0 wit_var (lift interp_hyp); + register_interp0 wit_intro_pattern (lifts interp_intro_pattern); + register_interp0 wit_clause_dft_concl (lift interp_clause); + register_interp0 wit_constr (lifts interp_constr); + register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v); + register_interp0 wit_red_expr (lifts interp_red_expr); + register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); + register_interp0 wit_open_constr (lifts interp_open_constr); + register_interp0 wit_bindings interp_bindings'; + register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; + register_interp0 wit_destruction_arg interp_destruction_arg'; + () + +let () = + let interp ist tac = Ftactic.return (Value.of_closure ist tac) in + register_interp0 wit_tactic interp + +let () = + let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in + register_interp0 wit_ltac interp + +let () = + 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 _ = + let open Goptions in + declare_bool_option + { optsync = false; + optdepr = false; + optname = "Ltac debug"; + optkey = ["Debug";"Ltac"]; + optread = (fun () -> get_debug () != Tactic_debug.DebugOff); + optwrite = vernac_debug } + +let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli new file mode 100644 index 0000000000..6f64981eff --- /dev/null +++ b/plugins/ltac/tacinterp.mli @@ -0,0 +1,122 @@ +(************************************************************************) +(* 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 -> Geninterp.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 + +(** 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_constr_gen : Pretyping.typing_constraint -> interp_sign -> + Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Evd.evar_map * constr + +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/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml new file mode 100644 index 0000000000..55de583613 --- /dev/null +++ b/plugins/ltac/tacsubst.ml @@ -0,0 +1,308 @@ +(************************************************************************) +(* 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_destruction_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 + Feedback.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 (bvars,c,p) = + (bvars,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 (ev,l) -> TacIntroPattern (ev,List.map (subst_intro_pattern subst) l) + | 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 (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_destruction_arg subst c, ids, cls) l in + let el' = Option.map (subst_glob_with_bindings subst) el in + TacInductionDestruct (isrec,ev,(l',el')) + + (* 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) + | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac) + + (* 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_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_destruction_arg subst_destruction_arg; + () diff --git a/plugins/ltac/tacsubst.mli b/plugins/ltac/tacsubst.mli new file mode 100644 index 0000000000..c1bf272579 --- /dev/null +++ b/plugins/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/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml new file mode 100644 index 0000000000..5cbddc7f64 --- /dev/null +++ b/plugins/ltac/tactic_debug.ml @@ -0,0 +1,422 @@ +(************************************************************************) +(* 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 = + CErrors.print (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))) + +let explain_logic_error_no_anomaly e = + CErrors.print_no_report + (fst (ExplainErr.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) :: _ -> not (Tacenv.is_ltac_for_ml_tactic f) + | (_, Tacexpr.LtacNotationCall f) :: _ -> true + | (_, Tacexpr.LtacAtomCall _) :: _ -> 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 (Pptactic.pr_alias_key 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 () + | [a] -> hov 0 (str "Ltac call to " ++ pr_call a ++ str " failed.") + | _ -> + 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 _ as tac) :: (_,Tacexpr.LtacMLCall _) :: _ -> + (* Case of an ML defined tactic with entry of the form <<"foo" args>> *) + (* see tacextend.mlp *) + [tac] + | (_,Tacexpr.LtacMLCall _ as tac) :: _ -> [tac] + | t :: tail -> t :: aux tail + | [] -> [] in + List.rev (aux (List.rev trace)) + +let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2 + +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, if finer_loc eloc loc then eloc else loc + else + (* We entered a primitive tactic, we don't display trace but + report on the finest location *) + let best_loc = + (* trace is with innermost call coming first *) + let rec aux best_loc = function + | (loc,_)::tail -> + if Loc.is_ghost best_loc || + not (Loc.is_ghost loc) && finer_loc loc best_loc + then + aux loc tail + else + aux best_loc tail + | [] -> best_loc in + aux eloc 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 () = ExplainErr.register_additional_error_info get_ltac_trace diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli new file mode 100644 index 0000000000..520fb41eff --- /dev/null +++ b/plugins/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/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml new file mode 100644 index 0000000000..ef45ee47e1 --- /dev/null +++ b/plugins/ltac/tactic_matching.ml @@ -0,0 +1,377 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + Constr_matching.bound_ident_map * Pattern.extended_patvar_map = + fun (l, lc) -> (l, Id.Map.map (fun c -> [], c) lc) + + +(** Adds a binding to a {!Id.Map.t} if the identifier is [Some id] *) +let id_map_try_add id x m = + match id with + | Some id -> Id.Map.add id x m + | None -> m + +(** Adds a binding to a {!Id.Map.t} if the name is [Name id] *) +let id_map_try_add_name id x m = + match id with + | Name id -> Id.Map.add id x m + | Anonymous -> m + +(** Takes the union of two {!Id.Map.t}. If there is conflict, + the binding of the right-hand argument shadows that of the left-hand + argument. *) +let id_map_right_biased_union m1 m2 = + if Id.Map.is_empty m1 then m2 (** Don't reconstruct the whole map *) + else Id.Map.fold Id.Map.add m2 m1 + +(** Tests whether the substitution [s] is empty. *) +let is_empty_subst (ln,lm) = + Id.Map.(is_empty ln && is_empty lm) + +(** {6 Non-linear patterns} *) + + +(** The patterns of Ltac are not necessarily linear. Non-linear + pattern are partially handled by the {!Matching} module, however + goal patterns are not primitive to {!Matching}, hence we must deal + with non-linearity between hypotheses and conclusion. Subterms are + considered equal up to the equality implemented in + [equal_instances]. *) +(* spiwack: it doesn't seem to be quite the same rule for non-linear + term patterns and non-linearity between hypotheses and/or + conclusion. Indeed, in [Matching], matching is made modulo + syntactic equality, and here we merge modulo conversion. It may be + a good idea to have an entry point of [Matching] with a partial + substitution as argument instead of merging substitution here. That + would ensure consistency. *) +let equal_instances env sigma (ctx',c') (ctx,c) = + (* How to compare instances? Do we want the terms to be convertible? + unifiable? Do we want the universe levels to be relevant? + (historically, conv_x is used) *) + CList.equal Id.equal ctx ctx' && Reductionops.is_conv env sigma c' c + + +(** Merges two substitutions. Raises [Not_coherent_metas] when + encountering two instances of the same metavariable which are not + equal according to {!equal_instances}. *) +exception Not_coherent_metas +let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) = + let merge id oc1 oc2 = match oc1, oc2 with + | None, None -> None + | None, Some c | Some c, None -> Some c + | Some c1, Some c2 -> + if equal_instances env sigma c1 c2 then Some c1 + else raise Not_coherent_metas + in + let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 in + (** ppedrot: Is that even correct? *) + let merged = ln +++ ln1 in + (merged, Id.Map.merge merge lcm lm) + +let matching_error = + CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") + +let imatching_error = (matching_error, Exninfo.null) + +(** A functor is introduced to share the environment and the + evar_map. They do not change and it would be a pity to introduce + closures everywhere just for the occasional calls to + {!equal_instances}. *) +module type StaticEnvironment = sig + val env : Environ.env + val sigma : Evd.evar_map +end +module PatternMatching (E:StaticEnvironment) = struct + + + (** {6 The pattern-matching monad } *) + + + (** To focus on the algorithmic portion of pattern-matching, the + bookkeeping is relegated to a monad: the composition of the + bactracking monad of {!IStream.t} with a "writer" effect. *) + (* spiwack: as we don't benefit from the various stream optimisations + of Haskell, it may be costly to give the monad in direct style such as + here. We may want to use some continuation passing style. *) + type 'a tac = 'a Proofview.tactic + type 'a m = { stream : 'r. ('a -> unit t -> 'r tac) -> unit t -> 'r tac } + + (** The empty substitution. *) + let empty_subst = Id.Map.empty , Id.Map.empty + + (** Composes two substitutions using {!verify_metas_coherence}. It + must be a monoid with neutral element {!empty_subst}. Raises + [Not_coherent_metas] when composition cannot be achieved. *) + let subst_prod s1 s2 = + if is_empty_subst s1 then s2 + else if is_empty_subst s2 then s1 + else verify_metas_coherence E.env E.sigma s1 s2 + + (** The empty context substitution. *) + let empty_context_subst = Id.Map.empty + + (** Compose two context substitutions, in case of conflict the + right hand substitution shadows the left hand one. *) + let context_subst_prod = id_map_right_biased_union + + (** The empty term substitution. *) + let empty_term_subst = Id.Map.empty + + (** Compose two terms substitutions, in case of conflict the + right hand substitution shadows the left hand one. *) + let term_subst_prod = id_map_right_biased_union + + (** Merge two writers (and ignore the first value component). *) + let merge m1 m2 = + try Some { + subst = subst_prod m1.subst m2.subst; + context = context_subst_prod m1.context m2.context; + terms = term_subst_prod m1.terms m2.terms; + lhs = m2.lhs; + } + with Not_coherent_metas -> None + + (** Monadic [return]: returns a single success with empty substitutions. *) + let return (type a) (lhs:a) : a m = + { stream = fun k ctx -> k lhs ctx } + + (** Monadic bind: each success of [x] is replaced by the successes + of [f x]. The substitutions of [x] and [f x] are composed, + dropping the apparent successes when the substitutions are not + coherent. *) + let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m = + { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx } + + (** A variant of [(>>=)] when the first argument returns [unit]. *) + let (<*>) (type a) (m:unit m) (y:a m) : a m = + { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } + + (** Failure of the pattern-matching monad: no success. *) + let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } + + let run (m : 'a m) = + let ctx = { + subst = empty_subst ; + context = empty_context_subst ; + terms = empty_term_subst ; + lhs = (); + } in + let eval lhs ctx = Proofview.tclUNIT { ctx with lhs } in + m.stream eval ctx + + (** Chooses in a list, in the same order as the list *) + let rec pick (l:'a list) (e, info) : 'a m = match l with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | x :: l -> + { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) } + + let pick l = pick l imatching_error + + (** Declares a subsitution, a context substitution and a term substitution. *) + let put subst context terms : unit m = + let s = { subst ; context ; terms ; lhs = () } in + { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } + + (** Declares a substitution. *) + let put_subst subst : unit m = put subst empty_context_subst empty_term_subst + + (** Declares a term substitution. *) + let put_terms terms : unit m = put empty_subst empty_context_subst terms + + + + (** {6 Pattern-matching} *) + + + (** [wildcard_match_term lhs] matches a term against a wildcard + pattern ([_ => lhs]). It has a single success with an empty + substitution. *) + let wildcard_match_term = return + + (** [pattern_match_term refresh pat term lhs] returns the possible + matchings of [term] with the pattern [pat => lhs]. If refresh is + true, refreshes the universes of [term]. *) + let pattern_match_term refresh pat term lhs = +(* let term = if refresh then Termops.refresh_universes_strict term else term in *) + match pat with + | Term p -> + begin + try + put_subst (Constr_matching.extended_matches E.env E.sigma p term) <*> + return lhs + with Constr_matching.PatternMatchingFailure -> fail + end + | Subterm (with_app_context,id_ctxt,p) -> + + let rec map s (e, info) = + { stream = fun k ctx -> match IStream.peek s with + | IStream.Nil -> Proofview.tclZERO ~info e + | IStream.Cons ({ Constr_matching.m_sub ; m_ctx }, s) -> + let subst = adjust m_sub in + let context = id_map_try_add id_ctxt m_ctx Id.Map.empty in + let terms = empty_term_subst in + let nctx = { subst ; context ; terms ; lhs = () } in + match merge ctx nctx with + | None -> (map s (e, info)).stream k ctx + | Some nctx -> Proofview.tclOR (k lhs nctx) (fun e -> (map s e).stream k ctx) + } + in + map (Constr_matching.match_subterm_gen E.env E.sigma with_app_context p term) imatching_error + + + (** [rule_match_term term rule] matches the term [term] with the + matching rule [rule]. *) + let rule_match_term term = function + | All lhs -> wildcard_match_term lhs + | Pat ([],pat,lhs) -> pattern_match_term false pat term lhs + | Pat _ -> + (** Rules with hypotheses, only work in match goal. *) + fail + + (** [match_term term rules] matches the term [term] with the set of + matching rules [rules].*) + let rec match_term (e, info) term rules = match rules with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | r :: rules -> + { stream = fun k ctx -> + let head = rule_match_term term r in + let tail e = match_term e term rules in + Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx) + } + + + (** [hyp_match_type hypname pat hyps] matches a single + hypothesis pattern [hypname:pat] against the hypotheses in + [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 decl -> + let id = NamedDecl.get_id decl in + let refresh = is_local_def decl in + pattern_match_term refresh pat (NamedDecl.get_type decl) () <*> + put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> + return id + + (** [hyp_match_type hypname bodypat typepat hyps] matches a single + hypothesis pattern [hypname := bodypat : typepat] against the + hypotheses in [hyps].Tries the hypotheses in order. For each + success returns the name of the matched hypothesis. *) + let hyp_match_body_and_type hypname bodypat typepat hyps = + pick hyps >>= function + | 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 + | LocalAssum (id,hyp) -> fail + + (** [hyp_match pat hyps] dispatches to + {!hyp_match_type} or {!hyp_match_body_and_type} depending on whether + [pat] is [Hyp _] or [Def _]. *) + let hyp_match pat hyps = + match pat with + | Hyp ((_,hypname),typepat) -> + hyp_match_type hypname typepat hyps + | Def ((_,hypname),bodypat,typepat) -> + hyp_match_body_and_type hypname bodypat typepat hyps + + (** [hyp_pattern_list_match pats hyps lhs], matches the list of + patterns [pats] against the hypotheses in [hyps], and eventually + returns [lhs]. *) + let rec hyp_pattern_list_match pats hyps lhs = + match pats with + | pat::pats -> + hyp_match pat hyps >>= fun matched_hyp -> + (* spiwack: alternatively it is possible to return the list + with the matched hypothesis removed directly in + [hyp_match]. *) + let select_matched_hyp decl = Id.equal (NamedDecl.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 + + (** [rule_match_goal hyps concl rule] matches the rule [rule] + against the goal [hyps|-concl]. *) + let rule_match_goal hyps concl = function + | All lhs -> wildcard_match_term lhs + | Pat (hyppats,conclpat,lhs) -> + (* the rules are applied from the topmost one (in the concrete + syntax) to the bottommost. *) + let hyppats = List.rev hyppats in + pattern_match_term false conclpat concl () <*> + hyp_pattern_list_match hyppats hyps lhs + + (** [match_goal hyps concl rules] matches the goal [hyps|-concl] + with the set of matching rules [rules]. *) + let rec match_goal (e, info) hyps concl rules = match rules with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | r :: rules -> + { stream = fun k ctx -> + let head = rule_match_goal hyps concl r in + let tail e = match_goal e hyps concl rules in + Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx) + } + +end + +(** [match_term env sigma term rules] matches the term [term] with the + set of matching rules [rules]. The environment [env] and the + evar_map [sigma] are not currently used, but avoid code + duplication. *) +let match_term env sigma term rules = + let module E = struct + let env = env + let sigma = sigma + end in + let module M = PatternMatching(E) in + M.run (M.match_term imatching_error term rules) + + +(** [match_goal env sigma hyps concl rules] matches the goal + [hyps|-concl] with the set of matching rules [rules]. The + environment [env] and the evar_map [sigma] are used to check + convertibility for pattern variables shared between hypothesis + patterns or the conclusion pattern. *) +let match_goal env sigma hyps concl rules = + let module E = struct + let env = env + let sigma = sigma + end in + let module M = PatternMatching(E) in + M.run (M.match_goal imatching_error hyps concl rules) diff --git a/plugins/ltac/tactic_matching.mli b/plugins/ltac/tactic_matching.mli new file mode 100644 index 0000000000..090207bcc3 --- /dev/null +++ b/plugins/ltac/tactic_matching.mli @@ -0,0 +1,49 @@ + (************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + Evd.evar_map -> + Term.constr -> + (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 + [hyps|-concl] with the set of matching rules [rules]. The + environment [env] and the evar_map [sigma] are used to check + convertibility for pattern variables shared between hypothesis + patterns or the conclusion pattern. *) +val match_goal: + Environ.env -> + Evd.evar_map -> + 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/plugins/ltac/tactic_option.ml b/plugins/ltac/tactic_option.ml new file mode 100644 index 0000000000..a5ba3b8371 --- /dev/null +++ b/plugins/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/plugins/ltac/tactic_option.mli b/plugins/ltac/tactic_option.mli new file mode 100644 index 0000000000..ed759a76db --- /dev/null +++ b/plugins/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/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml new file mode 100644 index 0000000000..756958c2f0 --- /dev/null +++ b/plugins/ltac/tauto.ml @@ -0,0 +1,279 @@ +(************************************************************************) +(* 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 tag_tauto_flags : tauto_flags Val.typ = Val.create "tauto_flags" + +let assoc_flags ist : tauto_flags = + let Val.Dyn (tag, v) = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in + match Val.eq tag tag_tauto_flags with + | None -> assert false + | Some Refl -> v + +(* 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 (Some tac) + in + Proofview.tclINDEPENDENT (Tactics.forward true tac None c) + +let apply c = Tactics.apply c + +let clear id = Tactics.clear [id] + +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 (tag_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/plugins/ltac/tauto.mli b/plugins/ltac/tauto.mli new file mode 100644 index 0000000000..e69de29bb2 diff --git a/plugins/ltac/vo.itarget b/plugins/ltac/vo.itarget new file mode 100644 index 0000000000..a28fb770be --- /dev/null +++ b/plugins/ltac/vo.itarget @@ -0,0 +1 @@ +Ltac.vo diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index 48fbe0793c..edcd53005e 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -88,9 +88,12 @@ Open Scope type_scope. (** ML Tactic Notations *) +Declare ML Module "ltac_plugin". Declare ML Module "coretactics". Declare ML Module "extratactics". Declare ML Module "g_auto". Declare ML Module "g_class". Declare ML Module "g_eqdecide". Declare ML Module "g_rewrite". + +Global Set Default Proof Mode "Classic". diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index d9f8ed8815..cc1c44fe31 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -603,8 +603,6 @@ let init_toplevel arglist = init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) Lib.init(); - (* Default Proofb Mode starts with an alternative default. *) - Goptions.set_string_option_value ["Default";"Proof";"Mode"] "Classic"; begin try let extras = parse_args arglist in -- cgit v1.2.3 From ebc0870ca932acf0ceea5fe513e2ca40e74c2a02 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 6 Oct 2016 17:34:12 +0200 Subject: Moving the Ltac plugin to a pack-based one. This is cumbersome, because now code may fail at link time if it's not referring to the correct module name. Therefore, one has to add corresponding open statements a the top of every file depending on a Ltac module. This includes seemingly unrelated files that use EXTEND statements. --- plugins/btauto/g_btauto.ml4 | 2 ++ plugins/cc/g_congruence.ml4 | 1 + plugins/decl_mode/decl_interp.ml | 1 + plugins/decl_mode/decl_proof_instr.ml | 1 + plugins/decl_mode/g_decl_mode.ml4 | 1 + plugins/decl_mode/ppdecl_proof.ml | 1 + plugins/extraction/g_extraction.ml4 | 1 + plugins/firstorder/g_ground.ml4 | 1 + plugins/firstorder/ground.ml | 1 + plugins/fourier/g_fourier.ml4 | 1 + plugins/funind/g_indfun.ml4 | 1 + plugins/funind/invfun.ml | 1 + plugins/ltac/ltac_plugin.mllib | 27 --------------------------- plugins/ltac/ltac_plugin.mlpack | 27 +++++++++++++++++++++++++++ plugins/micromega/g_micromega.ml4 | 1 + plugins/nsatz/g_nsatz.ml4 | 4 ++-- plugins/omega/g_omega.ml4 | 1 + plugins/quote/g_quote.ml4 | 1 + plugins/romega/g_romega.ml4 | 1 + plugins/rtauto/g_rtauto.ml4 | 2 ++ plugins/rtauto/refl_tauto.ml | 1 + plugins/setoid_ring/g_newring.ml4 | 1 + plugins/setoid_ring/newring.ml | 1 + plugins/ssrmatching/ssrmatching.ml4 | 1 + test-suite/bugs/closed/3612.v | 3 +++ test-suite/bugs/closed/3649.v | 2 ++ test-suite/bugs/closed/4121.v | 4 +++- test-suite/bugs/closed/4527.v | 1 + test-suite/bugs/closed/4533.v | 3 ++- test-suite/bugs/closed/4544.v | 3 ++- 30 files changed, 65 insertions(+), 32 deletions(-) delete mode 100644 plugins/ltac/ltac_plugin.mllib create mode 100644 plugins/ltac/ltac_plugin.mlpack diff --git a/plugins/btauto/g_btauto.ml4 b/plugins/btauto/g_btauto.ml4 index f3e2c99f4c..2980274487 100644 --- a/plugins/btauto/g_btauto.ml4 +++ b/plugins/btauto/g_btauto.ml4 @@ -8,6 +8,8 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin + DECLARE PLUGIN "btauto_plugin" TACTIC EXTEND btauto diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index 6f6811334d..7e76854b16 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Cctac open Stdarg diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index f68c01b18b..2b63ed6d6e 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open CErrors open Util open Names diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index e19dc86c45..deb2ede1d5 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open CErrors open Util open Pp diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 18a35c6cfb..a71d20f0dc 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -10,6 +10,7 @@ DECLARE PLUGIN "decl_mode_plugin" +open Ltac_plugin open Compat open Pp open Decl_expr diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml index 59a0bb5a2d..f5de638ed2 100644 --- a/plugins/decl_mode/ppdecl_proof.ml +++ b/plugins/decl_mode/ppdecl_proof.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open CErrors open Pp open Decl_expr diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index e1d6bb4a84..3ed959cf2c 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -12,6 +12,7 @@ DECLARE PLUGIN "extraction_plugin" (* ML names *) +open Ltac_plugin open Genarg open Stdarg open Pcoq.Prim diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 260e86ad67..e28d6aa626 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Formula open Sequent open Ground diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 628af4e719..d6cd7e2a08 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open Formula open Sequent open Rules diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4 index 7c665ae7b5..1960fa8355 100644 --- a/plugins/fourier/g_fourier.ml4 +++ b/plugins/fourier/g_fourier.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open FourierR DECLARE PLUGIN "fourier_plugin" diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 6603a95a84..368b23be30 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Compat open Util open Term diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index c8b4e48337..70333b063d 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open Tacexpr open Declarations open CErrors diff --git a/plugins/ltac/ltac_plugin.mllib b/plugins/ltac/ltac_plugin.mllib deleted file mode 100644 index af1c7149da..0000000000 --- a/plugins/ltac/ltac_plugin.mllib +++ /dev/null @@ -1,27 +0,0 @@ -Tacarg -Pptactic -Pltac -Taccoerce -Tacsubst -Tacenv -Tactic_debug -Tacintern -Tacentries -Profile_ltac -Tactic_matching -Tacinterp -Evar_tactics -Tactic_option -Extraargs -G_obligations -Coretactics -Extratactics -Profile_ltac_tactics -G_auto -G_class -Rewrite -G_rewrite -Tauto -G_eqdecide -G_tactic -G_ltac diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack new file mode 100644 index 0000000000..af1c7149da --- /dev/null +++ b/plugins/ltac/ltac_plugin.mlpack @@ -0,0 +1,27 @@ +Tacarg +Pptactic +Pltac +Taccoerce +Tacsubst +Tacenv +Tactic_debug +Tacintern +Tacentries +Profile_ltac +Tactic_matching +Tacinterp +Evar_tactics +Tactic_option +Extraargs +G_obligations +Coretactics +Extratactics +Profile_ltac_tactics +G_auto +G_class +Rewrite +G_rewrite +Tauto +G_eqdecide +G_tactic +G_ltac diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 79020ed037..ccb6daa116 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -16,6 +16,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Stdarg open Tacarg diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4 index 5f906a8dad..195dec3627 100644 --- a/plugins/nsatz/g_nsatz.ml4 +++ b/plugins/nsatz/g_nsatz.ml4 @@ -1,5 +1,3 @@ -DECLARE PLUGIN "nsatz_plugin" - (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Type) (u v : sigT P) (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2), p = q. +Declare ML Module "ltac_plugin". Declare ML Module "coretactics". +Set Default Proof Mode "Classic". + 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/test-suite/bugs/closed/3649.v b/test-suite/bugs/closed/3649.v index fc4c171e2c..8687eaab00 100644 --- a/test-suite/bugs/closed/3649.v +++ b/test-suite/bugs/closed/3649.v @@ -2,7 +2,9 @@ (* File reduced by coq-bug-finder from original input, then from 9518 lines to 404 lines, then from 410 lines to 208 lines, then from 162 lines to 77 lines *) (* coqc version trunk (September 2014) compiled on Sep 18 2014 21:0:5 with OCaml 4.01.0 coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *) +Declare ML Module "ltac_plugin". Declare ML Module "coretactics". +Set Default Proof Mode "Classic". 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. diff --git a/test-suite/bugs/closed/4121.v b/test-suite/bugs/closed/4121.v index d34a2b8b1b..816bc845fd 100644 --- a/test-suite/bugs/closed/4121.v +++ b/test-suite/bugs/closed/4121.v @@ -4,6 +4,8 @@ Unset Strict Universe Declaration. (* coqc version 8.5beta1 (March 2015) compiled on Mar 11 2015 18:51:36 with OCaml 4.01.0 coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (8dbfee5c5f897af8186cb1bdfb04fd4f88eca677) *) +Declare ML Module "ltac_plugin". + Set Universe Polymorphism. Class Contr_internal (A : Type) := BuildContr { center : A }. Arguments center A {_}. @@ -13,4 +15,4 @@ Definition contr_paths_contr0 {A} `{Contr A} : Contr A := {| center := center A Instance contr_paths_contr1 {A} `{Contr A} : Contr A := {| center := center A |}. Check @contr_paths_contr0@{i}. Check @contr_paths_contr1@{i}. (* Error: Universe instance should have length 2 *) -(** It should have length 1, just like contr_paths_contr0 *) \ No newline at end of file +(** It should have length 1, just like contr_paths_contr0 *) diff --git a/test-suite/bugs/closed/4527.v b/test-suite/bugs/closed/4527.v index 08628377f0..c6fcc24b6b 100644 --- a/test-suite/bugs/closed/4527.v +++ b/test-suite/bugs/closed/4527.v @@ -5,6 +5,7 @@ then from 269 lines to 255 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) *) +Declare ML Module "ltac_plugin". Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. diff --git a/test-suite/bugs/closed/4533.v b/test-suite/bugs/closed/4533.v index ae17fb145d..64c7fd8eb1 100644 --- a/test-suite/bugs/closed/4533.v +++ b/test-suite/bugs/closed/4533.v @@ -5,6 +5,7 @@ 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) *) +Declare ML Module "ltac_plugin". Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. @@ -223,4 +224,4 @@ v = _) r, | [ |- p2 @ p0 @ p1 @ eissect (to O A) (g x) = r ] => idtac "good" | [ |- ?G ] => fail 1 "bad" G end. - Fail rewrite concat_p_pp. \ No newline at end of file + Fail rewrite concat_p_pp. diff --git a/test-suite/bugs/closed/4544.v b/test-suite/bugs/closed/4544.v index da140c9318..64dd8c304f 100644 --- a/test-suite/bugs/closed/4544.v +++ b/test-suite/bugs/closed/4544.v @@ -2,6 +2,7 @@ (* 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) *) +Declare ML Module "ltac_plugin". Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. @@ -1004,4 +1005,4 @@ Proof. 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 +Abort. -- cgit v1.2.3 From 96e55866d49691f539bd43a88a8dd6a4cc7ae727 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 6 Oct 2016 18:31:03 +0200 Subject: Fix .gitignore. --- .gitignore | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.gitignore b/.gitignore index 7434f62127..35cdf9b4e8 100644 --- a/.gitignore +++ b/.gitignore @@ -122,10 +122,10 @@ g_*.ml ide/project_file.ml parsing/compat.ml parsing/cLexer.ml -ltac/coretactics.ml -ltac/extratactics.ml -ltac/extraargs.ml -ltac/profile_ltac_tactics.ml +plugins/ltac/coretactics.ml +plugins/ltac/extratactics.ml +plugins/ltac/extraargs.ml +plugins/ltac/profile_ltac_tactics.ml ide/coqide_main.ml plugins/ssrmatching/ssrmatching.ml -- cgit v1.2.3 From 6d49de4f2d1ed25b9a745378531a3b55bb0d8197 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 6 Oct 2016 18:39:28 +0200 Subject: Documenting the pluginification of Ltac. --- dev/doc/changes.txt | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index f54f3fcc8e..8d2d055908 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -40,6 +40,24 @@ important things: - Some printing functions were moved from Pptactic to Pputils - A part of Tacexpr has been moved to Tactypes +The folder itself has been turned into a plugin. This does not change much, +but because it is a packed plugin, it may wreak havoc for third-party plugins +depending on any module defined in the ltac/ directory. Namely, even if +everything looks OK at compile time, a plugin can fail to load at link time +because it mistakenly looks for a module Foo instead of Ltac_plugin.Foo, with +an error of the form: + +Error: while loading myplugin.cmxs, no implementation available for Foo. + +In particular, most EXTEND macros will trigger this problem even if they +seemingly do not use any Ltac module, as their expansion do. + +The solution is simple, and consists in adding a statement "open Ltac_plugin" +in each file using a Ltac module, before such a module is actually called. An +alternative solution would be to fully qualify Ltac modules, e.g. turning any +call to Tacinterp into Ltac_plugin.Tacinterp. Note that this solution does not +work for EXTEND macros though. + ** Error handling ** - All error functions now take an optional parameter `?loc:Loc.t`. For -- cgit v1.2.3 From b09751b9a1b48541acc9a2daaff9ebc453fc3bf7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 16 Feb 2017 19:05:45 +0100 Subject: Removing spurious folder includes in coq_makefile. --- tools/coq_makefile.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 624b9ced7d..4842a89151 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -50,9 +50,9 @@ let section s = let lib_dirs = ["kernel"; "lib"; "library"; "parsing"; "pretyping"; "interp"; "printing"; "intf"; - "proofs"; "tactics"; "tools"; "ltacprof"; + "proofs"; "tactics"; "tools"; "vernac"; "stm"; "toplevel"; "grammar"; "config"; - "ltac"; "engine"] + "engine"] let usage () = -- cgit v1.2.3 From 5efa4a5de54b681981c361fc679343790597a5d5 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Fri, 17 Feb 2017 14:25:03 +0100 Subject: remove obsolete file dev/Makefile.oug --- dev/Makefile.oug | 74 -------------------------------------------------------- 1 file changed, 74 deletions(-) delete mode 100644 dev/Makefile.oug diff --git a/dev/Makefile.oug b/dev/Makefile.oug deleted file mode 100644 index ee69ea80df..0000000000 --- a/dev/Makefile.oug +++ /dev/null @@ -1,74 +0,0 @@ -####################################################################### -# v # The Coq Proof Assistant / The Coq Development Team # -# " --useless-elements $@ - -core_intf.oug: - $(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(COREML) $(COREMLI) - -core_intf.useless: core_intf.oug - $(OUG) --load-data $< --no-reduce --print-loc --roots "" --useless-elements $@ - -# Analysis of coqchk, considering only files in the checker/ subdir - -CHECKERML:=$(call local_ml_of_cma,checker/check.cma) -CHECKERMLI:=$(call mli_of_ml,$(CHECKERML)) - -## BUG: in oug, include dirs have reversed priority compared with ocaml, cannot use CHKLIBS -MYCHKINCL:=$(MLINCLUDES) -I checker - -checker.oug: - $(OUG) --dump-data $@ -rectypes $(MYCHKINCL) $(CHECKERML) #$(CHECKERMLI) - -checker.useless: checker.oug - $(OUG) --load-data $< --no-reduce --print-loc --roots "" --useless-elements $@ - -# Analysis of extraction - -EXTRACTIONML:=$(call local_ml_of_cma,$(EXTRACTIONCMA)) -EXTRACTIONMLI:=$(call mli_of_ml,$(EXTRACTIONMLI)) - -extraction.oug: - $(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(EXTRACTIONML) #$(EXTRACTIONMLI) - -extraction.useless: extraction.oug - $(OUG) --load-data $< --no-reduce --print-loc --useless-elements $@ - -# More to come ... \ No newline at end of file -- cgit v1.2.3 From 278cebe6835512a5646eafcb13e1f020c0dc5d91 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 19 Feb 2017 20:28:16 +0100 Subject: Fixing debugger after the split of toplevel into vernac. --- dev/core.dbg | 1 + dev/ocamldebug-coq.run | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/dev/core.dbg b/dev/core.dbg index 38b9b29463..698db63d23 100644 --- a/dev/core.dbg +++ b/dev/core.dbg @@ -12,6 +12,7 @@ load_printer proofs.cma load_printer parsing.cma load_printer printing.cma load_printer tactics.cma +load_printer vernac.cma load_printer stm.cma load_printer toplevel.cma load_printer highparsing.cma diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index 46caca8d6f..26cfcc8ae4 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -20,7 +20,7 @@ exec $OCAMLDEBUG \ -I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar \ -I $COQTOP/lib -I $COQTOP/intf -I $COQTOP/kernel -I $COQTOP/kernel/byterun \ -I $COQTOP/library -I $COQTOP/engine \ - -I $COQTOP/pretyping -I $COQTOP/parsing \ + -I $COQTOP/pretyping -I $COQTOP/parsing -I $COQTOP/vernac \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \ -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config -I $COQTOP/ltac \ -I $COQTOP/plugins/cc -I $COQTOP/plugins/dp \ -- cgit v1.2.3 From 1fbc3afc7acd9629453af6276479c81e79f19d39 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 20 Feb 2017 00:15:19 +0100 Subject: [ocamlbuild] Update meta for the vernac split. --- META.coq | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/META.coq b/META.coq index 5be69d5fdc..a71af2f103 100644 --- a/META.coq +++ b/META.coq @@ -172,7 +172,7 @@ package "parsing" ( package "printing" ( - description = "Coq Printing Libraries" + description = "Coq Printing Engine" version = "8.6" requires = "coq.parsing" @@ -185,7 +185,7 @@ package "printing" ( package "tactics" ( - description = "Coq Tactics" + description = "Coq Basic Tactics" version = "8.6" requires = "coq.printing" @@ -196,12 +196,25 @@ package "tactics" ( ) +package "vernac" ( + + description = "Coq Vernacular Interpreter" + version = "8.6" + + requires = "coq.tactics" + directory = "vernac" + + archive(byte) = "vernac.cma" + archive(native) = "vernac.cmxa" + +) + package "stm" ( description = "Coq State Transactional Machine" version = "8.6" - requires = "coq.tactics" + requires = "coq.vernac" directory = "stm" archive(byte) = "stm.cma" -- cgit v1.2.3 From 11892a347930a15bc23c34f0743bb3180e3f12c7 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Mon, 20 Feb 2017 11:23:25 +0100 Subject: [ocamlbuild] fix small mistakes in descriptions --- META.coq | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/META.coq b/META.coq index a71af2f103..d83dab23d1 100644 --- a/META.coq +++ b/META.coq @@ -56,7 +56,7 @@ package "vm" ( package "kernel" ( - description = "The Coq's Kernel" + description = "Coq's Kernel" version = "8.6" directory = "kernel" @@ -95,7 +95,7 @@ package "intf" ( package "engine" ( - description = "Coq Libraries (vo) support" + description = "Coq Tactic Engine" version = "8.6" requires = "coq.library" -- cgit v1.2.3 From 858a559331b70e23a3a011e30e5a80a7d4bd7135 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 20 Feb 2017 16:50:42 +0100 Subject: Deprecate -debug flag. --- configure.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ml b/configure.ml index 9c22c52375..6d96e614db 100644 --- a/configure.ml +++ b/configure.ml @@ -336,7 +336,7 @@ let args_options = Arg.align [ "-byteonly", Arg.Set Prefs.byteonly, " Compiles only bytecode version of Coq"; "-debug", Arg.Set Prefs.debug, - " Add debugging information in the Coq executables"; + " Deprecated"; "-nodebug", Arg.Clear Prefs.debug, " Do not add debugging information in the Coq executables"; "-profile", Arg.Set Prefs.profile, -- cgit v1.2.3 From 15e2280fe975fa5a4376ee45557d3e532e208496 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Mon, 20 Feb 2017 22:22:48 +0100 Subject: Fix V7 syntax in refman. --- doc/refman/RefMan-pro.tex | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index c37367de5b..16c822b6a5 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -477,15 +477,15 @@ names. \item{\tt Show Intro.}\comindex{Show Intro}\\ If the current goal begins by at least one product, this command prints the name of the first product, as it would be generated by -an anonymous {\tt Intro}. The aim of this command is to ease the +an anonymous {\tt intro}. The aim of this command is to ease the writing of more robust scripts. For example, with an appropriate {\ProofGeneral} macro, it is possible to transform any anonymous {\tt - Intro} into a qualified one such as {\tt Intro y13}. + intro} into a qualified one such as {\tt intro y13}. In the case of a non-product goal, it prints nothing. \item{\tt Show Intros.}\comindex{Show Intros}\\ This command is similar to the previous one, it simulates the naming -process of an {\tt Intros}. +process of an {\tt intros}. \item{\tt Show Existentials.\label{ShowExistentials}}\comindex{Show Existentials} \\ It displays -- cgit v1.2.3 From e8137ae63b3b19436755f372b595e7343e942894 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 21 Feb 2017 08:09:56 +0100 Subject: Add empty ltac_plugin file for forward compatibility. This is in preparation for landing of PR#309: Ltac as a plugin --- ltac/ltac.mllib | 1 + ltac/ltac_plugin.ml | 0 ltac/ltac_plugin.mli | 0 3 files changed, 1 insertion(+) create mode 100644 ltac/ltac_plugin.ml create mode 100644 ltac/ltac_plugin.mli diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib index fc51e48ae4..974943ddd6 100644 --- a/ltac/ltac.mllib +++ b/ltac/ltac.mllib @@ -20,3 +20,4 @@ G_rewrite Tauto G_eqdecide G_ltac +Ltac_plugin diff --git a/ltac/ltac_plugin.ml b/ltac/ltac_plugin.ml new file mode 100644 index 0000000000..e69de29bb2 diff --git a/ltac/ltac_plugin.mli b/ltac/ltac_plugin.mli new file mode 100644 index 0000000000..e69de29bb2 -- cgit v1.2.3 From d9d8977cf213f0d4b2e8d324c759c23df58ba457 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 21 Feb 2017 09:46:34 +0100 Subject: [travis] track an 8.7 specific branch of HoTT. This is required since we merged PR#309: Ltac as a plugin. --- dev/ci/ci-hott.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index aaffc9d484..0c07564c02 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git_checkout mz-8.6 https://github.com/ejgallego/HoTT.git HoTT +git_checkout mz-8.7 https://github.com/ejgallego/HoTT.git HoTT ( cd HoTT && ./autogen.sh && ./configure && make -j ${NJOBS} ) -- cgit v1.2.3 From 4fca4ed3b27a51e01370e500cdce756113556ed2 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Sun, 4 Dec 2016 13:51:15 -0500 Subject: Allow interactive editing of Coq.Init.Logic Without this change, coqtop complains that I need to require Coq.Init.Logic to use [replace ... with ... by ...]. --- theories/Init/Logic.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 85123cc444..504ef95d98 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -553,7 +553,8 @@ Proof. intros A P (x & Hp & Huniq); split. - intro; exists x; auto. - intros (x0 & HPx0 & HQx0) x1 HPx1. - replace x1 with x0 by (transitivity x; [symmetry|]; auto). + assert (H : x0 = x1) by (transitivity x; [symmetry|]; auto). + destruct H. assumption. Qed. -- cgit v1.2.3 From 1682d4ed9df64937dfaa162e58233020036ff7b3 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 23 Feb 2017 13:23:15 +0100 Subject: Fixing #use"include" after vernac is added and ltac is moved to a plugin. --- dev/base_include | 4 ++-- dev/top_printers.ml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/dev/base_include b/dev/base_include index 0abcefc38e..242405ae29 100644 --- a/dev/base_include +++ b/dev/base_include @@ -17,7 +17,7 @@ #directory "grammar";; #directory "intf";; #directory "stm";; -#directory "ltac";; +#directory "vernac";; #directory "+camlp4";; (* lazy solution: add both of camlp4/5 so that *) #directory "+camlp5";; (* Gramext is found in top_printers.ml *) @@ -195,7 +195,7 @@ let qid = Libnames.qualid_of_string;; (* parsing of terms *) let parse_constr = Pcoq.parse_string Pcoq.Constr.constr;; -let parse_tac = Pcoq.parse_string Pltac.tactic;; +let parse_tac = Pcoq.parse_string Ltac_plugin.Pltac.tactic;; let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac;; (* build a term of type glob_constr without type-checking or resolution of diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 4fcad88202..dc354b130b 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -234,7 +234,7 @@ let ppenvwithcst e = pp str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]" ++ spc() ++ str "{" ++ Cmap_env.fold (fun a _ s -> pr_con a ++ spc () ++ s) (Obj.magic e).Pre_env.env_globals.Pre_env.env_constants (mt ()) ++ str "}") -let pptac = (fun x -> pp(Pptactic.pr_glob_tactic (Global.env()) x)) +let pptac = (fun x -> pp(Ltac_plugin.Pptactic.pr_glob_tactic (Global.env()) x)) let ppobj obj = Format.print_string (Libobject.object_tag obj) -- cgit v1.2.3 From 4ccd6436a014d5d1b27d42e9bda40fb381d1bfce Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 3 May 2016 22:25:28 +0200 Subject: Simplifying the proof of NoRetractToModalProposition.paradox in Hurkens.v by dropping the artificial need for monad laws. Tactic eauto decided to be dependent on the laws but there is a shorter proof without them. [Interestingly, eauto is not able to find the short proof. This is a situation of the form subgoal 1: H : ?A |- P x subgoal 2: H : M ?A |- M (forall x, P x) where addressing the second subgoal would find the right instance of ?A, but this instance is too hard to find by addressing first the first subgoal.] --- theories/Logic/Hurkens.v | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index 56e03e965c..a10c180ccf 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -360,13 +360,12 @@ Module NoRetractToModalProposition. Section Paradox. Variable M : Prop -> Prop. -Hypothesis unit : forall A:Prop, A -> M A. -Hypothesis join : forall A:Prop, M (M A) -> M A. Hypothesis incr : forall A B:Prop, (A->B) -> M A -> M B. Lemma strength: forall A (P:A->Prop), M(forall x:A,P x) -> forall x:A,M(P x). Proof. - eauto. + intros A P h x. + eapply incr in h; eauto. Qed. (** ** The universe of modal propositions *) @@ -470,7 +469,7 @@ Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). Theorem paradox : forall B:NProp, El B. Proof. intros B. - unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))). + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))). + exact (fun P => ~~P). + exact bool. + exact p2b. @@ -480,8 +479,6 @@ Proof. + cbn. auto. + cbn. auto. + cbn. auto. - + auto. - + auto. Qed. End Paradox. @@ -516,7 +513,7 @@ Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). Theorem mparadox : forall B:NProp, El B. Proof. intros B. - unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))). + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))). + exact (fun P => P). + exact bool. + exact p2b. @@ -526,8 +523,6 @@ Proof. + cbn. auto. + cbn. auto. + cbn. auto. - + auto. - + auto. Qed. End MParadox. -- cgit v1.2.3 From 04d086e21cdf28c4029133a0f8fd1720d13544e8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 24 Feb 2017 12:27:47 +0100 Subject: Revert "Add empty ltac_plugin file for forward compatibility." This reverts commit e8137ae63b3b19436755f372b595e7343e942894, was meant for 8.6 branch only. --- ltac/ltac_plugin.ml | 0 ltac/ltac_plugin.mli | 0 plugins/ltac/ltac_plugin.mlpack | 1 - 3 files changed, 1 deletion(-) delete mode 100644 ltac/ltac_plugin.ml delete mode 100644 ltac/ltac_plugin.mli diff --git a/ltac/ltac_plugin.ml b/ltac/ltac_plugin.ml deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/ltac/ltac_plugin.mli b/ltac/ltac_plugin.mli deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index b6e2cecd1c..af1c7149da 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -25,4 +25,3 @@ Tauto G_eqdecide G_tactic G_ltac -Ltac_plugin -- cgit v1.2.3 From a84797db94e9d242ebdf9f6feb08a63d42a14bae Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 24 Feb 2017 00:27:50 +0100 Subject: TACTIC EXTEND now takes an optional level as argument. The syntax is: TACTIC EXTEND foo AT LEVEL i This commit makes it possible to define tacticals like the ssreflect arrow without having to resort to GEXTEND statements and intepretation hacks. Note that it simply makes accessible through the ML interface what Tactic Notation already supports: Tactic Notation (at level 1) tactic1(t) "=>" ipats(l) := ... --- grammar/tacextend.mlp | 24 +++++++++++------------- plugins/ltac/tacentries.ml | 12 +++++++----- plugins/ltac/tacentries.mli | 2 +- 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index fe864ed405..6c1757dd2c 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -82,14 +82,14 @@ let make_var = function | ExtNonTerminal (_, p) -> Some p | _ -> assert false -let declare_tactic loc s c cl = match cl with +let declare_tactic loc tacname ~level classification clause = match clause with | [(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 let vars = List.map make_var rem in let vars = mlexpr_of_list (mlexpr_of_option mlexpr_of_ident) vars in - let entry = mlexpr_of_string s in + let entry = mlexpr_of_string tacname in 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 @@ -117,13 +117,14 @@ let declare_tactic loc s c cl = match cl with | _ -> (** Otherwise we add parsing and printing rules to generate a call to a TacML tactic. *) - let entry = mlexpr_of_string s in + let entry = mlexpr_of_string tacname in let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in - let gl = mlexpr_of_clause cl in - let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ $gl$ >> in + let gl = mlexpr_of_clause clause in + let level = mlexpr_of_int level in + let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ $level$ $gl$ >> in declare_str_items loc [ <:str_item< do { - Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc s cl$); + Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc tacname clause$); Mltop.declare_cache_obj $obj$ $plugin_name$; } >> ] @@ -134,20 +135,17 @@ EXTEND GLOBAL: str_item; str_item: [ [ "TACTIC"; "EXTEND"; s = tac_name; + level = OPT [ "AT"; "LEVEL"; level = INT -> level ]; c = OPT [ "CLASSIFIED"; "BY"; c = LIDENT -> <:expr< $lid:c$ >> ]; OPT "|"; l = LIST1 tacrule SEP "|"; "END" -> - declare_tactic loc s c l ] ] + let level = match level with Some i -> int_of_string i | None -> 0 in + declare_tactic loc s ~level c l ] ] ; tacrule: [ [ "["; l = LIST1 tacargs; "]"; c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> c ]; - "->"; "["; e = Pcaml.expr; "]" -> - (match l with - | ExtNonTerminal _ :: _ -> - (* En attendant la syntaxe de tacticielles *) - failwith "Tactic syntax must start with an identifier" - | _ -> (l,c,e)) + "->"; "["; e = Pcaml.expr; "]" -> (l,c,e) ] ] ; tacargs: diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 2e2b55be74..8570b5a447 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -302,9 +302,9 @@ let cons_production_parameter = function | TacTerm _ -> None | TacNonTerm (_, _, id) -> Some id -let add_glob_tactic_notation local n prods forml ids tac = +let add_glob_tactic_notation local ~level prods forml ids tac = let parule = { - tacgram_level = n; + tacgram_level = level; tacgram_prods = prods; } in let tacobj = { @@ -360,7 +360,7 @@ let extend_atomic_tactic name entries = in List.iteri add_atomic entries -let add_ml_tactic_notation name prods = +let add_ml_tactic_notation name ~level prods = let len = List.length prods in let iter i prods = let open Tacexpr in @@ -372,10 +372,12 @@ let add_ml_tactic_notation name prods = let entry = { mltac_name = name; mltac_index = len - i - 1 } in let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in let tac = TacML (Loc.ghost, entry, List.map map ids) in - add_glob_tactic_notation false 0 prods true ids tac + add_glob_tactic_notation false ~level prods true ids tac in List.iteri iter (List.rev prods); - extend_atomic_tactic name prods + (** We call [extend_atomic_tactic] only for "basic tactics" (the ones at + tactic_expr level 0) *) + if Int.equal level 0 then extend_atomic_tactic name prods (**********************************************************************) (** Ltac quotations *) diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 969c118fb5..0695044736 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -45,7 +45,7 @@ val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type - to finding an argument by name (as in {!Genarg}) if there is none matching. *) -val add_ml_tactic_notation : ml_tactic_name -> +val add_ml_tactic_notation : ml_tactic_name -> level:int -> argument grammar_tactic_prod_item_expr list list -> unit (** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND ML-side macro. *) -- cgit v1.2.3 From 4567e3a0a44a6c398375effa7d9a49342172512a Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 24 Feb 2017 02:28:27 +0100 Subject: [travis] [External CI] fiat-parsers --- .travis.yml | 1 + Makefile.ci | 2 +- dev/ci/ci-fiat-parsers.sh | 12 ++++++++++++ 3 files changed, 14 insertions(+), 1 deletion(-) create mode 100755 dev/ci/ci-fiat-parsers.sh diff --git a/.travis.yml b/.travis.yml index de16f2d0b4..5ed0809a52 100644 --- a/.travis.yml +++ b/.travis.yml @@ -30,6 +30,7 @@ env: - TEST_TARGET="ci-cpdt" - TEST_TARGET="ci-geocoq" - TEST_TARGET="ci-fiat-crypto" + - TEST_TARGET="ci-fiat-parsers" - TEST_TARGET="ci-flocq" - TEST_TARGET="ci-hott" - TEST_TARGET="ci-iris-coq" diff --git a/Makefile.ci b/Makefile.ci index e4b5832f60..897318c4dd 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -1,5 +1,5 @@ CI_TARGETS=ci-all ci-hott ci-math-comp ci-compcert ci-sf ci-cpdt \ - ci-color ci-math-classes ci-tlc ci-fiat-crypto \ + ci-color ci-math-classes ci-tlc ci-fiat-crypto ci-fiat-parsers \ ci-coquelicot ci-flocq ci-iris-coq ci-metacoq ci-geocoq \ ci-unimath diff --git a/dev/ci/ci-fiat-parsers.sh b/dev/ci/ci-fiat-parsers.sh new file mode 100755 index 0000000000..15d73078fd --- /dev/null +++ b/dev/ci/ci-fiat-parsers.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +fiat_parsers_CI_BRANCH=master +fiat_parsers_CI_GITURL=https://github.com/mit-plv/fiat.git + +git_checkout ${fiat_parsers_CI_BRANCH} ${fiat_parsers_CI_GITURL} fiat + +( cd fiat && make -j ${NJOBS} parsers ) -- cgit v1.2.3 From 3bca0281034722fbbd3a45b16ae841ef54c317ca Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 1 Mar 2017 15:21:37 -0500 Subject: Remove some trailing whitespace in Init/Specif.v --- theories/Init/Specif.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 9fc00e80c1..e94b2e3468 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -103,7 +103,7 @@ Definition sig_of_sig2 (A : Type) (P Q : A -> Prop) (X : sig2 P Q) : sig P of an [a] of type [A], a of a proof [h] that [a] satisfies [P], and a proof [h'] that [a] satisfies [Q]. Then [(proj1_sig (sig_of_sig2 y))] is the witness [a], - [(proj2_sig (sig_of_sig2 y))] is the proof of [(P a)], and + [(proj2_sig (sig_of_sig2 y))] is the proof of [(P a)], and [(proj3_sig y)] is the proof of [(Q a)]. *) Section Subset_projections2. @@ -263,10 +263,10 @@ Section Dependent_choice_lemmas. (forall x:X, {y | R x y}) -> forall x0, {f : nat -> X | f O = x0 /\ forall n, R (f n) (f (S n))}. Proof. - intros H x0. + intros H x0. set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end). exists f. - split. reflexivity. + split. reflexivity. induction n; simpl; apply proj2_sig. Defined. -- cgit v1.2.3 From f47aced0c78747920afe3d32cbc0aeed1045d8ce Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 1 Mar 2017 15:27:48 -0500 Subject: Add η principles for sigma types --- theories/Init/Specif.v | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index e94b2e3468..2cc2ecbc20 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -190,6 +190,23 @@ Definition sig2_of_sigT2 (A : Type) (P Q : A -> Prop) (X : sigT2 P Q) : sig2 P Q Definition sigT2_of_sig2 (A : Type) (P Q : A -> Prop) (X : sig2 P Q) : sigT2 P Q := existT2 P Q (proj1_sig (sig_of_sig2 X)) (proj2_sig (sig_of_sig2 X)) (proj3_sig X). +(** η Principles *) +Definition sigT_eta {A P} (p : { a : A & P a }) + : p = existT _ (projT1 p) (projT2 p). +Proof. destruct p; reflexivity. Defined. + +Definition sig_eta {A P} (p : { a : A | P a }) + : p = exist _ (proj1_sig p) (proj2_sig p). +Proof. destruct p; reflexivity. Defined. + +Definition sigT2_eta {A P Q} (p : { a : A & P a & Q a }) + : p = existT2 _ _ (projT1 (sigT_of_sigT2 p)) (projT2 (sigT_of_sigT2 p)) (projT3 p). +Proof. destruct p; reflexivity. Defined. + +Definition sig2_eta {A P Q} (p : { a : A | P a & Q a }) + : p = exist2 _ _ (proj1_sig (sig_of_sig2 p)) (proj2_sig (sig_of_sig2 p)) (proj3_sig p). +Proof. destruct p; reflexivity. Defined. + (** [sumbool] is a boolean type equipped with the justification of their value *) -- cgit v1.2.3 From dda3c644e195de2f72a81a0e2fb17e5095ea80ce Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 2 Mar 2017 18:25:43 +0100 Subject: [travis] Backport trunk's travis support. --- .travis.yml | 119 ++++++++++++++++++++++++++++++++++++++++++++++ Makefile | 5 ++ Makefile.ci | 11 +++++ dev/ci/ci-color.sh | 8 ++++ dev/ci/ci-common.sh | 52 ++++++++++++++++++++ dev/ci/ci-compcert.sh | 13 +++++ dev/ci/ci-coquelicot.sh | 12 +++++ dev/ci/ci-cpdt.sh | 10 ++++ dev/ci/ci-fiat-crypto.sh | 9 ++++ dev/ci/ci-flocq.sh | 9 ++++ dev/ci/ci-geocoq.sh | 16 +++++++ dev/ci/ci-hott.sh | 8 ++++ dev/ci/ci-iris-coq.sh | 17 +++++++ dev/ci/ci-math-classes.sh | 12 +++++ dev/ci/ci-math-comp.sh | 13 +++++ dev/ci/ci-metacoq.sh | 16 +++++++ dev/ci/ci-sf.sh | 11 +++++ dev/ci/ci-tlc.sh | 8 ++++ dev/ci/ci-unimath.sh | 15 ++++++ 19 files changed, 364 insertions(+) create mode 100644 .travis.yml create mode 100644 Makefile.ci create mode 100755 dev/ci/ci-color.sh create mode 100644 dev/ci/ci-common.sh create mode 100755 dev/ci/ci-compcert.sh create mode 100755 dev/ci/ci-coquelicot.sh create mode 100755 dev/ci/ci-cpdt.sh create mode 100755 dev/ci/ci-fiat-crypto.sh create mode 100755 dev/ci/ci-flocq.sh create mode 100755 dev/ci/ci-geocoq.sh create mode 100755 dev/ci/ci-hott.sh create mode 100755 dev/ci/ci-iris-coq.sh create mode 100755 dev/ci/ci-math-classes.sh create mode 100755 dev/ci/ci-math-comp.sh create mode 100755 dev/ci/ci-metacoq.sh create mode 100755 dev/ci/ci-sf.sh create mode 100755 dev/ci/ci-tlc.sh create mode 100755 dev/ci/ci-unimath.sh diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000000..de16f2d0b4 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,119 @@ +dist: trusty +sudo: required +# Until Ocaml becomes a language, we set a known one. +language: c +cache: + apt: true + directories: + - $HOME/.opam +addons: + apt: + sources: + - avsm + packages: + - opam + - aspcud + - gcc-multilib +env: + global: + - NJOBS=2 + # system is == 4.02.3 + - COMPILER="system" + # Main test suites + matrix: + - TEST_TARGET="test-suite" COMPILER="4.02.3+32bit" + - TEST_TARGET="validate" TW="travis_wait" + - TEST_TARGET="validate" COMPILER="4.02.3+32bit" TW="travis_wait" + - TEST_TARGET="ci-color" + - TEST_TARGET="ci-compcert" + - TEST_TARGET="ci-coquelicot" + - TEST_TARGET="ci-cpdt" + - TEST_TARGET="ci-geocoq" + - TEST_TARGET="ci-fiat-crypto" + - TEST_TARGET="ci-flocq" + - TEST_TARGET="ci-hott" + - TEST_TARGET="ci-iris-coq" + - TEST_TARGET="ci-math-classes" + - TEST_TARGET="ci-math-comp" + - TEST_TARGET="ci-sf" + - TEST_TARGET="ci-unimath" + # Not ready yet for 8.7 + # - TEST_TARGET="ci-metacoq" + # - TEST_TARGET="ci-tlc" + +matrix: + + allow_failures: + - env: TEST_TARGET="ci-cpdt" + + # Full Coq test-suite with two compilers + # [TODO: use yaml refs and avoid duplication for packages list] + include: + - env: + - TEST_TARGET="test-suite" + - EXTRA_CONF="-coqide opt -with-doc yes" + - EXTRA_OPAM="lablgtk-extras hevea" + addons: + apt: + sources: + - avsm + packages: + - opam + - aspcud + - libgtk2.0-dev + - libgtksourceview2.0-dev + - texlive-latex-base + - texlive-latex-recommended + - texlive-latex-extra + - texlive-math-extra + - texlive-fonts-recommended + - texlive-fonts-extra + - latex-xcolor + - ghostscript + - transfig + - imagemagick + - env: + - TEST_TARGET="test-suite" + - COMPILER="4.04.0" + - EXTRA_CONF="-coqide opt -with-doc yes" + - EXTRA_OPAM="lablgtk-extras hevea" + addons: + apt: + sources: + - avsm + packages: + - opam + - aspcud + - libgtk2.0-dev + - libgtksourceview2.0-dev + - texlive-latex-base + - texlive-latex-recommended + - texlive-latex-extra + - texlive-math-extra + - texlive-fonts-recommended + - texlive-fonts-extra + - latex-xcolor + - ghostscript + - transfig + - imagemagick + +install: +- opam init -j ${NJOBS} --compiler=${COMPILER} -n -y +- eval $(opam config env) +- opam config var root +- opam install -j ${NJOBS} -y camlp5 ocamlfind ${EXTRA_OPAM} +- opam list + +script: + +- echo 'Configuring Coq...' && echo -en 'travis_fold:start:coq.config\\r' +- ./configure -local -usecamlp5 -native-compiler yes ${EXTRA_CONF} +- echo -en 'travis_fold:end:coq.config\\r' + +- echo 'Building Coq...' && echo -en 'travis_fold:start:coq.build\\r' +- make -j ${NJOBS} +- echo -en 'travis_fold:end:coq.build\\r' + +- echo 'Running tests...' && echo -en 'travis_fold:start:coq.test\\r' +- ${TW} make -j ${NJOBS} ${TEST_TARGET} +- echo -en 'travis_fold:end:coq.test\\r' diff --git a/Makefile b/Makefile index 1dd4efca2e..e84d5e3775 100644 --- a/Makefile +++ b/Makefile @@ -245,6 +245,11 @@ devdocclean: rm -f $(OCAMLDOCDIR)/ocamldoc.sty $(OCAMLDOCDIR)/coq.tex rm -f $(OCAMLDOCDIR)/html/*.html +########################################################################### +# Continuous Intregration Tests +########################################################################### +include Makefile.ci + ########################################################################### # Emacs tags ########################################################################### diff --git a/Makefile.ci b/Makefile.ci new file mode 100644 index 0000000000..e4b5832f60 --- /dev/null +++ b/Makefile.ci @@ -0,0 +1,11 @@ +CI_TARGETS=ci-all ci-hott ci-math-comp ci-compcert ci-sf ci-cpdt \ + ci-color ci-math-classes ci-tlc ci-fiat-crypto \ + ci-coquelicot ci-flocq ci-iris-coq ci-metacoq ci-geocoq \ + ci-unimath + +.PHONY: $(CI_TARGETS) + +# Generic rule, we use make to easy travis integraton with mixed rules +$(CI_TARGETS): ci-%: + ./dev/ci/ci-$*.sh + diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh new file mode 100755 index 0000000000..78ae7f02f9 --- /dev/null +++ b/dev/ci/ci-color.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +svn checkout https://scm.gforge.inria.fr/anonscm/svn/color/trunk/color color + +( cd color && make -j ${NJOBS} ) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh new file mode 100644 index 0000000000..412da626fd --- /dev/null +++ b/dev/ci/ci-common.sh @@ -0,0 +1,52 @@ +#!/bin/bash + +set -xe + +# Coq's tools need an ending slash :S, we should fix them. +export COQBIN=`pwd`/bin/ +export PATH=`pwd`/bin:$PATH + +ls `pwd`/bin + +# Maybe we should just use Ruby... +mathcomp_CI_BRANCH=master +mathcomp_CI_GITURL=https://github.com/math-comp/math-comp.git + +# git_checkout branch +git_checkout() +{ + local _BRANCH=${1} + local _URL=${2} + local _DEST=${3} + + echo "Checking out ${_DEST}" + git clone --depth 1 -b ${_BRANCH} ${_URL} ${_DEST} + ( cd ${3} && echo "${_DEST}: `git log -1 --format='%s | %H | %cd | %aN'`" ) +} + +checkout_mathcomp() +{ + git_checkout ${mathcomp_CI_BRANCH} ${mathcomp_CI_GITURL} ${1} +} + +# this installs just the ssreflect library of math-comp +install_ssreflect() +{ + echo 'Installing ssreflect' && echo -en 'travis_fold:start:ssr.install\\r' + + checkout_mathcomp math-comp + ( cd math-comp/mathcomp && \ + sed -i.bak '/ssrtest/d' Make && \ + sed -i.bak '/odd_order/d' Make && \ + sed -i.bak '/all\/all.v/d' Make && \ + sed -i.bak '/character/d' Make && \ + sed -i.bak '/real_closed/d' Make && \ + sed -i.bak '/solvable/d' Make && \ + sed -i.bak '/field/d' Make && \ + sed -i.bak '/fingroup/d' Make && \ + sed -i.bak '/algebra/d' Make && \ + make Makefile.coq && make -f Makefile.coq -j ${NJOBS} all && make install ) + + echo -en 'travis_fold:end:ssr.install\\r' + +} diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh new file mode 100755 index 0000000000..ec09389f8e --- /dev/null +++ b/dev/ci/ci-compcert.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +CompCert_CI_BRANCH=master +CompCert_CI_GITURL=https://github.com/AbsInt/CompCert.git + +opam install -j ${NJOBS} -y menhir +git_checkout ${CompCert_CI_BRANCH} ${CompCert_CI_GITURL} CompCert + +# Patch to avoid the upper version limit +( cd CompCert && sed -i.bak 's/8.6)/8.6|trunk)/' configure && ./configure x86_32-linux && make -j ${NJOBS} ) diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh new file mode 100755 index 0000000000..94bd5e468f --- /dev/null +++ b/dev/ci/ci-coquelicot.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +install_ssreflect + +# Setup coquelicot +git_checkout master https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git coquelicot + +( cd coquelicot && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) diff --git a/dev/ci/ci-cpdt.sh b/dev/ci/ci-cpdt.sh new file mode 100755 index 0000000000..18d7561804 --- /dev/null +++ b/dev/ci/ci-cpdt.sh @@ -0,0 +1,10 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +wget http://adam.chlipala.net/cpdt/cpdt.tgz +tar xvfz cpdt.tgz + +( cd cpdt && make clean && make -j ${NJOBS} ) + diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh new file mode 100755 index 0000000000..c669195ddd --- /dev/null +++ b/dev/ci/ci-fiat-crypto.sh @@ -0,0 +1,9 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +git_checkout master https://github.com/mit-plv/fiat-crypto.git fiat-crypto + +( cd fiat-crypto && make -j ${NJOBS} ) diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh new file mode 100755 index 0000000000..345924e40a --- /dev/null +++ b/dev/ci/ci-flocq.sh @@ -0,0 +1,9 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +git_checkout master https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git flocq + +( cd flocq && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh new file mode 100755 index 0000000000..ce870e52b5 --- /dev/null +++ b/dev/ci/ci-geocoq.sh @@ -0,0 +1,16 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +# XXX: replace by generic template +GeoCoq_CI_BRANCH=master +GeoCoq_CI_GITURL=https://github.com/GeoCoq/GeoCoq.git + +git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} GeoCoq + +( cd GeoCoq && \ + ./configure.sh && \ + sed -i.bak '/Ch16_coordinates_with_functions\.v/d' Make && \ + coq_makefile -f Make -o Makefile && \ + make -j ${NJOBS} ) diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh new file mode 100755 index 0000000000..0c07564c02 --- /dev/null +++ b/dev/ci/ci-hott.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +git_checkout mz-8.7 https://github.com/ejgallego/HoTT.git HoTT + +( cd HoTT && ./autogen.sh && ./configure && make -j ${NJOBS} ) diff --git a/dev/ci/ci-iris-coq.sh b/dev/ci/ci-iris-coq.sh new file mode 100755 index 0000000000..c21af976f4 --- /dev/null +++ b/dev/ci/ci-iris-coq.sh @@ -0,0 +1,17 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +install_ssreflect + +# Setup stdpp +git_checkout master https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git coq-stdpp + +( cd coq-stdpp && make -j ${NJOBS} && make install ) + +# Setup Iris +git_checkout master https://gitlab.mpi-sws.org/FP/iris-coq.git iris-coq + +( cd iris-coq && make -j ${NJOBS} ) diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math-classes.sh new file mode 100755 index 0000000000..4450dc0710 --- /dev/null +++ b/dev/ci/ci-math-classes.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +git_checkout v8.6 https://github.com/math-classes/math-classes.git math-classes +( cd math-classes && make -j ${NJOBS} && make install ) + +git_checkout v8.6 https://github.com/c-corn/corn.git corn +( cd corn && make -j ${NJOBS} ) + diff --git a/dev/ci/ci-math-comp.sh b/dev/ci/ci-math-comp.sh new file mode 100755 index 0000000000..2eb150cb52 --- /dev/null +++ b/dev/ci/ci-math-comp.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +checkout_mathcomp math-comp + +# odd_order takes too much time for travis. +( cd math-comp/mathcomp && \ + sed -i.bak '/PFsection/d' Make && \ + sed -i.bak '/stripped_odd_order_theorem/d' Make && \ + make Makefile.coq && make -f Makefile.coq -j ${NJOBS} all ) diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh new file mode 100755 index 0000000000..91a33695b0 --- /dev/null +++ b/dev/ci/ci-metacoq.sh @@ -0,0 +1,16 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +# MetaCoq + UniCoq + +git_checkout master https://github.com/unicoq/unicoq.git unicoq + +( cd unicoq && coq_makefile -f Make -o Makefile && make -j ${NJOBS} && make install ) + +git_checkout master https://github.com/MetaCoq/MetaCoq.git MetaCoq + +( cd MetaCoq && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} ) + diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh new file mode 100755 index 0000000000..5e41211f1a --- /dev/null +++ b/dev/ci/ci-sf.sh @@ -0,0 +1,11 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +wget https://www.cis.upenn.edu/~bcpierce/sf/current/sf.tgz +tar xvfz sf.tgz + +( cd sf && sed -i.bak 's/(K,N)/((K,N))/' LibTactics.v && make clean && make -j ${NJOBS} ) + + diff --git a/dev/ci/ci-tlc.sh b/dev/ci/ci-tlc.sh new file mode 100755 index 0000000000..b946324924 --- /dev/null +++ b/dev/ci/ci-tlc.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +git_checkout master https://gforge.inria.fr/git/tlc/tlc.git tlc + +( cd tlc && make -j ${NJOBS} ) diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh new file mode 100755 index 0000000000..15e619acbb --- /dev/null +++ b/dev/ci/ci-unimath.sh @@ -0,0 +1,15 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +UniMath_CI_BRANCH=master +UniMath_CI_GITURL=https://github.com/UniMath/UniMath.git + +git_checkout ${UniMath_CI_BRANCH} ${UniMath_CI_GITURL} UniMath + +( cd UniMath && \ + sed -i.bak '/Folds/d' Makefile && \ + sed -i.bak '/HomologicalAlgebra/d' Makefile && \ + make -j ${NJOBS} BUILD_COQ=no ) + -- cgit v1.2.3 From 5ee6e1ac4782ce0c2fb45f3927d210d3f1207053 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 2 Mar 2017 23:37:33 +0100 Subject: [ltac] Move dummy plugin to plugins folder. This is needed to fix `Declare ML Module "ltac_plugin". --- Makefile.common | 5 +++-- ltac/ltac.mllib | 1 - ltac/ltac_plugin.ml | 0 ltac/ltac_plugin.mli | 0 plugins/ltac/LtacDummy.v | 2 ++ plugins/ltac/ltac_dummy.ml | 0 plugins/ltac/ltac_dummy.mli | 0 plugins/ltac/ltac_plugin.mlpack | 1 + plugins/ltac/vo.itarget | 1 + 9 files changed, 7 insertions(+), 3 deletions(-) delete mode 100644 ltac/ltac_plugin.ml delete mode 100644 ltac/ltac_plugin.mli create mode 100644 plugins/ltac/LtacDummy.v create mode 100644 plugins/ltac/ltac_dummy.ml create mode 100644 plugins/ltac/ltac_dummy.mli create mode 100644 plugins/ltac/ltac_plugin.mlpack create mode 100644 plugins/ltac/vo.itarget diff --git a/Makefile.common b/Makefile.common index 49fe1fd939..a2b59a93b2 100644 --- a/Makefile.common +++ b/Makefile.common @@ -62,7 +62,7 @@ PLUGINDIRS:=\ setoid_ring extraction fourier \ cc funind firstorder derive \ rtauto nsatz syntax decl_mode btauto \ - ssrmatching + ssrmatching ltac SRCDIRS:=\ $(CORESRCDIRS) \ @@ -120,6 +120,7 @@ OTHERSYNTAXCMO:=$(addprefix plugins/syntax/, \ string_syntax_plugin.cmo ) DECLMODECMO:=plugins/decl_mode/decl_mode_plugin.cmo DERIVECMO:=plugins/derive/derive_plugin.cmo +LTACCMO:=plugins/ltac/ltac_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ @@ -127,7 +128,7 @@ PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ $(FOURIERCMO) $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(NATSYNTAXCMO) $(OTHERSYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) + $(DERIVECMO) $(SSRMATCHINGCMO) $(LTACCMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib index 974943ddd6..fc51e48ae4 100644 --- a/ltac/ltac.mllib +++ b/ltac/ltac.mllib @@ -20,4 +20,3 @@ G_rewrite Tauto G_eqdecide G_ltac -Ltac_plugin diff --git a/ltac/ltac_plugin.ml b/ltac/ltac_plugin.ml deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/ltac/ltac_plugin.mli b/ltac/ltac_plugin.mli deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/plugins/ltac/LtacDummy.v b/plugins/ltac/LtacDummy.v new file mode 100644 index 0000000000..4f96bbaeb9 --- /dev/null +++ b/plugins/ltac/LtacDummy.v @@ -0,0 +1,2 @@ +(* The sole reason of this file is to trick coq's build system to build the dummy ltac plugin *) +Declare ML Module "ltac_plugin". diff --git a/plugins/ltac/ltac_dummy.ml b/plugins/ltac/ltac_dummy.ml new file mode 100644 index 0000000000..e69de29bb2 diff --git a/plugins/ltac/ltac_dummy.mli b/plugins/ltac/ltac_dummy.mli new file mode 100644 index 0000000000..e69de29bb2 diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack new file mode 100644 index 0000000000..6efb477cce --- /dev/null +++ b/plugins/ltac/ltac_plugin.mlpack @@ -0,0 +1 @@ +Ltac_dummy diff --git a/plugins/ltac/vo.itarget b/plugins/ltac/vo.itarget new file mode 100644 index 0000000000..4eff76566a --- /dev/null +++ b/plugins/ltac/vo.itarget @@ -0,0 +1 @@ +LtacDummy.vo -- cgit v1.2.3 From a0bd33bdb81271025494d3f7ac7ae20bd6671579 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 2 Oct 2016 21:30:29 +0200 Subject: Formatting references with surrounding brackets in Diaconescu.v. --- theories/Logic/Diaconescu.v | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 23af5afc68..896be7c339 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -8,9 +8,9 @@ (************************************************************************) (** Diaconescu showed that the Axiom of Choice entails Excluded-Middle - in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show + in topoi [[Diaconescu75]]. Lacas and Werner adapted the proof to show that the axiom of choice in equivalence classes entails - Excluded-Middle in Type Theory [LacasWerner99]. + Excluded-Middle in Type Theory [[LacasWerner99]]. Three variants of Diaconescu's result in type theory are shown below. @@ -23,22 +23,22 @@ Benjamin Werner) C. A proof that extensional Hilbert epsilon's description operator - entails excluded-middle (taken from Bell [Bell93]) + entails excluded-middle (taken from Bell [[Bell93]]) - See also [Carlström] for a discussion of the connection between the + See also [[Carlström04]] for a discussion of the connection between the Extensional Axiom of Choice and Excluded-Middle - [Diaconescu75] Radu Diaconescu, Axiom of Choice and Complementation, + [[Diaconescu75]] Radu Diaconescu, Axiom of Choice and Complementation, in Proceedings of AMS, vol 51, pp 176-178, 1975. - [LacasWerner99] Samuel Lacas, Benjamin Werner, Which Choices imply + [[LacasWerner99]] Samuel Lacas, Benjamin Werner, Which Choices imply the excluded middle?, preprint, 1999. - [Bell93] John L. Bell, Hilbert's epsilon operator and classical + [[Bell93]] John L. Bell, Hilbert's epsilon operator and classical logic, Journal of Philosophical Logic, 22: 1-18, 1993 - [Carlström04] Jesper Carlström, EM + Ext_ + AC_int <-> AC_ext, - Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004. + [[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent + to AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004. *) (**********************************************************************) @@ -263,7 +263,7 @@ End ProofIrrel_RelChoice_imp_EqEM. (**********************************************************************) (** * Extensional Hilbert's epsilon description operator -> Excluded-Middle *) -(** Proof sketch from Bell [Bell93] (with thanks to P. Castéran) *) +(** Proof sketch from Bell [[Bell93]] (with thanks to P. Castéran) *) Local Notation inhabited A := A (only parsing). -- cgit v1.2.3 From d8f42feb4f4e6c4e062678e256499e03454c7ab2 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 13 Sep 2016 22:12:35 +0200 Subject: Compatibility of iff wrt not and imp. This completes the series and cannot hurt. --- theories/Init/Datatypes.v | 1 - theories/Init/Logic.v | 19 +++++++++++++++++++ 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index ddaf08bf71..4e3f2e80f3 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -326,7 +326,6 @@ Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c, CompSpec eq lt x y c -> CompSpecT eq lt x y c. Proof. intros. apply CompareSpec2Type; assumption. Defined. - (******************************************************************) (** * Misc Other Datatypes *) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 85123cc444..fb1a7ab1c1 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -125,6 +125,25 @@ Proof. [apply Hl | apply Hr]; assumption. Qed. +Theorem imp_iff_compat_l : forall A B C : Prop, + (B <-> C) -> ((A -> B) <-> (A -> C)). +Proof. + intros ? ? ? [Hl Hr]; split; intros H ?; [apply Hl | apply Hr]; apply H; assumption. +Qed. + +Theorem imp_iff_compat_r : forall A B C : Prop, + (B <-> C) -> ((B -> A) <-> (C -> A)). +Proof. + intros ? ? ? [Hl Hr]; split; intros H ?; [apply H, Hr | apply H, Hl]; assumption. +Qed. + +Theorem not_iff_compat : forall A B : Prop, + (A <-> B) -> (~ A <-> ~B). +Proof. + intros; apply imp_iff_compat_r; assumption. +Qed. + + (** Some equivalences *) Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False). -- cgit v1.2.3 From 859a9666923e657add7e972762af29a1872cc842 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 13 Sep 2016 22:40:16 +0200 Subject: A couple of other useful properties about compare_cont. Don't know if compare_cont is very useful to use, but, at least, these extensions make sense. --- theories/Init/Datatypes.v | 5 +++++ theories/PArith/BinPos.v | 28 ++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+) diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 4e3f2e80f3..11d80dbc33 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -262,6 +262,11 @@ Inductive comparison : Set := | Lt : comparison | Gt : comparison. +Lemma comparison_eq_stable : forall c c' : comparison, ~~ c = c' -> c = c'. +Proof. + destruct c, c'; intro H; reflexivity || destruct H; discriminate. +Qed. + Definition CompOpp (r:comparison) := match r with | Eq => Eq diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index 7baf102aaa..d6385ee314 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -813,6 +813,34 @@ Proof. rewrite compare_cont_spec. unfold ge. destruct (p ?= q); easy'. Qed. +Lemma compare_cont_Lt_not_Lt p q : + compare_cont Lt p q <> Lt <-> p > q. +Proof. + rewrite compare_cont_Lt_Lt. + unfold gt, le, compare. + now destruct compare_cont; split; try apply comparison_eq_stable. +Qed. + +Lemma compare_cont_Lt_not_Gt p q : + compare_cont Lt p q <> Gt <-> p <= q. +Proof. + apply not_iff_compat, compare_cont_Lt_Gt. +Qed. + +Lemma compare_cont_Gt_not_Lt p q : + compare_cont Gt p q <> Lt <-> p >= q. +Proof. + apply not_iff_compat, compare_cont_Gt_Lt. +Qed. + +Lemma compare_cont_Gt_not_Gt p q : + compare_cont Gt p q <> Gt <-> p < q. +Proof. + rewrite compare_cont_Gt_Gt. + unfold ge, lt, compare. + now destruct compare_cont; split; try apply comparison_eq_stable. +Qed. + (** We can express recursive equations for [compare] *) Lemma compare_xO_xO p q : (p~0 ?= q~0) = (p ?= q). -- cgit v1.2.3 From 655401f6c5ca27ffddc231d89062041b163ae285 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 3 Mar 2017 10:13:24 +0100 Subject: Completing "few lemmas about Zneg" with lemmas also about Zpos. --- theories/ZArith/BinInt.v | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 5aa397f8a9..711047e525 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1367,7 +1367,7 @@ Lemma inj_testbit a n : 0<=n -> Z.testbit (Z.pos a) n = N.testbit (N.pos a) (Z.to_N n). Proof. apply Z.testbit_Zpos. Qed. -(** Some results concerning Z.neg *) +(** Some results concerning Z.neg and Z.pos *) Lemma inj_neg p q : Z.neg p = Z.neg q -> p = q. Proof. now injection 1. Qed. @@ -1375,18 +1375,36 @@ Proof. now injection 1. Qed. Lemma inj_neg_iff p q : Z.neg p = Z.neg q <-> p = q. Proof. split. apply inj_neg. intros; now f_equal. Qed. +Lemma inj_pos p q : Z.pos p = Z.pos q -> p = q. +Proof. now injection 1. Qed. + +Lemma inj_pos_iff p q : Z.pos p = Z.pos q <-> p = q. +Proof. split. apply inj_pos. intros; now f_equal. Qed. + Lemma neg_is_neg p : Z.neg p < 0. Proof. reflexivity. Qed. Lemma neg_is_nonpos p : Z.neg p <= 0. Proof. easy. Qed. +Lemma pos_is_pos p : 0 < Z.pos p. +Proof. reflexivity. Qed. + +Lemma pos_is_nonneg p : 0 <= Z.pos p. +Proof. easy. Qed. + Lemma neg_xO p : Z.neg p~0 = 2 * Z.neg p. Proof. reflexivity. Qed. Lemma neg_xI p : Z.neg p~1 = 2 * Z.neg p - 1. Proof. reflexivity. Qed. +Lemma pos_xO p : Z.pos p~0 = 2 * Z.pos p. +Proof. reflexivity. Qed. + +Lemma pos_xI p : Z.pos p~1 = 2 * Z.pos p + 1. +Proof. reflexivity. Qed. + Lemma opp_neg p : - Z.neg p = Z.pos p. Proof. reflexivity. Qed. @@ -1402,6 +1420,9 @@ Proof. reflexivity. Qed. Lemma add_neg_pos p q : Z.neg p + Z.pos q = Z.pos_sub q p. Proof. reflexivity. Qed. +Lemma add_pos_pos p q : Z.pos p + Z.pos q = Z.pos (p+q). +Proof. reflexivity. Qed. + Lemma divide_pos_neg_r n p : (n|Z.pos p) <-> (n|Z.neg p). Proof. apply Z.divide_Zpos_Zneg_r. Qed. @@ -1412,6 +1433,10 @@ Lemma testbit_neg a n : 0<=n -> Z.testbit (Z.neg a) n = negb (N.testbit (Pos.pred_N a) (Z.to_N n)). Proof. apply Z.testbit_Zneg. Qed. +Lemma testbit_pos a n : 0<=n -> + Z.testbit (Z.pos a) n = N.testbit (N.pos a) (Z.to_N n). +Proof. apply Z.testbit_Zpos. Qed. + End Pos2Z. Module Z2Pos. -- cgit v1.2.3 From a61494c8c430477da8a4b3367a8ac5d492bf83c1 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 3 Mar 2017 10:20:48 +0100 Subject: Relying on BinInt.Z.Pos2Z for proofs of a few lemmas in Zorder. --- theories/ZArith/BinInt.v | 3 +++ theories/ZArith/Zorder.v | 6 +++--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 711047e525..d093374847 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1393,6 +1393,9 @@ Proof. reflexivity. Qed. Lemma pos_is_nonneg p : 0 <= Z.pos p. Proof. easy. Qed. +Lemma neg_le_pos p q : Zneg p <= Zpos q. +Proof. easy. Qed. + Lemma neg_xO p : Z.neg p~0 = 2 * Z.neg p. Proof. reflexivity. Qed. diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 73dee0cf24..18915216a0 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -339,7 +339,7 @@ Notation Zle_0_1 := Z.le_0_1 (compat "8.3"). Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q. Proof. - easy. + exact Pos2Z.neg_le_pos. Qed. Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0. @@ -350,12 +350,12 @@ Qed. (* weaker but useful (in [Z.pow] for instance) *) Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p. Proof. - easy. + exact Pos2Z.pos_is_nonneg. Qed. Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0. Proof. - easy. + exact Pos2Z.neg_is_neg. Qed. Lemma Zle_0_nat : forall n:nat, 0 <= Z.of_nat n. -- cgit v1.2.3 From 27d92355d38af5ee93c7343a62671701e72c1096 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 3 Mar 2017 10:27:30 +0100 Subject: Completing basic lemmas about <= and < in BinInt.Z.Pos2Z. --- theories/ZArith/BinInt.v | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index d093374847..1e3ab66876 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1396,6 +1396,21 @@ Proof. easy. Qed. Lemma neg_le_pos p q : Zneg p <= Zpos q. Proof. easy. Qed. +Lemma neg_lt_pos p q : Zneg p < Zpos q. +Proof. easy. Qed. + +Lemma neg_le_neg p q : (q <= p)%positive -> Zneg p <= Zneg q. +Proof. intros; unfold Z.le; simpl. now rewrite <- Pos.compare_antisym. Qed. + +Lemma neg_lt_neg p q : (q < p)%positive -> Zneg p < Zneg q. +Proof. intros; unfold Z.lt; simpl. now rewrite <- Pos.compare_antisym. Qed. + +Lemma pos_le_pos p q : (p <= q)%positive -> Zpos p <= Zpos q. +Proof. easy. Qed. + +Lemma pos_lt_pos p q : (p < q)%positive -> Zpos p < Zpos q. +Proof. easy. Qed. + Lemma neg_xO p : Z.neg p~0 = 2 * Z.neg p. Proof. reflexivity. Qed. -- cgit v1.2.3 From 7497d4129775d15cdce862a0ac681c6400aabe54 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 6 Oct 2016 07:02:24 +0200 Subject: Logic library: Adding a characterization of excluded-middle in term of choice of a representative in a partition of bool. Also move a result about propositional extensionality from ClassicalFacts.v to PropExtensionalityFacts.v, generalizing it by symmetry. Also spotting typos (thanks to Théo). --- doc/stdlib/index-list.html.template | 1 + theories/Logic/ClassicalFacts.v | 66 ++++++++++++++++++- theories/Logic/PropExtensionalityFacts.v | 109 +++++++++++++++++++++++++++++++ 3 files changed, 173 insertions(+), 3 deletions(-) create mode 100644 theories/Logic/PropExtensionalityFacts.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 9216c81fcd..4a685a3b85 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -55,6 +55,7 @@ through the Require Import command.

theories/Logic/Description.v theories/Logic/Epsilon.v theories/Logic/IndefiniteDescription.v + theories/Logic/PropExtensionalityFacts.v theories/Logic/FunctionalExtensionality.v theories/Logic/ExtensionalityFacts.v theories/Logic/WeakFan.v diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index afd64efdf8..021408a37b 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -34,8 +34,11 @@ Table of contents: 3 3. Independence of general premises and drinker's paradox -4. Classical logic and principle of unrestricted minimization +4. Principles equivalent to classical logic +4.1 Classical logic = principle of unrestricted minimization + +4.2 Classical logic = choice of representatives in a partition of bool *) (************************************************************************) @@ -94,12 +97,14 @@ Qed. (** A weakest form of propositional extensionality: extensionality for provable propositions only *) +Require Import PropExtensionalityFacts. + Definition provable_prop_extensionality := forall A:Prop, A -> A = True. Lemma provable_prop_ext : prop_extensionality -> provable_prop_extensionality. Proof. - intros Ext A Ha; apply Ext; split; trivial. + exact PropExt_imp_ProvPropExt. Qed. (************************************************************************) @@ -516,7 +521,7 @@ End Weak_proof_irrelevance_CCI. (** ** Weak excluded-middle *) (** The weak classical logic based on [~~A \/ ~A] is referred to with - name KC in {[ChagrovZakharyaschev97]] + name KC in [[ChagrovZakharyaschev97]] [[ChagrovZakharyaschev97]] Alexander Chagrov and Michael Zakharyaschev, "Modal Logic", Clarendon Press, 1997. @@ -661,6 +666,8 @@ Proof. exists x0; exact Hnot. Qed. +(** * Axioms equivalent to classical logic *) + (** ** Principle of unrestricted minimization *) Require Import Coq.Arith.PeanoNat. @@ -736,3 +743,56 @@ Section Example_of_undecidable_predicate_with_the_minimization_property. Qed. End Example_of_undecidable_predicate_with_the_minimization_property. + +(** ** Choice of representatives in a partition of bool *) + +(** This is similar to Bell's "weak extensional selection principle" in [[Bell]] + + [[Bell]] John L. Bell, Choice principles in intuitionistic set theory, unpublished. +*) + +Require Import RelationClasses. + +Local Notation representative_boolean_partition := + (forall R:bool->bool->Prop, + Equivalence R -> exists f, forall x, R x (f x) /\ forall y, R x y -> f x = f y). + +Theorem representative_boolean_partition_imp_excluded_middle : + representative_boolean_partition -> excluded_middle. +Proof. + intros ReprFunChoice P. + pose (R (b1 b2 : bool) := b1 = b2 \/ P). + assert (Equivalence R). + { split. + - now left. + - destruct 1. now left. now right. + - destruct 1, 1; try now right. left; now transitivity y. } + destruct (ReprFunChoice R H) as (f,Hf). clear H. + destruct (Bool.bool_dec (f true) (f false)) as [Heq|Hneq]. + + left. + destruct (Hf false) as ([Hfalse|HP],_); try easy. + destruct (Hf true) as ([Htrue|HP],_); try easy. + congruence. + + right. intro HP. + destruct (Hf true) as (_,H). apply Hneq, H. now right. +Qed. + +Theorem excluded_middle_imp_representative_boolean_partition : + excluded_middle -> representative_boolean_partition. +Proof. + intros EM R H. + destruct (EM (R true false)). + - exists (fun _ => true). + intros []; firstorder. + - exists (fun b => b). + intro b. split. + + reflexivity. + + destruct b, y; intros HR; easy || now symmetry in HR. +Qed. + +Theorem excluded_middle_iff_representative_boolean_partition : + excluded_middle <-> representative_boolean_partition. +Proof. + split; auto using excluded_middle_imp_representative_boolean_partition, + representative_boolean_partition_imp_excluded_middle. +Qed. diff --git a/theories/Logic/PropExtensionalityFacts.v b/theories/Logic/PropExtensionalityFacts.v new file mode 100644 index 0000000000..7e455dfa1e --- /dev/null +++ b/theories/Logic/PropExtensionalityFacts.v @@ -0,0 +1,109 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Proposition extensionality + Propositional functional extensionality + +2.2 Propositional extensionality -> Provable propositional extensionality + +2.3 Propositional extensionality -> Refutable propositional extensionality + +*) + +Set Implicit Arguments. + +(**********************************************************************) +(** * Definitions *) + +(** Propositional extensionality *) + +Local Notation PropositionalExtensionality := + (forall A B : Prop, (A <-> B) -> A = B). + +(** Provable-proposition extensionality *) + +Local Notation ProvablePropositionExtensionality := + (forall A:Prop, A -> A = True). + +(** Refutable-proposition extensionality *) + +Local Notation RefutablePropositionExtensionality := + (forall A:Prop, ~A -> A = False). + +(** Predicate extensionality *) + +Local Notation PredicateExtensionality := + (forall (A:Type) (P Q : A -> Prop), (forall x, P x <-> Q x) -> P = Q). + +(** Propositional functional extensionality *) + +Local Notation PropositionalFunctionalExtensionality := + (forall (A:Type) (P Q : A -> Prop), (forall x, P x = Q x) -> P = Q). + +(**********************************************************************) +(** * Propositional and predicate extensionality *) + +(**********************************************************************) +(** ** Predicate extensionality <-> Propositional extensionality + Propositional functional extensionality *) + +Lemma PredExt_imp_PropExt : PredicateExtensionality -> PropositionalExtensionality. +Proof. + intros Ext A B Equiv. + change A with ((fun _ => A) I). + now rewrite Ext with (P := fun _ : True =>A) (Q := fun _ => B). +Qed. + +Lemma PredExt_imp_PropFunExt : PredicateExtensionality -> PropositionalFunctionalExtensionality. +Proof. + intros Ext A P Q Eq. apply Ext. intros x. now rewrite (Eq x). +Qed. + +Lemma PropExt_and_PropFunExt_imp_PredExt : + PropositionalExtensionality -> PropositionalFunctionalExtensionality -> PredicateExtensionality. +Proof. + intros Ext FunExt A P Q Equiv. + apply FunExt. intros x. now apply Ext. +Qed. + +Theorem PropExt_and_PropFunExt_iff_PredExt : + PropositionalExtensionality /\ PropositionalFunctionalExtensionality <-> PredicateExtensionality. +Proof. + firstorder using PredExt_imp_PropExt, PredExt_imp_PropFunExt, PropExt_and_PropFunExt_imp_PredExt. +Qed. + +(**********************************************************************) +(** ** Propositional extensionality and provable proposition extensionality *) + +Lemma PropExt_imp_ProvPropExt : PropositionalExtensionality -> ProvablePropositionExtensionality. +Proof. + intros Ext A Ha; apply Ext; split; trivial. +Qed. + +(**********************************************************************) +(** ** Propositional extensionality and refutable proposition extensionality *) + +Lemma PropExt_imp_RefutPropExt : PropositionalExtensionality -> RefutablePropositionExtensionality. +Proof. + intros Ext A Ha; apply Ext; split; easy. +Qed. -- cgit v1.2.3 From b453d0281db6de0c36cbd9f2c0a094946f4fcfd6 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 10 Oct 2016 12:12:33 +0200 Subject: Slightly unifying renaming in ChoiceFacts.v. --- theories/Logic/ChoiceFacts.v | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 1420a000b6..2ab851e297 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -284,7 +284,7 @@ Definition SmallDrinker'sParadox := relational formulation) without known inconsistency with classical logic, though functional relation reification conflicts with classical logic *) -Lemma description_rel_choice_imp_funct_choice : +Lemma functional_rel_reification_and_rel_choice_imp_fun_choice : forall A B : Type, FunctionalRelReification_on A B -> RelationalChoice_on A B -> FunctionalChoice_on A B. Proof. @@ -298,7 +298,10 @@ Proof. apply HR'R; assumption. Qed. -Lemma funct_choice_imp_rel_choice : +Notation description_rel_choice_imp_funct_choice := + functional_rel_reification_and_rel_choice_imp_fun_choice (compat "8.6"). + +Lemma fun_choice_imp_rel_choice : forall A B : Type, FunctionalChoice_on A B -> RelationalChoice_on A B. Proof. intros A B FunCh R H. @@ -311,7 +314,9 @@ Proof. trivial. Qed. -Lemma funct_choice_imp_description : +Notation funct_choice_imp_rel_choice := fun_choice_imp_rel_choice (compat "8.6"). + +Lemma fun_choice_imp_functional_rel_reification : forall A B : Type, FunctionalChoice_on A B -> FunctionalRelReification_on A B. Proof. intros A B FunCh R H. @@ -324,17 +329,21 @@ Proof. exists f; exact H0. Qed. -Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr : +Notation funct_choice_imp_description := fun_choice_imp_functional_rel_reification (compat "8.6"). + +Corollary fun_choice_iff_rel_choice_and_functional_rel_reification : forall A B : Type, FunctionalChoice_on A B <-> RelationalChoice_on A B /\ FunctionalRelReification_on A B. Proof. intros A B. split. intro H; split; - [ exact (funct_choice_imp_rel_choice H) - | exact (funct_choice_imp_description H) ]. - intros [H H0]; exact (description_rel_choice_imp_funct_choice H0 H). + [ exact (fun_choice_imp_rel_choice H) + | exact (fun_choice_imp_functional_rel_reification H) ]. + intros [H H0]; exact (functional_rel_reification_and_rel_choice_imp_fun_choice H0 H). Qed. +Notation FunChoice_Equiv_RelChoice_and_ParamDefinDescr := + fun_choice_iff_rel_choice_and_functional_rel_reification (compat "8.6"). (**********************************************************************) (** * Connection between the guarded, non guarded and omniscient choices *) -- cgit v1.2.3 From 62ed11de4c528a496e0ece70a07062a1b6d4f7d8 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 2 Oct 2016 21:48:52 +0200 Subject: Adding various properties and characterization of the extensional axiom of choice (i.e. choice on setoids) and of the axiom selecting representatives in classes of equivalence. Also integrating suggestions from Théo. --- theories/Logic/ChoiceFacts.v | 425 ++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 422 insertions(+), 3 deletions(-) diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 2ab851e297..3f17ba5a95 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -22,7 +22,14 @@ description principles - AC! = functional relation reification (known as axiom of unique choice in topos theory, sometimes called principle of definite description in - the context of constructive type theory) + the context of constructive type theory, sometimes + called axiom of no choice) + +- AC_fun_repr = functional choice of a representative in an equivalence class +- AC_fun_setoid_gen = functional form of the general form of the (so-called + extensional) axiom of choice over setoids +- AC_fun_setoid = functional form of the (so-called extensional) axiom of + choice from setoids - GAC_rel = guarded relational form of the (non extensional) axiom of choice - GAC_fun = guarded functional form of the (non extensional) axiom of choice @@ -45,6 +52,11 @@ description principles independence of premises) - Drinker = drinker's paradox (small form) (called Ex in Bell [[Bell]]) +- EM = excluded-middle + +- Ext_pred_repr = choice of a representative among extensional predicates +- Ext_pred = extensionality of predicates +- Ext_fun_prop_repr = choice of a representative among extensional functions to Prop We let also @@ -76,6 +88,10 @@ Table of contents 8. Choice -> Dependent choice -> Countable choice +9.1. AC_fun_ext = AC_fun + Ext_fun_repr + EM + +9.2. AC_fun_ext = AC_fun + Ext_prop_fun_repr + PI + References: [[Bell]] John L. Bell, Choice principles in intuitionistic set theory, @@ -84,8 +100,13 @@ unpublished. [[Bell93]] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic Type Theories, Mathematical Logic Quarterly, volume 39, 1993. +[[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent to +AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004. + [[Carlström05]] Jesper Carlström, Interpreting descriptions in intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005. + +[[Werner97]] Benjamin Werner, Sets in Types, Types in Sets, TACS, 1997. *) Set Implicit Arguments. @@ -108,8 +129,6 @@ Variables A B :Type. Variable P:A->Prop. -Variable R:A->B->Prop. - (** ** Constructive choice and description *) (** AC_rel *) @@ -121,6 +140,10 @@ Definition RelationalChoice_on := (** AC_fun *) +(* Note: This is called Type-Theoretic Description Axiom (TTDA) in + [[Werner97]] (using a non-standard meaning of "description"). This + is called intensional axiom of choice (AC_int) in [[Carlström04]] *) + Definition FunctionalChoice_on := forall R:A->B->Prop, (forall x : A, exists y : B, R x y) -> @@ -148,6 +171,55 @@ Definition FunctionalRelReification_on := (forall x : A, exists! y : B, R x y) -> (exists f : A->B, forall x : A, R x (f x)). +(** AC_fun_repr *) + +(* Note: This is called Type-Theoretic Choice Axiom (TTCA) in + [[Werner97]] (by reference to the extensional set-theoretic + formulation of choice); Note also a typo in its intended + formulation in [[Werner97]]. *) + +Require Import RelationClasses Logic. + +Definition RepresentativeFunctionalChoice_on := + forall R:A->A->Prop, + (Equivalence R) -> + (exists f : A->A, forall x : A, (R x (f x)) /\ forall y, R x y -> f x = f y). + +(** AC_fun_ext *) + +Definition SetoidFunctionalChoice_on := + forall R : A -> A -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + (forall x x' y, R x x' -> T x y -> T x' y) -> + (forall x, exists y, T x y) -> + exists f : A -> B, forall x : A, T x (f x) /\ (forall y : A, R x y -> f x = f y). + +(** AC_fun_ext_gen *) + +(* Note: This is called extensional axiom of choice (AC_ext) in + [[Carlström04]]. *) + +Definition GeneralizedSetoidFunctionalChoice_on := + forall R : A -> A -> Prop, + forall S : B -> B -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + Equivalence S -> + (forall x x' y y', R x x' -> S y y' -> T x y -> T x' y') -> + (forall x, exists y, T x y) -> + exists f : A -> B, + forall x : A, T x (f x) /\ (forall y : A, R x y -> S (f x) (f y)). + +(** AC_fun_ext_simple *) + +Definition SimpleSetoidFunctionalChoice_on A B := + forall R : A -> A -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + (forall x, exists y, forall x', R x x' -> T x' y) -> + exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). + (** ID_epsilon (constructive version of indefinite description; combined with proof-irrelevance, it may be connected to Carlström's type theory with a constructive indefinite description @@ -234,6 +306,14 @@ Notation FunctionalChoiceOnInhabitedSet := (forall A B : Type, inhabited B -> FunctionalChoice_on A B). Notation FunctionalRelReification := (forall A B : Type, FunctionalRelReification_on A B). +Notation RepresentativeFunctionalChoice := + (forall A : Type, RepresentativeFunctionalChoice_on A). +Notation SetoidFunctionalChoice := + (forall A B: Type, SetoidFunctionalChoice_on A B). +Notation GeneralizedSetoidFunctionalChoice := + (forall A B : Type, GeneralizedSetoidFunctionalChoice_on A B). +Notation SimpleSetoidFunctionalChoice := + (forall A B : Type, SimpleSetoidFunctionalChoice_on A B). Notation GuardedRelationalChoice := (forall A B : Type, GuardedRelationalChoice_on A B). @@ -271,6 +351,26 @@ Definition SmallDrinker'sParadox := forall (A:Type) (P:A -> Prop), inhabited A -> exists x, (exists x, P x) -> P x. +Definition ExcludedMiddle := + forall P:Prop, P \/ ~ P. + +(** Extensional schemes *) + +Local Notation ExtensionalPropositionRepresentative := + (forall (A:Type), + exists h : Prop -> Prop, + forall P : Prop, (P <-> h P) /\ forall Q, (P <-> Q) -> h P = h Q). + +Local Notation ExtensionalPredicateRepresentative := + (forall (A:Type), + exists h : (A->Prop) -> (A->Prop), + forall (P : A -> Prop), (forall x, P x <-> h P x) /\ forall Q, (forall x, P x <-> Q x) -> h P = h Q). + +Local Notation ExtensionalFunctionRepresentative := + (forall (A B:Type), + exists h : (A->B) -> (A->B), + forall (f : A -> B), (forall x, f x = h f x) /\ forall g, (forall x, f x = g x) -> h f = h g). + (**********************************************************************) (** * AC_rel + AC! = AC_fun @@ -871,3 +971,322 @@ Proof. rewrite Heq in HR. assumption. Qed. + +(**********************************************************************) +(** * About the axiom of choice over setoids *) + +Require Import ClassicalFacts PropExtensionalityFacts. + +(**********************************************************************) +(** ** Consequences of the choice of a representative in an equivalence class *) + +Theorem repr_fun_choice_imp_ext_prop_repr : + RepresentativeFunctionalChoice -> ExtensionalPropositionRepresentative. +Proof. + intros ReprFunChoice A. + pose (R P Q := P <-> Q). + assert (Hequiv:Equivalence R) by (split; firstorder). + apply (ReprFunChoice _ R Hequiv). +Qed. + +Theorem repr_fun_choice_imp_ext_pred_repr : + RepresentativeFunctionalChoice -> ExtensionalPredicateRepresentative. +Proof. + intros ReprFunChoice A. + pose (R P Q := forall x : A, P x <-> Q x). + assert (Hequiv:Equivalence R) by (split; firstorder). + apply (ReprFunChoice _ R Hequiv). +Qed. + +Theorem repr_fun_choice_imp_ext_function_repr : + RepresentativeFunctionalChoice -> ExtensionalFunctionRepresentative. +Proof. + intros ReprFunChoice A B. + pose (R (f g : A -> B) := forall x : A, f x = g x). + assert (Hequiv:Equivalence R). + { split; try easy. firstorder using eq_trans. } + apply (ReprFunChoice _ R Hequiv). +Qed. + +(** *** This is a variant of Diaconescu and Goodman-Myhill theorems *) + +Theorem repr_fun_choice_imp_excluded_middle : + RepresentativeFunctionalChoice -> ExcludedMiddle. +Proof. + intros ReprFunChoice. + apply representative_boolean_partition_imp_excluded_middle, ReprFunChoice. +Qed. + +Theorem repr_fun_choice_imp_relational_choice : + RepresentativeFunctionalChoice -> RelationalChoice. +Proof. + intros ReprFunChoice A B T Hexists. + pose (D := (A*B)%type). + pose (R (z z':D) := + let x := fst z in + let x' := fst z' in + let y := snd z in + let y' := snd z' in + x = x' /\ (T x y -> y = y' \/ T x y') /\ (T x y' -> y = y' \/ T x y)). + assert (Hequiv : Equivalence R). + { split. + - split. easy. firstorder. + - intros (x,y) (x',y') (H1,(H2,H2')). split. easy. simpl fst in *. simpl snd in *. + subst x'. split; intro H. + + destruct (H2' H); firstorder. + + destruct (H2 H); firstorder. + - intros (x,y) (x',y') (x'',y'') (H1,(H2,H2')) (H3,(H4,H4')). + simpl fst in *. simpl snd in *. subst x'' x'. split. easy. split; intro H. + + simpl fst in *. simpl snd in *. destruct (H2 H) as [<-|H0]. + * destruct (H4 H); firstorder. + * destruct (H2' H0), (H4 H0); try subst y'; try subst y''; try firstorder. + + simpl fst in *. simpl snd in *. destruct (H4' H) as [<-|H0]. + * destruct (H2' H); firstorder. + * destruct (H2' H0), (H4 H0); try subst y'; try subst y''; try firstorder. } + destruct (ReprFunChoice D R Hequiv) as (g,Hg). + set (T' x y := T x y /\ exists y', T x y' /\ g (x,y') = (x,y)). + exists T'. split. + - intros x y (H,_); easy. + - intro x. destruct (Hexists x) as (y,Hy). + exists (snd (g (x,y))). + destruct (Hg (x,y)) as ((Heq1,(H',H'')),Hgxyuniq); clear Hg. + destruct (H' Hy) as [Heq2|Hgy]; clear H'. + + split. split. + * rewrite <- Heq2. assumption. + * exists y. destruct (g (x,y)) as (x',y'). simpl in Heq1, Heq2. subst; easy. + * intros y' (Hy',(y'',(Hy'',Heq))). + rewrite (Hgxyuniq (x,y'')), Heq. easy. split. easy. + split; right; easy. + + split. split. + * assumption. + * exists y. destruct (g (x,y)) as (x',y'). simpl in Heq1. subst x'; easy. + * intros y' (Hy',(y'',(Hy'',Heq))). + rewrite (Hgxyuniq (x,y'')), Heq. easy. split. easy. + split; right; easy. +Qed. + +(**********************************************************************) +(** ** AC_fun_setoid = AC_fun_setoid_gen *) + +Theorem gen_setoid_fun_choice_imp_setoid_fun_choice : + GeneralizedSetoidFunctionalChoice -> SetoidFunctionalChoice. +Proof. + intros GenSetoidFunChoice A B R T Hequiv Hcompat Hex. + apply GenSetoidFunChoice; try easy. + apply eq_equivalence. + intros * H <-. firstorder. +Qed. + +Theorem setoid_fun_choice_imp_gen_setoid_fun_choice : + SetoidFunctionalChoice -> GeneralizedSetoidFunctionalChoice. +Proof. + intros SetoidFunChoice A B R S T HequivR HequivS Hcompat Hex. + destruct SetoidFunChoice with (R:=R) (T:=T) as (f,Hf); try easy. + { intros; apply (Hcompat x x' y y); try easy. } + exists f. intros x; specialize Hf with x as (Hf,Huniq). intuition. now erewrite Huniq. +Qed. + +Theorem setoid_fun_choice_imp_simple_setoid_fun_choice : + SetoidFunctionalChoice -> SimpleSetoidFunctionalChoice. +Proof. + intros SetoidFunChoice A B R T Hequiv Hexists. + pose (T' x y := forall x', R x x' -> T x' y). + assert (Hcompat : forall (x x' : A) (y : B), R x x' -> T' x y -> T' x' y) by firstorder. + destruct (SetoidFunChoice A B R T' Hequiv Hcompat Hexists) as (f,Hf). + exists f. firstorder. +Qed. + +Theorem simple_setoid_fun_choice_imp_setoid_fun_choice : + SimpleSetoidFunctionalChoice -> SetoidFunctionalChoice. +Proof. + intros SimpleSetoidFunChoice A B R T Hequiv Hcompat Hexists. + destruct (SimpleSetoidFunChoice A B R T Hequiv) as (f,Hf); firstorder. +Qed. + +(**********************************************************************) +(** ** AC_fun_setoid = AC! + AC_fun_repr *) + +Theorem setoid_fun_choice_imp_fun_choice : + SetoidFunctionalChoice -> FunctionalChoice. +Proof. + intros SetoidFunChoice A B T Hexists. + destruct SetoidFunChoice with (R:=@eq A) (T:=T) as (f,Hf). + - apply eq_equivalence. + - now intros * ->. + - assumption. + - exists f. firstorder. +Qed. + +Corollary setoid_fun_choice_imp_functional_rel_reification : + SetoidFunctionalChoice -> FunctionalRelReification. +Proof. + intro SetoidFunChoice. + intros A B; apply fun_choice_imp_functional_rel_reification. + now apply setoid_fun_choice_imp_fun_choice. +Qed. + +Theorem setoid_fun_choice_imp_repr_fun_choice : + SetoidFunctionalChoice -> RepresentativeFunctionalChoice. +Proof. + intros SetoidFunChoice A R Hequiv. + apply SetoidFunChoice; firstorder. +Qed. + +Theorem functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice : + FunctionalRelReification -> RepresentativeFunctionalChoice -> SetoidFunctionalChoice. +Proof. + intros FunRelReify ReprFunChoice A B R T Hequiv Hcompat Hexists. + assert (FunChoice : FunctionalChoice). + { intros A' B'. apply functional_rel_reification_and_rel_choice_imp_fun_choice. + - apply FunRelReify. + - now apply repr_fun_choice_imp_relational_choice. } + destruct (FunChoice _ _ T Hexists) as (f,Hf). + destruct (ReprFunChoice A R Hequiv) as (g,Hg). + exists (fun a => f (g a)). + intro x. destruct (Hg x) as (Hgx,HRuniq). + split. + - eapply Hcompat. symmetry. apply Hgx. apply Hf. + - intros y Hxy. f_equal. auto. +Qed. + +Theorem functional_rel_reification_and_repr_fun_choice_iff_setoid_fun_choice : + FunctionalRelReification /\ RepresentativeFunctionalChoice <-> SetoidFunctionalChoice. +Proof. + split; intros. + - now apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. + - split. + + now apply setoid_fun_choice_imp_functional_rel_reification. + + now apply setoid_fun_choice_imp_repr_fun_choice. +Qed. + +(** Note: What characterization to give of +RepresentativeFunctionalChoice? A formulation of it as a functional +relation would certainly be equivalent to the formulation of +SetoidFunctionalChoice as a functional relation, but in their +functional forms, SetoidFunctionalChoice seems strictly stronger *) + +(**********************************************************************) +(** * AC_fun_setoid = AC_fun + Ext_fun_repr + EM *) + +Import EqNotations. + +(** ** This is the main theorem in [[Carlström04]] *) + +(** Note: all ingredients have a computational meaning when taken in + separation. However, to compute with the functional choice, + existential quantification has to be thought as a strong + existential, which is incompatible with the computational content of + excluded-middle *) + +Theorem fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice : + FunctionalChoice -> ExtensionalFunctionRepresentative -> ExcludedMiddle -> RepresentativeFunctionalChoice. +Proof. + intros FunChoice SetoidFunRepr EM A R (Hrefl,Hsym,Htrans). + assert (H:forall P:Prop, exists b, b = true <-> P). + { intros P. destruct (EM P). + - exists true; firstorder. + - exists false; easy. } + destruct (FunChoice _ _ _ H) as (c,Hc). + pose (class_of a y := c (R a y)). + pose (isclass f := exists x:A, f x = true). + pose (class := {f:A -> bool | isclass f}). + pose (contains (c:class) (a:A) := proj1_sig c a = true). + destruct (FunChoice class A contains) as (f,Hf). + - intros f. destruct (proj2_sig f) as (x,Hx). + exists x. easy. + - destruct (SetoidFunRepr A bool) as (h,Hh). + assert (Hisclass:forall a, isclass (h (class_of a))). + { intro a. exists a. destruct (Hh (class_of a)) as (Ha,Huniqa). + rewrite <- Ha. apply Hc. apply Hrefl. } + pose (f':= fun a => exist _ (h (class_of a)) (Hisclass a) : class). + exists (fun a => f (f' a)). + intros x. destruct (Hh (class_of x)) as (Hx,Huniqx). split. + + specialize Hf with (f' x). unfold contains in Hf. simpl in Hf. rewrite <- Hx in Hf. apply Hc. assumption. + + intros y Hxy. + f_equal. + assert (Heq1: h (class_of x) = h (class_of y)). + { apply Huniqx. intro z. unfold class_of. + destruct (c (R x z)) eqn:Hxz. + - symmetry. apply Hc. apply -> Hc in Hxz. firstorder. + - destruct (c (R y z)) eqn:Hyz. + + apply -> Hc in Hyz. rewrite <- Hxz. apply Hc. firstorder. + + easy. } + assert (Heq2:rew Heq1 in Hisclass x = Hisclass y). + { apply proof_irrelevance_cci, EM. } + unfold f'. + rewrite <- Heq2. + rewrite <- Heq1. + reflexivity. +Qed. + +Theorem setoid_functional_choice_first_characterization : + FunctionalChoice /\ ExtensionalFunctionRepresentative /\ ExcludedMiddle <-> SetoidFunctionalChoice. +Proof. + split. + - intros (FunChoice & SetoidFunRepr & EM). + apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. + + intros A B. apply fun_choice_imp_functional_rel_reification, FunChoice. + + now apply fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice. + - intro SetoidFunChoice. repeat split. + + now apply setoid_fun_choice_imp_fun_choice. + + apply repr_fun_choice_imp_ext_function_repr. + now apply setoid_fun_choice_imp_repr_fun_choice. + + apply repr_fun_choice_imp_excluded_middle. + now apply setoid_fun_choice_imp_repr_fun_choice. +Qed. + +(**********************************************************************) +(** ** AC_fun_setoid = AC_fun + Ext_pred_repr + PI *) + +(** Note: all ingredients have a computational meaning when taken in + separation. However, to compute with the functional choice, + existential quantification has to be thought as a strong + existential, which is incompatible with proof-irrelevance which + requires existential quantification to be truncated *) + +Theorem fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice : + FunctionalChoice -> ExtensionalPredicateRepresentative -> ProofIrrelevance -> RepresentativeFunctionalChoice. +Proof. + intros FunChoice PredExtRepr PI A R (Hrefl,Hsym,Htrans). + pose (isclass P := exists x:A, P x). + pose (class := {P:A -> Prop | isclass P}). + pose (contains (c:class) (a:A) := proj1_sig c a). + pose (class_of a := R a). + destruct (FunChoice class A contains) as (f,Hf). + - intros c. apply proj2_sig. + - destruct (PredExtRepr A) as (h,Hh). + assert (Hisclass:forall a, isclass (h (class_of a))). + { intro a. exists a. destruct (Hh (class_of a)) as (Ha,Huniqa). + rewrite <- Ha; apply Hrefl. } + pose (f':= fun a => exist _ (h (class_of a)) (Hisclass a) : class). + exists (fun a => f (f' a)). + intros x. destruct (Hh (class_of x)) as (Hx,Huniqx). split. + + specialize Hf with (f' x). simpl in Hf. rewrite <- Hx in Hf. assumption. + + intros y Hxy. + f_equal. + assert (Heq1: h (class_of x) = h (class_of y)). + { apply Huniqx. intro z. unfold class_of. firstorder. } + assert (Heq2:rew Heq1 in Hisclass x = Hisclass y). + { apply PI. } + unfold f'. + rewrite <- Heq2. + rewrite <- Heq1. + reflexivity. +Qed. + +Theorem setoid_functional_choice_second_characterization : + FunctionalChoice /\ ExtensionalPredicateRepresentative /\ ProofIrrelevance <-> SetoidFunctionalChoice. +Proof. + split. + - intros (FunChoice & ExtPredRepr & PI). + apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. + + intros A B. now apply fun_choice_imp_functional_rel_reification. + + now apply fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice. + - intro SetoidFunChoice. repeat split. + + now apply setoid_fun_choice_imp_fun_choice. + + apply repr_fun_choice_imp_ext_pred_repr. + now apply setoid_fun_choice_imp_repr_fun_choice. + + red. apply proof_irrelevance_cci. + apply repr_fun_choice_imp_excluded_middle. + now apply setoid_fun_choice_imp_repr_fun_choice. +Qed. -- cgit v1.2.3 From 9c21392c7957a0a1a66e5269022d5991649a38b5 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 2 Oct 2016 22:02:52 +0200 Subject: Adding a file providing extensional choice (i.e. choice over setoids). Also integrating suggestions from Théo. --- doc/stdlib/index-list.html.template | 2 + theories/Logic/ExtensionalFunctionRepresentative.v | 24 +++++++++ theories/Logic/SetoidChoice.v | 60 ++++++++++++++++++++++ theories/Logic/vo.itarget | 4 +- 4 files changed, 89 insertions(+), 1 deletion(-) create mode 100644 theories/Logic/ExtensionalFunctionRepresentative.v create mode 100644 theories/Logic/SetoidChoice.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 4a685a3b85..4ffdbb1152 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -46,6 +46,7 @@ through the Require Import command.

theories/Logic/ClassicalDescription.v theories/Logic/ClassicalEpsilon.v theories/Logic/ClassicalUniqueChoice.v + theories/Logic/SetoidChoice.v theories/Logic/Berardi.v theories/Logic/Diaconescu.v theories/Logic/Hurkens.v @@ -57,6 +58,7 @@ through the Require Import command.

theories/Logic/IndefiniteDescription.v theories/Logic/PropExtensionalityFacts.v theories/Logic/FunctionalExtensionality.v + theories/Logic/ExtensionalFunctionRepresentative.v theories/Logic/ExtensionalityFacts.v theories/Logic/WeakFan.v theories/Logic/WKL.v diff --git a/theories/Logic/ExtensionalFunctionRepresentative.v b/theories/Logic/ExtensionalFunctionRepresentative.v new file mode 100644 index 0000000000..a9da68e165 --- /dev/null +++ b/theories/Logic/ExtensionalFunctionRepresentative.v @@ -0,0 +1,24 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* B), + (forall x, f x = repr f x) /\ + (forall g, (forall x, f x = g x) -> repr f = repr g). diff --git a/theories/Logic/SetoidChoice.v b/theories/Logic/SetoidChoice.v new file mode 100644 index 0000000000..84432dda1b --- /dev/null +++ b/theories/Logic/SetoidChoice.v @@ -0,0 +1,60 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + (forall x x' y, R x x' -> T x y -> T x' y) -> + (forall x, exists y, T x y) -> + exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). +Proof. + apply setoid_functional_choice_first_characterization. split; [|split]. + - exact choice. + - exact extensional_function_representative. + - exact classic. +Qed. + +Theorem representative_choice : + forall A (R:A->A->Prop), (Equivalence R) -> + exists f : A->A, forall x : A, R x (f x) /\ forall x', R x x' -> f x = f x'. +Proof. + apply setoid_fun_choice_imp_repr_fun_choice. + exact setoid_choice. +Qed. diff --git a/theories/Logic/vo.itarget b/theories/Logic/vo.itarget index 323597395f..71d01c1fb1 100644 --- a/theories/Logic/vo.itarget +++ b/theories/Logic/vo.itarget @@ -20,6 +20,7 @@ WeakFan.vo WKL.vo FunctionalExtensionality.vo ExtensionalityFacts.vo +ExtensionalFunctionRepresentative.vo Hurkens.vo IndefiniteDescription.vo JMeq.vo @@ -27,4 +28,5 @@ ProofIrrelevanceFacts.vo ProofIrrelevance.vo RelationalChoice.vo SetIsType.vo -FinFun.vo \ No newline at end of file +SetoidChoice.vo +FinFun.vo -- cgit v1.2.3 From 4e85cc6e9792da116f1b20e484b2ce629c6f6865 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 2 Oct 2016 20:27:59 +0200 Subject: Adding explicitly a file to work in the context of propositional extensionality. --- doc/stdlib/index-list.html.template | 1 + theories/Logic/PropExtensionality.v | 22 ++++++++++++++++++++++ theories/Logic/vo.itarget | 1 + 3 files changed, 24 insertions(+) create mode 100644 theories/Logic/PropExtensionality.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 4ffdbb1152..aeb0de48a3 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -56,6 +56,7 @@ through the Require Import command.

theories/Logic/Description.v theories/Logic/Epsilon.v theories/Logic/IndefiniteDescription.v + theories/Logic/PropExtensionality.v theories/Logic/PropExtensionalityFacts.v theories/Logic/FunctionalExtensionality.v theories/Logic/ExtensionalFunctionRepresentative.v diff --git a/theories/Logic/PropExtensionality.v b/theories/Logic/PropExtensionality.v new file mode 100644 index 0000000000..796c602734 --- /dev/null +++ b/theories/Logic/PropExtensionality.v @@ -0,0 +1,22 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Q) -> P = Q. + +Require Import ClassicalFacts. + +Theorem proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2. +Proof. + apply ext_prop_dep_proof_irrel_cic. + exact propositional_extensionality. +Qed. + diff --git a/theories/Logic/vo.itarget b/theories/Logic/vo.itarget index 71d01c1fb1..ef2709b472 100644 --- a/theories/Logic/vo.itarget +++ b/theories/Logic/vo.itarget @@ -26,6 +26,7 @@ IndefiniteDescription.vo JMeq.vo ProofIrrelevanceFacts.vo ProofIrrelevance.vo +PropExtensionality.vo RelationalChoice.vo SetIsType.vo SetoidChoice.vo -- cgit v1.2.3 From 620f1918452b898d6663cabb5e0f341c7e767017 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 12 Oct 2016 18:58:41 +0200 Subject: Strengthening some of the results in ChoiceFacts.v. Further highlighting when the correspondence between variants of choice is independent of the domain and codomain of the function, as was done already done in the beginning of the file (suggestion from Jason). Adding some corollaries. --- theories/Logic/ChoiceFacts.v | 76 ++++++++++++++++++++++++++------------------ 1 file changed, 45 insertions(+), 31 deletions(-) diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 3f17ba5a95..07e8b6ef8d 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -25,11 +25,13 @@ description principles the context of constructive type theory, sometimes called axiom of no choice) -- AC_fun_repr = functional choice of a representative in an equivalence class -- AC_fun_setoid_gen = functional form of the general form of the (so-called - extensional) axiom of choice over setoids -- AC_fun_setoid = functional form of the (so-called extensional) axiom of - choice from setoids +- AC_fun_repr = functional choice of a representative in an equivalence class +- AC_fun_setoid_gen = functional form of the general form of the (so-called + extensional) axiom of choice over setoids +- AC_fun_setoid = functional form of the (so-called extensional) axiom of + choice from setoids +- AC_fun_setoid_simple = functional form of the (so-called extensional) axiom of + choice from setoids on locally compatible relations - GAC_rel = guarded relational form of the (non extensional) axiom of choice - GAC_fun = guarded functional form of the (non extensional) axiom of choice @@ -183,9 +185,9 @@ Require Import RelationClasses Logic. Definition RepresentativeFunctionalChoice_on := forall R:A->A->Prop, (Equivalence R) -> - (exists f : A->A, forall x : A, (R x (f x)) /\ forall y, R x y -> f x = f y). + (exists f : A->A, forall x : A, (R x (f x)) /\ forall x', R x x' -> f x = f x'). -(** AC_fun_ext *) +(** AC_fun_setoid *) Definition SetoidFunctionalChoice_on := forall R : A -> A -> Prop, @@ -193,9 +195,9 @@ Definition SetoidFunctionalChoice_on := Equivalence R -> (forall x x' y, R x x' -> T x y -> T x' y) -> (forall x, exists y, T x y) -> - exists f : A -> B, forall x : A, T x (f x) /\ (forall y : A, R x y -> f x = f y). + exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). -(** AC_fun_ext_gen *) +(** AC_fun_setoid_gen *) (* Note: This is called extensional axiom of choice (AC_ext) in [[Carlström04]]. *) @@ -209,9 +211,9 @@ Definition GeneralizedSetoidFunctionalChoice_on := (forall x x' y y', R x x' -> S y y' -> T x y -> T x' y') -> (forall x, exists y, T x y) -> exists f : A -> B, - forall x : A, T x (f x) /\ (forall y : A, R x y -> S (f x) (f y)). + forall x : A, T x (f x) /\ (forall x' : A, R x x' -> S (f x) (f x')). -(** AC_fun_ext_simple *) +(** AC_fun_setoid_simple *) Definition SimpleSetoidFunctionalChoice_on A B := forall R : A -> A -> Prop, @@ -1066,50 +1068,62 @@ Proof. Qed. (**********************************************************************) -(** ** AC_fun_setoid = AC_fun_setoid_gen *) +(** ** AC_fun_setoid = AC_fun_setoid_gen = AC_fun_setoid_simple *) Theorem gen_setoid_fun_choice_imp_setoid_fun_choice : - GeneralizedSetoidFunctionalChoice -> SetoidFunctionalChoice. + forall A B, GeneralizedSetoidFunctionalChoice_on A B -> SetoidFunctionalChoice_on A B. Proof. - intros GenSetoidFunChoice A B R T Hequiv Hcompat Hex. + intros A B GenSetoidFunChoice R T Hequiv Hcompat Hex. apply GenSetoidFunChoice; try easy. apply eq_equivalence. intros * H <-. firstorder. Qed. Theorem setoid_fun_choice_imp_gen_setoid_fun_choice : - SetoidFunctionalChoice -> GeneralizedSetoidFunctionalChoice. + forall A B, SetoidFunctionalChoice_on A B -> GeneralizedSetoidFunctionalChoice_on A B. Proof. - intros SetoidFunChoice A B R S T HequivR HequivS Hcompat Hex. + intros A B SetoidFunChoice R S T HequivR HequivS Hcompat Hex. destruct SetoidFunChoice with (R:=R) (T:=T) as (f,Hf); try easy. { intros; apply (Hcompat x x' y y); try easy. } exists f. intros x; specialize Hf with x as (Hf,Huniq). intuition. now erewrite Huniq. Qed. +Corollary setoid_fun_choice_iff_gen_setoid_fun_choice : + forall A B, SetoidFunctionalChoice_on A B <-> GeneralizedSetoidFunctionalChoice_on A B. +Proof. + split; auto using gen_setoid_fun_choice_imp_setoid_fun_choice, setoid_fun_choice_imp_gen_setoid_fun_choice. +Qed. + Theorem setoid_fun_choice_imp_simple_setoid_fun_choice : - SetoidFunctionalChoice -> SimpleSetoidFunctionalChoice. + forall A B, SetoidFunctionalChoice_on A B -> SimpleSetoidFunctionalChoice_on A B. Proof. - intros SetoidFunChoice A B R T Hequiv Hexists. + intros A B SetoidFunChoice R T Hequiv Hexists. pose (T' x y := forall x', R x x' -> T x' y). assert (Hcompat : forall (x x' : A) (y : B), R x x' -> T' x y -> T' x' y) by firstorder. - destruct (SetoidFunChoice A B R T' Hequiv Hcompat Hexists) as (f,Hf). + destruct (SetoidFunChoice R T' Hequiv Hcompat Hexists) as (f,Hf). exists f. firstorder. Qed. Theorem simple_setoid_fun_choice_imp_setoid_fun_choice : - SimpleSetoidFunctionalChoice -> SetoidFunctionalChoice. + forall A B, SimpleSetoidFunctionalChoice_on A B -> SetoidFunctionalChoice_on A B. +Proof. + intros A B SimpleSetoidFunChoice R T Hequiv Hcompat Hexists. + destruct (SimpleSetoidFunChoice R T Hequiv) as (f,Hf); firstorder. +Qed. + +Corollary setoid_fun_choice_iff_simple_setoid_fun_choice : + forall A B, SetoidFunctionalChoice_on A B <-> SimpleSetoidFunctionalChoice_on A B. Proof. - intros SimpleSetoidFunChoice A B R T Hequiv Hcompat Hexists. - destruct (SimpleSetoidFunChoice A B R T Hequiv) as (f,Hf); firstorder. + split; auto using simple_setoid_fun_choice_imp_setoid_fun_choice, setoid_fun_choice_imp_simple_setoid_fun_choice. Qed. (**********************************************************************) (** ** AC_fun_setoid = AC! + AC_fun_repr *) Theorem setoid_fun_choice_imp_fun_choice : - SetoidFunctionalChoice -> FunctionalChoice. + forall A B, SetoidFunctionalChoice_on A B -> FunctionalChoice_on A B. Proof. - intros SetoidFunChoice A B T Hexists. + intros A B SetoidFunChoice T Hexists. destruct SetoidFunChoice with (R:=@eq A) (T:=T) as (f,Hf). - apply eq_equivalence. - now intros * ->. @@ -1118,15 +1132,15 @@ Proof. Qed. Corollary setoid_fun_choice_imp_functional_rel_reification : - SetoidFunctionalChoice -> FunctionalRelReification. + forall A B, SetoidFunctionalChoice_on A B -> FunctionalRelReification_on A B. Proof. - intro SetoidFunChoice. - intros A B; apply fun_choice_imp_functional_rel_reification. + intros A B SetoidFunChoice. + apply fun_choice_imp_functional_rel_reification. now apply setoid_fun_choice_imp_fun_choice. Qed. Theorem setoid_fun_choice_imp_repr_fun_choice : - SetoidFunctionalChoice -> RepresentativeFunctionalChoice. + SetoidFunctionalChoice -> RepresentativeFunctionalChoice . Proof. intros SetoidFunChoice A R Hequiv. apply SetoidFunChoice; firstorder. @@ -1155,7 +1169,7 @@ Proof. split; intros. - now apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. - split. - + now apply setoid_fun_choice_imp_functional_rel_reification. + + now intros A B; apply setoid_fun_choice_imp_functional_rel_reification. + now apply setoid_fun_choice_imp_repr_fun_choice. Qed. @@ -1228,7 +1242,7 @@ Proof. + intros A B. apply fun_choice_imp_functional_rel_reification, FunChoice. + now apply fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice. - intro SetoidFunChoice. repeat split. - + now apply setoid_fun_choice_imp_fun_choice. + + now intros A B; apply setoid_fun_choice_imp_fun_choice. + apply repr_fun_choice_imp_ext_function_repr. now apply setoid_fun_choice_imp_repr_fun_choice. + apply repr_fun_choice_imp_excluded_middle. @@ -1283,7 +1297,7 @@ Proof. + intros A B. now apply fun_choice_imp_functional_rel_reification. + now apply fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice. - intro SetoidFunChoice. repeat split. - + now apply setoid_fun_choice_imp_fun_choice. + + now intros A B; apply setoid_fun_choice_imp_fun_choice. + apply repr_fun_choice_imp_ext_pred_repr. now apply setoid_fun_choice_imp_repr_fun_choice. + red. apply proof_irrelevance_cci. -- cgit v1.2.3 From 9133d6faece4feb675fdc9c66cebcb2bba9246a9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 3 Mar 2017 14:43:00 +0100 Subject: CHANGES: choice over setoids and prop. ext. --- CHANGES | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/CHANGES b/CHANGES index 4a7cb8c45e..a7cba9aa4f 100644 --- a/CHANGES +++ b/CHANGES @@ -7,6 +7,15 @@ Tactics functional extensionality in H supposed to be a quantified equality until giving a bare equality. +Libraries + +- New file PropExtensionality.v to explicitly work in the axiomatic + context of propositional extensionality. +- New file SetoidChoice.v axiomatically providing choice over setoids, + and, consequently, choice of representatives in equivalence classes. + Various proof-theoretic characterizations of choice over setoids in + file ChoiceFacts.v. + Changes from V8.6beta1 to V8.6 ============================== -- cgit v1.2.3 From 02371a70f708d542907f72a7a8b61165b7e941a7 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Tue, 7 Mar 2017 15:31:51 +0100 Subject: Fixing Bug 5383 (Hyps Limit) + small refactoring. --- printing/printer.ml | 71 +++++++++++++++++++++++++++++------------------------ 1 file changed, 39 insertions(+), 32 deletions(-) diff --git a/printing/printer.ml b/printing/printer.ml index bfc2e1bc93..00c2b636b0 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -296,6 +296,9 @@ let pr_named_context_of env sigma = let psl = List.rev (fold_named_context make_decl_list env ~init:[]) in hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl) +let pr_var_list_decl env sigma decl = + hov 0 (pr_compacted_decl env sigma decl) + let pr_named_context env sigma ne_context = hv 0 (Context.Named.fold_outside (fun d pps -> pps ++ ws 2 ++ pr_named_decl env sigma d) @@ -329,39 +332,43 @@ let pr_ne_context_of header env sigma = List.is_empty (Environ.named_context env) then (mt ()) else let penv = pr_context_unlimited env sigma in (header ++ penv ++ fnl ()) -let pr_context_limit n env sigma = - let named_context = Environ.named_context env in - let lgsign = List.length named_context in - if n >= lgsign then - pr_context_unlimited env sigma - else - let k = lgsign-n in - let _,sign_env = - Context.Compacted.fold - (fun d (i,pps) -> - if i < k then - (i+1, (pps ++str ".")) - else - let pidt = pr_compacted_decl env sigma d in - (i+1, (pps ++ fnl () ++ - str (emacs_str "") ++ - pidt))) - (Termops.compact_named_context (Environ.named_context env)) ~init:(0,(mt ())) - in - let db_env = - fold_rel_context - (fun env d pps -> - let pnat = pr_rel_decl env sigma d in - (pps ++ fnl () ++ - str (emacs_str "") ++ - pnat)) - env ~init:(mt ()) - in - (sign_env ++ db_env) +let rec bld_sign_env env sigma ctxt pps = + match ctxt with + | [] -> pps + | d:: ctxt' -> + let pidt = pr_var_list_decl env sigma d in + let pps' = pps ++ brk (0,0) ++ pidt in + bld_sign_env env sigma ctxt' pps' + + +let pr_context_limit_compact ?n env sigma = + let ctxt = Termops.compact_named_context (named_context env) in + let lgth = List.length ctxt in + let n_capped = + match n with + | None -> lgth + | Some n when n > lgth -> lgth + | Some n -> n in + let ctxt_chopped,ctxt_hidden = Util.List.chop n_capped ctxt in + (* a dot line hinting the number of hiden hyps. *) + let hidden_dots = String.make (List.length ctxt_hidden) '.' in + let sign_env = v 0 (str hidden_dots ++ (mt ()) + ++ bld_sign_env env sigma (List.rev ctxt_chopped) (mt ())) in + let db_env = + fold_rel_context + (fun env d pps -> pps ++ fnl () ++ pr_rel_decl env sigma d) + env ~init:(mt ()) in + (sign_env ++ db_env) + +(* compact printing an env (variables and de Bruijn). Separator: three + spaces between simple hyps, and newline otherwise *) +let pr_context_unlimited_compact env sigma = + pr_context_limit_compact env sigma -let pr_context_of env sigma = match Flags.print_hyps_limit () with - | None -> hv 0 (pr_context_unlimited env sigma) - | Some n -> hv 0 (pr_context_limit n env sigma) +let pr_context_of env sigma = + match Flags.print_hyps_limit () with + | None -> hv 0 (pr_context_limit_compact env sigma) + | Some n -> hv 0 (pr_context_limit_compact ~n env sigma) (* display goal parts (Proof mode) *) -- cgit v1.2.3 From 5a88be6c0ee5e148f6daec722bfccfd2168ba5d1 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 9 Mar 2017 11:58:42 +0100 Subject: Fixing dependency order of plugins. This allows to support static linking of plugins (application to debugging or to when option -natdynlink is "no"). --- Makefile.common | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile.common b/Makefile.common index df705034e7..1e71bcf7d9 100644 --- a/Makefile.common +++ b/Makefile.common @@ -122,12 +122,12 @@ DERIVECMO:=plugins/derive/derive_plugin.cmo LTACCMO:=plugins/ltac/ltac_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo -PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ +PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ $(QUOTECMO) $(RINGCMO) \ $(FOURIERCMO) $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(NATSYNTAXCMO) $(OTHERSYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) $(LTACCMO) + $(DERIVECMO) $(SSRMATCHINGCMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) -- cgit v1.2.3 From b5e6c189f378815c2cfc350924d225d7bd1287d4 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 9 Mar 2017 12:38:02 +0100 Subject: Micromega: removing a constant preventing micromega to be loaded before Logic.v. The constant was useless after 9f56baf which fixed #5073. --- plugins/micromega/coq_micromega.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index e4b58a56f9..97f29df823 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -383,7 +383,6 @@ struct let coq_and = lazy (init_constant "and") let coq_or = lazy (init_constant "or") let coq_not = lazy (init_constant "not") - let coq_not_gl_ref = (Nametab.locate ( Libnames.qualid_of_string "Coq.Init.Logic.not")) let coq_iff = lazy (init_constant "iff") let coq_True = lazy (init_constant "True") -- cgit v1.2.3 From ae5ae4967c423a26b99666dcce441236dd7b9a7b Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 6 Mar 2017 16:33:47 +0100 Subject: [travis] Move GeoCoq to allow fail. We need to agree a bit more with upstream. --- .travis.yml | 4 ++-- dev/ci/ci-geocoq.sh | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 5ed0809a52..678b4af7f4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -27,7 +27,6 @@ env: - TEST_TARGET="ci-color" - TEST_TARGET="ci-compcert" - TEST_TARGET="ci-coquelicot" - - TEST_TARGET="ci-cpdt" - TEST_TARGET="ci-geocoq" - TEST_TARGET="ci-fiat-crypto" - TEST_TARGET="ci-fiat-parsers" @@ -39,13 +38,14 @@ env: - TEST_TARGET="ci-sf" - TEST_TARGET="ci-unimath" # Not ready yet for 8.7 + # - TEST_TARGET="ci-cpdt" # - TEST_TARGET="ci-metacoq" # - TEST_TARGET="ci-tlc" matrix: allow_failures: - - env: TEST_TARGET="ci-cpdt" + - env: TEST_TARGET="ci-geocoq" # Full Coq test-suite with two compilers # [TODO: use yaml refs and avoid duplication for packages list] diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index ce870e52b5..29667b018a 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -12,5 +12,7 @@ git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} GeoCoq ( cd GeoCoq && \ ./configure.sh && \ sed -i.bak '/Ch16_coordinates_with_functions\.v/d' Make && \ + sed -i.bak '/Elements\/Book_1\.v/d' Make && \ + sed -i.bak '/Elements\/Book_3\.v/d' Make && \ coq_makefile -f Make -o Makefile && \ make -j ${NJOBS} ) -- cgit v1.2.3 From b7415c84269b1553470216b06871def933e2f3bd Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 9 Mar 2017 13:50:22 +0100 Subject: Clarifying doc about interpretation of scopes in notations (#5386). --- doc/refman/RefMan-syn.tex | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index 21c39de967..b7d36ecaa3 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -59,6 +59,12 @@ and pretty-printer of {\Coq} already know how to deal with the syntactic expression (see \ref{ReservedNotation}), explicit precedences and associativity rules have to be given. +\Rem The right-hand side of a notation is interpreted at the time the +notation is given. In particular, implicit arguments (see +Section~\ref{Implicit Arguments}), coercions (see +Section~\ref{Coercions}), etc. are resolved at the time of the +declaration of the notation. + \subsection[Precedences and associativity]{Precedences and associativity\index{Precedences} \index{Associativity}} @@ -908,6 +914,28 @@ interpretation. See the next section. \SeeAlso The command to show the scopes bound to the arguments of a function is described in Section~\ref{About}. +\Rem In notations, the subterms matching the identifiers of the +notations are interpreted in the scope in which the identifiers +occurred at the time of the declaration of the notation. Here is an +example: + +\begin{coq_example} +Parameter g : bool -> bool. +Notation "@@" := true (only parsing) : bool_scope. +Notation "@@" := false (only parsing): mybool_scope. + +(* Defining a notation while the argument of g is bound to bool_scope *) +Bind Scope bool_scope with bool. +Notation "# x #" := (g x) (at level 40). +Check # @@ #. +(* Rebinding the argument of g to mybool_scope has no effect on the notation *) +Arguments g _%mybool_scope. +Check # @@ #. +(* But we can force the scope *) +Delimit Scope mybool_scope with mybool. +Check # @@%mybool #. +\end{coq_example} + \subsection[The {\tt type\_scope} interpretation scope]{The {\tt type\_scope} interpretation scope\index{type\_scope@\texttt{type\_scope}}} The scope {\tt type\_scope} has a special status. It is a primitive -- cgit v1.2.3 From cae09e5af6cf31d96662b1b66a63c6a236a8e741 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 9 Mar 2017 15:36:42 +0100 Subject: Typo doc notations. --- doc/refman/RefMan-syn.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index b7d36ecaa3..61093709ec 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -303,7 +303,7 @@ the possible following elements delimited by single quotes: of each newline \end{itemize} -Thus, for the previous example, we get +%Thus, for the previous example, we get %\footnote{The ``@'' is here to shunt %the notation "'IF' A 'then' B 'else' C" which is defined in {\Coq} %initial state}: -- cgit v1.2.3 From d30d5a9b32e020586d265f8e879c287269c17575 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 6 Mar 2017 16:33:47 +0100 Subject: [travis] Move GeoCoq to allow fail. We need to agree a bit more with upstream. --- .travis.yml | 4 ++-- dev/ci/ci-geocoq.sh | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index de16f2d0b4..f609852bc3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -27,7 +27,6 @@ env: - TEST_TARGET="ci-color" - TEST_TARGET="ci-compcert" - TEST_TARGET="ci-coquelicot" - - TEST_TARGET="ci-cpdt" - TEST_TARGET="ci-geocoq" - TEST_TARGET="ci-fiat-crypto" - TEST_TARGET="ci-flocq" @@ -38,13 +37,14 @@ env: - TEST_TARGET="ci-sf" - TEST_TARGET="ci-unimath" # Not ready yet for 8.7 + # - TEST_TARGET="ci-cpdt" # - TEST_TARGET="ci-metacoq" # - TEST_TARGET="ci-tlc" matrix: allow_failures: - - env: TEST_TARGET="ci-cpdt" + - env: TEST_TARGET="ci-geocoq" # Full Coq test-suite with two compilers # [TODO: use yaml refs and avoid duplication for packages list] diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index ce870e52b5..29667b018a 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -12,5 +12,7 @@ git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} GeoCoq ( cd GeoCoq && \ ./configure.sh && \ sed -i.bak '/Ch16_coordinates_with_functions\.v/d' Make && \ + sed -i.bak '/Elements\/Book_1\.v/d' Make && \ + sed -i.bak '/Elements\/Book_3\.v/d' Make && \ coq_makefile -f Make -o Makefile && \ make -j ${NJOBS} ) -- cgit v1.2.3 From 7812c5f39dd166559847c1ece573b02653e62100 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 9 Mar 2017 01:08:42 +0100 Subject: [META] Update version number. --- META.coq | 59 ++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 34 insertions(+), 25 deletions(-) diff --git a/META.coq b/META.coq index d83dab23d1..dea9fb458f 100644 --- a/META.coq +++ b/META.coq @@ -1,5 +1,15 @@ +# TODO: Move to META.in once coq_makefile2 is merged. +# We need to reuse: +# - The variable substitution mechanism. +# - Sourcing of "coq_install_path" and "coq_version" variables. +# +# With this rules, we would have: +# version = ${coq_version} +# and +# linkopts(byte) = "-dllpath ${coq_install_path}/kernel/byterun/ -dllib -lcoqrun" + description = "The Coq Proof Assistant Plugin API" -version = "8.6" +version = "8.7" directory = "" requires = "camlp5" @@ -7,7 +17,7 @@ requires = "camlp5" package "config" ( description = "Coq Configuration Variables" - version = "8.6" + version = "8.7" directory = "config" @@ -16,7 +26,7 @@ package "config" ( package "lib" ( description = "Base Coq Library" - version = "8.6" + version = "8.7" directory = "lib" @@ -34,13 +44,12 @@ package "vm" ( description = "Coq VM" - version = "8.6" + version = "8.7" -# EJGA FIXME: Unfortunately dllpath is dependent on the type of Coq -# install. In a local one we'll want kernel/byterun, in a non-local -# one we want to set it to coqlib. We should thus generate this file -# at configure time, but let's hear for some more feedback from -# experts. +# dllpath is dependent on the type of Coq install. In a local one +# we'll want kernel/byterun, in a non-local one we want to set it to +# coqlib. We should thus generate this file at configure time, but +# let's hear for some more feedback from experts. # Enable for local native & byte builds # directory = "kernel/byterun" @@ -57,7 +66,7 @@ package "vm" ( package "kernel" ( description = "Coq's Kernel" - version = "8.6" + version = "8.7" directory = "kernel" @@ -71,7 +80,7 @@ package "kernel" ( package "library" ( description = "Coq Libraries (vo) support" - version = "8.6" + version = "8.7" requires = "coq.kernel" @@ -85,7 +94,7 @@ package "library" ( package "intf" ( description = "Coq Public Data Types" - version = "8.6" + version = "8.7" requires = "coq.library" @@ -96,7 +105,7 @@ package "intf" ( package "engine" ( description = "Coq Tactic Engine" - version = "8.6" + version = "8.7" requires = "coq.library" directory = "engine" @@ -109,7 +118,7 @@ package "engine" ( package "pretyping" ( description = "Coq Pretyper" - version = "8.6" + version = "8.7" requires = "coq.engine" directory = "pretyping" @@ -122,7 +131,7 @@ package "pretyping" ( package "interp" ( description = "Coq Term Interpretation" - version = "8.6" + version = "8.7" requires = "coq.pretyping" directory = "interp" @@ -135,7 +144,7 @@ package "interp" ( package "grammar" ( description = "Coq Base Grammar" - version = "8.6" + version = "8.7" requires = "coq.interp" directory = "grammar" @@ -147,7 +156,7 @@ package "grammar" ( package "proofs" ( description = "Coq Proof Engine" - version = "8.6" + version = "8.7" requires = "coq.interp" directory = "proofs" @@ -160,7 +169,7 @@ package "proofs" ( package "parsing" ( description = "Coq Parsing Engine" - version = "8.6" + version = "8.7" requires = "coq.proofs" directory = "parsing" @@ -173,7 +182,7 @@ package "parsing" ( package "printing" ( description = "Coq Printing Engine" - version = "8.6" + version = "8.7" requires = "coq.parsing" directory = "printing" @@ -186,7 +195,7 @@ package "printing" ( package "tactics" ( description = "Coq Basic Tactics" - version = "8.6" + version = "8.7" requires = "coq.printing" directory = "tactics" @@ -199,7 +208,7 @@ package "tactics" ( package "vernac" ( description = "Coq Vernacular Interpreter" - version = "8.6" + version = "8.7" requires = "coq.tactics" directory = "vernac" @@ -212,7 +221,7 @@ package "vernac" ( package "stm" ( description = "Coq State Transactional Machine" - version = "8.6" + version = "8.7" requires = "coq.vernac" directory = "stm" @@ -225,7 +234,7 @@ package "stm" ( package "toplevel" ( description = "Coq Toplevel" - version = "8.6" + version = "8.7" requires = "coq.stm" directory = "toplevel" @@ -238,7 +247,7 @@ package "toplevel" ( package "highparsing" ( description = "Coq Extra Parsing" - version = "8.6" + version = "8.7" requires = "coq.toplevel" directory = "parsing" @@ -251,7 +260,7 @@ package "highparsing" ( package "ltac" ( description = "Coq LTAC Plugin" - version = "8.6" + version = "8.7" requires = "coq.highparsing" directory = "ltac" -- cgit v1.2.3 From ccb706774a8f9bf4f58f6899a58e6cc5117901a6 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 9 Mar 2017 01:09:00 +0100 Subject: [META] Ltac now a plugin. --- META.coq | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/META.coq b/META.coq index dea9fb458f..5084237e8e 100644 --- a/META.coq +++ b/META.coq @@ -263,9 +263,9 @@ package "ltac" ( version = "8.7" requires = "coq.highparsing" - directory = "ltac" + directory = "plugins/ltac" - archive(byte) = "ltac.cma" - archive(native) = "ltac.cmxa" + archive(byte) = "ltac_plugin.cmo" + archive(native) = "ltac_plugin.cmx" ) -- cgit v1.2.3 From d201ccad094feda44a4d232de936df57c33f22f2 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 9 Mar 2017 01:09:50 +0100 Subject: [META] [build] Install dlls to kernel/byterun This makes the dll path consistent both in `-local` and non-local Coq install. --- META.coq | 15 +++++---------- Makefile.install | 5 +++-- configure.ml | 2 +- 3 files changed, 9 insertions(+), 13 deletions(-) diff --git a/META.coq b/META.coq index 5084237e8e..83134d4a08 100644 --- a/META.coq +++ b/META.coq @@ -43,21 +43,16 @@ package "lib" ( package "vm" ( description = "Coq VM" - version = "8.7" -# dllpath is dependent on the type of Coq install. In a local one -# we'll want kernel/byterun, in a non-local one we want to set it to -# coqlib. We should thus generate this file at configure time, but -# let's hear for some more feedback from experts. + directory = "kernel/byterun" -# Enable for local native & byte builds -# directory = "kernel/byterun" +# We should generate this file at configure time for local byte builds +# to work properly. -# Enable for local byte builds and set up properly -# linkopts(byte) = "-dllpath /path/to/coq/kernel/byterun/ -dllib -lcoqrun" +# Enable this setting for local byte builds, disabling the one below. +# linkopts(byte) = "-dllpath path_to_coq/kernel/byterun/ -dllib -lcoqrun" -# Disable for local byte builds linkopts(byte) = "-dllib -lcoqrun" linkopts(native) = "-cclib -lcoqrun" diff --git a/Makefile.install b/Makefile.install index 4800ea0b96..bde0355519 100644 --- a/Makefile.install +++ b/Makefile.install @@ -104,11 +104,12 @@ install-library: $(MKDIR) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) $(MKDIR) $(FULLCOQLIB)/user-contrib + $(MKDIR) $(FULLCOQLIB)/kernel/byterun ifndef CUSTOM - $(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB) + $(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB)/kernel/byterun endif ifeq ($(BEST),opt) - $(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB) + $(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB)/kernel/byterun $(INSTALLSH) $(FULLCOQLIB) $(PLUGINSOPT) endif # csdpcert is not meant to be directly called by the user; we install diff --git a/configure.ml b/configure.ml index e711367510..82ce931d67 100644 --- a/configure.ml +++ b/configure.ml @@ -926,7 +926,7 @@ let config_runtime () = | _ -> let ld="CAML_LD_LIBRARY_PATH" in build_loadpath := sprintf "export %s:='%s/kernel/byterun':$(%s)" ld coqtop ld; - ["-dllib";"-lcoqrun";"-dllpath";libdir] + ["-dllib";"-lcoqrun";"-dllpath";libdir/"kernel/byterun"] let vmbyteflags = config_runtime () -- cgit v1.2.3 From 935946b1aed05fa2d285f0da8f457563f4641b9e Mon Sep 17 00:00:00 2001 From: Tej Chajed Date: Fri, 10 Mar 2017 12:13:38 -0500 Subject: [ci] Document that sudo: false is slower --- .travis.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.travis.yml b/.travis.yml index 678b4af7f4..7138d5c61e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,4 +1,7 @@ dist: trusty +# Travis builds are slower using sudo: false (the container-based +# infrastructure) as of March 2017; see +# https://github.com/coq/coq/pull/467 for some discussion. sudo: required # Until Ocaml becomes a language, we set a known one. language: c -- cgit v1.2.3 From 56dc3e331c6b4b2bfa5ac072db57db8250884ce3 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Tue, 7 Mar 2017 12:33:37 +0100 Subject: Improve build of travis target on local machine. - Move the git clones to a specific subfolder to avoid pollution. - Do not fail when git clone already exist (but make sure it is up-to-date). --- .gitignore | 1 + dev/ci/ci-common.sh | 15 ++++++++++++--- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/.gitignore b/.gitignore index 35cdf9b4e8..64c49b008c 100644 --- a/.gitignore +++ b/.gitignore @@ -43,6 +43,7 @@ TAGS .DS_Store .pc bin/ +_build_ci _build myocamlbuild_config.ml config/Makefile diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 412da626fd..cc34bc2957 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -12,6 +12,9 @@ ls `pwd`/bin mathcomp_CI_BRANCH=master mathcomp_CI_GITURL=https://github.com/math-comp/math-comp.git +# Where we clone and build external developments +CI_BUILD_DIR=`pwd`/_build_ci + # git_checkout branch git_checkout() { @@ -19,9 +22,15 @@ git_checkout() local _URL=${2} local _DEST=${3} - echo "Checking out ${_DEST}" - git clone --depth 1 -b ${_BRANCH} ${_URL} ${_DEST} - ( cd ${3} && echo "${_DEST}: `git log -1 --format='%s | %H | %cd | %aN'`" ) + mkdir -p ${CI_BUILD_DIR} + cd ${CI_BUILD_DIR} + + if [ ! -d ${_DEST} ] ; then + echo "Checking out ${_DEST}" + git clone --depth 1 -b ${_BRANCH} ${_URL} ${_DEST} + fi + ( cd ${_DEST} && git pull && + echo "${_DEST}: `git log -1 --format='%s | %H | %cd | %aN'`" ) } checkout_mathcomp() -- cgit v1.2.3 From ba36aab9ad9a3d210211e1d4527dd0f6f493ca05 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Tue, 7 Mar 2017 16:14:39 +0100 Subject: [travis] Change headband for wider compatibility. --- dev/ci/ci-color.sh | 2 +- dev/ci/ci-common.sh | 2 +- dev/ci/ci-compcert.sh | 2 +- dev/ci/ci-coquelicot.sh | 2 +- dev/ci/ci-cpdt.sh | 2 +- dev/ci/ci-fiat-crypto.sh | 2 +- dev/ci/ci-fiat-parsers.sh | 2 +- dev/ci/ci-flocq.sh | 2 +- dev/ci/ci-geocoq.sh | 2 +- dev/ci/ci-hott.sh | 2 +- dev/ci/ci-iris-coq.sh | 2 +- dev/ci/ci-math-classes.sh | 2 +- dev/ci/ci-math-comp.sh | 2 +- dev/ci/ci-metacoq.sh | 2 +- dev/ci/ci-sf.sh | 2 +- dev/ci/ci-tlc.sh | 2 +- dev/ci/ci-unimath.sh | 2 +- 17 files changed, 17 insertions(+), 17 deletions(-) diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh index 78ae7f02f9..36c7b9e965 100755 --- a/dev/ci/ci-color.sh +++ b/dev/ci/ci-color.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index cc34bc2957..94fd00c0d2 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash set -xe diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index ec09389f8e..3b897f679a 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh index 94bd5e468f..2052a1e5ff 100755 --- a/dev/ci/ci-coquelicot.sh +++ b/dev/ci/ci-coquelicot.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash # $0 is not the safest way, but... ci_dir="$(dirname "$0")" diff --git a/dev/ci/ci-cpdt.sh b/dev/ci/ci-cpdt.sh index 18d7561804..0e791ebbfd 100755 --- a/dev/ci/ci-cpdt.sh +++ b/dev/ci/ci-cpdt.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh index c669195ddd..683f9712d6 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat-crypto.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash # $0 is not the safest way, but... ci_dir="$(dirname "$0")" diff --git a/dev/ci/ci-fiat-parsers.sh b/dev/ci/ci-fiat-parsers.sh index 15d73078fd..5e52f44116 100755 --- a/dev/ci/ci-fiat-parsers.sh +++ b/dev/ci/ci-fiat-parsers.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash # $0 is not the safest way, but... ci_dir="$(dirname "$0")" diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh index 345924e40a..d398660444 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash # $0 is not the safest way, but... ci_dir="$(dirname "$0")" diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index 29667b018a..7502139c2b 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 0c07564c02..9d27be2e91 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh diff --git a/dev/ci/ci-iris-coq.sh b/dev/ci/ci-iris-coq.sh index c21af976f4..7044c3859d 100755 --- a/dev/ci/ci-iris-coq.sh +++ b/dev/ci/ci-iris-coq.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash # $0 is not the safest way, but... ci_dir="$(dirname "$0")" diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math-classes.sh index 4450dc0710..c5105a8486 100755 --- a/dev/ci/ci-math-classes.sh +++ b/dev/ci/ci-math-classes.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash # $0 is not the safest way, but... ci_dir="$(dirname "$0")" diff --git a/dev/ci/ci-math-comp.sh b/dev/ci/ci-math-comp.sh index 2eb150cb52..1b6c6fb847 100755 --- a/dev/ci/ci-math-comp.sh +++ b/dev/ci/ci-math-comp.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash # $0 is not the safest way, but... ci_dir="$(dirname "$0")" diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh index 91a33695b0..597a6ab7b3 100755 --- a/dev/ci/ci-metacoq.sh +++ b/dev/ci/ci-metacoq.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash # $0 is not the safest way, but... ci_dir="$(dirname "$0")" diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index 5e41211f1a..c451bf26a1 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh diff --git a/dev/ci/ci-tlc.sh b/dev/ci/ci-tlc.sh index b946324924..df86b3cadd 100755 --- a/dev/ci/ci-tlc.sh +++ b/dev/ci/ci-tlc.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh index 15e619acbb..5b7fc1c053 100755 --- a/dev/ci/ci-unimath.sh +++ b/dev/ci/ci-unimath.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -- cgit v1.2.3 From 710c1e1f49ce834acb9488704bcbbf13c4ebaf91 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Tue, 7 Mar 2017 23:30:29 +0100 Subject: [travis] Adding a template file and using it for all targets. --- dev/ci/ci-color.sh | 7 +++++-- dev/ci/ci-compcert.sh | 5 +++-- dev/ci/ci-coquelicot.sh | 10 ++++++---- dev/ci/ci-fiat-crypto.sh | 9 ++++++--- dev/ci/ci-fiat-parsers.sh | 6 +++--- dev/ci/ci-flocq.sh | 9 ++++++--- dev/ci/ci-geocoq.sh | 6 +++--- dev/ci/ci-hott.sh | 8 ++++++-- dev/ci/ci-iris-coq.sh | 19 ++++++++++++++----- dev/ci/ci-math-classes.sh | 22 +++++++++++++++++----- dev/ci/ci-math-comp.sh | 6 ++++-- dev/ci/ci-metacoq.sh | 20 ++++++++++++++------ dev/ci/ci-template.sh | 12 ++++++++++++ dev/ci/ci-tlc.sh | 8 ++++++-- dev/ci/ci-unimath.sh | 5 +++-- 15 files changed, 108 insertions(+), 44 deletions(-) create mode 100755 dev/ci/ci-template.sh diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh index 36c7b9e965..fbcf9be1d6 100755 --- a/dev/ci/ci-color.sh +++ b/dev/ci/ci-color.sh @@ -3,6 +3,9 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -svn checkout https://scm.gforge.inria.fr/anonscm/svn/color/trunk/color color +Color_CI_SVNURL=https://scm.gforge.inria.fr/anonscm/svn/color/trunk/color +Color_CI_DIR=${CI_BUILD_DIR}/color -( cd color && make -j ${NJOBS} ) +svn checkout ${Color_CI_SVNURL} ${Color_CI_DIR} + +( cd ${Color_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index 3b897f679a..111222ac7f 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -5,9 +5,10 @@ source ${ci_dir}/ci-common.sh CompCert_CI_BRANCH=master CompCert_CI_GITURL=https://github.com/AbsInt/CompCert.git +CompCert_CI_DIR=${CI_BUILD_DIR}/CompCert opam install -j ${NJOBS} -y menhir -git_checkout ${CompCert_CI_BRANCH} ${CompCert_CI_GITURL} CompCert +git_checkout ${CompCert_CI_BRANCH} ${CompCert_CI_GITURL} ${CompCert_CI_DIR} # Patch to avoid the upper version limit -( cd CompCert && sed -i.bak 's/8.6)/8.6|trunk)/' configure && ./configure x86_32-linux && make -j ${NJOBS} ) +( cd ${CompCert_CI_DIR} && sed -i.bak 's/8.6)/8.6|trunk)/' configure && ./configure x86_32-linux && make -j ${NJOBS} ) diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh index 2052a1e5ff..9dfdb87451 100755 --- a/dev/ci/ci-coquelicot.sh +++ b/dev/ci/ci-coquelicot.sh @@ -1,12 +1,14 @@ #!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh +Coquelicot_CI_BRANCH=master +Coquelicot_CI_GITURL=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git +Coquelicot_CI_DIR=${CI_BUILD_DIR}/coquelicot + install_ssreflect -# Setup coquelicot -git_checkout master https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git coquelicot +git_checkout ${Coquelicot_CI_BRANCH} ${Coquelicot_CI_GITURL} ${Coquelicot_CI_DIR} -( cd coquelicot && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) +( cd ${Coquelicot_CI_DIR} && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh index 683f9712d6..7fc0dae2c0 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat-crypto.sh @@ -1,9 +1,12 @@ #!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git_checkout master https://github.com/mit-plv/fiat-crypto.git fiat-crypto +fiat_crypto_CI_BRANCH=master +fiat_crypto_CI_GITURL=https://github.com/mit-plv/fiat-crypto.git +fiat_crypto_CI_DIR=${CI_BUILD_DIR}/fiat-crypto -( cd fiat-crypto && make -j ${NJOBS} ) +git_checkout ${fiat_crypto_CI_BRANCH} ${fiat_crypto_CI_GITURL} ${fiat_crypto_CI_DIR} + +( cd ${fiat_crypto_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-fiat-parsers.sh b/dev/ci/ci-fiat-parsers.sh index 5e52f44116..0b3312e878 100755 --- a/dev/ci/ci-fiat-parsers.sh +++ b/dev/ci/ci-fiat-parsers.sh @@ -1,12 +1,12 @@ #!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh fiat_parsers_CI_BRANCH=master fiat_parsers_CI_GITURL=https://github.com/mit-plv/fiat.git +fiat_parsers_CI_DIR=${CI_BUILD_DIR}/fiat -git_checkout ${fiat_parsers_CI_BRANCH} ${fiat_parsers_CI_GITURL} fiat +git_checkout ${fiat_parsers_CI_BRANCH} ${fiat_parsers_CI_GITURL} ${fiat_parsers_CI_DIR} -( cd fiat && make -j ${NJOBS} parsers ) +( cd ${fiat_parsers_CI_DIR} && make -j ${NJOBS} parsers ) diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh index d398660444..30eca7a3e9 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -1,9 +1,12 @@ #!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git_checkout master https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git flocq +Flocq_CI_BRANCH=master +Flocq_CI_GITURL=https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git +Flocq_CI_DIR=${CI_BUILD_DIR}/flocq -( cd flocq && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) +git_checkout ${Flocq_CI_BRANCH} ${Flocq_CI_GITURL} ${Flocq_CI_DIR} + +( cd ${Flocq_CI_DIR} && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index 7502139c2b..7b5950c887 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -3,13 +3,13 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -# XXX: replace by generic template GeoCoq_CI_BRANCH=master GeoCoq_CI_GITURL=https://github.com/GeoCoq/GeoCoq.git +GeoCoq_CI_DIR=${CI_BUILD_DIR}/GeoCoq -git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} GeoCoq +git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} ${GeoCoq_CI_DIR} -( cd GeoCoq && \ +( cd ${GeoCoq_CI_DIR} && \ ./configure.sh && \ sed -i.bak '/Ch16_coordinates_with_functions\.v/d' Make && \ sed -i.bak '/Elements\/Book_1\.v/d' Make && \ diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 9d27be2e91..62733c9452 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -3,6 +3,10 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git_checkout mz-8.7 https://github.com/ejgallego/HoTT.git HoTT +HoTT_CI_BRANCH=mz-8.7 +HoTT_CI_GITURL=https://github.com/ejgallego/HoTT.git +HoTT_CI_DIR=${CI_BUILD_DIR}/HoTT -( cd HoTT && ./autogen.sh && ./configure && make -j ${NJOBS} ) +git_checkout ${HoTT_CI_BRANCH} ${HoTT_CI_GITURL} ${HoTT_CI_DIR} + +( cd ${HoTT_CI_DIR} && ./autogen.sh && ./configure && make -j ${NJOBS} ) diff --git a/dev/ci/ci-iris-coq.sh b/dev/ci/ci-iris-coq.sh index 7044c3859d..10f2c2b4bd 100755 --- a/dev/ci/ci-iris-coq.sh +++ b/dev/ci/ci-iris-coq.sh @@ -1,17 +1,26 @@ #!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh +stdpp_CI_BRANCH=master +stdpp_CI_GITURL=https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git +stdpp_CI_DIR=${CI_BUILD_DIR}/coq-stdpp + +Iris_CI_BRANCH=master +Iris_CI_GITURL=https://gitlab.mpi-sws.org/FP/iris-coq.git +Iris_CI_DIR=${CI_BUILD_DIR}/iris-coq + install_ssreflect # Setup stdpp -git_checkout master https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git coq-stdpp -( cd coq-stdpp && make -j ${NJOBS} && make install ) +git_checkout ${stdpp_CI_BRANCH} ${stdpp_CI_GITURL} ${stdpp_CI_DIR} + +( cd ${stdpp_CI_DIR} && make -j ${NJOBS} && make install ) # Setup Iris -git_checkout master https://gitlab.mpi-sws.org/FP/iris-coq.git iris-coq -( cd iris-coq && make -j ${NJOBS} ) +git_checkout ${Iris_CI_BRANCH} ${Iris_CI_GITURL} ${Iris_CI_DIR} + +( cd ${Iris_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math-classes.sh index c5105a8486..e6a57404fe 100755 --- a/dev/ci/ci-math-classes.sh +++ b/dev/ci/ci-math-classes.sh @@ -1,12 +1,24 @@ #!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git_checkout v8.6 https://github.com/math-classes/math-classes.git math-classes -( cd math-classes && make -j ${NJOBS} && make install ) +math_classes_CI_BRANCH=v8.6 +math_classes_CI_GITURL=https://github.com/math-classes/math-classes.git +math_classes_CI_DIR=${CI_BUILD_DIR}/math-classes -git_checkout v8.6 https://github.com/c-corn/corn.git corn -( cd corn && make -j ${NJOBS} ) +Corn_CI_BRANCH=v8.6 +Corn_CI_GITURL=https://github.com/c-corn/corn.git +Corn_CI_DIR=${CI_BUILD_DIR}/corn +# Setup Math-Classes + +git_checkout ${math_classes_CI_BRANCH} ${math_classes_CI_GITURL} ${math_classes_CI_DIR} + +( cd ${math_classes_CI_DIR} && make -j ${NJOBS} && make install ) + +# Setup Corn + +git_checkout ${Corn_CI_BRANCH} ${Corn_CI_GITURL} ${Corn_CI_DIR} + +( cd ${Corn_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-math-comp.sh b/dev/ci/ci-math-comp.sh index 1b6c6fb847..bb8188da4e 100755 --- a/dev/ci/ci-math-comp.sh +++ b/dev/ci/ci-math-comp.sh @@ -4,10 +4,12 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -checkout_mathcomp math-comp +mathcomp_CI_DIR=${CI_BUILD_DIR}/math-comp + +checkout_mathcomp ${mathcomp_CI_DIR} # odd_order takes too much time for travis. -( cd math-comp/mathcomp && \ +( cd ${mathcomp_CI_DIR}/mathcomp && \ sed -i.bak '/PFsection/d' Make && \ sed -i.bak '/stripped_odd_order_theorem/d' Make && \ make Makefile.coq && make -f Makefile.coq -j ${NJOBS} all ) diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh index 597a6ab7b3..1ea56af29a 100755 --- a/dev/ci/ci-metacoq.sh +++ b/dev/ci/ci-metacoq.sh @@ -1,16 +1,24 @@ #!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -# MetaCoq + UniCoq +unicoq_CI_BRANCH=master +unicoq_CI_GITURL=https://github.com/unicoq/unicoq.git +unicoq_CI_DIR=${CI_BUILD_DIR}/unicoq -git_checkout master https://github.com/unicoq/unicoq.git unicoq +metacoq_CI_BRANCH=master +metacoq_CI_GITURL=https://github.com/MetaCoq/MetaCoq.git +metacoq_CI_DIR=${CI_BUILD_DIR}/MetaCoq -( cd unicoq && coq_makefile -f Make -o Makefile && make -j ${NJOBS} && make install ) +# Setup UniCoq -git_checkout master https://github.com/MetaCoq/MetaCoq.git MetaCoq +git_checkout ${unicoq_CI_BRANCH} ${unicoq_CI_GITURL} ${unicoq_CI_DIR} -( cd MetaCoq && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} ) +( cd ${unicoq_CI_DIR} && coq_makefile -f Make -o Makefile && make -j ${NJOBS} && make install ) +# Setup MetaCoq + +git_checkout ${metacoq_CI_BRANCH} ${metacoq_CI_GITURL} ${metacoq_CI_DIR} + +( cd ${metacoq_CI_DIR} && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} ) diff --git a/dev/ci/ci-template.sh b/dev/ci/ci-template.sh new file mode 100755 index 0000000000..700105aed4 --- /dev/null +++ b/dev/ci/ci-template.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +Template_CI_BRANCH=master +Template_CI_GITURL=https://github.com/Template/Template +Template_CI_DIR=${CI_BUILD_DIR}/Template + +git_checkout ${Template_CI_BRANCH} ${Template_CI_GITURL} ${Template_CI_DIR} + +( cd ${Template_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-tlc.sh b/dev/ci/ci-tlc.sh index df86b3cadd..415f9b38f9 100755 --- a/dev/ci/ci-tlc.sh +++ b/dev/ci/ci-tlc.sh @@ -3,6 +3,10 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git_checkout master https://gforge.inria.fr/git/tlc/tlc.git tlc +tlc_CI_BRANCH=master +tlc_CI_GITURL=https://gforge.inria.fr/git/tlc/tlc.git +tlc_CI_DIR=${CI_BUILD_DIR}/tlc -( cd tlc && make -j ${NJOBS} ) +git_checkout ${tlc_CI_BRANCH} ${tlc_CI_GITURL} ${tlc_CI_DIR} + +( cd ${tlc_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh index 5b7fc1c053..4c4b4f1ce1 100755 --- a/dev/ci/ci-unimath.sh +++ b/dev/ci/ci-unimath.sh @@ -5,10 +5,11 @@ source ${ci_dir}/ci-common.sh UniMath_CI_BRANCH=master UniMath_CI_GITURL=https://github.com/UniMath/UniMath.git +UniMath_CI_DIR=${CI_BUILD_DIR}/UniMath -git_checkout ${UniMath_CI_BRANCH} ${UniMath_CI_GITURL} UniMath +git_checkout ${UniMath_CI_BRANCH} ${UniMath_CI_GITURL} ${UniMath_CI_DIR} -( cd UniMath && \ +( cd ${UniMath_CI_DIR} && \ sed -i.bak '/Folds/d' Makefile && \ sed -i.bak '/HomologicalAlgebra/d' Makefile && \ make -j ${NJOBS} BUILD_COQ=no ) -- cgit v1.2.3 From fd5c5da475baea11d7ee2e1c2e965d7faeed3f33 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Wed, 8 Mar 2017 09:56:01 +0100 Subject: [travis] Make the git_checkout function more reliable. This commit also documents the behavior of said function; and fix the location of the ssreflect clone to an absolute path (this is now necessary). --- dev/ci/ci-common.sh | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 94fd00c0d2..6f624ab6ec 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -8,28 +8,29 @@ export PATH=`pwd`/bin:$PATH ls `pwd`/bin +# Where we clone and build external developments +CI_BUILD_DIR=`pwd`/_build_ci + # Maybe we should just use Ruby... mathcomp_CI_BRANCH=master mathcomp_CI_GITURL=https://github.com/math-comp/math-comp.git +mathcomp_CI_DIR=${CI_BUILD_DIR}/math-comp -# Where we clone and build external developments -CI_BUILD_DIR=`pwd`/_build_ci - -# git_checkout branch +# git_checkout branch url dest will create a git repository +# in (if it does not exist already) and checkout the +# remote branch from git_checkout() { local _BRANCH=${1} local _URL=${2} local _DEST=${3} - mkdir -p ${CI_BUILD_DIR} - cd ${CI_BUILD_DIR} - - if [ ! -d ${_DEST} ] ; then - echo "Checking out ${_DEST}" - git clone --depth 1 -b ${_BRANCH} ${_URL} ${_DEST} - fi - ( cd ${_DEST} && git pull && + mkdir -p ${_DEST} + ( cd ${_DEST} && \ + if [ ! -d .git ] ; then git clone --depth 1 ${_URL} . ; fi && \ + echo "Checking out ${_DEST}" && \ + git fetch ${_URL} ${_BRANCH} && \ + git checkout FETCH_HEAD && \ echo "${_DEST}: `git log -1 --format='%s | %H | %cd | %aN'`" ) } @@ -43,8 +44,8 @@ install_ssreflect() { echo 'Installing ssreflect' && echo -en 'travis_fold:start:ssr.install\\r' - checkout_mathcomp math-comp - ( cd math-comp/mathcomp && \ + checkout_mathcomp ${mathcomp_CI_DIR} + ( cd ${mathcomp_CI_DIR}/mathcomp && \ sed -i.bak '/ssrtest/d' Make && \ sed -i.bak '/odd_order/d' Make && \ sed -i.bak '/all\/all.v/d' Make && \ -- cgit v1.2.3 From e2135c2f5fd8846c30d8099eed523fe06202b614 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 12 Mar 2017 13:16:27 +0100 Subject: Updating core.dbg after ltac moved to plugins directory. --- dev/core.dbg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev/core.dbg b/dev/core.dbg index 698db63d23..f04e5c07b7 100644 --- a/dev/core.dbg +++ b/dev/core.dbg @@ -16,4 +16,4 @@ load_printer vernac.cma load_printer stm.cma load_printer toplevel.cma load_printer highparsing.cma -load_printer ltac.cma +load_printer ltac_plugin.cmo -- cgit v1.2.3 From 6d520f47e907010f556ef4ba24715607390460ef Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Fri, 24 Feb 2017 20:13:57 +0100 Subject: Remove a dead exception catching code. The code was assuming that Proofview.tclFOCUS could raise a CList.IndexOutOfRange exception but this isn't the case. The focusing functions already catch this exception and raises an algebraic exception within the tactic mechanism. --- proofs/pfedit.ml | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 80bea0c3b1..b06ea43bdd 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -143,12 +143,7 @@ let solve ?with_end_tac gi info_lvl tac pr = in (p,status) with - | Proof_global.NoCurrentProof -> CErrors.error "No focused proof" - | CList.IndexOutOfRange -> - match gi with - | Vernacexpr.SelectNth i -> let msg = str "No such goal: " ++ int i ++ str "." in - CErrors.user_err msg - | _ -> assert false + Proof_global.NoCurrentProof -> CErrors.error "No focused proof" let by tac = Proof_global.with_current_proof (fun _ -> solve (Vernacexpr.SelectNth 1) None tac) -- cgit v1.2.3 From 2cee6aa7a30b39c53e23fc69f0b9e7754ebee740 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 13 Mar 2017 19:53:00 +0100 Subject: [travis] Basic support for overlays. We now allow the user to overlay contribution repositories and branches by adding their own rules to `ci-basic-overlay.sh`. This just provides very basic support. --- dev/ci/ci-basic-overlay.sh | 103 +++++++++++++++++++++++++++++++++++++++++++++ dev/ci/ci-color.sh | 1 - dev/ci/ci-common.sh | 6 +-- dev/ci/ci-compcert.sh | 2 - dev/ci/ci-coquelicot.sh | 2 - dev/ci/ci-fiat-crypto.sh | 2 - dev/ci/ci-fiat-parsers.sh | 2 - dev/ci/ci-flocq.sh | 2 - dev/ci/ci-geocoq.sh | 2 - dev/ci/ci-hott.sh | 2 - dev/ci/ci-iris-coq.sh | 4 -- dev/ci/ci-math-classes.sh | 4 -- dev/ci/ci-metacoq.sh | 5 --- dev/ci/ci-sf.sh | 3 +- dev/ci/ci-tlc.sh | 2 - dev/ci/ci-unimath.sh | 2 - dev/ci/ci-user-overlay.sh | 22 ++++++++++ 17 files changed, 130 insertions(+), 36 deletions(-) create mode 100644 dev/ci/ci-basic-overlay.sh create mode 100644 dev/ci/ci-user-overlay.sh diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh new file mode 100644 index 0000000000..da5b425794 --- /dev/null +++ b/dev/ci/ci-basic-overlay.sh @@ -0,0 +1,103 @@ +#!/usr/bin/env bash + +# This is the basic overlay set for repositories in the CI. + +# Maybe we should just use Ruby to have real objects... + +######################################################################## +# MathComp +######################################################################## +: ${mathcomp_CI_BRANCH:=master} +: ${mathcomp_CI_GITURL:=https://github.com/math-comp/math-comp.git} + +######################################################################## +# UniMath +######################################################################## +: ${UniMath_CI_BRANCH:=master} +: ${UniMath_CI_GITURL:=https://github.com/UniMath/UniMath.git} + +######################################################################## +# Unicoq + Metacoq +######################################################################## +: ${unicoq_CI_BRANCH:=master} +: ${unicoq_CI_GITURL:=https://github.com/unicoq/unicoq.git} + +: ${metacoq_CI_BRANCH:=master} +: ${metacoq_CI_GITURL:=https://github.com/MetaCoq/MetaCoq.git} + +######################################################################## +# Mathclasses + Corn +######################################################################## +: ${math_classes_CI_BRANCH:=v8.6} +: ${math_classes_CI_GITURL:=https://github.com/math-classes/math-classes.git} + +: ${Corn_CI_BRANCH:=v8.6} +: ${Corn_CI_GITURL:=https://github.com/c-corn/corn.git} + +######################################################################## +# Iris +######################################################################## +: ${stdpp_CI_BRANCH:=master} +: ${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git} + +: ${Iris_CI_BRANCH:=master} +: ${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/FP/iris-coq.git} + +######################################################################## +# HoTT +######################################################################## +: ${HoTT_CI_BRANCH:=mz-8.7} +: ${HoTT_CI_GITURL:=https://github.com/ejgallego/HoTT.git} + +######################################################################## +# GeoCoq +######################################################################## +: ${GeoCoq_CI_BRANCH:=master} +: ${GeoCoq_CI_GITURL:=https://github.com/GeoCoq/GeoCoq.git} + +######################################################################## +# Flocq +######################################################################## +: ${Flocq_CI_BRANCH:=master} +: ${Flocq_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git} + +######################################################################## +# Coquelicot +######################################################################## +: ${Coquelicot_CI_BRANCH:=master} +: ${Coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git} + +######################################################################## +# Coquelicot +######################################################################## +: ${CompCert_CI_BRANCH:=master} +: ${CompCert_CI_GITURL:=https://github.com/AbsInt/CompCert.git} + +######################################################################## +# fiat_parsers +######################################################################## +: ${fiat_parsers_CI_BRANCH:=master} +: ${fiat_parsers_CI_GITURL:=https://github.com/mit-plv/fiat.git} + +######################################################################## +# fiat_crypto +######################################################################## +: ${fiat_crypto_CI_BRANCH:=master} +: ${fiat_crypto_CI_GITURL:=https://github.com/mit-plv/fiat-crypto.git} + +######################################################################## +# CoLoR +######################################################################## +: ${Color_CI_SVNURL:=https://scm.gforge.inria.fr/anonscm/svn/color/trunk/color} + +######################################################################## +# SF +######################################################################## +: ${sf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/current/sf.tgz} + +######################################################################## +# TLC +######################################################################## +: ${tlc_CI_BRANCH:=master} +: ${tlc_CI_GITURL:=https://gforge.inria.fr/git/tlc/tlc.git} + diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh index fbcf9be1d6..3f0716511d 100755 --- a/dev/ci/ci-color.sh +++ b/dev/ci/ci-color.sh @@ -3,7 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -Color_CI_SVNURL=https://scm.gforge.inria.fr/anonscm/svn/color/trunk/color Color_CI_DIR=${CI_BUILD_DIR}/color svn checkout ${Color_CI_SVNURL} ${Color_CI_DIR} diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 6f624ab6ec..c94f150263 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -11,9 +11,9 @@ ls `pwd`/bin # Where we clone and build external developments CI_BUILD_DIR=`pwd`/_build_ci -# Maybe we should just use Ruby... -mathcomp_CI_BRANCH=master -mathcomp_CI_GITURL=https://github.com/math-comp/math-comp.git +source ${ci_dir}/ci-user-overlay.sh +source ${ci_dir}/ci-basic-overlay.sh + mathcomp_CI_DIR=${CI_BUILD_DIR}/math-comp # git_checkout branch url dest will create a git repository diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index 111222ac7f..c78ffdc2c0 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -CompCert_CI_BRANCH=master -CompCert_CI_GITURL=https://github.com/AbsInt/CompCert.git CompCert_CI_DIR=${CI_BUILD_DIR}/CompCert opam install -j ${NJOBS} -y menhir diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh index 9dfdb87451..40eff03b78 100755 --- a/dev/ci/ci-coquelicot.sh +++ b/dev/ci/ci-coquelicot.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -Coquelicot_CI_BRANCH=master -Coquelicot_CI_GITURL=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git Coquelicot_CI_DIR=${CI_BUILD_DIR}/coquelicot install_ssreflect diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh index 7fc0dae2c0..93d39aab07 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat-crypto.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -fiat_crypto_CI_BRANCH=master -fiat_crypto_CI_GITURL=https://github.com/mit-plv/fiat-crypto.git fiat_crypto_CI_DIR=${CI_BUILD_DIR}/fiat-crypto git_checkout ${fiat_crypto_CI_BRANCH} ${fiat_crypto_CI_GITURL} ${fiat_crypto_CI_DIR} diff --git a/dev/ci/ci-fiat-parsers.sh b/dev/ci/ci-fiat-parsers.sh index 0b3312e878..c62aa1d859 100755 --- a/dev/ci/ci-fiat-parsers.sh +++ b/dev/ci/ci-fiat-parsers.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -fiat_parsers_CI_BRANCH=master -fiat_parsers_CI_GITURL=https://github.com/mit-plv/fiat.git fiat_parsers_CI_DIR=${CI_BUILD_DIR}/fiat git_checkout ${fiat_parsers_CI_BRANCH} ${fiat_parsers_CI_GITURL} ${fiat_parsers_CI_DIR} diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh index 30eca7a3e9..ec19bd9939 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -Flocq_CI_BRANCH=master -Flocq_CI_GITURL=https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git Flocq_CI_DIR=${CI_BUILD_DIR}/flocq git_checkout ${Flocq_CI_BRANCH} ${Flocq_CI_GITURL} ${Flocq_CI_DIR} diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index 7b5950c887..4e5aa2687b 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -GeoCoq_CI_BRANCH=master -GeoCoq_CI_GITURL=https://github.com/GeoCoq/GeoCoq.git GeoCoq_CI_DIR=${CI_BUILD_DIR}/GeoCoq git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} ${GeoCoq_CI_DIR} diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 62733c9452..1bf6e9a872 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -HoTT_CI_BRANCH=mz-8.7 -HoTT_CI_GITURL=https://github.com/ejgallego/HoTT.git HoTT_CI_DIR=${CI_BUILD_DIR}/HoTT git_checkout ${HoTT_CI_BRANCH} ${HoTT_CI_GITURL} ${HoTT_CI_DIR} diff --git a/dev/ci/ci-iris-coq.sh b/dev/ci/ci-iris-coq.sh index 10f2c2b4bd..eb1d1be078 100755 --- a/dev/ci/ci-iris-coq.sh +++ b/dev/ci/ci-iris-coq.sh @@ -3,12 +3,8 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -stdpp_CI_BRANCH=master -stdpp_CI_GITURL=https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git stdpp_CI_DIR=${CI_BUILD_DIR}/coq-stdpp -Iris_CI_BRANCH=master -Iris_CI_GITURL=https://gitlab.mpi-sws.org/FP/iris-coq.git Iris_CI_DIR=${CI_BUILD_DIR}/iris-coq install_ssreflect diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math-classes.sh index e6a57404fe..beb75773b7 100755 --- a/dev/ci/ci-math-classes.sh +++ b/dev/ci/ci-math-classes.sh @@ -3,12 +3,8 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -math_classes_CI_BRANCH=v8.6 -math_classes_CI_GITURL=https://github.com/math-classes/math-classes.git math_classes_CI_DIR=${CI_BUILD_DIR}/math-classes -Corn_CI_BRANCH=v8.6 -Corn_CI_GITURL=https://github.com/c-corn/corn.git Corn_CI_DIR=${CI_BUILD_DIR}/corn # Setup Math-Classes diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh index 1ea56af29a..e31691179e 100755 --- a/dev/ci/ci-metacoq.sh +++ b/dev/ci/ci-metacoq.sh @@ -3,12 +3,7 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -unicoq_CI_BRANCH=master -unicoq_CI_GITURL=https://github.com/unicoq/unicoq.git unicoq_CI_DIR=${CI_BUILD_DIR}/unicoq - -metacoq_CI_BRANCH=master -metacoq_CI_GITURL=https://github.com/MetaCoq/MetaCoq.git metacoq_CI_DIR=${CI_BUILD_DIR}/MetaCoq # Setup UniCoq diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index c451bf26a1..7d23ccad97 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -3,7 +3,8 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -wget https://www.cis.upenn.edu/~bcpierce/sf/current/sf.tgz +# XXX: Needs fixing to properly set the build directory. +wget ${sf_CI_TARURL} tar xvfz sf.tgz ( cd sf && sed -i.bak 's/(K,N)/((K,N))/' LibTactics.v && make clean && make -j ${NJOBS} ) diff --git a/dev/ci/ci-tlc.sh b/dev/ci/ci-tlc.sh index 415f9b38f9..ce26399378 100755 --- a/dev/ci/ci-tlc.sh +++ b/dev/ci/ci-tlc.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -tlc_CI_BRANCH=master -tlc_CI_GITURL=https://gforge.inria.fr/git/tlc/tlc.git tlc_CI_DIR=${CI_BUILD_DIR}/tlc git_checkout ${tlc_CI_BRANCH} ${tlc_CI_GITURL} ${tlc_CI_DIR} diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh index 4c4b4f1ce1..175b82b5f9 100755 --- a/dev/ci/ci-unimath.sh +++ b/dev/ci/ci-unimath.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -UniMath_CI_BRANCH=master -UniMath_CI_GITURL=https://github.com/UniMath/UniMath.git UniMath_CI_DIR=${CI_BUILD_DIR}/UniMath git_checkout ${UniMath_CI_BRANCH} ${UniMath_CI_GITURL} ${UniMath_CI_DIR} diff --git a/dev/ci/ci-user-overlay.sh b/dev/ci/ci-user-overlay.sh new file mode 100644 index 0000000000..0285747432 --- /dev/null +++ b/dev/ci/ci-user-overlay.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash + +# Add user overlays here. You can use some logic to detect if you are +# in your travis branch and conditionally enable the overlay. + +# Some useful Travis variables: +# (https://docs.travis-ci.com/user/environment-variables/#Default-Environment-Variables) +# +# - TRAVIS_BRANCH: For builds not triggered by a pull request this is +# the name of the branch currently being built; whereas for builds +# triggered by a pull request this is the name of the branch +# targeted by the pull request (in many cases this will be master). +# +# - TRAVIS_COMMIT: The commit that the current build is testing. +# +# - TRAVIS_PULL_REQUEST: The pull request number if the current job is +# a pull request, “false” if it’s not a pull request. +# +# - TRAVIS_PULL_REQUEST_BRANCH: If the current job is a pull request, +# the name of the branch from which the PR originated. "" if the +# current job is a push build. + -- cgit v1.2.3 From bbae426407ba7df585c22ec687a79c0cf216a6a8 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 14 Mar 2017 00:17:06 +0100 Subject: [library] Don't recompute path_prefix on unfreeze. We instead save the current value. --- library/lib.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/library/lib.ml b/library/lib.ml index 4fd29a94de..1531d408f6 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -561,7 +561,7 @@ let close_section () = (* State and initialization. *) -type frozen = Names.DirPath.t option * library_segment +type frozen = Names.DirPath.t option * library_segment * (Names.DirPath.t * (Names.module_path * Names.DirPath.t)) let freeze ~marshallable = match marshallable with @@ -579,17 +579,17 @@ let freeze ~marshallable = | n, ClosedSection _ -> Some (n,ClosedSection []) | _, FrozenState _ -> None) !lib_stk in - !comp_name, lib_stk + !comp_name, lib_stk, !path_prefix | _ -> - !comp_name, !lib_stk + !comp_name, !lib_stk, !path_prefix -let unfreeze (mn,stk) = +let unfreeze (mn,stk,path_prfx) = comp_name := mn; lib_stk := stk; - recalc_path_prefix () + path_prefix := path_prfx let init () = - unfreeze (None,[]); + unfreeze (None,[],initial_prefix); Summary.init_summaries (); add_frozen_state () (* Stores e.g. the keywords declared in g_*.ml4 *) -- cgit v1.2.3 From addc1304de75800fa9301e97d3ae78539f511959 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 14 Mar 2017 00:32:53 +0100 Subject: [library] Refactor state handling. This part of state is critical. We refactor it and make it into a record to ease handling. --- library/lib.ml | 84 +++++++++++++++++++++++++++++++--------------------------- 1 file changed, 45 insertions(+), 39 deletions(-) diff --git a/library/lib.ml b/library/lib.ml index 1531d408f6..ddd2ed6afa 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -97,21 +97,30 @@ let segment_of_objects prefix = let initial_prefix = default_library,(Names.initial_path,Names.DirPath.empty) -let lib_stk = ref ([] : library_segment) +type lib_state = { + comp_name : Names.DirPath.t option; + lib_stk : library_segment; + path_prefix : Names.DirPath.t * (Names.module_path * Names.DirPath.t); +} -let comp_name = ref None +let initial_lib_state = { + comp_name = None; + lib_stk = []; + path_prefix = initial_prefix; +} + +let lib_state = ref initial_lib_state let library_dp () = - match !comp_name with Some m -> m | None -> default_library + match !lib_state.comp_name with Some m -> m | None -> default_library (* [path_prefix] is a pair of absolute dirpath and a pair of current module path and relative section path *) -let path_prefix = ref initial_prefix -let cwd () = fst !path_prefix -let current_prefix () = snd !path_prefix -let current_mp () = fst (snd !path_prefix) -let current_sections () = snd (snd !path_prefix) +let cwd () = fst !lib_state.path_prefix +let current_prefix () = snd !lib_state.path_prefix +let current_mp () = fst (snd !lib_state.path_prefix) +let current_sections () = snd (snd !lib_state.path_prefix) let sections_depth () = List.length (Names.DirPath.repr (current_sections ())) let sections_are_opened () = not (Names.DirPath.is_empty (current_sections ())) @@ -132,7 +141,7 @@ let make_kn id = let mp,dir = current_prefix () in Names.make_kn mp dir (Names.Label.of_id id) -let make_oname id = Libnames.make_oname !path_prefix id +let make_oname id = Libnames.make_oname !lib_state.path_prefix id let recalc_path_prefix () = let rec recalc = function @@ -142,18 +151,18 @@ let recalc_path_prefix () = | _::l -> recalc l | [] -> initial_prefix in - path_prefix := recalc !lib_stk + lib_state := { !lib_state with path_prefix = recalc !lib_state.lib_stk } let pop_path_prefix () = - let dir,(mp,sec) = !path_prefix in - path_prefix := pop_dirpath dir, (mp, pop_dirpath sec) + let dir,(mp,sec) = !lib_state.path_prefix in + lib_state := { !lib_state with path_prefix = pop_dirpath dir, (mp, pop_dirpath sec)} let find_entry_p p = let rec find = function | [] -> raise Not_found | ent::l -> if p ent then ent else find l in - find !lib_stk + find !lib_state.lib_stk let split_lib_gen test = let rec collect after equal = function @@ -174,7 +183,7 @@ let split_lib_gen test = | _ -> findeq (hd::after) before) | [] -> None in - match findeq [] !lib_stk with + match findeq [] !lib_state.lib_stk with | None -> error "no such entry" | Some r -> r @@ -199,10 +208,10 @@ let split_lib_at_opening sp = (* Adding operations. *) let add_entry sp node = - lib_stk := (sp,node) :: !lib_stk + lib_state := { !lib_state with lib_stk = (sp,node) :: !lib_state.lib_stk } let pull_to_head oname = - lib_stk := (oname,List.assoc oname !lib_stk) :: List.remove_assoc oname !lib_stk + lib_state := { !lib_state with lib_stk = (oname,List.assoc oname !lib_state.lib_stk) :: List.remove_assoc oname !lib_state.lib_stk } let anonymous_id = let n = ref 0 in @@ -277,7 +286,7 @@ let start_mod is_type export id mp fs = if exists then user_err ~hdr:"open_module" (pr_id id ++ str " already exists"); add_entry (make_oname id) (OpenedModule (is_type,export,prefix,fs)); - path_prefix := prefix; + lib_state := { !lib_state with path_prefix = prefix} ; prefix let start_module = start_mod false @@ -299,16 +308,16 @@ let end_mod is_type = with Not_found -> error "No opened modules." in let (after,mark,before) = split_lib_at_opening oname in - lib_stk := before; + lib_state := { !lib_state with lib_stk = before }; add_entry oname (ClosedModule (List.rev (mark::after))); - let prefix = !path_prefix in + let prefix = !lib_state.path_prefix in recalc_path_prefix (); (oname, prefix, fs, after) let end_module () = end_mod false let end_modtype () = end_mod true -let contents () = !lib_stk +let contents () = !lib_state.lib_stk let contents_after sp = let (after,_,_) = split_lib sp in after @@ -316,14 +325,14 @@ let contents_after sp = let (after,_,_) = split_lib sp in after (* TODO: use check_for_module ? *) let start_compilation s mp = - if !comp_name != None then + if !lib_state.comp_name != None then error "compilation unit is already started"; if not (Names.DirPath.is_empty (current_sections ())) then error "some sections are already opened"; let prefix = s, (mp, Names.DirPath.empty) in let () = add_anonymous_entry (CompilingLibrary prefix) in - comp_name := Some s; - path_prefix := prefix + lib_state := { !lib_state with comp_name = Some s; + path_prefix = prefix } let end_compilation_checks dir = let _ = @@ -344,7 +353,7 @@ let end_compilation_checks dir = with Not_found -> anomaly (Pp.str "No module declared") in let _ = - match !comp_name with + match !lib_state.comp_name with | None -> anomaly (Pp.str "There should be a module name...") | Some m -> if not (Names.DirPath.equal m dir) then anomaly @@ -355,8 +364,8 @@ let end_compilation_checks dir = let end_compilation oname = let (after,mark,before) = split_lib_at_opening oname in - comp_name := None; - !path_prefix,after + lib_state := { !lib_state with comp_name = None }; + !lib_state.path_prefix,after (* Returns true if we are inside an opened module or module type *) @@ -514,7 +523,7 @@ 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 olddir,(mp,oldsec) = !lib_state.path_prefix in let dir = add_dirpath_suffix olddir id in let prefix = dir, (mp, add_dirpath_suffix oldsec id) in if Nametab.exists_section dir then @@ -523,7 +532,7 @@ let open_section id = add_entry (make_oname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix); - path_prefix := prefix; + lib_state := { !lib_state with path_prefix = prefix }; if !Flags.xml_export then Hook.get f_xml_open_section id; add_section () @@ -549,8 +558,8 @@ let close_section () = error "No opened section." in let (secdecls,mark,before) = split_lib_at_opening oname in - lib_stk := before; - let full_olddir = fst !path_prefix in + lib_state := { !lib_state with lib_stk = before }; + let full_olddir = fst !lib_state.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)); @@ -561,7 +570,7 @@ let close_section () = (* State and initialization. *) -type frozen = Names.DirPath.t option * library_segment * (Names.DirPath.t * (Names.module_path * Names.DirPath.t)) +type frozen = lib_state let freeze ~marshallable = match marshallable with @@ -578,18 +587,15 @@ let freeze ~marshallable = Some(n,OpenedSection(op,Summary.empty_frozen)) | n, ClosedSection _ -> Some (n,ClosedSection []) | _, FrozenState _ -> None) - !lib_stk in - !comp_name, lib_stk, !path_prefix + !lib_state.lib_stk in + { !lib_state with lib_stk } | _ -> - !comp_name, !lib_stk, !path_prefix + !lib_state -let unfreeze (mn,stk,path_prfx) = - comp_name := mn; - lib_stk := stk; - path_prefix := path_prfx +let unfreeze st = lib_state := st let init () = - unfreeze (None,[],initial_prefix); + unfreeze initial_lib_state; Summary.init_summaries (); add_frozen_state () (* Stores e.g. the keywords declared in g_*.ml4 *) -- cgit v1.2.3 From 3502cc7c3bbad154dbfe76558d411d2c76109668 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Sun, 5 Mar 2017 17:30:03 +0100 Subject: [future] Remove unused parameter greedy. It was always set to `greedy:true`. --- kernel/opaqueproof.ml | 2 +- kernel/term_typing.ml | 6 +++--- lib/future.ml | 14 +++++++------- lib/future.mli | 15 +++++++-------- stm/stm.ml | 6 +++--- vernac/command.ml | 2 +- vernac/lemmas.ml | 2 +- 7 files changed, 23 insertions(+), 24 deletions(-) diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 130f1eb039..f147ea3433 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -136,7 +136,7 @@ let dump (otab,_) = let disch_table = Array.make n a_discharge in let f2t_map = ref FMap.empty in Int.Map.iter (fun n (d,cu) -> - let c, u = Future.split2 ~greedy:true cu in + let c, u = Future.split2 cu in Future.sink u; Future.sink c; opaque_table.(n) <- c; diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 3a0d1a2a5e..a63eb33766 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -191,7 +191,7 @@ 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,uctx),side_eff) -> + Future.chain ~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 @@ -416,7 +416,7 @@ let export_side_effects mb env ce = 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 + const_entry_body = Future.chain ~pure:true body (fun (b_ctx, _) -> b_ctx, []) } in let not_exists (c,_,_,_) = try ignore(Environ.lookup_constant c env); false @@ -498,7 +498,7 @@ let translate_local_def mb env id centry = let translate_mind env kn mie = Indtypes.check_inductive env kn mie let inline_entry_side_effects env ce = { ce with - const_entry_body = Future.chain ~greedy:true ~pure:true + const_entry_body = Future.chain ~pure:true ce.const_entry_body (fun ((body, ctx), side_eff) -> let body, ctx',_ = inline_side_effects env body ctx side_eff in (body, ctx'), []); diff --git a/lib/future.ml b/lib/future.ml index ea0382a63d..b60b32bb61 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -191,9 +191,9 @@ let transactify f x = let purify_future f x = if is_over x then f x else purify f x let compute x = purify_future (compute ~pure:false) x let force ~pure x = purify_future (force ~pure) x -let chain ?(greedy=true) ~pure x f = +let chain ~pure x f = let y = chain ~pure x f in - if is_over x && greedy then ignore(force ~pure y); + if is_over x then ignore(force ~pure y); y let force x = force ~pure:false x @@ -204,13 +204,13 @@ let join kx = let sink kx = if is_val kx then ignore(join kx) -let split2 ?greedy x = - chain ?greedy ~pure:true x (fun x -> fst x), - chain ?greedy ~pure:true x (fun x -> snd x) +let split2 x = + chain ~pure:true x (fun x -> fst x), + chain ~pure:true x (fun x -> snd x) -let map2 ?greedy f x l = +let map2 f x l = CList.map_i (fun i y -> - let xi = chain ?greedy ~pure:true x (fun x -> + let xi = chain ~pure:true x (fun x -> try List.nth x i with Failure _ | Invalid_argument _ -> CErrors.anomaly (Pp.str "Future.map2 length mismatch")) in diff --git a/lib/future.mli b/lib/future.mli index c780faf324..2a025ae844 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -113,8 +113,9 @@ val is_exn : 'a computation -> bool val peek_val : 'a computation -> 'a option val uuid : 'a computation -> UUID.t -(* [chain greedy pure c f] chains computation [c] with [f]. - * The [greedy] and [pure] parameters are tricky: +(* [chain pure c f] chains computation [c] with [f]. + * [chain] forces immediately the new computation if the old one is_over (Exn or Val). + * The [pure] parameter is tricky: * [pure]: * When pure is true, the returned computation will not keep a copy * of the global state. @@ -124,10 +125,8 @@ val uuid : 'a computation -> UUID.t * one forces c' and then c''. * [join c; chain ~pure:false c g] is invalid and fails at runtime. * [force c; chain ~pure:false c g] is correct. - * [greedy]: - * The [greedy] parameter forces immediately the new computation if - * the old one is_over (Exn or Val). Defaults to true. *) -val chain : ?greedy:bool -> pure:bool -> + *) +val chain : pure:bool -> 'a computation -> ('a -> 'b) -> 'b computation (* Forcing a computation *) @@ -143,9 +142,9 @@ val join : 'a computation -> 'a val sink : 'a computation -> unit (*** Utility functions ************************************************* ***) -val split2 : ?greedy:bool -> +val split2 : ('a * 'b) computation -> 'a computation * 'b computation -val map2 : ?greedy:bool -> +val map2 : ('a computation -> 'b -> 'c) -> 'a list computation -> 'b list -> 'c list diff --git a/stm/stm.ml b/stm/stm.ml index e698d1c72e..e56db4090a 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1618,9 +1618,9 @@ end = struct (* {{{ *) Future.from_val (Option.get (Global.body_of_constant_body c)) in let uc = Future.chain - ~greedy:true ~pure:true uc Univ.hcons_universe_context_set in - let pr = Future.chain ~greedy:true ~pure:true pr discharge in - let pr = Future.chain ~greedy:true ~pure:true pr Constr.hcons in + ~pure:true uc Univ.hcons_universe_context_set in + let pr = Future.chain ~pure:true pr discharge in + let pr = Future.chain ~pure:true pr Constr.hcons in Future.sink pr; let extra = Future.join uc in u.(bucket) <- uc; diff --git a/vernac/command.ml b/vernac/command.ml index 049f58aa26..4b4f4d2711 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -81,7 +81,7 @@ let red_constant_entry n ce sigma = function 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 + { ce with const_entry_body = Future.chain ~pure:true proof_out (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) } let warn_implicits_in_term = diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 55f33be399..798a238c74 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -60,7 +60,7 @@ let adjust_guardness_conditions const = function (* Try all combinations... not optimal *) let env = Global.env() in { const with const_entry_body = - Future.chain ~greedy:true ~pure:true const.const_entry_body + Future.chain ~pure:true const.const_entry_body (fun ((body, ctx), eff) -> match kind_of_term body with | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> -- cgit v1.2.3 From 43524c6689f372b32770c20d19866f2f4edb4cc6 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Tue, 14 Mar 2017 16:22:24 +0100 Subject: Show unused-intro-pattern warning. This warning was shown in CoqIDE but not by coqc. --- tactics/tactics.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 9d64e7c599..f186f6e0ec 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -3010,7 +3010,7 @@ let warn_unused_intro_pattern = (fun c -> Printer.pr_constr (fst (run_delayed (Global.env()) Evd.empty c)))) names) let check_unused_names names = - if not (List.is_empty names) && Flags.is_verbose () then + if not (List.is_empty names) then warn_unused_intro_pattern names let intropattern_of_name gl avoid = function -- cgit v1.2.3 From 88c02e02a7b6067c78608e9ea526f81fd122edab Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Tue, 14 Mar 2017 16:22:48 +0100 Subject: Fix 3 unused-intro-pattern warnings in stdlib. --- theories/Lists/List.v | 4 ++-- theories/QArith/Qround.v | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 30f1dec22c..1aece3f60b 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -419,7 +419,7 @@ Section Elts. Proof. unfold lt; induction n as [| n hn]; simpl. - destruct l; simpl; [ inversion 2 | auto ]. - - destruct l as [| a l hl]; simpl. + - destruct l; simpl. * inversion 2. * intros d ie; right; apply hn; auto with arith. Qed. @@ -1280,7 +1280,7 @@ End Fold_Right_Recursor. partition l = ([], []) <-> l = []. Proof. split. - - destruct l as [|a l' _]. + - destruct l as [|a l']. * intuition. * simpl. destruct (f a), (partition l'); now intros [= -> ->]. - now intros ->. diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v index 0ed6d557c0..e94ef408db 100644 --- a/theories/QArith/Qround.v +++ b/theories/QArith/Qround.v @@ -141,7 +141,7 @@ Qed. Lemma Zdiv_Qdiv (n m: Z): (n / m)%Z = Qfloor (n / m). Proof. unfold Qfloor. intros. simpl. - destruct m as [?|?|p]; simpl. + destruct m as [ | | p]; simpl. now rewrite Zdiv_0_r, Z.mul_0_r. now rewrite Z.mul_1_r. rewrite <- Z.opp_eq_mul_m1. -- cgit v1.2.3 From 53d30eb8b3186031658dafd74dc7ad012854f385 Mon Sep 17 00:00:00 2001 From: Vadim Zaliva Date: Wed, 8 Mar 2017 23:05:55 -0800 Subject: Fix #5132: coq_makefile generates incorrect install goal --- tools/coq_makefile.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index b7dd5f2a14..294575e0a5 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -676,6 +676,7 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other print "VO=vo\n"; print "VOFILES:=$(VFILES:.v=.$(VO))\n"; classify_files_by_root "VOFILES" l inc; + classify_files_by_root "VFILES" l inc; print "GLOBFILES:=$(VFILES:.v=.glob)\n"; print "GFILES:=$(VFILES:.v=.g)\n"; print "HTMLFILES:=$(VFILES:.v=.html)\n"; -- cgit v1.2.3 From 611b34fae5974111e4753d99601214860bffe828 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 03:39:22 +0100 Subject: [safe_string] lib/cThread No functional changes. --- lib/cThread.ml | 18 ++++++++++-------- lib/cThread.mli | 4 ++-- 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/lib/cThread.ml b/lib/cThread.ml index 4f60a69745..9f642b3cec 100644 --- a/lib/cThread.ml +++ b/lib/cThread.ml @@ -36,7 +36,7 @@ let really_read_fd fd s off len = let really_read_fd_2_oc fd oc len = let i = ref 0 in let size = 4096 in - let s = String.create size in + let s = Bytes.create size in while !i < len do let len = len - !i in let r = thread_friendly_read_fd fd s ~off:0 ~len:(min len size) in @@ -55,11 +55,13 @@ let thread_friendly_really_read_line ic = try let fd = Unix.descr_of_in_channel ic in let b = Buffer.create 1024 in - let s = String.make 1 '\000' in - while s <> "\n" do + let s = Bytes.make 1 '\000' in + let endl = Bytes.of_string "\n" in + (* Bytes.equal is in 4.03.0 *) + while Bytes.compare s endl <> 0 do let n = thread_friendly_read_fd fd s ~off:0 ~len:1 in if n = 0 then raise End_of_file; - if s <> "\n" then Buffer.add_string b s; + if Bytes.compare s endl <> 0 then Buffer.add_bytes b s; done; Buffer.contents b with Unix.Unix_error _ -> raise End_of_file @@ -67,15 +69,15 @@ let thread_friendly_really_read_line ic = let thread_friendly_input_value ic = try let fd = Unix.descr_of_in_channel ic in - let header = String.create Marshal.header_size in + let header = Bytes.create Marshal.header_size in really_read_fd fd header 0 Marshal.header_size; let body_size = Marshal.data_size header 0 in let desired_size = body_size + Marshal.header_size in if desired_size <= Sys.max_string_length then begin - let msg = String.create desired_size in - String.blit header 0 msg 0 Marshal.header_size; + let msg = Bytes.create desired_size in + Bytes.blit header 0 msg 0 Marshal.header_size; really_read_fd fd msg Marshal.header_size body_size; - Marshal.from_string msg 0 + Marshal.from_bytes msg 0 end else begin (* Workaround for 32 bit systems and data > 16M *) let name, oc = diff --git a/lib/cThread.mli b/lib/cThread.mli index 7302dfb558..36477a1160 100644 --- a/lib/cThread.mli +++ b/lib/cThread.mli @@ -19,8 +19,8 @@ val prepare_in_channel_for_thread_friendly_io : in_channel -> thread_ic val thread_friendly_input_value : thread_ic -> 'a val thread_friendly_read : - thread_ic -> string -> off:int -> len:int -> int + thread_ic -> Bytes.t -> off:int -> len:int -> int val thread_friendly_really_read : - thread_ic -> string -> off:int -> len:int -> unit + thread_ic -> Bytes.t -> off:int -> len:int -> unit val thread_friendly_really_read_line : thread_ic -> string -- cgit v1.2.3 From fea15b446444e522d405e97b9e18d84baabfc633 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 13:33:11 +0100 Subject: [safe-string] lib/cUnix No functional change. --- lib/cUnix.ml | 8 ++++---- lib/cUnix.mli | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/cUnix.ml b/lib/cUnix.ml index cb436511fb..2542b9751b 100644 --- a/lib/cUnix.ml +++ b/lib/cUnix.ml @@ -91,15 +91,15 @@ let rec waitpid_non_intr pid = let run_command ?(hook=(fun _ ->())) c = let result = Buffer.create 127 in let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in - let buff = String.make 127 ' ' in - let buffe = String.make 127 ' ' in + let buff = Bytes.make 127 ' ' in + let buffe = Bytes.make 127 ' ' in let n = ref 0 in let ne = ref 0 in while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; !n+ !ne <> 0 do - let r = String.sub buff 0 !n in (hook r; Buffer.add_string result r); - let r = String.sub buffe 0 !ne in (hook r; Buffer.add_string result r); + let r = Bytes.sub buff 0 !n in (hook r; Buffer.add_bytes result r); + let r = Bytes.sub buffe 0 !ne in (hook r; Buffer.add_bytes result r); done; (Unix.close_process_full (cin,cout,cerr), Buffer.contents result) diff --git a/lib/cUnix.mli b/lib/cUnix.mli index f03719c3d2..c6bcf63475 100644 --- a/lib/cUnix.mli +++ b/lib/cUnix.mli @@ -46,7 +46,7 @@ val file_readable_p : string -> bool is called on each elements read on stdout or stderr. *) val run_command : - ?hook:(string->unit) -> string -> Unix.process_status * string + ?hook:(bytes->unit) -> string -> Unix.process_status * string (** [sys_command] launches program [prog] with arguments [args]. It behaves like [Sys.command], except that we rely on -- cgit v1.2.3 From b47bd5617018145332deaa75e42ddad0728d9638 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 13:34:17 +0100 Subject: [safe-string] lib/miscelanea No functional change.js --- lib/pp_control.ml | 2 +- lib/util.ml | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/pp_control.ml b/lib/pp_control.ml index 890ffe0a18..ab8dc0798c 100644 --- a/lib/pp_control.ml +++ b/lib/pp_control.ml @@ -58,7 +58,7 @@ let with_fp chan out_function flush_function = (* Output on a channel ch *) let with_output_to ch = - let ft = with_fp ch (output ch) (fun () -> flush ch) in + let ft = with_fp ch (output_substring ch) (fun () -> flush ch) in set_gp ft deep_gp; ft diff --git a/lib/util.ml b/lib/util.ml index 9fb0d48ee8..0d2425f271 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -161,11 +161,11 @@ let iraise = Exninfo.iraise let open_utf8_file_in fname = let is_bom s = - Int.equal (Char.code s.[0]) 0xEF && - Int.equal (Char.code s.[1]) 0xBB && - Int.equal (Char.code s.[2]) 0xBF + Int.equal (Char.code (Bytes.get s 0)) 0xEF && + Int.equal (Char.code (Bytes.get s 1)) 0xBB && + Int.equal (Char.code (Bytes.get s 2)) 0xBF in let in_chan = open_in fname in - let s = " " in + let s = Bytes.make 3 ' ' in if input in_chan s 0 3 < 3 || not (is_bom s) then seek_in in_chan 0; in_chan -- cgit v1.2.3 From 3a050f305293676ccf66d415ab386d9521f0f765 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 04:04:33 +0100 Subject: [safe_string] kernel/term_typing No functional change, we create the new string beforehand and `id_of_string` will become a noop with `-safe-string`. --- kernel/term_typing.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 3a0d1a2a5e..b9cf8101da 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -76,8 +76,7 @@ let inline_side_effects env body ctx side_eff = let cbl = List.filter not_exists cbl in let cname c = let name = string_of_con c in - for i = 0 to String.length name - 1 do - if name.[i] == '.' || name.[i] == '#' then name.[i] <- '_' done; + let name = String.map (fun c -> if c == '.' || c == '#' then '_' else c) name in Name (id_of_string name) in let rec sub c i x = match kind_of_term x with | Const (c', _) when eq_constant c c' -> mkRel i -- cgit v1.2.3 From 6098d329afc1e212ff866212a8f7815969a460ad Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 13:33:39 +0100 Subject: [safe-string] kernel/nativevalues No functional change. --- kernel/nativevalues.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 8093df3044..965ed67b07 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -491,12 +491,12 @@ let str_encode expr = let str_decode s = let mshl_expr_len = String.length s / 2 in let mshl_expr = Buffer.create mshl_expr_len in - let buf = String.create 2 in + let buf = Bytes.create 2 in for i = 0 to mshl_expr_len - 1 do - String.blit s (2*i) buf 0 2; - Buffer.add_char mshl_expr (bin_of_hex buf) + Bytes.blit_string s (2*i) buf 0 2; + Buffer.add_char mshl_expr (bin_of_hex (Bytes.to_string buf)) done; - Marshal.from_string (Buffer.contents mshl_expr) 0 + Marshal.from_bytes (Buffer.to_bytes mshl_expr) 0 (** Retroknowledge, to be removed when we switch to primitive integers *) -- cgit v1.2.3 From 028db341f3cb924c2d1b3a9e0fa5666425130f90 Mon Sep 17 00:00:00 2001 From: Tej Chajed Date: Thu, 9 Feb 2017 11:15:51 -0500 Subject: Report missing tactic arguments in error message Augments "A fully applied tactic is expected" with the list of missing arguments to the tactic. Addresses [bug 5344](https://coq.inria.fr/bugs/show_bug.cgi?id=5344). --- plugins/ltac/tacinterp.ml | 9 ++++++++- test-suite/output/ltac_missing_args.out | 21 +++++++++++++++++++++ test-suite/output/ltac_missing_args.v | 19 +++++++++++++++++++ 3 files changed, 48 insertions(+), 1 deletion(-) create mode 100644 test-suite/output/ltac_missing_args.out create mode 100644 test-suite/output/ltac_missing_args.v diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index aa646aa517..54bec39670 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1422,7 +1422,14 @@ and tactic_of_value ist vle = extra = TacStore.set ist.extra f_trace []; } in let tac = name_if_glob appl (eval_tactic ist t) in Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) - | (VFun _|VRec _) -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") + | VFun (_, _, _,vars,_) -> + let numargs = List.length vars in + Tacticals.New.tclZEROMSG + (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++ + Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++ + Pp.str (String.plural numargs "variable") ++ Pp.str " " ++ + pr_enum pr_name vars ++ Pp.str ".") + | 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 diff --git a/test-suite/output/ltac_missing_args.out b/test-suite/output/ltac_missing_args.out new file mode 100644 index 0000000000..ae3fd7acc7 --- /dev/null +++ b/test-suite/output/ltac_missing_args.out @@ -0,0 +1,21 @@ +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +Error: A fully applied tactic is expected: +missing arguments for variables y and _. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable _. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable _. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable _. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable x. diff --git a/test-suite/output/ltac_missing_args.v b/test-suite/output/ltac_missing_args.v new file mode 100644 index 0000000000..8ecd97aa56 --- /dev/null +++ b/test-suite/output/ltac_missing_args.v @@ -0,0 +1,19 @@ +Ltac foo x := idtac x. +Ltac bar x := fun y _ => idtac x y. +Ltac baz := foo. +Ltac qux := bar. +Ltac mydo tac := tac (). +Ltac rec x := rec. + +Goal True. + Fail foo. + Fail bar. + Fail bar True. + Fail baz. + Fail qux. + Fail mydo ltac:(fun _ _ => idtac). + Fail let tac := (fun _ => idtac) in tac. + Fail (fun _ => idtac). + Fail rec True. + Fail let rec tac x := tac in tac True. +Abort. \ No newline at end of file -- cgit v1.2.3 From b087d133f7d6d091cce72190c05a9a09d5b37791 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 14 Mar 2017 21:24:53 +0100 Subject: [toplevel] Remove unusable option -notop Maxime points out that -notop cannot be used as the kernel requires all constants to belong into a module. Indeed: ``` $ rlwrap ./bin/coqtop -notop Coq < Definition foo := True. Toplevel input, characters 0-23: > Definition foo := True. > ^^^^^^^^^^^^^^^^^^^^^^^ Error: No session module started (use -top dir) Coq < Module M. Definition foo := True. End M. Module M is defined Coq < Locate foo. Constant If you see this, it's a bug.M.foo (shorter name to refer to it in current context is M.foo) ``` My rationale for the removal is that this kind of incomplete features are often confusing to newcomers ─ it has happened to me many times ─ as it can be seen for example in #397 . --- doc/refman/RefMan-com.tex | 6 ------ doc/refman/RefMan-ext.tex | 2 +- kernel/safe_typing.ml | 2 +- toplevel/coqtop.ml | 8 +++----- toplevel/usage.ml | 1 - 5 files changed, 5 insertions(+), 14 deletions(-) diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index bef0a1686f..45230fb6e5 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -123,12 +123,6 @@ The following command-line options are recognized by the commands {\tt 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}]\ % Exclude any subdirectory named {\em directory} while diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index b475a5233c..1d423f8b16 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -991,7 +991,7 @@ but library file names based on other roots can be obtained by using {\Coq} commands ({\tt coqc}, {\tt coqtop}, {\tt coqdep}, \dots) options {\tt -Q} or {\tt -R} (see Section~\ref{coqoptions}). Also, when an interactive {\Coq} session starts, a library of root {\tt Top} is -started, unless option {\tt -top} or {\tt -notop} is set (see +started, unless option {\tt -top} is set (see Section~\ref{coqoptions}). \subsection{Qualified names diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index e4b3fcbf1a..2312f891c5 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -71,7 +71,7 @@ module NamedDecl = Context.Named.Declaration - [env] : the underlying environment (cf Environ) - [modpath] : the current module name - [modvariant] : - * NONE before coqtop initialization (or when -notop is used) + * NONE before coqtop initialization * LIBRARY at toplevel of a compilation or a regular coqtop session * STRUCT (params,oldsenv) : inside a local module, with module parameters [params] and earlier environment [oldsenv] diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index cc1c44fe31..c9a1f0def5 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -122,11 +122,10 @@ let engage () = let set_batch_mode () = batch_mode := true let toplevel_default_name = DirPath.make [Id.of_string "Top"] -let toplevel_name = ref (Some toplevel_default_name) +let toplevel_name = ref toplevel_default_name let set_toplevel_name dir = if DirPath.is_empty dir then error "Need a non empty toplevel module name"; - toplevel_name := Some dir -let unset_toplevel_name () = toplevel_name := None + toplevel_name := dir let remove_top_ml () = Mltop.remove () @@ -556,7 +555,6 @@ let parse_args arglist = if Coq_config.no_native_compiler then warning "Native compilation was disabled at configure time." else native_compiler := true - |"-notop" -> unset_toplevel_name () |"-output-context" -> output_context := true |"-profile-ltac" -> Flags.profile_ltac := true |"-q" -> no_load_rc () @@ -628,7 +626,7 @@ let init_toplevel arglist = engage (); if (not !batch_mode || List.is_empty !compile_list) && Global.env_is_initial () - then Option.iter Declaremods.start_library !toplevel_name; + then Declaremods.start_library !toplevel_name; init_library_roots (); load_vernac_obj (); require (); diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 38ceacf5ec..66f782ffbe 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -30,7 +30,6 @@ let print_usage_channel co command = \n -R dir coqdir recursively map physical dir to logical coqdir\ \n -Q dir coqdir map physical dir to logical coqdir\ \n -top coqdir set the toplevel name to be coqdir instead of Top\ -\n -notop set the toplevel name to be the empty logical path\ \n -exclude-dir f exclude subdirectories named f for option -R\ \n\ \n -noinit start without loading the Init library\ -- cgit v1.2.3 From 581b8d52fe93d666045d4878a1b48dad916451ec Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 04:09:33 +0100 Subject: [safe_string] kernel/cemitcodes The `emitcodes` string type was used in both a functional and an imperative way, so we have to handle it with care in order to preserve the previous optimizations and semantics. --- kernel/cemitcodes.ml | 39 +++++++++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index ad7a41a347..a0a13174ff 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -24,33 +24,45 @@ type reloc_info = type patch = reloc_info * int let patch_char4 buff pos c1 c2 c3 c4 = - String.unsafe_set buff pos c1; - String.unsafe_set buff (pos + 1) c2; - String.unsafe_set buff (pos + 2) c3; - String.unsafe_set buff (pos + 3) c4 + Bytes.unsafe_set buff pos c1; + Bytes.unsafe_set buff (pos + 1) c2; + Bytes.unsafe_set buff (pos + 2) c3; + Bytes.unsafe_set buff (pos + 3) c4 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)) +(* val patch_int : emitcodes -> ((\*pos*\)int * int) list -> emitcodes *) 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 buff = Bytes.of_string buff in let () = List.iter (fun p -> patch buff p) patches in - buff + (* Note: we follow the apporach suggested by Gabriel Scherer in + PR#136 here, and use unsafe as we own buff. + + The crux of the question that avoids defining emitcodes just as a + Byte.t is the call to hcons in to_memory below. Even if disabling + this optimization has no visible time impact, test data shows + that the optimization is indeed triggered quite often so we + choose ugliness over altering the semantics. + + Handle with care. + *) + Bytes.unsafe_to_string buff (* Buffering of bytecode *) -let out_buffer = ref(String.create 1024) +let out_buffer = ref(Bytes.create 1024) and out_position = ref 0 let out_word b1 b2 b3 b4 = let p = !out_position in - if p >= String.length !out_buffer then begin - let len = String.length !out_buffer in + if p >= Bytes.length !out_buffer then begin + let len = Bytes.length !out_buffer in let new_len = if len <= Sys.max_string_length / 2 then 2 * len @@ -58,8 +70,8 @@ let out_word b1 b2 b3 b4 = if len = Sys.max_string_length then invalid_arg "String.create" (* Pas la bonne exception .... *) else Sys.max_string_length in - let new_buffer = String.create new_len in - String.blit !out_buffer 0 new_buffer 0 len; + let new_buffer = Bytes.create new_len in + Bytes.blit !out_buffer 0 new_buffer 0 len; out_buffer := new_buffer end; patch_char4 !out_buffer p (Char.unsafe_chr b1) @@ -305,7 +317,7 @@ let init () = label_table := Array.make 16 (Label_undefined []); reloc_info := [] -type emitcodes = string +type emitcodes = String.t let length = String.length @@ -369,9 +381,8 @@ let to_memory (init_code, fun_code, fv) = init(); emit init_code; 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 = Bytes.sub_string !out_buffer 0 !out_position in let code = CString.hcons code in let reloc = List.rev !reloc_info in Array.iter (fun lbl -> -- cgit v1.2.3 From 7601ddc3500cae2da39883b339951205be19c41d Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 03:48:50 +0100 Subject: [safe_string] library/nameops We add a more convenient API to create identifiers from mutable strings. We cannot solve the `String.copy` deprecation problem until we enable `-safe-string`. --- kernel/names.ml | 5 +++++ kernel/names.mli | 1 + library/nameops.ml | 20 ++++++++++---------- 3 files changed, 16 insertions(+), 10 deletions(-) diff --git a/kernel/names.ml b/kernel/names.ml index 1f138581cc..831b6ad46e 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -50,6 +50,11 @@ struct | None -> true | Some _ -> false + let of_bytes s = + let s = Bytes.to_string s in + check_soft s; + String.hcons s + let of_string s = let () = check_soft s in let s = String.copy s in diff --git a/kernel/names.mli b/kernel/names.mli index 6b0a80625b..be9b9422b7 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -43,6 +43,7 @@ sig (** Check that a string may be converted to an identifier. @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) + val of_bytes : bytes -> t val of_string : string -> t (** Converts a string into an identifier. @raise UserError if the string is not valid, or echo a warning if it contains invalid identifier characters. diff --git a/library/nameops.ml b/library/nameops.ml index 6020db33d9..098f5112fd 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -61,7 +61,7 @@ let make_ident sa = function if c < code_of_0 || c > code_of_9 then sa ^ (string_of_int n) else sa ^ "_" ^ (string_of_int n) in Id.of_string s - | None -> Id.of_string (String.copy sa) + | None -> Id.of_string sa let root_of_id id = let suffixstart = cut_ident true id in @@ -92,20 +92,20 @@ let increment_subscript id = add (carrypos-1) end else begin - let newid = String.copy id in - String.fill newid (carrypos+1) (len-1-carrypos) '0'; - newid.[carrypos] <- Char.chr (Char.code c + 1); + let newid = Bytes.of_string id in + Bytes.fill newid (carrypos+1) (len-1-carrypos) '0'; + Bytes.set newid carrypos (Char.chr (Char.code c + 1)); newid end else begin - let newid = id^"0" in + let newid = Bytes.of_string (id^"0") in if carrypos < len-1 then begin - String.fill newid (carrypos+1) (len-1-carrypos) '0'; - newid.[carrypos+1] <- '1' + Bytes.fill newid (carrypos+1) (len-1-carrypos) '0'; + Bytes.set newid (carrypos+1) '1' end; newid end - in Id.of_string (add (len-1)) + in Id.of_bytes (add (len-1)) let has_subscript id = let id = Id.to_string id in @@ -113,9 +113,9 @@ let has_subscript id = let forget_subscript id = let numstart = cut_ident false id in - let newid = String.make (numstart+1) '0' in + let newid = Bytes.make (numstart+1) '0' in String.blit (Id.to_string id) 0 newid 0 numstart; - (Id.of_string newid) + (Id.of_bytes newid) let add_suffix id s = Id.of_string (Id.to_string id ^ s) let add_prefix s id = Id.of_string (s ^ Id.to_string id) -- cgit v1.2.3 From 7228a44c08f658171ba924bc7d3807d71c5a2349 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 03:17:09 +0100 Subject: [safe_string] interp/dumpglob No functional change. --- interp/dumpglob.ml | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index b020f89457..9f549b0c0f 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -173,32 +173,33 @@ let cook_notation df sc = (* - all single quotes in terminal tokens are doubled *) (* - characters < 32 are represented by '^A, '^B, '^C, etc *) (* The output is decoded in function Index.prepare_entry of coqdoc *) - let ntn = String.make (String.length df * 5) '_' in + let ntn = Bytes.make (String.length df * 5) '_' in let j = ref 0 in let l = String.length df - 1 in let i = ref 0 in + let open Bytes in (* Bytes.set *) while !i <= l do assert (df.[!i] != ' '); if df.[!i] == '_' && (Int.equal !i l || df.[!i+1] == ' ') then (* Next token is a non-terminal *) - (ntn.[!j] <- 'x'; incr j; incr i) + (set ntn !j 'x'; incr j; incr i) else begin (* Next token is a terminal *) - ntn.[!j] <- '\''; incr j; + set ntn !j '\''; incr j; while !i <= l && df.[!i] != ' ' do if df.[!i] < ' ' then let c = char_of_int (int_of_char 'A' + int_of_char df.[!i] - 1) in (String.blit ("'^" ^ String.make 1 c) 0 ntn !j 3; j := !j+3; incr i) else begin - if df.[!i] == '\'' then (ntn.[!j] <- '\''; incr j); - ntn.[!j] <- df.[!i]; incr j; incr i + if df.[!i] == '\'' then (set ntn !j '\''; incr j); + set ntn !j df.[!i]; incr j; incr i end done; - ntn.[!j] <- '\''; incr j + set ntn !j '\''; incr j end; - if !i <= l then (ntn.[!j] <- '_'; incr j; incr i) + if !i <= l then (set ntn !j '_'; incr j; incr i) done; - let df = String.sub ntn 0 !j in + let df = Bytes.sub_string ntn 0 !j in match sc with Some sc -> ":" ^ sc ^ ":" ^ df | _ -> "::" ^ df let dump_notation_location posl df (((path,secpath),_),sc) = -- cgit v1.2.3 From f4c3d91fe94b9ec221f87365aac06d1884b9aaf8 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 14:56:13 +0100 Subject: [safe-string] parsing/cLexer No functional change. --- parsing/cLexer.ml4 | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 02a720d2d9..72bd11e030 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -240,18 +240,19 @@ let unfreeze tt = (token_tree := tt) (* The string buffering machinery *) -let buff = ref (String.create 80) +let buff = ref (Bytes.create 80) let store len x = - if len >= String.length !buff then - buff := !buff ^ String.create (String.length !buff); - !buff.[len] <- x; + let open Bytes in + if len >= length !buff then + buff := cat !buff (create (length !buff)); + set !buff len x; succ len let rec nstore n len cs = if n>0 then nstore (n-1) (store len (Stream.next cs)) cs else len -let get_buff len = String.sub !buff 0 len +let get_buff len = Bytes.sub_string !buff 0 len (* The classical lexer: idents, numbers, quoted strings, comments *) @@ -382,6 +383,7 @@ let push_char c = real_push_char c let push_string s = Buffer.add_string current_comment s +let push_bytes s = Buffer.add_bytes current_comment s let null_comment s = let rec null i = @@ -716,13 +718,13 @@ let strip s = in if len == String.length s then s else - let s' = String.create len in + let s' = Bytes.create len in let rec loop i i' = if i == String.length s then s' else if s.[i] == ' ' then loop (i + 1) i' - else begin s'.[i'] <- s.[i]; loop (i + 1) (i' + 1) end + else begin Bytes.set s' i' s.[i]; loop (i + 1) (i' + 1) end in - loop 0 0 + Bytes.to_string (loop 0 0) let terminal s = let s = strip s in -- cgit v1.2.3 From 40fe374710c7d701e539dd92c085dfb6b244ffae Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 03:12:05 +0100 Subject: [safe_string] toplevel/coqloop No functional change, even if we could optimize `blanch_utf8_string` a bit more by using `String.init`. --- toplevel/coqloop.ml | 36 ++++++++++++++++++------------------ toplevel/coqloop.mli | 2 +- 2 files changed, 19 insertions(+), 19 deletions(-) diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index e9771cfa40..0dfd06726a 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -20,7 +20,7 @@ let top_stderr x = msg_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft x type input_buffer = { mutable prompt : unit -> string; - mutable str : string; (* buffer of already read characters *) + mutable str : Bytes.t; (* buffer of already read characters *) mutable len : int; (* number of chars in the buffer *) mutable bols : int list; (* offsets in str of beginning of lines *) mutable tokens : Gram.coq_parsable; (* stream of tokens *) @@ -28,9 +28,9 @@ type input_buffer = { (* Double the size of the buffer. *) -let resize_buffer ibuf = - let nstr = String.create (2 * String.length ibuf.str + 1) in - String.blit ibuf.str 0 nstr 0 (String.length ibuf.str); +let resize_buffer ibuf = let open Bytes in + let nstr = create (2 * length ibuf.str + 1) in + blit ibuf.str 0 nstr 0 (length ibuf.str); ibuf.str <- nstr (* Delete all irrelevant lines of the input buffer. Keep the last line @@ -40,7 +40,7 @@ let resynch_buffer ibuf = match ibuf.bols with | ll::_ -> let new_len = ibuf.len - ll in - String.blit ibuf.str ll ibuf.str 0 new_len; + Bytes.blit ibuf.str ll ibuf.str 0 new_len; ibuf.len <- new_len; ibuf.bols <- []; ibuf.start <- ibuf.start + ll @@ -65,8 +65,8 @@ let prompt_char ic ibuf count = try let c = input_char ic in if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols; - if ibuf.len == String.length ibuf.str then resize_buffer ibuf; - ibuf.str.[ibuf.len] <- c; + if ibuf.len == Bytes.length ibuf.str then resize_buffer ibuf; + Bytes.set ibuf.str ibuf.len c; ibuf.len <- ibuf.len + 1; Some c with End_of_file -> @@ -75,7 +75,7 @@ let prompt_char ic ibuf count = (* Reinitialize the char stream (after a Drop) *) let reset_input_buffer ic ibuf = - ibuf.str <- ""; + ibuf.str <- Bytes.empty; ibuf.len <- 0; ibuf.bols <- []; ibuf.tokens <- Gram.parsable (Stream.from (prompt_char ic ibuf)); @@ -109,19 +109,19 @@ let dotted_location (b,e) = else (String.make (e-b-1) '.', " ") -let blanch_utf8_string s bp ep = - let s' = String.make (ep-bp) ' ' in +let blanch_utf8_string s bp ep = let open Bytes in + let s' = make (ep-bp) ' ' in let j = ref 0 in for i = bp to ep - 1 do - let n = Char.code s.[i] in + let n = Char.code (get s i) in (* Heuristic: assume utf-8 chars are printed using a single fixed-size char and therefore contract all utf-8 code into one space; in any case, preserve tabulation so that its effective interpretation in terms of spacing is preserved *) - if s.[i] == '\t' then s'.[!j] <- '\t'; + if get s i == '\t' then set s' !j '\t'; if n < 0x80 || 0xC0 <= n then incr j done; - String.sub s' 0 !j + Bytes.sub_string s' 0 !j let print_highlight_location ib loc = let (bp,ep) = Loc.unloc loc in @@ -132,17 +132,17 @@ let print_highlight_location ib loc = | ([],(bl,el)) -> let shift = blanch_utf8_string ib.str bl bp in let span = String.length (blanch_utf8_string ib.str bp ep) in - (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++ + (str"> " ++ str(Bytes.sub_string ib.str bl (el-bl-1)) ++ fnl () ++ str"> " ++ str(shift) ++ str(String.make span '^')) | ((b1,e1)::ml,(bn,en)) -> let (d1,s1) = dotted_location (b1,bp) in let (dn,sn) = dotted_location (ep,en) in let l1 = (str"> " ++ str d1 ++ str s1 ++ - str(String.sub ib.str bp (e1-bp))) in + str(Bytes.sub_string ib.str bp (e1-bp))) in let li = prlist (fun (bi,ei) -> - (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in - let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++ + (str"> " ++ str(Bytes.sub_string ib.str bi (ei-bi)))) ml in + let ln = (str"> " ++ str(Bytes.sub_string ib.str bn (ep-bn)) ++ str sn ++ str dn) in (l1 ++ li ++ ln) in @@ -220,7 +220,7 @@ let top_buffer = ^ emacs_prompt_endstring() in { prompt = pr; - str = ""; + str = Bytes.empty; len = 0; bols = []; tokens = Gram.parsable (Stream.of_list []); diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index e40353e0f9..d248f2f706 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -15,7 +15,7 @@ open Pp type input_buffer = { mutable prompt : unit -> string; - mutable str : string; (** buffer of already read characters *) + mutable str : Bytes.t; (** buffer of already read characters *) mutable len : int; (** number of chars in the buffer *) mutable bols : int list; (** offsets in str of begining of lines *) mutable tokens : Pcoq.Gram.coq_parsable; (** stream of tokens *) -- cgit v1.2.3 From 3757311c70020448bc8c834b129a7305df82bcd9 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 03:33:49 +0100 Subject: [safe_string] toplevel/vernac No functional changes, only a minor copy on a deprecated output option. --- toplevel/vernac.ml | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index f914f83b9b..b73321c005 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -108,7 +108,7 @@ let verbose_phrase verbch loc = let s = Bytes.create len in seek_in ch (fst loc); really_input ch s 0 len; - Feedback.msg_notice (str s) + Feedback.msg_notice (str (Bytes.to_string s)) | None -> () exception End_of_input @@ -126,7 +126,7 @@ let chan_beautify = ref stdout let beautify_suffix = ".beautified" let set_formatter_translator ch = - let out s b e = output ch s b e in + let out s b e = output_substring ch s b e in Format.set_formatter_output_functions out (fun () -> flush ch); Format.set_max_boxes max_int @@ -161,13 +161,11 @@ let pr_new_syntax po loc chan_beautify ocom = let pp_cmd_header loc com = let shorten s = try (String.sub s 0 30)^"..." with _ -> s in - let noblank s = - for i = 0 to Bytes.length s - 1 do - match s.[i] with - | ' ' | '\n' | '\t' | '\r' -> s.[i] <- '~' - | _ -> () - done; - s + let noblank s = String.map (fun c -> + match c with + | ' ' | '\n' | '\t' | '\r' -> '~' + | x -> x + ) s in let (start,stop) = Loc.unloc loc in let safe_pr_vernac x = -- cgit v1.2.3 From fa895511eaa1c374c72ea2096c1dfb33dfbee379 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 13:36:52 +0100 Subject: [safe-string] ltac/profile_ltac No functional change, one extra copy introduced but it seems hard to avoid. --- plugins/ltac/profile_ltac.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 2514ededb0..58123f63ef 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -257,7 +257,7 @@ let string_of_call ck = (Pptactic.pr_glob_tactic (Global.env ()) te) ) in - for i = 0 to String.length s - 1 do if s.[i] = '\n' then s.[i] <- ' ' done; + let s = String.map (fun c -> if c = '\n' then ' ' else c) s in let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in CString.strip s -- cgit v1.2.3 From 6b78d0602d46520ed1bd0cfbef120de3b06ca826 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 13:32:46 +0100 Subject: [safe-string] plugins/extraction No functional change. --- plugins/extraction/common.ml | 5 +---- plugins/extraction/scheme.ml | 6 +----- plugins/extraction/table.ml | 4 +--- 3 files changed, 3 insertions(+), 12 deletions(-) diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index de97ba97c3..0a591e786f 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -91,10 +91,7 @@ let begins_with_CoqXX s = let unquote s = if lang () != Scheme then s - else - let s = String.copy s in - for i=0 to String.length s - 1 do if s.[i] == '\'' then s.[i] <- '~' done; - s + else String.map (fun c -> if c == '\'' then '~' else c) s let rec qualify delim = function | [] -> assert false diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index a6309e61f9..8d0cc4a0db 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -40,11 +40,7 @@ let preamble _ comment _ usf = (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ()) let pr_id id = - let s = Id.to_string id in - for i = 0 to String.length s - 1 do - if s.[i] == '\'' then s.[i] <- '~' - done; - str s + str @@ String.map (fun c -> if c == '\'' then '~' else c) (Id.to_string id) let paren = pp_par true diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 5e7d810c93..d6a334c5fe 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -773,9 +773,7 @@ let file_of_modfile mp = | MPfile f -> Id.to_string (List.hd (DirPath.repr f)) | _ -> assert false in - let s = String.copy (string_of_modfile mp) in - if s.[0] != s0.[0] then s.[0] <- s0.[0]; - s + String.mapi (fun i c -> if i = 0 then s0.[0] else c) (string_of_modfile mp) let add_blacklist_entries l = blacklist_table := -- cgit v1.2.3 From facf0520a47603d2679508136cbed43def0744cc Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 13:46:07 +0100 Subject: [safe-string] ide No functional change, one extra copy introduced but it seems hard to avoid. --- ide/coqide.ml | 4 ++-- ide/ideutils.ml | 25 ++++++++++++++----------- 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/ide/coqide.ml b/ide/coqide.ml index 450bfcdfb1..eec829f345 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -887,8 +887,8 @@ let alpha_items menu_name item_name l = | [] -> () | [s] -> mk_item s | s::_ as ll -> - let name = item_name^" "^(String.make 1 s.[0]) in - let label = "_@..." in label.[1] <- s.[0]; + let name = Printf.sprintf "%s %c" item_name s.[0] in + let label = Printf.sprintf "_%c..." s.[0] in item name ~label menu_name; List.iter mk_item ll in diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 06a1327320..c3a2807967 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -294,18 +294,20 @@ let coqtop_path () = match cmd_coqtop#get with | Some s -> s | None -> - let prog = String.copy Sys.executable_name in try - let pos = String.length prog - 6 in - let i = Str.search_backward (Str.regexp_string "coqide") prog pos + let old_prog = Sys.executable_name in + let pos = String.length old_prog - 6 in + let i = Str.search_backward (Str.regexp_string "coqide") old_prog pos in - String.blit "coqtop" 0 prog i 6; - if Sys.file_exists prog then prog + let new_prog = Bytes.of_string old_prog in + Bytes.blit_string "coqtop" 0 new_prog i 6; + let new_prog = Bytes.to_string new_prog in + if Sys.file_exists new_prog then new_prog else let in_macos_bundle = Filename.concat - (Filename.dirname prog) - (Filename.concat "../Resources/bin" (Filename.basename prog)) + (Filename.dirname new_prog) + (Filename.concat "../Resources/bin" (Filename.basename new_prog)) in if Sys.file_exists in_macos_bundle then in_macos_bundle else "coqtop" with Not_found -> "coqtop" @@ -357,7 +359,7 @@ let stat f = let maxread = 4096 -let read_string = String.create maxread +let read_string = Bytes.create maxread let read_buffer = Buffer.create maxread (** Read the content of file [f] and add it to buffer [b]. @@ -368,7 +370,7 @@ let read_file name buf = let len = ref 0 in try while len := input ic read_string 0 maxread; !len > 0 do - Buffer.add_substring buf read_string 0 !len + Buffer.add_subbytes buf read_string 0 !len done; close_in ic with e -> close_in ic; raise e @@ -381,8 +383,9 @@ let read_file name buf = let io_read_all chan = Buffer.clear read_buffer; let read_once () = - let len = Glib.Io.read_chars ~buf:read_string ~pos:0 ~len:maxread chan in - Buffer.add_substring read_buffer read_string 0 len + (* XXX: Glib.Io must be converted to bytes / -safe-string upstream *) + let len = Glib.Io.read_chars ~buf:(Bytes.unsafe_to_string read_string) ~pos:0 ~len:maxread chan in + Buffer.add_subbytes read_buffer read_string 0 len in begin try while true do read_once () done -- cgit v1.2.3 From 92579449f62f0fd7699b0b447f3aee0d82d1b5c3 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 13:48:47 +0100 Subject: [safe-string] tools No functional changes. --- tools/coq_makefile.ml | 7 ++----- tools/coqdoc/alpha.ml | 7 +------ tools/coqdoc/index.ml | 4 ++-- tools/coqworkmgr.ml | 9 ++++++--- 4 files changed, 11 insertions(+), 16 deletions(-) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 4842a89151..23479aee52 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -125,12 +125,9 @@ let physical_dir_of_logical_dir ldir = let le = String.length ldir - 1 in let pdir = if le >= 0 && ldir.[le] = '.' then String.sub ldir 0 (le - 1) - else String.copy ldir + else ldir in - for i = 0 to le - 1 do - if pdir.[i] = '.' then pdir.[i] <- '/'; - done; - pdir + String.map (fun c -> if c = '.' then '/' else c) pdir let standard opt = print "byte:\n"; diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml index f817ed5a2a..3d92c9356b 100644 --- a/tools/coqdoc/alpha.ml +++ b/tools/coqdoc/alpha.ml @@ -26,12 +26,7 @@ let norm_char c = if !latin1 then norm_char_latin1 c else Char.uppercase c -let norm_string s = - let u = String.copy s in - for i = 0 to String.length s - 1 do - u.[i] <- norm_char s.[i] - done; - u +let norm_string = String.map (fun s -> norm_char s) let compare_char c1 c2 = match norm_char c1, norm_char c2 with | ('A'..'Z' as c1), ('A'..'Z' as c2) -> compare c1 c2 diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index 9be791a8de..c9cb676e98 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -197,7 +197,7 @@ let prepare_entry s = function let h = try String.index_from s 0 ':' with _ -> err () in let i = try String.index_from s (h+1) ':' with _ -> err () in let sc = String.sub s (h+1) (i-h-1) in - let ntn = String.make (String.length s - i) ' ' in + let ntn = Bytes.make (String.length s - i) ' ' in let k = ref 0 in let j = ref (i+1) in let quoted = ref false in @@ -220,7 +220,7 @@ let prepare_entry s = function end; incr j done; - let ntn = String.sub ntn 0 !k in + let ntn = Bytes.sub_string ntn 0 !k in if sc = "" then ntn else ntn ^ " (" ^ sc ^ ")" | _ -> s diff --git a/tools/coqworkmgr.ml b/tools/coqworkmgr.ml index d7bdf907a2..b8e69d6c6d 100644 --- a/tools/coqworkmgr.ml +++ b/tools/coqworkmgr.ml @@ -72,10 +72,13 @@ let really_read_fd fd s off len = let raw_input_line fd = try let b = Buffer.create 80 in - let s = String.make 1 '\000' in - while s <> "\n" do + let s = Bytes.make 1 '\000' in + let endl = Bytes.of_string "\n" in + let endr = Bytes.of_string "\r" in + while Bytes.compare s endl <> 0 do really_read_fd fd s 0 1; - if s <> "\n" && s <> "\r" then Buffer.add_string b s; + if Bytes.compare s endl <> 0 && Bytes.compare s endr <> 0 + then Buffer.add_bytes b s; done; Buffer.contents b with Unix.Unix_error _ -> raise End_of_file -- cgit v1.2.3 From 5e2574cbef1ba132aacc73b4a079cc0b5584f589 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 14:57:59 +0100 Subject: [safe-string] Enable -safe-string ! We now build Coq with `-safe-string`, which enforces functional use of the `string` datatype. Coq was pretty safe in these regard so only a few tweaks were needed. - coq_makefile: build plugins with -safe-string too. - `names.ml`: we remove `String.copy` uses, as they are not needed. --- .merlin | 2 +- configure.ml | 9 ++++++++- kernel/names.ml | 4 +--- tools/coq_makefile.ml | 14 +++++++------- 4 files changed, 17 insertions(+), 12 deletions(-) diff --git a/.merlin b/.merlin index bda18d5490..394db528d4 100644 --- a/.merlin +++ b/.merlin @@ -1,4 +1,4 @@ -FLG -rectypes -thread +FLG -rectypes -thread -safe-string S ltac B ltac diff --git a/configure.ml b/configure.ml index 82ce931d67..dfc6724a2d 100644 --- a/configure.ml +++ b/configure.ml @@ -264,6 +264,10 @@ module Prefs = struct let debug = ref true let profile = ref false let annotate = ref false + (* Note, disabling this should be OK, but be careful with the + sharing invariants. + *) + let safe_string = 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 @@ -386,6 +390,9 @@ let coq_annotate_flag = then if program_in_path "ocamlmerlin" then "-bin-annot" else "-annot" else "" +let coq_safe_string = + if !Prefs.safe_string then "-safe-string" else "" + let cflags = "-Wall -Wno-unused -g -O2" (** * Architecture *) @@ -1118,7 +1125,7 @@ let write_makefile f = pr "CAMLHLIB=%S\n\n" camllib; pr "# Caml link command and Caml make top command\n"; pr "# Caml flags\n"; - pr "CAMLFLAGS=-rectypes %s\n" coq_annotate_flag; + pr "CAMLFLAGS=-rectypes %s %s\n" coq_annotate_flag coq_safe_string; pr "# User compilation flag\n"; pr "USERFLAGS=\n\n"; pr "# Flags for GCC\n"; diff --git a/kernel/names.ml b/kernel/names.ml index 831b6ad46e..ee8d838da1 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -57,15 +57,13 @@ struct let of_string s = let () = check_soft s in - let s = String.copy s in String.hcons s let of_string_soft s = let () = check_soft ~warn:false s in - let s = String.copy s in String.hcons s - let to_string id = String.copy id + let to_string id = id let print id = str id diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 23479aee52..4dfb7af6aa 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -521,10 +521,10 @@ let variables is_install opt (args,defs) = List.iter (fun c -> print " \\ -I \"$(COQLIB)/"; print c; print "\"") Coq_config.plugins_dirs; print "\n"; print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n\n"; - print "CAMLC?=$(OCAMLFIND) ocamlc -c -rectypes -thread\n"; - print "CAMLOPTC?=$(OCAMLFIND) opt -c -rectypes -thread\n"; - print "CAMLLINK?=$(OCAMLFIND) ocamlc -rectypes -thread\n"; - print "CAMLOPTLINK?=$(OCAMLFIND) opt -rectypes -thread\n"; + print "CAMLC?=$(OCAMLFIND) ocamlc -c -rectypes -thread -safe-string\n"; + print "CAMLOPTC?=$(OCAMLFIND) opt -c -rectypes -thread -safe-string\n"; + print "CAMLLINK?=$(OCAMLFIND) ocamlc -rectypes -thread -safe-string\n"; + print "CAMLOPTLINK?=$(OCAMLFIND) opt -rectypes -thread -safe-string\n"; print "CAMLDEP?=$(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack\n"; print "CAMLLIB?=$(shell $(OCAMLFIND) printconf stdlib)\n"; print "GRAMMARS?=grammar.cma\n"; @@ -764,9 +764,9 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other begin print "mlihtml: $(MLIFILES:.mli=.cmi)\n"; print "\t mkdir $@ || rm -rf $@/*\n"; - print "\t$(OCAMLFIND) ocamldoc -html -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; + print "\t$(OCAMLFIND) ocamldoc -html -safe-string -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; print "all-mli.tex: $(MLIFILES:.mli=.cmi)\n"; - print "\t$(OCAMLFIND) ocamldoc -latex -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; + print "\t$(OCAMLFIND) ocamldoc -latex -safe-string -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; end; if !some_vfile then begin @@ -882,7 +882,7 @@ let check_overlapping_include (_,inc_i,inc_r) = *) let merlin targets (ml_inc,_,_) = print ".merlin:\n"; - print "\t@echo 'FLG -rectypes' > .merlin\n" ; + print "\t@echo 'FLG -rectypes -safe-string' > .merlin\n" ; List.iter (fun c -> printf "\t@echo \"B $(COQLIB)%s\" >> .merlin\n" c) lib_dirs ; -- cgit v1.2.3 From 347827ef4ea72048762c1677f37cb716109a5d9c Mon Sep 17 00:00:00 2001 From: Valentin Robert Date: Thu, 16 Feb 2017 14:37:47 -0800 Subject: doc: fix a French-ism --- doc/refman/RefMan-syn.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index 21c39de967..ce662eb208 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -114,7 +114,7 @@ Notation "A \/ B" := (or A B) (at level 85, right associativity). By default, a notation is considered non associative, but the precedence level is mandatory (except for special cases whose level is -canonical). The level is either a number or the mention {\tt next +canonical). The level is either a number or the phrase {\tt next level} whose meaning is obvious. The list of levels already assigned is on Figure~\ref{init-notations}. -- cgit v1.2.3 From 671e5ad1795b2606a5da9c65758fb0d337c4d14e Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 13 Mar 2017 23:06:33 +0100 Subject: Attempt to improve error message when "apply in" fail. - Adding a better location in the "apply" on the fly pattern. - Printing statement of lemma and of hypothesis. Was suggested by discussion at wish report #5390. --- intf/misctypes.mli | 2 +- plugins/ltac/g_tactic.ml4 | 5 +++-- plugins/ltac/tacintern.ml | 4 ++-- plugins/ltac/tacinterp.ml | 6 +++--- plugins/ltac/tacsubst.ml | 4 ++-- printing/miscprint.ml | 2 +- tactics/tactics.ml | 29 +++++++++++++++++++++-------- 7 files changed, 33 insertions(+), 19 deletions(-) diff --git a/intf/misctypes.mli b/intf/misctypes.mli index e4f595ac4a..33dc2a335c 100644 --- a/intf/misctypes.mli +++ b/intf/misctypes.mli @@ -28,7 +28,7 @@ and 'constr intro_pattern_action_expr = | IntroWildcard | IntroOrAndPattern of 'constr or_and_intro_pattern_expr | IntroInjection of (Loc.t * 'constr intro_pattern_expr) list - | IntroApplyOn of 'constr * (Loc.t * 'constr intro_pattern_expr) + | IntroApplyOn of (Loc.t * 'constr) * (Loc.t * 'constr intro_pattern_expr) | IntroRewrite of bool and 'constr or_and_intro_pattern_expr = | IntroOrPattern of (Loc.t * 'constr intro_pattern_expr) list list diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 index 685c07c9a8..fa01baab75 100644 --- a/plugins/ltac/g_tactic.ml4 +++ b/plugins/ltac/g_tactic.ml4 @@ -325,8 +325,9 @@ GEXTEND Gram 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 - IntroAction (IntroApplyOn (c,(loc,pat))) in + let loc1 = Constrexpr_ops.constr_loc c in + let loc = Loc.merge loc0 loc1 in + IntroAction (IntroApplyOn ((loc1,c),(loc,pat))) in !@loc, List.fold_right f l pat ] ] ; simple_intropattern_closed: diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 1a8f26b264..3f83f104e9 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -248,8 +248,8 @@ and intern_intro_pattern_action lf ist = function | 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) + | IntroApplyOn ((loc,c),pat) -> + IntroApplyOn ((loc,intern_constr ist c), intern_intro_pattern lf ist pat) and intern_or_and_intro_pattern lf ist = function | IntroAndPattern l -> diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index aa646aa517..61a70d712d 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -520,7 +520,7 @@ let rec intropattern_ids (loc,pat) = match pat with 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 + | IntroAction (IntroApplyOn ((_,c),pat)) -> intropattern_ids pat | IntroNaming (IntroAnonymous | IntroFresh _) | IntroAction (IntroWildcard | IntroRewrite _) | IntroForthcoming _ -> [] @@ -913,14 +913,14 @@ and interp_intro_pattern_action ist env sigma = function | IntroInjection l -> let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in sigma, IntroInjection l - | IntroApplyOn (c,ipat) -> + | IntroApplyOn ((loc,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) + sigma, IntroApplyOn ((loc,c),ipat) | IntroWildcard | IntroRewrite _ as x -> sigma, x and interp_or_and_intro_pattern ist env sigma = function diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index b09bdda65c..fe3a9f3b2a 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -51,8 +51,8 @@ let rec subst_intro_pattern subst = function | 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) + | IntroApplyOn ((loc,t),pat) -> + IntroApplyOn ((loc,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) diff --git a/printing/miscprint.ml b/printing/miscprint.ml index 7b2c5695fd..360843711c 100644 --- a/printing/miscprint.ml +++ b/printing/miscprint.ml @@ -28,7 +28,7 @@ and pr_intro_pattern_action prc = function | IntroInjection pl -> str "[=" ++ hv 0 (prlist_with_sep spc (pr_intro_pattern prc) pl) ++ str "]" - | IntroApplyOn (c,pat) -> pr_intro_pattern prc pat ++ str "%" ++ prc c + | IntroApplyOn ((_,c),pat) -> pr_intro_pattern prc pat ++ str "%" ++ prc c | IntroRewrite true -> str "->" | IntroRewrite false -> str "<-" diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 6205bd1092..84d09d8330 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1815,24 +1815,37 @@ let find_matching_clause unifier clause = with NotExtensibleClause -> failwith "Cannot apply" in find clause +exception UnableToApply + 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."; + if List.is_empty ordered_metas then raise UnableToApply; let f mv = 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 - with Not_found -> error "Unable to unify." + with Not_found -> raise UnableToApply + +let explain_unable_to_apply_lemma loc env sigma thm innerclause = + user_err ~loc (hov 0 + (Pp.str "Unable to apply lemma of type" ++ brk(1,1) ++ + Pp.quote (Printer.pr_lconstr_env env sigma thm) ++ spc() ++ + str "on hypothesis of type" ++ brk(1,1) ++ + Pp.quote (Printer.pr_lconstr_env innerclause.env innerclause.evd (clenv_type innerclause)) ++ + str ".")) -let apply_in_once_main flags innerclause env sigma (d,lbind) = +let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> - let e = CErrors.push e in + let e' = CErrors.push e in try aux (clenv_push_prod clause) - with NotExtensibleClause -> iraise e + with NotExtensibleClause -> + match e with + | UnableToApply -> explain_unable_to_apply_lemma loc env sigma thm innerclause + | _ -> iraise e' in aux (make_clenv_binding env sigma (d,thm) lbind) @@ -1852,7 +1865,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try - let clause = apply_in_once_main flags innerclause env sigma (c,lbind) in + let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in clenv_refine_in ~sidecond_first with_evars targetid id sigma clause (fun id -> Tacticals.New.tclTHENLIST [ @@ -2467,7 +2480,7 @@ and intro_pattern_action loc with_evars b style pat thin destopt tac id = intro_decomp_eq loc l' thin tac id | IntroRewrite l2r -> rewrite_hyp_then style with_evars thin l2r id (fun thin -> tac thin None []) - | IntroApplyOn (f,(loc,pat)) -> + | IntroApplyOn ((loc',f),(loc,pat)) -> let naming,tac_ipat = prepare_intros_loc loc with_evars (IntroIdentifier id) destopt pat in let doclear = @@ -2479,7 +2492,7 @@ and intro_pattern_action loc with_evars b style pat thin destopt tac id = let Sigma (c, sigma, p) = f.delayed env sigma in Sigma ((c, NoBindings), sigma, p) } in - apply_in_delayed_once false true true with_evars naming id (None,(loc,f)) + apply_in_delayed_once false true true with_evars naming id (None,(loc',f)) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) and prepare_intros_loc loc with_evars dft destopt = function -- cgit v1.2.3 From 2f3b7a1ee530f236a153c0971cd99680dcee9b10 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Sun, 19 Mar 2017 13:11:41 +0100 Subject: Add a forgotten (?) line to "theories/Logic/vo.itarget". The "theories/Logic/PropExtensionalityFacts.v" file was: - compiled - used in several places but not actually installed. This commit fixes that. --- theories/Logic/vo.itarget | 1 + 1 file changed, 1 insertion(+) diff --git a/theories/Logic/vo.itarget b/theories/Logic/vo.itarget index ef2709b472..8b0aa6691e 100644 --- a/theories/Logic/vo.itarget +++ b/theories/Logic/vo.itarget @@ -1,4 +1,5 @@ Berardi.vo +PropExtensionalityFacts.vo ChoiceFacts.vo ClassicalChoice.vo ClassicalDescription.vo -- cgit v1.2.3 From c318a983e078b6c729425f21526c6896ba55df09 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 13 Mar 2017 18:06:29 +0100 Subject: [future] Use eager evaluation for chaining values. The current future system is lazy when "chaining" (*) a resolved future, which implies that chaining with a resolved future will produce a non-resolved one. This misfeature interacts badly with the "purification" optimization, which in turn provokes a swarm of spurious state setting calls in real use. To solve this problem, we revert to the more natural semantics of respecting the evaluation semantics when mapping over a future, indeed respecting the previous resolution status. This commit solves a kind of _critical_ bug in the current system, with the particular bad path origination in `Future.split2` due to the following accumulation of circumstances: ``` split2 x -> chain x (fun x -> fst x) => let y = chain ~pure x (fun x -> fst x) in if is_over x && greedy then ignore(force ~pure y); y => [y <- Closure (fun x -> fst x)] ignore(force (Closure (fun x -> fst x))) => purify_future (force ~pure) (Closure (fun x -> fst x)) ``` and then, the test in `purify_future` fails, triggering the spurious state reset operation. This problem was first noted at https://sympa.inria.fr/sympa/arc/coqdev/2016-02/msg00081.html , and seems related to https://coq.inria.fr/bugs/show_bug.cgi?id=5382 We fix the problem by making chaining eager, but other solutions would be possible. Given that the main user of `chain` is `split2` which does `snd/fst`, I recommend this solution. The difference in calls to `unfreeze_state` is dramatic: ``` | File | Freeze Calls After | Freeze Calls Before | |----------------------------------------+--------------------+---------------------| | theories/Init/Notations.v | 0 | 0 | | theories/Init/Logic.v | 57 | 614 | | theories/Init/Datatypes.v | 13 | 132 | | theories/Init/Logic_Type.v | 7 | 57 | | theories/Init/Specif.v | 5 | 35 | | theories/Init/Nat.v | 0 | 0 | | theories/Init/Peano.v | 22 | 264 | | theories/Init/Wf.v | 8 | 89 | | theories/Init/Tactics.v | 2 | 24 | | theories/Init/Tauto.v | 0 | 0 | | theories/Init/Prelude.v | 0 | 0 | | Bool/Bool.v | 104 | 1220 | | Program/Basics.v | 0 | 0 | | Classes/Init.v | 0 | 0 | | Program/Tactics.v | 0 | 0 | | Relations/Relation_Definitions.v | 0 | 0 | | Classes/RelationClasses.v | 21 | 341 | | Classes/Morphisms.v | 47 | 689 | | Classes/CRelationClasses.v | 18 | 245 | | Classes/CMorphisms.v | 50 | 587 | | Classes/Morphisms_Prop.v | 3 | 127 | | Classes/Equivalence.v | 6 | 105 | | Classes/SetoidTactics.v | 0 | 0 | | Setoids/Setoid.v | 4 | 33 | | Structures/Equalities.v | 8 | 93 | | Relations/Relation_Operators.v | 0 | 0 | | Relations/Operators_Properties.v | 35 | 627 | | Relations/Relations.v | 2 | 24 | | Structures/Orders.v | 12 | 148 | | Numbers/NumPrelude.v | 0 | 0 | | Structures/OrdersTac.v | 13 | 234 | | Structures/OrdersFacts.v | 73 | 931 | | Structures/GenericMinMax.v | 82 | 1294 | | Numbers/NatInt/NZAxioms.v | 0 | 0 | | Numbers/NatInt/NZBase.v | 7 | 87 | | Numbers/NatInt/NZAdd.v | 14 | 168 | | Numbers/NatInt/NZMul.v | 12 | 144 | | Logic/Decidable.v | 28 | 336 | | Numbers/NatInt/NZOrder.v | 81 | 1174 | | Numbers/NatInt/NZAddOrder.v | 24 | 288 | | Numbers/NatInt/NZMulOrder.v | 46 | 552 | | Numbers/NatInt/NZParity.v | 35 | 420 | | Numbers/NatInt/NZPow.v | 29 | 348 | | Numbers/NatInt/NZSqrt.v | 54 | 673 | | Numbers/NatInt/NZLog.v | 64 | 797 | | Numbers/NatInt/NZDiv.v | 49 | 588 | | Numbers/NatInt/NZGcd.v | 36 | 432 | | Numbers/NatInt/NZBits.v | 0 | 0 | | Numbers/Natural/Abstract/NAxioms.v | 0 | 0 | | Numbers/NatInt/NZProperties.v | 0 | 0 | | Numbers/Natural/Abstract/NBase.v | 14 | 177 | | Numbers/Natural/Abstract/NAdd.v | 6 | 72 | | Numbers/Natural/Abstract/NOrder.v | 29 | 349 | | Numbers/Natural/Abstract/NAddOrder.v | 5 | 60 | | Numbers/Natural/Abstract/NMulOrder.v | 8 | 96 | | Numbers/Natural/Abstract/NSub.v | 36 | 432 | | Numbers/Natural/Abstract/NMaxMin.v | 18 | 216 | | Numbers/Natural/Abstract/NParity.v | 4 | 48 | | Numbers/Natural/Abstract/NPow.v | 26 | 312 | | Numbers/Natural/Abstract/NSqrt.v | 9 | 108 | | Numbers/Natural/Abstract/NLog.v | 0 | 0 | | Numbers/Natural/Abstract/NDiv.v | 50 | 600 | | Numbers/Natural/Abstract/NGcd.v | 14 | 168 | | Numbers/Natural/Abstract/NLcm.v | 29 | 348 | | Numbers/Natural/Abstract/NBits.v | 168 | 2016 | | Numbers/Natural/Abstract/NProperties.v | 0 | 0 | | Arith/PeanoNat.v | 77 | 990 | | Arith/Le.v | 2 | 57 | | Arith/Lt.v | 14 | 168 | | Arith/Plus.v | 20 | 269 | | Arith/Gt.v | 17 | 248 | | Arith/Minus.v | 11 | 132 | | Arith/Mult.v | 14 | 168 | | Arith/Between.v | 19 | 299 | | Logic/EqdepFacts.v | 26 | 539 | | Logic/Eqdep_dec.v | 13 | 361 | | Arith/Peano_dec.v | 3 | 26 | | Arith/Compare_dec.v | 35 | 360 | | Arith/Factorial.v | 3 | 36 | | Arith/EqNat.v | 10 | 111 | | Arith/Wf_nat.v | 18 | 173 | | Arith/Arith_base.v | 0 | 0 | | Numbers/BinNums.v | 0 | 0 | | PArith/BinPosDef.v | 0 | 0 | | PArith/BinPos.v | 229 | 2810 | | NArith/BinNatDef.v | 0 | 0 | | NArith/BinNat.v | 107 | 1330 | | PArith/Pnat.v | 51 | 688 | | NArith/Nnat.v | 30 | 360 | | setoid_ring/Ring_theory.v | 43 | 756 | | Lists/List.v | 195 | 2908 | | setoid_ring/BinList.v | 6 | 90 | | Numbers/Integer/Abstract/ZAxioms.v | 0 | 0 | | Numbers/Integer/Abstract/ZBase.v | 3 | 36 | | Numbers/Integer/Abstract/ZAdd.v | 46 | 552 | | Numbers/Integer/Abstract/ZMul.v | 8 | 96 | | Numbers/Integer/Abstract/ZLt.v | 21 | 252 | | Numbers/Integer/Abstract/ZAddOrder.v | 45 | 543 | | Numbers/Integer/Abstract/ZMulOrder.v | 24 | 288 | | Numbers/Integer/Abstract/ZMaxMin.v | 22 | 264 | | Numbers/Integer/Abstract/ZSgnAbs.v | 41 | 492 | | Numbers/Integer/Abstract/ZParity.v | 6 | 72 | | Numbers/Integer/Abstract/ZPow.v | 10 | 120 | | Numbers/Integer/Abstract/ZDivTrunc.v | 68 | 816 | | Numbers/Integer/Abstract/ZDivFloor.v | 70 | 840 | | Numbers/Integer/Abstract/ZGcd.v | 29 | 348 | | Numbers/Integer/Abstract/ZLcm.v | 50 | 600 | | Numbers/Integer/Abstract/ZBits.v | 205 | 2460 | | Numbers/Integer/Abstract/ZProperties.v | 0 | 0 | | ZArith/BinIntDef.v | 0 | 0 | | ZArith/BinInt.v | 212 | 2839 | |----------------------------------------+--------------------+---------------------| ``` (*) I would call it `Future.map` better than chain. --- lib/future.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/future.ml b/lib/future.ml index ea0382a63d..ca73d5e39e 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -151,8 +151,8 @@ let chain ~pure ck f = create ~uuid ~name fix_exn (match !c with | Closure _ | Delegated _ -> Closure (fun () -> f (force ~pure ck)) | Exn _ as x -> x - | Val (v, None) when pure -> Closure (fun () -> f v) - | Val (v, Some _) when pure -> Closure (fun () -> f v) + | Val (v, None) when pure -> Val (f v, None) + | Val (v, Some _) when pure -> Val (f v, None) | Val (v, Some state) -> Closure (fun () -> !unfreeze state; f v) | Val (v, None) -> match !ck with -- cgit v1.2.3 From d25b1431eb73a04bdfc0f1ad2922819b69bba93a Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 20 Mar 2017 15:14:01 +0100 Subject: [misc] Remove warnings about String.set The `a.[i] <- x` notation is deprecated and we were getting a couple of warnings. --- kernel/cemitcodes.ml | 8 ++++---- tools/coqdoc/index.ml | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index a0a13174ff..f2c3b402b3 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -106,10 +106,10 @@ let extend_label_table needed = let backpatch (pos, orig) = let displ = (!out_position - orig) asr 2 in - !out_buffer.[pos] <- Char.unsafe_chr displ; - !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8); - !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16); - !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24) + Bytes.set !out_buffer pos @@ Char.unsafe_chr displ; + Bytes.set !out_buffer (pos+1) @@ Char.unsafe_chr (displ asr 8); + Bytes.set !out_buffer (pos+2) @@ Char.unsafe_chr (displ asr 16); + Bytes.set !out_buffer (pos+3) @@ Char.unsafe_chr (displ asr 24) let define_label lbl = if lbl >= Array.length !label_table then extend_label_table lbl; diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index c9cb676e98..34108eff42 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -205,17 +205,17 @@ let prepare_entry s = function while !j <= l do if not !quoted then begin (match s.[!j] with - | '_' -> ntn.[!k] <- ' '; incr k - | 'x' -> ntn.[!k] <- '_'; incr k + | '_' -> Bytes.set ntn !k ' '; incr k + | 'x' -> Bytes.set ntn !k '_'; incr k | '\'' -> quoted := true | _ -> assert false) end else if s.[!j] = '\'' then if (!j = l || s.[!j+1] = '_') then quoted := false - else (incr j; ntn.[!k] <- s.[!j]; incr k) + else (incr j; Bytes.set ntn !k s.[!j]; incr k) else begin - ntn.[!k] <- s.[!j]; + Bytes.set ntn !k s.[!j]; incr k end; incr j -- cgit v1.2.3 From 76c263b5eceac313ac2cdd3a3e7e2961876d3e31 Mon Sep 17 00:00:00 2001 From: Paul Steckler Date: Mon, 20 Mar 2017 12:21:12 -0400 Subject: In the Kami project, that causes a stack overflow in one of the example files (ProcThreeStInl.v, when the final "Defined" runs). I've verified that the change here fixes the stack overflow there with Coq 8.5pl2. In this version, all the recursive calls are in tail position. Instead of taking a single list of instructions, `emit' here takes a curent list and a remaining list of lists of instructions. That means the two calls elsewhere in the file now add an empty list argument. The algorithm works on the current list until it's empty, then works on the remaining lists. The most complex case is for Ksequence, where one of the pieces becomes the new current list, and the other pieces are consed onto the remaining sub-lists. --- kernel/cemitcodes.ml | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index ad7a41a347..f13620e101 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -262,41 +262,44 @@ let emit_instr = function | Kstop -> out opSTOP -(* Emission of a list of instructions. Include some peephole optimization. *) +(* Emission of a current list and remaining lists of instructions. Include some peephole optimization. *) -let rec emit = function - | [] -> () +let rec emit insns remaining = match insns with + | [] -> + (match remaining with + [] -> () + | (first::rest) -> emit first rest) (* Peephole optimizations *) | Kpush :: Kacc n :: c -> if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n); - emit c + emit c remaining | Kpush :: Kenvacc n :: c -> if n >= 1 && n <= 4 then out(opPUSHENVACC1 + n - 1) else (out opPUSHENVACC; out_int n); - emit c + emit c remaining | Kpush :: Koffsetclosure ofs :: c -> if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2 then out(opPUSHOFFSETCLOSURE0 + ofs / 2) else (out opPUSHOFFSETCLOSURE; out_int ofs); - emit c + emit c remaining | Kpush :: Kgetglobal id :: c -> - out opPUSHGETGLOBAL; slot_for_getglobal id; emit c + out opPUSHGETGLOBAL; slot_for_getglobal id; emit c remaining | Kpush :: Kconst (Const_b0 i) :: c -> if i >= 0 && i <= 3 then out (opPUSHCONST0 + i) else (out opPUSHCONSTINT; out_int i); - emit c + emit c remaining | Kpush :: Kconst const :: c -> out opPUSHGETGLOBAL; slot_for_const const; - emit c + emit c remaining | Kpop n :: Kjump :: c -> - out opRETURN; out_int n; emit c + out opRETURN; out_int n; emit c remaining | Ksequence(c1,c2)::c -> - emit c1; emit c2;emit c + emit c1 (c2::c::remaining) (* Default case *) | instr :: c -> - emit_instr instr; emit c + emit_instr instr; emit c remaining (* Initialization *) @@ -367,8 +370,8 @@ let repr_body_code = function let to_memory (init_code, fun_code, fv) = init(); - emit init_code; - emit fun_code; + emit init_code []; + 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 *) -- cgit v1.2.3 From becc6ef43a0f838d1f6388e8c7373c13f26082bc Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 21 Mar 2017 15:12:27 +0100 Subject: trivial: fix comment --- dev/ci/ci-basic-overlay.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index da5b425794..241ec35861 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -68,7 +68,7 @@ : ${Coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git} ######################################################################## -# Coquelicot +# CompCert ######################################################################## : ${CompCert_CI_BRANCH:=master} : ${CompCert_CI_GITURL:=https://github.com/AbsInt/CompCert.git} -- cgit v1.2.3 From 2633ab1f433a290acbc2ec77d8ae05ec3ba64ec4 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 21 Mar 2017 15:40:31 +0100 Subject: [safe-string] update dev/doc/changes --- dev/doc/changes.txt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 12c3ec4546..3dc6973ba0 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -2,6 +2,12 @@ = CHANGES BETWEEN COQ V8.6 AND COQ V8.7 = ========================================= +* Ocaml * + +Coq is compiled with -safe-string enabled and requires plugins to do +the same. This means that code using `String` in an imperative way +will fail to compile now. They should switch to `Bytes.t` + * ML API * We renamed the following functions: -- cgit v1.2.3 From f1c5e2ce2a4515a7c90c5ca22aa6eff22dd2f5ff Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 28 Jun 2016 16:52:46 +0200 Subject: [ide] Use "log via feedback". We remove the custom logger handler in ide_slave, and handle everything via feedback. This is an experimental patch but it seems to bring quite a bit of cleanup and a more uniform handling to messaging. --- ide/coq.ml | 47 +++++++++++++++-------------------------------- ide/coq.mli | 12 ++++-------- ide/coqOps.ml | 21 +++++++++++---------- ide/coqide.ml | 2 +- ide/ide_slave.ml | 14 ++++---------- ide/wg_Command.ml | 6 +----- ide/xmlprotocol.ml | 6 ------ ide/xmlprotocol.mli | 2 -- tools/fake_ide.ml | 9 ++------- 9 files changed, 38 insertions(+), 81 deletions(-) diff --git a/ide/coq.ml b/ide/coq.ml index 6d44ca59e3..9637b5b3f2 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -205,7 +205,7 @@ type handle = { proc : CoqTop.process; xml_oc : Xml_printer.t; mutable alive : bool; - mutable waiting_for : (ccb * logger) option; (* last call + callback + log *) + mutable waiting_for : ccb option; (* last call + callback + log *) } (** Coqtop process status : @@ -290,18 +290,6 @@ let rec check_errors = function | `NVAL :: _ -> raise (TubeError "NVAL") | `OUT :: _ -> raise (TubeError "OUT") -let handle_intermediate_message handle level content = - let logger = match handle.waiting_for with - | Some (_, l) -> l - | None -> function - | Feedback.Error -> fun s -> Minilib.log ~level:`ERROR (xml_to_string s) - | Feedback.Info -> fun s -> Minilib.log ~level:`INFO (xml_to_string s) - | Feedback.Notice -> fun s -> Minilib.log ~level:`NOTICE (xml_to_string s) - | Feedback.Warning -> fun s -> Minilib.log ~level:`WARNING (xml_to_string s) - | Feedback.Debug -> fun s -> Minilib.log ~level:`DEBUG (xml_to_string s) - in - logger level content - let handle_feedback feedback_processor xml = let feedback = Xmlprotocol.to_feedback xml in feedback_processor feedback @@ -310,7 +298,7 @@ let handle_final_answer handle xml = let () = Minilib.log "Handling coqtop answer" in let ccb = match handle.waiting_for with | None -> raise (AnswerWithoutRequest (Xml_printer.to_string_fmt xml)) - | Some (c, _) -> c in + | Some c -> c in let () = handle.waiting_for <- None in with_ccb ccb { bind_ccb = fun (c, f) -> f (Xmlprotocol.to_answer c xml) } @@ -332,18 +320,13 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all = let l_end = Lexing.lexeme_end lex in state.fragment <- String.sub s l_end (String.length s - l_end); state.lexerror <- None; - match Xmlprotocol.is_message xml with - | Some (lvl, _loc, msg) -> - handle_intermediate_message handle lvl msg; + if Xmlprotocol.is_feedback xml then begin + handle_feedback feedback_processor xml; loop () - | None -> - if Xmlprotocol.is_feedback xml then begin - handle_feedback feedback_processor xml; - loop () - end else - begin - ignore (handle_final_answer handle xml) - end + end else + begin + ignore (handle_final_answer handle xml) + end in try loop () with Xml_parser.Error _ as e -> @@ -493,20 +476,20 @@ let init_coqtop coqtop task = type 'a query = 'a Interface.value task -let eval_call ?(logger=default_logger) call handle k = +let eval_call call handle k = (** Send messages to coqtop and prepare the decoding of the answer *) Minilib.log ("Start eval_call " ^ Xmlprotocol.pr_call call); assert (handle.alive && handle.waiting_for = None); - handle.waiting_for <- Some (mk_ccb (call,k), logger); + handle.waiting_for <- Some (mk_ccb (call,k)); Xml_printer.print handle.xml_oc (Xmlprotocol.of_call call); Minilib.log "End eval_call"; Void -let add ?(logger=default_logger) x = eval_call ~logger (Xmlprotocol.add x) +let add x = eval_call (Xmlprotocol.add x) let edit_at i = eval_call (Xmlprotocol.edit_at i) -let query ?(logger=default_logger) x = eval_call ~logger (Xmlprotocol.query x) +let query x = eval_call (Xmlprotocol.query x) let mkcases s = eval_call (Xmlprotocol.mkcases s) -let status ?logger force = eval_call ?logger (Xmlprotocol.status force) +let status force = eval_call (Xmlprotocol.status force) let hints x = eval_call (Xmlprotocol.hints x) let search flags = eval_call (Xmlprotocol.search flags) let init x = eval_call (Xmlprotocol.init x) @@ -585,8 +568,8 @@ struct end -let goals ?logger x h k = - PrintOpt.enforce h (fun () -> eval_call ?logger (Xmlprotocol.goals x) h k) +let goals x h k = + PrintOpt.enforce h (fun () -> eval_call (Xmlprotocol.goals x) h k) let evars x h k = PrintOpt.enforce h (fun () -> eval_call (Xmlprotocol.evars x) h k) diff --git a/ide/coq.mli b/ide/coq.mli index 8a1fa3ed15..f2876de246 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -115,15 +115,11 @@ val try_grab : coqtop -> unit task -> (unit -> unit) -> unit type 'a query = 'a Interface.value task (** A type abbreviation for coqtop specific answers *) -val add : ?logger:Ideutils.logger -> - Interface.add_sty -> Interface.add_rty query +val add : Interface.add_sty -> Interface.add_rty query val edit_at : Interface.edit_at_sty -> Interface.edit_at_rty query -val query : ?logger:Ideutils.logger -> - Interface.query_sty -> Interface.query_rty query -val status : ?logger:Ideutils.logger -> - Interface.status_sty -> Interface.status_rty query -val goals : ?logger:Ideutils.logger -> - Interface.goals_sty -> Interface.goals_rty query +val query : Interface.query_sty -> Interface.query_rty query +val status : Interface.status_sty -> Interface.status_rty query +val goals : Interface.goals_sty -> Interface.goals_rty query val evars : Interface.evars_sty -> Interface.evars_rty query val hints : Interface.hints_sty -> Interface.hints_rty query val mkcases : Interface.mkcases_sty -> Interface.mkcases_rty query diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 1563c7ffb4..0f3629c8fc 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -345,7 +345,7 @@ object(self) script#recenter_insert end end; - Coq.bind (Coq.goals ~logger:messages#push ()) (function + Coq.bind (Coq.goals ()) (function | Fail x -> self#handle_failure_aux ~move_insert x | Good goals -> Coq.bind (Coq.evars ()) (function @@ -368,7 +368,7 @@ object(self) else messages#add s; in let query = - Coq.query ~logger:messages#push (phrase,Stateid.dummy) in + Coq.query (phrase,Stateid.dummy) in let next = function | Fail (_, _, err) -> display_error err; Coq.return () | Good msg -> @@ -476,13 +476,14 @@ object(self) self#position_error_tag_at_sentence sentence (Some (Loc.unloc loc)) | Message(Warning, loc, msg), Some (id,sentence) -> let loc = Option.default Loc.ghost loc in - let msg = Richpp.raw_print msg in + let rmsg = Richpp.raw_print msg in log "WarningMsg" id; - add_flag sentence (`WARNING (loc, msg)); - self#attach_tooltip sentence loc msg; - self#position_warning_tag_at_sentence sentence loc - | Message((Info|Notice|Debug as lvl), _, msg), _ -> - messages#push lvl msg + add_flag sentence (`WARNING (loc, rmsg)); + self#attach_tooltip sentence loc rmsg; + self#position_warning_tag_at_sentence sentence loc; + messages#push Warning msg + | Message(lvl, loc, msg), Some (id,sentence) -> + messages#push lvl msg | InProgress n, _ -> if n < 0 then processed <- processed + abs n else to_process <- to_process + n @@ -641,7 +642,7 @@ object(self) add_flag sentence `PROCESSING; Doc.push document sentence; let _, _, phrase = self#get_sentence sentence in - let coq_query = Coq.add ~logger ((phrase,edit_id),(tip,verbose)) in + let coq_query = Coq.add ((phrase,edit_id),(tip,verbose)) in let handle_answer = function | Good (id, (Util.Inl (* NewTip *) (), msg)) -> Doc.assign_tip_id document id; @@ -675,7 +676,7 @@ object(self) messages#push Feedback.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 + Coq.bind (Coq.status true) next method stop_worker n = Coq.bind (Coq.stop_worker n) (fun _ -> Coq.return ()) diff --git a/ide/coqide.ml b/ide/coqide.ml index eec829f345..3d56f9dd49 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -536,7 +536,7 @@ let update_status sn = display ("Ready"^ (if nanoPG#get then ", [μPG]" else "") ^ path ^ name); Coq.return () in - Coq.bind (Coq.status ~logger:sn.messages#push false) next + Coq.bind (Coq.status false) next let find_next_occurrence ~backward sn = (** go to the next occurrence of the current word, forward or backward *) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index ae3dcd94a9..7619c1452e 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -428,7 +428,7 @@ let print_ast id = (** Grouping all call handlers together + error handling *) -let eval_call xml_oc log c = +let eval_call log c = let interruptible f x = catch_break := true; Control.check_for_interrupt (); @@ -474,13 +474,6 @@ let print_xml = with e -> let e = CErrors.push e in Mutex.unlock m; iraise e -let slave_logger xml_oc ?loc level message = - (* convert the message into XML *) - let msg = hov 0 message in - let () = pr_debug (Printf.sprintf "-> %S" (string_of_ppcmds msg)) in - let xml = Xmlprotocol.of_message level loc (Richpp.richpp_of_pp message) in - print_xml xml_oc xml - let slave_feeder xml_oc msg = let xml = Xmlprotocol.of_feedback msg in print_xml xml_oc xml @@ -500,8 +493,9 @@ let loop () = CThread.thread_friendly_read in_ch s ~off:0 ~len) in let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in let () = Xml_parser.check_eof xml_ic false in - Feedback.set_logger (slave_logger xml_oc); + Feedback.set_logger Feedback.feedback_logger; Feedback.add_feeder (slave_feeder xml_oc); + let f_log str = Feedback.(feedback (Message(Notice, None, Richpp.richpp_of_pp str))) in (* We'll handle goal fetching and display in our own way *) Vernacentries.enable_goal_printing := false; Vernacentries.qed_display_script := false; @@ -511,7 +505,7 @@ let loop () = (* pr_with_pid (Xml_printer.to_string_fmt xml_query); *) 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 Feedback.Notice) q in + let r = eval_call f_log q in let () = pr_debug_answer q r in (* pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *) print_xml xml_oc (Xmlprotocol.of_answer q r); diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index 946aaf010d..d33c0add4a 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -100,12 +100,8 @@ object(self) if Str.string_match (Str.regexp "\\. *$") com 0 then com else com ^ " " ^ arg ^" . " 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 + Coq.bind (Coq.query (phrase,Stateid.dummy)) (function | Interface.Fail (_,l,str) -> Ideutils.insert_xml result#buffer str; notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce; diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 5f82a8898b..65f44fdd38 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -795,12 +795,6 @@ let to_message xml = match xml with Message(to_message_level lvl, to_option to_loc xloc, to_richpp content) | x -> raise (Marshal_error("message",x)) -let is_message xml = - try begin match to_message xml with - | Message(l,c,m) -> Some (l,c,m) - | _ -> None - end with | Marshal_error _ -> None - let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with | "addedaxiom", _ -> AddedAxiom | "processed", _ -> Processed diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli index 1bb9989704..ca911178f5 100644 --- a/ide/xmlprotocol.mli +++ b/ide/xmlprotocol.mli @@ -66,7 +66,5 @@ val of_feedback : Feedback.feedback -> xml val to_feedback : xml -> Feedback.feedback val is_feedback : xml -> bool -val is_message : xml -> (Feedback.level * Loc.t option * Richpp.richpp) option val of_message : Feedback.level -> Loc.t option -> Richpp.richpp -> xml -(* val to_message : xml -> Feedback.message *) diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index 8fcca535d1..23c111b371 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -37,14 +37,9 @@ let base_eval_call ?(print=true) ?(fail=true) call coqtop = Xml_printer.print coqtop.xml_printer xml_query; let rec loop () = let xml = Xml_parser.parse coqtop.xml_parser in - match Xmlprotocol.is_message xml with - | Some (level, _loc, content) -> - logger level content; + if Xmlprotocol.is_feedback xml then loop () - | None -> - if Xmlprotocol.is_feedback xml then - loop () - else Xmlprotocol.to_answer call xml + else Xmlprotocol.to_answer call xml in let res = loop () in if print then prerr_endline (Xmlprotocol.pr_full_value call res); -- cgit v1.2.3 From eda304d2f0531b8fa088a2d71d369d4482f29ed2 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 28 Jun 2016 19:17:21 +0200 Subject: [ide] ide_slave doesnt't need to capture stdout The miscellaneous `msg_*` cleanup patches have finally enforced this invariant. --- ide/ide_slave.ml | 49 ++++++++++++------------------------------------- 1 file changed, 12 insertions(+), 37 deletions(-) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 7619c1452e..8a1f8c6383 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -35,21 +35,6 @@ let init_signal_handler () = (** Redirection of standard output to a printable buffer *) -let init_stdout, read_stdout = - let out_buff = Buffer.create 100 in - let out_ft = Format.formatter_of_buffer out_buff in - let deep_out_ft = Format.formatter_of_buffer out_buff in - let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in - (fun () -> - flush_all (); - Pp_control.std_ft := out_ft; - Pp_control.err_ft := out_ft; - Pp_control.deep_ft := deep_out_ft; - ), - (fun () -> Format.pp_print_flush out_ft (); - let r = Buffer.contents out_buff in - Buffer.clear out_buff; r) - let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s let pr_error s = pr_with_pid s @@ -115,14 +100,14 @@ let coqide_cmd_checks (loc,ast) = let add ((s,eid),(sid,verbose)) = let newid, rc = Stm.add ~ontop:sid verbose ~check:coqide_cmd_checks eid s in let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in - newid, (rc, read_stdout ()) + newid, (rc, "") let edit_at id = match Stm.edit_at id with | `NewTip -> CSig.Inl () | `Focus { Stm.start; stop; tip} -> CSig.Inr (start, (stop, tip)) -let query (s,id) = Stm.query ~at:id s; read_stdout () +let query (s,id) = Stm.query ~at:id s; "" let annotate phrase = let (loc, ast) = @@ -214,8 +199,6 @@ let export_pre_goals pgs = let goals () = Stm.finish (); - let s = read_stdout () in - if not (String.is_empty s) then Feedback.msg_info (str s); try let pfts = Proof_global.give_me_the_proof () in Some (export_pre_goals (Proof.map_structured_proof pfts process_goal)) @@ -224,8 +207,6 @@ let goals () = let evars () = try Stm.finish (); - let s = read_stdout () in - if not (String.is_empty s) then Feedback.msg_info (str s); let pfts = Proof_global.give_me_the_proof () in let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in let exl = Evar.Map.bindings (Evarutil.non_instantiated sigma) in @@ -257,8 +238,6 @@ let status force = and display the other parts (opened sections and modules) *) Stm.finish (); if force then Stm.join (); - let s = read_stdout () in - if not (String.is_empty s) then Feedback.msg_info (str s); let path = let l = Names.DirPath.repr (Lib.cwd ()) in List.rev_map Names.Id.to_string l @@ -365,8 +344,7 @@ let handle_exn (e, info) = | Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc) | _ -> None in let mk_msg () = - let msg = read_stdout () in - let msg = str msg ++ fnl () ++ CErrors.print ~info e in + let msg = CErrors.print ~info e in Richpp.richpp_of_pp msg in match e with @@ -409,7 +387,7 @@ let interp ((_raw, verbose), s) = | Some ast -> ast) () in Stm.interp verbose (vernac_parse s); - Stm.get_current_state (), CSig.Inl (read_stdout ()) + Stm.get_current_state (), CSig.Inl "" (** When receiving the Quit call, we don't directly do an [exit 0], but rather set this reference, in order to send a final answer @@ -428,14 +406,12 @@ let print_ast id = (** Grouping all call handlers together + error handling *) -let eval_call log c = +let eval_call c = let interruptible f x = catch_break := true; Control.check_for_interrupt (); let r = f x in catch_break := false; - let out = read_stdout () in - if not (String.is_empty out) then log (str out); r in let handler = { @@ -487,15 +463,15 @@ let slave_feeder xml_oc msg = let loop () = init_signal_handler (); catch_break := false; - let in_ch, out_ch = Spawned.get_channels () in - let xml_oc = Xml_printer.make (Xml_printer.TChannel out_ch) in - let in_lb = Lexing.from_function (fun s len -> - CThread.thread_friendly_read in_ch s ~off:0 ~len) in - let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in + let in_ch, out_ch = Spawned.get_channels () in + let xml_oc = Xml_printer.make (Xml_printer.TChannel out_ch) in + let in_lb = Lexing.from_function (fun s len -> + CThread.thread_friendly_read in_ch s ~off:0 ~len) in + (* SEXP parser make *) + let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in let () = Xml_parser.check_eof xml_ic false in Feedback.set_logger Feedback.feedback_logger; Feedback.add_feeder (slave_feeder xml_oc); - let f_log str = Feedback.(feedback (Message(Notice, None, Richpp.richpp_of_pp str))) in (* We'll handle goal fetching and display in our own way *) Vernacentries.enable_goal_printing := false; Vernacentries.qed_display_script := false; @@ -505,7 +481,7 @@ let loop () = (* pr_with_pid (Xml_printer.to_string_fmt xml_query); *) let Xmlprotocol.Unknown q = Xmlprotocol.to_call xml_query in let () = pr_debug_call q in - let r = eval_call f_log q in + let r = eval_call q in let () = pr_debug_answer q r in (* pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *) print_xml xml_oc (Xmlprotocol.of_answer q r); @@ -536,7 +512,6 @@ let rec parse = function let () = Coqtop.toploop_init := (fun args -> let args = parse args in Flags.make_silent true; - init_stdout (); CoqworkmgrApi.(init Flags.High); args) -- cgit v1.2.3 From 8c5adfd5acb883a3bc2850b6fc8c29d352a421f8 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 1 Jun 2016 17:52:39 +0200 Subject: [pp] Remove unused printing tagging infrastructure. Applications of it were not clear/unproven, it made printers more complex (as they needed to be functors) and as it lacked examples it confused some people. The printers now tag unconditionally, it is up to the backends to interpreted the tags. Tagging (and indeed the notion of rich document) should be reworked in a follow-up patch, so they are in sync, but this is a first step. Tested, test-suite passes. Notes: - We remove the `Richprinter` module. It was only used in the `annotate` IDE protocol call, its output was identical to the normal printer (or even inconsistent if taggers were not kept manually in sync). - Note that Richpp didn't need a single change. In particular, its main API entry point `Richpp.rich_pp` is not used by anyone. --- ide/ide_slave.ml | 7 +-- ide/richprinter.ml | 23 -------- ide/richprinter.mli | 36 ----------- plugins/ltac/pptactic.ml | 101 +++++++++---------------------- plugins/ltac/pptactic.mli | 70 +++++++++++++++++++--- plugins/ltac/pptacticsig.mli | 81 ------------------------- printing/ppannotation.ml | 33 ----------- printing/ppannotation.mli | 29 --------- printing/ppconstr.ml | 138 ++++++++++++++----------------------------- printing/ppconstr.mli | 86 +++++++++++++++++++++++++-- printing/ppconstrsig.mli | 95 ----------------------------- printing/ppvernac.ml | 35 ++--------- printing/ppvernac.mli | 15 +++-- printing/ppvernacsig.mli | 20 ------- printing/printing.mllib | 1 - printing/printmod.mli | 5 +- printing/printmodsig.mli | 17 ------ 17 files changed, 230 insertions(+), 562 deletions(-) delete mode 100644 ide/richprinter.ml delete mode 100644 ide/richprinter.mli delete mode 100644 plugins/ltac/pptacticsig.mli delete mode 100644 printing/ppannotation.ml delete mode 100644 printing/ppannotation.mli delete mode 100644 printing/ppconstrsig.mli delete mode 100644 printing/ppvernacsig.mli delete mode 100644 printing/printmodsig.mli diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 8a1f8c6383..0cb8d377f6 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -114,11 +114,8 @@ let annotate phrase = let pa = Pcoq.Gram.parsable (Stream.of_string phrase) in Vernac.parse_sentence (pa,None) in - let (_, xml) = - Richprinter.richpp_vernac ast - in - xml - + Richpp.repr (Richpp.richpp_of_pp (Ppvernac.pr_vernac ast)) + (** Goal display *) let hyp_next_tac sigma env decl = diff --git a/ide/richprinter.ml b/ide/richprinter.ml deleted file mode 100644 index 995cef1ac5..0000000000 --- a/ide/richprinter.ml +++ /dev/null @@ -1,23 +0,0 @@ -open Richpp - -module RichppConstr = Ppconstr.Richpp -module RichppVernac = Ppvernac.Richpp - -type rich_pp = - Ppannotation.t Richpp.located Xml_datatype.gxml - * Xml_datatype.xml - -let get_annotations obj = Pp.Tag.prj obj Ppannotation.tag - -let make_richpp pr ast = - let rich_pp = - rich_pp get_annotations (pr ast) - in - let xml = Ppannotation.( - xml_of_rich_pp tag_of_annotation attributes_of_annotation rich_pp - ) - in - (rich_pp, xml) - -let richpp_vernac = make_richpp RichppVernac.pr_vernac -let richpp_constr = make_richpp RichppConstr.pr_constr_expr diff --git a/ide/richprinter.mli b/ide/richprinter.mli deleted file mode 100644 index c9e84e3eb4..0000000000 --- a/ide/richprinter.mli +++ /dev/null @@ -1,36 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* rich_pp - -(** [richpp_constr constr] produces a rich pretty-printing of [constr]. *) -val richpp_constr : Constrexpr.constr_expr -> rich_pp diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 6f4ef37b44..9dacce28d5 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -27,6 +27,33 @@ open Pputils open Ppconstr open Printer +module Tag = +struct + let keyword = + let style = Terminal.make ~bold:true () in + Ppstyle.make ~style ["tactic"; "keyword"] + + let primitive = + let style = Terminal.make ~fg_color:`LIGHT_GREEN () in + Ppstyle.make ~style ["tactic"; "primitive"] + + let string = + let style = Terminal.make ~fg_color:`LIGHT_RED () in + Ppstyle.make ~style ["tactic"; "string"] + +end + +let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s +let do_not_tag _ x = x +let tag_keyword = tag Tag.keyword +let tag_primitive = tag Tag.primitive +let tag_string = tag Tag.string +let tag_glob_tactic_expr = do_not_tag +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_atomic_tactic_expr = do_not_tag + let pr_global x = Nametab.pr_global_env Id.Set.empty x type 'a grammar_tactic_prod_item_expr = @@ -64,30 +91,6 @@ type 'a extra_genarg_printer = (tolerability -> Val.t -> std_ppcmds) -> 'a -> std_ppcmds -module Make - (Ppconstr : Ppconstrsig.Pp) - (Taggers : sig - val tag_keyword - : std_ppcmds -> std_ppcmds - val tag_primitive - : std_ppcmds -> std_ppcmds - val tag_string - : std_ppcmds -> std_ppcmds - val tag_glob_tactic_expr - : glob_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_glob_atomic_tactic_expr - : glob_atomic_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_raw_tactic_expr - : raw_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_raw_atomic_tactic_expr - : raw_atomic_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_atomic_tactic_expr - : atomic_tactic_expr -> std_ppcmds -> std_ppcmds - end) -= struct - - open Taggers - let keyword x = tag_keyword (str x) let primitive x = tag_primitive (str x) @@ -1206,37 +1209,6 @@ module Make let pr_atomic_tactic env = pr_atomic_tactic_level env ltop -end - -module Tag = -struct - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["tactic"; "keyword"] - - let primitive = - let style = Terminal.make ~fg_color:`LIGHT_GREEN () in - Ppstyle.make ~style ["tactic"; "primitive"] - - let string = - let style = Terminal.make ~fg_color:`LIGHT_RED () in - Ppstyle.make ~style ["tactic"; "string"] - -end - -include Make (Ppconstr) (struct - let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s - let do_not_tag _ x = x - let tag_keyword = tag Tag.keyword - let tag_primitive = tag Tag.primitive - let tag_string = tag Tag.string - let tag_glob_tactic_expr = do_not_tag - 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_atomic_tactic_expr = do_not_tag -end) - let declare_extra_genarg_pprule wit (f : 'a raw_extra_genarg_printer) (g : 'b glob_extra_genarg_printer) @@ -1338,22 +1310,3 @@ 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 - open Ppannotation - open Genarg - let do_not_tag _ x = x - let tag e s = Pp.tag (Pp.Tag.inj e tag) s - let tag_keyword = tag AKeyword - let tag_primitive = tag AKeyword - let tag_string = do_not_tag () - let tag_glob_tactic_expr e = tag (AGlbGenArg (in_gen (glbwit wit_ltac) e)) - let tag_glob_atomic_tactic_expr = do_not_tag - let tag_raw_tactic_expr e = tag (ARawGenArg (in_gen (rawwit wit_ltac) e)) - let tag_raw_atomic_tactic_expr = do_not_tag - let tag_atomic_tactic_expr = do_not_tag - end) - -end diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 86e3ea5484..43e22dba3f 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -13,6 +13,8 @@ open Pp open Genarg open Geninterp open Names +open Misctypes +open Environ open Constrexpr open Tacexpr open Ppextend @@ -54,14 +56,66 @@ type pp_tactic = { val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit -(** The default pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as raw strings. *) -include Pptacticsig.Pp +val pr_with_occurrences : + ('a -> std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds +val pr_red_expr : + ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> + ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds +val pr_may_eval : + ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds + +val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds +val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds + +val pr_in_clause : + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + +val pr_clauses : bool option -> + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + +val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds + +val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds + +val pr_raw_extend: env -> int -> + ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds + +val pr_glob_extend: env -> int -> + ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds + +val pr_extend : + (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds + +val pr_alias_key : Names.KerName.t -> 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 + +val pr_raw_tactic : raw_tactic_expr -> std_ppcmds + +val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds + +val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds + +val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds + +val pr_hintbases : string list option -> std_ppcmds + +val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds + +val pr_bindings : + ('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 + +val pr_value : tolerability -> Val.t -> std_ppcmds -(** The rich pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as annotated strings. The annotations can be - retrieved using {!RichPp.rich_pp}. Their definitions are - located in {!Ppannotation.t}. *) -module Richpp : Pptacticsig.Pp val ltop : tolerability diff --git a/plugins/ltac/pptacticsig.mli b/plugins/ltac/pptacticsig.mli deleted file mode 100644 index 74ddd377ad..0000000000 --- a/plugins/ltac/pptacticsig.mli +++ /dev/null @@ -1,81 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds - val pr_red_expr : - ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> - ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds - val pr_may_eval : - ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds - - val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds - - val pr_in_clause : - ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds - - val pr_clauses : bool option -> - ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds - - val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds - - val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds - - val pr_raw_extend: env -> int -> - ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds - - val pr_glob_extend: env -> int -> - ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds - - val pr_extend : - (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds - - val pr_alias_key : Names.KerName.t -> std_ppcmds - - val pr_alias : (Val.t -> std_ppcmds) -> - int -> Names.KerName.t -> Val.t list -> std_ppcmds - - val pr_alias_key : Names.KerName.t -> std_ppcmds - - val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds - - val pr_raw_tactic : raw_tactic_expr -> std_ppcmds - - val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds - - val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds - - val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds - - val pr_hintbases : string list option -> std_ppcmds - - val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds - - val pr_bindings : - ('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 - - val pr_value : tolerability -> Val.t -> std_ppcmds - -end diff --git a/printing/ppannotation.ml b/printing/ppannotation.ml deleted file mode 100644 index 726c0ffcf1..0000000000 --- a/printing/ppannotation.ml +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* "keyword" - | AUnparsing _ -> "unparsing" - | AConstrExpr _ -> "constr_expr" - | AVernac _ -> "vernac_expr" - | AGlbGenArg _ -> "glob_generic_argument" - | ARawGenArg _ -> "raw_generic_argument" - -let attributes_of_annotation a = - [] - -let tag = Pp.Tag.create "ppannotation" diff --git a/printing/ppannotation.mli b/printing/ppannotation.mli deleted file mode 100644 index b0e0facef6..0000000000 --- a/printing/ppannotation.mli +++ /dev/null @@ -1,29 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* string - -val attributes_of_annotation : t -> (string * string) list - -val tag : t Pp.Tag.key diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 80ddd669f4..b16384c600 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -21,18 +21,49 @@ open Decl_kinds open Misctypes (*i*) -module Make (Taggers : sig - val tag_keyword : std_ppcmds -> std_ppcmds - val tag_evar : std_ppcmds -> std_ppcmds - val tag_type : std_ppcmds -> std_ppcmds - val tag_path : std_ppcmds -> std_ppcmds - val tag_ref : std_ppcmds -> std_ppcmds - val tag_var : std_ppcmds -> std_ppcmds - val tag_constr_expr : constr_expr -> std_ppcmds -> std_ppcmds - val tag_unparsing : unparsing -> std_ppcmds -> std_ppcmds -end) = struct - - open Taggers +module Tag = +struct + let keyword = + let style = Terminal.make ~bold:true () in + Ppstyle.make ~style ["constr"; "keyword"] + + let evar = + let style = Terminal.make ~fg_color:`LIGHT_BLUE () in + Ppstyle.make ~style ["constr"; "evar"] + + let univ = + let style = Terminal.make ~bold:true ~fg_color:`YELLOW () in + Ppstyle.make ~style ["constr"; "type"] + + let notation = + let style = Terminal.make ~fg_color:`WHITE () in + Ppstyle.make ~style ["constr"; "notation"] + + let variable = + Ppstyle.make ["constr"; "variable"] + + let reference = + let style = Terminal.make ~fg_color:`LIGHT_GREEN () in + Ppstyle.make ~style ["constr"; "reference"] + + let path = + let style = Terminal.make ~fg_color:`LIGHT_MAGENTA () in + Ppstyle.make ~style ["constr"; "path"] +end + +let do_not_tag _ x = x +let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s +let tag_keyword = tag Tag.keyword +let tag_evar = tag Tag.evar +let tag_type = tag Tag.univ +let tag_unparsing = function +| UnpTerminal s -> tag Tag.notation +| _ -> do_not_tag () +let tag_constr_expr = do_not_tag +let tag_path = tag Tag.path +let tag_ref = tag Tag.reference +let tag_var = tag Tag.variable + let keyword s = tag_keyword (str s) let sep_v = fun _ -> str"," ++ spc() @@ -764,86 +795,3 @@ end) = struct let pr_binders = pr_undelimited_binders spc (pr ltop) -end - -module Tag = -struct - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["constr"; "keyword"] - - let evar = - let style = Terminal.make ~fg_color:`LIGHT_BLUE () in - Ppstyle.make ~style ["constr"; "evar"] - - let univ = - let style = Terminal.make ~bold:true ~fg_color:`YELLOW () in - Ppstyle.make ~style ["constr"; "type"] - - let notation = - let style = Terminal.make ~fg_color:`WHITE () in - Ppstyle.make ~style ["constr"; "notation"] - - let variable = - Ppstyle.make ["constr"; "variable"] - - let reference = - let style = Terminal.make ~fg_color:`LIGHT_GREEN () in - Ppstyle.make ~style ["constr"; "reference"] - - let path = - let style = Terminal.make ~fg_color:`LIGHT_MAGENTA () in - Ppstyle.make ~style ["constr"; "path"] - -end - -let do_not_tag _ x = x - -let split_token tag s = - let len = String.length s in - let rec parse_string off i = - if Int.equal i len then - if Int.equal off i then mt () else tag (str (String.sub s off (i - off))) - else if s.[i] == ' ' then - if Int.equal off i then parse_space 1 (succ i) - else tag (str (String.sub s off (i - off))) ++ parse_space 1 (succ i) - else parse_string off (succ i) - and parse_space spc i = - if Int.equal i len then str (String.make spc ' ') - else if s.[i] == ' ' then parse_space (succ spc) (succ i) - else str (String.make spc ' ') ++ parse_string i (succ i) - in - parse_string 0 0 - -(** Instantiating Make with tagging functions that only add style - information. *) -include Make (struct - let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s - let tag_keyword = tag Tag.keyword - let tag_evar = tag Tag.evar - let tag_type = tag Tag.univ - let tag_unparsing = function - | UnpTerminal s -> fun _ -> split_token (fun pp -> tag Tag.notation pp) s - | _ -> do_not_tag () - let tag_constr_expr = do_not_tag - let tag_path = tag Tag.path - let tag_ref = tag Tag.reference - let tag_var = tag Tag.variable -end) - -module Richpp = struct - - include Make (struct - open Ppannotation - let tag_keyword = Pp.tag (Pp.Tag.inj AKeyword tag) - let tag_type = Pp.tag (Pp.Tag.inj AKeyword tag) - let tag_evar = do_not_tag () - let tag_unparsing unp = Pp.tag (Pp.Tag.inj (AUnparsing unp) tag) - let tag_constr_expr e = Pp.tag (Pp.Tag.inj (AConstrExpr e) tag) - let tag_path = do_not_tag () - let tag_ref = do_not_tag () - let tag_var = do_not_tag () - end) - -end - diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 0241633c61..a0106837ad 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -11,11 +11,85 @@ (** The default pretty-printers produce {!Pp.std_ppcmds} that are interpreted as raw strings. *) -include Ppconstrsig.Pp +open Loc +open Pp +open Libnames +open Constrexpr +open Names +open Misctypes -(** The rich pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as annotated strings. The annotations can be - retrieved using {!RichPp.rich_pp}. Their definitions are - located in {!Ppannotation.t}. *) +val extract_lam_binders : + constr_expr -> local_binder list * constr_expr +val extract_prod_binders : + constr_expr -> local_binder list * constr_expr +val split_fix : + int -> constr_expr -> constr_expr -> + local_binder list * constr_expr * constr_expr -module Richpp : Ppconstrsig.Pp +val prec_less : int -> int * Ppextend.parenRelation -> bool + +val pr_tight_coma : unit -> std_ppcmds + +val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds + +val pr_lident : Id.t located -> std_ppcmds +val pr_lname : Name.t located -> std_ppcmds + +val pr_with_comments : Loc.t -> std_ppcmds -> std_ppcmds +val pr_com_at : int -> std_ppcmds +val pr_sep_com : + (unit -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + constr_expr -> std_ppcmds + +val pr_id : Id.t -> std_ppcmds +val pr_name : Name.t -> std_ppcmds +val pr_qualid : qualid -> std_ppcmds +val pr_patvar : patvar -> std_ppcmds + +val pr_glob_level : glob_level -> std_ppcmds +val pr_glob_sort : glob_sort -> std_ppcmds +val pr_guard_annot : (constr_expr -> std_ppcmds) -> + local_binder list -> + ('a * Names.Id.t) option * recursion_order_expr -> + std_ppcmds + +val pr_record_body : (reference * constr_expr) list -> std_ppcmds +val pr_binders : local_binder list -> std_ppcmds +val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds +val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds +val pr_constr_expr : constr_expr -> std_ppcmds +val pr_lconstr_expr : constr_expr -> std_ppcmds +val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds + +type term_pr = { + pr_constr_expr : constr_expr -> std_ppcmds; + pr_lconstr_expr : constr_expr -> std_ppcmds; + pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds; + pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds +} + +val set_term_pr : term_pr -> unit +val default_term_pr : term_pr + +(* The modular constr printer. + [modular_constr_pr pr s p t] prints the head of the term [t] and calls + [pr] on its subterms. + [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers + and [ltop] for "lconstr" printers (spiwack: we might need more + specification here). + We can make a new modular constr printer by overriding certain branches, + for instance if we want to build a printer which prints "Prop" as "Omega" + instead we can proceed as follows: + let my_modular_constr_pr pr s p = function + | CSort (_,GProp Null) -> str "Omega" + | t -> modular_constr_pr pr s p t + Which has the same type. We can turn a modular printer into a printer by + taking its fixpoint. *) + +type precedence +val lsimpleconstr : precedence +val ltop : precedence +val modular_constr_pr : + ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) -> + (unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds diff --git a/printing/ppconstrsig.mli b/printing/ppconstrsig.mli deleted file mode 100644 index 3de0d805c4..0000000000 --- a/printing/ppconstrsig.mli +++ /dev/null @@ -1,95 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* local_binder list * constr_expr - val extract_prod_binders : - constr_expr -> local_binder list * constr_expr - val split_fix : - int -> constr_expr -> constr_expr -> - local_binder list * constr_expr * constr_expr - - val prec_less : int -> int * Ppextend.parenRelation -> bool - - val pr_tight_coma : unit -> std_ppcmds - - val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds - - val pr_lident : Id.t located -> std_ppcmds - val pr_lname : Name.t located -> std_ppcmds - - val pr_with_comments : Loc.t -> std_ppcmds -> std_ppcmds - val pr_com_at : int -> std_ppcmds - val pr_sep_com : - (unit -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - constr_expr -> std_ppcmds - - val pr_id : Id.t -> std_ppcmds - val pr_name : Name.t -> std_ppcmds - val pr_qualid : qualid -> std_ppcmds - val pr_patvar : patvar -> std_ppcmds - - val pr_glob_level : glob_level -> std_ppcmds - val pr_glob_sort : glob_sort -> std_ppcmds - val pr_guard_annot : (constr_expr -> std_ppcmds) -> - local_binder list -> - ('a * Names.Id.t) option * recursion_order_expr -> - std_ppcmds - - val pr_record_body : (reference * constr_expr) list -> std_ppcmds - val pr_binders : local_binder list -> std_ppcmds - val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds - val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds - val pr_constr_expr : constr_expr -> std_ppcmds - val pr_lconstr_expr : constr_expr -> std_ppcmds - val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds - - type term_pr = { - pr_constr_expr : constr_expr -> std_ppcmds; - pr_lconstr_expr : constr_expr -> std_ppcmds; - pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds; - pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds - } - - val set_term_pr : term_pr -> unit - val default_term_pr : term_pr - -(** The modular constr printer. - [modular_constr_pr pr s p t] prints the head of the term [t] and calls - [pr] on its subterms. - [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers - and [ltop] for "lconstr" printers (spiwack: we might need more - specification here). - We can make a new modular constr printer by overriding certain branches, - for instance if we want to build a printer which prints "Prop" as "Omega" - instead we can proceed as follows: - let my_modular_constr_pr pr s p = function - | CSort (_,GProp Null) -> str "Omega" - | t -> modular_constr_pr pr s p t - Which has the same type. We can turn a modular printer into a printer by - taking its fixpoint. *) - - type precedence - val lsimpleconstr : precedence - val ltop : precedence - val modular_constr_pr : - ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) -> - (unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds - -end - diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index ff72be90c5..78ef4d4bad 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -19,17 +19,12 @@ open Constrexpr open Constrexpr_ops open Decl_kinds -module Make - (Ppconstr : Ppconstrsig.Pp) - (Taggers : sig - val tag_keyword : std_ppcmds -> std_ppcmds - val tag_vernac : vernac_expr -> std_ppcmds -> std_ppcmds - end) -= struct - - open Taggers open Ppconstr + let do_not_tag _ x = x + let tag_keyword = do_not_tag () + let tag_vernac = do_not_tag + let keyword s = tag_keyword (str s) let pr_constr = pr_constr_expr @@ -526,7 +521,7 @@ module Make let pr_using e = str (Proof_using.to_string e) let rec pr_vernac_body v = - let return = Taggers.tag_vernac v in + let return = tag_vernac v in match v with | VernacPolymorphic (poly, v) -> let s = if poly then keyword "Polymorphic" else keyword "Monomorphic" in @@ -1244,23 +1239,3 @@ module Make let pr_vernac v = try pr_vernac_body v ++ sep_end v with e -> CErrors.print e - -end - -include Make (Ppconstr) (struct - let do_not_tag _ x = x - let tag_keyword = do_not_tag () - let tag_vernac = do_not_tag -end) - -module Richpp = struct - - include Make - (Ppconstr.Richpp) - (struct - open Ppannotation - let tag_keyword s = Pp.tag (Pp.Tag.inj AKeyword tag) s - let tag_vernac v s = Pp.tag (Pp.Tag.inj (AVernac v) tag) s - end) - -end diff --git a/printing/ppvernac.mli b/printing/ppvernac.mli index d3d4a5ceb7..836b05e0e4 100644 --- a/printing/ppvernac.mli +++ b/printing/ppvernac.mli @@ -9,12 +9,11 @@ (** This module implements pretty-printers for vernac_expr syntactic objects and their subcomponents. *) -(** The default pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as raw strings. *) -include Ppvernacsig.Pp +(** Prints a fixpoint body *) +val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.std_ppcmds -(** The rich pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as annotated strings. The annotations can be - retrieved using {!RichPp.rich_pp}. Their definitions are - located in {!Ppannotation.t}. *) -module Richpp : Ppvernacsig.Pp +(** Prints a vernac expression *) +val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds + +(** Prints a vernac expression and closes it with a dot. *) +val pr_vernac : Vernacexpr.vernac_expr -> Pp.std_ppcmds diff --git a/printing/ppvernacsig.mli b/printing/ppvernacsig.mli deleted file mode 100644 index 5e5e4bcf49..0000000000 --- a/printing/ppvernacsig.mli +++ /dev/null @@ -1,20 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.std_ppcmds - - (** Prints a vernac expression *) - val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds - - (** Prints a vernac expression and closes it with a dot. *) - val pr_vernac : Vernacexpr.vernac_expr -> Pp.std_ppcmds - -end diff --git a/printing/printing.mllib b/printing/printing.mllib index b0141b6d37..86b68d8fb0 100644 --- a/printing/printing.mllib +++ b/printing/printing.mllib @@ -1,6 +1,5 @@ Genprint Pputils -Ppannotation Ppconstr Printer Printmod diff --git a/printing/printmod.mli b/printing/printmod.mli index 7f7d343927..f3079d5b6b 100644 --- a/printing/printmod.mli +++ b/printing/printmod.mli @@ -6,9 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Pp open Names (** false iff the module is an element of an open module type *) val printable_body : DirPath.t -> bool -include Printmodsig.Pp +val pr_mutual_inductive_body : Environ.env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds +val print_module : bool -> module_path -> std_ppcmds +val print_modtype : module_path -> std_ppcmds diff --git a/printing/printmodsig.mli b/printing/printmodsig.mli deleted file mode 100644 index f71fffdcec..0000000000 --- a/printing/printmodsig.mli +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds - val print_module : bool -> module_path -> std_ppcmds - val print_modtype : module_path -> std_ppcmds -end -- cgit v1.2.3 From 14155762a7cd46ed6a3e9cf2a58e11ee1244b188 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 1 Jun 2016 18:31:05 +0200 Subject: [pp] Replace `Pp.Tag` by `Ppstyle.tag` = `string list` This is what has always been used, so it doesn't represent a functional change. This is just a preliminary patch, but many more possibilities could be done wrt tags. --- lib/cErrors.ml | 4 ++-- lib/feedback.ml | 10 +++++----- lib/pp.ml | 24 +++--------------------- lib/pp.mli | 26 +++++--------------------- lib/ppstyle.ml | 36 ++++++++++++++++++------------------ lib/ppstyle.mli | 20 +++++++++----------- lib/richpp.ml | 5 +---- lib/richpp.mli | 2 +- parsing/cLexer.ml4 | 2 +- plugins/ltac/pptactic.ml | 2 +- printing/ppconstr.ml | 2 +- printing/printmod.ml | 40 ++++++++++++++++------------------------ toplevel/coqloop.ml | 4 ++-- toplevel/vernac.ml | 2 +- vernac/explainErr.ml | 2 +- 15 files changed, 67 insertions(+), 114 deletions(-) diff --git a/lib/cErrors.ml b/lib/cErrors.ml index dbebe6a48f..9cbc3fb6d6 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -22,7 +22,7 @@ exception Anomaly of string option * std_ppcmds (* System errors *) * Anyways, tagging should not happen here, but in the specific * listener to the msg_* stuff. *) -let tag_err_str s = tag Ppstyle.(Tag.inj error_tag tag) (str s) ++ spc () +let tag_err_str s = tag Ppstyle.error_tag (str s) ++ spc () let err_str = tag_err_str "Error:" let ann_str = tag_err_str "Anomaly:" @@ -154,6 +154,6 @@ let handled e = let fatal_error info anomaly = let msg = info ++ fnl () in - pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft msg; + pp_with !Pp_control.err_ft msg; Format.pp_print_flush !Pp_control.err_ft (); exit (if anomaly then 129 else 1) diff --git a/lib/feedback.ml b/lib/feedback.ml index 57c6f30a41..e723bf4bae 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -73,10 +73,10 @@ end open Emacs -let dbg_str = tag Ppstyle.(Tag.inj debug_tag tag) (str "Debug:") ++ spc () +let dbg_str = tag Ppstyle.debug_tag (str "Debug:") ++ spc () let info_str = mt () -let warn_str = tag Ppstyle.(Tag.inj warning_tag tag) (str "Warning:") ++ spc () -let err_str = tag Ppstyle.(Tag.inj error_tag tag) (str "Error:" ) ++ spc () +let warn_str = tag Ppstyle.warning_tag (str "Warning:") ++ spc () +let err_str = tag Ppstyle.error_tag (str "Error:" ) ++ spc () let make_body quoter info ?loc s = let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in @@ -132,7 +132,7 @@ let make_style_stack () = | st :: _ -> st in let push tag = - let style = match Ppstyle.get_style tag with + let style = match Ppstyle.get_style_format tag with | None -> empty | Some st -> st in @@ -156,7 +156,7 @@ let init_color_output () = let open Pp_control in let push_tag, pop_tag, clear_tag = make_style_stack () in std_logger_cleanup := clear_tag; - std_logger_tag := Some Ppstyle.pp_tag; + std_logger_tag := Some Ppstyle.to_format; let tag_handler = { Format.mark_open_tag = push_tag; Format.mark_close_tag = pop_tag; diff --git a/lib/pp.ml b/lib/pp.ml index a51b4458fb..57d630a69c 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -42,25 +42,7 @@ end = struct end -module Tag : -sig - type t - type 'a key - val create : string -> 'a key - val inj : 'a -> 'a key -> t - val prj : t -> 'a key -> 'a option -end = -struct - -module Dyn = Dyn.Make(struct end) - -type t = Dyn.t -type 'a key = 'a Dyn.tag -let create = Dyn.create -let inj = Dyn.Easy.inj -let prj = Dyn.Easy.prj - -end +type pp_tag = string list open Pp_control @@ -95,7 +77,7 @@ type 'a ppcmd_token = | Ppcmd_open_box of block_type | Ppcmd_close_box | Ppcmd_comment of string list - | Ppcmd_open_tag of Tag.t + | Ppcmd_open_tag of pp_tag | Ppcmd_close_tag type 'a ppdir_token = @@ -243,7 +225,7 @@ let rec pr_com ft s = Some s2 -> Format.pp_force_newline ft (); pr_com ft s2 | None -> () -type tag_handler = Tag.t -> Format.tag +type tag_handler = pp_tag -> Format.tag (* pretty printing functions *) let pp_dirs ?pp_tag ft = diff --git a/lib/pp.mli b/lib/pp.mli index f17908262c..64ebea1964 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -67,27 +67,11 @@ val close : unit -> std_ppcmds (** {6 Opening and closing of tags} *) -module Tag : -sig - type t - (** Type of tags. Tags are dynamic types comparable to {Dyn.t}. *) +(* XXX: Improve and add attributes *) +type pp_tag = string list - type 'a key - (** Keys used to inject tags *) - - val create : string -> 'a key - (** Create a key with the given name. Two keys cannot share the same name, if - ever this is the case this function raises an assertion failure. *) - - val inj : 'a -> 'a key -> t - (** Inject an object into a tag. *) - - val prj : t -> 'a key -> 'a option - (** Project an object from a tag. *) -end - -val tag : Tag.t -> std_ppcmds -> std_ppcmds -val open_tag : Tag.t -> std_ppcmds +val tag : pp_tag -> std_ppcmds -> std_ppcmds +val open_tag : pp_tag -> std_ppcmds val close_tag : unit -> std_ppcmds (** {6 Utilities} *) @@ -165,7 +149,7 @@ val pr_loc : Loc.t -> std_ppcmds (** {6 Low-level pretty-printing functions with and without flush} *) (** FIXME: These ignore the logging settings and call [Format] directly *) -type tag_handler = Tag.t -> Format.tag +type tag_handler = pp_tag -> Format.tag (** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and flush [fmt] *) val msg_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml index aa47c51671..298e3be6b3 100644 --- a/lib/ppstyle.ml +++ b/lib/ppstyle.ml @@ -8,32 +8,38 @@ module String = CString -type t = string -(** We use the concatenated string, with dots separating each string. We - forbid the use of dots in the strings. *) +type t = Pp.pp_tag let tags : Terminal.style option String.Map.t ref = ref String.Map.empty +let to_format tag = String.concat "." tag +let of_format tag = String.split '.' tag + let make ?style tag = - let check s = if String.contains s '.' then invalid_arg "Ppstyle.make" in - let () = List.iter check tag in - let name = String.concat "." tag in + let name = to_format tag in let () = assert (not (String.Map.mem name !tags)) in - let () = tags := String.Map.add name style !tags in - name + let () = tags := String.Map.add name style !tags in + tag -let repr t = String.split '.' t +let repr t = t let get_style tag = - try String.Map.find tag !tags with Not_found -> assert false + try String.Map.find (to_format tag) !tags + with Not_found -> assert false + +let get_style_format tag = + try String.Map.find tag !tags + with Not_found -> assert false let set_style tag st = - try tags := String.Map.update tag st !tags with Not_found -> assert false + try tags := String.Map.update (to_format tag) st !tags + with Not_found -> assert false let clear_styles () = tags := String.Map.map (fun _ -> None) !tags -let dump () = String.Map.bindings !tags +let dump () = + List.map (fun (s,b) -> (String.split '.' s, b)) (String.Map.bindings !tags) let parse_config s = let styles = Terminal.parse s in @@ -42,8 +48,6 @@ let parse_config s = in tags := List.fold_left set !tags styles -let tag = Pp.Tag.create "ppstyle" - (** Default tag is to reset everything *) let default = Terminal.({ fg_color = Some `DEFAULT; @@ -67,7 +71,3 @@ let warning_tag = let debug_tag = let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA () in make ~style ["message"; "debug"] - -let pp_tag t = match Pp.Tag.prj t tag with -| None -> "" -| Some key -> key diff --git a/lib/ppstyle.mli b/lib/ppstyle.mli index d9fd757656..b9422f7cf7 100644 --- a/lib/ppstyle.mli +++ b/lib/ppstyle.mli @@ -11,7 +11,11 @@ (** {5 Style tags} *) -type t = string +(** This API is provisional and will likely be refined. *) +type t = Pp.pp_tag + +val to_format : t -> Format.tag +val of_format : Format.tag -> t (** Style tags *) @@ -23,14 +27,15 @@ val repr : t -> string list (** Gives back the original name of the style tag where each string has been concatenated and separated with a dot. *) -val tag : t Pp.Tag.key -(** An annotation for styles *) - (** {5 Manipulating global styles} *) val get_style : t -> Terminal.style option (** Get the style associated to a tag. *) +val get_style_format : Format.tag -> Terminal.style option +(** Get the style associated to a tag from a format tag. *) + + val set_style : t -> Terminal.style option -> unit (** Set a style associated to a tag. *) @@ -44,13 +49,6 @@ val parse_config : string -> unit val dump : unit -> (t * Terminal.style option) list (** Recover the list of known tags together with their current style. *) -(** {5 Color output} *) - -val pp_tag : Pp.tag_handler -(** Returns the name of a style tag that is understandable by the formatters - that have been inititialized through {!init_color_output}. To be used with - {!Pp.pp_with}. *) - (** {5 Tags} *) val error_tag : t diff --git a/lib/richpp.ml b/lib/richpp.ml index d1c6d158e4..c0128dbc2d 100644 --- a/lib/richpp.ml +++ b/lib/richpp.ml @@ -177,10 +177,7 @@ 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 annotate t = Some (Ppstyle.repr t) in let rec drop = function | PCData s -> [PCData s] | Element (_, annotation, cs) -> diff --git a/lib/richpp.mli b/lib/richpp.mli index 287d265a8f..2e839e996b 100644 --- a/lib/richpp.mli +++ b/lib/richpp.mli @@ -22,7 +22,7 @@ type 'annotation located = { The [get_annotations] function is used to convert tags into the desired annotation. *) val rich_pp : - (Pp.Tag.t -> 'annotation option) -> Pp.std_ppcmds -> + (Pp.pp_tag -> 'annotation option) -> Pp.std_ppcmds -> 'annotation located Xml_datatype.gxml (** [annotations_positions ssdoc] returns a list associating each diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 72bd11e030..a637d2e43f 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -105,7 +105,7 @@ module Error = struct Printf.sprintf "Unsupported Unicode character (0x%x)" x) (* Require to fix the Camlp4 signature *) - let print ppf x = Pp.pp_with ~pp_tag:Ppstyle.pp_tag ppf (Pp.str (to_string x)) + let print ppf x = Pp.pp_with ~pp_tag:Ppstyle.to_format ppf (Pp.str (to_string x)) end open Error diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 9dacce28d5..d9410a0885 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -43,7 +43,7 @@ struct end -let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s +let tag t s = Pp.tag t s let do_not_tag _ x = x let tag_keyword = tag Tag.keyword let tag_primitive = tag Tag.primitive diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index b16384c600..c772f7be16 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -52,7 +52,7 @@ struct end let do_not_tag _ x = x -let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s +let tag t s = Pp.tag t s let tag_keyword = tag Tag.keyword let tag_evar = tag Tag.evar let tag_type = tag Tag.univ diff --git a/printing/printmod.ml b/printing/printmod.ml index dfa66d4376..ac7ff7697b 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -26,6 +26,20 @@ open Goptions the "short" mode or (Some env) in the "rich" one. *) +module Tag = +struct + let definition = + let style = Terminal.make ~bold:true ~fg_color:`LIGHT_RED () in + Ppstyle.make ~style ["module"; "definition"] + let keyword = + let style = Terminal.make ~bold:true () in + Ppstyle.make ~style ["module"; "keyword"] +end + +let tag t s = Pp.tag t s +let tag_definition s = tag Tag.definition s +let tag_keyword s = tag Tag.keyword s + let short = ref false let _ = @@ -44,14 +58,8 @@ let mk_fake_top = let r = ref 0 in fun () -> incr r; Id.of_string ("FAKETOP"^(string_of_int !r)) -module Make (Taggers : sig - val tag_definition : std_ppcmds -> std_ppcmds - val tag_keyword : std_ppcmds -> std_ppcmds -end) = -struct - -let def s = Taggers.tag_definition (str s) -let keyword s = Taggers.tag_keyword (str s) +let def s = tag_definition (str s) +let keyword s = tag_keyword (str s) let get_new_id locals id = let rec get_id l id = @@ -441,20 +449,4 @@ let print_modtype kn = with e when CErrors.noncritical e -> print_signature' true None kn mtb.mod_type)) -end - -module Tag = -struct - let definition = - let style = Terminal.make ~bold:true ~fg_color:`LIGHT_RED () in - Ppstyle.make ~style ["module"; "definition"] - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["module"; "keyword"] -end -include Make(struct - let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s - let tag_definition s = tag Tag.definition s - let tag_keyword s = tag Tag.keyword s -end) diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 0dfd06726a..5521e8a40d 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -13,7 +13,7 @@ open Flags open Vernac open Pcoq -let top_stderr x = msg_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft x +let top_stderr x = msg_with ~pp_tag:Ppstyle.to_format !Pp_control.err_ft x (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) @@ -309,7 +309,7 @@ let do_vernac () = | any -> let any = CErrors.push any in let msg = print_toplevel_error any ++ fnl () in - pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft msg; + pp_with !Pp_control.std_ft msg; Format.pp_print_flush !Pp_control.std_ft () (** Main coq loop : read vernacular expressions until Drop is entered. diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index b73321c005..de7bc6929a 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -179,7 +179,7 @@ let pp_cmd_header loc com = and take control of the console. *) let print_cmd_header loc com = - Pp.pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft (pp_cmd_header loc com); + Pp.pp_with ~pp_tag:Ppstyle.to_format !Pp_control.std_ft (pp_cmd_header loc com); Format.pp_print_flush !Pp_control.std_ft () let rec interp_vernac po chan_beautify checknav (loc,com) = diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 17897460c0..148d029bc2 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -47,7 +47,7 @@ let _ = CErrors.register_handler explain_exn_default let wrap_vernac_error with_header (exn, info) strm = if with_header then - let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in + let header = Pp.tag Ppstyle.error_tag (str "Error:") in let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in (e, info) else -- cgit v1.2.3 From 2617a83e572531e26734cff8b9eb8aa09d49b850 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 27 Sep 2016 16:33:47 +0200 Subject: [pp] Remove `Pp.stras`. Mostly unused, we ought to limit spacing in the boxes themselves. --- lib/pp.ml | 34 ++++++++++++---------------------- lib/pp.mli | 1 - plugins/extraction/common.ml | 4 +++- 3 files changed, 15 insertions(+), 24 deletions(-) diff --git a/lib/pp.ml b/lib/pp.ml index 57d630a69c..9d2445d490 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -58,18 +58,14 @@ open Pp_control *) type block_type = - | Pp_hbox of int - | Pp_vbox of int - | Pp_hvbox of int + | Pp_hbox of int + | Pp_vbox of int + | Pp_hvbox of int | Pp_hovbox of int -type str_token = -| Str_def of string -| Str_len of string * int (** provided length *) - -type 'a ppcmd_token = - | Ppcmd_print of 'a - | Ppcmd_box of block_type * ('a ppcmd_token Glue.t) +type ppcmd_token = + | Ppcmd_string of string + | Ppcmd_box of block_type * (ppcmd_token Glue.t) | Ppcmd_print_break of int * int | Ppcmd_white_space of int | Ppcmd_force_newline @@ -81,11 +77,11 @@ type 'a ppcmd_token = | Ppcmd_close_tag type 'a ppdir_token = - | Ppdir_ppcmds of 'a ppcmd_token Glue.t + | Ppdir_ppcmds of ppcmd_token Glue.t | Ppdir_print_newline | Ppdir_print_flush -type ppcmd = str_token ppcmd_token +type ppcmd = ppcmd_token type std_ppcmds = ppcmd Glue.t @@ -134,8 +130,7 @@ let utf8_length s = !cnt (* formatting commands *) -let str s = Glue.atom(Ppcmd_print (Str_def s)) -let stras (i, s) = Glue.atom(Ppcmd_print (Str_len (s, i))) +let str s = Glue.atom(Ppcmd_string s) let brk (a,b) = Glue.atom(Ppcmd_print_break (a,b)) let fnl () = Glue.atom(Ppcmd_force_newline) let pifb () = Glue.atom(Ppcmd_print_if_broken) @@ -236,14 +231,9 @@ let pp_dirs ?pp_tag ft = | Pp_hovbox n -> Format.pp_open_hovbox ft n in let rec pp_cmd = function - | Ppcmd_print tok -> - begin match tok with - | Str_def s -> - let n = utf8_length s in - Format.pp_print_as ft n s - | Str_len (s, n) -> - Format.pp_print_as ft n s - end + | Ppcmd_string str -> + let n = utf8_length str in + Format.pp_print_as ft n str | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) pp_open_box bty ; if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss; diff --git a/lib/pp.mli b/lib/pp.mli index 64ebea1964..82accfff32 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -13,7 +13,6 @@ type std_ppcmds (** {6 Formatting commands} *) val str : string -> std_ppcmds -val stras : int * string -> std_ppcmds val brk : int * int -> std_ppcmds val fnl : unit -> std_ppcmds val pifb : unit -> std_ppcmds diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 0a591e786f..fc8d5356c8 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -67,7 +67,9 @@ let pp_boxed_tuple f = function blocks is less that a line length. To avoid this awkward situation, we attach a big virtual size to [fnl] newlines. *) -let fnl () = stras (1000000,"") ++ fnl () +(* EG: This looks quite suspicious... but beware of bugs *) +(* let fnl () = stras (1000000,"") ++ fnl () *) +let fnl () = fnl () let fnl2 () = fnl () ++ fnl () -- cgit v1.2.3 From 8f8af9e4ebf1ea1ed15f765196ef5af8a77d3c27 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 29 Sep 2016 16:06:43 +0200 Subject: [pp] Prepare for serialization, remove opaque glue. We also remove flushing operations `msg_with`, now the flushing responsibility belong to the owner of the formatter. --- lib/feedback.ml | 4 +- lib/pp.ml | 184 +++++++++++++++----------------------------- lib/pp.mli | 21 +---- plugins/extraction/ocaml.ml | 8 +- printing/printer.ml | 2 +- printing/printmod.ml | 4 +- toplevel/coqloop.ml | 4 +- toplevel/coqtop.ml | 2 +- toplevel/vernac.ml | 3 +- vernac/explainErr.ml | 2 +- 10 files changed, 83 insertions(+), 151 deletions(-) diff --git a/lib/feedback.ml b/lib/feedback.ml index e723bf4bae..971a51e354 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -51,7 +51,9 @@ open Pp_control type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit -let msgnl_with ?pp_tag fmt strm = msg_with ?pp_tag fmt (strm ++ fnl ()) +let msgnl_with ?pp_tag fmt strm = + pp_with ?pp_tag fmt (strm ++ fnl ()); + Format.pp_print_flush fmt () (* XXX: This is really painful! *) module Emacs = struct diff --git a/lib/pp.ml b/lib/pp.ml index 9d2445d490..6d7bdf75e3 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -6,44 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -module Glue : sig - - (** The [Glue] module implements a container data structure with - efficient concatenation. *) - - type 'a t - - val atom : 'a -> 'a t - val glue : 'a t -> 'a t -> 'a t - val empty : 'a t - val is_empty : 'a t -> bool - val iter : ('a -> unit) -> 'a t -> unit - -end = struct - - type 'a t = GEmpty | GLeaf of 'a | GNode of 'a t * 'a t - - let atom x = GLeaf x - - let glue x y = - match x, y with - | GEmpty, _ -> y - | _, GEmpty -> x - | _, _ -> GNode (x,y) - - let empty = GEmpty - - let is_empty x = x = GEmpty - - let rec iter f = function - | GEmpty -> () - | GLeaf x -> f x - | GNode (x,y) -> iter f x; iter f y - -end - -type pp_tag = string list - open Pp_control (* The different kinds of blocks are: @@ -63,36 +25,22 @@ type block_type = | Pp_hvbox of int | Pp_hovbox of int -type ppcmd_token = +type pp_tag = string list + +type std_ppcmds = + | Ppcmd_empty | Ppcmd_string of string - | Ppcmd_box of block_type * (ppcmd_token Glue.t) + | Ppcmd_glue of std_ppcmds * std_ppcmds + | Ppcmd_box of block_type * std_ppcmds | Ppcmd_print_break of int * int | Ppcmd_white_space of int | Ppcmd_force_newline - | Ppcmd_print_if_broken | Ppcmd_open_box of block_type | Ppcmd_close_box | Ppcmd_comment of string list | Ppcmd_open_tag of pp_tag | Ppcmd_close_tag -type 'a ppdir_token = - | Ppdir_ppcmds of ppcmd_token Glue.t - | Ppdir_print_newline - | Ppdir_print_flush - -type ppcmd = ppcmd_token - -type std_ppcmds = ppcmd Glue.t - -type 'a ppdirs = 'a ppdir_token Glue.t - -let (++) = Glue.glue - -let app = Glue.glue - -let is_empty g = Glue.is_empty g - (* Compute length of an UTF-8 encoded string Rem 1 : utf8_length <= String.length (equal if pure ascii) Rem 2 : if used for an iso8859_1 encoded string, the result is @@ -129,22 +77,30 @@ let utf8_length s = done ; !cnt +let app s1 s2 = match s1, s2 with + | Ppcmd_empty, s + | s, Ppcmd_empty -> s + | s1, s2 -> Ppcmd_glue(s1, s2) + +let (++) = app + (* formatting commands *) -let str s = Glue.atom(Ppcmd_string s) -let brk (a,b) = Glue.atom(Ppcmd_print_break (a,b)) -let fnl () = Glue.atom(Ppcmd_force_newline) -let pifb () = Glue.atom(Ppcmd_print_if_broken) -let ws n = Glue.atom(Ppcmd_white_space n) -let comment l = Glue.atom(Ppcmd_comment l) +let str s = Ppcmd_string s +let brk (a,b) = Ppcmd_print_break (a,b) +let fnl () = Ppcmd_force_newline +let ws n = Ppcmd_white_space n +let comment l = Ppcmd_comment l (* derived commands *) -let mt () = Glue.empty -let spc () = Glue.atom(Ppcmd_print_break (1,0)) -let cut () = Glue.atom(Ppcmd_print_break (0,0)) -let align () = Glue.atom(Ppcmd_print_break (0,0)) -let int n = str (string_of_int n) -let real r = str (string_of_float r) -let bool b = str (string_of_bool b) +let mt () = Ppcmd_empty +let spc () = Ppcmd_print_break (1,0) +let cut () = Ppcmd_print_break (0,0) +let align () = Ppcmd_print_break (0,0) +let int n = str (string_of_int n) +let real r = str (string_of_float r) +let bool b = str (string_of_bool b) + +(* XXX: To Remove *) let strbrk s = let rec aux p n = if n < String.length s then @@ -153,7 +109,7 @@ let strbrk s = else str (String.sub s p (n-p)) :: spc () :: aux (n+1) (n+1) else aux p (n + 1) else if p = n then [] else [str (String.sub s p (n-p))] - in List.fold_left (++) Glue.empty (aux 0 0) + in List.fold_left (++) Ppcmd_empty (aux 0 0) let pr_loc_pos loc = if Loc.is_ghost loc then (str"") @@ -174,26 +130,25 @@ let pr_loc loc = int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++ str":" ++ fnl()) -let ismt = is_empty +let ismt = function | Ppcmd_empty -> true | _ -> false (* boxing commands *) -let h n s = Glue.atom(Ppcmd_box(Pp_hbox n,s)) -let v n s = Glue.atom(Ppcmd_box(Pp_vbox n,s)) -let hv n s = Glue.atom(Ppcmd_box(Pp_hvbox n,s)) -let hov n s = Glue.atom(Ppcmd_box(Pp_hovbox n,s)) +let h n s = Ppcmd_box(Pp_hbox n,s) +let v n s = Ppcmd_box(Pp_vbox n,s) +let hv n s = Ppcmd_box(Pp_hvbox n,s) +let hov n s = Ppcmd_box(Pp_hovbox n,s) (* Opening and closing of boxes *) -let hb n = Glue.atom(Ppcmd_open_box(Pp_hbox n)) -let vb n = Glue.atom(Ppcmd_open_box(Pp_vbox n)) -let hvb n = Glue.atom(Ppcmd_open_box(Pp_hvbox n)) -let hovb n = Glue.atom(Ppcmd_open_box(Pp_hovbox n)) -let close () = Glue.atom(Ppcmd_close_box) +let hb n = Ppcmd_open_box(Pp_hbox n) +let vb n = Ppcmd_open_box(Pp_vbox n) +let hvb n = Ppcmd_open_box(Pp_hvbox n) +let hovb n = Ppcmd_open_box(Pp_hovbox n) +let close () = Ppcmd_close_box (* Opening and closed of tags *) -let open_tag t = Glue.atom(Ppcmd_open_tag t) -let close_tag () = Glue.atom(Ppcmd_close_tag) +let open_tag t = Ppcmd_open_tag t +let close_tag () = Ppcmd_close_tag let tag t s = open_tag t ++ s ++ close_tag () -let eval_ppcmds l = l (* In new syntax only double quote char is escaped by repeating it *) let escape_string s = @@ -223,27 +178,27 @@ let rec pr_com ft s = type tag_handler = pp_tag -> Format.tag (* pretty printing functions *) -let pp_dirs ?pp_tag ft = - let pp_open_box = function +let pp_with ?pp_tag ft = + let cpp_open_box = function | Pp_hbox n -> Format.pp_open_hbox ft () | Pp_vbox n -> Format.pp_open_vbox ft n | Pp_hvbox n -> Format.pp_open_hvbox ft n | Pp_hovbox n -> Format.pp_open_hovbox ft n in - let rec pp_cmd = function - | Ppcmd_string str -> - let n = utf8_length str in - Format.pp_print_as ft n str + let rec pp_cmd = let open Format in function + | Ppcmd_empty -> () + | Ppcmd_glue(s1,s2) -> pp_cmd s1; pp_cmd s2 + | Ppcmd_string str -> let n = utf8_length str in + pp_print_as ft n str | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) - pp_open_box bty ; - if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss; + cpp_open_box bty ; + if not (Format.over_max_boxes ()) then pp_cmd ss; Format.pp_close_box ft () - | Ppcmd_open_box bty -> pp_open_box bty - | Ppcmd_close_box -> Format.pp_close_box ft () - | Ppcmd_white_space n -> Format.pp_print_break ft n 0 - | Ppcmd_print_break(m,n) -> Format.pp_print_break ft m n - | Ppcmd_force_newline -> Format.pp_force_newline ft () - | Ppcmd_print_if_broken -> Format.pp_print_if_newline ft () + | Ppcmd_open_box bty -> cpp_open_box bty + | Ppcmd_close_box -> pp_close_box ft () + | Ppcmd_white_space n -> pp_print_break ft n 0 + | Ppcmd_print_break(m,n) -> pp_print_break ft m n + | Ppcmd_force_newline -> pp_force_newline ft () | Ppcmd_comment coms -> List.iter (pr_com ft) coms | Ppcmd_open_tag tag -> begin match pp_tag with @@ -256,34 +211,19 @@ let pp_dirs ?pp_tag ft = | Some _ -> Format.pp_close_tag ft () end in - let pp_dir = function - | Ppdir_ppcmds cmdstream -> Glue.iter pp_cmd cmdstream - | Ppdir_print_newline -> Format.pp_print_newline ft () - | Ppdir_print_flush -> Format.pp_print_flush ft () - in - fun (dirstream : _ ppdirs) -> - try - Glue.iter pp_dir dirstream - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - let () = Format.pp_print_flush ft () in - Exninfo.iraise reraise - -(* pretty printing functions WITHOUT FLUSH *) -let pp_with ?pp_tag ft strm = - pp_dirs ?pp_tag ft (Glue.atom (Ppdir_ppcmds strm)) - -(* pretty printing functions WITH FLUSH *) -let msg_with ?pp_tag ft strm = - pp_dirs ?pp_tag ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush)) + try pp_cmd + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + let () = Format.pp_print_flush ft () in + Exninfo.iraise reraise (* If mixing some output and a goal display, please use msg_warning, so that interfaces (proofgeneral for example) can easily dispatch them to different windows. *) (** Output to a string formatter *) -let string_of_ppcmds c = - Format.fprintf Format.str_formatter "@[%a@]" (msg_with ?pp_tag:None) c; +let string_of_ppcmds ?pp_tag c = + Format.fprintf Format.str_formatter "@[%a@]" (pp_with ?pp_tag) c; Format.flush_str_formatter () (* Copy paste from Util *) @@ -310,7 +250,7 @@ let pr_nth n = (* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *) -let prlist pr l = List.fold_left (fun x e -> x ++ pr e) Glue.empty l +let prlist pr l = List.fold_left (fun x e -> x ++ pr e) Ppcmd_empty l (* unlike all other functions below, [prlist] works lazily. if a strict behavior is needed, use [prlist_strict] instead. diff --git a/lib/pp.mli b/lib/pp.mli index 82accfff32..f61261a17b 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -15,7 +15,6 @@ type std_ppcmds val str : string -> std_ppcmds val brk : int * int -> std_ppcmds val fnl : unit -> std_ppcmds -val pifb : unit -> std_ppcmds val ws : int -> std_ppcmds val mt : unit -> std_ppcmds val ismt : std_ppcmds -> bool @@ -30,12 +29,6 @@ val app : std_ppcmds -> std_ppcmds -> std_ppcmds val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds (** Infix alias for [app]. *) -val eval_ppcmds : std_ppcmds -> std_ppcmds -(** Force computation. *) - -val is_empty : std_ppcmds -> bool -(** Test emptyness. *) - (** {6 Derived commands} *) val spc : unit -> std_ppcmds @@ -73,10 +66,6 @@ val tag : pp_tag -> std_ppcmds -> std_ppcmds val open_tag : pp_tag -> std_ppcmds val close_tag : unit -> std_ppcmds -(** {6 Utilities} *) - -val string_of_ppcmds : std_ppcmds -> string - (** {6 Printing combinators} *) val pr_comma : unit -> std_ppcmds @@ -145,13 +134,11 @@ val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds val pr_loc : Loc.t -> std_ppcmds -(** {6 Low-level pretty-printing functions with and without flush} *) +(** {6 Main renderers, to formatter and to string } *) (** FIXME: These ignore the logging settings and call [Format] directly *) type tag_handler = pp_tag -> Format.tag -(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and flush [fmt] *) -val msg_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit - -(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) -val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit +(** [msg_with fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) +val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit +val string_of_ppcmds : ?pp_tag:tag_handler -> std_ppcmds -> string diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index d89bf95ee8..d8e3821557 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -66,7 +66,7 @@ let pp_header_comment = function | None -> mt () | Some com -> pp_comment com ++ fnl2 () -let then_nl pp = if Pp.is_empty pp then mt () else pp ++ fnl () +let then_nl pp = if Pp.ismt pp then mt () else pp ++ fnl () let pp_tdummy usf = if usf.tdummy || usf.tunknown then str "type __ = Obj.t" ++ fnl () else mt () @@ -618,7 +618,7 @@ and pp_module_type params = function push_visible mp params; let try_pp_specif l x = let px = pp_specif x in - if Pp.is_empty px then l else px::l + if Pp.ismt 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 @@ -696,7 +696,7 @@ and pp_module_expr params = function push_visible mp params; let try_pp_structure_elem l x = let px = pp_structure_elem x in - if Pp.is_empty px then l else px::l + if Pp.ismt 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 @@ -714,7 +714,7 @@ let rec prlist_sep_nonempty sep f = function | h::t -> let e = f h in let r = prlist_sep_nonempty sep f t in - if Pp.is_empty e then r + if Pp.ismt e then r else e ++ sep () ++ r let do_struct f s = diff --git a/printing/printer.ml b/printing/printer.ml index 00c2b636b0..5e7e9ce548 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -722,7 +722,7 @@ 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." ++ (let s = Proof_global.Bullet.suggest p in - if Pp.is_empty s then s else fnl () ++ s) ++ + if Pp.ismt s then s else fnl () ++ s) ++ fnl () in pr_subgoals ~pr_first:false (Some end_cmd) bsigma seeds shelf [] bgoals diff --git a/printing/printmod.ml b/printing/printmod.ml index ac7ff7697b..521b4ec2ae 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -405,11 +405,11 @@ let rec printable_body dir = let print_expression' is_type env mp me = States.with_state_protection - (fun e -> eval_ppcmds (print_expression is_type env mp [] e)) me + (fun e -> print_expression is_type env mp [] e) me let print_signature' is_type env mp me = States.with_state_protection - (fun e -> eval_ppcmds (print_signature is_type env mp [] e)) me + (fun e -> print_signature is_type env mp [] e) me let unsafe_print_module env mp with_body mb = let name = print_modpath [] mp in diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 5521e8a40d..2cb6083261 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -13,7 +13,9 @@ open Flags open Vernac open Pcoq -let top_stderr x = msg_with ~pp_tag:Ppstyle.to_format !Pp_control.err_ft x +let top_stderr x = + pp_with ~pp_tag:Ppstyle.to_format !Pp_control.err_ft x; + Format.pp_print_flush !Pp_control.err_ft () (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index cc1c44fe31..0ece0b0148 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -595,7 +595,7 @@ let parse_args arglist = parse () with | UserError(_, s) as e -> - if is_empty s then exit 1 + if ismt s then exit 1 else fatal_error (CErrors.print e) false | any -> fatal_error (CErrors.print any) (CErrors.is_anomaly any) diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index de7bc6929a..5d17054fce 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -143,7 +143,8 @@ let pr_new_syntax_in_context loc chan_beautify ocom = | None -> mt() in let after = comment (CLexer.extract_comments (snd loc)) in if !beautify_file then - Pp.msg_with !Pp_control.std_ft (hov 0 (before ++ com ++ after)) + (Pp.pp_with !Pp_control.std_ft (hov 0 (before ++ com ++ after)); + Format.pp_print_flush !Pp_control.std_ft ()) else Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); States.unfreeze fs; diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 148d029bc2..5b91af03ca 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -91,7 +91,7 @@ let process_vernac_interp_error with_header exn = match fst exn with let s = Lazy.force s in wrap_vernac_error with_header exn (str "Tactic failure" ++ - (if Pp.is_empty s then s else str ": " ++ s) ++ + (if Pp.ismt s then s else str ": " ++ s) ++ if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").") | AlreadyDeclared msg -> wrap_vernac_error with_header exn (msg ++ str ".") -- cgit v1.2.3 From 77b61ac3de351f462f113f8075c11518b2847935 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 29 Sep 2016 16:10:22 +0200 Subject: [pp] Make pp public to allow serialization. --- lib/pp.ml | 4 ++-- lib/pp.mli | 27 ++++++++++++++++++++++----- 2 files changed, 24 insertions(+), 7 deletions(-) diff --git a/lib/pp.ml b/lib/pp.ml index 6d7bdf75e3..140ad4e222 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -19,14 +19,14 @@ open Pp_control \end{description} *) +type pp_tag = string list + type block_type = | Pp_hbox of int | Pp_vbox of int | Pp_hvbox of int | Pp_hovbox of int -type pp_tag = string list - type std_ppcmds = | Ppcmd_empty | Ppcmd_string of string diff --git a/lib/pp.mli b/lib/pp.mli index f61261a17b..2b20179260 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -6,9 +6,29 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Pretty-printers. *) +(** Coq document type. *) -type std_ppcmds +(* XXX: Improve and add attributes *) +type pp_tag = string list + +type block_type = + | Pp_hbox of int + | Pp_vbox of int + | Pp_hvbox of int + | Pp_hovbox of int + +type std_ppcmds = + | Ppcmd_empty + | Ppcmd_string of string + | Ppcmd_glue of std_ppcmds * std_ppcmds + | Ppcmd_box of block_type * std_ppcmds + | Ppcmd_print_break of int * int + | Ppcmd_white_space of int + | Ppcmd_force_newline + | Ppcmd_open_box of block_type + | Ppcmd_close_box + | Ppcmd_open_tag of pp_tag + | Ppcmd_close_tag (** {6 Formatting commands} *) @@ -59,9 +79,6 @@ val close : unit -> std_ppcmds (** {6 Opening and closing of tags} *) -(* XXX: Improve and add attributes *) -type pp_tag = string list - val tag : pp_tag -> std_ppcmds -> std_ppcmds val open_tag : pp_tag -> std_ppcmds val close_tag : unit -> std_ppcmds -- cgit v1.2.3 From 689893ab0b648c8385ce77ec47127676088fccd5 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 30 Sep 2016 01:53:29 +0200 Subject: [pp] Implement n-ary glue. --- lib/pp.ml | 10 +++++----- lib/pp.mli | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/pp.ml b/lib/pp.ml index 140ad4e222..405fe0f86f 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -30,7 +30,7 @@ type block_type = type std_ppcmds = | Ppcmd_empty | Ppcmd_string of string - | Ppcmd_glue of std_ppcmds * std_ppcmds + | Ppcmd_glue of std_ppcmds list | Ppcmd_box of block_type * std_ppcmds | Ppcmd_print_break of int * int | Ppcmd_white_space of int @@ -80,7 +80,7 @@ let utf8_length s = let app s1 s2 = match s1, s2 with | Ppcmd_empty, s | s, Ppcmd_empty -> s - | s1, s2 -> Ppcmd_glue(s1, s2) + | s1, s2 -> Ppcmd_glue [s1; s2] let (++) = app @@ -109,7 +109,7 @@ let strbrk s = else str (String.sub s p (n-p)) :: spc () :: aux (n+1) (n+1) else aux p (n + 1) else if p = n then [] else [str (String.sub s p (n-p))] - in List.fold_left (++) Ppcmd_empty (aux 0 0) + in Ppcmd_glue (aux 0 0) let pr_loc_pos loc = if Loc.is_ghost loc then (str"") @@ -187,7 +187,7 @@ let pp_with ?pp_tag ft = in let rec pp_cmd = let open Format in function | Ppcmd_empty -> () - | Ppcmd_glue(s1,s2) -> pp_cmd s1; pp_cmd s2 + | Ppcmd_glue sl -> List.iter pp_cmd sl | Ppcmd_string str -> let n = utf8_length str in pp_print_as ft n str | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) @@ -250,7 +250,7 @@ let pr_nth n = (* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *) -let prlist pr l = List.fold_left (fun x e -> x ++ pr e) Ppcmd_empty l +let prlist pr l = Ppcmd_glue (List.map pr l) (* unlike all other functions below, [prlist] works lazily. if a strict behavior is needed, use [prlist_strict] instead. diff --git a/lib/pp.mli b/lib/pp.mli index 2b20179260..bd8509dbce 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -20,7 +20,7 @@ type block_type = type std_ppcmds = | Ppcmd_empty | Ppcmd_string of string - | Ppcmd_glue of std_ppcmds * std_ppcmds + | Ppcmd_glue of std_ppcmds list | Ppcmd_box of block_type * std_ppcmds | Ppcmd_print_break of int * int | Ppcmd_white_space of int -- cgit v1.2.3 From 6c521565323ae8af22fb03e65664ef944da6ecdf Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 30 Sep 2016 17:12:11 +0200 Subject: [pp] Force well-tagged docs by construction. We replace open/close tag commands by a well-balanced "tag" wrapper. --- lib/pp.ml | 20 +++++--------------- lib/pp.mli | 6 ++---- 2 files changed, 7 insertions(+), 19 deletions(-) diff --git a/lib/pp.ml b/lib/pp.ml index 405fe0f86f..4ff10b4d72 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -38,8 +38,7 @@ type std_ppcmds = | Ppcmd_open_box of block_type | Ppcmd_close_box | Ppcmd_comment of string list - | Ppcmd_open_tag of pp_tag - | Ppcmd_close_tag + | Ppcmd_tag of pp_tag * std_ppcmds (* Compute length of an UTF-8 encoded string Rem 1 : utf8_length <= String.length (equal if pure ascii) @@ -146,9 +145,7 @@ let hovb n = Ppcmd_open_box(Pp_hovbox n) let close () = Ppcmd_close_box (* Opening and closed of tags *) -let open_tag t = Ppcmd_open_tag t -let close_tag () = Ppcmd_close_tag -let tag t s = open_tag t ++ s ++ close_tag () +let tag t s = Ppcmd_tag(t,s) (* In new syntax only double quote char is escaped by repeating it *) let escape_string s = @@ -200,16 +197,9 @@ let pp_with ?pp_tag ft = | Ppcmd_print_break(m,n) -> pp_print_break ft m n | Ppcmd_force_newline -> pp_force_newline ft () | Ppcmd_comment coms -> List.iter (pr_com ft) coms - | Ppcmd_open_tag tag -> - begin match pp_tag with - | None -> () - | Some f -> Format.pp_open_tag ft (f tag) - end - | Ppcmd_close_tag -> - begin match pp_tag with - | None -> () - | Some _ -> Format.pp_close_tag ft () - end + | Ppcmd_tag(tag, s) -> Option.iter (fun f -> pp_open_tag ft (f tag)) pp_tag; + pp_cmd s; + Option.iter (fun _ -> pp_close_tag ft () ) pp_tag in try pp_cmd with reraise -> diff --git a/lib/pp.mli b/lib/pp.mli index bd8509dbce..ed97226ae2 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -27,8 +27,8 @@ type std_ppcmds = | Ppcmd_force_newline | Ppcmd_open_box of block_type | Ppcmd_close_box - | Ppcmd_open_tag of pp_tag - | Ppcmd_close_tag + | Ppcmd_comment of string list + | Ppcmd_tag of pp_tag * std_ppcmds (** {6 Formatting commands} *) @@ -80,8 +80,6 @@ val close : unit -> std_ppcmds (** {6 Opening and closing of tags} *) val tag : pp_tag -> std_ppcmds -> std_ppcmds -val open_tag : pp_tag -> std_ppcmds -val close_tag : unit -> std_ppcmds (** {6 Printing combinators} *) -- cgit v1.2.3 From fd6271089a0f0fcaa6d89e347d76247c7c831d23 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 30 Sep 2016 19:44:13 +0200 Subject: [pp] Force well-formed boxes by construction. We replace open/close box commands in favor of the create box ones. --- lib/pp.ml | 14 ++------------ lib/pp.mli | 15 +++------------ plugins/rtauto/proof_search.ml | 6 +++--- 3 files changed, 8 insertions(+), 27 deletions(-) diff --git a/lib/pp.ml b/lib/pp.ml index 4ff10b4d72..388eed9e45 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -32,13 +32,12 @@ type std_ppcmds = | Ppcmd_string of string | Ppcmd_glue of std_ppcmds list | Ppcmd_box of block_type * std_ppcmds + | Ppcmd_tag of pp_tag * std_ppcmds + (* Are those redundant? *) | Ppcmd_print_break of int * int | Ppcmd_white_space of int | Ppcmd_force_newline - | Ppcmd_open_box of block_type - | Ppcmd_close_box | Ppcmd_comment of string list - | Ppcmd_tag of pp_tag * std_ppcmds (* Compute length of an UTF-8 encoded string Rem 1 : utf8_length <= String.length (equal if pure ascii) @@ -137,13 +136,6 @@ let v n s = Ppcmd_box(Pp_vbox n,s) let hv n s = Ppcmd_box(Pp_hvbox n,s) let hov n s = Ppcmd_box(Pp_hovbox n,s) -(* Opening and closing of boxes *) -let hb n = Ppcmd_open_box(Pp_hbox n) -let vb n = Ppcmd_open_box(Pp_vbox n) -let hvb n = Ppcmd_open_box(Pp_hvbox n) -let hovb n = Ppcmd_open_box(Pp_hovbox n) -let close () = Ppcmd_close_box - (* Opening and closed of tags *) let tag t s = Ppcmd_tag(t,s) @@ -191,8 +183,6 @@ let pp_with ?pp_tag ft = cpp_open_box bty ; if not (Format.over_max_boxes ()) then pp_cmd ss; Format.pp_close_box ft () - | Ppcmd_open_box bty -> cpp_open_box bty - | Ppcmd_close_box -> pp_close_box ft () | Ppcmd_white_space n -> pp_print_break ft n 0 | Ppcmd_print_break(m,n) -> pp_print_break ft m n | Ppcmd_force_newline -> pp_force_newline ft () diff --git a/lib/pp.mli b/lib/pp.mli index ed97226ae2..cee7fa0528 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -22,13 +22,12 @@ type std_ppcmds = | Ppcmd_string of string | Ppcmd_glue of std_ppcmds list | Ppcmd_box of block_type * std_ppcmds + | Ppcmd_tag of pp_tag * std_ppcmds + (* Are those redundant? *) | Ppcmd_print_break of int * int | Ppcmd_white_space of int | Ppcmd_force_newline - | Ppcmd_open_box of block_type - | Ppcmd_close_box | Ppcmd_comment of string list - | Ppcmd_tag of pp_tag * std_ppcmds (** {6 Formatting commands} *) @@ -69,15 +68,7 @@ val v : int -> std_ppcmds -> std_ppcmds val hv : int -> std_ppcmds -> std_ppcmds val hov : int -> std_ppcmds -> std_ppcmds -(** {6 Opening and closing of boxes} *) - -val hb : int -> std_ppcmds -val vb : int -> std_ppcmds -val hvb : int -> std_ppcmds -val hovb : int -> std_ppcmds -val close : unit -> std_ppcmds - -(** {6 Opening and closing of tags} *) +(** {6 Tagging} *) val tag : pp_tag -> std_ppcmds -> std_ppcmds diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 8b92611136..1ad4d622b2 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -505,12 +505,12 @@ let pp_mapint map = pp_form obj ++ str " => " ++ pp_list (fun (i,f) -> pp_form f) l ++ cut ()) ) map; - str "{ " ++ vb 0 ++ (!pp) ++ str " }" ++ close () + str "{ " ++ hv 0 (!pp ++ str " }") let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2 let pp_gl gl= cut () ++ - str "{ " ++ vb 0 ++ + str "{ " ++ hv 0 ( begin match gl.abs with None -> str "" @@ -520,7 +520,7 @@ let pp_gl gl= cut () ++ str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++ str "arrows=" ++ pp_mapint gl.right ++ cut () ++ str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++ - str "goal =" ++ pp_form gl.gl ++ str " }" ++ close () + str "goal =" ++ pp_form gl.gl ++ str " }") let pp = function -- cgit v1.2.3 From 7440be4ffaf6ace5b8e94354c9a56462f45fa2dd Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 30 Sep 2016 19:45:32 +0200 Subject: [pp] Remove redundant white spacing pp construct. --- lib/pp.ml | 4 +--- lib/pp.mli | 1 - 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/lib/pp.ml b/lib/pp.ml index 388eed9e45..d763767dc2 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -35,7 +35,6 @@ type std_ppcmds = | Ppcmd_tag of pp_tag * std_ppcmds (* Are those redundant? *) | Ppcmd_print_break of int * int - | Ppcmd_white_space of int | Ppcmd_force_newline | Ppcmd_comment of string list @@ -86,7 +85,7 @@ let (++) = app let str s = Ppcmd_string s let brk (a,b) = Ppcmd_print_break (a,b) let fnl () = Ppcmd_force_newline -let ws n = Ppcmd_white_space n +let ws n = Ppcmd_print_break (n,0) let comment l = Ppcmd_comment l (* derived commands *) @@ -183,7 +182,6 @@ let pp_with ?pp_tag ft = cpp_open_box bty ; if not (Format.over_max_boxes ()) then pp_cmd ss; Format.pp_close_box ft () - | Ppcmd_white_space n -> pp_print_break ft n 0 | Ppcmd_print_break(m,n) -> pp_print_break ft m n | Ppcmd_force_newline -> pp_force_newline ft () | Ppcmd_comment coms -> List.iter (pr_com ft) coms diff --git a/lib/pp.mli b/lib/pp.mli index cee7fa0528..5bf5391d3b 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -25,7 +25,6 @@ type std_ppcmds = | Ppcmd_tag of pp_tag * std_ppcmds (* Are those redundant? *) | Ppcmd_print_break of int * int - | Ppcmd_white_space of int | Ppcmd_force_newline | Ppcmd_comment of string list -- cgit v1.2.3 From eb68e001f2ebbf09dc32c999e9c9b0f116c0a530 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 30 Sep 2016 19:58:06 +0200 Subject: [feedback] Allow to remove feedback listeners. --- lib/feedback.ml | 13 ++++++++++--- lib/feedback.mli | 7 +++++-- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/lib/feedback.ml b/lib/feedback.ml index 971a51e354..852eec2f26 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -180,8 +180,15 @@ let msg_error ?loc x = !logger ?loc Error x let msg_debug ?loc x = !logger ?loc Debug x (** Feeders *) -let feeders = ref [] -let add_feeder f = feeders := f :: !feeders +let feeders : (int, feedback -> unit) Hashtbl.t = Hashtbl.create 7 + +let add_feeder = + let f_id = ref 0 in fun f -> + incr f_id; + Hashtbl.add feeders !f_id f; + !f_id + +let del_feeder fid = Hashtbl.remove feeders fid let debug_feeder = function | { contents = Message (Debug, loc, pp) } -> @@ -200,7 +207,7 @@ let feedback ?id ?route what = route = Option.default !feedback_route route; id = Option.default !feedback_id id; } in - List.iter (fun f -> f m) !feeders + Hashtbl.iter (fun _ f -> f m) feeders let feedback_logger ?loc lvl msg = feedback ~route:!feedback_route ~id:!feedback_id diff --git a/lib/feedback.mli b/lib/feedback.mli index b4bed8793d..8eae315883 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -79,8 +79,11 @@ val feedback_logger : logger val emacs_logger : logger -(** [add_feeder] feeders observe the feedback *) -val add_feeder : (feedback -> unit) -> unit +(** [add_feeder f] adds a feeder listiner [f], returning its id *) +val add_feeder : (feedback -> unit) -> int + +(** [del_feeder fid] removes the feeder with id [fid] *) +val del_feeder : int -> unit (** Prints feedback messages of kind Message(Debug,_) using msg_debug *) val debug_feeder : feedback -> unit -- cgit v1.2.3 From f0341076aa60a84177a6b46db0d8d50df220536b Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 6 Dec 2016 17:16:16 +0100 Subject: [error] Move back fatal_error to toplevel This reverts 4444768d3f4f9c4fcdd440f7ab902886bd8e2b09 (the mllib dependencies that should be surely tweaked more). The logic for `fatal_error` has no place in `CErrors`, this is coqtop-specific code. What is more, a libobject caller should handle the exception correctly, I fail to see why the fix was needed on the first place. --- lib/cErrors.ml | 10 ---------- lib/cErrors.mli | 5 ----- library/libobject.ml | 12 ++---------- toplevel/coqtop.ml | 7 +++++++ 4 files changed, 9 insertions(+), 25 deletions(-) diff --git a/lib/cErrors.ml b/lib/cErrors.ml index 9cbc3fb6d6..a059640394 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -147,13 +147,3 @@ let handled e = let bottom _ = raise Bottom in try let _ = print_gen bottom !handle_stack e in true with Bottom -> false - -(** Prints info which is either an error or - an anomaly and then exits with the appropriate - error code *) - -let fatal_error info anomaly = - let msg = info ++ fnl () in - pp_with !Pp_control.err_ft msg; - Format.pp_print_flush !Pp_control.err_ft (); - exit (if anomaly then 129 else 1) diff --git a/lib/cErrors.mli b/lib/cErrors.mli index 5cffc725d9..0665a8ce73 100644 --- a/lib/cErrors.mli +++ b/lib/cErrors.mli @@ -98,8 +98,3 @@ val noncritical : exn -> bool (** Check whether an exception is handled by some toplevel printer. The [Anomaly] exception is never handled. *) val handled : exn -> bool - -(** Prints info which is either an error or - an anomaly and then exits with the appropriate - error code *) -val fatal_error : Pp.std_ppcmds -> bool -> 'a diff --git a/library/libobject.ml b/library/libobject.ml index caa03c85be..8757ca08c6 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -91,16 +91,8 @@ let declare_object_full odecl = dyn_rebuild_function = rebuild }; (infun,outfun) -(* The "try .. with .. " allows for correct printing when calling - declare_object a loading time. -*) - -let declare_object odecl = - try fst (declare_object_full odecl) - with e -> CErrors.fatal_error (CErrors.print e) (CErrors.is_anomaly e) -let declare_object_full odecl = - try declare_object_full odecl - with e -> CErrors.fatal_error (CErrors.print e) (CErrors.is_anomaly e) +let declare_object odecl = fst (declare_object_full odecl) +let declare_object_full odecl = declare_object_full odecl (* this function describes how the cache, load, open, and export functions are triggered. *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 0ece0b0148..541c1fd1bb 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -431,6 +431,13 @@ let get_native_name s = Nativelib.output_dir; Library.native_name_from_filename s] with _ -> "" +(** Prints info which is either an error or an anomaly and then exits + with the appropriate error code *) +let fatal_error info anomaly = + let msg = info ++ fnl () in + Format.fprintf !Topfmt.err_ft "@[%a@]%!" pp_with msg; + exit (if anomaly then 129 else 1) + let parse_args arglist = let args = ref arglist in let extras = ref [] in -- cgit v1.2.3 From 5b8bfee9d80e550cd81e326ec134430b2a4797a5 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 29 Sep 2016 16:30:21 +0200 Subject: [pp] Make feedback the only logging mechanism. Previously to this patch, Coq featured to distinct logging paths: the console legacy one, based on `Pp.std_ppcmds` and Ocaml's `Format` module, and the `Feedback` one, intended to encapsulate message inside a more general, GUI-based feedback protocol. This patch removes the legacy logging path and makes feedback canonical. Thus, the core of Coq has no dependency on console code anymore. Additionally, this patch resolves the duplication of "document" formats present in the same situation. The original console-based printing code relied on an opaque datatype `std_ppcmds`, (mostly a reification of `Format`'s format strings) that could be then rendered to the console. However, the feedback path couldn't reuse this type due to its opaque nature. The first versions just embedded rending of `std_ppcmds` to a string, however in 8.5 a new "rich printing" type, `Richpp.richpp` was introduced. The idea for this type was to be serializable, however it brought several problems: it didn't have proper document manipulation operations, its format was overly verbose and didn't preserve the full layout, and it still relied on `Format` for generation, making client-side rendering difficult. We thus follow the plan outlined in CEP#9, that is to say, we take a public and refactored version of `std_ppcmds` as the canonical "document type", and move feedback to be over there. The toplevel now is implemented as a feedback listener and has ownership of the console. `richpp` is now IDE-specific, and only used for legacy rendering. It could go away in future versions. `std_ppcmds` carries strictly more information and is friendlier to client-side rendering and display control. Thus, the new panorama is: - `Feedback` has become a very module for event dispatching. - `Pp` contains a target-independent box-based document format. It also contains the `Format`-based renderer. - All console access lives in `toplevel`, with console handlers private to coqtop. _NOTE_: After this patch, many printing parameters such as printing width or depth should be set client-side. This works better IMO, clients don't need to notify Coq about resizing anywmore. Indeed, for box-based capable backends such as HTML or LaTeX, the UI can directly render and let the engine perform the word breaking work. _NOTE_: Many messages could benefit from new features of the output format, however we have chosen not to alter them to preserve output. A Future commits will move console tag handling in `Pp_style` to `toplevel/`, where it logically belongs. The only change with regards to printing is that the "Error:" header was added to console output in several different positions, we have removed some of this duplication, now error messages should be a bit more consistent. --- Makefile.build | 7 +- dev/doc/changes.txt | 52 +++++++ dev/top_printers.ml | 2 +- ide/coq.ml | 2 +- ide/coqOps.ml | 44 +++--- ide/coqide.ml | 16 +- ide/coqidetop.mllib | 2 +- ide/ide.mllib | 4 +- ide/ide_slave.ml | 20 +-- ide/ideutils.ml | 4 +- ide/ideutils.mli | 2 +- ide/interface.mli | 9 +- ide/richpp.ml | 200 +++++++++++++++++++++++++ ide/richpp.mli | 64 ++++++++ ide/wg_Command.ml | 2 +- ide/wg_MessageView.ml | 21 +-- ide/wg_MessageView.mli | 4 +- ide/wg_ProofView.ml | 12 +- ide/xmlprotocol.ml | 71 +++++++-- ide/xmlprotocol.mli | 3 +- lib/cErrors.ml | 14 +- lib/clib.mllib | 4 +- lib/feedback.ml | 177 ++-------------------- lib/feedback.mli | 33 +---- lib/pp.ml | 9 +- lib/pp.mli | 24 +++ lib/pp_control.ml | 93 ------------ lib/pp_control.mli | 38 ----- lib/richpp.ml | 200 ------------------------- lib/richpp.mli | 64 -------- plugins/extraction/extract_env.ml | 5 +- stm/asyncTaskQueue.ml | 12 +- stm/stm.ml | 10 +- test-suite/output/Arguments.out | 4 +- test-suite/output/Arguments_renaming.out | 14 +- test-suite/output/Errors.out | 2 +- test-suite/output/FunExt.out | 2 +- test-suite/output/Notations.out | 20 +-- test-suite/output/ltac.out | 5 +- test-suite/output/ltac_missing_args.out | 21 ++- tools/fake_ide.ml | 12 +- toplevel/coqloop.ml | 63 +++++--- toplevel/coqloop.mli | 2 + toplevel/coqtop.ml | 28 +++- toplevel/vernac.ml | 9 +- vernac/explainErr.ml | 42 +++--- vernac/explainErr.mli | 2 +- vernac/topfmt.ml | 245 +++++++++++++++++++++++++++++++ vernac/topfmt.mli | 49 +++++++ vernac/vernac.mllib | 1 + vernac/vernacentries.ml | 12 +- 51 files changed, 923 insertions(+), 834 deletions(-) create mode 100644 ide/richpp.ml create mode 100644 ide/richpp.mli delete mode 100644 lib/pp_control.ml delete mode 100644 lib/pp_control.mli delete mode 100644 lib/richpp.ml delete mode 100644 lib/richpp.mli create mode 100644 vernac/topfmt.ml create mode 100644 vernac/topfmt.mli diff --git a/Makefile.build b/Makefile.build index 9d76638e12..c62420326a 100644 --- a/Makefile.build +++ b/Makefile.build @@ -440,9 +440,10 @@ $(COQWORKMGR): $(call bestobj, lib/clib.cma stm/coqworkmgrApi.cmo tools/coqworkm # fake_ide : for debugging or test-suite purpose, a fake ide simulating # a connection to coqtop -ideslave -FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo ide/document.cmo \ - ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo ide/xml_printer.cmo \ - ide/xmlprotocol.cmo tools/fake_ide.cmo +FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo \ + ide/document.cmo ide/serialize.cmo ide/richpp.cmo ide/xml_lexer.cmo \ + ide/xml_parser.cmo ide/xml_printer.cmo ide/xmlprotocol.cmo \ + tools/fake_ide.cmo $(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOPLOOPCMA:.cma=$(BESTDYN)) $(SHOW)'OCAMLBEST -o $@' diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 12c3ec4546..53e9a282fa 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -70,6 +70,58 @@ work for EXTEND macros though. - The header parameter to `user_err` has been made optional. +** Pretty printing ** + +Some functions have been removed, see pretty printing below for more +details. + +* Pretty Printing and XML protocol * + +The type std_cmdpps has been reworked and made the canonical "Coq rich +document type". This allows for a more uniform handling of printing +(specially in IDEs). The main consequences are: + + - Richpp has been confined to IDE use. Most of previous uses of the + `richpp` type should be replaced now by `Pp.std_cmdpps`. Main API + has been updated. + + - The XML protocol will send a new message type of `pp`, which should + be rendered client-wise. + + - `Set Printing Width` is deprecated, now width is controlled + client-side. + + - `Pp_control` has removed. The new module `Topfmt` implements + console control for the toplevel. + + - The impure tag system in Pp has been removed. This also does away + with the printer signatures and functors. Now printers tag + unconditionally. + + - The following functions have been removed from `Pp`: + + val stras : int * string -> std_ppcmds + val tbrk : int * int -> std_ppcmds + val tab : unit -> std_ppcmds + val pifb : unit -> std_ppcmds + val comment : int -> std_ppcmds + val comments : ((int * int) * string) list ref + val eval_ppcmds : std_ppcmds -> std_ppcmds + val is_empty : std_ppcmds -> bool + val t : std_ppcmds -> std_ppcmds + val hb : int -> std_ppcmds + val vb : int -> std_ppcmds + val hvb : int -> std_ppcmds + val hovb : int -> std_ppcmds + val tb : unit -> std_ppcmds + val close : unit -> std_ppcmds + val tclose : unit -> std_ppcmds + val open_tag : Tag.t -> std_ppcmds + val close_tag : unit -> std_ppcmds + val msg_with : ... + + module Tag + ========================================= = CHANGES BETWEEN COQ V8.5 AND COQ V8.6 = ========================================= diff --git a/dev/top_printers.ml b/dev/top_printers.ml index dc354b130b..cd464801b0 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -29,7 +29,7 @@ let _ = set_bool_option_value ["Printing";"Matching"] false let _ = Detyping.set_detype_anonymous (fun _ _ -> raise Not_found) (* std_ppcmds *) -let pp x = Pp.pp_with !Pp_control.std_ft x +let pp x = Pp.pp_with !Topfmt.std_ft x (** Future printer *) diff --git a/ide/coq.ml b/ide/coq.ml index 9637b5b3f2..e2036beee3 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -205,7 +205,7 @@ type handle = { proc : CoqTop.process; xml_oc : Xml_printer.t; mutable alive : bool; - mutable waiting_for : ccb option; (* last call + callback + log *) + mutable waiting_for : ccb option; (* last call + callback *) } (** Coqtop process status : diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 0f3629c8fc..7982ffc8b8 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -162,13 +162,16 @@ 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) +(* Move to utils? *) +let rec validate (s : Pp.std_ppcmds) = match s with + | Pp.Ppcmd_empty + | Pp.Ppcmd_print_break _ + | Pp.Ppcmd_force_newline -> true + | Pp.Ppcmd_glue l -> List.for_all validate l + | Pp.Ppcmd_string s -> Glib.Utf8.validate s + | Pp.Ppcmd_box (_,s) + | Pp.Ppcmd_tag (_,s) -> validate s + | Pp.Ppcmd_comment s -> List.for_all Glib.Utf8.validate s module Doc = Document @@ -418,9 +421,10 @@ object(self) | _ -> false method private enqueue_feedback msg = + (* Minilib.log ("Feedback received: " ^ Xml_printer.to_string_fmt (Xmlprotocol.of_feedback msg)); *) let id = msg.id in if self#is_dummy_id id then () else Queue.add msg feedbacks - + method private process_feedback () = let rec eat_feedback n = if n = 0 then true else @@ -466,7 +470,7 @@ object(self) (Printf.sprintf "%s %s %s" filepath ident ty) | Message(Error, loc, msg), Some (id,sentence) -> let loc = Option.default Loc.ghost loc in - let msg = Richpp.raw_print msg in + let msg = Pp.string_of_ppcmds msg in log "ErrorMsg" id; remove_flag sentence `PROCESSING; add_flag sentence (`ERROR (loc, msg)); @@ -476,14 +480,15 @@ object(self) self#position_error_tag_at_sentence sentence (Some (Loc.unloc loc)) | Message(Warning, loc, msg), Some (id,sentence) -> let loc = Option.default Loc.ghost loc in - let rmsg = Richpp.raw_print msg in - log "WarningMsg" id; + let rmsg = Pp.string_of_ppcmds msg in + log ("WarningMsg: " ^ Pp.string_of_ppcmds msg)id; add_flag sentence (`WARNING (loc, rmsg)); self#attach_tooltip sentence loc rmsg; self#position_warning_tag_at_sentence sentence loc; messages#push Warning msg | Message(lvl, loc, msg), Some (id,sentence) -> - messages#push lvl msg + log ("Msg: " ^ Pp.string_of_ppcmds msg) id; + messages#push lvl msg | InProgress n, _ -> if n < 0 then processed <- processed + abs n else to_process <- to_process + n @@ -629,10 +634,9 @@ object(self) if Queue.is_empty queue then conclude topstack else match Queue.pop queue, topstack with | `Skip(start,stop), [] -> - - logger Feedback.Error (Richpp.richpp_of_string "You must close the proof with Qed or Admitted"); + logger Feedback.Error (Pp.str "You must close the proof with Qed or Admitted"); self#discard_command_queue queue; - conclude [] + conclude [] | `Skip(start,stop), (_,s) :: topstack -> assert(start#equal (buffer#get_iter_at_mark s.start)); assert(stop#equal (buffer#get_iter_at_mark s.stop)); @@ -646,7 +650,7 @@ object(self) let handle_answer = function | Good (id, (Util.Inl (* NewTip *) (), msg)) -> Doc.assign_tip_id document id; - logger Feedback.Notice (Richpp.richpp_of_string msg); + logger Feedback.Notice (Pp.str msg); self#commit_queue_transaction sentence; loop id [] | Good (id, (Util.Inr (* Unfocus *) tip, msg)) -> @@ -654,7 +658,7 @@ object(self) let topstack, _ = Doc.context document in self#exit_focus; self#cleanup (Doc.cut_at document tip); - logger Feedback.Notice (Richpp.richpp_of_string msg); + logger Feedback.Notice (Pp.str msg); self#mark_as_needed sentence; if Queue.is_empty queue then loop tip [] else loop tip (List.rev topstack) @@ -673,7 +677,7 @@ object(self) let next = function | Good _ -> messages#clear; - messages#push Feedback.Info (Richpp.richpp_of_string "All proof terms checked by the kernel"); + messages#push Feedback.Info (Pp.str "All proof terms checked by the kernel"); Coq.return () | Fail x -> self#handle_failure x in Coq.bind (Coq.status true) next @@ -860,7 +864,7 @@ object(self) let next = function | Fail (_, l, str) -> (* FIXME: check *) display_error (l, str); - messages#add (Richpp.richpp_of_string ("Unsuccessfully tried: "^phrase)); + messages#add (Pp.str ("Unsuccessfully tried: "^phrase)); more | Good msg -> messages#add_string msg; @@ -906,7 +910,7 @@ object(self) let get_initial_state = let next = function | Fail (_, _, message) -> - let message = "Couldn't initialize coqtop\n\n" ^ (Richpp.raw_print message) in + let message = "Couldn't initialize coqtop\n\n" ^ (Pp.string_of_ppcmds 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 diff --git a/ide/coqide.ml b/ide/coqide.ml index 3d56f9dd49..25858acced 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -318,7 +318,7 @@ let export kind sn = local_cd f ^ cmd_coqdoc#get ^ " --" ^ kind ^ " -o " ^ (Filename.quote output) ^ " " ^ (Filename.quote basef) ^ " 2>&1" in - sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd)); + sn.messages#set (Pp.str ("Running: "^cmd)); let finally st = flash_info (cmd ^ pr_exit_status st) in run_command (fun msg -> sn.messages#add_string msg) finally cmd @@ -431,7 +431,7 @@ let compile sn = ^ " " ^ (Filename.quote f) ^ " 2>&1" in let buf = Buffer.create 1024 in - sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd)); + sn.messages#set (Pp.str ("Running: "^cmd)); let display s = sn.messages#add_string s; Buffer.add_string buf s @@ -441,8 +441,8 @@ let compile sn = flash_info (f ^ " successfully compiled") else begin flash_info (f ^ " failed to compile"); - sn.messages#set (Richpp.richpp_of_string "Compilation output:\n"); - sn.messages#add (Richpp.richpp_of_string (Buffer.contents buf)); + sn.messages#set (Pp.str "Compilation output:\n"); + sn.messages#add (Pp.str (Buffer.contents buf)); end in run_command display finally cmd @@ -464,7 +464,7 @@ let make sn = |Some f -> File.saveall (); let cmd = local_cd f ^ cmd_make#get ^ " 2>&1" in - sn.messages#set (Richpp.richpp_of_string "Compilation output:\n"); + sn.messages#set (Pp.str "Compilation output:\n"); Buffer.reset last_make_buf; last_make := ""; last_make_index := 0; @@ -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 (Richpp.richpp_of_string error_msg); + sn.messages#set (Pp.str error_msg); sn.script#misc#grab_focus () with Not_found -> last_make_index := 0; - sn.messages#set (Richpp.richpp_of_string "No more errors.\n") + sn.messages#set (Pp.str "No more errors.\n") let next_error = cb_on_current_term next_error @@ -789,7 +789,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 Feedback.Error (Richpp.richpp_of_string msg) + sn.messages#push Feedback.Error (Pp.str msg) else dialog#destroy () in let _ = entry#connect#activate ok_cb in diff --git a/ide/coqidetop.mllib b/ide/coqidetop.mllib index ed1fa465d2..043ad6008b 100644 --- a/ide/coqidetop.mllib +++ b/ide/coqidetop.mllib @@ -2,7 +2,7 @@ Xml_lexer Xml_parser Xml_printer Serialize -Richprinter +Richpp Xmlprotocol Texmacspp Document diff --git a/ide/ide.mllib b/ide/ide.mllib index 72a14134bf..12170c4621 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -9,11 +9,11 @@ Config_lexer Utf8_convert Preferences Project_file -Serialize -Richprinter Xml_lexer Xml_parser Xml_printer +Serialize +Richpp Xmlprotocol Ideutils Coq diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 0cb8d377f6..88b61042ed 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -32,9 +32,6 @@ let init_signal_handler () = let f _ = if !catch_break then raise Sys.Break else Control.interrupt := true in Sys.set_signal Sys.sigint (Sys.Signal_handle f) - -(** Redirection of standard output to a printable buffer *) - let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s let pr_error s = pr_with_pid s @@ -174,13 +171,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 - Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr) + pr_goal_concl_style_env env sigma norm_constr in let process_hyp d (env,l) = let d = CompactedDecl.map_constr (Reductionops.nf_evar sigma) d in let d' = CompactedDecl.to_named_context d in (List.fold_right Environ.push_named d' env, - (Richpp.richpp_of_pp (pr_compacted_decl env sigma d)) :: l) in + (pr_compacted_decl env sigma d) :: l) in let (_env, hyps) = Context.Compacted.fold process_hyp (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in @@ -340,13 +337,10 @@ 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 () = - let msg = CErrors.print ~info e in - Richpp.richpp_of_pp msg - in + let mk_msg () = CErrors.print ~info e in match e with - | CErrors.Drop -> dummy, None, Richpp.richpp_of_string "Drop is not allowed by coqide!" - | CErrors.Quit -> dummy, None, Richpp.richpp_of_string "Quit is not allowed by coqide!" + | CErrors.Drop -> dummy, None, Pp.str "Drop is not allowed by coqide!" + | CErrors.Quit -> dummy, None, Pp.str "Quit is not allowed by coqide!" | e -> match Stateid.get info with | Some (valid, _) -> valid, loc_of info, mk_msg () @@ -446,7 +440,6 @@ let print_xml = try Xml_printer.print oc xml; Mutex.unlock m with e -> let e = CErrors.push e in Mutex.unlock m; iraise e - let slave_feeder xml_oc msg = let xml = Xmlprotocol.of_feedback msg in print_xml xml_oc xml @@ -467,7 +460,6 @@ let loop () = (* SEXP parser make *) let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in let () = Xml_parser.check_eof xml_ic false in - Feedback.set_logger Feedback.feedback_logger; Feedback.add_feeder (slave_feeder xml_oc); (* We'll handle goal fetching and display in our own way *) Vernacentries.enable_goal_printing := false; @@ -478,7 +470,7 @@ let loop () = (* pr_with_pid (Xml_printer.to_string_fmt xml_query); *) let Xmlprotocol.Unknown q = Xmlprotocol.to_call xml_query in let () = pr_debug_call q in - let r = eval_call q in + let r = eval_call q in let () = pr_debug_answer q r in (* pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *) print_xml xml_oc (Xmlprotocol.of_answer q r); diff --git a/ide/ideutils.ml b/ide/ideutils.ml index c3a2807967..498a911ee4 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -327,7 +327,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 = Feedback.level -> Richpp.richpp -> unit +type logger = Feedback.level -> Pp.std_ppcmds -> unit let default_logger level message = let level = match level with @@ -337,7 +337,7 @@ let default_logger level message = | Feedback.Warning -> `WARNING | Feedback.Error -> `ERROR in - Minilib.log ~level (xml_to_string message) + Minilib.log ~level (Pp.string_of_ppcmds message) (** {6 File operations} *) diff --git a/ide/ideutils.mli b/ide/ideutils.mli index e32a4d9e38..1ae66e23e9 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -69,7 +69,7 @@ val requote : string -> string val textview_width : #GText.view_skel -> int (** Returns an approximate value of the character width of a textview *) -type logger = Feedback.level -> Richpp.richpp -> unit +type logger = Feedback.level -> Pp.std_ppcmds -> unit val default_logger : logger (** Default logger. It logs messages that the casual user should not see. *) diff --git a/ide/interface.mli b/ide/interface.mli index 123cac6c22..43446f3918 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -12,15 +12,14 @@ type raw = bool type verbose = bool -type richpp = Richpp.richpp (** The type of coqtop goals *) type goal = { goal_id : string; (** Unique goal identifier *) - goal_hyp : richpp list; + goal_hyp : Pp.std_ppcmds list; (** List of hypotheses *) - goal_ccl : richpp; + goal_ccl : Pp.std_ppcmds; (** Goal conclusion *) } @@ -119,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 * richpp) + | Fail of (state_id * location * Pp.std_ppcmds) type ('a, 'b) union = ('a, 'b) Util.union @@ -203,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 * richpp +type handle_exn_rty = state_id * location * Pp.std_ppcmds (* Retrocompatibility stuff *) type interp_sty = (raw * verbose) * string diff --git a/ide/richpp.ml b/ide/richpp.ml new file mode 100644 index 0000000000..c0128dbc2d --- /dev/null +++ b/ide/richpp.ml @@ -0,0 +1,200 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* assert false + | Node (node, child, pos, ctx) -> + let data = Buffer.contents pp_buffer in + let () = Buffer.clear pp_buffer in + let () = context.stack <- Node (node, PCData data :: child, pos, ctx) in + context.offset <- context.offset + len + in + + let open_xml_tag tag = + let () = push_pcdata () in + context.stack <- Node (tag, [], context.offset, context.stack) + in + + let close_xml_tag tag = + let () = push_pcdata () in + match context.stack with + | Leaf -> assert false + | Node (node, child, pos, ctx) -> + let () = assert (String.equal tag node) in + let annotation = + try Int.Map.find (int_of_string node) context.annotations + with _ -> None + in + let annotation = { + annotation = annotation; + startpos = pos; + endpos = context.offset; + } in + let xml = Element (node, annotation, List.rev child) in + match ctx with + | Leaf -> + (** Final node: we keep the result in a dummy context *) + context.stack <- Node ("", [xml], 0, Leaf) + | Node (node, child, pos, ctx) -> + context.stack <- Node (node, xml :: child, pos, ctx) + in + + let open Format in + + let ft = formatter_of_buffer pp_buffer in + + let tag_functions = { + mark_open_tag = (fun tag -> let () = open_xml_tag tag in ""); + mark_close_tag = (fun tag -> let () = close_xml_tag tag in ""); + print_open_tag = ignore; + print_close_tag = ignore; + } in + + pp_set_formatter_tag_functions ft tag_functions; + pp_set_mark_tags ft true; + + (* Set formatter width. This is currently a hack and duplicate code + with Pp_control. Hopefully it will be fixed better in Coq 8.7 *) + let w = pp_get_margin str_formatter () in + let m = max (64 * w / 100) (w-30) in + pp_set_margin ft w; + pp_set_max_indent ft m; + + (** The whole output must be a valid document. To that + end, we nest the document inside tags. *) + pp_open_tag ft "pp"; + Pp.(pp_with ~pp_tag ft ppcmds); + pp_close_tag ft (); + + (** Get the resulting XML tree. *) + let () = pp_print_flush ft () in + let () = assert (Buffer.length pp_buffer = 0) in + match context.stack with + | Node ("", [xml], 0, Leaf) -> xml + | _ -> assert false + + +let annotations_positions xml = + let rec node accu = function + | Element (_, { annotation = Some annotation; startpos; endpos }, cs) -> + children ((annotation, (startpos, endpos)) :: accu) cs + | Element (_, _, cs) -> + children accu cs + | _ -> + accu + and children accu cs = + List.fold_left node accu cs + in + node [] xml + +let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml = + let rec node = function + | Element (index, { annotation; startpos; endpos }, cs) -> + let attributes = + [ "startpos", string_of_int startpos; + "endpos", string_of_int endpos + ] + @ (match annotation with + | None -> [] + | Some annotation -> attributes_of_annotation annotation + ) + in + let tag = + match annotation with + | None -> index + | Some annotation -> tag_of_annotation annotation + in + Element (tag, attributes, List.map node cs) + | PCData s -> + PCData s + 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 = Some (Ppstyle.repr t) 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 + diff --git a/ide/richpp.mli b/ide/richpp.mli new file mode 100644 index 0000000000..2e839e996b --- /dev/null +++ b/ide/richpp.mli @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'annotation option) -> Pp.std_ppcmds -> + 'annotation located Xml_datatype.gxml + +(** [annotations_positions ssdoc] returns a list associating each + annotations with its position in the string from which [ssdoc] is + built. *) +val annotations_positions : + 'annotation located Xml_datatype.gxml -> + ('annotation * (int * int)) list + +(** [xml_of_rich_pp ssdoc] returns an XML representation of the + semi-structured document [ssdoc]. *) +val xml_of_rich_pp : + ('annotation -> string) -> + ('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 Debug/Compat} *) + +(** Represent the semi-structured document as a string, dropping any additional + information. *) +val raw_print : richpp -> string diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index d33c0add4a..b83bd107ee 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -103,7 +103,7 @@ object(self) let process = Coq.bind (Coq.query (phrase,Stateid.dummy)) (function | Interface.Fail (_,l,str) -> - Ideutils.insert_xml result#buffer str; + Ideutils.insert_xml result#buffer (Richpp.richpp_of_pp str); notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce; Coq.return () | Interface.Good res -> diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 0330b8eff1..1cf389c75d 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -28,9 +28,9 @@ class type message_view = inherit GObj.widget method connect : message_view_signals method clear : unit - method add : Richpp.richpp -> unit + method add : Pp.std_ppcmds -> unit method add_string : string -> unit - method set : Richpp.richpp -> unit + method set : Pp.std_ppcmds -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) method buffer : GText.buffer @@ -79,21 +79,14 @@ let message_view () : message_view = | Feedback.Warning -> [Tags.Message.warning] | _ -> [] in - 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 - let mark = `MARK mark in - Ideutils.insert_xml ~mark buffer ~tags msg; - buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n"; - push#call (level, msg) - end + let mark = `MARK mark in + Ideutils.insert_xml ~mark buffer ~tags (Richpp.richpp_of_pp msg); + buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n"; + push#call (level, msg) method add msg = self#push Feedback.Notice msg - method add_string s = self#add (Richpp.richpp_of_string s) + method add_string s = self#add (Pp.str s) method set msg = self#clear; self#add msg diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index 2d34533dee..a71d345a5f 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -18,9 +18,9 @@ class type message_view = inherit GObj.widget method connect : message_view_signals method clear : unit - method add : Richpp.richpp -> unit + method add : Pp.std_ppcmds -> unit method add_string : string -> unit - method set : Richpp.richpp -> unit + method set : Pp.std_ppcmds -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) method buffer : GText.buffer diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 47c86045a5..72aa9051a0 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -84,7 +84,7 @@ 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 () = insert_xml ~tags proof#buffer hyp in + let () = insert_xml ~tags proof#buffer (Richpp.richpp_of_pp hyp) in proof#buffer#insert "\n"; insert_hyp rem_hints hs in @@ -98,13 +98,13 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with else [] in proof#buffer#insert (goal_str 1 goals_cnt); - insert_xml proof#buffer cur_goal; + insert_xml proof#buffer (Richpp.richpp_of_pp 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); - insert_xml proof#buffer g; + insert_xml proof#buffer (Richpp.richpp_of_pp g); proof#buffer#insert "\n" in let () = Util.List.fold_left_i fold_goal 2 () rem_goals in @@ -144,7 +144,7 @@ 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 = - insert_xml view#buffer goal.Interface.goal_ccl; + insert_xml view#buffer (Richpp.richpp_of_pp goal.Interface.goal_ccl); view#buffer#insert "\n" in List.iter iter given_up_goals; @@ -153,7 +153,7 @@ 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 = - insert_xml view#buffer goal.Interface.goal_ccl; + insert_xml view#buffer (Richpp.richpp_of_pp goal.Interface.goal_ccl); view#buffer#insert "\n" in List.iter iter shelved_goals @@ -166,7 +166,7 @@ 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 - insert_xml view#buffer goal.Interface.goal_ccl; + insert_xml view#buffer (Richpp.richpp_of_pp goal.Interface.goal_ccl); view#buffer#insert "\n" in List.iteri iter bg diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 65f44fdd38..08f23d3d4e 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -97,6 +97,49 @@ let to_richpp xml = match xml with | Element ("richpp", [], [x]) -> Richpp.richpp_of_xml x | x -> raise Serialize.(Marshal_error("richpp",x)) +let of_box (ppb : Pp.block_type) = let open Pp in match ppb with + | Pp_hbox i -> constructor "ppbox" "hbox" [of_int i] + | Pp_vbox i -> constructor "ppbox" "vbox" [of_int i] + | Pp_hvbox i -> constructor "ppbox" "hvbox" [of_int i] + | Pp_hovbox i -> constructor "ppbox" "hovbox" [of_int i] + +let to_box = let open Pp in + do_match "ppbox" (fun s args -> match s with + | "hbox" -> Pp_hbox (to_int (singleton args)) + | "vbox" -> Pp_vbox (to_int (singleton args)) + | "hvbox" -> Pp_hvbox (to_int (singleton args)) + | "hovbox" -> Pp_hovbox (to_int (singleton args)) + | x -> raise (Marshal_error("*ppbox",PCData x)) + ) + +let rec of_pp (pp : Pp.std_ppcmds) = let open Pp in match pp with + | Ppcmd_empty -> constructor "ppdoc" "emtpy" [] + | Ppcmd_string s -> constructor "ppdoc" "string" [of_string s] + | Ppcmd_glue sl -> constructor "ppdoc" "glue" [of_list of_pp sl] + | Ppcmd_box (bt,s) -> constructor "ppdoc" "box" [of_pair of_box of_pp (bt,s)] + | Ppcmd_tag (t,s) -> constructor "ppdoc" "tag" [of_pair (of_list of_string) of_pp (t,s)] + | Ppcmd_print_break (i,j) + -> constructor "ppdoc" "break" [of_pair of_int of_int (i,j)] + | Ppcmd_force_newline -> constructor "ppdoc" "newline" [] + | Ppcmd_comment cmd -> constructor "ppdoc" "comment" [of_list of_string cmd] + + +let rec to_pp xpp = let open Pp in + do_match "ppdoc" (fun s args -> match s with + | "empty" -> Ppcmd_empty + | "string" -> Ppcmd_string (to_string (singleton args)) + | "glue" -> Ppcmd_glue (to_list to_pp (singleton args)) + | "box" -> let (bt,s) = to_pair to_box to_pp (singleton args) in + Ppcmd_box(bt,s) + | "tag" -> let (tg,s) = to_pair (to_list to_string) to_pp (singleton args) in + Ppcmd_tag(tg,s) + | "break" -> let (i,j) = to_pair to_int to_int (singleton args) in + Ppcmd_print_break(i, j) + | "newline" -> Ppcmd_force_newline + | "comment" -> Ppcmd_comment (to_list to_string (singleton args)) + | x -> raise (Marshal_error("*ppdoc",PCData x)) + ) xpp + let of_value f = function | Good x -> Element ("value", ["val", "good"], [f x]) | Fail (id,loc, msg) -> @@ -104,7 +147,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 = of_stateid id in - Element ("value", ["val", "fail"] @ loc, [id; of_richpp msg]) + Element ("value", ["val", "fail"] @ loc, [id; of_pp msg]) let to_value f = function | Element ("value", attrs, l) -> @@ -120,7 +163,7 @@ let to_value f = function in let (id, msg) = match l with [id; msg] -> (id, msg) | _ -> raise (Marshal_error("val",PCData "no id attribute")) in let id = to_stateid id in - let msg = to_richpp msg in + let msg = to_pp msg in Fail (id, loc, msg) else raise (Marshal_error("good or fail",PCData ans)) | x -> raise (Marshal_error("value",x)) @@ -147,15 +190,15 @@ let to_evar = function | x -> raise (Marshal_error("evar",x)) let of_goal g = - let hyp = of_list of_richpp g.goal_hyp in - let ccl = of_richpp g.goal_ccl in + let hyp = of_list of_pp g.goal_hyp in + let ccl = of_pp 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_richpp hyp in - let ccl = to_richpp ccl in - let id = to_string id in + let hyp = to_list to_pp hyp in + let ccl = to_pp ccl in + let id = to_string id in { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; } | x -> raise (Marshal_error("goal",x)) @@ -344,8 +387,8 @@ end = struct Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals else let pr_goal { goal_hyp = hyps; goal_ccl = goal } = - "[" ^ String.concat "; " (List.map Richpp.raw_print hyps) ^ " |- " ^ - Richpp.raw_print goal ^ "]" in + "[" ^ String.concat "; " (List.map Pp.string_of_ppcmds hyps) ^ " |- " ^ + Pp.string_of_ppcmds goal ^ "]" in String.concat " " (List.map pr_goal g.fg_goals) let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]" let pr_status (s : status) = @@ -701,10 +744,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^" ["^Richpp.raw_print str^"]" + | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^ Pp.string_of_ppcmds str ^ "]" | Fail (id,Some(i,j),str) -> "FAIL "^Stateid.to_string id^ - " ("^string_of_int i^","^string_of_int j^")["^Richpp.raw_print str^"]" + " ("^string_of_int i^","^string_of_int j^")["^Pp.string_of_ppcmds str^"]" let pr_value v = pr_value_gen (fun _ -> "FIXME") v 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 @@ -760,7 +803,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),Richpp.richpp_of_string "error message")))); + (Fail (Stateid.initial,Some (15,34), Pp.str "error message")))); document_type_encoding to_string_fmt (* Moved from feedback.mli : This is IDE specific and we don't want to @@ -787,12 +830,12 @@ let to_message_level = let of_message lvl loc msg = let lvl = of_message_level lvl in let xloc = of_option of_loc loc in - let content = of_richpp msg in + let content = of_pp msg in Xml_datatype.Element ("message", [], [lvl; xloc; content]) let to_message xml = match xml with | Xml_datatype.Element ("message", [], [lvl; xloc; content]) -> - Message(to_message_level lvl, to_option to_loc xloc, to_richpp content) + Message(to_message_level lvl, to_option to_loc xloc, to_pp content) | x -> raise (Marshal_error("message",x)) let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli index ca911178f5..f6fae24d7c 100644 --- a/ide/xmlprotocol.mli +++ b/ide/xmlprotocol.mli @@ -66,5 +66,6 @@ val of_feedback : Feedback.feedback -> xml val to_feedback : xml -> Feedback.feedback val is_feedback : xml -> bool -val of_message : Feedback.level -> Loc.t option -> Richpp.richpp -> xml +val of_message : Feedback.level -> Loc.t option -> Pp.std_ppcmds -> xml +(* val to_message : xml -> Feedback.message *) diff --git a/lib/cErrors.ml b/lib/cErrors.ml index a059640394..99b763602d 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -16,16 +16,6 @@ let push = Backtrace.add_backtrace exception Anomaly of string option * std_ppcmds (* System errors *) -(* XXX: To move to common tagging functions in Pp, blocked on tag - * system cleanup as we cannot define generic error tags now. - * - * Anyways, tagging should not happen here, but in the specific - * listener to the msg_* stuff. - *) -let tag_err_str s = tag Ppstyle.error_tag (str s) ++ spc () -let err_str = tag_err_str "Error:" -let ann_str = tag_err_str "Anomaly:" - let _ = let pr = function | Anomaly (s, pp) -> Some ("\"Anomaly: " ^ string_of_ppcmds pp ^ "\"") @@ -102,7 +92,7 @@ let print_backtrace e = match Backtrace.get_backtrace e with let print_anomaly askreport e = if askreport then - hov 0 (ann_str ++ raw_anomaly e ++ spc () ++ + hov 0 (raw_anomaly e ++ spc () ++ strbrk "Please report at " ++ str Coq_config.wwwbugtracker ++ str ".") else @@ -124,7 +114,7 @@ let iprint_no_report (e, info) = let _ = register_handler begin function | UserError(s, pps) -> - hov 0 (err_str ++ where s ++ pps) + hov 0 (where s ++ pps) | _ -> raise Unhandled end diff --git a/lib/clib.mllib b/lib/clib.mllib index 1e33173ee1..5a5f6afd39 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -15,7 +15,6 @@ Store Exninfo Backtrace IStream -Pp_control Flags Control Loc @@ -28,9 +27,8 @@ CStack Util Stateid Pp -Ppstyle -Richpp Feedback +Ppstyle CUnix Envars Aux_file diff --git a/lib/feedback.ml b/lib/feedback.ml index 852eec2f26..31677ecfc9 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -35,7 +35,7 @@ type feedback_content = (* Extra metadata *) | Custom of Loc.t * string * xml (* Generic messages *) - | Message of level * Loc.t option * Richpp.richpp + | Message of level * Loc.t option * Pp.std_ppcmds type feedback = { id : edit_or_state_id; @@ -45,140 +45,6 @@ type feedback = { let default_route = 0 -(** Feedback and logging *) -open Pp -open Pp_control - -type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit - -let msgnl_with ?pp_tag fmt strm = - pp_with ?pp_tag fmt (strm ++ fnl ()); - Format.pp_print_flush fmt () - -(* XXX: This is really painful! *) -module Emacs = struct - - (* Special chars for emacs, to detect warnings inside goal output *) - let emacs_quote_start = String.make 1 (Char.chr 254) - let emacs_quote_end = String.make 1 (Char.chr 255) - - let emacs_quote_err g = - hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end) - - let emacs_quote_info_start = "" - let emacs_quote_info_end = "" - - let emacs_quote_info g = - hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end) - -end - -open Emacs - -let dbg_str = tag Ppstyle.debug_tag (str "Debug:") ++ spc () -let info_str = mt () -let warn_str = tag Ppstyle.warning_tag (str "Warning:") ++ spc () -let err_str = tag Ppstyle.error_tag (str "Error:" ) ++ spc () - -let make_body quoter info ?loc s = - let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in - quoter (hov 0 (loc ++ info ++ s)) - -(* Generic logger *) -let gen_logger dbg err ?pp_tag ?loc level msg = match level with - | Debug -> msgnl_with ?pp_tag !std_ft (make_body dbg dbg_str ?loc msg) - | Info -> msgnl_with ?pp_tag !std_ft (make_body dbg info_str ?loc msg) - | Notice -> msgnl_with ?pp_tag !std_ft msg - | Warning -> Flags.if_warn (fun () -> - msgnl_with ?pp_tag !err_ft (make_body err warn_str ?loc msg)) () - | Error -> msgnl_with ?pp_tag !err_ft (make_body err err_str ?loc msg) - -(* We provide a generic clear_log_backend callback for backends - wanting to do clenaup after the print. -*) -let std_logger_tag = ref None -let std_logger_cleanup = ref (fun () -> ()) - -let std_logger ?loc level msg = - gen_logger (fun x -> x) (fun x -> x) ?pp_tag:!std_logger_tag ?loc level msg; - !std_logger_cleanup () - -(* Rules for emacs: - - Debug/info: emacs_quote_info - - Warning/Error: emacs_quote_err - - Notice: unquoted - - Note the inconsistency. - *) -let emacs_logger = gen_logger emacs_quote_info emacs_quote_err ?pp_tag:None - -(** Color logging. Moved from pp_style, it may need some more refactoring *) - -(** Not thread-safe. We should put a lock somewhere if we print from - different threads. Do we? *) -let make_style_stack () = - (** Default tag is to reset everything *) - let empty = Terminal.make () in - let default_tag = Terminal.({ - fg_color = Some `DEFAULT; - bg_color = Some `DEFAULT; - bold = Some false; - italic = Some false; - underline = Some false; - negative = Some false; - }) - in - let style_stack = ref [] in - let peek () = match !style_stack with - | [] -> default_tag (** Anomalous case, but for robustness *) - | st :: _ -> st - in - let push tag = - let style = match Ppstyle.get_style_format tag with - | None -> empty - | Some st -> st - in - (** Use the merging of the latest tag and the one being currently pushed. - This may be useful if for instance the latest tag changes the background and - the current one the foreground, so that the two effects are additioned. *) - let style = Terminal.merge (peek ()) style in - style_stack := style :: !style_stack; - Terminal.eval style - in - let pop _ = match !style_stack with - | [] -> (** Something went wrong, we fallback *) - Terminal.eval default_tag - | _ :: rem -> style_stack := rem; - Terminal.eval (peek ()) - in - let clear () = style_stack := [] in - push, pop, clear - -let init_color_output () = - let open Pp_control in - let push_tag, pop_tag, clear_tag = make_style_stack () in - std_logger_cleanup := clear_tag; - std_logger_tag := Some Ppstyle.to_format; - let tag_handler = { - Format.mark_open_tag = push_tag; - Format.mark_close_tag = pop_tag; - Format.print_open_tag = ignore; - Format.print_close_tag = ignore; - } in - Format.pp_set_mark_tags !std_ft true; - Format.pp_set_mark_tags !err_ft true; - Format.pp_set_formatter_tag_functions !std_ft tag_handler; - Format.pp_set_formatter_tag_functions !err_ft tag_handler - -let logger = ref std_logger -let set_logger l = logger := l - -let msg_info ?loc x = !logger ?loc Info x -let msg_notice ?loc x = !logger ?loc Notice x -let msg_warning ?loc x = !logger ?loc Warning x -let msg_error ?loc x = !logger ?loc Error x -let msg_debug ?loc x = !logger ?loc Debug x - (** Feeders *) let feeders : (int, feedback -> unit) Hashtbl.t = Hashtbl.create 7 @@ -190,11 +56,6 @@ let add_feeder = let del_feeder fid = Hashtbl.remove feeders fid -let debug_feeder = function - | { contents = Message (Debug, loc, pp) } -> - msg_debug ?loc (Pp.str (Richpp.raw_print pp)) - | _ -> () - let feedback_id = ref (Edit 0) let feedback_route = ref default_route @@ -209,32 +70,16 @@ let feedback ?id ?route what = } in Hashtbl.iter (fun _ f -> f m) feeders +(* Logging messages *) let feedback_logger ?loc lvl msg = - feedback ~route:!feedback_route ~id:!feedback_id - (Message (lvl, loc, Richpp.richpp_of_pp msg)) + feedback ~route:!feedback_route ~id:!feedback_id (Message (lvl, loc, msg)) -(* Output to file *) -let ft_logger old_logger ft ?loc level mesg = - let id x = x in - match level with - | Debug -> msgnl_with ft (make_body id dbg_str mesg) - | Info -> msgnl_with ft (make_body id info_str mesg) - | Notice -> msgnl_with ft mesg - | Warning -> old_logger ?loc level mesg - | Error -> old_logger ?loc level mesg - -let with_output_to_file fname func input = - let old_logger = !logger in - let channel = open_out (String.concat "." [fname; "out"]) in - logger := ft_logger old_logger (Format.formatter_of_out_channel channel); - try - let output = func input in - logger := old_logger; - close_out channel; - output - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - logger := old_logger; - close_out channel; - Exninfo.iraise reraise +let msg_info ?loc x = feedback_logger ?loc Info x +let msg_notice ?loc x = feedback_logger ?loc Notice x +let msg_warning ?loc x = feedback_logger ?loc Warning x +let msg_error ?loc x = feedback_logger ?loc Error x +let msg_debug ?loc x = feedback_logger ?loc Debug x +let debug_feeder = function + | { contents = Message (Debug, loc, pp) } -> msg_debug ?loc pp + | _ -> () diff --git a/lib/feedback.mli b/lib/feedback.mli index 8eae315883..3fb7c0039e 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -8,7 +8,7 @@ open Xml_datatype -(* Old plain messages (used to be in Pp) *) +(* Legacy-style logging messages (used to be in Pp) *) type level = | Debug | Info @@ -16,7 +16,6 @@ type level = | Warning | Error - (** Coq "semantic" infos obtained during parsing/execution *) type edit_id = int type state_id = Stateid.t @@ -44,7 +43,7 @@ type feedback_content = (* Extra metadata *) | Custom of Loc.t * string * xml (* Generic messages *) - | Message of level * Loc.t option * Richpp.richpp + | Message of level * Loc.t option * Pp.std_ppcmds type feedback = { id : edit_or_state_id; (* The document part concerned *) @@ -53,32 +52,12 @@ type feedback = { } (** {6 Feedback sent, even asynchronously, to the user interface} *) - -(** Moved here from pp.ml *) - (* Morally the parser gets a string and an edit_id, and gives back an AST. * Feedbacks during the parsing phase are attached to this edit_id. * The interpreter assignes an exec_id to the ast, and feedbacks happening * during interpretation are attached to the exec_id. * Only one among state_id and edit_id can be provided. *) -(** A [logger] takes a level plus a pretty printing doc and logs it *) -type logger = ?loc:Loc.t -> level -> Pp.std_ppcmds -> unit - -(** [set_logger l] makes the [msg_*] to use [l] for logging *) -val set_logger : logger -> unit - -(** [std_logger] standard logger to [stdout/stderr] *) -val std_logger : logger - -(** [init_color_output ()] Enable color in the std_logger *) -val init_color_output : unit -> unit - -(** [feedback_logger] will produce feedback messages instead IO events *) -val feedback_logger : logger -val emacs_logger : logger - - (** [add_feeder f] adds a feeder listiner [f], returning its id *) val add_feeder : (feedback -> unit) -> int @@ -97,10 +76,6 @@ val feedback : (** [set_id_for_feedback route id] Set the defaults for feedback *) val set_id_for_feedback : ?route:route_id -> edit_or_state_id -> unit -(** [with_output_to_file file f x] executes [f x] with logging - redirected to a file [file] *) -val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b - (** {6 output functions} [msg_notice] do not put any decoration on output by default. If @@ -128,7 +103,3 @@ val msg_error : ?loc:Loc.t -> Pp.std_ppcmds -> unit val msg_debug : ?loc:Loc.t -> Pp.std_ppcmds -> unit (** For debugging purposes *) - - - - diff --git a/lib/pp.ml b/lib/pp.ml index d763767dc2..5dba0356d8 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp_control - (* The different kinds of blocks are: \begin{description} \item[hbox:] Horizontal block no line breaking; @@ -178,10 +176,9 @@ let pp_with ?pp_tag ft = | Ppcmd_glue sl -> List.iter pp_cmd sl | Ppcmd_string str -> let n = utf8_length str in pp_print_as ft n str - | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) - cpp_open_box bty ; - if not (Format.over_max_boxes ()) then pp_cmd ss; - Format.pp_close_box ft () + | Ppcmd_box(bty,ss) -> cpp_open_box bty ; + if not (over_max_boxes ()) then pp_cmd ss; + pp_close_box ft () | Ppcmd_print_break(m,n) -> pp_print_break ft m n | Ppcmd_force_newline -> pp_force_newline ft () | Ppcmd_comment coms -> List.iter (pr_com ft) coms diff --git a/lib/pp.mli b/lib/pp.mli index 5bf5391d3b..12747d3a1d 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -8,6 +8,30 @@ (** Coq document type. *) +(** Pretty printing guidelines ******************************************) +(* *) +(* std_ppcmds is the main pretty printing datatype in he Coq. Documents *) +(* are composed laying out boxes, and users can add arbitrary metadata *) +(* that backends are free to interpret. *) +(* *) +(* The datatype is public to allow serialization or advanced uses, *) +(* regular users are _strongly_ encouraged to use the top-level *) +(* functions to manipulate the type. *) +(* *) +(* Box order and number is indeed an important factor. Users should try *) +(* to create a proper amount of boxes. Also, the ++ operator provides *) +(* "efficient" concatenation, but directly using a list is preferred. *) +(* *) +(* That is to say, this: *) +(* *) +(* `hov [str "Term"; hov (pr_term t); str "is defined"]` *) +(* *) +(* is preferred to: *) +(* *) +(* `hov (str "Term" ++ hov (pr_term t) ++ str "is defined")` *) +(* *) +(************************************************************************) + (* XXX: Improve and add attributes *) type pp_tag = string list diff --git a/lib/pp_control.ml b/lib/pp_control.ml deleted file mode 100644 index ab8dc0798c..0000000000 --- a/lib/pp_control.ml +++ /dev/null @@ -1,93 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* pp_global_params -> unit - * set the parameters of a formatter *) - -let set_gp ft gp = - Format.pp_set_margin ft gp.margin ; - Format.pp_set_max_indent ft gp.max_indent ; - Format.pp_set_max_boxes ft gp.max_depth ; - Format.pp_set_ellipsis_text ft gp.ellipsis - -let set_dflt_gp ft = set_gp ft dflt_gp - -let get_gp ft = - { margin = Format.pp_get_margin ft (); - max_indent = Format.pp_get_max_indent ft (); - max_depth = Format.pp_get_max_boxes ft (); - ellipsis = Format.pp_get_ellipsis_text ft () } - -(* with_fp : 'a pp_formatter_params -> Format.formatter - * returns of formatter for given formatter functions *) - -let with_fp chan out_function flush_function = - let ft = Format.make_formatter out_function flush_function in - Format.pp_set_formatter_out_channel ft chan; - ft - -(* Output on a channel ch *) - -let with_output_to ch = - let ft = with_fp ch (output_substring ch) (fun () -> flush ch) in - set_gp ft deep_gp; - ft - -let std_ft = ref Format.std_formatter -let _ = set_dflt_gp !std_ft - -let err_ft = ref Format.err_formatter -let _ = set_gp !err_ft deep_gp - -let deep_ft = ref (with_output_to stdout) -let _ = set_gp !deep_ft deep_gp - -(* For parametrization through vernacular *) -let default = Format.pp_get_max_boxes !std_ft () -let default_margin = Format.pp_get_margin !std_ft () - -let get_depth_boxes () = Some (Format.pp_get_max_boxes !std_ft ()) -let set_depth_boxes v = - Format.pp_set_max_boxes !std_ft (match v with None -> default | Some v -> v) - -let get_margin () = Some (Format.pp_get_margin !std_ft ()) -let set_margin v = - let v = match v with None -> default_margin | Some v -> v in - Format.pp_set_margin Format.str_formatter v; - Format.pp_set_margin !std_ft v; - Format.pp_set_margin !deep_ft v; - (* Heuristic, based on usage: the column on the right of max_indent - column is 20% of width, capped to 30 characters *) - let m = max (64 * v / 100) (v-30) in - Format.pp_set_max_indent Format.str_formatter m; - Format.pp_set_max_indent !std_ft m; - Format.pp_set_max_indent !deep_ft m diff --git a/lib/pp_control.mli b/lib/pp_control.mli deleted file mode 100644 index d26f89eb30..0000000000 --- a/lib/pp_control.mli +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* pp_global_params -> unit -val set_dflt_gp : Format.formatter -> unit -val get_gp : Format.formatter -> pp_global_params - - -(** {6 Output functions of pretty-printing. } *) - -val with_output_to : out_channel -> Format.formatter - -val std_ft : Format.formatter ref -val err_ft : Format.formatter ref -val deep_ft : Format.formatter ref - -(** {6 For parametrization through vernacular. } *) - -val set_depth_boxes : int option -> unit -val get_depth_boxes : unit -> int option - -val set_margin : int option -> unit -val get_margin : unit -> int option diff --git a/lib/richpp.ml b/lib/richpp.ml deleted file mode 100644 index c0128dbc2d..0000000000 --- a/lib/richpp.ml +++ /dev/null @@ -1,200 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false - | Node (node, child, pos, ctx) -> - let data = Buffer.contents pp_buffer in - let () = Buffer.clear pp_buffer in - let () = context.stack <- Node (node, PCData data :: child, pos, ctx) in - context.offset <- context.offset + len - in - - let open_xml_tag tag = - let () = push_pcdata () in - context.stack <- Node (tag, [], context.offset, context.stack) - in - - let close_xml_tag tag = - let () = push_pcdata () in - match context.stack with - | Leaf -> assert false - | Node (node, child, pos, ctx) -> - let () = assert (String.equal tag node) in - let annotation = - try Int.Map.find (int_of_string node) context.annotations - with _ -> None - in - let annotation = { - annotation = annotation; - startpos = pos; - endpos = context.offset; - } in - let xml = Element (node, annotation, List.rev child) in - match ctx with - | Leaf -> - (** Final node: we keep the result in a dummy context *) - context.stack <- Node ("", [xml], 0, Leaf) - | Node (node, child, pos, ctx) -> - context.stack <- Node (node, xml :: child, pos, ctx) - in - - let open Format in - - let ft = formatter_of_buffer pp_buffer in - - let tag_functions = { - mark_open_tag = (fun tag -> let () = open_xml_tag tag in ""); - mark_close_tag = (fun tag -> let () = close_xml_tag tag in ""); - print_open_tag = ignore; - print_close_tag = ignore; - } in - - pp_set_formatter_tag_functions ft tag_functions; - pp_set_mark_tags ft true; - - (* Set formatter width. This is currently a hack and duplicate code - with Pp_control. Hopefully it will be fixed better in Coq 8.7 *) - let w = pp_get_margin str_formatter () in - let m = max (64 * w / 100) (w-30) in - pp_set_margin ft w; - pp_set_max_indent ft m; - - (** The whole output must be a valid document. To that - end, we nest the document inside tags. *) - pp_open_tag ft "pp"; - Pp.(pp_with ~pp_tag ft ppcmds); - pp_close_tag ft (); - - (** Get the resulting XML tree. *) - let () = pp_print_flush ft () in - let () = assert (Buffer.length pp_buffer = 0) in - match context.stack with - | Node ("", [xml], 0, Leaf) -> xml - | _ -> assert false - - -let annotations_positions xml = - let rec node accu = function - | Element (_, { annotation = Some annotation; startpos; endpos }, cs) -> - children ((annotation, (startpos, endpos)) :: accu) cs - | Element (_, _, cs) -> - children accu cs - | _ -> - accu - and children accu cs = - List.fold_left node accu cs - in - node [] xml - -let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml = - let rec node = function - | Element (index, { annotation; startpos; endpos }, cs) -> - let attributes = - [ "startpos", string_of_int startpos; - "endpos", string_of_int endpos - ] - @ (match annotation with - | None -> [] - | Some annotation -> attributes_of_annotation annotation - ) - in - let tag = - match annotation with - | None -> index - | Some annotation -> tag_of_annotation annotation - in - Element (tag, attributes, List.map node cs) - | PCData s -> - PCData s - 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 = Some (Ppstyle.repr t) 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 - diff --git a/lib/richpp.mli b/lib/richpp.mli deleted file mode 100644 index 2e839e996b..0000000000 --- a/lib/richpp.mli +++ /dev/null @@ -1,64 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'annotation option) -> Pp.std_ppcmds -> - 'annotation located Xml_datatype.gxml - -(** [annotations_positions ssdoc] returns a list associating each - annotations with its position in the string from which [ssdoc] is - built. *) -val annotations_positions : - 'annotation located Xml_datatype.gxml -> - ('annotation * (int * int)) list - -(** [xml_of_rich_pp ssdoc] returns an XML representation of the - semi-structured document [ssdoc]. *) -val xml_of_rich_pp : - ('annotation -> string) -> - ('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 Debug/Compat} *) - -(** Represent the semi-structured document as a string, dropping any additional - information. *) -val raw_print : richpp -> string diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index e019bb3c2a..ee623c5ca0 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -472,13 +472,14 @@ let formatter dry file = if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) else match file with - | Some f -> Pp_control.with_output_to f + | Some f -> Topfmt.with_output_to f | None -> Format.formatter_of_buffer buf in + (* XXX: Fixme, this shouldn't depend on Topfmt *) (* We never want to see ellipsis ... in extracted code *) Format.pp_set_max_boxes ft max_int; (* We reuse the width information given via "Set Printing Width" *) - (match Pp_control.get_margin () with + (match Topfmt.get_margin () with | None -> () | Some i -> Format.pp_set_margin ft i; diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 8acc3c233a..28548ecee9 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -298,18 +298,11 @@ module Make(T : Task) = struct let slave_handshake () = Pool.worker_handshake (Option.get !slave_ic) (Option.get !slave_oc) - let pp_pid pp = - (* Breaking all abstraction barriers... very nice *) - let get_xml pp = match Richpp.repr pp with - | Xml_datatype.Element("_", [], xml) -> xml - | _ -> assert false in - Richpp.richpp_of_xml (Xml_datatype.Element("_", [], - get_xml (Richpp.richpp_of_pp Pp.(str (System.process_id ()^ " "))) @ - get_xml pp)) + let pp_pid pp = Pp.(str (System.process_id () ^ " ") ++ pp) let debug_with_pid = Feedback.(function | { contents = Message(Debug, loc, pp) } as fb -> - { fb with contents = Message(Debug,loc,pp_pid pp) } + { fb with contents = Message(Debug,loc, pp_pid pp) } | x -> x) let main_loop () = @@ -317,7 +310,6 @@ module Make(T : Task) = struct let slave_feeder oc fb = Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc in Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x); - Feedback.set_logger Feedback.feedback_logger; (* We ask master to allocate universe identifiers *) Universes.set_remote_new_univ_level (bufferize (fun () -> marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel; diff --git a/stm/stm.ml b/stm/stm.ml index e56db4090a..75872d633f 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -11,10 +11,6 @@ let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr let prerr_endline s = if false then begin pr_err (s ()) end else () let prerr_debug s = if !Flags.debug then begin pr_err (s ()) end else () -(* Opening ppvernac below aliases Richpp, see PR#185 *) -let pp_to_richpp = Richpp.richpp_of_pp -let str_to_richpp = Richpp.richpp_of_string - open Vernacexpr open CErrors open Pp @@ -26,7 +22,7 @@ open Feedback let execution_error state_id loc msg = feedback ~id:(State state_id) - (Message (Error, Some loc, pp_to_richpp msg)) + (Message (Error, Some loc, msg)) module Hooks = struct @@ -48,7 +44,7 @@ let forward_feedback, forward_feedback_hook = let parse_error, parse_error_hook = Hook.make ~default:(fun id loc msg -> - feedback ~id (Message(Error, Some loc, pp_to_richpp msg))) () + feedback ~id (Message(Error, Some loc, msg))) () let unreachable_state, unreachable_state_hook = Hook.make ~default:(fun _ _ -> ()) () @@ -1945,7 +1941,7 @@ end = struct (* {{{ *) feedback ~id:(State r_for) Processed with e when CErrors.noncritical e -> let e = CErrors.push e in - let msg = pp_to_richpp (iprint e) in + let msg = iprint e in feedback ~id:(State r_for) (Message (Error, None, msg)) let name_of_task { t_what } = string_of_ppcmds (pr_ast t_what) diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index a2ee2d4c8e..979396969a 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -97,8 +97,8 @@ Expands to: Constant Top.f forall w : r, w 3 true = tt : Prop The command has indeed failed with message: -Error: Unknown interpretation for notation "$". +Unknown interpretation for notation "$". w 3 true = tt : Prop The command has indeed failed with message: -Error: Extra arguments: _, _. +Extra arguments: _, _. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index b084ad4984..4df21ae353 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -1,5 +1,5 @@ The command has indeed failed with message: -Error: To rename arguments the "rename" flag must be specified. +To rename arguments the "rename" flag must be specified. Argument A renamed to B. File "stdin", line 2, characters 0-25: Warning: This command is just asserting the names of arguments of identity. @@ -103,15 +103,15 @@ Expands to: Constant Top.myplus @myplus : forall Z : Type, Z -> nat -> nat -> nat The command has indeed failed with message: -Error: Argument lists should agree on the names they provide. +Argument lists should agree on the names they provide. The command has indeed failed with message: -Error: Sequences of implicit arguments must be of different lengths. +Sequences of implicit arguments must be of different lengths. The command has indeed failed with message: -Error: Some argument names are duplicated: F +Some argument names are duplicated: F The command has indeed failed with message: -Error: Argument z cannot be declared implicit. +Argument z cannot be declared implicit. The command has indeed failed with message: -Error: Extra arguments: y. +Extra arguments: y. The command has indeed failed with message: -Error: To rename arguments the "rename" flag must be specified. +To rename arguments the "rename" flag must be specified. Argument A renamed to R. diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out index 06a6b2d157..38d055b28e 100644 --- a/test-suite/output/Errors.out +++ b/test-suite/output/Errors.out @@ -7,4 +7,4 @@ In nested Ltac calls to "f" and "apply x", last call failed. Unable to unify "nat" with "True". The command has indeed failed with message: Ltac call to "instantiate ( (ident) := (lglob) )" failed. -Error: Instance is not well-typed in the environment of ?x. +Instance is not well-typed in the environment of ?x. diff --git a/test-suite/output/FunExt.out b/test-suite/output/FunExt.out index c6786c72ff..8d2a125c1d 100644 --- a/test-suite/output/FunExt.out +++ b/test-suite/output/FunExt.out @@ -16,4 +16,4 @@ Tactic failure: Already an intensional equality. The command has indeed failed with message: In nested Ltac calls to "extensionality in (var)" and "clearbody (ne_var_list)", last call failed. -Error: Hypothesis e depends on the body of H' +Hypothesis e depends on the body of H' diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 26eaca8272..9d106d2dac 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -41,29 +41,29 @@ fun x : nat => ifn x is succ n then n else 0 -4 : Z The command has indeed failed with message: -Error: x should not be bound in a recursive pattern of the right-hand side. +x should not be bound in a recursive pattern of the right-hand side. The command has indeed failed with message: -Error: in the right-hand side, y and z should appear in +in the right-hand side, y and z should appear in term position as part of a recursive pattern. The command has indeed failed with message: The reference w was not found in the current environment. The command has indeed failed with message: -Error: in the right-hand side, y and z should appear in +in the right-hand side, y and z should appear in term position as part of a recursive pattern. The command has indeed failed with message: -Error: z is expected to occur in binding position in the right-hand side. +z is expected to occur in binding position in the right-hand side. The command has indeed failed with message: -Error: as y is a non-closed binder, no such "," is allowed to occur. +as y is a non-closed binder, no such "," is allowed to occur. The command has indeed failed with message: -Error: Cannot find where the recursive pattern starts. +Cannot find where the recursive pattern starts. The command has indeed failed with message: -Error: Cannot find where the recursive pattern starts. +Cannot find where the recursive pattern starts. The command has indeed failed with message: -Error: Cannot find where the recursive pattern starts. +Cannot find where the recursive pattern starts. The command has indeed failed with message: -Error: Cannot find where the recursive pattern starts. +Cannot find where the recursive pattern starts. The command has indeed failed with message: -Error: Both ends of the recursive pattern are the same. +Both ends of the recursive pattern are the same. SUM (nat * nat) nat : Set FST (0; 1) diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index 1ff09e3af6..35c3057d84 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -1,5 +1,4 @@ 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 @@ -22,11 +21,11 @@ The term "I" has type "True" while it is expected to have type "False". The command has indeed failed with message: In nested Ltac calls to "h" and "injection (destruction_arg)", last call failed. -Error: No primitive equality found. +No primitive equality found. The command has indeed failed with message: In nested Ltac calls to "h" and "injection (destruction_arg)", last call failed. -Error: No primitive equality found. +No primitive equality found. Hx nat nat diff --git a/test-suite/output/ltac_missing_args.out b/test-suite/output/ltac_missing_args.out index ae3fd7acc7..172612405f 100644 --- a/test-suite/output/ltac_missing_args.out +++ b/test-suite/output/ltac_missing_args.out @@ -1,21 +1,20 @@ The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable x. +A fully applied tactic is expected: missing argument for variable x. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable x. +A fully applied tactic is expected: missing argument for variable x. The command has indeed failed with message: -Error: A fully applied tactic is expected: -missing arguments for variables y and _. +A fully applied tactic is expected: missing arguments for variables y and _. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable x. +A fully applied tactic is expected: missing argument for variable x. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable x. +A fully applied tactic is expected: missing argument for variable x. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable _. +A fully applied tactic is expected: missing argument for variable _. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable _. +A fully applied tactic is expected: missing argument for variable _. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable _. +A fully applied tactic is expected: missing argument for variable _. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable x. +A fully applied tactic is expected: missing argument for variable x. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable x. +A fully applied tactic is expected: missing argument for variable x. diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index 23c111b371..e89f19041f 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -29,7 +29,7 @@ let error_xml s = exit 1 let logger level content = - Printf.eprintf "%a\n%! " print_xml (Richpp.repr content) + Printf.eprintf "%a\n%! " print_xml Richpp.(content |> richpp_of_pp |> repr) let base_eval_call ?(print=true) ?(fail=true) call coqtop = if print then prerr_endline (Xmlprotocol.pr_call call); @@ -44,8 +44,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_xml (Richpp.repr s) - | Interface.Fail (_,_,s) as x -> Printf.eprintf "%a\n%!" print_xml (Richpp.repr s); x + | Interface.Fail (_,_,s) when fail -> error_xml Richpp.(s |> richpp_of_pp |> repr) + | Interface.Fail (_,_,s) as x -> Printf.eprintf "%a\n%!" print_xml Richpp.(s |> richpp_of_pp |> repr); x | x -> x let eval_call c q = ignore(base_eval_call c q) @@ -194,7 +194,7 @@ let print_document () = module GUILogic = struct let after_add = function - | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) + | Interface.Fail (_,_,s) -> error_xml Richpp.(repr (richpp_of_pp s)) | Interface.Good (id, (Util.Inl (), _)) -> Document.assign_tip_id doc id | Interface.Good (id, (Util.Inr tip, _)) -> @@ -206,7 +206,7 @@ module GUILogic = struct let at id id' _ = Stateid.equal id' id let after_edit_at (id,need_unfocus) = function - | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) + | Interface.Fail (_,_,s) -> error_xml Richpp.(repr (richpp_of_pp s)) | Interface.Good (Util.Inl ()) -> if need_unfocus then Document.unfocus doc; ignore(Document.cut_at doc id); @@ -329,7 +329,7 @@ let main = let finish () = match base_eval_call (Xmlprotocol.status true) coq with | Interface.Good _ -> exit 0 - | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) in + | Interface.Fail (_,_,s) -> error_xml Richpp.(repr (richpp_of_pp s)) in (* The main loop *) init (); while true do diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 2cb6083261..e9506803df 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -14,8 +14,7 @@ open Vernac open Pcoq let top_stderr x = - pp_with ~pp_tag:Ppstyle.to_format !Pp_control.err_ft x; - Format.pp_print_flush !Pp_control.err_ft () + Format.fprintf !Topfmt.err_ft "@[%a@]%!" (pp_with ~pp_tag:Ppstyle.to_format) x (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) @@ -253,7 +252,8 @@ let print_toplevel_error (e, info) = else mt () else print_location_in_file loc in - locmsg ++ CErrors.iprint (e, info) + let hdr msg = hov 0 (tag Ppstyle.error_tag (str "Error:") ++ spc () ++ msg) in + locmsg ++ hdr (CErrors.iprint (e, info)) (* Read the input stream until a dot is encountered *) let parse_to_dot = @@ -285,6 +285,33 @@ let read_sentence input = discard_to_dot (); iraise reraise +(** Coqloop Console feedback handler *) +let coqloop_feed (fb : Feedback.feedback) = let open Feedback in + match fb.contents with + | Processed -> () + | Incomplete -> () + | Complete -> () + | ProcessingIn _ -> () + | InProgress _ -> () + | WorkerStatus (_,_) -> () + | AddedAxiom -> () + | GlobRef (_,_,_,_,_) -> () + | GlobDef (_,_,_,_) -> () + | FileDependency (_,_) -> () + | FileLoaded (_,_) -> () + | Custom (_,_,_) -> () + | Message (Error,loc,msg) -> + (* We ignore errors here as we (still) have a different error + printer for the toplevel. It is hard to solve due the many + error paths presents, and the different compromise of feedback + error forwaring in the stm depending on the mode *) + () + | Message (lvl,loc,msg) -> + if !Flags.print_emacs then + Topfmt.emacs_logger ?loc lvl msg + else + Topfmt.std_logger ?loc lvl msg + (** [do_vernac] reads and executes a toplevel phrase, and print error messages when an exception is raised, except for the following: - Drop: kill the Coq toplevel, going down to the Caml toplevel if it exists. @@ -307,12 +334,13 @@ let do_vernac () = top_stderr (fnl ()); raise CErrors.Quit | CErrors.Drop -> (* Last chance *) if Mltop.is_ocaml_top() then raise CErrors.Drop - else Feedback.msg_error (str"There is no ML toplevel.") + else top_stderr (str "There is no ML toplevel.") | any -> + (** Main error printer, note that this didn't it the "emacs" + legacy path. *) let any = CErrors.push any in let msg = print_toplevel_error any ++ fnl () in - pp_with !Pp_control.std_ft msg; - Format.pp_print_flush !Pp_control.std_ft () + top_stderr msg (** Main coq loop : read vernacular expressions until Drop is entered. Ctrl-C is handled internally as Sys.Break instead of aborting Coq. @@ -320,22 +348,13 @@ let do_vernac () = exit the loop are Drop and Quit. Any other exception there indicates an issue with [print_toplevel_error] above. *) -(* -let feed_emacs = function - | { Interface.id = Interface.State id; - Interface.content = Interface.GlobRef (_,a,_,c,_) } -> - prerr_endline ("" ^""^Stateid.to_string id ^"" - ^a^" "^c^ "") - | _ -> () -*) - (* Flush in a compatible order with 8.5 *) (* This mimics the semantics of the old Pp.flush_all *) let loop_flush_all () = Pervasives.flush stderr; Pervasives.flush stdout; - Format.pp_print_flush !Pp_control.std_ft (); - Format.pp_print_flush !Pp_control.err_ft () + Format.pp_print_flush !Topfmt.std_ft (); + Format.pp_print_flush !Topfmt.err_ft () let rec loop () = Sys.catch_break true; @@ -348,9 +367,9 @@ let rec loop () = | CErrors.Drop -> () | CErrors.Quit -> exit 0 | any -> - Feedback.msg_error (str"Anomaly: main loop exited with exception: " ++ - str (Printexc.to_string any) ++ - fnl() ++ - str"Please report" ++ - strbrk" at " ++ str Coq_config.wwwbugtracker ++ str "."); + top_stderr (str"Anomaly: main loop exited with exception: " ++ + str (Printexc.to_string any) ++ + fnl() ++ + str"Please report" ++ + strbrk" at " ++ str Coq_config.wwwbugtracker ++ str "."); loop () diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index d248f2f706..eb61084e09 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -32,6 +32,8 @@ val set_prompt : (unit -> string) -> unit val print_toplevel_error : Exninfo.iexn -> std_ppcmds +val coqloop_feed : Feedback.feedback -> unit + (** Parse and execute one vernac command. *) val do_vernac : unit -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 541c1fd1bb..823d05580b 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -61,7 +61,7 @@ let init_color () = match colors with | None -> (** Default colors *) - Feedback.init_color_output () + Topfmt.init_color_output () | Some "" -> (** No color output *) () @@ -69,7 +69,7 @@ let init_color () = (** Overwrite all colors *) Ppstyle.clear_styles (); Ppstyle.parse_config s; - Feedback.init_color_output () + Topfmt.init_color_output () end let toploop_init = ref begin fun x -> @@ -78,15 +78,27 @@ let toploop_init = ref begin fun x -> x end -let toploop_run = ref (fun () -> +(* Feedback received in the init stage, this is different as the STM + will not be generally be initialized, thus stateid, etc... may be + bogus. For now we just print to the console too *) +let coqtop_init_feed = Coqloop.coqloop_feed + +(* Default toplevel loop *) +let console_toploop_run () = + (* We initialize the console only if we run the toploop_run *) + let tl_feed = Feedback.add_feeder Coqloop.coqloop_feed in if Dumpglob.dump () then begin if_verbose warning "Dumpglob cannot be used in interactive mode."; Dumpglob.noglob () end; Coqloop.loop(); + (* We remove the feeder but it could be ok not to do so *) + Feedback.del_feeder tl_feed; (* Initialise and launch the Ocaml toplevel *) Coqinit.init_ocaml_path(); - Mltop.ocaml_toploop()) + Mltop.ocaml_toploop() + +let toploop_run = ref console_toploop_run let output_context = ref false @@ -228,7 +240,6 @@ let compile_files () = if !compile_list == [] then () else let init_state = States.freeze ~marshallable:`No in - Feedback.(add_feeder debug_feeder); List.iter (fun vf -> States.unfreeze init_state; compile_file vf) @@ -240,7 +251,6 @@ let set_emacs () = if not (Option.is_empty !toploop) then error "Flag -emacs is incompatible with a custom toplevel loop"; Flags.print_emacs := true; - Feedback.(set_logger emacs_logger); Vernacentries.qed_display_script := false; color := `OFF @@ -435,7 +445,7 @@ let get_native_name s = with the appropriate error code *) let fatal_error info anomaly = let msg = info ++ fnl () in - Format.fprintf !Topfmt.err_ft "@[%a@]%!" pp_with msg; + Format.fprintf !Topfmt.err_ft "@[%a@]%!" (pp_with ?pp_tag:None) msg; exit (if anomaly then 129 else 1) let parse_args arglist = @@ -609,6 +619,7 @@ let parse_args arglist = let init_toplevel arglist = init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) + let init_feeder = Feedback.add_feeder coqtop_init_feed in Lib.init(); begin try @@ -663,7 +674,8 @@ let init_toplevel arglist = Feedback.msg_notice (with_option raw_print Prettyp.print_full_pure_context () ++ fnl ()); Profile.print_profile (); exit 0 - end + end; + Feedback.del_feeder init_feeder let start () = let () = init_toplevel (List.tl (Array.to_list Sys.argv)) in diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 5d17054fce..4fc4540c1c 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -143,8 +143,8 @@ let pr_new_syntax_in_context loc chan_beautify ocom = | None -> mt() in let after = comment (CLexer.extract_comments (snd loc)) in if !beautify_file then - (Pp.pp_with !Pp_control.std_ft (hov 0 (before ++ com ++ after)); - Format.pp_print_flush !Pp_control.std_ft ()) + (Pp.pp_with !Topfmt.std_ft (hov 0 (before ++ com ++ after)); + Format.pp_print_flush !Topfmt.std_ft ()) else Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); States.unfreeze fs; @@ -179,9 +179,10 @@ let pp_cmd_header loc com = (* This is a special case where we assume we are in console batch mode and take control of the console. *) +(* FIXME *) let print_cmd_header loc com = - Pp.pp_with ~pp_tag:Ppstyle.to_format !Pp_control.std_ft (pp_cmd_header loc com); - Format.pp_print_flush !Pp_control.std_ft () + Pp.pp_with ~pp_tag:Ppstyle.to_format !Topfmt.std_ft (pp_cmd_header loc com); + Format.pp_print_flush !Topfmt.std_ft () let rec interp_vernac po chan_beautify checknav (loc,com) = let interp = function diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 5b91af03ca..f1e0c48f03 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -45,15 +45,9 @@ let _ = CErrors.register_handler explain_exn_default (** Pre-explain a vernac interpretation error *) -let wrap_vernac_error with_header (exn, info) strm = - if with_header then - let header = Pp.tag Ppstyle.error_tag (str "Error:") in - let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in - (e, info) - else - (EvaluatedError (strm, None), info) +let wrap_vernac_error (exn, info) strm = (EvaluatedError (strm, None), info) -let process_vernac_interp_error with_header exn = match fst exn with +let process_vernac_interp_error exn = match fst exn with | Univ.UniverseInconsistency i -> let msg = if !Constrextern.print_universes then @@ -61,40 +55,40 @@ let process_vernac_interp_error with_header exn = match fst exn with Univ.explain_universe_inconsistency Universes.pr_with_global_universes i else mt() in - wrap_vernac_error with_header exn (str "Universe inconsistency" ++ msg ++ str ".") + wrap_vernac_error exn (str "Universe inconsistency" ++ msg ++ str ".") | TypeError(ctx,te) -> - wrap_vernac_error with_header exn (Himsg.explain_type_error ctx Evd.empty te) + wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te) | PretypeError(ctx,sigma,te) -> - wrap_vernac_error with_header exn (Himsg.explain_pretype_error ctx sigma te) + wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> - wrap_vernac_error with_header exn (Himsg.explain_typeclass_error env te) + wrap_vernac_error exn (Himsg.explain_typeclass_error env te) | InductiveError e -> - wrap_vernac_error with_header exn (Himsg.explain_inductive_error e) + wrap_vernac_error exn (Himsg.explain_inductive_error e) | Modops.ModuleTypingError e -> - wrap_vernac_error with_header exn (Himsg.explain_module_error e) + wrap_vernac_error exn (Himsg.explain_module_error e) | Modintern.ModuleInternalizationError e -> - wrap_vernac_error with_header exn (Himsg.explain_module_internalization_error e) + wrap_vernac_error exn (Himsg.explain_module_internalization_error e) | RecursionSchemeError e -> - wrap_vernac_error with_header exn (Himsg.explain_recursion_scheme_error e) + wrap_vernac_error exn (Himsg.explain_recursion_scheme_error e) | Cases.PatternMatchingError (env,sigma,e) -> - wrap_vernac_error with_header exn (Himsg.explain_pattern_matching_error env sigma e) + wrap_vernac_error exn (Himsg.explain_pattern_matching_error env sigma e) | Tacred.ReductionTacticError e -> - wrap_vernac_error with_header exn (Himsg.explain_reduction_tactic_error e) + wrap_vernac_error exn (Himsg.explain_reduction_tactic_error e) | Logic.RefinerError e -> - wrap_vernac_error with_header exn (Himsg.explain_refiner_error e) + wrap_vernac_error exn (Himsg.explain_refiner_error e) | Nametab.GlobalizationError q -> - wrap_vernac_error with_header exn + wrap_vernac_error exn (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ spc () ++ str "was not found" ++ spc () ++ str "in the current" ++ spc () ++ str "environment.") | Refiner.FailError (i,s) -> let s = Lazy.force s in - wrap_vernac_error with_header exn + wrap_vernac_error exn (str "Tactic failure" ++ (if Pp.ismt s then s else str ": " ++ s) ++ if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").") | AlreadyDeclared msg -> - wrap_vernac_error with_header exn (msg ++ str ".") + wrap_vernac_error exn (msg ++ str ".") | _ -> exn @@ -108,9 +102,9 @@ 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 process_vernac_interp_error ?(allow_uncaught=true) (exc, info) = let exc = strip_wrapping_exceptions exc in - let e = process_vernac_interp_error with_header (exc, info) in + let e = process_vernac_interp_error (exc, info) in let () = if not allow_uncaught && not (CErrors.handled (fst e)) then let (e, info) = e in diff --git a/vernac/explainErr.mli b/vernac/explainErr.mli index a67c887af3..370ad7e3b5 100644 --- a/vernac/explainErr.mli +++ b/vernac/explainErr.mli @@ -11,7 +11,7 @@ exception EvaluatedError of Pp.std_ppcmds * exn option (** Pre-explain a vernac interpretation error *) -val process_vernac_interp_error : ?allow_uncaught:bool -> ?with_header:bool -> Util.iexn -> Util.iexn +val process_vernac_interp_error : ?allow_uncaught:bool -> Util.iexn -> Util.iexn (** General explain function. Should not be used directly now, see instead function [Errors.print] and variants *) diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml new file mode 100644 index 0000000000..85981c386c --- /dev/null +++ b/vernac/topfmt.ml @@ -0,0 +1,245 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* pp_global_params -> unit + * set the parameters of a formatter *) + +let set_gp ft gp = + Format.pp_set_margin ft gp.margin ; + Format.pp_set_max_indent ft gp.max_indent ; + Format.pp_set_max_boxes ft gp.max_depth ; + Format.pp_set_ellipsis_text ft gp.ellipsis + +let set_dflt_gp ft = set_gp ft dflt_gp + +let get_gp ft = + { margin = Format.pp_get_margin ft (); + max_indent = Format.pp_get_max_indent ft (); + max_depth = Format.pp_get_max_boxes ft (); + ellipsis = Format.pp_get_ellipsis_text ft () } + +(* with_fp : 'a pp_formatter_params -> Format.formatter + * returns of formatter for given formatter functions *) + +let with_fp chan out_function flush_function = + let ft = Format.make_formatter out_function flush_function in + Format.pp_set_formatter_out_channel ft chan; + ft + +(* Output on a channel ch *) + +let with_output_to ch = + let ft = with_fp ch (output_substring ch) (fun () -> flush ch) in + set_gp ft deep_gp; + ft + +let std_ft = ref Format.std_formatter +let _ = set_dflt_gp !std_ft + +let err_ft = ref Format.err_formatter +let _ = set_gp !err_ft deep_gp + +let deep_ft = ref (with_output_to stdout) +let _ = set_gp !deep_ft deep_gp + +(* For parametrization through vernacular *) +let default = Format.pp_get_max_boxes !std_ft () +let default_margin = Format.pp_get_margin !std_ft () + +let get_depth_boxes () = Some (Format.pp_get_max_boxes !std_ft ()) +let set_depth_boxes v = + Format.pp_set_max_boxes !std_ft (match v with None -> default | Some v -> v) + +let get_margin () = Some (Format.pp_get_margin !std_ft ()) +let set_margin v = + let v = match v with None -> default_margin | Some v -> v in + Format.pp_set_margin Format.str_formatter v; + Format.pp_set_margin !std_ft v; + Format.pp_set_margin !deep_ft v; + (* Heuristic, based on usage: the column on the right of max_indent + column is 20% of width, capped to 30 characters *) + let m = max (64 * v / 100) (v-30) in + Format.pp_set_max_indent Format.str_formatter m; + Format.pp_set_max_indent !std_ft m; + Format.pp_set_max_indent !deep_ft m + +(** Console display of feedback *) + +type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit + +let msgnl_with ?pp_tag fmt strm = + pp_with ?pp_tag fmt (strm ++ fnl ()); + Format.pp_print_flush fmt () + +(* XXX: This is really painful! *) +module Emacs = struct + + (* Special chars for emacs, to detect warnings inside goal output *) + let emacs_quote_start = String.make 1 (Char.chr 254) + let emacs_quote_end = String.make 1 (Char.chr 255) + + let emacs_quote_err g = + hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end) + + let emacs_quote_info_start = "" + let emacs_quote_info_end = "" + + let emacs_quote_info g = + hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end) + +end + +open Emacs + +let dbg_str = tag Ppstyle.debug_tag (str "Debug:") ++ spc () +let info_str = mt () +let warn_str = tag Ppstyle.warning_tag (str "Warning:") ++ spc () +let err_str = tag Ppstyle.error_tag (str "Error:") ++ spc () + +let make_body quoter info ?loc s = + let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in + quoter (hov 0 (loc ++ info ++ s)) + +(* Generic logger *) +let gen_logger ?pp_tag dbg err ?loc level msg = match level with + | Debug -> msgnl_with ?pp_tag !std_ft (make_body dbg dbg_str ?loc msg) + | Info -> msgnl_with ?pp_tag !std_ft (make_body dbg info_str ?loc msg) + (* XXX: What to do with loc here? *) + | Notice -> msgnl_with ?pp_tag !std_ft msg + | Warning -> Flags.if_warn (fun () -> + msgnl_with ?pp_tag !err_ft (make_body err warn_str ?loc msg)) () + | Error -> msgnl_with ?pp_tag !err_ft (make_body err err_str ?loc msg) + +(** Standard loggers *) + +(* We provide a generic clear_log_backend callback for backends + wanting to do clenaup after the print. +*) +let std_logger_tag = ref None +let std_logger_cleanup = ref (fun () -> ()) + +let std_logger ?loc level msg = + gen_logger (fun x -> x) (fun x -> x) ?pp_tag:!std_logger_tag ?loc level msg; + !std_logger_cleanup () + +(** Color logging. Moved from pp_style, it may need some more refactoring *) + +(** Not thread-safe. We should put a lock somewhere if we print from + different threads. Do we? *) +let make_style_stack () = + (** Default tag is to reset everything *) + let empty = Terminal.make () in + let default_tag = Terminal.({ + fg_color = Some `DEFAULT; + bg_color = Some `DEFAULT; + bold = Some false; + italic = Some false; + underline = Some false; + negative = Some false; + }) + in + let style_stack = ref [] in + let peek () = match !style_stack with + | [] -> default_tag (** Anomalous case, but for robustness *) + | st :: _ -> st + in + let push tag = + let style = match Ppstyle.get_style_format tag with + | None -> empty + | Some st -> st + in + (** Use the merging of the latest tag and the one being currently pushed. + This may be useful if for instance the latest tag changes the background and + the current one the foreground, so that the two effects are additioned. *) + let style = Terminal.merge (peek ()) style in + style_stack := style :: !style_stack; + Terminal.eval style + in + let pop _ = match !style_stack with + | [] -> (** Something went wrong, we fallback *) + Terminal.eval default_tag + | _ :: rem -> style_stack := rem; + Terminal.eval (peek ()) + in + let clear () = style_stack := [] in + push, pop, clear + +let init_color_output () = + let push_tag, pop_tag, clear_tag = make_style_stack () in + std_logger_cleanup := clear_tag; + std_logger_tag := Some Ppstyle.to_format; + let tag_handler = { + Format.mark_open_tag = push_tag; + Format.mark_close_tag = pop_tag; + Format.print_open_tag = ignore; + Format.print_close_tag = ignore; + } in + Format.pp_set_mark_tags !std_ft true; + Format.pp_set_mark_tags !err_ft true; + Format.pp_set_formatter_tag_functions !std_ft tag_handler; + Format.pp_set_formatter_tag_functions !err_ft tag_handler + +(* Rules for emacs: + - Debug/info: emacs_quote_info + - Warning/Error: emacs_quote_err + - Notice: unquoted + *) +let emacs_logger = gen_logger emacs_quote_info emacs_quote_err + +(* Output to file, used only in extraction so a candidate for removal *) +let ft_logger old_logger ft ?loc level mesg = + let id x = x in + match level with + | Debug -> msgnl_with ft (make_body id dbg_str mesg) + | Info -> msgnl_with ft (make_body id info_str mesg) + | Notice -> msgnl_with ft mesg + | Warning -> old_logger ?loc level mesg + | Error -> old_logger ?loc level mesg + +let with_output_to_file fname func input = + (* XXX FIXME: redirect std_ft *) + (* let old_logger = !logger in *) + let channel = open_out (String.concat "." [fname; "out"]) in + (* logger := ft_logger old_logger (Format.formatter_of_out_channel channel); *) + try + let output = func input in + (* logger := old_logger; *) + close_out channel; + output + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + (* logger := old_logger; *) + close_out channel; + Exninfo.iraise reraise diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli new file mode 100644 index 0000000000..38a400cfd0 --- /dev/null +++ b/vernac/topfmt.mli @@ -0,0 +1,49 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* pp_global_params -> unit +val set_dflt_gp : Format.formatter -> unit +val get_gp : Format.formatter -> pp_global_params + +(** {6 Output functions of pretty-printing. } *) + +val with_output_to : out_channel -> Format.formatter + +val std_ft : Format.formatter ref +val err_ft : Format.formatter ref +val deep_ft : Format.formatter ref + +(** {6 For parametrization through vernacular. } *) + +val set_depth_boxes : int option -> unit +val get_depth_boxes : unit -> int option + +val set_margin : int option -> unit +val get_margin : unit -> int option + +(** Console display of feedback *) +val std_logger : ?loc:Loc.t -> Feedback.level -> Pp.std_ppcmds -> unit + +val emacs_logger : ?loc:Loc.t -> Feedback.level -> Pp.std_ppcmds -> unit + +val init_color_output : unit -> unit + +(** [with_output_to_file file f x] executes [f x] with logging + redirected to a file [file] *) +val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b + diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 94ef54f70f..283c095eb6 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -14,4 +14,5 @@ Record Assumptions Vernacinterp Mltop +Topfmt Vernacentries diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 3afe04b37b..09c43f93ef 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1448,8 +1448,8 @@ let _ = optdepr = false; optname = "the printing depth"; optkey = ["Printing";"Depth"]; - optread = Pp_control.get_depth_boxes; - optwrite = Pp_control.set_depth_boxes } + optread = Topfmt.get_depth_boxes; + optwrite = Topfmt.set_depth_boxes } let _ = declare_int_option @@ -1457,8 +1457,8 @@ let _ = optdepr = false; optname = "the printing width"; optkey = ["Printing";"Width"]; - optread = Pp_control.get_margin; - optwrite = Pp_control.set_margin } + optread = Topfmt.get_margin; + optwrite = Topfmt.set_margin } let _ = declare_bool_option @@ -2193,7 +2193,7 @@ let with_fail b f = | e -> let e = CErrors.push e in raise (HasFailed (CErrors.iprint - (ExplainErr.process_vernac_interp_error ~allow_uncaught:false ~with_header:false e)))) + (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e)))) () with e when CErrors.noncritical e -> let (e, _) = CErrors.push e in @@ -2226,7 +2226,7 @@ let interp ?(verbosely=true) ?proof (loc,c) = current_timeout := Some n; aux ?locality ?polymorphism isprogcmd v | VernacRedirect (s, (_,v)) -> - Feedback.with_output_to_file s (aux false) v + Topfmt.with_output_to_file s (aux false) v | VernacTime (_,v) -> System.with_time !Flags.time (aux ?locality ?polymorphism isprogcmd) v; -- cgit v1.2.3 From a010de9bcaa33fc95a2a7cb6478ac21c95e3ad9e Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 30 Nov 2016 22:18:30 +0100 Subject: [pp] Remove richpp from fake_ide. --- Makefile.build | 7 +++---- tools/fake_ide.ml | 25 +++++++------------------ 2 files changed, 10 insertions(+), 22 deletions(-) diff --git a/Makefile.build b/Makefile.build index c62420326a..3b8d82e689 100644 --- a/Makefile.build +++ b/Makefile.build @@ -440,10 +440,9 @@ $(COQWORKMGR): $(call bestobj, lib/clib.cma stm/coqworkmgrApi.cmo tools/coqworkm # fake_ide : for debugging or test-suite purpose, a fake ide simulating # a connection to coqtop -ideslave -FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo \ - ide/document.cmo ide/serialize.cmo ide/richpp.cmo ide/xml_lexer.cmo \ - ide/xml_parser.cmo ide/xml_printer.cmo ide/xmlprotocol.cmo \ - tools/fake_ide.cmo +FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo ide/document.cmo \ + ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo ide/xml_printer.cmo \ + ide/xmlprotocol.cmo tools/fake_ide.cmo $(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOPLOOPCMA:.cma=$(BESTDYN)) $(SHOW)'OCAMLBEST -o $@' diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index e89f19041f..b538ba1d04 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -17,19 +17,8 @@ type coqtop = { xml_parser : Xml_parser.t; } -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 Richpp.(content |> richpp_of_pp |> repr) +let print_error msg = + Format.eprintf "fake_id: error: @[%a@]\n%!" (Pp.pp_with ?pp_tag:None) msg let base_eval_call ?(print=true) ?(fail=true) call coqtop = if print then prerr_endline (Xmlprotocol.pr_call call); @@ -44,8 +33,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_xml Richpp.(s |> richpp_of_pp |> repr) - | Interface.Fail (_,_,s) as x -> Printf.eprintf "%a\n%!" print_xml Richpp.(s |> richpp_of_pp |> repr); x + | Interface.Fail (_,_,s) when fail -> print_error s; exit 1 + | Interface.Fail (_,_,s) as x -> print_error s; x | x -> x let eval_call c q = ignore(base_eval_call c q) @@ -194,7 +183,7 @@ let print_document () = module GUILogic = struct let after_add = function - | Interface.Fail (_,_,s) -> error_xml Richpp.(repr (richpp_of_pp s)) + | Interface.Fail (_,_,s) -> print_error s; exit 1 | Interface.Good (id, (Util.Inl (), _)) -> Document.assign_tip_id doc id | Interface.Good (id, (Util.Inr tip, _)) -> @@ -206,7 +195,7 @@ module GUILogic = struct let at id id' _ = Stateid.equal id' id let after_edit_at (id,need_unfocus) = function - | Interface.Fail (_,_,s) -> error_xml Richpp.(repr (richpp_of_pp s)) + | Interface.Fail (_,_,s) -> print_error s; exit 1 | Interface.Good (Util.Inl ()) -> if need_unfocus then Document.unfocus doc; ignore(Document.cut_at doc id); @@ -329,7 +318,7 @@ let main = let finish () = match base_eval_call (Xmlprotocol.status true) coq with | Interface.Good _ -> exit 0 - | Interface.Fail (_,_,s) -> error_xml Richpp.(repr (richpp_of_pp s)) in + | Interface.Fail (_,_,s) -> print_error s; exit 1 in (* The main loop *) init (); while true do -- cgit v1.2.3 From e872f76058e954fac3e0652ec567aff72226e9dd Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 6 Dec 2016 11:03:12 +0100 Subject: [pp] Debug feeder is not needed anymore. -> Candidate to be merge with the main feedback commit. --- lib/feedback.ml | 4 ---- lib/feedback.mli | 3 --- 2 files changed, 7 deletions(-) diff --git a/lib/feedback.ml b/lib/feedback.ml index 31677ecfc9..7d9d6bf7f0 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -79,7 +79,3 @@ let msg_notice ?loc x = feedback_logger ?loc Notice x let msg_warning ?loc x = feedback_logger ?loc Warning x let msg_error ?loc x = feedback_logger ?loc Error x let msg_debug ?loc x = feedback_logger ?loc Debug x - -let debug_feeder = function - | { contents = Message (Debug, loc, pp) } -> msg_debug ?loc pp - | _ -> () diff --git a/lib/feedback.mli b/lib/feedback.mli index 3fb7c0039e..4bbdfcb5b6 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -64,9 +64,6 @@ val add_feeder : (feedback -> unit) -> int (** [del_feeder fid] removes the feeder with id [fid] *) val del_feeder : int -> unit -(** Prints feedback messages of kind Message(Debug,_) using msg_debug *) -val debug_feeder : feedback -> unit - (** [feedback ?id ?route fb] produces feedback fb, with [route] and [id] set appropiatedly, if absent, it will use the defaults set by [set_id_for_feedback] *) -- cgit v1.2.3 From 4084ee30293a6013592c0651dfeb1975711f135f Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 30 Nov 2016 22:24:17 +0100 Subject: [ide] richpp clenaup We remove the "abstraction breaking" primitives and reduce the file to the used fragment. --- ide/ide_slave.ml | 5 +++-- ide/ideutils.ml | 4 ++-- ide/ideutils.mli | 2 -- ide/richpp.ml | 14 -------------- ide/richpp.mli | 18 ++---------------- ide/xmlprotocol.ml | 5 ----- ide/xmlprotocol.mli | 4 ---- 7 files changed, 7 insertions(+), 45 deletions(-) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 88b61042ed..c77232ad15 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -111,8 +111,9 @@ let annotate phrase = let pa = Pcoq.Gram.parsable (Stream.of_string phrase) in Vernac.parse_sentence (pa,None) in - Richpp.repr (Richpp.richpp_of_pp (Ppvernac.pr_vernac ast)) - + (* XXX: Width should be a parameter of annotate... *) + Richpp.richpp_of_pp (Ppvernac.pr_vernac ast) + (** Goal display *) let hyp_next_tac sigma env decl = diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 498a911ee4..101f1a5eee 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -43,7 +43,7 @@ let xml_to_string xml = | Element (_, _, children) -> List.iter iter children in - let () = iter (Richpp.repr xml) in + let () = iter xml in Buffer.contents buf let insert_with_tags (buf : #GText.buffer_skel) mark rmark tags text = @@ -75,7 +75,7 @@ let insert_xml ?(mark = `INSERT) ?(tags = []) (buf : #GText.buffer_skel) msg = let tags = try tag t :: tags with Not_found -> tags in List.iter (fun xml -> insert tags xml) children in - let () = try insert tags (Richpp.repr msg) with _ -> () in + let () = try insert tags msg with _ -> () in buf#delete_mark rmark let set_location = ref (function s -> failwith "not ready") diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 1ae66e23e9..4b4ba72b0b 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -52,8 +52,6 @@ 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 : ?mark:GText.mark -> ?tags:GText.tag list -> #GText.buffer_skel -> Richpp.richpp -> unit diff --git a/ide/richpp.ml b/ide/richpp.ml index c0128dbc2d..b84c518245 100644 --- a/ide/richpp.ml +++ b/ide/richpp.ml @@ -172,10 +172,6 @@ let xml_of_rich_pp tag_of_annotation attributes_of_annotation 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 = Some (Ppstyle.repr t) in let rec drop = function @@ -188,13 +184,3 @@ let richpp_of_pp pp = 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 - diff --git a/ide/richpp.mli b/ide/richpp.mli index 2e839e996b..980d27407f 100644 --- a/ide/richpp.mli +++ b/ide/richpp.mli @@ -42,23 +42,9 @@ val xml_of_rich_pp : (** {5 Enriched text} *) -type richpp +type richpp = Xml_datatype.xml + (** 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 Debug/Compat} *) - -(** Represent the semi-structured document as a string, dropping any additional - information. *) -val raw_print : richpp -> string diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 08f23d3d4e..6ed62082d7 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -92,11 +92,6 @@ let to_stateid = function let of_stateid i = Element ("state_id",["val",string_of_int (Stateid.to_int i)],[]) -let of_richpp x = Element ("richpp", [], [Richpp.repr x]) -let to_richpp xml = match xml with - | Element ("richpp", [], [x]) -> Richpp.richpp_of_xml x - | x -> raise Serialize.(Marshal_error("richpp",x)) - let of_box (ppb : Pp.block_type) = let open Pp in match ppb with | Pp_hbox i -> constructor "ppbox" "hbox" [of_int i] | Pp_vbox i -> constructor "ppbox" "vbox" [of_int i] diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli index f6fae24d7c..43a65dfa85 100644 --- a/ide/xmlprotocol.mli +++ b/ide/xmlprotocol.mli @@ -57,10 +57,6 @@ val pr_call : 'a call -> string val pr_value : 'a value -> string val pr_full_value : 'a call -> 'a value -> string -(** * Serialization of rich documents *) -val of_richpp : Richpp.richpp -> Xml_datatype.xml -val to_richpp : Xml_datatype.xml -> Richpp.richpp - (** * Serializaiton of feedback *) val of_feedback : Feedback.feedback -> xml val to_feedback : xml -> Feedback.feedback -- cgit v1.2.3 From 6885a398229918865378ea24f07d93d2bcdd2802 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 30 Sep 2016 09:43:31 +0200 Subject: [ide] Dynamic printing width. The IDE now gets core Coq's `std_ppcmds` document format which is width-independent. Thus, we follow [1] and make the `{proof,message}_view` object refresh their contents when the container widget changes size (by listening to GTK's `size_allocated` signal). The practical advantage is that now CoqIDE always renders terms with the proper printing width set and without a roundtrip to Coq. This patch dispenses the need for the `printing width` option, which could be removed altogether. [1] http://stackoverflow.com/questions/40854571/change-gtksourceview-contents-on-resize/ --- ide/coq.ml | 7 ------ ide/coq.mli | 1 - ide/coqOps.ml | 1 - ide/ide_slave.ml | 2 +- ide/richpp.ml | 16 +++++++------- ide/richpp.mli | 11 ++++++---- ide/wg_Command.ml | 5 +++-- ide/wg_MessageView.ml | 59 +++++++++++++++++++++++++++++++++++++++----------- ide/wg_MessageView.mli | 1 + ide/wg_ProofView.ml | 29 ++++++++++++++----------- ide/wg_ProofView.mli | 1 - 11 files changed, 82 insertions(+), 51 deletions(-) diff --git a/ide/coq.ml b/ide/coq.ml index e2036beee3..bb9d6e5228 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -549,18 +549,11 @@ struct let _ = reset () - (** Integer option *) - - let width = ["Printing"; "Width"] - let width_state = ref None - let set_printing_width w = width_state := Some w - (** Transmitting options to coqtop *) let enforce h k = let mkopt o v acc = (o, Interface.BoolValue v) :: acc in let opts = Hashtbl.fold mkopt current_state [] in - let opts = (width, Interface.IntValue !width_state) :: opts in eval_call (Xmlprotocol.set_options opts) h (function | Interface.Good () -> k () diff --git a/ide/coq.mli b/ide/coq.mli index f2876de246..ab8c12a6f1 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -139,7 +139,6 @@ sig val bool_items : bool_descr list val set : t -> bool -> unit - val set_printing_width : int -> unit (** [enforce] transmits to coq the current option values. It is also called by [goals] and [evars] above. *) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 7982ffc8b8..cee243f91f 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -340,7 +340,6 @@ object(self) buffer#get_iter_at_mark `INSERT method private show_goals_aux ?(move_insert=false) () = - Coq.PrintOpt.set_printing_width proof#width; if move_insert then begin let dest = self#get_start_of_input in if (buffer#get_iter_at_mark `INSERT)#compare dest <= 0 then begin diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index c77232ad15..e3e1a88903 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -112,7 +112,7 @@ let annotate phrase = Vernac.parse_sentence (pa,None) in (* XXX: Width should be a parameter of annotate... *) - Richpp.richpp_of_pp (Ppvernac.pr_vernac ast) + Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast) (** Goal display *) diff --git a/ide/richpp.ml b/ide/richpp.ml index b84c518245..515090f713 100644 --- a/ide/richpp.ml +++ b/ide/richpp.ml @@ -38,7 +38,7 @@ type 'a context = { marking functions. As those functions are called when actually writing to the device, the resulting tree is correct. *) -let rich_pp annotate ppcmds = +let rich_pp width annotate ppcmds = let context = { stack = Leaf; @@ -113,12 +113,12 @@ let rich_pp annotate ppcmds = pp_set_formatter_tag_functions ft tag_functions; pp_set_mark_tags ft true; - (* Set formatter width. This is currently a hack and duplicate code - with Pp_control. Hopefully it will be fixed better in Coq 8.7 *) - let w = pp_get_margin str_formatter () in - let m = max (64 * w / 100) (w-30) in - pp_set_margin ft w; + (* Setting the formatter *) + pp_set_margin ft width; + let m = max (64 * width / 100) (width-30) in pp_set_max_indent ft m; + pp_set_max_boxes ft 50 ; + pp_set_ellipsis_text ft "..."; (** The whole output must be a valid document. To that end, we nest the document inside tags. *) @@ -172,7 +172,7 @@ let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml = type richpp = xml -let richpp_of_pp pp = +let richpp_of_pp width pp = let annotate t = Some (Ppstyle.repr t) in let rec drop = function | PCData s -> [PCData s] @@ -182,5 +182,5 @@ let richpp_of_pp pp = | None -> cs | Some s -> [Element (String.concat "." s, [], cs)] in - let xml = rich_pp annotate pp in + let xml = rich_pp width annotate pp in Element ("_", [], drop xml) diff --git a/ide/richpp.mli b/ide/richpp.mli index 980d27407f..0ceeeefc29 100644 --- a/ide/richpp.mli +++ b/ide/richpp.mli @@ -16,12 +16,15 @@ type 'annotation located = { endpos : int } -(** [rich_pp get_annotations ppcmds] returns the interpretation +(* XXX: The width parameter should be moved to a `formatter_property` + record shared with Topfmt *) + +(** [rich_pp width get_annotations ppcmds] returns the interpretation of [ppcmds] as a semi-structured document that represents (located) annotations of this string. The [get_annotations] function is used to convert tags into the desired - annotation. *) -val rich_pp : + annotation. [width] sets the printing witdh of the formatter. *) +val rich_pp : int -> (Pp.pp_tag -> 'annotation option) -> Pp.std_ppcmds -> 'annotation located Xml_datatype.gxml @@ -46,5 +49,5 @@ type richpp = Xml_datatype.xml (** Type of text with style annotations *) -val richpp_of_pp : Pp.std_ppcmds -> richpp +val richpp_of_pp : int -> Pp.std_ppcmds -> richpp (** Extract style information from formatted text *) diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index b83bd107ee..47dad8f196 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -103,11 +103,12 @@ object(self) let process = Coq.bind (Coq.query (phrase,Stateid.dummy)) (function | Interface.Fail (_,l,str) -> - Ideutils.insert_xml result#buffer (Richpp.richpp_of_pp str); + let width = Ideutils.textview_width result in + Ideutils.insert_xml result#buffer (Richpp.richpp_of_pp width str); notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce; Coq.return () | Interface.Good res -> - result#buffer#insert res; + result#buffer#insert res; notebook#set_page ~tab_label:(new_tab_lbl arg) frame#coerce; Coq.return ()) in diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 1cf389c75d..3d0cd46cd4 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -31,6 +31,7 @@ class type message_view = method add : Pp.std_ppcmds -> unit method add_string : string -> unit method set : Pp.std_ppcmds -> unit + method refresh : bool -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) method buffer : GText.buffer @@ -57,31 +58,58 @@ let message_view () : message_view = let () = view#set_left_margin 2 in view#misc#show (); let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in - let _ = background_color#connect#changed cb in - let _ = view#misc#connect#realize (fun () -> cb background_color#get) in + let _ = background_color#connect#changed ~callback:cb in + let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in stick text_font view cb; - object (self) + + (* Inserts at point, advances the mark *) + let insert_msg (level, msg) = + let tags = match level with + | Feedback.Error -> [Tags.Message.error] + | Feedback.Warning -> [Tags.Message.warning] + | _ -> [] + in + let mark = `MARK mark in + let width = Ideutils.textview_width view in + Ideutils.insert_xml ~mark buffer ~tags (Richpp.richpp_of_pp width msg); + buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n" + in + + let mv = object (self) inherit GObj.widget box#as_widget + (* List of displayed messages *) + val mutable last_width = -1 + val mutable msgs = [] + val push = new GUtil.signal () method connect = new message_view_signals_impl box#as_widget push + method refresh force = + (* We need to block updates here due to the following race: + insertion of messages may create a vertical scrollbar, this + will trigger a width change, calling refresh again and + going into an infinite loop. *) + let width = Ideutils.textview_width view in + (* Could still this method race if the scrollbar changes the + textview_width ?? *) + let needed = force || last_width <> width in + if needed then begin + last_width <- width; + buffer#set_text ""; + buffer#move_mark (`MARK mark) ~where:buffer#start_iter; + List.(iter insert_msg (rev msgs)) + end + method clear = - buffer#set_text ""; - buffer#move_mark (`MARK mark) ~where:buffer#start_iter + msgs <- []; self#refresh true method push level msg = - let tags = match level with - | Feedback.Error -> [Tags.Message.error] - | Feedback.Warning -> [Tags.Message.warning] - | _ -> [] - in - let mark = `MARK mark in - Ideutils.insert_xml ~mark buffer ~tags (Richpp.richpp_of_pp msg); - buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n"; + msgs <- (level, msg) :: msgs; + insert_msg (level, msg); push#call (level, msg) method add msg = self#push Feedback.Notice msg @@ -93,3 +121,8 @@ let message_view () : message_view = method buffer = text_buffer end + in + (* Is there a better way to connect the signal ? *) + let w_cb (_ : Gtk.rectangle) = mv#refresh false in + ignore (view#misc#connect#size_allocate ~callback:w_cb); + mv diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index a71d345a5f..d065fcbc80 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -21,6 +21,7 @@ class type message_view = method add : Pp.std_ppcmds -> unit method add_string : string -> unit method set : Pp.std_ppcmds -> unit + method refresh : bool -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) method buffer : GText.buffer diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 72aa9051a0..b5405570c9 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -18,7 +18,6 @@ class type proof_view = method clear : unit -> unit method set_goals : Interface.goals option -> unit method set_evars : Interface.evar list option -> unit - method width : int end (* tag is the tag to be hooked, item is the item covered by this tag, make_menu @@ -74,6 +73,7 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with | None -> [], [] | Some (hl, h) -> (hl, h) in + let width = Ideutils.textview_width proof in let rec insert_hyp hints hs = match hs with | [] -> () | hyp :: hs -> @@ -84,7 +84,7 @@ 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 () = insert_xml ~tags proof#buffer (Richpp.richpp_of_pp hyp) in + let () = insert_xml ~tags proof#buffer (Richpp.richpp_of_pp width hyp) in proof#buffer#insert "\n"; insert_hyp rem_hints hs in @@ -98,13 +98,13 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with else [] in proof#buffer#insert (goal_str 1 goals_cnt); - insert_xml proof#buffer (Richpp.richpp_of_pp cur_goal); + insert_xml proof#buffer (Richpp.richpp_of_pp width 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); - insert_xml proof#buffer (Richpp.richpp_of_pp g); + insert_xml proof#buffer (Richpp.richpp_of_pp width g); proof#buffer#insert "\n" in let () = Util.List.fold_left_i fold_goal 2 () rem_goals in @@ -122,6 +122,7 @@ let rec flatten = function let display mode (view : #GText.view_skel) goals hints evars = let () = view#buffer#set_text "" in + let width = Ideutils.textview_width view in match goals with | None -> () (* No proof in progress *) @@ -144,7 +145,7 @@ 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 = - insert_xml view#buffer (Richpp.richpp_of_pp goal.Interface.goal_ccl); + insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); view#buffer#insert "\n" in List.iter iter given_up_goals; @@ -153,7 +154,7 @@ 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 = - insert_xml view#buffer (Richpp.richpp_of_pp goal.Interface.goal_ccl); + insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); view#buffer#insert "\n" in List.iter iter shelved_goals @@ -166,7 +167,7 @@ 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 - insert_xml view#buffer (Richpp.richpp_of_pp goal.Interface.goal_ccl); + insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); view#buffer#insert "\n" in List.iteri iter bg @@ -192,7 +193,7 @@ let proof_view () = let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in stick text_font view cb; - object + let pf = object inherit GObj.widget view#as_widget val mutable goals = None val mutable evars = None @@ -207,9 +208,11 @@ let proof_view () = method refresh () = let dummy _ () = () in - display (mode_tactic dummy) (view :> GText.view_skel) goals None evars - - method width = Ideutils.textview_width (view :> GText.view_skel) + display (mode_tactic dummy) view goals None evars end - -(* ignore (proof_buffer#add_selection_clipboard cb); *) + in + (* Is there a better way to connect the signal ? *) + (* Can this be done in the object constructor? *) + let w_cb _ = pf#refresh () in + ignore (view#misc#connect#size_allocate w_cb); + pf diff --git a/ide/wg_ProofView.mli b/ide/wg_ProofView.mli index b6eae48b39..aa01d955d0 100644 --- a/ide/wg_ProofView.mli +++ b/ide/wg_ProofView.mli @@ -14,7 +14,6 @@ class type proof_view = method clear : unit -> unit method set_goals : Interface.goals option -> unit method set_evars : Interface.evar list option -> unit - method width : int end val proof_view : unit -> proof_view -- cgit v1.2.3 From a8ec2dc5c330ded1ba400ef202c57e68d2533312 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 5 Dec 2016 18:17:46 +0100 Subject: [pp] Remove special tag type and handler from Pp. For legacy reasons, pretty printing required to provide a "tag" interpretation function `pp_tag`. However such function was not of much use as the backends (richpp and terminal) hooked at the `Format.tag` level. We thus remove this unused indirection layer and annotate expressions with their `Format` tags. This is a step towards moving the last bit of terminal code out of the core system. --- ide/richpp.ml | 29 +++++------------------------ ide/richpp.mli | 4 +--- ide/xmlprotocol.ml | 4 ++-- lib/pp.ml | 14 ++++++-------- lib/pp.mli | 10 ++++------ lib/ppstyle.ml | 13 +++---------- lib/ppstyle.mli | 11 ----------- parsing/cLexer.ml4 | 2 +- tools/fake_ide.ml | 2 +- toplevel/coqloop.ml | 2 +- toplevel/coqtop.ml | 9 ++------- toplevel/vernac.ml | 2 +- vernac/topfmt.ml | 22 ++++++++++------------ 13 files changed, 37 insertions(+), 87 deletions(-) diff --git a/ide/richpp.ml b/ide/richpp.ml index 515090f713..ecf1f40211 100644 --- a/ide/richpp.ml +++ b/ide/richpp.ml @@ -24,10 +24,6 @@ type 'a context = { (** Pending opened nodes *) mutable offset : int; (** Quantity of characters printed so far *) - mutable annotations : 'a option Int.Map.t; - (** Map associating annotations to indexes *) - mutable index : int; - (** Current index of annotations *) } (** We use Format to introduce tags inside the pretty-printed document. @@ -38,23 +34,13 @@ type 'a context = { marking functions. As those functions are called when actually writing to the device, the resulting tree is correct. *) -let rich_pp width annotate ppcmds = +let rich_pp width ppcmds = let context = { stack = Leaf; offset = 0; - annotations = Int.Map.empty; - index = (-1); } in - let pp_tag obj = - let index = context.index + 1 in - let () = context.index <- index in - let obj = annotate obj in - let () = context.annotations <- Int.Map.add index obj context.annotations in - string_of_int index - in - let pp_buffer = Buffer.create 180 in let push_pcdata () = @@ -81,12 +67,8 @@ let rich_pp width annotate ppcmds = | Leaf -> assert false | Node (node, child, pos, ctx) -> let () = assert (String.equal tag node) in - let annotation = - try Int.Map.find (int_of_string node) context.annotations - with _ -> None - in let annotation = { - annotation = annotation; + annotation = Some tag; startpos = pos; endpos = context.offset; } in @@ -123,7 +105,7 @@ let rich_pp width annotate ppcmds = (** The whole output must be a valid document. To that end, we nest the document inside tags. *) pp_open_tag ft "pp"; - Pp.(pp_with ~pp_tag ft ppcmds); + Pp.(pp_with ft ppcmds); pp_close_tag ft (); (** Get the resulting XML tree. *) @@ -173,14 +155,13 @@ let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml = type richpp = xml let richpp_of_pp width pp = - let annotate t = Some (Ppstyle.repr t) 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)] + | Some s -> [Element (s, [], cs)] in - let xml = rich_pp width annotate pp in + let xml = rich_pp width pp in Element ("_", [], drop xml) diff --git a/ide/richpp.mli b/ide/richpp.mli index 0ceeeefc29..0fe4315b7a 100644 --- a/ide/richpp.mli +++ b/ide/richpp.mli @@ -24,9 +24,7 @@ type 'annotation located = { that represents (located) annotations of this string. The [get_annotations] function is used to convert tags into the desired annotation. [width] sets the printing witdh of the formatter. *) -val rich_pp : int -> - (Pp.pp_tag -> 'annotation option) -> Pp.std_ppcmds -> - 'annotation located Xml_datatype.gxml +val rich_pp : int -> Pp.std_ppcmds -> Pp.pp_tag located Xml_datatype.gxml (** [annotations_positions ssdoc] returns a list associating each annotations with its position in the string from which [ssdoc] is diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 6ed62082d7..1d50aed032 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -112,7 +112,7 @@ let rec of_pp (pp : Pp.std_ppcmds) = let open Pp in match pp with | Ppcmd_string s -> constructor "ppdoc" "string" [of_string s] | Ppcmd_glue sl -> constructor "ppdoc" "glue" [of_list of_pp sl] | Ppcmd_box (bt,s) -> constructor "ppdoc" "box" [of_pair of_box of_pp (bt,s)] - | Ppcmd_tag (t,s) -> constructor "ppdoc" "tag" [of_pair (of_list of_string) of_pp (t,s)] + | Ppcmd_tag (t,s) -> constructor "ppdoc" "tag" [of_pair of_string of_pp (t,s)] | Ppcmd_print_break (i,j) -> constructor "ppdoc" "break" [of_pair of_int of_int (i,j)] | Ppcmd_force_newline -> constructor "ppdoc" "newline" [] @@ -126,7 +126,7 @@ let rec to_pp xpp = let open Pp in | "glue" -> Ppcmd_glue (to_list to_pp (singleton args)) | "box" -> let (bt,s) = to_pair to_box to_pp (singleton args) in Ppcmd_box(bt,s) - | "tag" -> let (tg,s) = to_pair (to_list to_string) to_pp (singleton args) in + | "tag" -> let (tg,s) = to_pair to_string to_pp (singleton args) in Ppcmd_tag(tg,s) | "break" -> let (i,j) = to_pair to_int to_int (singleton args) in Ppcmd_print_break(i, j) diff --git a/lib/pp.ml b/lib/pp.ml index 5dba0356d8..53c1fb4c31 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -17,7 +17,7 @@ \end{description} *) -type pp_tag = string list +type pp_tag = string type block_type = | Pp_hbox of int @@ -161,10 +161,8 @@ let rec pr_com ft s = Some s2 -> Format.pp_force_newline ft (); pr_com ft s2 | None -> () -type tag_handler = pp_tag -> Format.tag - (* pretty printing functions *) -let pp_with ?pp_tag ft = +let pp_with ft = let cpp_open_box = function | Pp_hbox n -> Format.pp_open_hbox ft () | Pp_vbox n -> Format.pp_open_vbox ft n @@ -182,9 +180,9 @@ let pp_with ?pp_tag ft = | Ppcmd_print_break(m,n) -> pp_print_break ft m n | Ppcmd_force_newline -> pp_force_newline ft () | Ppcmd_comment coms -> List.iter (pr_com ft) coms - | Ppcmd_tag(tag, s) -> Option.iter (fun f -> pp_open_tag ft (f tag)) pp_tag; + | Ppcmd_tag(tag, s) -> pp_open_tag ft tag; pp_cmd s; - Option.iter (fun _ -> pp_close_tag ft () ) pp_tag + pp_close_tag ft () in try pp_cmd with reraise -> @@ -197,8 +195,8 @@ let pp_with ?pp_tag ft = them to different windows. *) (** Output to a string formatter *) -let string_of_ppcmds ?pp_tag c = - Format.fprintf Format.str_formatter "@[%a@]" (pp_with ?pp_tag) c; +let string_of_ppcmds c = + Format.fprintf Format.str_formatter "@[%a@]" pp_with c; Format.flush_str_formatter () (* Copy paste from Util *) diff --git a/lib/pp.mli b/lib/pp.mli index 12747d3a1d..ff42065349 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -33,7 +33,7 @@ (************************************************************************) (* XXX: Improve and add attributes *) -type pp_tag = string list +type pp_tag = string type block_type = | Pp_hbox of int @@ -165,9 +165,7 @@ val pr_loc : Loc.t -> std_ppcmds (** {6 Main renderers, to formatter and to string } *) -(** FIXME: These ignore the logging settings and call [Format] directly *) -type tag_handler = pp_tag -> Format.tag - (** [msg_with fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) -val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit -val string_of_ppcmds : ?pp_tag:tag_handler -> std_ppcmds -> string +val pp_with : Format.formatter -> std_ppcmds -> unit + +val string_of_ppcmds : std_ppcmds -> string diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml index 298e3be6b3..6969c3d5cb 100644 --- a/lib/ppstyle.ml +++ b/lib/ppstyle.ml @@ -19,27 +19,20 @@ let make ?style tag = let name = to_format tag in let () = assert (not (String.Map.mem name !tags)) in let () = tags := String.Map.add name style !tags in - tag - -let repr t = t + name let get_style tag = - try String.Map.find (to_format tag) !tags - with Not_found -> assert false - -let get_style_format tag = try String.Map.find tag !tags with Not_found -> assert false let set_style tag st = - try tags := String.Map.update (to_format tag) st !tags + try tags := String.Map.update tag st !tags with Not_found -> assert false let clear_styles () = tags := String.Map.map (fun _ -> None) !tags -let dump () = - List.map (fun (s,b) -> (String.split '.' s, b)) (String.Map.bindings !tags) +let dump () = String.Map.bindings !tags let parse_config s = let styles = Terminal.parse s in diff --git a/lib/ppstyle.mli b/lib/ppstyle.mli index b9422f7cf7..2690d3910a 100644 --- a/lib/ppstyle.mli +++ b/lib/ppstyle.mli @@ -14,28 +14,17 @@ (** This API is provisional and will likely be refined. *) type t = Pp.pp_tag -val to_format : t -> Format.tag -val of_format : Format.tag -> t - (** Style tags *) val make : ?style:Terminal.style -> string list -> t (** Create a new tag with the given name. Each name must be unique. The optional style is taken as the default one. *) -val repr : t -> string list -(** Gives back the original name of the style tag where each string has been - concatenated and separated with a dot. *) - (** {5 Manipulating global styles} *) val get_style : t -> Terminal.style option -(** Get the style associated to a tag. *) - -val get_style_format : Format.tag -> Terminal.style option (** Get the style associated to a tag from a format tag. *) - val set_style : t -> Terminal.style option -> unit (** Set a style associated to a tag. *) diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index a637d2e43f..3b84eaa816 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -105,7 +105,7 @@ module Error = struct Printf.sprintf "Unsupported Unicode character (0x%x)" x) (* Require to fix the Camlp4 signature *) - let print ppf x = Pp.pp_with ~pp_tag:Ppstyle.to_format ppf (Pp.str (to_string x)) + let print ppf x = Pp.pp_with ppf (Pp.str (to_string x)) end open Error diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index b538ba1d04..5dd2a92200 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -18,7 +18,7 @@ type coqtop = { } let print_error msg = - Format.eprintf "fake_id: error: @[%a@]\n%!" (Pp.pp_with ?pp_tag:None) msg + Format.eprintf "fake_id: error: @[%a@]\n%!" Pp.pp_with msg let base_eval_call ?(print=true) ?(fail=true) call coqtop = if print then prerr_endline (Xmlprotocol.pr_call call); diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index e9506803df..43807c1ca6 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -14,7 +14,7 @@ open Vernac open Pcoq let top_stderr x = - Format.fprintf !Topfmt.err_ft "@[%a@]%!" (pp_with ~pp_tag:Ppstyle.to_format) x + Format.fprintf !Topfmt.err_ft "@[%a@]%!" pp_with x (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 823d05580b..268d40c91d 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -311,18 +311,13 @@ let print_style_tags () = let tags = Ppstyle.dump () in let iter (t, st) = let st = match st with Some st -> st | None -> Terminal.make () in - let opt = - Terminal.eval st ^ - String.concat "." (Ppstyle.repr t) ^ - Terminal.reset ^ "\n" - in + let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in print_string opt in let make (t, st) = match st with | None -> None | Some st -> let tags = List.map string_of_int (Terminal.repr st) in - let t = String.concat "." (Ppstyle.repr t) in Some (t ^ "=" ^ String.concat ";" tags) in let repr = List.map_filter make tags in @@ -445,7 +440,7 @@ let get_native_name s = with the appropriate error code *) let fatal_error info anomaly = let msg = info ++ fnl () in - Format.fprintf !Topfmt.err_ft "@[%a@]%!" (pp_with ?pp_tag:None) msg; + Format.fprintf !Topfmt.err_ft "@[%a@]%!" pp_with msg; exit (if anomaly then 129 else 1) let parse_args arglist = diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 4fc4540c1c..06908abb6e 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -181,7 +181,7 @@ let pp_cmd_header loc com = *) (* FIXME *) let print_cmd_header loc com = - Pp.pp_with ~pp_tag:Ppstyle.to_format !Topfmt.std_ft (pp_cmd_header loc com); + Pp.pp_with !Topfmt.std_ft (pp_cmd_header loc com); Format.pp_print_flush !Topfmt.std_ft () let rec interp_vernac po chan_beautify checknav (loc,com) = diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 85981c386c..e5063e27b0 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -99,8 +99,8 @@ let set_margin v = type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit -let msgnl_with ?pp_tag fmt strm = - pp_with ?pp_tag fmt (strm ++ fnl ()); +let msgnl_with fmt strm = + pp_with fmt (strm ++ fnl ()); Format.pp_print_flush fmt () (* XXX: This is really painful! *) @@ -133,25 +133,24 @@ let make_body quoter info ?loc s = quoter (hov 0 (loc ++ info ++ s)) (* Generic logger *) -let gen_logger ?pp_tag dbg err ?loc level msg = match level with - | Debug -> msgnl_with ?pp_tag !std_ft (make_body dbg dbg_str ?loc msg) - | Info -> msgnl_with ?pp_tag !std_ft (make_body dbg info_str ?loc msg) +let gen_logger dbg err ?loc level msg = match level with + | Debug -> msgnl_with !std_ft (make_body dbg dbg_str ?loc msg) + | Info -> msgnl_with !std_ft (make_body dbg info_str ?loc msg) (* XXX: What to do with loc here? *) - | Notice -> msgnl_with ?pp_tag !std_ft msg + | Notice -> msgnl_with !std_ft msg | Warning -> Flags.if_warn (fun () -> - msgnl_with ?pp_tag !err_ft (make_body err warn_str ?loc msg)) () - | Error -> msgnl_with ?pp_tag !err_ft (make_body err err_str ?loc msg) + msgnl_with !err_ft (make_body err warn_str ?loc msg)) () + | Error -> msgnl_with !err_ft (make_body err err_str ?loc msg) (** Standard loggers *) (* We provide a generic clear_log_backend callback for backends wanting to do clenaup after the print. *) -let std_logger_tag = ref None let std_logger_cleanup = ref (fun () -> ()) let std_logger ?loc level msg = - gen_logger (fun x -> x) (fun x -> x) ?pp_tag:!std_logger_tag ?loc level msg; + gen_logger (fun x -> x) (fun x -> x) ?loc level msg; !std_logger_cleanup () (** Color logging. Moved from pp_style, it may need some more refactoring *) @@ -176,7 +175,7 @@ let make_style_stack () = | st :: _ -> st in let push tag = - let style = match Ppstyle.get_style_format tag with + let style = match Ppstyle.get_style tag with | None -> empty | Some st -> st in @@ -199,7 +198,6 @@ let make_style_stack () = let init_color_output () = let push_tag, pop_tag, clear_tag = make_style_stack () in std_logger_cleanup := clear_tag; - std_logger_tag := Some Ppstyle.to_format; let tag_handler = { Format.mark_open_tag = push_tag; Format.mark_close_tag = pop_tag; -- cgit v1.2.3 From 3fc02bb2034a648c9c27b76a9e7b4e02a78e55b9 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 5 Dec 2016 17:56:22 +0100 Subject: [pp] Move terminal-specific tagging to the toplevel. Previously, tags were associated to terminal styles, which doesn't make sense on terminal-free pretty printing scenarios. This commit moves tag interpretation to the toplevel terminal handling module `Topfmt`. --- ide/richpp.mli | 2 +- lib/clib.mllib | 1 - lib/pp.ml | 1 - lib/pp.mli | 3 +- lib/ppstyle.ml | 66 ------------------------------------------ lib/ppstyle.mli | 50 -------------------------------- plugins/ltac/pptactic.ml | 13 ++------- printing/ppconstr.ml | 32 +++++---------------- printing/printmod.ml | 10 +++---- toplevel/coqloop.ml | 2 +- toplevel/coqtop.ml | 17 +++++------ vernac/topfmt.ml | 74 +++++++++++++++++++++++++++++++++++++++--------- vernac/topfmt.mli | 6 ++++ 13 files changed, 90 insertions(+), 187 deletions(-) delete mode 100644 lib/ppstyle.ml delete mode 100644 lib/ppstyle.mli diff --git a/ide/richpp.mli b/ide/richpp.mli index 0fe4315b7a..ea4b189ba8 100644 --- a/ide/richpp.mli +++ b/ide/richpp.mli @@ -19,7 +19,7 @@ type 'annotation located = { (* XXX: The width parameter should be moved to a `formatter_property` record shared with Topfmt *) -(** [rich_pp width get_annotations ppcmds] returns the interpretation +(** [rich_pp width ppcmds] returns the interpretation of [ppcmds] as a semi-structured document that represents (located) annotations of this string. The [get_annotations] function is used to convert tags into the desired diff --git a/lib/clib.mllib b/lib/clib.mllib index 5a5f6afd39..c73ae9b904 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -28,7 +28,6 @@ Util Stateid Pp Feedback -Ppstyle CUnix Envars Aux_file diff --git a/lib/pp.ml b/lib/pp.ml index 53c1fb4c31..7b21f9bbd9 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -288,4 +288,3 @@ let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v let prvect elem v = prvect_with_sep mt elem v let surround p = hov 1 (str"(" ++ p ++ str")") - diff --git a/lib/pp.mli b/lib/pp.mli index ff42065349..2c45ce0a70 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -160,12 +160,11 @@ val surround : std_ppcmds -> std_ppcmds (** Surround with parenthesis. *) val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds - val pr_loc : Loc.t -> std_ppcmds (** {6 Main renderers, to formatter and to string } *) -(** [msg_with fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) +(** [pp_with fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) val pp_with : Format.formatter -> std_ppcmds -> unit val string_of_ppcmds : std_ppcmds -> string diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml deleted file mode 100644 index 6969c3d5cb..0000000000 --- a/lib/ppstyle.ml +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false - -let set_style tag st = - try tags := String.Map.update tag st !tags - with Not_found -> assert false - -let clear_styles () = - tags := String.Map.map (fun _ -> None) !tags - -let dump () = String.Map.bindings !tags - -let parse_config s = - let styles = Terminal.parse s in - let set accu (name, st) = - try String.Map.update name (Some st) accu with Not_found -> accu - in - tags := List.fold_left set !tags styles - -(** Default tag is to reset everything *) -let default = Terminal.({ - fg_color = Some `DEFAULT; - bg_color = Some `DEFAULT; - bold = Some false; - italic = Some false; - underline = Some false; - negative = Some false; -}) - -let empty = Terminal.make () - -let error_tag = - let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`RED () in - make ~style ["message"; "error"] - -let warning_tag = - let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`YELLOW () in - make ~style ["message"; "warning"] - -let debug_tag = - let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA () in - make ~style ["message"; "debug"] diff --git a/lib/ppstyle.mli b/lib/ppstyle.mli deleted file mode 100644 index 2690d3910a..0000000000 --- a/lib/ppstyle.mli +++ /dev/null @@ -1,50 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* string list -> t -(** Create a new tag with the given name. Each name must be unique. The optional - style is taken as the default one. *) - -(** {5 Manipulating global styles} *) - -val get_style : t -> Terminal.style option -(** Get the style associated to a tag from a format tag. *) - -val set_style : t -> Terminal.style option -> unit -(** Set a style associated to a tag. *) - -val clear_styles : unit -> unit -(** Clear all styles. *) - -val parse_config : string -> unit -(** Add all styles from the given string as parsed by {!Terminal.parse}. - Unregistered tags are ignored. *) - -val dump : unit -> (t * Terminal.style option) list -(** Recover the list of known tags together with their current style. *) - -(** {5 Tags} *) - -val error_tag : t -(** Tag used by the {!Pp.msg_error} function. *) - -val warning_tag : t -(** Tag used by the {!Pp.msg_warning} function. *) - -val debug_tag : t -(** Tag used by the {!Pp.msg_debug} function. *) diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index d9410a0885..dc418d530e 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -29,17 +29,10 @@ open Printer module Tag = struct - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["tactic"; "keyword"] - let primitive = - let style = Terminal.make ~fg_color:`LIGHT_GREEN () in - Ppstyle.make ~style ["tactic"; "primitive"] - - let string = - let style = Terminal.make ~fg_color:`LIGHT_RED () in - Ppstyle.make ~style ["tactic"; "string"] + let keyword = "tactic.keyword" + let primitive = "tactic.primitive" + let string = "tactic.string" end diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index c772f7be16..d92d832759 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -23,32 +23,14 @@ open Misctypes module Tag = struct - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["constr"; "keyword"] + let keyword = "constr.keyword" + let evar = "constr.evar" + let univ = "constr.type" + let notation = "constr.notation" + let variable = "constr.variable" + let reference = "constr.reference" + let path = "constr.path" - let evar = - let style = Terminal.make ~fg_color:`LIGHT_BLUE () in - Ppstyle.make ~style ["constr"; "evar"] - - let univ = - let style = Terminal.make ~bold:true ~fg_color:`YELLOW () in - Ppstyle.make ~style ["constr"; "type"] - - let notation = - let style = Terminal.make ~fg_color:`WHITE () in - Ppstyle.make ~style ["constr"; "notation"] - - let variable = - Ppstyle.make ["constr"; "variable"] - - let reference = - let style = Terminal.make ~fg_color:`LIGHT_GREEN () in - Ppstyle.make ~style ["constr"; "reference"] - - let path = - let style = Terminal.make ~fg_color:`LIGHT_MAGENTA () in - Ppstyle.make ~style ["constr"; "path"] end let do_not_tag _ x = x diff --git a/printing/printmod.ml b/printing/printmod.ml index 521b4ec2ae..baa1b8d791 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -28,12 +28,10 @@ open Goptions module Tag = struct - let definition = - let style = Terminal.make ~bold:true ~fg_color:`LIGHT_RED () in - Ppstyle.make ~style ["module"; "definition"] - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["module"; "keyword"] + + let definition = "module.definition" + let keyword = "module.keyword" + end let tag t s = Pp.tag t s diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 43807c1ca6..0cc6ca3177 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -252,7 +252,7 @@ let print_toplevel_error (e, info) = else mt () else print_location_in_file loc in - let hdr msg = hov 0 (tag Ppstyle.error_tag (str "Error:") ++ spc () ++ msg) in + let hdr msg = hov 0 (Topfmt.err_hdr ++ msg) in locmsg ++ hdr (CErrors.iprint (e, info)) (* Read the input stream until a dot is encountered *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 268d40c91d..c4d8dfec9f 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -67,8 +67,8 @@ let init_color () = () | Some s -> (** Overwrite all colors *) - Ppstyle.clear_styles (); - Ppstyle.parse_config s; + Topfmt.clear_styles (); + Topfmt.parse_color_config s; Topfmt.init_color_output () end @@ -308,19 +308,16 @@ let usage () = let print_style_tags () = let () = init_color () in - let tags = Ppstyle.dump () in + let tags = Topfmt.dump_tags () in let iter (t, st) = - let st = match st with Some st -> st | None -> Terminal.make () in - let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in + let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in print_string opt in - let make (t, st) = match st with - | None -> None - | Some st -> + let make (t, st) = let tags = List.map string_of_int (Terminal.repr st) in - Some (t ^ "=" ^ String.concat ";" tags) + (t ^ "=" ^ String.concat ";" tags) in - let repr = List.map_filter make tags in + let repr = List.map make tags in let () = Printf.printf "COQ_COLORS=\"%s\"\n" (String.concat ":" repr) in let () = List.iter iter tags in flush_all () diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index e5063e27b0..f843484f7e 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -97,6 +97,15 @@ let set_margin v = (** Console display of feedback *) +(** Default tags *) +module Tag = struct + + let error = "message.error" + let warning = "message.warning" + let debug = "message.debug" + +end + type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit let msgnl_with fmt strm = @@ -123,10 +132,10 @@ end open Emacs -let dbg_str = tag Ppstyle.debug_tag (str "Debug:") ++ spc () -let info_str = mt () -let warn_str = tag Ppstyle.warning_tag (str "Warning:") ++ spc () -let err_str = tag Ppstyle.error_tag (str "Error:") ++ spc () +let dbg_hdr = tag Tag.debug (str "Debug:") ++ spc () +let info_hdr = mt () +let warn_hdr = tag Tag.warning (str "Warning:") ++ spc () +let err_hdr = tag Tag.error (str "Error:") ++ spc () let make_body quoter info ?loc s = let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in @@ -134,13 +143,13 @@ let make_body quoter info ?loc s = (* Generic logger *) let gen_logger dbg err ?loc level msg = match level with - | Debug -> msgnl_with !std_ft (make_body dbg dbg_str ?loc msg) - | Info -> msgnl_with !std_ft (make_body dbg info_str ?loc msg) + | Debug -> msgnl_with !std_ft (make_body dbg dbg_hdr ?loc msg) + | Info -> msgnl_with !std_ft (make_body dbg info_hdr ?loc msg) (* XXX: What to do with loc here? *) | Notice -> msgnl_with !std_ft msg | Warning -> Flags.if_warn (fun () -> - msgnl_with !err_ft (make_body err warn_str ?loc msg)) () - | Error -> msgnl_with !err_ft (make_body err err_str ?loc msg) + msgnl_with !err_ft (make_body err warn_hdr ?loc msg)) () + | Error -> msgnl_with !err_ft (make_body err err_hdr ?loc msg) (** Standard loggers *) @@ -153,7 +162,43 @@ let std_logger ?loc level msg = gen_logger (fun x -> x) (fun x -> x) ?loc level msg; !std_logger_cleanup () -(** Color logging. Moved from pp_style, it may need some more refactoring *) +(** Color logging. Moved from Ppstyle, it may need some more refactoring *) + +(* Tag map for terminal style *) +let default_tag_map () = let open Terminal in [ + (* Local to console toplevel *) + "message.error" , make ~bold:true ~fg_color:`WHITE ~bg_color:`RED () + ; "message.warning" , make ~bold:true ~fg_color:`WHITE ~bg_color:`YELLOW () + ; "message.debug" , make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA () + (* Coming from the printer *) + ; "constr.evar" , make ~fg_color:`LIGHT_BLUE () + ; "constr.keyword" , make ~bold:true () + ; "constr.type" , make ~bold:true ~fg_color:`YELLOW () + ; "constr.notation" , make ~fg_color:`WHITE () + (* ["constr"; "variable"] is not assigned *) + ; "constr.reference" , make ~fg_color:`LIGHT_GREEN () + ; "constr.path" , make ~fg_color:`LIGHT_MAGENTA () + ; "module.definition", make ~bold:true ~fg_color:`LIGHT_RED () + ; "module.keyword" , make ~bold:true () + ; "tactic.keyword" , make ~bold:true () + ; "tactic.primitive" , make ~fg_color:`LIGHT_GREEN () + ; "tactic.string" , make ~fg_color:`LIGHT_RED () + ] + +let tag_map = ref CString.Map.empty + +let init_tag_map styles = + let set accu (name, st) = CString.Map.add name st accu in + tag_map := List.fold_left set !tag_map styles + +let clear_styles () = + tag_map := CString.Map.empty + +let parse_color_config file = + let styles = Terminal.parse file in + init_tag_map styles + +let dump_tags () = CString.Map.bindings !tag_map (** Not thread-safe. We should put a lock somewhere if we print from different threads. Do we? *) @@ -175,9 +220,9 @@ let make_style_stack () = | st :: _ -> st in let push tag = - let style = match Ppstyle.get_style tag with - | None -> empty - | Some st -> st + let style = + try CString.Map.find tag !tag_map + with | Not_found -> empty in (** Use the merging of the latest tag and the one being currently pushed. This may be useful if for instance the latest tag changes the background and @@ -196,6 +241,7 @@ let make_style_stack () = push, pop, clear let init_color_output () = + init_tag_map (default_tag_map ()); let push_tag, pop_tag, clear_tag = make_style_stack () in std_logger_cleanup := clear_tag; let tag_handler = { @@ -220,8 +266,8 @@ let emacs_logger = gen_logger emacs_quote_info emacs_quote_err let ft_logger old_logger ft ?loc level mesg = let id x = x in match level with - | Debug -> msgnl_with ft (make_body id dbg_str mesg) - | Info -> msgnl_with ft (make_body id info_str mesg) + | Debug -> msgnl_with ft (make_body id dbg_hdr mesg) + | Info -> msgnl_with ft (make_body id info_hdr mesg) | Notice -> msgnl_with ft mesg | Warning -> old_logger ?loc level mesg | Error -> old_logger ?loc level mesg diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index 38a400cfd0..1555f80a9f 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -36,12 +36,18 @@ val get_depth_boxes : unit -> int option val set_margin : int option -> unit val get_margin : unit -> int option +(** Headers for tagging *) +val err_hdr : Pp.std_ppcmds + (** Console display of feedback *) val std_logger : ?loc:Loc.t -> Feedback.level -> Pp.std_ppcmds -> unit val emacs_logger : ?loc:Loc.t -> Feedback.level -> Pp.std_ppcmds -> unit val init_color_output : unit -> unit +val clear_styles : unit -> unit +val parse_color_config : string -> unit +val dump_tags : unit -> (string * Terminal.style) list (** [with_output_to_file file f x] executes [f x] with logging redirected to a file [file] *) -- cgit v1.2.3 From 3b3d5937939ac8dc4f152d61391630e62bb0b2e5 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 7 Dec 2016 12:12:54 +0100 Subject: [pp] [ide] Minor cleanups in pp code. - We avoid unnecessary use of Pp -> string conversion functions. and the creation of intermediate buffers on logging. - We rename local functions that share the name with the Coq stdlib, this is usually dangerous as if the normal function is removed, code may pick up the one in the stdlib, with different semantics. --- ide/coqOps.ml | 30 ++++++++++++++----------- ide/ideutils.ml | 2 +- ide/minilib.ml | 6 +++-- ide/minilib.mli | 3 ++- lib/pp.ml | 2 ++ lib/pp.mli | 3 +++ library/summary.ml | 6 +++-- proofs/proof_global.ml | 4 ++-- proofs/proof_using.ml | 2 +- stm/asyncTaskQueue.ml | 25 ++++++++++----------- stm/stm.ml | 58 ++++++++++++++++++++++++------------------------- vernac/auto_ind_decl.ml | 4 ++-- vernac/vernacentries.ml | 4 ++-- 13 files changed, 81 insertions(+), 68 deletions(-) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index cee243f91f..1b4c5d3be0 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -128,6 +128,9 @@ end = struct end open SentenceId +let log_pp msg : unit task = + Coq.lift (fun () -> Minilib.log_pp msg) + let log msg : unit task = Coq.lift (fun () -> Minilib.log msg) @@ -308,7 +311,7 @@ object(self) method private print_stack = Minilib.log "document:"; - Minilib.log (Pp.string_of_ppcmds (Doc.print document (dbg_to_string buffer))) + Minilib.log_pp (Doc.print document (dbg_to_string buffer)) method private enter_focus start stop = let at id id' _ = Stateid.equal id' id in @@ -379,8 +382,7 @@ object(self) Coq.bind (Coq.seq action query) next method private mark_as_needed sentence = - Minilib.log("Marking " ^ - Pp.string_of_ppcmds (dbg_to_string buffer false None sentence)); + Minilib.log_pp Pp.(str "Marking " ++ dbg_to_string buffer false None sentence); let start = buffer#get_iter_at_mark sentence.start in let stop = buffer#get_iter_at_mark sentence.stop in let to_process = Tags.Script.to_process in @@ -437,9 +439,11 @@ object(self) | _ -> None in try Some (Doc.find_map document finder) with Not_found -> None in - let log s state_id = - Minilib.log ("Feedback " ^ s ^ " on " ^ Stateid.to_string - (Option.default Stateid.dummy state_id)) in + let log_pp s state_id = + Minilib.log_pp Pp.(seq + [str "Feedback "; s; str " on "; + str (Stateid.to_string (Option.default Stateid.dummy state_id))]) in + let log s state_id = log_pp (Pp.str s) state_id in begin match msg.contents, sentence with | AddedAxiom, Some (id,sentence) -> log "AddedAxiom" id; @@ -469,24 +473,24 @@ object(self) (Printf.sprintf "%s %s %s" filepath ident ty) | Message(Error, loc, msg), Some (id,sentence) -> let loc = Option.default Loc.ghost loc in - let msg = Pp.string_of_ppcmds msg in - log "ErrorMsg" id; + log_pp Pp.(str "ErrorMsg" ++ msg) id; remove_flag sentence `PROCESSING; - add_flag sentence (`ERROR (loc, msg)); + let rmsg = Pp.string_of_ppcmds msg in + add_flag sentence (`ERROR (loc, rmsg)); self#mark_as_needed sentence; - self#attach_tooltip sentence loc msg; + self#attach_tooltip sentence loc rmsg; if not (Loc.is_ghost loc) then self#position_error_tag_at_sentence sentence (Some (Loc.unloc loc)) | Message(Warning, loc, msg), Some (id,sentence) -> let loc = Option.default Loc.ghost loc in - let rmsg = Pp.string_of_ppcmds msg in - log ("WarningMsg: " ^ Pp.string_of_ppcmds msg)id; + log_pp Pp.(str "WarningMsg" ++ msg) id; + let rmsg = Pp.string_of_ppcmds msg in add_flag sentence (`WARNING (loc, rmsg)); self#attach_tooltip sentence loc rmsg; self#position_warning_tag_at_sentence sentence loc; messages#push Warning msg | Message(lvl, loc, msg), Some (id,sentence) -> - log ("Msg: " ^ Pp.string_of_ppcmds msg) id; + log_pp Pp.(str "Msg" ++ msg) id; messages#push lvl msg | InProgress n, _ -> if n < 0 then processed <- processed + abs n diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 101f1a5eee..da867e689e 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -337,7 +337,7 @@ let default_logger level message = | Feedback.Warning -> `WARNING | Feedback.Error -> `ERROR in - Minilib.log ~level (Pp.string_of_ppcmds message) + Minilib.log_pp ~level message (** {6 File operations} *) diff --git a/ide/minilib.ml b/ide/minilib.ml index d11e8c56b2..2c24e46f8f 100644 --- a/ide/minilib.ml +++ b/ide/minilib.ml @@ -30,7 +30,7 @@ let debug = ref false print in the response buffer. *) -let log ?(level = `DEBUG) msg = +let log_pp ?(level = `DEBUG) msg = let prefix = match level with | `DEBUG -> "DEBUG" | `INFO -> "INFO" @@ -40,10 +40,12 @@ let log ?(level = `DEBUG) msg = | `FATAL -> "FATAL" in if !debug then begin - try Printf.eprintf "[%s] %s\n%!" prefix msg + try Format.eprintf "[%s] @[%a@]\n%!" prefix Pp.pp_with msg with _ -> () end +let log ?level str = log_pp ?level (Pp.str str) + let coqify d = Filename.concat d "coq" let coqide_config_home () = diff --git a/ide/minilib.mli b/ide/minilib.mli index b7672c9002..4517a23744 100644 --- a/ide/minilib.mli +++ b/ide/minilib.mli @@ -22,7 +22,8 @@ type level = [ (** debug printing *) val debug : bool ref -val log : ?level:level -> string -> unit +val log_pp : ?level:level -> Pp.std_ppcmds -> unit +val log : ?level:level -> string -> unit val coqide_config_home : unit -> string val coqide_config_dirs : unit -> string list diff --git a/lib/pp.ml b/lib/pp.ml index 7b21f9bbd9..80c599274a 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -77,6 +77,8 @@ let app s1 s2 = match s1, s2 with | s, Ppcmd_empty -> s | s1, s2 -> Ppcmd_glue [s1; s2] +let seq s = Ppcmd_glue s + let (++) = app (* formatting commands *) diff --git a/lib/pp.mli b/lib/pp.mli index 2c45ce0a70..4b7ac5c1ae 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -68,6 +68,9 @@ val comment : string list -> std_ppcmds val app : std_ppcmds -> std_ppcmds -> std_ppcmds (** Concatenation. *) +val seq : std_ppcmds list -> std_ppcmds +(** Multi-Concatenation. *) + val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds (** Infix alias for [app]. *) diff --git a/library/summary.ml b/library/summary.ml index 6efa07f388..2ec4760d64 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -107,8 +107,10 @@ let unfreeze_summaries fs = try fold id decl state with e when CErrors.noncritical e -> let e = CErrors.push e in - Printf.eprintf "Error unfrezing summay %s\n%s\n%!" - (name_of_summary id) (Pp.string_of_ppcmds (CErrors.iprint e)); + Feedback.msg_error + Pp.(seq [str "Error unfrezing summay %s\n%s\n%!"; + str (name_of_summary id); + CErrors.iprint e]); iraise e in (** We rely on the order of the frozen list, and the order of folding *) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 120cde5e55..ca7330fdb6 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -195,9 +195,9 @@ let check_no_pending_proof () = if not (there_are_pending_proofs ()) then () else begin - CErrors.error (Pp.string_of_ppcmds + CErrors.user_err (str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++ - str"Use \"Abort All\" first or complete proof(s).")) + str"Use \"Abort All\" first or complete proof(s).") end let discard_gen id = diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml index a125fb10db..f51586c739 100644 --- a/proofs/proof_using.ml +++ b/proofs/proof_using.ml @@ -108,7 +108,7 @@ let remove_ids_and_lets env s ids = let suggest_Proof_using name env vars ids_typ context_ids = let module S = Id.Set in let open Pp in - let print x = prerr_endline (string_of_ppcmds x) in + let print x = Feedback.msg_error x in let pr_set parens s = let wrap ppcmds = if parens && S.cardinal s > 1 then str "(" ++ ppcmds ++ str ")" diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 28548ecee9..1254919880 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -10,9 +10,9 @@ open CErrors open Pp open Util -let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr +let stm_pr_err pp = Format.eprintf "%s] @[%a@]%!\n" (System.process_id ()) Pp.pp_with pp -let prerr_endline s = if !Flags.debug then begin pr_err s end else () +let stm_prerr_endline s = if !Flags.debug then begin stm_pr_err (str s) end else () type 'a worker_status = [ `Fresh | `Old of 'a ] @@ -147,23 +147,23 @@ module Make(T : Task) = struct let stop_waiting = ref false in let expiration_date = ref (ref false) in let pick_task () = - prerr_endline "waiting for a task"; + stm_prerr_endline "waiting for a task"; let pick age (t, c) = not !c && T.task_match age t in let task, task_expiration = TQueue.pop ~picky:(pick !worker_age) ~destroy:stop_waiting queue in expiration_date := task_expiration; last_task := Some task; - prerr_endline ("got task: "^T.name_of_task task); + stm_prerr_endline ("got task: " ^ T.name_of_task task); task in let add_tasks l = List.iter (fun t -> TQueue.push queue (t,!expiration_date)) l in let get_exec_token () = ignore(CoqworkmgrApi.get 1); got_token := true; - prerr_endline ("got execution token") in + stm_prerr_endline ("got execution token") in let kill proc = Worker.kill proc; - prerr_endline ("Worker exited: " ^ + stm_prerr_endline ("Worker exited: " ^ match Worker.wait proc with | Unix.WEXITED 0x400 -> "exit code unavailable" | Unix.WEXITED i -> Printf.sprintf "exit(%d)" i @@ -196,7 +196,7 @@ module Make(T : Task) = struct report_status ~id "Idle"; let task = pick_task () in match T.request_of_task !worker_age task with - | None -> prerr_endline ("Task expired: " ^ T.name_of_task task) + | None -> stm_prerr_endline ("Task expired: " ^ T.name_of_task task) | Some req -> try get_exec_token (); @@ -222,8 +222,7 @@ module Make(T : Task) = struct raise e (* we pass the exception to the external handler *) | MarshalError s -> T.on_marshal_error s task; raise Die | e -> - pr_err ("Uncaught exception in worker manager: "^ - string_of_ppcmds (print e)); + stm_pr_err Pp.(seq [str "Uncaught exception in worker manager: "; print e]); flush_all (); raise Die done with | (Die | TQueue.BeingDestroyed) -> @@ -261,7 +260,7 @@ module Make(T : Task) = struct let broadcast { queue } = TQueue.broadcast queue let enqueue_task { queue; active } (t, _ as item) = - prerr_endline ("Enqueue task "^T.name_of_task t); + stm_prerr_endline ("Enqueue task "^T.name_of_task t); TQueue.push queue item let cancel_worker { active } n = Pool.cancel n active @@ -329,11 +328,11 @@ module Make(T : Task) = struct CEphemeron.clear () with | MarshalError s -> - pr_err ("Fatal marshal error: " ^ s); flush_all (); exit 2 + stm_pr_err Pp.(prlist str ["Fatal marshal error: "; s]); flush_all (); exit 2 | End_of_file -> - prerr_endline "connection lost"; flush_all (); exit 2 + stm_prerr_endline "connection lost"; flush_all (); exit 2 | e -> - pr_err ("Slave: critical exception: " ^ Pp.string_of_ppcmds (print e)); + stm_pr_err Pp.(seq [str "Slave: critical exception: "; print e]); flush_all (); exit 1 done diff --git a/stm/stm.ml b/stm/stm.ml index 75872d633f..ee142b2930 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -6,10 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr +let stm_pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr -let prerr_endline s = if false then begin pr_err (s ()) end else () -let prerr_debug s = if !Flags.debug then begin pr_err (s ()) end else () +let stm_prerr_endline s = if false then begin stm_pr_err (s ()) end else () +let stm_prerr_debug s = if !Flags.debug then begin stm_pr_err (s ()) end else () open Vernacexpr open CErrors @@ -540,7 +540,7 @@ end = struct (* {{{ *) let branch, mode = match Vcs_aux.find_proof_at_depth !vcs pl with | h, { Vcs_.kind = `Proof (m, _) } -> h, m | _ -> assert false in checkout branch; - prerr_endline (fun () -> "mode:" ^ mode); + stm_prerr_endline (fun () -> "mode:" ^ mode); Proof_global.activate_proof_mode mode with Failure _ -> checkout Branch.master; @@ -852,7 +852,7 @@ end = struct (* {{{ *) if is_cached id && not redefine then anomaly (str"defining state "++str str_id++str" twice"); try - prerr_endline (fun () -> "defining "^str_id^" (cache="^ + stm_prerr_endline (fun () -> "defining "^str_id^" (cache="^ if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)"); let good_id = match safe_id with None -> !cur_id | Some id -> id in fix_exn_ref := exn_on id ~valid:good_id; @@ -860,7 +860,7 @@ end = struct (* {{{ *) fix_exn_ref := (fun x -> x); if cache = `Yes then freeze `No id else if cache = `Shallow then freeze `Shallow id; - prerr_endline (fun () -> "setting cur id to "^str_id); + stm_prerr_endline (fun () -> "setting cur id to "^str_id); cur_id := id; if feedback_processed then Hooks.(call state_computed id ~in_cache:false); @@ -994,11 +994,11 @@ let stm_vernac_interp ?proof id ?route { verbose; loc; expr } = in let aux_interp cmd = if is_filtered_command cmd then - prerr_endline (fun () -> "ignoring " ^ Pp.string_of_ppcmds(pr_vernac expr)) + stm_prerr_endline (fun () -> "ignoring " ^ Pp.string_of_ppcmds(pr_vernac expr)) else match cmd with | VernacShow ShowScript -> ShowScript.show_script () | expr -> - prerr_endline (fun () -> "interpreting " ^ Pp.string_of_ppcmds(pr_vernac expr)); + stm_prerr_endline (fun () -> "interpreting " ^ Pp.string_of_ppcmds(pr_vernac expr)); try Vernacentries.interp ?verbosely:(Some verbose) ?proof (loc, expr) with e -> let e = CErrors.push e in @@ -1431,8 +1431,8 @@ end = struct (* {{{ *) | Some (safe, err) -> err, safe | None -> Stateid.dummy, Stateid.dummy in let e_msg = iprint (e, info) in - prerr_endline (fun () -> "failed with the following exception:"); - prerr_endline (fun () -> string_of_ppcmds e_msg); + stm_prerr_endline (fun () -> "failed with the following exception:"); + stm_prerr_endline (fun () -> string_of_ppcmds e_msg); let e_safe_states = List.filter State.is_cached_and_valid my_states in RespError { e_error_at; e_safe_id; e_msg; e_safe_states } @@ -1697,7 +1697,7 @@ end = struct (* {{{ *) | Some (ReqBuildProof (r, b, _)) -> Some(r, b) | _ -> None) tasks in - prerr_endline (fun () -> Printf.sprintf "dumping %d tasks\n" (List.length reqs)); + stm_prerr_endline (fun () -> Printf.sprintf "dumping %d tasks\n" (List.length reqs)); reqs let reset_task_queue () = TaskQueue.clear (Option.get !queue) @@ -1781,7 +1781,7 @@ end = struct (* {{{ *) `Stay ((),[]) let on_marshal_error err { t_name } = - pr_err ("Fatal marshal error: " ^ t_name ); + stm_pr_err ("Fatal marshal error: " ^ t_name ); flush_all (); exit 1 let on_task_cancellation_or_expiration_or_slave_death = function @@ -1880,7 +1880,7 @@ end = struct (* {{{ *) let open Notations in try let pt, uc = Future.join f in - prerr_endline (fun () -> string_of_ppcmds(hov 0 ( + stm_prerr_endline (fun () -> string_of_ppcmds(hov 0 ( str"g=" ++ int (Evar.repr gid) ++ spc () ++ str"t=" ++ (Printer.pr_constr pt) ++ spc () ++ str"uc=" ++ Evd.pr_evar_universe_context uc))); @@ -1925,7 +1925,7 @@ end = struct (* {{{ *) let use_response _ _ _ = `End let on_marshal_error _ _ = - pr_err ("Fatal marshal error in query"); + stm_pr_err ("Fatal marshal error in query"); flush_all (); exit 1 let on_task_cancellation_or_expiration_or_slave_death _ = () @@ -2000,7 +2000,7 @@ let warn_deprecated_nested_proofs = "stop working in a future Coq version")) let collect_proof keep cur hd brkind id = - prerr_endline (fun () -> "Collecting proof ending at "^Stateid.to_string id); + stm_prerr_endline (fun () -> "Collecting proof ending at "^Stateid.to_string id); let no_name = "" in let name = function | [] -> no_name @@ -2100,7 +2100,7 @@ let string_of_reason = function | `NoPU_NoHint_NoES -> "no 'Proof using..', no .aux file, inside a section" | `Unknown -> "unsupported case" -let log_string s = prerr_debug (fun () -> "STM: " ^ s) +let log_string s = stm_prerr_debug (fun () -> "STM: " ^ s) let log_processing_async id name = log_string Printf.(sprintf "%s: proof %s: asynch" (Stateid.to_string id) name ) @@ -2187,16 +2187,16 @@ let known_state ?(redefine_qed=false) ~cache id = Summary.unfreeze_summary s; Lib.unfreeze l; update_global_env () in let rec pure_cherry_pick_non_pstate safe_id id = Future.purify (fun id -> - prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id); + stm_prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id); reach ~safe_id id; cherry_pick_non_pstate ()) id (* traverses the dag backward from nodes being already calculated *) and reach ?safe_id ?(redefine_qed=false) ?(cache=cache) id = - prerr_endline (fun () -> "reaching: " ^ Stateid.to_string id); + stm_prerr_endline (fun () -> "reaching: " ^ Stateid.to_string id); if not redefine_qed && State.is_cached ~cache id then begin Hooks.(call state_computed id ~in_cache:true); - prerr_endline (fun () -> "reached (cache)"); + stm_prerr_endline (fun () -> "reached (cache)"); State.install_cached id end else let step, cache_step, feedback_processed = @@ -2348,7 +2348,7 @@ let known_state ?(redefine_qed=false) ~cache id = else cache_step in State.define ?safe_id ~cache:cache_step ~redefine:redefine_qed ~feedback_processed step id; - prerr_endline (fun () -> "reached: "^ Stateid.to_string id) in + stm_prerr_endline (fun () -> "reached: "^ Stateid.to_string id) in reach ~redefine_qed id end (* }}} *) @@ -2363,7 +2363,7 @@ let init () = Backtrack.record (); Slaves.init (); if Flags.async_proofs_is_master () then begin - prerr_endline (fun () -> "Initializing workers"); + stm_prerr_endline (fun () -> "Initializing workers"); Query.init (); let opts = match !Flags.async_proofs_private_flags with | None -> [] @@ -2415,9 +2415,9 @@ let rec join_admitted_proofs id = let join () = finish (); wait (); - prerr_endline (fun () -> "Joining the environment"); + stm_prerr_endline (fun () -> "Joining the environment"); Global.join_safe_environment (); - prerr_endline (fun () -> "Joining Admitted proofs"); + stm_prerr_endline (fun () -> "Joining Admitted proofs"); join_admitted_proofs (VCS.get_branch_pos (VCS.current_branch ())); VCS.print (); VCS.print () @@ -2491,7 +2491,7 @@ let handle_failure (e, info) vcs tty = anomaly(str"error with no safe_id attached:" ++ spc() ++ CErrors.iprint_no_report (e, info)) | Some (safe_id, id) -> - prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); + stm_prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); VCS.restore vcs; if tty && interactive () = `Yes then begin (* We stay on a valid state *) @@ -2514,13 +2514,13 @@ let reset_task_queue = Slaves.reset_task_queue (* Document building *) let process_transaction ?(newtip=Stateid.fresh ()) ~tty ({ verbose; loc; expr } as x) c = - prerr_endline (fun () -> "{{{ processing: "^ string_of_ppcmds (pr_ast x)); + stm_prerr_endline (fun () -> "{{{ processing: "^ string_of_ppcmds (pr_ast x)); let vcs = VCS.backup () in try let head = VCS.current_branch () in VCS.checkout head; let rc = begin - prerr_endline (fun () -> + stm_prerr_endline (fun () -> " classified as: " ^ string_of_vernac_classification c); match c with (* PG stuff *) @@ -2558,7 +2558,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty VCS.commit id (Alias (oid,x)); Backtrack.record (); if w == VtNow then finish (); `Ok | VtStm (VtBack id, false), VtNow -> - prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id); + stm_prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id); Backtrack.backto id; VCS.checkout_shallowest_proof_branch (); Reach.known_state ~cache:(interactive ()) id; `Ok @@ -2708,7 +2708,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty expr = VernacShow (ShowGoal OpenSubgoals) } | _ -> () end; - prerr_endline (fun () -> "processed }}}"); + stm_prerr_endline (fun () -> "processed }}}"); VCS.print (); rc with e -> @@ -2894,7 +2894,7 @@ let edit_at id = anomaly (str ("edit_at "^Stateid.to_string id^": ") ++ CErrors.print_no_report e) | Some (_, id) -> - prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); + stm_prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); VCS.restore vcs; VCS.print (); iraise (e, info) diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 594f2e9449..6d71601cc5 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -444,14 +444,14 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = with Not_found -> (* spiwack: the format of this error message should probably be improved. *) - let err_msg = string_of_ppcmds + let err_msg = (str "boolean->Leibniz:" ++ str "You have to declare the" ++ str "decidability over " ++ Printer.pr_constr tt1 ++ str " first.") in - error err_msg + user_err err_msg in let bl_args = Array.append (Array.append (Array.map (fun x -> x) v) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 09c43f93ef..999fe297ed 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -39,7 +39,7 @@ module NamedDecl = Context.Named.Declaration let (f_interp_redexp, interp_redexp_hook) = Hook.make () let debug = false -let prerr_endline x = +let vernac_prerr_endline x = if debug then prerr_endline (x ()) else () (* Misc *) @@ -1933,7 +1933,7 @@ let vernac_load interp fname = * 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 (fun () -> "interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c)); + vernac_prerr_endline (fun () -> "interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c)); match c with (* The below vernac are candidates for removal from the main type and to be put into a new doc_command datatype: *) -- cgit v1.2.3 From 921ea3983d45051ae85b0e20bf13de2eff38e53e Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 8 Feb 2017 18:13:25 +0100 Subject: [pp] Remove uses of expensive string_of_ppcmds. In general we want to avoid this as much as we can, as it will need to make choices regarding the output backend (width, etc...) and it is expensive. It is better to serve the printing backends the pretty print document itself. --- checker/reduction.ml | 6 +++--- engine/universes.ml | 7 +++---- ide/ide_slave.ml | 2 +- stm/stm.ml | 20 +++++++++++--------- tools/fake_ide.ml | 4 +++- vernac/search.ml | 2 +- vernac/search.mli | 2 +- vernac/vernacentries.ml | 7 ++++--- 8 files changed, 27 insertions(+), 23 deletions(-) diff --git a/checker/reduction.ml b/checker/reduction.ml index ec16aa2615..28c0126b41 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -176,9 +176,9 @@ 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 "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)) + Format.eprintf "sort_cmp: @[%a@]\n%!" Pp.pp_with Pp.( + str"Error: " ++ Univ.pr_uni u1 ++ str op ++ Univ.pr_uni u2 ++ str ":" ++ cut() + ++ Univ.pr_universes univ) end; raise NotConvertible end diff --git a/engine/universes.ml b/engine/universes.ml index 6720fcef8f..30a9ef1634 100644 --- a/engine/universes.ml +++ b/engine/universes.ml @@ -416,10 +416,9 @@ let constr_of_global gr = (* Should be an error as we might forget constraints, allow for now to make firstorder work with "using" clauses *) c - else raise (Invalid_argument - ("constr_of_global: globalization of polymorphic reference " ^ - Pp.string_of_ppcmds (Nametab.pr_global_env Id.Set.empty gr) ^ - " would forget universes.")) + else CErrors.user_err ~hdr:"constr_of_global" + Pp.(str "globalization of polymorphic reference " ++ Nametab.pr_global_env Id.Set.empty gr ++ + str " would forget universes.") else c let constr_of_reference = constr_of_global diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index e3e1a88903..2065a45467 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -255,7 +255,7 @@ let status force = let export_coq_object t = { Interface.coq_object_prefix = t.Search.coq_object_prefix; Interface.coq_object_qualid = t.Search.coq_object_qualid; - Interface.coq_object_object = t.Search.coq_object_object + Interface.coq_object_object = Pp.string_of_ppcmds (pr_lconstr_env (Global.env ()) Evd.empty t.Search.coq_object_object) } let pattern_of_string ?env s = diff --git a/stm/stm.ml b/stm/stm.ml index ee142b2930..b9dbb78917 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -6,11 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -let stm_pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr +let stm_pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr +let stm_pp_err pp = Format.eprintf "%s] @[%a@]\n" (System.process_id ()) Pp.pp_with pp; flush stderr let stm_prerr_endline s = if false then begin stm_pr_err (s ()) end else () let stm_prerr_debug s = if !Flags.debug then begin stm_pr_err (s ()) end else () +let stm_pperr_endline s = if false then begin stm_pp_err (s ()) end else () + open Vernacexpr open CErrors open Pp @@ -994,11 +997,11 @@ let stm_vernac_interp ?proof id ?route { verbose; loc; expr } = in let aux_interp cmd = if is_filtered_command cmd then - stm_prerr_endline (fun () -> "ignoring " ^ Pp.string_of_ppcmds(pr_vernac expr)) + stm_pperr_endline Pp.(fun () -> str "ignoring " ++ pr_vernac expr) else match cmd with | VernacShow ShowScript -> ShowScript.show_script () | expr -> - stm_prerr_endline (fun () -> "interpreting " ^ Pp.string_of_ppcmds(pr_vernac expr)); + stm_pperr_endline Pp.(fun () -> str "interpreting " ++ pr_vernac expr); try Vernacentries.interp ?verbosely:(Some verbose) ?proof (loc, expr) with e -> let e = CErrors.push e in @@ -1431,11 +1434,10 @@ end = struct (* {{{ *) | Some (safe, err) -> err, safe | None -> Stateid.dummy, Stateid.dummy in let e_msg = iprint (e, info) in - stm_prerr_endline (fun () -> "failed with the following exception:"); - stm_prerr_endline (fun () -> string_of_ppcmds e_msg); + stm_pperr_endline Pp.(fun () -> str "failed with the following exception: " ++ fnl () ++ e_msg); let e_safe_states = List.filter State.is_cached_and_valid my_states in RespError { e_error_at; e_safe_id; e_msg; e_safe_states } - + let perform_states query = if query = [] then [] else let is_tac e = match classify_vernac e with @@ -1880,10 +1882,10 @@ end = struct (* {{{ *) let open Notations in try let pt, uc = Future.join f in - stm_prerr_endline (fun () -> string_of_ppcmds(hov 0 ( + stm_pperr_endline (fun () -> hov 0 ( str"g=" ++ int (Evar.repr gid) ++ spc () ++ str"t=" ++ (Printer.pr_constr pt) ++ spc () ++ - str"uc=" ++ Evd.pr_evar_universe_context uc))); + str"uc=" ++ Evd.pr_evar_universe_context uc)); (if abstract then Tactics.tclABSTRACT None else (fun x -> x)) (V82.tactic (Refiner.tclPUSHEVARUNIVCONTEXT uc) <*> Tactics.exact_no_check pt) @@ -2514,7 +2516,7 @@ let reset_task_queue = Slaves.reset_task_queue (* Document building *) let process_transaction ?(newtip=Stateid.fresh ()) ~tty ({ verbose; loc; expr } as x) c = - stm_prerr_endline (fun () -> "{{{ processing: "^ string_of_ppcmds (pr_ast x)); + stm_pperr_endline (fun () -> str "{{{ processing: " ++ pr_ast x); let vcs = VCS.backup () in try let head = VCS.current_branch () in diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index 5dd2a92200..7a891239bd 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -12,6 +12,8 @@ let error s = prerr_endline ("fake_id: error: "^s); exit 1 +let pperr_endline pp = Format.eprintf "@[%a@]\n%!" Pp.pp_with pp + type coqtop = { xml_printer : Xml_printer.t; xml_parser : Xml_parser.t; @@ -170,7 +172,7 @@ let print_document () = Str.global_replace (Str.regexp "^[\n ]*") "" (if String.length s > 20 then String.sub s 0 17 ^ "..." else s) in - prerr_endline (Pp.string_of_ppcmds + pperr_endline ( (Document.print doc (fun b state_id { name; text } -> Pp.str (Printf.sprintf "%s[%10s, %3s] %s" diff --git a/vernac/search.ml b/vernac/search.ml index e1b56b1319..540573843e 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -367,7 +367,7 @@ let interface_search = let answer = { coq_object_prefix = prefix; coq_object_qualid = qualid; - coq_object_object = string_of_ppcmds (pr_lconstr_env env Evd.empty constr); + coq_object_object = constr; } in ans := answer :: !ans; in diff --git a/vernac/search.mli b/vernac/search.mli index c9167c485d..82b79f75de 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -67,7 +67,7 @@ type 'a coq_object = { } val interface_search : ?glnum:int -> (search_constraint * bool) list -> - string coq_object list + constr coq_object list (** {6 Generic search function} *) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 999fe297ed..32e18a0149 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -39,8 +39,9 @@ module NamedDecl = Context.Named.Declaration let (f_interp_redexp, interp_redexp_hook) = Hook.make () let debug = false -let vernac_prerr_endline x = - if debug then prerr_endline (x ()) else () +(* XXX Should move to a common library *) +let vernac_pperr_endline pp = + if debug then Format.eprintf "@[%a@]@\n%!" Pp.pp_with (pp ()) else () (* Misc *) @@ -1933,7 +1934,7 @@ let vernac_load interp fname = * 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 = - vernac_prerr_endline (fun () -> "interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c)); + vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac c); match c with (* The below vernac are candidates for removal from the main type and to be put into a new doc_command datatype: *) -- cgit v1.2.3 From 6e3fc0992be7ddd841328028dec51d390fffb851 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 25 Jan 2017 01:48:41 +0100 Subject: [stm] Add common toploop for workers. This is a small, but convenient refactoring, as it will allow common argument parsing. --- stm/proofworkertop.ml | 6 +----- stm/queryworkertop.ml | 6 +----- stm/tacworkertop.ml | 6 +----- stm/workerLoop.ml | 15 +++++++++++++++ stm/workerLoop.mli | 9 +++++++++ 5 files changed, 27 insertions(+), 15 deletions(-) create mode 100644 stm/workerLoop.ml create mode 100644 stm/workerLoop.mli diff --git a/stm/proofworkertop.ml b/stm/proofworkertop.ml index 23538a467e..0d2f9cb747 100644 --- a/stm/proofworkertop.ml +++ b/stm/proofworkertop.ml @@ -8,11 +8,7 @@ module W = AsyncTaskQueue.MakeWorker(Stm.ProofTask) -let () = Coqtop.toploop_init := (fun args -> - Flags.make_silent true; - W.init_stdout (); - CoqworkmgrApi.init !Flags.async_proofs_worker_priority; - args) +let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout let () = Coqtop.toploop_run := W.main_loop diff --git a/stm/queryworkertop.ml b/stm/queryworkertop.ml index fff6d55434..9d30473739 100644 --- a/stm/queryworkertop.ml +++ b/stm/queryworkertop.ml @@ -8,11 +8,7 @@ module W = AsyncTaskQueue.MakeWorker(Stm.QueryTask) -let () = Coqtop.toploop_init := (fun args -> - Flags.make_silent true; - W.init_stdout (); - CoqworkmgrApi.init !Flags.async_proofs_worker_priority; - args) +let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout let () = Coqtop.toploop_run := W.main_loop diff --git a/stm/tacworkertop.ml b/stm/tacworkertop.ml index d5333d1077..256532c6b6 100644 --- a/stm/tacworkertop.ml +++ b/stm/tacworkertop.ml @@ -8,11 +8,7 @@ module W = AsyncTaskQueue.MakeWorker(Stm.TacTask) -let () = Coqtop.toploop_init := (fun args -> - Flags.make_silent true; - W.init_stdout (); - CoqworkmgrApi.init !Flags.async_proofs_worker_priority; - args) +let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout let () = Coqtop.toploop_run := W.main_loop diff --git a/stm/workerLoop.ml b/stm/workerLoop.ml new file mode 100644 index 0000000000..56fcf8537f --- /dev/null +++ b/stm/workerLoop.ml @@ -0,0 +1,15 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit) -> string list -> string list -- cgit v1.2.3 From 829a8feb3d02da057d39b5029b422e8a45dd1608 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 25 Jan 2017 14:39:29 +0100 Subject: [xml] Restore protocol compatibility with 8.6. By default, we serialize messages to the "rich printing representation" as it was done in 8.6, this ways clients don't have to adapt unless they specifically request the new format using option `--xml_format=Ppcmds` --- Makefile.build | 2 +- ide/coq.ml | 2 +- ide/ide.mllib | 1 + ide/ide_slave.ml | 19 ++++++++++++++----- ide/xmlprotocol.ml | 17 +++++++++++++++++ ide/xmlprotocol.mli | 14 ++++++++------ stm/stm.mllib | 1 + stm/workerLoop.ml | 6 +++++- tools/fake_ide.ml | 5 +++-- 9 files changed, 51 insertions(+), 16 deletions(-) diff --git a/Makefile.build b/Makefile.build index 3b8d82e689..01cc4d8780 100644 --- a/Makefile.build +++ b/Makefile.build @@ -442,7 +442,7 @@ $(COQWORKMGR): $(call bestobj, lib/clib.cma stm/coqworkmgrApi.cmo tools/coqworkm FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo ide/document.cmo \ ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo ide/xml_printer.cmo \ - ide/xmlprotocol.cmo tools/fake_ide.cmo + ide/richpp.cmo ide/xmlprotocol.cmo tools/fake_ide.cmo $(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOPLOOPCMA:.cma=$(BESTDYN)) $(SHOW)'OCAMLBEST -o $@' diff --git a/ide/coq.ml b/ide/coq.ml index bb9d6e5228..3a1d877872 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -366,7 +366,7 @@ let bind_self_as f = (** This launches a fresh handle from its command line arguments. *) let spawn_handle args respawner feedback_processor = let prog = coqtop_path () in - let args = Array.of_list ("-async-proofs" :: "on" :: "-ideslave" :: args) in + let args = Array.of_list ("--xml_format=Ppcmds" :: "-async-proofs" :: "on" :: "-ideslave" :: args) in let env = match !Flags.ideslave_coqtop_flags with | None -> None diff --git a/ide/ide.mllib b/ide/ide.mllib index 12170c4621..78b4c01e8c 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -14,6 +14,7 @@ Xml_parser Xml_printer Serialize Richpp +Topfmt Xmlprotocol Ideutils Coq diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 2065a45467..db450b4bc8 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -441,8 +441,8 @@ let print_xml = try Xml_printer.print oc xml; Mutex.unlock m with e -> let e = CErrors.push e in Mutex.unlock m; iraise e -let slave_feeder xml_oc msg = - let xml = Xmlprotocol.of_feedback msg in +let slave_feeder fmt xml_oc msg = + let xml = Xmlprotocol.(of_feedback fmt msg) in print_xml xml_oc xml (** The main loop *) @@ -451,6 +451,11 @@ let slave_feeder xml_oc msg = messages by [handle_exn] above. Otherwise, we die badly, without trying to answer malformed requests. *) +let msg_format = ref (fun () -> + let margin = Option.default 72 (Topfmt.get_margin ()) in + Xmlprotocol.Richpp margin +) + let loop () = init_signal_handler (); catch_break := false; @@ -461,7 +466,7 @@ let loop () = (* SEXP parser make *) let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in let () = Xml_parser.check_eof xml_ic false in - Feedback.add_feeder (slave_feeder xml_oc); + ignore (Feedback.add_feeder (slave_feeder (!msg_format ()) xml_oc)); (* We'll handle goal fetching and display in our own way *) Vernacentries.enable_goal_printing := false; Vernacentries.qed_display_script := false; @@ -474,7 +479,7 @@ let loop () = let r = eval_call q in let () = pr_debug_answer q r in (* pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *) - print_xml xml_oc (Xmlprotocol.of_answer q r); + print_xml xml_oc Xmlprotocol.(of_answer (!msg_format ()) q r); flush out_ch with | Xml_parser.Error (Xml_parser.Empty, _) -> @@ -496,6 +501,8 @@ let loop () = let rec parse = function | "--help-XML-protocol" :: rest -> Xmlprotocol.document Xml_printer.to_string_fmt; exit 0 + | "--xml_format=Ppcmds" :: rest -> + msg_format := (fun () -> Xmlprotocol.Ppcmds); parse rest | x :: rest -> x :: parse rest | [] -> [] @@ -507,4 +514,6 @@ let () = Coqtop.toploop_init := (fun args -> let () = Coqtop.toploop_run := loop -let () = Usage.add_to_usage "coqidetop" " --help-XML-protocol print the documentation of the XML protocol used by CoqIDE\n" +let () = Usage.add_to_usage "coqidetop" +" --xml_format=Ppcmds serialize pretty printing messages using the std_ppcmds format + --help-XML-protocol print the documentation of the XML protocol used by CoqIDE\n" diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 1d50aed032..b4f2ad0bef 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -12,6 +12,9 @@ let protocol_version = "20150913" +type msg_format = Richpp of int | Ppcmds +let msg_format = ref (Richpp 72) + (** * Interface of calls to Coq by CoqIde *) open Util @@ -135,6 +138,14 @@ let rec to_pp xpp = let open Pp in | x -> raise (Marshal_error("*ppdoc",PCData x)) ) xpp +let of_richpp x = Element ("richpp", [], [x]) + +(* Run-time Selectable *) +let of_pp (pp : Pp.std_ppcmds) = + match !msg_format with + | Richpp margin -> of_richpp (Richpp.richpp_of_pp margin pp) + | Ppcmds -> of_pp pp + let of_value f = function | Good x -> Element ("value", ["val", "good"], [f x]) | Fail (id,loc, msg) -> @@ -669,6 +680,9 @@ let of_answer : type a. a call -> a value -> xml = function | PrintAst _ -> of_value (of_value_type print_ast_rty_t ) | Annotate _ -> of_value (of_value_type annotate_rty_t ) +let of_answer msg_fmt = + msg_format := msg_fmt; of_answer + 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 ) @@ -902,6 +916,9 @@ let of_feedback msg = let route = string_of_int msg.route in Element ("feedback", obj @ ["route",route], [id;content]) +let of_feedback msg_fmt = + msg_format := msg_fmt; of_feedback + let to_feedback xml = match xml with | Element ("feedback", ["object","edit";"route",route], [id;content]) -> { id = Edit(to_edit_id id); diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli index 43a65dfa85..9cefab517f 100644 --- a/ide/xmlprotocol.mli +++ b/ide/xmlprotocol.mli @@ -40,12 +40,17 @@ val abstract_eval_call : handler -> 'a call -> 'a value val protocol_version : string +(** By default, we still output messages in Richpp so we are + compatible with 8.6, however, 8.7 aware clients will want to + set this to Ppcmds *) +type msg_format = Richpp of int | Ppcmds + (** * XML data marshalling *) val of_call : 'a call -> xml val to_call : xml -> unknown_call -val of_answer : 'a call -> 'a value -> xml +val of_answer : msg_format -> 'a call -> 'a value -> xml val to_answer : 'a call -> xml -> 'a value (* Prints the documentation of this module *) @@ -58,10 +63,7 @@ val pr_value : 'a value -> string val pr_full_value : 'a call -> 'a value -> string (** * Serializaiton of feedback *) -val of_feedback : Feedback.feedback -> xml +val of_feedback : msg_format -> Feedback.feedback -> xml val to_feedback : xml -> Feedback.feedback -val is_feedback : xml -> bool - -val of_message : Feedback.level -> Loc.t option -> Pp.std_ppcmds -> xml -(* val to_message : xml -> Feedback.message *) +val is_feedback : xml -> bool diff --git a/stm/stm.mllib b/stm/stm.mllib index 4b254e8113..72b5380162 100644 --- a/stm/stm.mllib +++ b/stm/stm.mllib @@ -5,6 +5,7 @@ TQueue WorkerPool Vernac_classifier CoqworkmgrApi +WorkerLoop AsyncTaskQueue Stm ProofBlockDelimiter diff --git a/stm/workerLoop.ml b/stm/workerLoop.ml index 56fcf8537f..50b42512cb 100644 --- a/stm/workerLoop.ml +++ b/stm/workerLoop.ml @@ -6,9 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -let rec parse args = args +let rec parse = function + | "--xml_format=Ppcmds" :: rest -> parse rest + | x :: rest -> x :: parse rest + | [] -> [] let loop init args = + let args = parse args in Flags.make_silent true; init (); CoqworkmgrApi.init !Flags.async_proofs_worker_priority; diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index 7a891239bd..932097607b 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -296,11 +296,12 @@ let main = Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> prerr_endline "Broken Pipe (coqtop died ?)"; exit 1)); + let def_args = ["--xml_format=Ppcmds"; "-ideslave"] in let coqtop_name, coqtop_args, input_file = match Sys.argv with - | [| _; f |] -> "coqtop",[|"-ideslave"|], f + | [| _; f |] -> "coqtop", Array.of_list def_args, f | [| _; f; ct |] -> let ct = Str.split (Str.regexp " ") ct in - List.hd ct, Array.of_list ("-ideslave" :: List.tl ct), f + List.hd ct, Array.of_list (def_args @ List.tl ct), f | _ -> usage () in let inc = if input_file = "-" then stdin else open_in input_file in let coq = -- cgit v1.2.3 From 00b1ceb18db39334a357784a114e45a9012cf594 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 6 Feb 2017 04:52:43 +0100 Subject: [extraction] Flush formatters at end of output. Previous implementations of `Pp` flushed on newline, however, depending on the formatter this may not be always the case. We now alwayas flush the formatters before closing the file as this is the intended behavior. --- plugins/extraction/extract_env.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index ee623c5ca0..2b12462ad5 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -519,8 +519,10 @@ let print_structure_to_file (fn,si,mo) dry struc = set_phase Impl; pp_with ft (d.preamble mo comment opened unsafe_needs); pp_with ft (d.pp_struct struc); + Format.pp_print_flush ft (); Option.iter close_out cout; with reraise -> + Format.pp_print_flush ft (); Option.iter close_out cout; raise reraise end; if not dry then Option.iter info_file fn; @@ -533,8 +535,10 @@ let print_structure_to_file (fn,si,mo) dry struc = set_phase Intf; pp_with ft (d.sig_preamble mo comment opened unsafe_needs); pp_with ft (d.pp_sig (signature_of_structure struc)); + Format.pp_print_flush ft (); close_out cout; with reraise -> + Format.pp_print_flush ft (); close_out cout; raise reraise end; info_file si) -- cgit v1.2.3 From 66a245d8055923f8807ae42ed938c1d992051749 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 9 Feb 2017 03:12:18 +0100 Subject: [pp] Fix bug in richpp Format use. Format requires a top-level box to be present, this is similar to the fix done in `Pp.string_of_ppcmds`. --- ide/richpp.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ide/richpp.ml b/ide/richpp.ml index ecf1f40211..522a3e0b31 100644 --- a/ide/richpp.ml +++ b/ide/richpp.ml @@ -104,9 +104,11 @@ let rich_pp width ppcmds = (** The whole output must be a valid document. To that end, we nest the document inside tags. *) + pp_open_box ft 0; pp_open_tag ft "pp"; Pp.(pp_with ft ppcmds); pp_close_tag ft (); + pp_close_box ft (); (** Get the resulting XML tree. *) let () = pp_print_flush ft () in -- cgit v1.2.3 From fb04bc5cae0d648c379b9eb44f8b515f8e15b854 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 17 Mar 2017 18:12:03 +0100 Subject: [pp] Hide the internal representation of `std_ppcmds`. Following a suggestion by @ppedrot in #390, we require `Pp` clients to be aware that they are using a "view" on the `std_ppcmds` type. This is not extremely useful as people caring about the documents will indeed have to follow changes in the view, but it costs little to play on the safe side here for now. We also introduce a more standard notation, `Pp.t` for the main type. --- ide/coqOps.ml | 2 +- ide/xmlprotocol.ml | 3 ++- lib/pp.ml | 16 ++++++++++++---- lib/pp.mli | 34 +++++++++++++++++++++------------- 4 files changed, 36 insertions(+), 19 deletions(-) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 1b4c5d3be0..4a1d688f51 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -166,7 +166,7 @@ let flags_to_color f = else `NAME Preferences.processed_color#get (* Move to utils? *) -let rec validate (s : Pp.std_ppcmds) = match s with +let rec validate (s : Pp.std_ppcmds) = match Pp.repr s with | Pp.Ppcmd_empty | Pp.Ppcmd_print_break _ | Pp.Ppcmd_force_newline -> true diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index b4f2ad0bef..5f80d68974 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -110,7 +110,7 @@ let to_box = let open Pp in | x -> raise (Marshal_error("*ppbox",PCData x)) ) -let rec of_pp (pp : Pp.std_ppcmds) = let open Pp in match pp with +let rec of_pp (pp : Pp.std_ppcmds) = let open Pp in match Pp.repr pp with | Ppcmd_empty -> constructor "ppdoc" "emtpy" [] | Ppcmd_string s -> constructor "ppdoc" "string" [of_string s] | Ppcmd_glue sl -> constructor "ppdoc" "glue" [of_list of_pp sl] @@ -123,6 +123,7 @@ let rec of_pp (pp : Pp.std_ppcmds) = let open Pp in match pp with let rec to_pp xpp = let open Pp in + Pp.unrepr @@ do_match "ppdoc" (fun s args -> match s with | "empty" -> Ppcmd_empty | "string" -> Ppcmd_string (to_string (singleton args)) diff --git a/lib/pp.ml b/lib/pp.ml index 80c599274a..9f33756dfe 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -25,17 +25,25 @@ type block_type = | Pp_hvbox of int | Pp_hovbox of int -type std_ppcmds = +type doc_view = | Ppcmd_empty | Ppcmd_string of string - | Ppcmd_glue of std_ppcmds list - | Ppcmd_box of block_type * std_ppcmds - | Ppcmd_tag of pp_tag * std_ppcmds + | Ppcmd_glue of doc_view list + | Ppcmd_box of block_type * doc_view + | Ppcmd_tag of pp_tag * doc_view (* Are those redundant? *) | Ppcmd_print_break of int * int | Ppcmd_force_newline | Ppcmd_comment of string list +(* Following discussion on #390, we play on the safe side and make the + internal representation opaque here. *) +type t = doc_view +type std_ppcmds = t + +let repr x = x +let unrepr x = x + (* Compute length of an UTF-8 encoded string Rem 1 : utf8_length <= String.length (equal if pure ascii) Rem 2 : if used for an iso8859_1 encoded string, the result is diff --git a/lib/pp.mli b/lib/pp.mli index 4b7ac5c1ae..802ffe8e7a 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -10,17 +10,17 @@ (** Pretty printing guidelines ******************************************) (* *) -(* std_ppcmds is the main pretty printing datatype in he Coq. Documents *) -(* are composed laying out boxes, and users can add arbitrary metadata *) -(* that backends are free to interpret. *) +(* `Pp.t` or `Pp.std_ppcmds` is the main pretty printing document type *) +(* in the Coq system. Documents are composed laying out boxes, and *) +(* users can add arbitrary tag metadata that backends are free *) (* *) -(* The datatype is public to allow serialization or advanced uses, *) -(* regular users are _strongly_ encouraged to use the top-level *) -(* functions to manipulate the type. *) +(* The datatype has a public view to allow serialization or advanced *) +(* uses, however regular users are _strongly_ warned againt its use, *) +(* they should instead rely on the available functions below. *) (* *) -(* Box order and number is indeed an important factor. Users should try *) -(* to create a proper amount of boxes. Also, the ++ operator provides *) -(* "efficient" concatenation, but directly using a list is preferred. *) +(* Box order and number is indeed an important factor. Try to create *) +(* a proper amount of boxes. The `++` operator provides "efficient" *) +(* concatenation, but using the list constructors is usually preferred. *) (* *) (* That is to say, this: *) (* *) @@ -35,23 +35,31 @@ (* XXX: Improve and add attributes *) type pp_tag = string +(* Following discussion on #390, we play on the safe side and make the + internal representation opaque here. *) +type t +type std_ppcmds = t + type block_type = | Pp_hbox of int | Pp_vbox of int | Pp_hvbox of int | Pp_hovbox of int -type std_ppcmds = +type doc_view = | Ppcmd_empty | Ppcmd_string of string - | Ppcmd_glue of std_ppcmds list - | Ppcmd_box of block_type * std_ppcmds - | Ppcmd_tag of pp_tag * std_ppcmds + | Ppcmd_glue of t list + | Ppcmd_box of block_type * t + | Ppcmd_tag of pp_tag * t (* Are those redundant? *) | Ppcmd_print_break of int * int | Ppcmd_force_newline | Ppcmd_comment of string list +val repr : std_ppcmds -> doc_view +val unrepr : doc_view -> std_ppcmds + (** {6 Formatting commands} *) val str : string -> std_ppcmds -- cgit v1.2.3 From aa9e94275ccac92311a6bdac563b61a6c7876cec Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 17 Mar 2017 20:27:44 +0100 Subject: [ide protocol] Add comment about leftover parameter. We try to address @silene 's concerns, which indeed are legitimate. --- ide/ide_slave.ml | 27 +++++++++++++++++++++++++++ ide/interface.mli | 16 ++++++++++++---- 2 files changed, 39 insertions(+), 4 deletions(-) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index db450b4bc8..2ec79dc585 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -97,6 +97,15 @@ let coqide_cmd_checks (loc,ast) = let add ((s,eid),(sid,verbose)) = let newid, rc = Stm.add ~ontop:sid verbose ~check:coqide_cmd_checks eid s in let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in + (* TODO: the "" parameter is a leftover of the times the protocol + * used to include stderr/stdout output. + * + * Currently, we force all the output meant for the to go via the + * feedback mechanism, and we don't manipulate stderr/stdout, which + * are left to the client's discrection. The parameter is still there + * as not to break the core protocol for this minor change, but it should + * be removed in the next version of the protocol. + *) newid, (rc, "") let edit_at id = @@ -104,6 +113,15 @@ let edit_at id = | `NewTip -> CSig.Inl () | `Focus { Stm.start; stop; tip} -> CSig.Inr (start, (stop, tip)) +(* TODO: the "" parameter is a leftover of the times the protocol + * used to include stderr/stdout output. + * + * Currently, we force all the output meant for the to go via the + * feedback mechanism, and we don't manipulate stderr/stdout, which + * are left to the client's discrection. The parameter is still there + * as not to break the core protocol for this minor change, but it should + * be removed in the next version of the protocol. + *) let query (s,id) = Stm.query ~at:id s; "" let annotate phrase = @@ -379,6 +397,15 @@ let interp ((_raw, verbose), s) = | Some ast -> ast) () in Stm.interp verbose (vernac_parse s); + (* TODO: the "" parameter is a leftover of the times the protocol + * used to include stderr/stdout output. + * + * Currently, we force all the output meant for the to go via the + * feedback mechanism, and we don't manipulate stderr/stdout, which + * are left to the client's discrection. The parameter is still there + * as not to break the core protocol for this minor change, but it should + * be removed in the next version of the protocol. + *) Stm.get_current_state (), CSig.Inl "" (** When receiving the Quit call, we don't directly do an [exit 0], diff --git a/ide/interface.mli b/ide/interface.mli index 43446f3918..9ed6062588 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -127,9 +127,13 @@ type ('a, 'b) union = ('a, 'b) Util.union (** [add ((s,eid),(sid,v))] adds the phrase [s] with edit id [eid] on top of the current edit position (that is asserted to be [sid]) verbosely if [v] is true. The response [(id,(rc,s)] is the new state - [id] assigned to the phrase, some output [s]. [rc] is [Inl] if the new + [id] assigned to the phrase. [rc] is [Inl] if the new state id is the tip of the edit point, or [Inr tip] if the new phrase - closes a focus and [tip] is the new edit tip *) + closes a focus and [tip] is the new edit tip + + [s] used to contain Coq's console output and has been deprecated + in favor of sending feedback, it will be removed in a future + version of the protocol. *) type add_sty = (string * edit_id) * (state_id * verbose) type add_rty = state_id * ((unit, state_id) union * string) @@ -142,8 +146,12 @@ type add_rty = state_id * ((unit, state_id) union * string) type edit_at_sty = state_id type edit_at_rty = (unit, state_id * (state_id * state_id)) union -(** [query s id] executes [s] at state [id] and does not record any state - change but for the printings that are sent in response *) +(** [query s id] executes [s] at state [id]. + + query used to reply with the contents of Coq's console output, and + has been deprecated in favor of sending the query answers as + feedback. It will be removed in a future version of the protocol. +*) type query_sty = string * state_id type query_rty = string -- cgit v1.2.3 From 09c856a3bcb7369244202ed94db247f7abe84dad Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 21 Mar 2017 14:29:56 +0100 Subject: Do not typecheck twice the type of opaque constants. I believe an unwanted shadowing was introduced by a4043608f704f0. --- kernel/term_typing.ml | 41 +++++++++++++++++------------------------ 1 file changed, 17 insertions(+), 24 deletions(-) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 749b5dbafa..2d55803475 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -22,24 +22,6 @@ open Entries open Typeops open Fast_typeops -let constrain_type env j poly subst = function - | `None -> - if not poly then (* Old-style polymorphism *) - make_polymorphic_if_constant_for_ind env j - else RegularArity (Vars.subst_univs_level_constr subst j.uj_type) - | `Some t -> - let tj = infer_type env t in - let _ = judge_of_cast env j DEFAULTcast tj in - assert (eq_constr t tj.utj_val); - RegularArity (Vars.subst_univs_level_constr subst t) - | `SomeWJ (t, tj) -> - let tj = infer_type env t in - let _ = judge_of_cast env j DEFAULTcast tj in - assert (eq_constr t tj.utj_val); - RegularArity (Vars.subst_univs_level_constr subst t) - -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), [] @@ -193,15 +175,16 @@ let infer_declaration ~trust env kn dcl = 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 env = push_context_set uctx env in let j = - let body,env',ectx = skip_trusted_seff valid_signatures body env' in - let j = infer env' body in + let body,env,ectx = skip_trusted_seff valid_signatures body env in + let j = infer env body 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 + let _ = judge_of_cast env j DEFAULTcast tyj in + assert (eq_constr typ tyj.utj_val); + let _typ = RegularArity (Vars.subst_univs_level_constr subst typ) in feedback_completion_typecheck feedback_id; j.uj_val, uctx) in let def = OpaqueDef (Opaqueproof.create proofterm) in @@ -221,7 +204,17 @@ let infer_declaration ~trust env kn dcl = 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 typ = match typ with + | None -> + if not c.const_entry_polymorphic then (* Old-style polymorphism *) + make_polymorphic_if_constant_for_ind env j + else RegularArity (Vars.subst_univs_level_constr usubst j.uj_type) + | Some t -> + let tj = infer_type env t in + let _ = judge_of_cast env j DEFAULTcast tj in + assert (eq_constr t tj.utj_val); + RegularArity (Vars.subst_univs_level_constr usubst t) + in let def = hcons_constr (Vars.subst_univs_level_constr usubst j.uj_val) in let def = if opaque then OpaqueDef (Opaqueproof.create (Future.from_val (def, Univ.ContextSet.empty))) -- cgit v1.2.3 From 6d416ea54fd26987188858bcf80461247b002a09 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 21 Mar 2017 14:30:58 +0100 Subject: Add a few comments in term_typing.ml. --- kernel/term_typing.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 2d55803475..b7597ba7fb 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -164,6 +164,10 @@ let infer_declaration ~trust env kn dcl = let t = hcons_constr (Vars.subst_univs_level_constr usubst c) in Undef nl, RegularArity t, None, poly, univs, false, ctx + (** Definition [c] is opaque (Qed), non polymorphic and with a specified type, + so we delay the typing and hash consing of its body. + Remark: when the universe quantification is given explicitly, we could + delay even in the polymorphic case. *) | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true; const_entry_polymorphic = false} as c) -> @@ -192,6 +196,7 @@ let infer_declaration ~trust env kn dcl = c.const_entry_universes, c.const_entry_inline_code, c.const_entry_secctx + (** Other definitions have to be processed immediately. *) | DefinitionEntry c -> let { const_entry_type = typ; const_entry_opaque = opaque } = c in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in -- cgit v1.2.3 From 3602b909afc6eac0f150c9961a04b0bf50d8bbf0 Mon Sep 17 00:00:00 2001 From: Tej Chajed Date: Fri, 10 Mar 2017 11:05:27 -0500 Subject: funind: Ignore missing info for current function Fixes [Coq bug #5372](https://coq.inria.fr/bugs/show_bug.cgi?id=5372) "Anomaly: Not a valid information when defining mutual fixpoints that are not mutual with Function". --- plugins/funind/functional_principles_proofs.ml | 3 +-- test-suite/bugs/closed/5372.v | 7 +++++++ 2 files changed, 8 insertions(+), 2 deletions(-) create mode 100644 test-suite/bugs/closed/5372.v diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index b0ffc775b5..0bbe4bb4cb 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1215,7 +1215,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let mk_fixes : tactic = let pre_info,infos = list_chop fun_num infos in match pre_info,infos with - | [],[] -> tclIDTAC + | _,[] -> tclIDTAC | _, this_fix_info::others_infos -> let other_fix_infos = List.map @@ -1231,7 +1231,6 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam else Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) other_fix_infos 0) - | _ -> anomaly (Pp.str "Not a valid information") in let first_tac : tactic = (* every operations until fix creations *) tclTHENSEQ diff --git a/test-suite/bugs/closed/5372.v b/test-suite/bugs/closed/5372.v new file mode 100644 index 0000000000..2dc78d4c7f --- /dev/null +++ b/test-suite/bugs/closed/5372.v @@ -0,0 +1,7 @@ +(* coq bug 5372: https://coq.inria.fr/bugs/show_bug.cgi?id=5372 *) +Function odd (n:nat) := + match n with + | 0 => false + | S n => true + end +with even (n:nat) := false. -- cgit v1.2.3 From d2061bd8cd2d809d6e5a849dd150e9e0d74331fc Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 16 Dec 2016 17:23:33 +0100 Subject: Remove duplicate lemmas. --- plugins/micromega/RMicromega.v | 315 +++---------------------------------- plugins/micromega/coq_micromega.ml | 3 +- 2 files changed, 26 insertions(+), 292 deletions(-) diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 2352d78d63..30e475b710 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -18,7 +18,7 @@ Require Import Refl. Require Import Raxioms RIneq Rpow_def DiscrR. Require Import QArith. Require Import Qfield. - +Require Import Qreals. Require Setoid. (*Declare ML Module "micromega_plugin".*) @@ -38,15 +38,8 @@ Proof. exact Rplus_opp_r. Qed. -Add Ring Rring : Rsrt. Open Scope R_scope. -Lemma Rmult_neutral : forall x:R , 0 * x = 0. -Proof. - intro ; ring. -Qed. - - Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt. Proof. constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)). @@ -59,142 +52,41 @@ Proof. apply (Rlt_irrefl m) ; auto. apply Rnot_le_lt. auto with real. destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto. - intros. - rewrite <- (Rmult_neutral m). - apply (Rmult_lt_compat_r) ; auto. -Qed. - -Definition IQR := fun x : Q => (IZR (Qnum x) * / IZR (' Qden x))%R. - - -Lemma Rinv_elim : forall x y z, - y <> 0 -> (z * y = x <-> x * / y = z). -Proof. - intros. - split ; intros. - subst. - rewrite Rmult_assoc. - rewrite Rinv_r; auto. - ring. - subst. - rewrite Rmult_assoc. - rewrite (Rmult_comm (/ y)). - rewrite Rinv_r ; auto. - ring. -Qed. - -Ltac INR_nat_of_P := - match goal with - | H : context[INR (Pos.to_nat ?X)] |- _ => - revert H ; - let HH := fresh in - assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) - | |- context[INR (Pos.to_nat ?X)] => - let HH := fresh in - assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) - end. - -Ltac add_eq expr val := set (temp := expr) ; - generalize (eq_refl temp) ; - unfold temp at 1 ; generalize temp ; intro val ; clear temp. - -Ltac Rinv_elim := - match goal with - | |- context[?x * / ?y] => - let z := fresh "v" in - add_eq (x * / y) z ; - let H := fresh in intro H ; rewrite <- Rinv_elim in H - end. - -Lemma Rlt_neq : forall r , 0 < r -> r <> 0. -Proof. - red. intros. - subst. - apply (Rlt_irrefl 0 H). + now apply Rmult_lt_0_compat. Qed. +Notation IQR := Q2R (only parsing). Lemma Rinv_1 : forall x, x * / 1 = x. Proof. intro. - Rinv_elim. - subst ; ring. - apply R1_neq_R0. + rewrite Rinv_1. + apply Rmult_1_r. Qed. -Lemma Qeq_true : forall x y, - Qeq_bool x y = true -> - IQR x = IQR y. +Lemma Qeq_true : forall x y, Qeq_bool x y = true -> IQR x = IQR y. Proof. - unfold IQR. - simpl. - intros. - apply Qeq_bool_eq in H. - unfold Qeq in H. - assert (IZR (Qnum x * ' Qden y) = IZR (Qnum y * ' Qden x))%Z. - rewrite H. reflexivity. - repeat rewrite mult_IZR in H0. - simpl in H0. - revert H0. - repeat INR_nat_of_P. intros. - apply Rinv_elim in H2 ; [| apply Rlt_neq ; auto]. - rewrite <- H2. - field. - split ; apply Rlt_neq ; auto. + now apply Qeq_eqR, Qeq_bool_eq. Qed. Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y. Proof. intros. - apply Qeq_bool_neq in H. - intro. apply H. clear H. - unfold Qeq,IQR in *. - simpl in *. - revert H0. - repeat Rinv_elim. - intros. - subst. - assert (IZR (Qnum x * ' Qden y)%Z = IZR (Qnum y * ' Qden x)%Z). - repeat rewrite mult_IZR. - simpl. - rewrite <- H0. rewrite <- H. - ring. - apply eq_IZR ; auto. - INR_nat_of_P; intros; apply Rlt_neq ; auto. - INR_nat_of_P; intros ; apply Rlt_neq ; auto. + apply Qeq_bool_neq in H. + contradict H. + now apply eqR_Qeq. Qed. - - Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y. Proof. intros. - apply Qle_bool_imp_le in H. - unfold Qle in H. - unfold IQR. - simpl in *. - apply IZR_le in H. - repeat rewrite mult_IZR in H. - simpl in H. - repeat INR_nat_of_P; intros. - assert (Hr := Rlt_neq r H). - assert (Hr0 := Rlt_neq r0 H0). - replace (IZR (Qnum x) * / r) with ((IZR (Qnum x) * r0) * (/r * /r0)). - replace (IZR (Qnum y) * / r0) with ((IZR (Qnum y) * r) * (/r * /r0)). - apply Rmult_le_compat_r ; auto. - apply Rmult_le_pos. - unfold Rle. left. apply Rinv_0_lt_compat ; auto. - unfold Rle. left. apply Rinv_0_lt_compat ; auto. - field ; intuition. - field ; intuition. + now apply Qle_Rle, Qle_bool_imp_le. Qed. - - Lemma IQR_0 : IQR 0 = 0. Proof. - compute. apply Rinv_1. + apply Rmult_0_l. Qed. Lemma IQR_1 : IQR 1 = 1. @@ -202,160 +94,6 @@ Proof. compute. apply Rinv_1. Qed. -Lemma IQR_plus : forall x y, IQR (x + y) = IQR x + IQR y. -Proof. - intros. - unfold IQR. - simpl in *. - rewrite plus_IZR in *. - rewrite mult_IZR in *. - simpl. - rewrite Pos2Nat.inj_mul. - rewrite mult_INR. - rewrite mult_IZR. - simpl. - repeat INR_nat_of_P. - intros. field. - split ; apply Rlt_neq ; auto. -Qed. - -Lemma IQR_opp : forall x, IQR (- x) = - IQR x. -Proof. - intros. - unfold IQR. - simpl. - rewrite opp_IZR. - ring. -Qed. - -Lemma IQR_minus : forall x y, IQR (x - y) = IQR x - IQR y. -Proof. - intros. - unfold Qminus. - rewrite IQR_plus. - rewrite IQR_opp. - ring. -Qed. - - -Lemma IQR_mult : forall x y, IQR (x * y) = IQR x * IQR y. -Proof. - unfold IQR ; intros. - simpl. - repeat rewrite mult_IZR. - rewrite Pos2Nat.inj_mul. - rewrite mult_INR. - repeat INR_nat_of_P. - intros. field ; split ; apply Rlt_neq ; auto. -Qed. - -Lemma IQR_inv_lt : forall x, (0 < x)%Q -> - IQR (/ x) = / IQR x. -Proof. - unfold IQR ; simpl. - intros. - unfold Qlt in H. - revert H. - simpl. - intros. - unfold Qinv. - destruct x. - destruct Qnum ; simpl in *. - exfalso. auto with zarith. - clear H. - repeat INR_nat_of_P. - intros. - assert (HH := Rlt_neq _ H). - assert (HH0 := Rlt_neq _ H0). - rewrite Rinv_mult_distr ; auto. - rewrite Rinv_involutive ; auto. - ring. - apply Rinv_0_lt_compat in H0. - apply Rlt_neq ; auto. - simpl in H. - exfalso. - rewrite Pos.mul_comm in H. - compute in H. - discriminate. -Qed. - -Lemma Qinv_opp : forall x, (- (/ x) = / ( -x))%Q. -Proof. - destruct x ; destruct Qnum ; reflexivity. -Qed. - -Lemma Qopp_involutive_strong : forall x, (- - x = x)%Q. -Proof. - intros. - destruct x. - unfold Qopp. - simpl. - rewrite Z.opp_involutive. - reflexivity. -Qed. - -Lemma Ropp_0 : forall r , - r = 0 -> r = 0. -Proof. - intros. - rewrite <- (Ropp_involutive r). - apply Ropp_eq_0_compat ; auto. -Qed. - -Lemma IQR_x_0 : forall x, IQR x = 0 -> x == 0%Q. -Proof. - destruct x ; simpl. - unfold IQR. - simpl. - INR_nat_of_P. - intros. - apply Rmult_integral in H0. - destruct H0. - apply eq_IZR_R0 in H0. - subst. - reflexivity. - exfalso. - apply Rinv_0_lt_compat in H. - rewrite <- H0 in H. - apply Rlt_irrefl in H. auto. -Qed. - - -Lemma IQR_inv_gt : forall x, (0 > x)%Q -> - IQR (/ x) = / IQR x. -Proof. - intros. - rewrite <- (Qopp_involutive_strong x). - rewrite <- Qinv_opp. - rewrite IQR_opp. - rewrite IQR_inv_lt. - repeat rewrite IQR_opp. - rewrite Ropp_inv_permute. - auto. - intro. - apply Ropp_0 in H0. - apply IQR_x_0 in H0. - rewrite H0 in H. - compute in H. discriminate. - unfold Qlt in *. - destruct x ; simpl in *. - auto with zarith. -Qed. - -Lemma IQR_inv : forall x, ~ x == 0 -> - IQR (/ x) = / IQR x. -Proof. - intros. - assert ( 0 > x \/ 0 < x)%Q. - destruct x ; unfold Qlt, Qeq in * ; simpl in *. - rewrite Z.mul_1_r in *. - destruct Qnum ; simpl in * ; intuition auto. - right. reflexivity. - left ; reflexivity. - destruct H0. - apply IQR_inv_gt ; auto. - apply IQR_inv_lt ; auto. -Qed. - Lemma IQR_inv_ext : forall x, IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x). Proof. @@ -366,18 +104,13 @@ Proof. destruct x ; simpl. unfold Qeq in H. simpl in H. - replace Qnum with 0%Z. - compute. rewrite Rinv_1. - reflexivity. - rewrite <- H. ring. + rewrite Zmult_1_r in H. + rewrite H. + apply Rmult_0_l. intros. - apply IQR_inv. - intro. - rewrite <- Qeq_bool_iff in H0. - congruence. + now apply Q2R_inv, Qeq_bool_neq. Qed. - Notation to_nat := N.to_nat. Lemma QSORaddon : @@ -391,10 +124,10 @@ Proof. constructor ; intros ; try reflexivity. apply IQR_0. apply IQR_1. - apply IQR_plus. - apply IQR_minus. - apply IQR_mult. - apply IQR_opp. + apply Q2R_plus. + apply Q2R_minus. + apply Q2R_mult. + apply Q2R_opp. apply Qeq_true ; auto. apply R_power_theory. apply Qeq_false. @@ -453,13 +186,13 @@ Proof. apply IQR_1. reflexivity. unfold IQR. simpl. rewrite Rinv_1. reflexivity. - apply IQR_plus. - apply IQR_minus. - apply IQR_mult. + apply Q2R_plus. + apply Q2R_minus. + apply Q2R_mult. rewrite <- IHc. apply IQR_inv_ext. rewrite <- IHc. - apply IQR_opp. + apply Q2R_opp. Qed. Require Import EnvRing. diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 97f29df823..6051cb3d3c 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -364,6 +364,7 @@ struct [["Coq";"Reals" ; "Rdefinitions"]; ["Coq";"Reals" ; "Rpow_def"] ; ["Coq";"Reals" ; "Raxioms"] ; + ["Coq";"QArith"; "Qreals"] ; ] let z_modules = [["Coq";"ZArith";"BinInt"]] @@ -479,7 +480,7 @@ struct let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") let coq_IZR = lazy (r_constant "IZR") - let coq_IQR = lazy (constant "IQR") + let coq_IQR = lazy (r_constant "Q2R") let coq_PEX = lazy (constant "PEX" ) -- cgit v1.2.3 From 46d79ebd74876f34242c8c5d9ab3dcedbadba7cc Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sun, 5 Mar 2017 19:58:44 +0100 Subject: Simplify some proofs using ring and field. --- theories/Reals/RIneq.v | 48 +++--------- theories/Reals/R_sqr.v | 53 +------------ theories/Reals/R_sqrt.v | 117 ++++------------------------ theories/Reals/Ranalysis4.v | 11 +-- theories/Reals/Rderiv.v | 12 +-- theories/Reals/Rlimit.v | 3 +- theories/Reals/Rpower.v | 19 +---- theories/Reals/Rtrigo1.v | 38 ++------- theories/Reals/Rtrigo_calc.v | 181 ++++++++++++------------------------------- theories/Reals/Rtrigo_reg.v | 11 +-- 10 files changed, 99 insertions(+), 394 deletions(-) diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 379fee6f49..07bcd98369 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -2017,42 +2017,18 @@ Qed. Lemma le_epsilon : forall r1 r2, (forall eps:R, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2. Proof. - intros x y; intros; elim (Rtotal_order x y); intro. - left; assumption. - elim H0; intro. - right; assumption. - clear H0; generalize (Rgt_minus x y H1); intro H2; change (0 < x - y) in H2. - cut (0 < 2). - intro. - generalize (Rmult_lt_0_compat (x - y) (/ 2) H2 (Rinv_0_lt_compat 2 H0)); - intro H3; generalize (H ((x - y) * / 2) H3); - replace (y + (x - y) * / 2) with ((y + x) * / 2). - intro H4; - generalize (Rmult_le_compat_l 2 x ((y + x) * / 2) (Rlt_le 0 2 H0) H4); - rewrite <- (Rmult_comm ((y + x) * / 2)); rewrite Rmult_assoc; - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; replace (2 * x) with (x + x). - rewrite (Rplus_comm y); intro H5; apply Rplus_le_reg_l with x; assumption. - ring. - replace 2 with (INR 2); [ apply not_0_INR; discriminate | reflexivity ]. - pattern y at 2; replace y with (y / 2 + y / 2). - unfold Rminus, Rdiv. - repeat rewrite Rmult_plus_distr_r. - ring. - cut (forall z:R, 2 * z = z + z). - intro. - rewrite <- (H4 (y / 2)). - unfold Rdiv. - rewrite <- Rmult_assoc; apply Rinv_r_simpl_m. - replace 2 with (INR 2). - apply not_0_INR. - discriminate. - unfold INR; reflexivity. - intro; ring. - cut (0%nat <> 2%nat); - [ intro H0; generalize (lt_0_INR 2 (neq_O_lt 2 H0)); unfold INR; - intro; assumption - | discriminate ]. + intros x y H. + destruct (Rle_or_lt x y) as [H1|H1]. + exact H1. + apply Rplus_le_reg_r with x. + replace (y + x) with (2 * (y + (x - y) * / 2)) by field. + replace (x + x) with (2 * x) by ring. + apply Rmult_le_compat_l. + now apply (IZR_le 0 2). + apply H. + apply Rmult_lt_0_compat. + now apply Rgt_minus. + apply Rinv_0_lt_compat, Rlt_0_2. Qed. (**********) diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v index 445ffcb21b..a8937e36fd 100644 --- a/theories/Reals/R_sqr.v +++ b/theories/Reals/R_sqr.v @@ -296,56 +296,9 @@ Lemma canonical_Rsqr : a * Rsqr (x + b / (2 * a)) + (4 * a * c - Rsqr b) / (4 * a). Proof. intros. - rewrite Rsqr_plus. - repeat rewrite Rmult_plus_distr_l. - repeat rewrite Rplus_assoc. - apply Rplus_eq_compat_l. - unfold Rdiv, Rminus. - replace (2 * 1 + 2 * 1) with 4; [ idtac | ring ]. - rewrite (Rmult_plus_distr_r (4 * a * c) (- Rsqr b) (/ (4 * a))). - rewrite Rsqr_mult. - repeat rewrite Rinv_mult_distr. - repeat rewrite (Rmult_comm a). - repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite (Rmult_comm (/ 2)). - rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite (Rmult_comm a). - repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - repeat rewrite Rplus_assoc. - rewrite (Rplus_comm (Rsqr b * (Rsqr (/ a * / 2) * a))). - repeat rewrite Rplus_assoc. - rewrite (Rmult_comm x). - apply Rplus_eq_compat_l. - rewrite (Rmult_comm (/ a)). - unfold Rsqr; repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - ring. - apply (cond_nonzero a). - discrR. - apply (cond_nonzero a). - discrR. - discrR. - apply (cond_nonzero a). - discrR. - discrR. - discrR. - apply (cond_nonzero a). - discrR. - apply (cond_nonzero a). + unfold Rsqr. + field. + apply a. Qed. Lemma Rsqr_eq : forall x y:R, Rsqr x = Rsqr y -> x = y \/ x = - y. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index a6b1a26e03..5c975c3f54 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -359,107 +359,22 @@ Lemma Rsqr_sol_eq_0_1 : x = sol_x1 a b c \/ x = sol_x2 a b c -> a * Rsqr x + b * x + c = 0. Proof. intros; elim H0; intro. - unfold sol_x1 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv; - repeat rewrite Rsqr_mult; rewrite Rsqr_plus; rewrite <- Rsqr_neg; - rewrite Rsqr_sqrt. - rewrite Rsqr_inv. - unfold Rsqr; repeat rewrite Rinv_mult_distr. - repeat rewrite Rmult_assoc; rewrite (Rmult_comm a). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite Rmult_plus_distr_r. - repeat rewrite Rmult_assoc. - pattern 2 at 2; rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite - (Rmult_plus_distr_r (- b) (sqrt (b * b - 2 * (2 * (a * c)))) (/ 2 * / a)) - . - rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc. - replace - (- b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) + - (b * (- b * (/ 2 * / a)) + - (b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) + c))) with - (b * (- b * (/ 2 * / a)) + c). - unfold Rminus; repeat rewrite <- Rplus_assoc. - replace (b * b + b * b) with (2 * (b * b)). - rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc. - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; repeat rewrite Rmult_assoc. - rewrite (Rmult_comm a); rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite <- Rmult_opp_opp. - ring. - apply (cond_nonzero a). - discrR. - discrR. - discrR. - ring. - ring. - discrR. - apply (cond_nonzero a). - discrR. - apply (cond_nonzero a). - apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. - apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. - apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. - assumption. - unfold sol_x2 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv; - repeat rewrite Rsqr_mult; rewrite Rsqr_minus; rewrite <- Rsqr_neg; - rewrite Rsqr_sqrt. - rewrite Rsqr_inv. - unfold Rsqr; repeat rewrite Rinv_mult_distr; - repeat rewrite Rmult_assoc. - rewrite (Rmult_comm a); repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; unfold Rminus; rewrite Rmult_plus_distr_r. - rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc; - pattern 2 at 2; rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; - rewrite - (Rmult_plus_distr_r (- b) (- sqrt (b * b + - (2 * (2 * (a * c))))) - (/ 2 * / a)). - rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc. - rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_involutive. - replace - (b * (sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) + - (b * (- b * (/ 2 * / a)) + - (b * (- sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) + c))) with - (b * (- b * (/ 2 * / a)) + c). - repeat rewrite <- Rplus_assoc; replace (b * b + b * b) with (2 * (b * b)). - rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; - rewrite <- Rinv_l_sym. - rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc. - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc. - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; repeat rewrite Rmult_assoc; rewrite (Rmult_comm a); - rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite <- Rmult_opp_opp; ring. - apply (cond_nonzero a). - discrR. - discrR. - discrR. - ring. - ring. - discrR. - apply (cond_nonzero a). - discrR. - discrR. - apply (cond_nonzero a). - apply prod_neq_R0; discrR || apply (cond_nonzero a). - apply prod_neq_R0; discrR || apply (cond_nonzero a). - apply prod_neq_R0; discrR || apply (cond_nonzero a). - assumption. + rewrite H1. + unfold sol_x1, Delta, Rsqr. + field_simplify. + rewrite <- (Rsqr_pow2 (sqrt _)), Rsqr_sqrt. + field. + apply a. + apply H. + apply a. + rewrite H1. + unfold sol_x2, Delta, Rsqr. + field_simplify. + rewrite <- (Rsqr_pow2 (sqrt _)), Rsqr_sqrt. + field. + apply a. + apply H. + apply a. Qed. Lemma Rsqr_sol_eq_0_0 : diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v index 661bc8c76b..23daedb8ba 100644 --- a/theories/Reals/Ranalysis4.v +++ b/theories/Reals/Ranalysis4.v @@ -130,15 +130,8 @@ Proof. intro; exists (mkposreal (- x) H1); intros. rewrite (Rabs_left x). rewrite (Rabs_left (x + h)). - rewrite Rplus_comm. - rewrite Ropp_plus_distr. - unfold Rminus; rewrite Ropp_involutive; rewrite Rplus_assoc; - rewrite Rplus_opp_l. - rewrite Rplus_0_r; unfold Rdiv. - rewrite Ropp_mult_distr_l_reverse. - rewrite <- Rinv_r_sym. - rewrite Ropp_involutive; rewrite Rplus_opp_l; rewrite Rabs_R0; apply H0. - apply H2. + replace ((-(x + h) - - x) / h - -1) with 0 by now field. + rewrite Rabs_R0; apply H0. destruct (Rcase_abs h) as [Hlt|Hgt]. apply Ropp_lt_cancel. rewrite Ropp_0; rewrite Ropp_plus_distr; apply Rplus_lt_0_compat. diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v index bd330ac9b9..5fb6bd2b71 100644 --- a/theories/Reals/Rderiv.v +++ b/theories/Reals/Rderiv.v @@ -296,14 +296,10 @@ Proof. intros; generalize (H0 eps H1); clear H0; intro; elim H0; clear H0; intros; elim H0; clear H0; simpl; intros; split with x; split; auto. - intros; generalize (H2 x1 H3); clear H2; intro; - rewrite Ropp_mult_distr_l_reverse in H2; - rewrite Ropp_mult_distr_l_reverse in H2; - rewrite Ropp_mult_distr_l_reverse in H2; - rewrite (let (H1, H2) := Rmult_ne (f x1) in H2) in H2; - rewrite (let (H1, H2) := Rmult_ne (f x0) in H2) in H2; - rewrite (let (H1, H2) := Rmult_ne (df x0) in H2) in H2; - assumption. + intros; generalize (H2 x1 H3); clear H2; intro. + replace (- f x1 - - f x0) with (-1 * f x1 - -1 * f x0) by ring. + replace (- df x0) with (-1 * df x0) by ring. + exact H2. Qed. (*********) diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index e424a732ac..f071407521 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -407,8 +407,7 @@ Proof. generalize (Rplus_lt_compat (R_dist (f x2) l) eps (R_dist (f x2) l') eps H H0); unfold R_dist; intros; rewrite (Rabs_minus_sym (f x2) l) in H1; - rewrite (Rmult_comm 2 eps); rewrite (Rmult_plus_distr_l eps 1 1); - elim (Rmult_ne eps); intros a b; rewrite a; clear a b; + rewrite (Rmult_comm 2 eps); replace (eps *2) with (eps + eps) by ring; generalize (R_dist_tri l l' (f x2)); unfold R_dist; intros; apply diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index b3ce6fa338..a053c349e4 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -55,25 +55,8 @@ Proof. simpl in H0. replace (/ 3) with (1 * / 1 + -1 * 1 * / 1 + -1 * (-1 * 1) * / 2 + - -1 * (-1 * (-1 * 1)) * / (2 + 1 + 1 + 1 + 1)). + -1 * (-1 * (-1 * 1)) * / (2 + 1 + 1 + 1 + 1)) by field. apply H0. - repeat rewrite Rinv_1; repeat rewrite Rmult_1_r; - rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l; - rewrite Ropp_involutive; rewrite Rplus_opp_r; rewrite Rmult_1_r; - rewrite Rplus_0_l; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 6. - rewrite Rmult_plus_distr_l; replace (2 + 1 + 1 + 1 + 1) with 6. - rewrite <- (Rmult_comm (/ 6)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym. - rewrite Rmult_1_l; replace 6 with 6. - do 2 rewrite Rmult_assoc; rewrite <- Rinv_r_sym. - rewrite Rmult_1_r; rewrite (Rmult_comm 3); rewrite <- Rmult_assoc; - rewrite <- Rinv_r_sym. - ring. - discrR. - discrR. - ring. - discrR. - ring. - discrR. apply H. unfold Un_decreasing; intros; apply Rmult_le_reg_l with (INR (fact n)). diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index 4d24186396..5f2e0d5b55 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -1260,44 +1260,22 @@ Proof. intros x y H1 H2 H3 H4; rewrite <- (cos_neg x); rewrite <- (cos_neg y); rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1); unfold INR in |- *; - replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))). - replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))). + replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))) by field. + replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))) by field. repeat rewrite cos_shift; intro H5; generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1); generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2); generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3); generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4). - replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)). - replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)). - replace (-3 * (PI / 2) + 2 * PI) with (PI / 2). - replace (-3 * (PI / 2) + PI) with (- (PI / 2)). + replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)) by ring. + replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)) by ring. + replace (-3 * (PI / 2) + 2 * PI) with (PI / 2) by field. + replace (-3 * (PI / 2) + PI) with (- (PI / 2)) by field. clear H1 H2 H3 H4; intros H1 H2 H3 H4; apply Rplus_lt_reg_l with (-3 * (PI / 2)); - replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)). - replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)). + replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)) by ring. + replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)) by ring. apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5). - unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. - unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. - pattern PI at 3 in |- *; rewrite double_var. - ring. - rewrite double; pattern PI at 3 4 in |- *; rewrite double_var. - ring. - unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. - unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. - rewrite Rmult_1_r. - rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var. - ring. - rewrite Rmult_1_r. - rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var. - ring. Qed. Lemma cos_increasing_1 : diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v index 9ba14ee734..53056cabdf 100644 --- a/theories/Reals/Rtrigo_calc.v +++ b/theories/Reals/Rtrigo_calc.v @@ -32,48 +32,22 @@ Proof. Qed. Lemma sin_cos_PI4 : sin (PI / 4) = cos (PI / 4). -Proof with trivial. - rewrite cos_sin... - replace (PI / 2 + PI / 4) with (- (PI / 4) + PI)... - rewrite neg_sin; rewrite sin_neg; ring... - cut (PI = PI / 2 + PI / 2); [ intro | apply double_var ]... - pattern PI at 2 3; rewrite H; pattern PI at 2 3; rewrite H... - assert (H0 : 2 <> 0); - [ discrR | unfold Rdiv; rewrite Rinv_mult_distr; try ring ]... +Proof. + rewrite cos_sin. + replace (PI / 2 + PI / 4) with (- (PI / 4) + PI) by field. + rewrite neg_sin, sin_neg; ring. Qed. Lemma sin_PI3_cos_PI6 : sin (PI / 3) = cos (PI / 6). -Proof with trivial. - replace (PI / 6) with (PI / 2 - PI / 3)... - rewrite cos_shift... - assert (H0 : 6 <> 0); [ discrR | idtac ]... - assert (H1 : 3 <> 0); [ discrR | idtac ]... - assert (H2 : 2 <> 0); [ discrR | idtac ]... - apply Rmult_eq_reg_l with 6... - rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)... - unfold Rdiv; repeat rewrite Rmult_assoc... - rewrite <- Rinv_l_sym... - rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym... - rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r; - repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym... - ring... +Proof. + replace (PI / 6) with (PI / 2 - PI / 3) by field. + now rewrite cos_shift. Qed. Lemma sin_PI6_cos_PI3 : cos (PI / 3) = sin (PI / 6). -Proof with trivial. - replace (PI / 6) with (PI / 2 - PI / 3)... - rewrite sin_shift... - assert (H0 : 6 <> 0); [ discrR | idtac ]... - assert (H1 : 3 <> 0); [ discrR | idtac ]... - assert (H2 : 2 <> 0); [ discrR | idtac ]... - apply Rmult_eq_reg_l with 6... - rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)... - unfold Rdiv; repeat rewrite Rmult_assoc... - rewrite <- Rinv_l_sym... - rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym... - rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r; - repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym... - ring... +Proof. + replace (PI / 6) with (PI / 2 - PI / 3) by field. + now rewrite sin_shift. Qed. Lemma PI6_RGT_0 : 0 < PI / 6. @@ -90,29 +64,20 @@ Proof. Qed. Lemma sin_PI6 : sin (PI / 6) = 1 / 2. -Proof with trivial. - assert (H : 2 <> 0); [ discrR | idtac ]... - apply Rmult_eq_reg_l with (2 * cos (PI / 6))... +Proof. + apply Rmult_eq_reg_l with (2 * cos (PI / 6)). replace (2 * cos (PI / 6) * sin (PI / 6)) with - (2 * sin (PI / 6) * cos (PI / 6))... - rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3)... - rewrite sin_PI3_cos_PI6... - unfold Rdiv; rewrite Rmult_1_l; rewrite Rmult_assoc; - pattern 2 at 2; rewrite (Rmult_comm 2); rewrite Rmult_assoc; - rewrite <- Rinv_l_sym... - rewrite Rmult_1_r... - unfold Rdiv; rewrite Rinv_mult_distr... - rewrite (Rmult_comm (/ 2)); rewrite (Rmult_comm 2); - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r... - discrR... - ring... - apply prod_neq_R0... + (2 * sin (PI / 6) * cos (PI / 6)) by ring. + rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3) by field. + rewrite sin_PI3_cos_PI6. + field. + apply prod_neq_R0. + discrR. cut (0 < cos (PI / 6)); [ intro H1; auto with real | apply cos_gt_0; [ apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0) - | apply PI6_RLT_PI2 ] ]... + | apply PI6_RLT_PI2 ] ]. Qed. Lemma sqrt2_neq_0 : sqrt 2 <> 0. @@ -188,20 +153,13 @@ Proof with trivial. apply Rinv_0_lt_compat; apply Rlt_sqrt2_0... rewrite Rsqr_div... rewrite Rsqr_1; rewrite Rsqr_sqrt... - assert (H : 2 <> 0); [ discrR | idtac ]... unfold Rsqr; pattern (cos (PI / 4)) at 1; rewrite <- sin_cos_PI4; replace (sin (PI / 4) * cos (PI / 4)) with - (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4)))... - rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2)... + (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4))) by field. + rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2) by field. rewrite sin_PI2... - apply Rmult_1_r... - unfold Rdiv; rewrite (Rmult_comm 2); rewrite Rinv_mult_distr... - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r... - unfold Rdiv; rewrite Rmult_1_l; repeat rewrite <- Rmult_assoc... - rewrite <- Rinv_l_sym... - rewrite Rmult_1_l... + field. left; prove_sup... apply sqrt2_neq_0... Qed. @@ -219,24 +177,17 @@ Proof. Qed. Lemma cos3PI4 : cos (3 * (PI / 4)) = -1 / sqrt 2. -Proof with trivial. - replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))... - rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4... - unfold Rdiv; rewrite Ropp_mult_distr_l_reverse... - unfold Rminus; rewrite Ropp_involutive; pattern PI at 1; - rewrite double_var; unfold Rdiv; rewrite Rmult_plus_distr_r; - repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr; - [ ring | discrR | discrR ]... +Proof. + replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field. + rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4. + unfold Rdiv. + ring. Qed. Lemma sin3PI4 : sin (3 * (PI / 4)) = 1 / sqrt 2. -Proof with trivial. - replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))... - rewrite sin_shift; rewrite cos_neg; rewrite cos_PI4... - unfold Rminus; rewrite Ropp_involutive; pattern PI at 1; - rewrite double_var; unfold Rdiv; rewrite Rmult_plus_distr_r; - repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr; - [ ring | discrR | discrR ]... +Proof. + replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field. + now rewrite sin_shift, cos_neg, cos_PI4. Qed. Lemma cos_PI6 : cos (PI / 6) = sqrt 3 / 2. @@ -248,19 +199,11 @@ Proof with trivial. left; apply (Rmult_lt_0_compat (sqrt 3) (/ 2))... apply Rlt_sqrt3_0... apply Rinv_0_lt_compat; prove_sup0... - assert (H : 2 <> 0); [ discrR | idtac ]... - assert (H1 : 4 <> 0); [ apply prod_neq_R0 | idtac ]... rewrite Rsqr_div... rewrite cos2; unfold Rsqr; rewrite sin_PI6; rewrite sqrt_def... - unfold Rdiv; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4... - rewrite Rmult_minus_distr_l; rewrite (Rmult_comm 3); - repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym... - rewrite Rmult_1_l; rewrite Rmult_1_r... - rewrite <- (Rmult_comm (/ 2)); repeat rewrite <- Rmult_assoc... - rewrite <- Rinv_l_sym... - rewrite Rmult_1_l; rewrite <- Rinv_r_sym... - ring... - left; prove_sup0... + field. + left ; prove_sup0. + discrR. Qed. Lemma tan_PI6 : tan (PI / 6) = 1 / sqrt 3. @@ -306,56 +249,32 @@ Proof. Qed. Lemma cos_2PI3 : cos (2 * (PI / 3)) = -1 / 2. -Proof with trivial. - assert (H : 2 <> 0); [ discrR | idtac ]... - assert (H0 : 4 <> 0); [ apply prod_neq_R0 | idtac ]... - rewrite double; rewrite cos_plus; rewrite sin_PI3; rewrite cos_PI3; - unfold Rdiv; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4... - rewrite Rmult_minus_distr_l; repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2)... - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r; rewrite <- Rinv_r_sym... - pattern 2 at 4; rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; - rewrite <- Rinv_l_sym... - rewrite Rmult_1_r; rewrite Ropp_mult_distr_r_reverse; rewrite Rmult_1_r... - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r; rewrite (Rmult_comm 2); rewrite (Rmult_comm (/ 2))... - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r; rewrite sqrt_def... - ring... - left; prove_sup... +Proof. + rewrite cos_2a, sin_PI3, cos_PI3. + replace (sqrt 3 / 2 * (sqrt 3 / 2)) with ((sqrt 3 * sqrt 3) / 4) by field. + rewrite sqrt_sqrt. + field. + left ; prove_sup0. Qed. Lemma tan_2PI3 : tan (2 * (PI / 3)) = - sqrt 3. -Proof with trivial. - assert (H : 2 <> 0); [ discrR | idtac ]... - unfold tan; rewrite sin_2PI3; rewrite cos_2PI3; unfold Rdiv; - rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l; - rewrite <- Ropp_inv_permute... - rewrite Rinv_involutive... - rewrite Rmult_assoc; rewrite Ropp_mult_distr_r_reverse; rewrite <- Rinv_l_sym... - ring... - apply Rinv_neq_0_compat... +Proof. + unfold tan; rewrite sin_2PI3, cos_2PI3. + field. Qed. Lemma cos_5PI4 : cos (5 * (PI / 4)) = -1 / sqrt 2. -Proof with trivial. - replace (5 * (PI / 4)) with (PI / 4 + PI)... - rewrite neg_cos; rewrite cos_PI4; unfold Rdiv; - rewrite Ropp_mult_distr_l_reverse... - pattern PI at 2; rewrite double_var; pattern PI at 2 3; - rewrite double_var; assert (H : 2 <> 0); - [ discrR | unfold Rdiv; repeat rewrite Rinv_mult_distr; try ring ]... +Proof. + replace (5 * (PI / 4)) with (PI / 4 + PI) by field. + rewrite neg_cos; rewrite cos_PI4; unfold Rdiv. + ring. Qed. Lemma sin_5PI4 : sin (5 * (PI / 4)) = -1 / sqrt 2. -Proof with trivial. - replace (5 * (PI / 4)) with (PI / 4 + PI)... - rewrite neg_sin; rewrite sin_PI4; unfold Rdiv; - rewrite Ropp_mult_distr_l_reverse... - pattern PI at 2; rewrite double_var; pattern PI at 2 3; - rewrite double_var; assert (H : 2 <> 0); - [ discrR | unfold Rdiv; repeat rewrite Rinv_mult_distr; try ring ]... +Proof. + replace (5 * (PI / 4)) with (PI / 4 + PI) by field. + rewrite neg_sin; rewrite sin_PI4; unfold Rdiv. + ring. Qed. Lemma sin_cos5PI4 : cos (5 * (PI / 4)) = sin (5 * (PI / 4)). diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v index eed612d94b..4a1e3179c6 100644 --- a/theories/Reals/Rtrigo_reg.v +++ b/theories/Reals/Rtrigo_reg.v @@ -395,15 +395,8 @@ Proof. apply Rlt_le_trans with alp. apply H7. unfold alp; apply Rmin_l. - rewrite sin_plus; unfold Rminus, Rdiv; - repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l; - repeat rewrite Rmult_assoc; repeat rewrite Rplus_assoc; - apply Rplus_eq_compat_l. - rewrite (Rplus_comm (sin x * (-1 * / h))); repeat rewrite Rplus_assoc; - apply Rplus_eq_compat_l. - rewrite Ropp_mult_distr_r_reverse; rewrite Ropp_mult_distr_l_reverse; - rewrite Rmult_1_r; rewrite Rmult_1_l; rewrite Ropp_mult_distr_r_reverse; - rewrite <- Ropp_mult_distr_l_reverse; apply Rplus_comm. + rewrite sin_plus. + now field. unfold alp; unfold Rmin; case (Rle_dec alp1 alp2); intro. apply (cond_pos alp1). apply (cond_pos alp2). -- cgit v1.2.3 From 9e621625618e1a0f341b87d66c1ea6027369c2e5 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 20 Dec 2016 16:11:03 +0100 Subject: Fix some typos. --- doc/refman/Polynom.tex | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/refman/Polynom.tex b/doc/refman/Polynom.tex index 0664bf9095..77d5928345 100644 --- a/doc/refman/Polynom.tex +++ b/doc/refman/Polynom.tex @@ -342,16 +342,16 @@ describes their syntax and effects: By default the tactic does not recognize power expressions as ring expressions. \item[sign {\term}] allows {\tt ring\_simplify} to use a minus operation - when outputing its normal form, i.e writing $x - y$ instead of $x + (-y)$. + when outputting its normal form, i.e writing $x - y$ instead of $x + (-y)$. The term {\term} is a proof that a given sign function indicates expressions that are signed ({\term} has to be a - proof of {\tt Ring\_theory.get\_sign}). See {\tt plugins/setoid\_ring/IntialRing.v} for examples of sign function. -\item[div {\term}] allows {\tt ring} and {\tt ring\_simplify} to use moniomals + proof of {\tt Ring\_theory.get\_sign}). See {\tt plugins/setoid\_ring/InitialRing.v} for examples of sign function. +\item[div {\term}] allows {\tt ring} and {\tt ring\_simplify} to use monomials with coefficient other than 1 in the rewriting. The term {\term} is a proof that a given division function satisfies the specification of an euclidean division function ({\term} has to be a proof of {\tt Ring\_theory.div\_theory}). For example, this function is called when trying to rewrite $7x$ by $2x = z$ to tell that $7 = 3 * 2 + 1$. - See {\tt plugins/setoid\_ring/IntialRing.v} for examples of div function. + See {\tt plugins/setoid\_ring/InitialRing.v} for examples of div function. \end{description} -- cgit v1.2.3 From ddbc3839923731686a89a401d0f9dd44f3ad339b Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 1 Feb 2017 14:37:08 +0100 Subject: Fix broken evaluation strategies for ring and field. A bang indicates an argument that must be reduced, a star indicates an argument that must be handled recursively. PEeval: R r0 r1 add mul sub opp C phi Cpow powphi pow varmap pol 0 1 2 3 4 5 6 7 8! 9 10! 11 12* 13! FEeval: R r0 r1 add mul sub opp div inv C phi Cpow powphi pow varmap pol 0 1 2 3 4 5 6 7 8 9 10! 11 12! 13 14* 15! Pphi_dev: R r0 r1 add mul sub opp C c0 c1 ceq phi sign varmap pol 0 1 2 3 4 5 6 7 8! 9! 10! 11! 12! 13* 14! Pphi_pow: R r0 r1 add mul sub opp C c0 c1 ceq phi Cpow powphi pow sign varmap pol 0 1 2 3 4 5 6 7 8! 9! 10! 11! 12 13! 14 15! 16* 17! display_linear: R r0 r1 add mul sub opp div C c0 c1 ceq phi sign varmap num den 0 1 2 3 4 5 6 7 8 9! 10!11! 12! 13! 14* 15! 16! display_pow_linear: R r0 r1 add mul sub opp div C c0 c1 ceq phi Cpow powphi pow sign varmap num den 0 1 2 3 4 5 6 7 8 9! 10!11! 12! 13 14! 15 16! 17* 18! 19! PCond: R r0 r1 add mul sub opp eq C phi Cpow powphi pow varmap pol 0 1 2 3 4 5 6 7 8 9! 10 11! 12 13* 14! --- plugins/setoid_ring/newring.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index eb35d3f806..2a3d66934b 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -330,7 +330,7 @@ let _ = add_map "ring" (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)]) + pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot)]) (****************************************************************************) (* Ring database *) @@ -761,7 +761,7 @@ let _ = add_map "field" my_reference "display_linear", (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); my_reference "display_pow_linear", - (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot); + (function -1|9|10|11|12|14|16|18|19->Eval|17->Rec|_->Prot); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); @@ -769,10 +769,10 @@ let _ = add_map "field" (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot); + pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot); (* FEeval: evaluate morphism, protect field operations and make recursive call on the var map *) - my_reference "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; + my_reference "FEeval", (function -1|10|12|15->Eval|14->Rec|_->Prot)]);; let _ = add_map "field_cond" (map_without_eq @@ -781,7 +781,6 @@ let _ = add_map "field_cond" (* PCond: evaluate morphism and denum list, protect ring operations and make recursive call on the var map *) my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);; -(* (function -1|9|11->Eval|10->Rec|_->Prot)]);;*) let _ = Redexpr.declare_reduction "simpl_field_expr" -- cgit v1.2.3 From a4a76c253474ac4ce523b70d0150ea5dcf546385 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sun, 5 Mar 2017 20:48:52 +0100 Subject: Make IZR use a compact representation of integers. That way, (IZR 5) is no longer reduced to 2 + 1 + 1 + 1 (which is not convertible to 5) but instead to 1 + 2 * 2 (which is). Moreover, it means that, after reduction, real constants no longer exponentially blow up. Note that I was not able to fix the test-suite for the declarative mode, so the missing proof terms have been admitted. --- test-suite/success/decl_mode.v | 2 +- theories/Reals/ArithProp.v | 4 +-- theories/Reals/RIneq.v | 67 +++++++++++++++++++++++++----------------- theories/Reals/R_Ifp.v | 4 +-- theories/Reals/Ratan.v | 6 ++-- theories/Reals/Raxioms.v | 22 ++++++++++++-- theories/Reals/Rbasic_fun.v | 9 +++--- theories/Reals/Rlogic.v | 2 +- theories/Reals/Rtrigo1.v | 8 ++--- 9 files changed, 78 insertions(+), 46 deletions(-) diff --git a/test-suite/success/decl_mode.v b/test-suite/success/decl_mode.v index 58f79d45ec..e569bcb49f 100644 --- a/test-suite/success/decl_mode.v +++ b/test-suite/success/decl_mode.v @@ -153,7 +153,7 @@ proof. thus ~= (IZR (Zneg z) * IZR (Zneg z)). end cases. end proof. -Qed. +Admitted. Definition irrational (x:R):Prop := forall (p:Z) (q:nat),q<>0%nat -> x<> (IZR p/INR q). diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index 6fca9c8ad6..7d9fff2764 100644 --- a/theories/Reals/ArithProp.v +++ b/theories/Reals/ArithProp.v @@ -106,7 +106,7 @@ Proof. split. ring. unfold k0; case (Rcase_abs y) as [Hlt|Hge]. - assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl; + assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; change (IZR 1) with 1; unfold Rminus. replace (- ((1 + - IZR (up (x / - y))) * y)) with ((IZR (up (x / - y)) - 1) * y); [ idtac | ring ]. @@ -140,7 +140,7 @@ Proof. rewrite <- Ropp_mult_distr_r_reverse; rewrite (Ropp_inv_permute _ H); elim H0; unfold Rdiv; intros H1 _; exact H1. apply Ropp_neq_0_compat; assumption. - assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl; + assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; change (IZR 1) with 1; cut (0 < y). intro; unfold Rminus; replace (- ((IZR (up (x / y)) + -1) * y)) with ((1 - IZR (up (x / y))) * y); diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 07bcd98369..6860773270 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -1743,24 +1743,40 @@ Proof. intros z; idtac; apply Z_of_nat_complete; assumption. Qed. +Lemma INR_IPR : forall p, INR (Pos.to_nat p) = IPR p. +Proof. + assert (H: forall p, 2 * INR (Pos.to_nat p) = IPR_2 p). + induction p as [p|p|] ; simpl IPR_2. + rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- IHp. + now rewrite (Rplus_comm (2 * _)). + now rewrite Pos2Nat.inj_xO, mult_INR, <- IHp. + apply Rmult_1_r. + intros [p|p|] ; unfold IPR. + rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H. + apply Rplus_comm. + now rewrite Pos2Nat.inj_xO, mult_INR, <- H. + easy. +Qed. + (**********) Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z.of_nat n). Proof. - simple induction n; auto with real. - intros; simpl; rewrite SuccNat2Pos.id_succ; - auto with real. + intros [|n]. + easy. + simpl Z.of_nat. unfold IZR. + now rewrite <- INR_IPR, SuccNat2Pos.id_succ. Qed. Lemma plus_IZR_NEG_POS : forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q). Proof. intros p q; simpl. rewrite Z.pos_sub_spec. - case Pos.compare_spec; intros H; simpl. + case Pos.compare_spec; intros H; unfold IZR. subst. ring. - rewrite Pos2Nat.inj_sub by trivial. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial. rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt). ring. - rewrite Pos2Nat.inj_sub by trivial. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial. rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt). ring. Qed. @@ -1769,26 +1785,18 @@ Qed. Lemma plus_IZR : forall n m:Z, IZR (n + m) = IZR n + IZR m. Proof. intro z; destruct z; intro t; destruct t; intros; auto with real. - simpl; intros; rewrite Pos2Nat.inj_add; auto with real. + simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add. apply plus_INR. apply plus_IZR_NEG_POS. rewrite Z.add_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS. - simpl; intros; rewrite Pos2Nat.inj_add; rewrite plus_INR; - auto with real. + simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add, plus_INR. + apply Ropp_plus_distr. Qed. (**********) Lemma mult_IZR : forall n m:Z, IZR (n * m) = IZR n * IZR m. Proof. - intros z t; case z; case t; simpl; auto with real. - intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real. - intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real. - rewrite Rmult_comm. - rewrite Ropp_mult_distr_l_reverse; auto with real. - apply Ropp_eq_compat; rewrite mult_comm; auto with real. - intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real. - rewrite Ropp_mult_distr_l_reverse; auto with real. - intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real. - rewrite Rmult_opp_opp; auto with real. + intros z t; case z; case t; simpl; auto with real; + unfold IZR; intros m n; rewrite <- 3!INR_IPR, Pos2Nat.inj_mul, mult_INR; ring. Qed. Lemma pow_IZR : forall z n, pow (IZR z) n = IZR (Z.pow z (Z.of_nat n)). @@ -1810,7 +1818,7 @@ Qed. (**********) Lemma opp_IZR : forall n:Z, IZR (- n) = - IZR n. Proof. - intro z; case z; simpl; auto with real. + intros [|z|z]; unfold IZR; simpl; auto with real. Qed. Definition Ropp_Ropp_IZR := opp_IZR. @@ -1833,10 +1841,12 @@ Qed. Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. Proof. intro z; case z; simpl; intros. - absurd (0 < 0); auto with real. - unfold Z.lt; simpl; trivial. - case Rlt_not_le with (1 := H). - replace 0 with (-0); auto with real. + elim (Rlt_irrefl _ H). + easy. + elim (Rlt_not_le _ _ H). + unfold IZR. + rewrite <- INR_IPR. + auto with real. Qed. (**********) @@ -1852,9 +1862,12 @@ Qed. Lemma eq_IZR_R0 : forall n:Z, IZR n = 0 -> n = 0%Z. Proof. intro z; destruct z; simpl; intros; auto with zarith. - case (Rlt_not_eq 0 (INR (Pos.to_nat p))); auto with real. - case (Rlt_not_eq (- INR (Pos.to_nat p)) 0); auto with real. - apply Ropp_lt_gt_0_contravar. unfold Rgt; apply pos_INR_nat_of_P. + elim Rgt_not_eq with (2 := H). + unfold IZR. rewrite <- INR_IPR. + apply lt_0_INR, Pos2Nat.is_pos. + elim Rlt_not_eq with (2 := H). + unfold IZR. rewrite <- INR_IPR. + apply Ropp_lt_gt_0_contravar, lt_0_INR, Pos2Nat.is_pos. Qed. (**********) diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index b6d0728371..d0f9aea28a 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -92,7 +92,7 @@ Proof. auto with zarith real. (*inf a 1*) cut (r - IZR (up r) < 0). - rewrite <- Z_R_minus; simpl; intro; unfold Rminus; + rewrite <- Z_R_minus; change (IZR 1) with 1; intro; unfold Rminus; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; fold (r - IZR (up r)); rewrite Ropp_involutive; elim (Rplus_ne 1); intros a b; pattern 1 at 2; @@ -376,7 +376,7 @@ Proof. rewrite (Ropp_involutive (IZR 1)); rewrite (Ropp_involutive (IZR (Int_part r2))); rewrite (Ropp_plus_distr (IZR (Int_part r1))); - rewrite (Ropp_involutive (IZR (Int_part r2))); simpl; + rewrite (Ropp_involutive (IZR (Int_part r2))); change (IZR 1) with 1; rewrite <- (Rplus_assoc (r1 + - r2) (- IZR (Int_part r1) + IZR (Int_part r2)) 1) ; rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2))); diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v index e13ef1f2ca..d9aa6b8592 100644 --- a/theories/Reals/Ratan.v +++ b/theories/Reals/Ratan.v @@ -322,8 +322,8 @@ apply Rlt_le_trans with (2 := t); clear t. unfold cos_approx; simpl; unfold cos_term. simpl mult; replace ((-1)^ 0) with 1 by ring; replace ((-1)^2) with 1 by ring; replace ((-1)^4) with 1 by ring; replace ((-1)^1) with (-1) by ring; - replace ((-1)^3) with (-1) by ring; replace 3 with (IZR 3) by (simpl; ring); - replace 2 with (IZR 2) by (simpl; ring); simpl Z.of_nat; + replace ((-1)^3) with (-1) by ring; change 3 with (IZR 3); + change 2 with (IZR 2); simpl Z.of_nat; rewrite !INR_IZR_INZ, Ropp_mult_distr_l_reverse, Rmult_1_l. match goal with |- _ < ?a => replace a with ((- IZR 3 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * @@ -853,6 +853,8 @@ intros x Hx eps Heps. apply Rlt_trans with (2 := H). apply Rinv_0_lt_compat. exact Heps. + unfold N. + rewrite INR_IZR_INZ, positive_nat_Z. exact HN. apply lt_INR. omega. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 9fbda92a2f..e9098104ce 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -118,14 +118,30 @@ Arguments INR n%nat. (** * Injection from [Z] to [R] *) (**********************************************************) +(* compact representation for 2*p *) +Fixpoint IPR_2 (p:positive) : R := + match p with + | xH => 1 + 1 + | xO p => (1 + 1) * IPR_2 p + | xI p => (1 + 1) * (1 + IPR_2 p) + end. + +Definition IPR (p:positive) : R := + match p with + | xH => 1 + | xO p => IPR_2 p + | xI p => 1 + IPR_2 p + end. +Arguments IPR p%positive : simpl never. + (**********) Definition IZR (z:Z) : R := match z with | Z0 => 0 - | Zpos n => INR (Pos.to_nat n) - | Zneg n => - INR (Pos.to_nat n) + | Zpos n => IPR n + | Zneg n => - IPR n end. -Arguments IZR z%Z. +Arguments IZR z%Z : simpl never. (**********************************************************) (** * [R] Archimedean *) diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index c889d73473..fe5402e6e3 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -613,11 +613,12 @@ Qed. Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Z.abs z). Proof. - intros z; case z; simpl; auto with real. - apply Rabs_right; auto with real. - intros p0; apply Rabs_right; auto with real zarith. + intros z; case z; unfold Zabs. + apply Rabs_R0. + now intros p0; apply Rabs_pos_eq, (IZR_le 0). + unfold IZR at 1. intros p0; rewrite Rabs_Ropp. - apply Rabs_right; auto with real zarith. + now apply Rabs_pos_eq, (IZR_le 0). Qed. Lemma abs_IZR : forall z, IZR (Z.abs z) = Rabs (IZR z). diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v index b9a9458c8d..7bd6c916d0 100644 --- a/theories/Reals/Rlogic.v +++ b/theories/Reals/Rlogic.v @@ -82,7 +82,7 @@ assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). apply Rle_lt_trans with (1 := H1l). apply archimed. rewrite minus_IZR. - simpl. + change (IZR 2) with 2%R. ring. assert (Hl': (/ (INR (S N) + 1) < l)%R). rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq. diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index 5f2e0d5b55..6b17540213 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -182,8 +182,8 @@ destruct (pre_cos_bound _ 0 lo up) as [_ upper]. apply Rle_lt_trans with (1 := upper). apply Rlt_le_trans with (2 := lower). unfold cos_approx, sin_approx. -simpl sum_f_R0; replace 7 with (IZR 7) by (simpl; field). -replace 8 with (IZR 8) by (simpl; field). +simpl sum_f_R0; change 7 with (IZR 7). +change 8 with (IZR 8). unfold cos_term, sin_term; simpl fact; rewrite !INR_IZR_INZ. simpl plus; simpl mult. field_simplify; @@ -1798,7 +1798,7 @@ Lemma cos_eq_0_0 (x:R) : Proof. rewrite cos_sin. intros Hx. destruct (sin_eq_0_0 (PI/2 + x) Hx) as (k,Hk). clear Hx. - exists (k-1)%Z. rewrite <- Z_R_minus; simpl. + exists (k-1)%Z. rewrite <- Z_R_minus; change (IZR 1) with 1. symmetry in Hk. field_simplify [Hk]. field. Qed. @@ -1836,7 +1836,7 @@ Proof. - right; left; auto. - left. clear Hi. subst. - replace 0 with (IZR 0 * PI) by (simpl; ring). f_equal. f_equal. + replace 0 with (IZR 0 * PI) by apply Rmult_0_l. f_equal. f_equal. apply one_IZR_lt1. split. + apply Rlt_le_trans with 0; -- cgit v1.2.3 From 1b0d67a0cf1b725715e97ba6448c3ff0154813bc Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 21 Mar 2017 17:17:28 +0100 Subject: [travis] [8.6.only] Backport latest changes from trunk. --- .travis.yml | 4 ++ Makefile.ci | 2 +- dev/ci/ci-basic-overlay.sh | 103 +++++++++++++++++++++++++++++++++++++++++++++ dev/ci/ci-color.sh | 8 ++-- dev/ci/ci-common.sh | 34 ++++++++++----- dev/ci/ci-compcert.sh | 9 ++-- dev/ci/ci-coquelicot.sh | 10 ++--- dev/ci/ci-cpdt.sh | 2 +- dev/ci/ci-fiat-crypto.sh | 9 ++-- dev/ci/ci-fiat-parsers.sh | 10 +++++ dev/ci/ci-flocq.sh | 9 ++-- dev/ci/ci-geocoq.sh | 10 ++--- dev/ci/ci-hott.sh | 8 ++-- dev/ci/ci-iris-coq.sh | 24 ++++++++--- dev/ci/ci-math-classes.sh | 20 ++++++--- dev/ci/ci-math-comp.sh | 8 ++-- dev/ci/ci-metacoq.sh | 17 +++++--- dev/ci/ci-sf.sh | 5 ++- dev/ci/ci-template.sh | 12 ++++++ dev/ci/ci-tlc.sh | 8 ++-- dev/ci/ci-unimath.sh | 9 ++-- dev/ci/ci-user-overlay.sh | 22 ++++++++++ 22 files changed, 268 insertions(+), 75 deletions(-) create mode 100644 dev/ci/ci-basic-overlay.sh create mode 100755 dev/ci/ci-fiat-parsers.sh create mode 100755 dev/ci/ci-template.sh create mode 100644 dev/ci/ci-user-overlay.sh diff --git a/.travis.yml b/.travis.yml index f609852bc3..7138d5c61e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,4 +1,7 @@ dist: trusty +# Travis builds are slower using sudo: false (the container-based +# infrastructure) as of March 2017; see +# https://github.com/coq/coq/pull/467 for some discussion. sudo: required # Until Ocaml becomes a language, we set a known one. language: c @@ -29,6 +32,7 @@ env: - TEST_TARGET="ci-coquelicot" - TEST_TARGET="ci-geocoq" - TEST_TARGET="ci-fiat-crypto" + - TEST_TARGET="ci-fiat-parsers" - TEST_TARGET="ci-flocq" - TEST_TARGET="ci-hott" - TEST_TARGET="ci-iris-coq" diff --git a/Makefile.ci b/Makefile.ci index e4b5832f60..897318c4dd 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -1,5 +1,5 @@ CI_TARGETS=ci-all ci-hott ci-math-comp ci-compcert ci-sf ci-cpdt \ - ci-color ci-math-classes ci-tlc ci-fiat-crypto \ + ci-color ci-math-classes ci-tlc ci-fiat-crypto ci-fiat-parsers \ ci-coquelicot ci-flocq ci-iris-coq ci-metacoq ci-geocoq \ ci-unimath diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh new file mode 100644 index 0000000000..241ec35861 --- /dev/null +++ b/dev/ci/ci-basic-overlay.sh @@ -0,0 +1,103 @@ +#!/usr/bin/env bash + +# This is the basic overlay set for repositories in the CI. + +# Maybe we should just use Ruby to have real objects... + +######################################################################## +# MathComp +######################################################################## +: ${mathcomp_CI_BRANCH:=master} +: ${mathcomp_CI_GITURL:=https://github.com/math-comp/math-comp.git} + +######################################################################## +# UniMath +######################################################################## +: ${UniMath_CI_BRANCH:=master} +: ${UniMath_CI_GITURL:=https://github.com/UniMath/UniMath.git} + +######################################################################## +# Unicoq + Metacoq +######################################################################## +: ${unicoq_CI_BRANCH:=master} +: ${unicoq_CI_GITURL:=https://github.com/unicoq/unicoq.git} + +: ${metacoq_CI_BRANCH:=master} +: ${metacoq_CI_GITURL:=https://github.com/MetaCoq/MetaCoq.git} + +######################################################################## +# Mathclasses + Corn +######################################################################## +: ${math_classes_CI_BRANCH:=v8.6} +: ${math_classes_CI_GITURL:=https://github.com/math-classes/math-classes.git} + +: ${Corn_CI_BRANCH:=v8.6} +: ${Corn_CI_GITURL:=https://github.com/c-corn/corn.git} + +######################################################################## +# Iris +######################################################################## +: ${stdpp_CI_BRANCH:=master} +: ${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git} + +: ${Iris_CI_BRANCH:=master} +: ${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/FP/iris-coq.git} + +######################################################################## +# HoTT +######################################################################## +: ${HoTT_CI_BRANCH:=mz-8.7} +: ${HoTT_CI_GITURL:=https://github.com/ejgallego/HoTT.git} + +######################################################################## +# GeoCoq +######################################################################## +: ${GeoCoq_CI_BRANCH:=master} +: ${GeoCoq_CI_GITURL:=https://github.com/GeoCoq/GeoCoq.git} + +######################################################################## +# Flocq +######################################################################## +: ${Flocq_CI_BRANCH:=master} +: ${Flocq_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git} + +######################################################################## +# Coquelicot +######################################################################## +: ${Coquelicot_CI_BRANCH:=master} +: ${Coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git} + +######################################################################## +# CompCert +######################################################################## +: ${CompCert_CI_BRANCH:=master} +: ${CompCert_CI_GITURL:=https://github.com/AbsInt/CompCert.git} + +######################################################################## +# fiat_parsers +######################################################################## +: ${fiat_parsers_CI_BRANCH:=master} +: ${fiat_parsers_CI_GITURL:=https://github.com/mit-plv/fiat.git} + +######################################################################## +# fiat_crypto +######################################################################## +: ${fiat_crypto_CI_BRANCH:=master} +: ${fiat_crypto_CI_GITURL:=https://github.com/mit-plv/fiat-crypto.git} + +######################################################################## +# CoLoR +######################################################################## +: ${Color_CI_SVNURL:=https://scm.gforge.inria.fr/anonscm/svn/color/trunk/color} + +######################################################################## +# SF +######################################################################## +: ${sf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/current/sf.tgz} + +######################################################################## +# TLC +######################################################################## +: ${tlc_CI_BRANCH:=master} +: ${tlc_CI_GITURL:=https://gforge.inria.fr/git/tlc/tlc.git} + diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh index 78ae7f02f9..3f0716511d 100755 --- a/dev/ci/ci-color.sh +++ b/dev/ci/ci-color.sh @@ -1,8 +1,10 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -svn checkout https://scm.gforge.inria.fr/anonscm/svn/color/trunk/color color +Color_CI_DIR=${CI_BUILD_DIR}/color -( cd color && make -j ${NJOBS} ) +svn checkout ${Color_CI_SVNURL} ${Color_CI_DIR} + +( cd ${Color_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 412da626fd..9fdd2504d4 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash set -xe @@ -8,20 +8,34 @@ export PATH=`pwd`/bin:$PATH ls `pwd`/bin -# Maybe we should just use Ruby... -mathcomp_CI_BRANCH=master -mathcomp_CI_GITURL=https://github.com/math-comp/math-comp.git +# Where we clone and build external developments +CI_BUILD_DIR=`pwd`/_build_ci -# git_checkout branch +source ${ci_dir}/ci-user-overlay.sh +source ${ci_dir}/ci-basic-overlay.sh + +mathcomp_CI_DIR=${CI_BUILD_DIR}/math-comp + +# git_checkout branch url dest will create a git repository +# in (if it does not exist already) and checkout the +# remote branch from git_checkout() { local _BRANCH=${1} local _URL=${2} local _DEST=${3} - echo "Checking out ${_DEST}" - git clone --depth 1 -b ${_BRANCH} ${_URL} ${_DEST} - ( cd ${3} && echo "${_DEST}: `git log -1 --format='%s | %H | %cd | %aN'`" ) + # Allow an optional 4th argument for the commit + local _COMMIT=${4:-FETCH_HEAD} + local _DEPTH=${5:-1} + + mkdir -p ${_DEST} + ( cd ${_DEST} && \ + if [ ! -d .git ] ; then git clone --depth ${_DEPTH} ${_URL} . ; fi && \ + echo "Checking out ${_DEST}" && \ + git fetch ${_URL} ${_BRANCH} && \ + git checkout ${_COMMIT} && \ + echo "${_DEST}: `git log -1 --format='%s | %H | %cd | %aN'`" ) } checkout_mathcomp() @@ -34,8 +48,8 @@ install_ssreflect() { echo 'Installing ssreflect' && echo -en 'travis_fold:start:ssr.install\\r' - checkout_mathcomp math-comp - ( cd math-comp/mathcomp && \ + checkout_mathcomp ${mathcomp_CI_DIR} + ( cd ${mathcomp_CI_DIR}/mathcomp && \ sed -i.bak '/ssrtest/d' Make && \ sed -i.bak '/odd_order/d' Make && \ sed -i.bak '/all\/all.v/d' Make && \ diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index ec09389f8e..c78ffdc2c0 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -1,13 +1,12 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -CompCert_CI_BRANCH=master -CompCert_CI_GITURL=https://github.com/AbsInt/CompCert.git +CompCert_CI_DIR=${CI_BUILD_DIR}/CompCert opam install -j ${NJOBS} -y menhir -git_checkout ${CompCert_CI_BRANCH} ${CompCert_CI_GITURL} CompCert +git_checkout ${CompCert_CI_BRANCH} ${CompCert_CI_GITURL} ${CompCert_CI_DIR} # Patch to avoid the upper version limit -( cd CompCert && sed -i.bak 's/8.6)/8.6|trunk)/' configure && ./configure x86_32-linux && make -j ${NJOBS} ) +( cd ${CompCert_CI_DIR} && sed -i.bak 's/8.6)/8.6|trunk)/' configure && ./configure x86_32-linux && make -j ${NJOBS} ) diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh index 94bd5e468f..40eff03b78 100755 --- a/dev/ci/ci-coquelicot.sh +++ b/dev/ci/ci-coquelicot.sh @@ -1,12 +1,12 @@ -#!/bin/bash +#!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh +Coquelicot_CI_DIR=${CI_BUILD_DIR}/coquelicot + install_ssreflect -# Setup coquelicot -git_checkout master https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git coquelicot +git_checkout ${Coquelicot_CI_BRANCH} ${Coquelicot_CI_GITURL} ${Coquelicot_CI_DIR} -( cd coquelicot && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) +( cd ${Coquelicot_CI_DIR} && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) diff --git a/dev/ci/ci-cpdt.sh b/dev/ci/ci-cpdt.sh index 18d7561804..0e791ebbfd 100755 --- a/dev/ci/ci-cpdt.sh +++ b/dev/ci/ci-cpdt.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh index c669195ddd..93d39aab07 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat-crypto.sh @@ -1,9 +1,10 @@ -#!/bin/bash +#!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git_checkout master https://github.com/mit-plv/fiat-crypto.git fiat-crypto +fiat_crypto_CI_DIR=${CI_BUILD_DIR}/fiat-crypto -( cd fiat-crypto && make -j ${NJOBS} ) +git_checkout ${fiat_crypto_CI_BRANCH} ${fiat_crypto_CI_GITURL} ${fiat_crypto_CI_DIR} + +( cd ${fiat_crypto_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-fiat-parsers.sh b/dev/ci/ci-fiat-parsers.sh new file mode 100755 index 0000000000..c62aa1d859 --- /dev/null +++ b/dev/ci/ci-fiat-parsers.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +fiat_parsers_CI_DIR=${CI_BUILD_DIR}/fiat + +git_checkout ${fiat_parsers_CI_BRANCH} ${fiat_parsers_CI_GITURL} ${fiat_parsers_CI_DIR} + +( cd ${fiat_parsers_CI_DIR} && make -j ${NJOBS} parsers ) diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh index 345924e40a..ec19bd9939 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -1,9 +1,10 @@ -#!/bin/bash +#!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git_checkout master https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git flocq +Flocq_CI_DIR=${CI_BUILD_DIR}/flocq -( cd flocq && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) +git_checkout ${Flocq_CI_BRANCH} ${Flocq_CI_GITURL} ${Flocq_CI_DIR} + +( cd ${Flocq_CI_DIR} && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index 29667b018a..4e5aa2687b 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -1,15 +1,13 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -# XXX: replace by generic template -GeoCoq_CI_BRANCH=master -GeoCoq_CI_GITURL=https://github.com/GeoCoq/GeoCoq.git +GeoCoq_CI_DIR=${CI_BUILD_DIR}/GeoCoq -git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} GeoCoq +git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} ${GeoCoq_CI_DIR} -( cd GeoCoq && \ +( cd ${GeoCoq_CI_DIR} && \ ./configure.sh && \ sed -i.bak '/Ch16_coordinates_with_functions\.v/d' Make && \ sed -i.bak '/Elements\/Book_1\.v/d' Make && \ diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 0c07564c02..1bf6e9a872 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -1,8 +1,10 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git_checkout mz-8.7 https://github.com/ejgallego/HoTT.git HoTT +HoTT_CI_DIR=${CI_BUILD_DIR}/HoTT -( cd HoTT && ./autogen.sh && ./configure && make -j ${NJOBS} ) +git_checkout ${HoTT_CI_BRANCH} ${HoTT_CI_GITURL} ${HoTT_CI_DIR} + +( cd ${HoTT_CI_DIR} && ./autogen.sh && ./configure && make -j ${NJOBS} ) diff --git a/dev/ci/ci-iris-coq.sh b/dev/ci/ci-iris-coq.sh index c21af976f4..dcb46ed2ab 100755 --- a/dev/ci/ci-iris-coq.sh +++ b/dev/ci/ci-iris-coq.sh @@ -1,17 +1,27 @@ -#!/bin/bash +#!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh +stdpp_CI_DIR=${CI_BUILD_DIR}/coq-stdpp + +Iris_CI_DIR=${CI_BUILD_DIR}/iris-coq + install_ssreflect +# Setup Iris first, as it is needed to compute the dependencies + +git_checkout ${Iris_CI_BRANCH} ${Iris_CI_GITURL} ${Iris_CI_DIR} +read -a IRIS_DEP < ${Iris_CI_DIR}/opam.pins + # Setup stdpp -git_checkout master https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git coq-stdpp +stdpp_CI_GITURL=${IRIS_DEP[1]}.git +stdpp_CI_COMMIT=${IRIS_DEP[2]} +stdpp_CI_DEPTH="1000" -( cd coq-stdpp && make -j ${NJOBS} && make install ) +git_checkout ${stdpp_CI_BRANCH} ${stdpp_CI_GITURL} ${stdpp_CI_DIR} ${stdpp_CI_COMMIT} ${stdpp_CI_DEPTH} -# Setup Iris -git_checkout master https://gitlab.mpi-sws.org/FP/iris-coq.git iris-coq +( cd ${stdpp_CI_DIR} && make -j ${NJOBS} && make install ) -( cd iris-coq && make -j ${NJOBS} ) +# Build iris now +( cd ${Iris_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math-classes.sh index 4450dc0710..beb75773b7 100755 --- a/dev/ci/ci-math-classes.sh +++ b/dev/ci/ci-math-classes.sh @@ -1,12 +1,20 @@ -#!/bin/bash +#!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git_checkout v8.6 https://github.com/math-classes/math-classes.git math-classes -( cd math-classes && make -j ${NJOBS} && make install ) +math_classes_CI_DIR=${CI_BUILD_DIR}/math-classes -git_checkout v8.6 https://github.com/c-corn/corn.git corn -( cd corn && make -j ${NJOBS} ) +Corn_CI_DIR=${CI_BUILD_DIR}/corn +# Setup Math-Classes + +git_checkout ${math_classes_CI_BRANCH} ${math_classes_CI_GITURL} ${math_classes_CI_DIR} + +( cd ${math_classes_CI_DIR} && make -j ${NJOBS} && make install ) + +# Setup Corn + +git_checkout ${Corn_CI_BRANCH} ${Corn_CI_GITURL} ${Corn_CI_DIR} + +( cd ${Corn_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-math-comp.sh b/dev/ci/ci-math-comp.sh index 2eb150cb52..bb8188da4e 100755 --- a/dev/ci/ci-math-comp.sh +++ b/dev/ci/ci-math-comp.sh @@ -1,13 +1,15 @@ -#!/bin/bash +#!/usr/bin/env bash # $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -checkout_mathcomp math-comp +mathcomp_CI_DIR=${CI_BUILD_DIR}/math-comp + +checkout_mathcomp ${mathcomp_CI_DIR} # odd_order takes too much time for travis. -( cd math-comp/mathcomp && \ +( cd ${mathcomp_CI_DIR}/mathcomp && \ sed -i.bak '/PFsection/d' Make && \ sed -i.bak '/stripped_odd_order_theorem/d' Make && \ make Makefile.coq && make -f Makefile.coq -j ${NJOBS} all ) diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh index 91a33695b0..e31691179e 100755 --- a/dev/ci/ci-metacoq.sh +++ b/dev/ci/ci-metacoq.sh @@ -1,16 +1,19 @@ -#!/bin/bash +#!/usr/bin/env bash -# $0 is not the safest way, but... ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -# MetaCoq + UniCoq +unicoq_CI_DIR=${CI_BUILD_DIR}/unicoq +metacoq_CI_DIR=${CI_BUILD_DIR}/MetaCoq -git_checkout master https://github.com/unicoq/unicoq.git unicoq +# Setup UniCoq -( cd unicoq && coq_makefile -f Make -o Makefile && make -j ${NJOBS} && make install ) +git_checkout ${unicoq_CI_BRANCH} ${unicoq_CI_GITURL} ${unicoq_CI_DIR} -git_checkout master https://github.com/MetaCoq/MetaCoq.git MetaCoq +( cd ${unicoq_CI_DIR} && coq_makefile -f Make -o Makefile && make -j ${NJOBS} && make install ) -( cd MetaCoq && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} ) +# Setup MetaCoq +git_checkout ${metacoq_CI_BRANCH} ${metacoq_CI_GITURL} ${metacoq_CI_DIR} + +( cd ${metacoq_CI_DIR} && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} ) diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index 5e41211f1a..7d23ccad97 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -1,9 +1,10 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -wget https://www.cis.upenn.edu/~bcpierce/sf/current/sf.tgz +# XXX: Needs fixing to properly set the build directory. +wget ${sf_CI_TARURL} tar xvfz sf.tgz ( cd sf && sed -i.bak 's/(K,N)/((K,N))/' LibTactics.v && make clean && make -j ${NJOBS} ) diff --git a/dev/ci/ci-template.sh b/dev/ci/ci-template.sh new file mode 100755 index 0000000000..700105aed4 --- /dev/null +++ b/dev/ci/ci-template.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +Template_CI_BRANCH=master +Template_CI_GITURL=https://github.com/Template/Template +Template_CI_DIR=${CI_BUILD_DIR}/Template + +git_checkout ${Template_CI_BRANCH} ${Template_CI_GITURL} ${Template_CI_DIR} + +( cd ${Template_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-tlc.sh b/dev/ci/ci-tlc.sh index b946324924..ce26399378 100755 --- a/dev/ci/ci-tlc.sh +++ b/dev/ci/ci-tlc.sh @@ -1,8 +1,10 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -git_checkout master https://gforge.inria.fr/git/tlc/tlc.git tlc +tlc_CI_DIR=${CI_BUILD_DIR}/tlc -( cd tlc && make -j ${NJOBS} ) +git_checkout ${tlc_CI_BRANCH} ${tlc_CI_GITURL} ${tlc_CI_DIR} + +( cd ${tlc_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh index 15e619acbb..175b82b5f9 100755 --- a/dev/ci/ci-unimath.sh +++ b/dev/ci/ci-unimath.sh @@ -1,14 +1,13 @@ -#!/bin/bash +#!/usr/bin/env bash ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -UniMath_CI_BRANCH=master -UniMath_CI_GITURL=https://github.com/UniMath/UniMath.git +UniMath_CI_DIR=${CI_BUILD_DIR}/UniMath -git_checkout ${UniMath_CI_BRANCH} ${UniMath_CI_GITURL} UniMath +git_checkout ${UniMath_CI_BRANCH} ${UniMath_CI_GITURL} ${UniMath_CI_DIR} -( cd UniMath && \ +( cd ${UniMath_CI_DIR} && \ sed -i.bak '/Folds/d' Makefile && \ sed -i.bak '/HomologicalAlgebra/d' Makefile && \ make -j ${NJOBS} BUILD_COQ=no ) diff --git a/dev/ci/ci-user-overlay.sh b/dev/ci/ci-user-overlay.sh new file mode 100644 index 0000000000..0285747432 --- /dev/null +++ b/dev/ci/ci-user-overlay.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash + +# Add user overlays here. You can use some logic to detect if you are +# in your travis branch and conditionally enable the overlay. + +# Some useful Travis variables: +# (https://docs.travis-ci.com/user/environment-variables/#Default-Environment-Variables) +# +# - TRAVIS_BRANCH: For builds not triggered by a pull request this is +# the name of the branch currently being built; whereas for builds +# triggered by a pull request this is the name of the branch +# targeted by the pull request (in many cases this will be master). +# +# - TRAVIS_COMMIT: The commit that the current build is testing. +# +# - TRAVIS_PULL_REQUEST: The pull request number if the current job is +# a pull request, “false” if it’s not a pull request. +# +# - TRAVIS_PULL_REQUEST_BRANCH: If the current job is a pull request, +# the name of the branch from which the PR originated. "" if the +# current job is a push build. + -- cgit v1.2.3 From e1ef9491edaf8f7e6f553c49b24163b7e2a53825 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sun, 5 Mar 2017 21:03:51 +0100 Subject: Change the parser and printer so that they use IZR for real constants. There are two main issues. First, (-cst)%R is no longer syntactically equal to (-(cst))%R (though they are still convertible). This breaks some rewriting rules. Second, the ring/field_simplify tactics did not know how to refold real constants. This defect is no longer hidden by the pretty-printer, which makes these tactics almost unusable on goals containing large constants. This commit also modifies the ring/field tactics so that real constant reification is now constant time rather than linear. Note that there is now a bit of code duplication between z_syntax and r_syntax. This should be fixed once plugin interdependencies are supported. Ideally the r_syntax plugin should just disappear by declaring IZR as a coercion. Unfortunately the coercion mechanism is not powerful enough yet, be it for parsing (need the ability for a scope to delegate constant parsing to another scope) or printing (too many visible coercions left). --- plugins/fourier/Fourier.v | 2 +- plugins/setoid_ring/RealField.v | 21 ++++-- plugins/syntax/r_syntax.ml | 159 +++++++++++++++++++++------------------- theories/Reals/Alembert.v | 2 +- theories/Reals/ArithProp.v | 6 +- theories/Reals/DiscrR.v | 9 --- theories/Reals/Exp_prop.v | 12 +-- theories/Reals/Machin.v | 2 +- theories/Reals/RIneq.v | 2 +- theories/Reals/R_Ifp.v | 39 ++++------ theories/Reals/R_sqrt.v | 4 +- theories/Reals/Ranalysis2.v | 16 ++-- theories/Reals/Ranalysis3.v | 32 +++----- theories/Reals/Ranalysis5.v | 5 +- theories/Reals/Ratan.v | 44 ++++------- theories/Reals/Raxioms.v | 29 -------- theories/Reals/Rbasic_fun.v | 18 ++--- theories/Reals/Rdefinitions.v | 29 ++++++++ theories/Reals/Rfunctions.v | 5 +- theories/Reals/Rlogic.v | 2 +- theories/Reals/Rpow_def.v | 2 +- theories/Reals/Rpower.v | 9 +-- theories/Reals/Rseries.v | 2 +- theories/Reals/Rtrigo1.v | 42 +++++------ theories/Reals/Rtrigo_alt.v | 6 +- theories/Reals/Rtrigo_reg.v | 3 +- theories/Reals/Sqrt_reg.v | 1 + 27 files changed, 229 insertions(+), 274 deletions(-) diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v index 1d7ee93ea3..a962547131 100644 --- a/plugins/fourier/Fourier.v +++ b/plugins/fourier/Fourier.v @@ -13,6 +13,6 @@ Require Export DiscrR. Require Export Fourier_util. Declare ML Module "fourier_plugin". -Ltac fourier := abstract (fourierz; field; discrR). +Ltac fourier := abstract (compute [IZR IPR IPR_2] in *; fourierz; field; discrR). Ltac fourier_eq := apply Rge_antisym; fourier. diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v index 293722125b..facd2e0625 100644 --- a/plugins/setoid_ring/RealField.v +++ b/plugins/setoid_ring/RealField.v @@ -59,11 +59,12 @@ Notation Rset := (Eqsth R). Notation Rext := (Eq_ext Rplus Rmult Ropp). Lemma Rlt_0_2 : 0 < 2. +Proof. apply Rlt_trans with (0 + 1). apply Rlt_n_Sn. rewrite Rplus_comm. apply Rplus_lt_compat_l. - replace 1 with (0 + 1). + replace R1 with (0 + 1). apply Rlt_n_Sn. apply Rplus_0_l. Qed. @@ -126,9 +127,17 @@ Ltac Rpow_tac t := | _ => constr:(N.of_nat t) end. -Add Field RField : Rfield - (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]). - - - +Ltac IZR_tac t := + match t with + | R0 => constr:(0%Z) + | R1 => constr:(1%Z) + | IZR ?u => + match isZcst u with + | true => u + | _ => constr:(InitialRing.NotConstant) + end + | _ => constr:(InitialRing.NotConstant) + end. +Add Field RField : Rfield + (completeness Zeq_bool_complete, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]). diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 3ae2d45f32..8f065f5282 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -9,6 +9,8 @@ open Util open Names open Globnames +open Glob_term +open Bigint (* Poor's man DECLARE PLUGIN *) let __coq_plugin_name = "r_syntax_plugin" @@ -17,95 +19,105 @@ let () = Mltop.add_known_module __coq_plugin_name exception Non_closed_number (**********************************************************************) -(* Parsing R via scopes *) +(* Parsing positive via scopes *) (**********************************************************************) -open Glob_term -open Bigint +let binnums = ["Coq";"Numbers";"BinNums"] let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"] -let make_path dir id = Libnames.make_path dir (Id.of_string id) +let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) + +let positive_path = make_path binnums "positive" + +(* TODO: temporary hack *) +let make_kn dir id = Globnames.encode_mind dir id + +let positive_kn = make_kn (make_dir binnums) (Id.of_string "positive") +let glob_positive = IndRef (positive_kn,0) +let path_of_xI = ((positive_kn,0),1) +let path_of_xO = ((positive_kn,0),2) +let path_of_xH = ((positive_kn,0),3) +let glob_xI = ConstructRef path_of_xI +let glob_xO = ConstructRef path_of_xO +let glob_xH = ConstructRef path_of_xH + +let pos_of_bignat dloc x = + let ref_xI = GRef (dloc, glob_xI, None) in + let ref_xH = GRef (dloc, glob_xH, None) in + let ref_xO = GRef (dloc, glob_xO, None) in + let rec pos_of x = + match div2_with_rest x with + | (q,false) -> GApp (dloc, ref_xO,[pos_of q]) + | (q,true) when not (Bigint.equal q zero) -> GApp (dloc,ref_xI,[pos_of q]) + | (q,true) -> ref_xH + in + pos_of x + +(**********************************************************************) +(* Printing positive via scopes *) +(**********************************************************************) + +let rec bignat_of_pos = function + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) + | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one + | _ -> raise Non_closed_number + +(**********************************************************************) +(* Parsing Z via scopes *) +(**********************************************************************) +let z_path = make_path binnums "Z" +let z_kn = make_kn (make_dir binnums) (Id.of_string "Z") +let glob_z = IndRef (z_kn,0) +let path_of_ZERO = ((z_kn,0),1) +let path_of_POS = ((z_kn,0),2) +let path_of_NEG = ((z_kn,0),3) +let glob_ZERO = ConstructRef path_of_ZERO +let glob_POS = ConstructRef path_of_POS +let glob_NEG = ConstructRef path_of_NEG + +let z_of_int dloc n = + if not (Bigint.equal n zero) then + let sgn, n = + if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in + GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n]) + else + GRef (dloc, glob_ZERO, None) + +(**********************************************************************) +(* Printing Z via scopes *) +(**********************************************************************) + +let bigint_of_z = function + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) + | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero + | _ -> raise Non_closed_number + +(**********************************************************************) +(* Parsing R via scopes *) +(**********************************************************************) + +let rdefinitions = ["Coq";"Reals";"Rdefinitions"] let r_path = make_path rdefinitions "R" (* TODO: temporary hack *) let make_path dir id = Globnames.encode_con dir (Id.of_string id) -let r_kn = make_path rdefinitions "R" -let glob_R = ConstRef r_kn -let glob_R1 = ConstRef (make_path rdefinitions "R1") -let glob_R0 = ConstRef (make_path rdefinitions "R0") -let glob_Ropp = ConstRef (make_path rdefinitions "Ropp") -let glob_Rplus = ConstRef (make_path rdefinitions "Rplus") -let glob_Rmult = ConstRef (make_path rdefinitions "Rmult") - -let two = mult_2 one -let three = add_1 two -let four = mult_2 two - -(* Unary representation of strictly positive numbers *) -let rec small_r dloc n = - if equal one n then GRef (dloc, glob_R1, None) - else GApp(dloc,GRef (dloc,glob_Rplus, None), - [GRef (dloc, glob_R1, None);small_r dloc (sub_1 n)]) - -let r_of_posint dloc n = - let r1 = GRef (dloc, glob_R1, None) in - let r2 = small_r dloc two in - let rec r_of_pos n = - if less_than n four then small_r dloc n - else - let (q,r) = div2_with_rest n in - let b = GApp(dloc,GRef(dloc,glob_Rmult,None),[r2;r_of_pos q]) in - if r then GApp(dloc,GRef(dloc,glob_Rplus,None),[r1;b]) else b in - if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0,None) +let glob_IZR = ConstRef (make_path (make_dir rdefinitions) "IZR") let r_of_int dloc z = - if is_strictly_neg z then - GApp (dloc, GRef(dloc,glob_Ropp,None), [r_of_posint dloc (neg z)]) - else - r_of_posint dloc z + GApp (dloc, GRef(dloc,glob_IZR,None), [z_of_int dloc z]) (**********************************************************************) (* Printing R via scopes *) (**********************************************************************) -let bignat_of_r = -(* for numbers > 1 *) -let rec bignat_of_pos = function - (* 1+1 *) - | GApp (_,GRef (_,p,_), [GRef (_,o1,_); GRef (_,o2,_)]) - when Globnames.eq_gr p glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 -> two - (* 1+(1+1) *) - | GApp (_,GRef (_,p1,_), [GRef (_,o1,_); - GApp(_,GRef (_,p2,_),[GRef(_,o2,_);GRef(_,o3,_)])]) - when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rplus && - Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 && Globnames.eq_gr o3 glob_R1 -> three - (* (1+1)*b *) - | GApp (_,GRef (_,p,_), [a; b]) when Globnames.eq_gr p glob_Rmult -> - if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; - mult_2 (bignat_of_pos b) - (* 1+(1+1)*b *) - | GApp (_,GRef (_,p1,_), [GRef (_,o,_); GApp (_,GRef (_,p2,_),[a;b])]) - when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rmult && Globnames.eq_gr o glob_R1 -> - if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; - add_1 (mult_2 (bignat_of_pos b)) - | _ -> raise Non_closed_number -in -let bignat_of_r = function - | GRef (_,a,_) when Globnames.eq_gr a glob_R0 -> zero - | GRef (_,a,_) when Globnames.eq_gr a glob_R1 -> one - | r -> bignat_of_pos r -in -bignat_of_r - let bigint_of_r = function - | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_Ropp -> - let n = bignat_of_r a in - if Bigint.equal n zero then raise Non_closed_number; - neg n - | a -> bignat_of_r a + | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_IZR -> + bigint_of_z a + | _ -> raise Non_closed_number let uninterp_r p = try @@ -113,12 +125,9 @@ let uninterp_r p = with Non_closed_number -> None -let mkGRef gr = GRef (Loc.ghost,gr,None) - let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int - (List.map mkGRef - [glob_Ropp;glob_R0;glob_Rplus;glob_Rmult;glob_R1], + ([GRef (Loc.ghost,glob_IZR,None)], uninterp_r, false) diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index a98d529fa0..0e1608a32f 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -78,7 +78,7 @@ Proof. ring. discrR. discrR. - pattern 1 at 3; replace 1 with (/ 1); + replace 1 with (/ 1); [ apply tech7; discrR | apply Rinv_1 ]. replace (An (S x)) with (An (S x + 0)%nat). apply (tech6 (fun i:nat => An (S x + i)%nat) (/ 2)). diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index 7d9fff2764..67584f7759 100644 --- a/theories/Reals/ArithProp.v +++ b/theories/Reals/ArithProp.v @@ -106,7 +106,7 @@ Proof. split. ring. unfold k0; case (Rcase_abs y) as [Hlt|Hge]. - assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; change (IZR 1) with 1; + assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl; unfold Rminus. replace (- ((1 + - IZR (up (x / - y))) * y)) with ((IZR (up (x / - y)) - 1) * y); [ idtac | ring ]. @@ -140,10 +140,10 @@ Proof. rewrite <- Ropp_mult_distr_r_reverse; rewrite (Ropp_inv_permute _ H); elim H0; unfold Rdiv; intros H1 _; exact H1. apply Ropp_neq_0_compat; assumption. - assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; change (IZR 1) with 1; + assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl; cut (0 < y). intro; unfold Rminus; - replace (- ((IZR (up (x / y)) + -1) * y)) with ((1 - IZR (up (x / y))) * y); + replace (- ((IZR (up (x / y)) + -(1)) * y)) with ((1 - IZR (up (x / y))) * y); [ idtac | ring ]. split. apply Rmult_le_reg_l with (/ y). diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v index 4e2a7c3c6e..05911cd539 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -31,9 +31,6 @@ Ltac discrR := try match goal with | |- (?X1 <> ?X2) => - change 2 with (IZR 2); - change 1 with (IZR 1); - change 0 with (IZR 0); repeat rewrite <- plus_IZR || rewrite <- mult_IZR || @@ -52,9 +49,6 @@ Ltac prove_sup0 := end. Ltac omega_sup := - change 2 with (IZR 2); - change 1 with (IZR 1); - change 0 with (IZR 0); repeat rewrite <- plus_IZR || rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; @@ -72,9 +66,6 @@ Ltac prove_sup := end. Ltac Rcompute := - change 2 with (IZR 2); - change 1 with (IZR 1); - change 0 with (IZR 0); repeat rewrite <- plus_IZR || rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index 569518f7b8..e9de24898e 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -439,20 +439,16 @@ Proof. repeat rewrite <- Rmult_assoc. rewrite <- Rinv_r_sym. rewrite Rmult_1_l. - replace (INR N * INR N) with (Rsqr (INR N)); [ idtac | reflexivity ]. - rewrite Rmult_assoc. - rewrite Rmult_comm. - replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ]. + change 4 with (Rsqr 2). rewrite <- Rsqr_mult. apply Rsqr_incr_1. - replace 2 with (INR 2). - rewrite <- mult_INR; apply H1. - reflexivity. + change 2 with (INR 2). + rewrite Rmult_comm, <- mult_INR; apply H1. left; apply lt_INR_0; apply H. left; apply Rmult_lt_0_compat. - prove_sup0. apply lt_INR_0; apply div2_not_R0. apply lt_n_S; apply H. + now apply IZR_lt. cut (1 < S N)%nat. intro; unfold Rsqr; apply prod_neq_R0; apply not_O_INR; intro; assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4; diff --git a/theories/Reals/Machin.v b/theories/Reals/Machin.v index 19db476fde..2d2385703b 100644 --- a/theories/Reals/Machin.v +++ b/theories/Reals/Machin.v @@ -53,7 +53,7 @@ assert (-(PI/4) <= atan x). destruct xm1 as [xm1 | xm1]. rewrite <- atan_1, <- atan_opp; apply Rlt_le, atan_increasing. assumption. - solve[rewrite <- xm1, atan_opp, atan_1; apply Rle_refl]. + solve[rewrite <- xm1; change (-1) with (-(1)); rewrite atan_opp, atan_1; apply Rle_refl]. assert (-(PI/4) < atan y). rewrite <- atan_1, <- atan_opp; apply atan_increasing. assumption. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 6860773270..7cd4c00c78 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -1812,7 +1812,7 @@ Qed. (**********) Lemma succ_IZR : forall n:Z, IZR (Z.succ n) = IZR n + 1. Proof. - intro; change 1 with (IZR 1); unfold Z.succ; apply plus_IZR. + intro; unfold Z.succ; apply plus_IZR. Qed. (**********) diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index d0f9aea28a..e9b1762af8 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -92,7 +92,7 @@ Proof. auto with zarith real. (*inf a 1*) cut (r - IZR (up r) < 0). - rewrite <- Z_R_minus; change (IZR 1) with 1; intro; unfold Rminus; + rewrite <- Z_R_minus; simpl; intro; unfold Rminus; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; fold (r - IZR (up r)); rewrite Ropp_involutive; elim (Rplus_ne 1); intros a b; pattern 1 at 2; @@ -112,21 +112,12 @@ Lemma base_Int_part : Proof. intro; unfold Int_part; elim (archimed r); intros. split; rewrite <- (Z_R_minus (up r) 1); simpl. - generalize (Rle_minus (IZR (up r) - r) 1 H0); intro; unfold Rminus in H1; - rewrite (Rplus_assoc (IZR (up r)) (- r) (-1)) in H1; - rewrite (Rplus_comm (- r) (-1)) in H1; - rewrite <- (Rplus_assoc (IZR (up r)) (-1) (- r)) in H1; - fold (IZR (up r) - 1) in H1; fold (IZR (up r) - 1 - r) in H1; - apply Rminus_le; auto with zarith real. - generalize (Rplus_gt_compat_l (-1) (IZR (up r)) r H); intro; - rewrite (Rplus_comm (-1) (IZR (up r))) in H1; - generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1); - intro; clear H H0 H1; rewrite (Rplus_comm (- r) (IZR (up r) + -1)) in H2; - fold (IZR (up r) - 1) in H2; fold (IZR (up r) - 1 - r) in H2; - rewrite (Rplus_comm (- r) (-1 + r)) in H2; - rewrite (Rplus_assoc (-1) r (- r)) in H2; rewrite (Rplus_opp_r r) in H2; - elim (Rplus_ne (-1)); intros a b; rewrite a in H2; - clear a b; auto with zarith real. + apply Rminus_le. + replace (IZR (up r) - 1 - r) with (IZR (up r) - r - 1) by ring. + now apply Rle_minus. + apply Rminus_gt. + replace (IZR (up r) - 1 - r - -1) with (IZR (up r) - r) by ring. + now apply Rgt_minus. Qed. (**********) @@ -240,7 +231,6 @@ Proof. clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; cut (1 = IZR 1); auto with zarith real. - intro; rewrite H1 in H; clear H1; rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H; generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); intros; clear H H0; unfold Int_part at 1; @@ -324,12 +314,12 @@ Proof. rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0; elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; clear a b; rewrite <- (Rplus_opp_l 1) in H0; - rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1) + rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-(1)) 1) in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; - cut (1 = IZR 1); auto with zarith real. - intro; rewrite H1 in H; rewrite H1 in H0; clear H1; + auto with zarith real. + change (_ + -1) with (IZR (Int_part r1 - Int_part r2) - 1) in H; rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H; rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0; rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0; @@ -376,7 +366,7 @@ Proof. rewrite (Ropp_involutive (IZR 1)); rewrite (Ropp_involutive (IZR (Int_part r2))); rewrite (Ropp_plus_distr (IZR (Int_part r1))); - rewrite (Ropp_involutive (IZR (Int_part r2))); change (IZR 1) with 1; + rewrite (Ropp_involutive (IZR (Int_part r2))); simpl; rewrite <- (Rplus_assoc (r1 + - r2) (- IZR (Int_part r1) + IZR (Int_part r2)) 1) ; rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2))); @@ -442,9 +432,9 @@ Proof. in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0; elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; clear a b; + change 2 with (1 + 1) in H0; rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0; - cut (1 = IZR 1); auto with zarith real. - intro; rewrite H1 in H0; rewrite H1 in H; clear H1; + auto with zarith real. rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H; @@ -509,7 +499,6 @@ Proof. intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1); auto with zarith real. - intro; rewrite H in H1; clear H; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1; @@ -536,7 +525,7 @@ Proof. rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))); unfold Rminus; rewrite - (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-1)) + (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-(1))) ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1); trivial with zarith real. Qed. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index 5c975c3f54..0c1e0b7e86 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -420,10 +420,10 @@ Proof. rewrite (Rmult_comm (/ a)). rewrite Rmult_assoc. rewrite <- Rinv_mult_distr. - replace (2 * (2 * a) * a) with (Rsqr (2 * a)). + replace (4 * a * a) with (Rsqr (2 * a)). reflexivity. ring_Rsqr. - rewrite <- Rmult_assoc; apply prod_neq_R0; + apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. apply (cond_nonzero a). assumption. diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index 0254218c44..27cb356a09 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -88,17 +88,11 @@ Proof. right; unfold Rdiv. repeat rewrite Rabs_mult. rewrite Rabs_Rinv; discrR. - replace (Rabs 8) with 8. - replace 8 with 8; [ idtac | ring ]. - rewrite Rinv_mult_distr; [ idtac | discrR | discrR ]. - replace (2 * / Rabs (f2 x) * (Rabs eps * Rabs (f2 x) * (/ 2 * / 4))) with - (Rabs eps * / 4 * (2 * / 2) * (Rabs (f2 x) * / Rabs (f2 x))); - [ idtac | ring ]. - replace (Rabs eps) with eps. - repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption). - ring. - symmetry ; apply Rabs_right; left; assumption. - symmetry ; apply Rabs_right; left; prove_sup. + rewrite (Rabs_pos_eq 8) by now apply IZR_le. + rewrite (Rabs_pos_eq eps). + field. + now apply Rabs_no_R0. + now apply Rlt_le. Qed. Lemma maj_term2 : diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v index 4e88714d61..d4597aebaf 100644 --- a/theories/Reals/Ranalysis3.v +++ b/theories/Reals/Ranalysis3.v @@ -201,8 +201,8 @@ Proof. apply Rabs_pos_lt. unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc. repeat apply prod_neq_R0; try assumption. - red; intro; rewrite H15 in H6; elim (Rlt_irrefl _ H6). - apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption. + now apply Rgt_not_eq. + apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption]. apply H13. split. apply D_x_no_cond; assumption. @@ -213,8 +213,7 @@ Proof. red; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6). assumption. assumption. - apply Rinv_neq_0_compat; repeat apply prod_neq_R0; - [ discrR | discrR | discrR | assumption ]. + apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption]. (***********************************) (* Third case *) (* (f1 x)<>0 l1=0 l2=0 *) @@ -224,11 +223,11 @@ Proof. elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); [ idtac | apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc; - repeat apply prod_neq_R0; + repeat apply prod_neq_R0 ; [ assumption | assumption - | red; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6) - | apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption ] ]. + | now apply Rgt_not_eq + | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. intros alp_f2d H12. cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)). intro. @@ -295,8 +294,10 @@ Proof. elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); [ idtac | apply Rabs_pos_lt; unfold Rsqr, Rdiv; - repeat rewrite Rinv_mult_distr; repeat apply prod_neq_R0; - try assumption || discrR ]. + repeat apply prod_neq_R0 ; + [ assumption.. + | now apply Rgt_not_eq + | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. intros alp_f2d H11. assert (H12 := derivable_continuous_pt _ _ X). unfold continuity_pt in H12. @@ -380,15 +381,9 @@ Proof. repeat apply prod_neq_R0; try assumption. red; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; assumption. apply Rinv_neq_0_compat; assumption. discrR. - discrR. - discrR. - discrR. - discrR. apply prod_neq_R0; [ discrR | assumption ]. elim H13; intros. apply H19. @@ -408,16 +403,9 @@ Proof. repeat apply prod_neq_R0; try assumption. red; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; assumption. apply Rinv_neq_0_compat; assumption. apply prod_neq_R0; [ discrR | assumption ]. - red; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6). - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; assumption. (***********************************) (* Fifth case *) (* (f1 x)<>0 l1<>0 l2=0 *) diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index d172139f56..f9da88aad4 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -249,8 +249,10 @@ assert (Sublemma : forall x y lb ub, lb <= x <= ub /\ lb <= y <= ub -> lb <= (x+ split. replace lb with ((lb + lb) * /2) by field. unfold Rdiv ; apply Rmult_le_compat_r ; intuition. + now apply Rlt_le, Rinv_0_lt_compat, IZR_lt. replace ub with ((ub + ub) * /2) by field. unfold Rdiv ; apply Rmult_le_compat_r ; intuition. + now apply Rlt_le, Rinv_0_lt_compat, IZR_lt. intros x y P N x_lt_y. induction N. simpl ; intuition. @@ -1030,6 +1032,7 @@ intros x ub lb lb_lt_x x_lt_ub. assert (T : 0 < ub - lb). fourier. unfold Rdiv ; apply Rlt_mult_inv_pos ; intuition. +now apply IZR_lt. Qed. Definition mkposreal_lb_ub (x lb ub:R) (lb_lt_x:lb -replace a with ((- IZR 3 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * - IZR (Z.of_nat (fact 4)) + - IZR 3 ^ 4 * IZR 2 ^ 2 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * - IZR (Z.of_nat (fact 6)) - - IZR 3 ^ 2 * IZR 2 ^ 4 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 4)) * - IZR (Z.of_nat (fact 6)) + - IZR 2 ^ 6 * IZR (Z.of_nat (fact 2)) * IZR (Z.of_nat (fact 4)) * - IZR (Z.of_nat (fact 6))) / - (IZR 2 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * - IZR (Z.of_nat (fact 4)) * IZR (Z.of_nat (fact 6))));[ | field; - repeat apply conj;((rewrite <- INR_IZR_INZ; apply INR_fact_neq_0) || - (apply Rgt_not_eq; apply (IZR_lt 0); reflexivity)) ] -end. -rewrite !fact_simpl, !Nat2Z.inj_mul; simpl Z.of_nat. -unfold Rdiv; apply Rmult_lt_0_compat. -unfold Rminus; rewrite !pow_IZR, <- !opp_IZR, <- !mult_IZR, <- !opp_IZR, - <- !plus_IZR; apply (IZR_lt 0); reflexivity. -apply Rinv_0_lt_compat; rewrite !pow_IZR, <- !mult_IZR; apply (IZR_lt 0). -reflexivity. +unfold INR. +simpl. +field_simplify. +change (0 */ 1 < 9925632 / 141557760). +rewrite Rmult_0_l. +apply Rdiv_lt_0_compat ; now apply IZR_lt. Qed. Lemma PI2_1 : 1 < PI/2. @@ -502,11 +482,11 @@ split. rewrite (Rmult_comm (-1)); simpl ((/(Rabs y + 1)) ^ 0). unfold Rdiv; rewrite Rinv_1, !Rmult_assoc, <- !Rmult_plus_distr_l. apply tmp;[assumption | ]. - rewrite Rplus_assoc, Rmult_1_l; pattern 1 at 3; rewrite <- Rplus_0_r. + rewrite Rplus_assoc, Rmult_1_l; pattern 1 at 2; rewrite <- Rplus_0_r. apply Rplus_lt_compat_l. rewrite <- Rmult_assoc. match goal with |- (?a * (-1)) + _ < 0 => - rewrite <- (Rplus_opp_l a), Ropp_mult_distr_r_reverse, Rmult_1_r + rewrite <- (Rplus_opp_l a); change (-1) with (-(1)); rewrite Ropp_mult_distr_r_reverse, Rmult_1_r end. apply Rplus_lt_compat_l. assert (0 < u ^ 2) by (apply pow_lt; assumption). @@ -1078,8 +1058,9 @@ apply Rlt_not_eq; apply Rle_lt_trans with 0;[ | apply Rlt_0_1]. assert (t := pow2_ge_0 x); fourier. replace (1 + x ^ 2) with (1 - - (x ^ 2)) by ring; rewrite <- (tech3 _ n dif). apply sum_eq; unfold tg_alt, Datan_seq; intros i _. -rewrite pow_mult, <- Rpow_mult_distr, Ropp_mult_distr_l_reverse, Rmult_1_l. -reflexivity. +rewrite pow_mult, <- Rpow_mult_distr. +f_equal. +ring. Qed. Lemma Datan_seq_increasing : forall x y n, (n > 0)%nat -> 0 <= x < y -> Datan_seq x n < Datan_seq y n. @@ -1167,6 +1148,7 @@ assert (tool : forall a b, a / b - /b = (-1 + a) /b). reflexivity. set (u := 1 + x ^ 2); rewrite tool; unfold Rminus; rewrite <- Rplus_assoc. unfold Rdiv, u. +change (-1) with (-(1)). rewrite Rplus_opp_l, Rplus_0_l, Ropp_mult_distr_l_reverse, Rabs_Ropp. rewrite Rabs_mult; clear tool u. assert (tool : forall k, Rabs ((-x ^ 2) ^ k) = Rabs ((x ^ 2) ^ k)). diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index e9098104ce..7f9db3b18f 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -114,35 +114,6 @@ Fixpoint INR (n:nat) : R := Arguments INR n%nat. -(**********************************************************) -(** * Injection from [Z] to [R] *) -(**********************************************************) - -(* compact representation for 2*p *) -Fixpoint IPR_2 (p:positive) : R := - match p with - | xH => 1 + 1 - | xO p => (1 + 1) * IPR_2 p - | xI p => (1 + 1) * (1 + IPR_2 p) - end. - -Definition IPR (p:positive) : R := - match p with - | xH => 1 - | xO p => IPR_2 p - | xI p => 1 + IPR_2 p - end. -Arguments IPR p%positive : simpl never. - -(**********) -Definition IZR (z:Z) : R := - match z with - | Z0 => 0 - | Zpos n => IPR n - | Zneg n => - IPR n - end. -Arguments IZR z%Z : simpl never. - (**********************************************************) (** * [R] Archimedean *) (**********************************************************) diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index fe5402e6e3..df16624976 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -451,20 +451,16 @@ Qed. Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x. Proof. - intro; cut (- x = -1 * x). - intros; rewrite H. + intro; replace (-x) with (-1 * x) by ring. rewrite Rabs_mult. - cut (Rabs (-1) = 1). - intros; rewrite H0. - ring. + replace (Rabs (-1)) with 1. + apply Rmult_1_l. unfold Rabs; case (Rcase_abs (-1)). intro; ring. - intro H0; generalize (Rge_le (-1) 0 H0); intros. - generalize (Ropp_le_ge_contravar 0 (-1) H1). - rewrite Ropp_involutive; rewrite Ropp_0. - intro; generalize (Rgt_not_le 1 0 Rlt_0_1); intro; generalize (Rge_le 0 1 H2); - intro; exfalso; auto. - ring. + rewrite <- Ropp_0. + intro H0; apply Ropp_ge_cancel in H0. + elim (Rge_not_lt _ _ H0). + apply Rlt_0_1. Qed. (*********) diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index f3f8f74098..cb5dea93ad 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -69,3 +69,32 @@ Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope. Notation "x <= y < z" := (x <= y /\ y < z) : R_scope. Notation "x < y < z" := (x < y /\ y < z) : R_scope. Notation "x < y <= z" := (x < y /\ y <= z) : R_scope. + +(**********************************************************) +(** * Injection from [Z] to [R] *) +(**********************************************************) + +(* compact representation for 2*p *) +Fixpoint IPR_2 (p:positive) : R := + match p with + | xH => R1 + R1 + | xO p => (R1 + R1) * IPR_2 p + | xI p => (R1 + R1) * (R1 + IPR_2 p) + end. + +Definition IPR (p:positive) : R := + match p with + | xH => R1 + | xO p => IPR_2 p + | xI p => R1 + IPR_2 p + end. +Arguments IPR p%positive : simpl never. + +(**********) +Definition IZR (z:Z) : R := + match z with + | Z0 => R0 + | Zpos n => IPR n + | Zneg n => - IPR n + end. +Arguments IZR z%Z : simpl never. diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index 0a49d49831..99acdd0a1c 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -416,8 +416,9 @@ Proof. simpl; apply Rabs_R1. replace (S n) with (n + 1)%nat; [ rewrite pow_add | ring ]. rewrite Rabs_mult. - rewrite Hrecn; rewrite Rmult_1_l; simpl; rewrite Rmult_1_r; - rewrite Rabs_Ropp; apply Rabs_R1. + rewrite Hrecn; rewrite Rmult_1_l; simpl; rewrite Rmult_1_r. + change (-1) with (-(1)). + rewrite Rabs_Ropp; apply Rabs_R1. Qed. Lemma pow_mult : forall (x:R) (n1 n2:nat), x ^ (n1 * n2) = (x ^ n1) ^ n2. diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v index 7bd6c916d0..b9a9458c8d 100644 --- a/theories/Reals/Rlogic.v +++ b/theories/Reals/Rlogic.v @@ -82,7 +82,7 @@ assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). apply Rle_lt_trans with (1 := H1l). apply archimed. rewrite minus_IZR. - change (IZR 2) with 2%R. + simpl. ring. assert (Hl': (/ (INR (S N) + 1) < l)%R). rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq. diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v index 791718a450..f331bb2039 100644 --- a/theories/Reals/Rpow_def.v +++ b/theories/Reals/Rpow_def.v @@ -10,6 +10,6 @@ Require Import Rdefinitions. Fixpoint pow (r:R) (n:nat) : R := match n with - | O => R1 + | O => 1 | S n => Rmult r (pow r n) end. diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index a053c349e4..f62ed2a6c1 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -488,12 +488,9 @@ Proof. rewrite Rinv_r. apply exp_lt_inv. apply Rle_lt_trans with (1 := exp_le_3). - change (3 < 2 ^R 2). + change (3 < 2 ^R (1 + 1)). repeat rewrite Rpower_plus; repeat rewrite Rpower_1. - repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l; - repeat rewrite Rmult_1_l. - pattern 3 at 1; rewrite <- Rplus_0_r; replace (2 + 2) with (3 + 1); - [ apply Rplus_lt_compat_l; apply Rlt_0_1 | ring ]. + now apply (IZR_lt 3 4). prove_sup0. discrR. Qed. @@ -715,7 +712,7 @@ Definition arcsinh x := ln (x + sqrt (x ^ 2 + 1)). Lemma arcsinh_sinh : forall x, arcsinh (sinh x) = x. intros x; unfold sinh, arcsinh. assert (Rminus_eq_0 : forall r, r - r = 0) by (intros; ring). -pattern 1 at 5; rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus. +rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus. rewrite exp_plus. match goal with |- context[sqrt ?a] => replace a with (((exp x + exp(-x))/2)^2) by field diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v index 744fd66416..c6b0c3f37a 100644 --- a/theories/Reals/Rseries.v +++ b/theories/Reals/Rseries.v @@ -207,7 +207,7 @@ Section sequence. assert (Rabs (/2) < 1). rewrite Rabs_pos_eq. - rewrite <- Rinv_1 at 3. + rewrite <- Rinv_1. apply Rinv_lt_contravar. rewrite Rmult_1_l. now apply (IZR_lt 0 2). diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index 6b17540213..48dbd1944a 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -182,13 +182,11 @@ destruct (pre_cos_bound _ 0 lo up) as [_ upper]. apply Rle_lt_trans with (1 := upper). apply Rlt_le_trans with (2 := lower). unfold cos_approx, sin_approx. -simpl sum_f_R0; change 7 with (IZR 7). -change 8 with (IZR 8). +simpl sum_f_R0. unfold cos_term, sin_term; simpl fact; rewrite !INR_IZR_INZ. -simpl plus; simpl mult. -field_simplify; - try (repeat apply conj; apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity). -unfold Rminus; rewrite !pow_IZR, <- !mult_IZR, <- !opp_IZR, <- ?plus_IZR. +simpl plus; simpl mult; simpl Z_of_nat. +field_simplify. +change (8073344 / 12582912 < 18760 / 24576). match goal with |- IZR ?a / ?b < ?c / ?d => apply Rmult_lt_reg_r with d;[apply (IZR_lt 0); reflexivity | @@ -323,6 +321,7 @@ Lemma sin_PI : sin PI = 0. Proof. assert (H := sin2_cos2 PI). rewrite cos_PI in H. + change (-1) with (-(1)) in H. rewrite <- Rsqr_neg in H. rewrite Rsqr_1 in H. cut (Rsqr (sin PI) = 0). @@ -533,9 +532,8 @@ Qed. Lemma sin_PI_x : forall x:R, sin (PI - x) = sin x. Proof. - intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI; rewrite Rmult_0_l; - unfold Rminus in |- *; rewrite Rplus_0_l; rewrite Ropp_mult_distr_l_reverse; - rewrite Ropp_involutive; apply Rmult_1_l. + intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI. + ring. Qed. Lemma sin_period : forall (x:R) (k:nat), sin (x + 2 * INR k * PI) = sin x. @@ -593,9 +591,9 @@ Proof. generalize (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1) (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H))); - rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0; + rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0. generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0); - repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; + repeat rewrite <- Rplus_assoc; change (-1) with (-(1)); rewrite Rplus_opp_l; rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); @@ -603,6 +601,7 @@ Proof. auto with real. cut (sin x < -1). intro; generalize (Ropp_lt_gt_contravar (sin x) (-1) H); + change (-1) with (-(1)); rewrite Ropp_involutive; clear H; intro; generalize (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1) @@ -610,7 +609,7 @@ Proof. rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0; rewrite sin2 in H0; unfold Rminus in H0; generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0); - repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; + rewrite <- Rplus_assoc; change (-1) with (-(1)); rewrite Rplus_opp_l; rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); @@ -712,17 +711,16 @@ Proof. do 2 rewrite fact_simpl; do 2 rewrite mult_INR. repeat rewrite <- Rmult_assoc. rewrite <- (Rmult_comm (INR (fact (2 * n + 1)))). - rewrite Rmult_assoc. apply Rmult_lt_compat_l. apply lt_INR_0; apply neq_O_lt. assert (H2 := fact_neq_0 (2 * n + 1)). red in |- *; intro; elim H2; symmetry in |- *; assumption. do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; set (x := INR n); unfold INR in |- *. - replace ((2 * x + 1 + 1 + 1) * (2 * x + 1 + 1)) with (4 * x * x + 10 * x + 6); + replace (((1 + 1) * x + 1 + 1 + 1) * ((1 + 1) * x + 1 + 1)) with (4 * x * x + 10 * x + 6); [ idtac | ring ]. - apply Rplus_lt_reg_l with (-4); rewrite Rplus_opp_l; - replace (-4 + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2); + apply Rplus_lt_reg_l with (-(4)); rewrite Rplus_opp_l; + replace (-(4) + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2); [ idtac | ring ]. apply Rplus_le_lt_0_compat. cut (0 <= x). @@ -767,7 +765,7 @@ Proof. unfold Rdiv in |- *; pattern PI at 2 in |- *; rewrite <- Rmult_1_r. apply Rmult_lt_compat_l. apply PI_RGT_0. - pattern 1 at 3 in |- *; rewrite <- Rinv_1; apply Rinv_lt_contravar. + rewrite <- Rinv_1; apply Rinv_lt_contravar. rewrite Rmult_1_l; prove_sup0. pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1. @@ -1715,7 +1713,7 @@ Proof. rewrite H5. rewrite mult_INR. simpl in |- *. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. apply sin_0. rewrite H5. @@ -1725,7 +1723,7 @@ Proof. rewrite Rmult_1_l; rewrite sin_plus. rewrite sin_PI. rewrite Rmult_0_r. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. rewrite sin_0; ring. apply le_IZR. @@ -1747,7 +1745,7 @@ Proof. rewrite H5. rewrite mult_INR. simpl in |- *. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. rewrite sin_0; ring. rewrite H5. @@ -1757,7 +1755,7 @@ Proof. rewrite Rmult_1_l; rewrite sin_plus. rewrite sin_PI. rewrite Rmult_0_r. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. rewrite sin_0; ring. apply le_IZR. @@ -1798,7 +1796,7 @@ Lemma cos_eq_0_0 (x:R) : Proof. rewrite cos_sin. intros Hx. destruct (sin_eq_0_0 (PI/2 + x) Hx) as (k,Hk). clear Hx. - exists (k-1)%Z. rewrite <- Z_R_minus; change (IZR 1) with 1. + exists (k-1)%Z. rewrite <- Z_R_minus; simpl. symmetry in Hk. field_simplify [Hk]. field. Qed. diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index a5092d22dc..092bc30d07 100644 --- a/theories/Reals/Rtrigo_alt.v +++ b/theories/Reals/Rtrigo_alt.v @@ -320,7 +320,7 @@ Proof. (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)). unfold Rminus; rewrite Ropp_plus_distr; rewrite Ropp_involutive; repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1); - rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc; + rewrite (Rplus_comm (-(1))); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp; rewrite Ropp_plus_distr; rewrite Ropp_involutive; unfold Rminus in H6; apply H6. @@ -367,10 +367,10 @@ Proof. reflexivity. ring. intro; elim H2; intros; split. - apply Rplus_le_reg_l with (-1). + apply Rplus_le_reg_l with (-(1)). rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite (Rplus_comm (-1)); apply H3. - apply Rplus_le_reg_l with (-1). + apply Rplus_le_reg_l with (-(1)). rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite (Rplus_comm (-1)); apply H4. unfold cos_term; simpl; unfold Rdiv; rewrite Rinv_1; diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v index 4a1e3179c6..d9c18d3587 100644 --- a/theories/Reals/Rtrigo_reg.v +++ b/theories/Reals/Rtrigo_reg.v @@ -251,6 +251,7 @@ Proof. exists delta; intros. rewrite Rplus_0_l; replace (cos h - cos 0) with (-2 * Rsqr (sin (h / 2))). unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. + change (-2) with (-(2)). unfold Rdiv; do 2 rewrite Ropp_mult_distr_l_reverse. rewrite Rabs_Ropp. replace (2 * Rsqr (sin (h * / 2)) * / h) with @@ -266,7 +267,7 @@ Proof. apply Rabs_pos. assert (H9 := SIN_bound (h / 2)). unfold Rabs; case (Rcase_abs (sin (h / 2))); intro. - pattern 1 at 3; rewrite <- (Ropp_involutive 1). + rewrite <- (Ropp_involutive 1). apply Ropp_le_contravar. elim H9; intros; assumption. elim H9; intros; assumption. diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v index d43baee8cd..12d5cbbf0f 100644 --- a/theories/Reals/Sqrt_reg.v +++ b/theories/Reals/Sqrt_reg.v @@ -21,6 +21,7 @@ Proof. destruct (total_order_T h 0) as [[Hlt|Heq]|Hgt]. repeat rewrite Rabs_left. unfold Rminus; do 2 rewrite <- (Rplus_comm (-1)). + change (-1) with (-(1)). do 2 rewrite Ropp_plus_distr; rewrite Ropp_involutive; apply Rplus_le_compat_l. apply Ropp_le_contravar; apply sqrt_le_1. -- cgit v1.2.3 From d6ced637d9b7acabef2ccc9e761ec149bc7c93da Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sun, 5 Mar 2017 21:46:26 +0100 Subject: Mark ring morphisms as opaque. This prevents Coq from unfolding IZR in ring_simplify and field_simplify. This is a change of behavior for users of morphism rings, so they might have to pass the postprocess option to Add Ring/Field if they want morphisms to be automatically expanded. There are two predefined morphisms in the standard library: IDphi (when polynomial coefficients have the same type as constants) and gen_phiZ (when the only available constants are 0 and 1). They are hardcoded as transparent. --- plugins/setoid_ring/newring.ml | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 2a3d66934b..87ee666605 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -323,11 +323,13 @@ let _ = add_map "ring" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); + my_reference "IDphi", (function _->Eval); + my_reference "gen_phiZ", (function _->Eval); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); pol_cst "Pphi_pow", - (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); + (function -1|8|9|10|13|15|17->Eval|11|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot)]) @@ -756,12 +758,14 @@ let _ = add_map "field" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); + my_reference "IDphi", (function _->Eval); + my_reference "gen_phiZ", (function _->Eval); (* display_linear: evaluate polynomials and coef operations, protect field operations and make recursive call on the var map *) my_reference "display_linear", (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); my_reference "display_pow_linear", - (function -1|9|10|11|12|14|16|18|19->Eval|17->Rec|_->Prot); + (function -1|9|10|11|14|16|18|19->Eval|12|17->Rec|_->Prot); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); @@ -778,9 +782,11 @@ let _ = add_map "field_cond" (map_without_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); - (* PCond: evaluate morphism and denum list, protect ring + my_reference "IDphi", (function _->Eval); + my_reference "gen_phiZ", (function _->Eval); + (* PCond: evaluate denum list, protect ring operations and make recursive call on the var map *) - my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);; + my_reference "PCond", (function -1|11|14->Eval|9|13->Rec|_->Prot)]);; let _ = Redexpr.declare_reduction "simpl_field_expr" -- cgit v1.2.3 From 4e6fa17a3ef0b8d12cb8d55305f302338589ad1c Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sun, 5 Mar 2017 21:50:19 +0100 Subject: Make IZR a morphism for field. There are now two field structures for R: one in RealField and one in RIneq. The first one is used to prove that IZR is a morphism which is needed to define the second one. --- theories/Reals/RIneq.v | 25 +++++++++++++++++++++++++ theories/Reals/Ratan.v | 4 ++-- theories/Reals/Rtrigo1.v | 3 +-- 3 files changed, 28 insertions(+), 4 deletions(-) diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 7cd4c00c78..dd2108159f 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -2016,6 +2016,31 @@ Proof. [ apply not_0_INR; discriminate | unfold INR; ring ]. Qed. +Lemma R_rm : ring_morph + R0 R1 Rplus Rmult Rminus Ropp eq + 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool IZR. +Proof. +constructor ; try easy. +exact plus_IZR. +exact minus_IZR. +exact mult_IZR. +exact opp_IZR. +intros x y H. +apply f_equal. +now apply Zeq_bool_eq. +Qed. + +Lemma Zeq_bool_IZR x y : + IZR x = IZR y -> Zeq_bool x y = true. +Proof. +intros H. +apply Zeq_is_eq_bool. +now apply eq_IZR. +Qed. + +Add Field RField : Rfield + (completeness Zeq_bool_IZR, morphism R_rm, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]). + (*********************************************************) (** ** Other rules about < and <= *) (*********************************************************) diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v index 3e5362efec..e438750df0 100644 --- a/theories/Reals/Ratan.v +++ b/theories/Reals/Ratan.v @@ -319,10 +319,10 @@ apply PI2_lower_bound;[split; fourier | ]. destruct (pre_cos_bound (3/2) 1) as [t _]; [fourier | fourier | ]. apply Rlt_le_trans with (2 := t); clear t. unfold cos_approx; simpl; unfold cos_term. -unfold INR. +rewrite !INR_IZR_INZ. simpl. field_simplify. -change (0 */ 1 < 9925632 / 141557760). +unfold Rdiv. rewrite Rmult_0_l. apply Rdiv_lt_0_compat ; now apply IZR_lt. Qed. diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index 48dbd1944a..17b9677eff 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -186,7 +186,6 @@ simpl sum_f_R0. unfold cos_term, sin_term; simpl fact; rewrite !INR_IZR_INZ. simpl plus; simpl mult; simpl Z_of_nat. field_simplify. -change (8073344 / 12582912 < 18760 / 24576). match goal with |- IZR ?a / ?b < ?c / ?d => apply Rmult_lt_reg_r with d;[apply (IZR_lt 0); reflexivity | @@ -196,7 +195,7 @@ match goal with end. unfold Rdiv; rewrite !Rmult_assoc, Rinv_l, Rmult_1_r; [ | apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity]. -repeat (rewrite <- !plus_IZR || rewrite <- !mult_IZR). +rewrite <- !mult_IZR. apply IZR_lt; reflexivity. Qed. -- cgit v1.2.3 From 4f4b9d04bc59dc1f3b6962b0b077ba274638efc7 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Mon, 13 Mar 2017 10:44:58 +0100 Subject: Document the changes to IZR. --- CHANGES | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/CHANGES b/CHANGES index a7cba9aa4f..0acc2bb950 100644 --- a/CHANGES +++ b/CHANGES @@ -7,7 +7,7 @@ Tactics functional extensionality in H supposed to be a quantified equality until giving a bare equality. -Libraries +Standard Library - New file PropExtensionality.v to explicitly work in the axiomatic context of propositional extensionality. @@ -16,6 +16,12 @@ Libraries Various proof-theoretic characterizations of choice over setoids in file ChoiceFacts.v. +- IZR (Reals) has been changed to produce a compact representation of + integers. As a consequence, IZR is no longer convertible to INR and + lemmas such as INR_IZR_INZ should be used instead. +- Real constants are now represented using IZR rather than R0 and R1; + this might cause rewriting rules to fail to apply to constants. + Changes from V8.6beta1 to V8.6 ============================== -- cgit v1.2.3 From 44b2c7979e1ea3a834f4e9bd2fcd631d568b895e Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 22 Mar 2017 17:17:33 +0100 Subject: [travis] Fix iris-coq build. We need to do a bit of hacking, but it should be fine for the short term. c.f. https://gitlab.mpi-sws.org/FP/iris-coq/issues/83 --- dev/ci/ci-common.sh | 8 ++++++-- dev/ci/ci-iris-coq.sh | 14 +++++++++----- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index c94f150263..2711b7ecaa 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -25,12 +25,16 @@ git_checkout() local _URL=${2} local _DEST=${3} + # Allow an optional 4th argument for the commit + local _COMMIT=${4:-FETCH_HEAD} + local _DEPTH=$(if [ -z "${4}" ]; then echo "--depth 1"; fi) + mkdir -p ${_DEST} ( cd ${_DEST} && \ - if [ ! -d .git ] ; then git clone --depth 1 ${_URL} . ; fi && \ + if [ ! -d .git ] ; then git clone ${_DEPTH} ${_URL} . ; fi && \ echo "Checking out ${_DEST}" && \ git fetch ${_URL} ${_BRANCH} && \ - git checkout FETCH_HEAD && \ + git checkout ${_COMMIT} && \ echo "${_DEST}: `git log -1 --format='%s | %H | %cd | %aN'`" ) } diff --git a/dev/ci/ci-iris-coq.sh b/dev/ci/ci-iris-coq.sh index eb1d1be078..262dd6fa01 100755 --- a/dev/ci/ci-iris-coq.sh +++ b/dev/ci/ci-iris-coq.sh @@ -9,14 +9,18 @@ Iris_CI_DIR=${CI_BUILD_DIR}/iris-coq install_ssreflect -# Setup stdpp +# Setup Iris first, as it is needed to compute the dependencies -git_checkout ${stdpp_CI_BRANCH} ${stdpp_CI_GITURL} ${stdpp_CI_DIR} +git_checkout ${Iris_CI_BRANCH} ${Iris_CI_GITURL} ${Iris_CI_DIR} +read -a IRIS_DEP < ${Iris_CI_DIR}/opam.pins -( cd ${stdpp_CI_DIR} && make -j ${NJOBS} && make install ) +# Setup stdpp +stdpp_CI_GITURL=${IRIS_DEP[1]}.git +stdpp_CI_COMMIT=${IRIS_DEP[2]} -# Setup Iris +git_checkout ${stdpp_CI_BRANCH} ${stdpp_CI_GITURL} ${stdpp_CI_DIR} ${stdpp_CI_COMMIT} -git_checkout ${Iris_CI_BRANCH} ${Iris_CI_GITURL} ${Iris_CI_DIR} +( cd ${stdpp_CI_DIR} && make -j ${NJOBS} && make install ) +# Build iris now ( cd ${Iris_CI_DIR} && make -j ${NJOBS} ) -- cgit v1.2.3 From 947d93a8b7ff0fc7ba23633fcd44820427e29326 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 22 Mar 2017 19:31:18 +0100 Subject: Better compatibility of TACTIC EXTEND AT LEVEL with versions of camlp5. This adds at least support for camlp5 6.14 (in addition to 6.17). --- grammar/tacextend.mlp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index 33ca2c629b..8c0614a7be 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -135,7 +135,7 @@ EXTEND GLOBAL: str_item; str_item: [ [ "TACTIC"; "EXTEND"; s = tac_name; - level = OPT [ "AT"; "LEVEL"; level = INT -> level ]; + level = OPT [ "AT"; UIDENT "LEVEL"; level = INT -> level ]; c = OPT [ "CLASSIFIED"; "BY"; c = LIDENT -> <:expr< $lid:c$ >> ]; OPT "|"; l = LIST1 tacrule SEP "|"; "END" -> -- cgit v1.2.3 From 8c42932d1788c8924844d8fa22419f6fb4401030 Mon Sep 17 00:00:00 2001 From: Paul Steckler Date: Wed, 22 Mar 2017 14:50:23 -0400 Subject: make check not CoqIDE-specific --- ide/ide_slave.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 2ec79dc585..8cadf1a263 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -79,23 +79,23 @@ let is_undo cmd = match cmd with | VernacUndo _ | VernacUndoTo _ -> true | _ -> false -(** Check whether a command is forbidden by CoqIDE *) +(** Check whether a command is forbidden in the IDE *) -let coqide_cmd_checks (loc,ast) = +let ide_cmd_checks (loc,ast) = let user_error s = CErrors.user_err ~loc ~hdr:"CoqIde" (str s) in if is_debug ast then - user_error "Debug mode not available within CoqIDE"; + user_error "Debug mode not available in the IDE"; if is_known_option ast then - Feedback.msg_warning (strbrk"This will not work. Use CoqIDE view menu instead"); + Feedback.msg_warning (strbrk "Set this option from the IDE menu instead"); if Vernac.is_navigation_vernac ast || is_undo ast then - Feedback.msg_warning (strbrk "Rather use CoqIDE navigation instead"); + Feedback.msg_warning (strbrk "Use IDE navigation instead"); if is_query ast then Feedback.msg_warning (strbrk "Query commands should not be inserted in scripts") (** Interpretation (cf. [Ide_intf.interp]) *) let add ((s,eid),(sid,verbose)) = - let newid, rc = Stm.add ~ontop:sid verbose ~check:coqide_cmd_checks eid s in + let newid, rc = Stm.add ~ontop:sid verbose ~check:ide_cmd_checks eid s in let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in (* TODO: the "" parameter is a leftover of the times the protocol * used to include stderr/stdout output. -- cgit v1.2.3 From f58df8669c60dfdc6092810da13707cb965cf151 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 22 Mar 2017 21:26:25 +0100 Subject: [META] add support for ide libraries This makes sense for clients willing to link to richpp. --- META.coq | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/META.coq b/META.coq index 83134d4a08..074c2e457b 100644 --- a/META.coq +++ b/META.coq @@ -252,6 +252,33 @@ package "highparsing" ( ) +package "idetop" ( + + description = "Coq IDE Libraries" + version = "8.7" + + requires = "coq.toplevel" + directory = "ide" + + archive(byte) = "coqidetop.cma" + archive(native) = "coqidetop.cmxa" + +) + +package "ide" ( + + description = "Coq IDE Libraries" + version = "8.7" + +# XXX Add GTK + requires = "coq.toplevel" + directory = "ide" + + archive(byte) = "ide.cma" + archive(native) = "ide.cmxa" + +) + package "ltac" ( description = "Coq LTAC Plugin" -- cgit v1.2.3 From 6d2802075606dcddb02dd13cbaf38ff76f8bf242 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 23 Mar 2017 01:13:38 +0100 Subject: Add empty Extraction.v and FunInd.v to prepare landing of PR#220. This way, after we merge PR#220, scripts can be fixed in a way that is compatible with the 8.6 and trunk branches. --- plugins/extraction/Extraction.v | 0 plugins/extraction/vo.itarget | 1 + plugins/funind/FunInd.v | 0 plugins/funind/vo.itarget | 1 + 4 files changed, 2 insertions(+) create mode 100644 plugins/extraction/Extraction.v create mode 100644 plugins/funind/FunInd.v diff --git a/plugins/extraction/Extraction.v b/plugins/extraction/Extraction.v new file mode 100644 index 0000000000..e69de29bb2 diff --git a/plugins/extraction/vo.itarget b/plugins/extraction/vo.itarget index 9c30c5eb3e..3563f71dfc 100644 --- a/plugins/extraction/vo.itarget +++ b/plugins/extraction/vo.itarget @@ -1,3 +1,4 @@ +Extraction.vo ExtrHaskellBasic.vo ExtrHaskellNatNum.vo ExtrHaskellNatInt.vo diff --git a/plugins/funind/FunInd.v b/plugins/funind/FunInd.v new file mode 100644 index 0000000000..e69de29bb2 diff --git a/plugins/funind/vo.itarget b/plugins/funind/vo.itarget index 33c9683028..a17a5ec122 100644 --- a/plugins/funind/vo.itarget +++ b/plugins/funind/vo.itarget @@ -1 +1,2 @@ +FunInd.vo Recdef.vo -- cgit v1.2.3 From 9c38a23ae84e1542ab1eeab6ded4201718ec1cf8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 23 Mar 2017 14:50:56 +0100 Subject: Revert "Add empty Extraction.v and FunInd.v to prepare landing of PR#220." This reverts commit 6d2802075606dcddb02dd13cbaf38ff76f8bf242, which is an 8.6 only commit. --- plugins/extraction/Extraction.v | 0 plugins/extraction/vo.itarget | 1 - plugins/funind/FunInd.v | 0 plugins/funind/vo.itarget | 1 - 4 files changed, 2 deletions(-) delete mode 100644 plugins/extraction/Extraction.v delete mode 100644 plugins/funind/FunInd.v diff --git a/plugins/extraction/Extraction.v b/plugins/extraction/Extraction.v deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/plugins/extraction/vo.itarget b/plugins/extraction/vo.itarget index 3563f71dfc..9c30c5eb3e 100644 --- a/plugins/extraction/vo.itarget +++ b/plugins/extraction/vo.itarget @@ -1,4 +1,3 @@ -Extraction.vo ExtrHaskellBasic.vo ExtrHaskellNatNum.vo ExtrHaskellNatInt.vo diff --git a/plugins/funind/FunInd.v b/plugins/funind/FunInd.v deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/plugins/funind/vo.itarget b/plugins/funind/vo.itarget index a17a5ec122..33c9683028 100644 --- a/plugins/funind/vo.itarget +++ b/plugins/funind/vo.itarget @@ -1,2 +1 @@ -FunInd.vo Recdef.vo -- cgit v1.2.3 From b1656b1f10501b34ae6a7e147f550710b935e54b Mon Sep 17 00:00:00 2001 From: Tej Chajed Date: Wed, 22 Mar 2017 20:35:38 -0400 Subject: Intern names bound in match patterns Fixes Coq bug 5345 (https://coq.inria.fr/bugs/show_bug.cgi?id=5345): Cannot use names bound in matches inside Ltac definitions. --- pretyping/patternops.ml | 4 +++- test-suite/bugs/closed/5345.v | 7 +++++++ test-suite/success/ltac_match_pattern_names.v | 28 +++++++++++++++++++++++++++ 3 files changed, 38 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/5345.v create mode 100644 test-suite/success/ltac_match_pattern_names.v diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index fe73b6105b..2090aad8a0 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -404,7 +404,9 @@ let rec pat_of_raw metas vars = function and pats_of_glob_branches loc metas vars ind brs = let get_arg = function - | PatVar(_,na) -> na + | PatVar(_,na) -> + name_iter (fun n -> metas := n::!metas) na; + na | PatCstr(loc,_,_,_) -> err loc (Pp.str "Non supported pattern.") in let rec get_pat indexes = function diff --git a/test-suite/bugs/closed/5345.v b/test-suite/bugs/closed/5345.v new file mode 100644 index 0000000000..d8448f35db --- /dev/null +++ b/test-suite/bugs/closed/5345.v @@ -0,0 +1,7 @@ +Ltac break_tuple := + match goal with + | [ H: context[match ?a with | pair n m => _ end] |- _ ] => + let n := fresh n in + let m := fresh m in + destruct a as [n m] + end. diff --git a/test-suite/success/ltac_match_pattern_names.v b/test-suite/success/ltac_match_pattern_names.v new file mode 100644 index 0000000000..7363294960 --- /dev/null +++ b/test-suite/success/ltac_match_pattern_names.v @@ -0,0 +1,28 @@ +(* example from bug 5345 *) +Ltac break_tuple := + match goal with + | [ H: context[let '(n, m) := ?a in _] |- _ ] => + let n := fresh n in + let m := fresh m in + destruct a as [n m] + end. + +(* desugared version of break_tuple *) +Ltac break_tuple' := + match goal with + | [ H: context[match ?a with | pair n m => _ end] |- _ ] => + let n := fresh n in + let m := fresh m in + idtac + end. + +Ltac multiple_branches := + match goal with + | [ H: match _ with + | left P => _ + | right Q => _ + end |- _ ] => + let P := fresh P in + let Q := fresh Q in + idtac + end. \ No newline at end of file -- cgit v1.2.3 From ea8185d872f242f8ebf4274ebe550ed81107150a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 12 Mar 2017 19:57:48 +0100 Subject: Making the side_effects type opaque. We move it from Entries to Term_typing and export the few functions needed to manipulate it in this module. --- kernel/entries.mli | 2 -- kernel/safe_typing.ml | 12 ++++++------ kernel/safe_typing.mli | 2 +- kernel/term_typing.ml | 17 ++++++++++++----- kernel/term_typing.mli | 7 ++++++- 5 files changed, 25 insertions(+), 15 deletions(-) diff --git a/kernel/entries.mli b/kernel/entries.mli index ea7c266bcd..5287a009e5 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -113,5 +113,3 @@ type side_effect = { from_env : Declarations.structure_body CEphemeron.key; eff : side_eff; } - -type side_effects = side_effect list diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index bc1cb63d82..e3b87bbe1a 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -206,19 +206,19 @@ let get_opaque_body env cbo = Opaqueproof.force_constraints (Environ.opaque_tables env) opaque) type private_constant = Entries.side_effect -type private_constants = private_constant list +type private_constants = Term_typing.side_effects type private_constant_role = Term_typing.side_effect_role = | Subproof | Schema of inductive * string -let empty_private_constants = [] -let add_private x xs = if List.mem_f Term_typing.equal_eff x xs then xs else x :: xs -let concat_private xs ys = List.fold_right add_private xs ys +let empty_private_constants = Term_typing.empty_seff +let add_private = Term_typing.add_seff +let concat_private = Term_typing.concat_seff let mk_pure_proof = Term_typing.mk_pure_proof 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 side_effects_of_private_constants = Term_typing.uniq_seff let private_con_of_con env c = let cbo = Environ.lookup_constant c env.env in @@ -248,7 +248,7 @@ let universes_of_private eff = | Entries.SEsubproof (c, cb, e) -> if cb.const_polymorphic then acc else Univ.ContextSet.of_context cb.const_universes :: acc) - [] eff + [] (Term_typing.uniq_seff eff) let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 15ebc7d880..8bc47d6ce0 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -47,7 +47,7 @@ type private_constant_role = | Schema of inductive * string val side_effects_of_private_constants : - private_constants -> Entries.side_effects + private_constants -> Entries.side_effect list val empty_private_constants : private_constants val add_private : private_constant -> private_constants -> private_constants diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index b7597ba7fb..24da308b4f 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -37,13 +37,20 @@ let equal_eff e1 e2 = cl1 cl2 | _ -> false -let rec uniq_seff = function +type side_effects = side_effect list + +let rec uniq_seff_aux = function | [] -> [] - | x :: xs -> x :: uniq_seff (List.filter (fun y -> not (equal_eff x y)) xs) + | x :: xs -> x :: uniq_seff_aux (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 "topological" order between effects we have to uniq-ize from * the tail *) -let uniq_seff l = List.rev (uniq_seff (List.rev l)) +let uniq_seff_rev l = List.rev (uniq_seff_aux (List.rev l)) +let uniq_seff l = List.rev (uniq_seff_aux l) + +let empty_seff = [] +let add_seff x xs = if List.mem_f equal_eff x xs then xs else x :: xs +let concat_seff xs ys = List.fold_right add_seff xs ys let inline_side_effects env body ctx side_eff = let handle_sideff (t,ctx,sl) { eff = se; from_env = mb } = @@ -97,7 +104,7 @@ let inline_side_effects env body ctx side_eff = t, ctx, (mb,List.length cbl) :: sl in (* CAVEAT: we assure a proper order *) - List.fold_left handle_sideff (body,ctx,[]) (uniq_seff side_eff) + List.fold_left handle_sideff (body,ctx,[]) (uniq_seff_rev 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 *) @@ -427,7 +434,7 @@ let export_side_effects mb env ce = 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 seff, signatures = List.fold_left aux ([],[]) (uniq_seff_rev eff) in let trusted = check_signatures mb signatures in let push_seff env = function | kn, cb, `Nothing, _ -> diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 89b5fc40e3..5330fb32ba 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -12,6 +12,8 @@ open Environ open Declarations open Entries +type side_effects + val translate_local_def : structure_body -> env -> Id.t -> side_effects definition_entry -> constant_def * types * constant_universes @@ -29,7 +31,10 @@ val inline_entry_side_effects : {!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 empty_seff : side_effects +val add_seff : side_effect -> side_effects -> side_effects +val concat_seff : side_effects -> side_effects -> side_effects +val uniq_seff : side_effects -> side_effect list val equal_eff : side_effect -> side_effect -> bool val translate_constant : -- cgit v1.2.3 From ee1546dc6686e888cc8da5f9442bcf788544dd0e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 12 Mar 2017 20:16:43 +0100 Subject: Using a dedicated datastructure for side effect ordering. We were doing fishy things in the Term_typing file, where side-effects were not considered in the right uniquization order because of the uniq_seff_rev function. It probably did not matter after a9b76df because effects were (mostly) uniquize upfront, but this is not clear because of the use of the transparente API in the module. Now everything has to go through the opaque API, so that a proper dependence order is ensured. --- kernel/term_typing.ml | 66 ++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 49 insertions(+), 17 deletions(-) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 24da308b4f..6ce14c853d 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -24,8 +24,6 @@ open Fast_typeops (* Insertion of constants and parameters in environment. *) -let mk_pure_proof c = (c, Univ.ContextSet.empty), [] - let equal_eff e1 e2 = let open Entries in match e1, e2 with @@ -37,20 +35,54 @@ let equal_eff e1 e2 = cl1 cl2 | _ -> false -type side_effects = side_effect list +module SideEffects : +sig + type t + val repr : t -> side_effect list + val empty : t + val add : side_effect -> t -> t + val concat : t -> t -> t +end = +struct + +let compare_seff e1 e2 = match e1, e2 with +| SEsubproof (c1, _, _), SEsubproof (c2, _, _) -> Constant.CanOrd.compare c1 c2 +| SEscheme (cl1, _), SEscheme (cl2, _) -> + let cmp (_, c1, _, _) (_, c2, _, _) = Constant.CanOrd.compare c1 c2 in + CList.compare cmp cl1 cl2 +| SEsubproof _, SEscheme _ -> -1 +| SEscheme _, SEsubproof _ -> 1 + +module SeffOrd = struct +type t = side_effect +let compare e1 e2 = compare_seff e1.eff e2.eff +end + +module SeffSet = Set.Make(SeffOrd) + +type t = { seff : side_effect list; elts : SeffSet.t } +(** Invariant: [seff] is a permutation of the elements of [elts] *) + +let repr eff = eff.seff +let empty = { seff = []; elts = SeffSet.empty } +let add x es = + if SeffSet.mem x es.elts then es + else { seff = x :: es.seff; elts = SeffSet.add x es.elts } +let concat xes yes = + List.fold_right add xes.seff yes + +end + +type side_effects = SideEffects.t + +let uniq_seff_rev = SideEffects.repr +let uniq_seff l = List.rev (SideEffects.repr l) -let rec uniq_seff_aux = function - | [] -> [] - | x :: xs -> x :: uniq_seff_aux (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 "topological" order between effects we have to uniq-ize from - * the tail *) -let uniq_seff_rev l = List.rev (uniq_seff_aux (List.rev l)) -let uniq_seff l = List.rev (uniq_seff_aux l) +let empty_seff = SideEffects.empty +let add_seff = SideEffects.add +let concat_seff = SideEffects.concat -let empty_seff = [] -let add_seff x xs = if List.mem_f equal_eff x xs then xs else x :: xs -let concat_seff xs ys = List.fold_right add_seff xs ys +let mk_pure_proof c = (c, Univ.ContextSet.empty), empty_seff let inline_side_effects env body ctx side_eff = let handle_sideff (t,ctx,sl) { eff = se; from_env = mb } = @@ -388,7 +420,7 @@ let constant_entry_of_side_effect cb u = | Def b, `Nothing -> Mod_subst.force_constr b, Univ.ContextSet.empty | _ -> assert false in DefinitionEntry { - const_entry_body = Future.from_val (pt, []); + const_entry_body = Future.from_val (pt, empty_seff); const_entry_secctx = None; const_entry_feedback = None; const_entry_type = @@ -422,7 +454,7 @@ let export_side_effects mb env ce = 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 + (fun (b_ctx, _) -> b_ctx, empty_seff) } in let not_exists (c,_,_,_) = try ignore(Environ.lookup_constant c env); false with Not_found -> true in @@ -507,7 +539,7 @@ 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',_ = inline_side_effects env body ctx side_eff in - (body, ctx'), []); + (body, ctx'), empty_seff); } let inline_side_effects env body side_eff = -- cgit v1.2.3 From 91dbe4af7b2a435142dcf40902082f90f07cc8be Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 20 Mar 2017 08:48:22 +0100 Subject: Documenting the API of side-effects. --- kernel/safe_typing.mli | 7 +++++++ kernel/term_typing.mli | 5 +++++ 2 files changed, 12 insertions(+) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 8bc47d6ce0..efeb98bd25 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -48,10 +48,17 @@ type private_constant_role = val side_effects_of_private_constants : private_constants -> Entries.side_effect list +(** Return the list of individual side-effects in the order of their + creation. *) val empty_private_constants : private_constants val add_private : private_constant -> private_constants -> private_constants +(** Add a constant to a list of private constants. The former must be more + recent than all constants appearing in the latter, i.e. one should not + create a dependency cycle. *) val concat_private : private_constants -> private_constants -> private_constants +(** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in + [e1] must be more recent than those of [e2]. *) val private_con_of_con : safe_environment -> constant -> private_constant val private_con_of_scheme : kind:string -> safe_environment -> (inductive * constant) list -> private_constant diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 5330fb32ba..075389ea53 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -34,7 +34,12 @@ val inline_entry_side_effects : val empty_seff : side_effects val add_seff : side_effect -> side_effects -> side_effects val concat_seff : side_effects -> side_effects -> side_effects +(** [concat_seff e1 e2] adds the side-effects of [e1] to [e2], i.e. effects in + [e1] must be more recent than those of [e2]. *) val uniq_seff : side_effects -> side_effect list +(** Return the list of individual side-effects in the order of their + creation. *) + val equal_eff : side_effect -> side_effect -> bool val translate_constant : -- cgit v1.2.3 From f29e577ef81e608cb8b3a68f4e171716c1280711 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 20 Mar 2017 13:38:14 +0100 Subject: [travis] Add VST --- .travis.yml | 2 ++ Makefile.ci | 2 +- dev/ci/ci-basic-overlay.sh | 9 +++++++++ dev/ci/ci-vst.sh | 13 +++++++++++++ 4 files changed, 25 insertions(+), 1 deletion(-) create mode 100755 dev/ci/ci-vst.sh diff --git a/.travis.yml b/.travis.yml index 7138d5c61e..81f50af0a0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -40,6 +40,7 @@ env: - TEST_TARGET="ci-math-comp" - TEST_TARGET="ci-sf" - TEST_TARGET="ci-unimath" + - TEST_TARGET="ci-vst" # Not ready yet for 8.7 # - TEST_TARGET="ci-cpdt" # - TEST_TARGET="ci-metacoq" @@ -49,6 +50,7 @@ matrix: allow_failures: - env: TEST_TARGET="ci-geocoq" + - env: TEST_TARGET="ci-vst" # Full Coq test-suite with two compilers # [TODO: use yaml refs and avoid duplication for packages list] diff --git a/Makefile.ci b/Makefile.ci index 897318c4dd..b055ada8e5 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -1,7 +1,7 @@ CI_TARGETS=ci-all ci-hott ci-math-comp ci-compcert ci-sf ci-cpdt \ ci-color ci-math-classes ci-tlc ci-fiat-crypto ci-fiat-parsers \ ci-coquelicot ci-flocq ci-iris-coq ci-metacoq ci-geocoq \ - ci-unimath + ci-unimath ci-vst .PHONY: $(CI_TARGETS) diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 241ec35861..336ce9d8f1 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -46,8 +46,11 @@ ######################################################################## # HoTT ######################################################################## +# Temporal overlay : ${HoTT_CI_BRANCH:=mz-8.7} : ${HoTT_CI_GITURL:=https://github.com/ejgallego/HoTT.git} +# : ${HoTT_CI_BRANCH:=master} +# : ${HoTT_CI_GITURL:=https://github.com/HoTT/HoTT.git} ######################################################################## # GeoCoq @@ -73,6 +76,12 @@ : ${CompCert_CI_BRANCH:=master} : ${CompCert_CI_GITURL:=https://github.com/AbsInt/CompCert.git} +######################################################################## +# VST +######################################################################## +: ${VST_CI_BRANCH:=master} +: ${VST_CI_GITURL:=https://github.com/PrincetonUniversity/VST.git} + ######################################################################## # fiat_parsers ######################################################################## diff --git a/dev/ci/ci-vst.sh b/dev/ci/ci-vst.sh new file mode 100755 index 0000000000..c111951852 --- /dev/null +++ b/dev/ci/ci-vst.sh @@ -0,0 +1,13 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +VST_CI_DIR=${CI_BUILD_DIR}/VST + +# opam install -j ${NJOBS} -y menhir +git_checkout ${VST_CI_BRANCH} ${VST_CI_GITURL} ${VST_CI_DIR} + +# Targets are: msl veric floyd +# Patch to avoid the upper version limit +( cd ${VST_CI_DIR} && sed -i.bak 's/8.6$/8.6 or-else trunk/' Makefile && make -j ${NJOBS} ) -- cgit v1.2.3