diff options
Diffstat (limited to 'plugins')
76 files changed, 7784 insertions, 7027 deletions
diff --git a/plugins/btauto/plugin_base.dune b/plugins/btauto/dune index 6a024358c3..d2f5b65980 100644 --- a/plugins/btauto/plugin_base.dune +++ b/plugins/btauto/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.btauto) (synopsis "Coq's btauto plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_btauto)) diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 020ab9307d..52c6c5d0f9 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -164,14 +164,17 @@ module Btauto = struct let reify env t = lapp eval [|convert_env env; convert t|] - let print_counterexample p penv gl = + let print_counterexample p penv = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let var = lapp witness [|p|] in let var = EConstr.of_constr var in (* Compute an assignment that dissatisfies the goal *) - let redfun, _ = Redexpr.reduction_of_red_expr (Refiner.pf_env gl) Genredexpr.(CbvVm None) in - let _, var = redfun Refiner.(pf_env gl) Refiner.(project gl) var in + let redfun, _ = Redexpr.reduction_of_red_expr env Genredexpr.(CbvVm None) in + let _, var = redfun env sigma var in let var = EConstr.Unsafe.to_constr var in - let rec to_list l = match decomp_term (Tacmach.project gl) l with + let rec to_list l = match decomp_term sigma l with | App (c, _) when c === (Lazy.force CoqList._nil) -> [] | App (c, [|_; h; t|]) @@ -196,7 +199,6 @@ module Btauto = struct let assign = List.combine penv var in let map_msg (key, v) = let b = if v then str "true" else str "false" in - let sigma, env = Tacmach.project gl, Tacmach.pf_env gl in let term = Printer.pr_constr_env env sigma key in term ++ spc () ++ str ":=" ++ spc () ++ b in @@ -205,7 +207,8 @@ module Btauto = struct str "Not a tautology:" ++ spc () ++ l with e when CErrors.noncritical e -> (str "Not a tautology") in - Tacticals.tclFAIL 0 msg gl + Tacticals.New.tclFAIL 0 msg + end let try_unification env = Proofview.Goal.enter begin fun gl -> @@ -216,7 +219,7 @@ module Btauto = struct match t with | App (c, [|typ; p; _|]) when c === eq -> (* should be an equality [@eq poly ?p (Cst false)] *) - let tac = Tacticals.New.tclORELSE0 Tactics.reflexivity (Proofview.V82.tactic (print_counterexample p env)) in + let tac = Tacticals.New.tclORELSE0 Tactics.reflexivity (print_counterexample p env) in tac | _ -> let msg = str "Btauto: Internal error" in diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 74043d6bc8..6f5c910297 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -25,19 +25,14 @@ open Util let init_size=5 -let cc_verbose=ref false +let cc_verbose= + declare_bool_option_and_ref + ~depr:false + ~key:["Congruence";"Verbose"] + ~value:false let debug x = - if !cc_verbose then Feedback.msg_debug (x ()) - -let () = - let gdopt= - { optdepr=false; - optkey=["Congruence";"Verbose"]; - optread=(fun ()-> !cc_verbose); - optwrite=(fun b -> cc_verbose := b)} - in - declare_bool_option gdopt + if cc_verbose () then Feedback.msg_debug (x ()) (* Signature table *) diff --git a/plugins/cc/plugin_base.dune b/plugins/cc/dune index 2a92996d2a..f7fa3adb56 100644 --- a/plugins/cc/plugin_base.dune +++ b/plugins/cc/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.cc) (synopsis "Coq's congruence closure plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_congruence)) diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index dca69f06ca..f09b35a6d1 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -42,6 +42,6 @@ let start_deriving f suchthat name : Lemmas.t = let info = Lemmas.Info.make ~proof_ending:(Lemmas.Proof_ending.(End_derive {f; name})) ~kind () in let lemma = Lemmas.start_dependent_lemma ~name ~poly ~info goals in - Lemmas.pf_map (Proof_global.map_proof begin fun p -> + Lemmas.pf_map (Declare.Proof.map_proof begin fun p -> Util.pi1 @@ Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p end) lemma diff --git a/plugins/derive/plugin_base.dune b/plugins/derive/dune index ba9cd595ce..1931339471 100644 --- a/plugins/derive/plugin_base.dune +++ b/plugins/derive/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.derive) (synopsis "Coq's derive plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_derive)) diff --git a/plugins/extraction/plugin_base.dune b/plugins/extraction/dune index 037b0d5053..0c01dcd488 100644 --- a/plugins/extraction/plugin_base.dune +++ b/plugins/extraction/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.extraction) (synopsis "Coq's extraction plugin") (libraries num coq.plugins.ltac)) + +(coq.pp (modules g_extraction)) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 3a90d24c97..f7d78551d8 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -163,7 +163,8 @@ let expand_mexpr env mpo me = let expand_modtype env mp me = let inl = Some (Flags.get_inline_level()) in - Mod_typing.translate_modtype env mp inl ([],me) + let mtb, _cst = Mod_typing.translate_modtype env mp inl ([],me) in + mtb let no_delta = Mod_subst.empty_delta_resolver @@ -728,13 +729,13 @@ let extract_and_compile l = (* Show the extraction of the current ongoing proof *) let show_extraction ~pstate = init ~inner:true false false; - let prf = Proof_global.get_proof pstate in - let sigma, env = Pfedit.get_current_context pstate in + let prf = Declare.Proof.get_proof pstate in + let sigma, env = Declare.get_current_context pstate in let trms = Proof.partial_proof prf in let extr_term t = let ast, ty = extract_constr env sigma t in let mp = Lib.current_mp () in - let l = Label.of_id (Proof_global.get_proof_name pstate) in + let l = Label.of_id (Declare.Proof.get_proof_name pstate) in let fake_ref = GlobRef.ConstRef (Constant.make2 mp l) in let decl = Dterm (fake_ref, ast, ty) in print_one_decl [] mp decl diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index edbc1f5ea7..06cc475200 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -40,4 +40,4 @@ val structure_for_compute : (* Show the extraction of the current ongoing proof *) -val show_extraction : pstate:Proof_global.t -> unit +val show_extraction : pstate:Declare.Proof.t -> unit diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index a53c2395f0..f8449bcda1 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -498,16 +498,8 @@ let info_file f = (* The objects defined below should survive an arbitrary time, so we register them to coq save/undo mechanism. *) -let my_bool_option name initval = - let flag = ref initval in - let access = fun () -> !flag in - let () = declare_bool_option - {optdepr = false; - optkey = ["Extraction"; name]; - optread = access; - optwrite = (:=) flag } - in - access +let my_bool_option name value = + declare_bool_option_and_ref ~depr:false ~key:["Extraction"; name] ~value (*s Extraction AccessOpaque *) @@ -588,25 +580,18 @@ let () = declare_int_option (* This option controls whether "dummy lambda" are removed when a toplevel constant is defined. *) -let conservative_types_ref = ref false -let conservative_types () = !conservative_types_ref - -let () = declare_bool_option - {optdepr = false; - optkey = ["Extraction"; "Conservative"; "Types"]; - optread = (fun () -> !conservative_types_ref); - optwrite = (fun b -> conservative_types_ref := b) } - +let conservative_types = + declare_bool_option_and_ref + ~depr:false + ~key:["Extraction"; "Conservative"; "Types"] + ~value:false (* Allows to print a comment at the beginning of the output files *) -let file_comment_ref = ref "" -let file_comment () = !file_comment_ref - -let () = declare_string_option - {optdepr = false; - optkey = ["Extraction"; "File"; "Comment"]; - optread = (fun () -> !file_comment_ref); - optwrite = (fun s -> file_comment_ref := s) } +let file_comment = + declare_string_option_and_ref + ~depr:false + ~key:["Extraction"; "File"; "Comment"] + ~value:"" (*s Extraction Lang *) diff --git a/plugins/firstorder/plugin_base.dune b/plugins/firstorder/dune index d88daa23fc..1b05452d8f 100644 --- a/plugins/firstorder/plugin_base.dune +++ b/plugins/firstorder/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.firstorder) (synopsis "Coq's first order logic solver plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_ground)) diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 49e4c91182..6ddc6ba21e 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -31,20 +31,8 @@ DECLARE PLUGIN "ground_plugin" { -let ground_depth=ref 3 - -let ()= - let gdopt= - { optdepr=false; - optkey=["Firstorder";"Depth"]; - optread=(fun ()->Some !ground_depth); - optwrite= - (function - None->ground_depth:=3 - | Some i->ground_depth:=(max i 0))} - in - declare_int_option gdopt - +let ground_depth = + declare_nat_option_and_ref ~depr:false ~key:["Firstorder";"Depth"] ~value:3 let default_intuition_tac = let tac _ _ = Auto.h_auto None [] (Some []) in @@ -85,7 +73,7 @@ let gen_ground_tac flag taco ids bases = | None-> snd (default_solver ()) in let startseq k = Proofview.Goal.enter begin fun gl -> - let seq=empty_seq !ground_depth in + let seq=empty_seq (ground_depth ()) in let seq, sigma = extend_with_ref_list (pf_env gl) (project gl) ids seq in let seq, sigma = extend_with_auto_hints (pf_env gl) sigma bases seq in tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k seq) diff --git a/plugins/funind/.ocamlformat b/plugins/funind/.ocamlformat new file mode 100644 index 0000000000..a22a2ff88c --- /dev/null +++ b/plugins/funind/.ocamlformat @@ -0,0 +1 @@ +disable=false diff --git a/plugins/funind/plugin_base.dune b/plugins/funind/dune index 6ccf15df29..e594ffbd02 100644 --- a/plugins/funind/plugin_base.dune +++ b/plugins/funind/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.funind) (synopsis "Coq's functional induction plugin") (libraries coq.plugins.extraction)) + +(coq.pp (modules g_indfun)) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 9749af1e66..f4200854c2 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -15,280 +15,268 @@ open Tactics open Indfun_common open Libnames open Context.Rel.Declaration - module RelDecl = Context.Rel.Declaration -let list_chop ?(msg="") n l = - try - List.chop n l - with Failure (msg') -> - failwith (msg ^ msg') +let list_chop ?(msg = "") n l = + try List.chop n l with Failure msg' -> failwith (msg ^ msg') let pop t = Vars.lift (-1) t -let make_refl_eq constructor type_of_t t = -(* let refl_equal_term = Lazy.force refl_equal in *) - mkApp(constructor,[|type_of_t;t|]) - +let make_refl_eq constructor type_of_t t = + (* let refl_equal_term = Lazy.force refl_equal in *) + mkApp (constructor, [|type_of_t; t|]) type pte_info = - { - proving_tac : (Id.t list -> Tacmach.tactic); - is_valid : constr -> bool - } + {proving_tac : Id.t list -> Tacmach.tactic; is_valid : constr -> bool} type ptes_info = pte_info Id.Map.t type 'a dynamic_info = - { - nb_rec_hyps : int; - rec_hyps : Id.t list ; - eq_hyps : Id.t list; - info : 'a - } + {nb_rec_hyps : int; rec_hyps : Id.t list; eq_hyps : Id.t list; info : 'a} type body_info = constr dynamic_info let observe_tac s = observe_tac (fun _ _ -> Pp.str s) let finish_proof dynamic_infos g = - observe_tac "finish" - (Proofview.V82.of_tactic assumption) - g - + observe_tac "finish" (Proofview.V82.of_tactic assumption) g -let refine c = Refiner.refiner ~check:true EConstr.Unsafe.(to_constr c) +let refine c = + Proofview.V82.of_tactic + (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr c)) let thin l = Proofview.V82.of_tactic (Tactics.clear l) - let eq_constr sigma u v = EConstr.eq_constr_nounivs sigma u v let is_trivial_eq sigma t = - let res = try - begin + let res = + try match EConstr.kind sigma t with - | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> - eq_constr sigma t1 t2 - | App(f,[|t1;a1;t2;a2|]) when eq_constr sigma f (jmeq ()) -> - eq_constr sigma t1 t2 && eq_constr sigma a1 a2 - | _ -> false - end - with e when CErrors.noncritical e -> false + | App (f, [|_; t1; t2|]) when eq_constr sigma f (Lazy.force eq) -> + eq_constr sigma t1 t2 + | App (f, [|t1; a1; t2; a2|]) when eq_constr sigma f (jmeq ()) -> + eq_constr sigma t1 t2 && eq_constr sigma a1 a2 + | _ -> false + with e when CErrors.noncritical e -> false in -(* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) + (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res let rec incompatible_constructor_terms sigma t1 t2 = - let c1,arg1 = decompose_app sigma t1 - and c2,arg2 = decompose_app sigma t2 - in - (not (eq_constr sigma t1 t2)) && - isConstruct sigma c1 && isConstruct sigma c2 && - ( - not (eq_constr sigma c1 c2) || - List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 - ) + let c1, arg1 = decompose_app sigma t1 and c2, arg2 = decompose_app sigma t2 in + (not (eq_constr sigma t1 t2)) + && isConstruct sigma c1 && isConstruct sigma c2 + && ( (not (eq_constr sigma c1 c2)) + || List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 ) let is_incompatible_eq env sigma t = let res = try match EConstr.kind sigma t with - | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> - incompatible_constructor_terms sigma t1 t2 - | App(f,[|u1;t1;u2;t2|]) when eq_constr sigma f (jmeq ()) -> - (eq_constr sigma u1 u2 && - incompatible_constructor_terms sigma t1 t2) - | _ -> false + | App (f, [|_; t1; t2|]) when eq_constr sigma f (Lazy.force eq) -> + incompatible_constructor_terms sigma t1 t2 + | App (f, [|u1; t1; u2; t2|]) when eq_constr sigma f (jmeq ()) -> + eq_constr sigma u1 u2 && incompatible_constructor_terms sigma t1 t2 + | _ -> false with e when CErrors.noncritical e -> false in if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); res let change_hyp_with_using msg hyp_id t tac : tactic = - fun g -> - let prov_id = pf_get_new_id hyp_id g in - tclTHENS - ((* observe_tac msg *) Proofview.V82.of_tactic (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) - [tclTHENLIST - [ - (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); - (* observe_tac "change_hyp_with_using rename " *) (Proofview.V82.of_tactic (rename_hyp [prov_id,hyp_id])) - ]] g + fun g -> + let prov_id = pf_get_new_id hyp_id g in + tclTHENS + ((* observe_tac msg *) Proofview.V82.of_tactic + (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) + [ tclTHENLIST + [ (* observe_tac "change_hyp_with_using thin" *) + thin [hyp_id] + ; (* observe_tac "change_hyp_with_using rename " *) + Proofview.V82.of_tactic (rename_hyp [(prov_id, hyp_id)]) ] ] + g exception TOREMOVE - -let prove_trivial_eq h_id context (constructor,type_of_term,term) = +let prove_trivial_eq h_id context (constructor, type_of_term, term) = let nb_intros = List.length context in tclTHENLIST - [ - tclDO nb_intros (Proofview.V82.of_tactic intro); (* introducing context *) + [ tclDO nb_intros (Proofview.V82.of_tactic intro) + ; (* introducing context *) (fun g -> - let context_hyps = - fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) - in - let context_hyps' = - (mkApp(constructor,[|type_of_term;term|])):: - (List.map mkVar context_hyps) - in - let to_refine = applist(mkVar h_id,List.rev context_hyps') in - refine to_refine g - ) - ] - - + let context_hyps = + fst + (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) + in + let context_hyps' = + mkApp (constructor, [|type_of_term; term|]) + :: List.map mkVar context_hyps + in + let to_refine = applist (mkVar h_id, List.rev context_hyps') in + refine to_refine g) ] let find_rectype env sigma c = - let (t, l) = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in + let t, l = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in match EConstr.kind sigma t with | Ind ind -> (t, l) - | Construct _ -> (t,l) + | Construct _ -> (t, l) | _ -> raise Not_found - -let isAppConstruct ?(env=Global.env ()) sigma t = +let isAppConstruct ?(env = Global.env ()) sigma t = try - let t',l = find_rectype env sigma t in - observe (str "isAppConstruct : " ++ Printer.pr_leconstr_env env sigma t ++ str " -> " ++ - Printer.pr_leconstr_env env sigma (applist (t',l))); + let t', l = find_rectype env sigma t in + observe + ( str "isAppConstruct : " + ++ Printer.pr_leconstr_env env sigma t + ++ str " -> " + ++ Printer.pr_leconstr_env env sigma (applist (t', l)) ); true with Not_found -> false exception NoChange -let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = - let nochange ?t' msg = - begin - observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr_env env sigma t ++ str " " ++ - match t' with None -> str "" | Some t -> Printer.pr_leconstr_env env sigma t ); - raise NoChange; - end +let change_eq env sigma hyp_id (context : rel_context) x t end_of_type = + let nochange ?t' msg = + observe + ( str ("Not treating ( " ^ msg ^ " )") + ++ pr_leconstr_env env sigma t + ++ str " " + ++ + match t' with + | None -> str "" + | Some t -> Printer.pr_leconstr_env env sigma t ); + raise NoChange in let eq_constr c1 c2 = - try ignore(Evarconv.unify_delay env sigma c1 c2); true - with Evarconv.UnableToUnify _ -> false in - if not (noccurn sigma 1 end_of_type) - then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) - if not (isApp sigma t) then nochange "not an equality"; - let f_eq,args = destApp sigma t in - let constructor,t1,t2,t1_typ = + try + ignore (Evarconv.unify_delay env sigma c1 c2); + true + with Evarconv.UnableToUnify _ -> false + in + if not (noccurn sigma 1 end_of_type) then nochange "dependent"; + (* if end_of_type depends on this term we don't touch it *) + if not (isApp sigma t) then nochange "not an equality"; + let f_eq, args = destApp sigma t in + let constructor, t1, t2, t1_typ = + try + if eq_constr f_eq (Lazy.force eq) then + let t1 = (args.(1), args.(0)) + and t2 = (args.(2), args.(0)) + and t1_typ = args.(0) in + (Lazy.force refl_equal, t1, t2, t1_typ) + else if eq_constr f_eq (jmeq ()) then + (jmeq_refl (), (args.(1), args.(0)), (args.(3), args.(2)), args.(0)) + else nochange "not an equality" + with e when CErrors.noncritical e -> nochange "not an equality" + in + if not (closed0 sigma (fst t1) && closed0 sigma (snd t1)) then + nochange "not a closed lhs"; + let rec compute_substitution sub t1 t2 = + (* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) + if isRel sigma t2 then ( + let t2 = destRel sigma t2 in try - if (eq_constr f_eq (Lazy.force eq)) - then - let t1 = (args.(1),args.(0)) - and t2 = (args.(2),args.(0)) - and t1_typ = args.(0) - in - (Lazy.force refl_equal,t1,t2,t1_typ) - else - if (eq_constr f_eq (jmeq ())) - then - (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) - else nochange "not an equality" - with e when CErrors.noncritical e -> nochange "not an equality" - in - if not ((closed0 sigma (fst t1)) && (closed0 sigma (snd t1)))then nochange "not a closed lhs"; - let rec compute_substitution sub t1 t2 = -(* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) - if isRel sigma t2 - then - let t2 = destRel sigma t2 in - begin - try - let t1' = Int.Map.find t2 sub in - if not (eq_constr t1 t1') then nochange "twice bound variable"; - sub - with Not_found -> - assert (closed0 sigma t1); - Int.Map.add t2 t1 sub - end - else if isAppConstruct sigma t1 && isAppConstruct sigma t2 - then - begin - let c1,args1 = find_rectype env sigma t1 - and c2,args2 = find_rectype env sigma t2 - in - if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; - List.fold_left2 compute_substitution sub args1 args2 - end - else - if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) "cannot solve (diff)" - in - let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in - let sub = compute_substitution sub (fst t1) (fst t2) in - let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) - let new_end_of_type = - (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 - Can be safely replaced by the next comment for Ocaml >= 3.08.4 - *) - let sub = Int.Map.bindings sub in - List.fold_left (fun end_of_type (i,t) -> liftn 1 i (substnl [t] (i-1) end_of_type)) - end_of_type_with_pop + let t1' = Int.Map.find t2 sub in + if not (eq_constr t1 t1') then nochange "twice bound variable"; sub - in - let old_context_length = List.length context + 1 in - let witness_fun = - mkLetIn(make_annot Anonymous Sorts.Relevant,make_refl_eq constructor t1_typ (fst t1),t, - mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) - ) - in - let new_type_of_hyp,ctxt_size,witness_fun = - List.fold_left_i - (fun i (end_of_type,ctxt_size,witness_fun) decl -> - try - let witness = Int.Map.find i sub in - if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_annot decl, - witness, RelDecl.get_type decl, witness_fun)) - with Not_found -> - (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) - ) - 1 - (new_end_of_type,0,witness_fun) - context - in - let new_type_of_hyp = - Reductionops.nf_betaiota env sigma new_type_of_hyp in - let new_ctxt,new_end_of_type = - decompose_prod_n_assum sigma ctxt_size new_type_of_hyp - in - let prove_new_hyp : tactic = - tclTHEN - (tclDO ctxt_size (Proofview.V82.of_tactic intro)) - (fun g -> - let all_ids = pf_ids_of_hyps g in - let new_ids,_ = list_chop ctxt_size all_ids in - let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - let evm, _ = pf_apply Typing.type_of g to_refine in - tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g - ) - in - let simpl_eq_tac = - change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp - in -(* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) -(* str "removing an equation " ++ fnl ()++ *) -(* str "old_typ_of_hyp :=" ++ *) -(* Printer.pr_lconstr_env *) -(* env *) -(* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) -(* ++ fnl () ++ *) -(* str "new_typ_of_hyp := "++ *) -(* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) -(* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) -(* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) -(* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) -(* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) -(* ); *) - new_ctxt,new_end_of_type,simpl_eq_tac - - -let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp = - if isApp sigma t_x - then - let pte,args = destApp sigma t_x in - if isVar sigma pte && Array.for_all (closed0 sigma) args - then + with Not_found -> + assert (closed0 sigma t1); + Int.Map.add t2 t1 sub ) + else if isAppConstruct sigma t1 && isAppConstruct sigma t2 then begin + let c1, args1 = find_rectype env sigma t1 + and c2, args2 = find_rectype env sigma t2 in + if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; + List.fold_left2 compute_substitution sub args1 args2 + end + else if eq_constr t1 t2 then sub + else + nochange + ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) + "cannot solve (diff)" + in + let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in + let sub = compute_substitution sub (fst t1) (fst t2) in + let end_of_type_with_pop = pop end_of_type in + (*the equation will be removed *) + let new_end_of_type = + (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 + Can be safely replaced by the next comment for Ocaml >= 3.08.4 + *) + let sub = Int.Map.bindings sub in + List.fold_left + (fun end_of_type (i, t) -> liftn 1 i (substnl [t] (i - 1) end_of_type)) + end_of_type_with_pop sub + in + let old_context_length = List.length context + 1 in + let witness_fun = + mkLetIn + ( make_annot Anonymous Sorts.Relevant + , make_refl_eq constructor t1_typ (fst t1) + , t + , mkApp + ( mkVar hyp_id + , Array.init old_context_length (fun i -> + mkRel (old_context_length - i)) ) ) + in + let new_type_of_hyp, ctxt_size, witness_fun = + List.fold_left_i + (fun i (end_of_type, ctxt_size, witness_fun) decl -> + try + let witness = Int.Map.find i sub in + if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); + ( pop end_of_type + , ctxt_size + , mkLetIn + ( RelDecl.get_annot decl + , witness + , RelDecl.get_type decl + , witness_fun ) ) + with Not_found -> + ( mkProd_or_LetIn decl end_of_type + , ctxt_size + 1 + , mkLambda_or_LetIn decl witness_fun )) + 1 + (new_end_of_type, 0, witness_fun) + context + in + let new_type_of_hyp = Reductionops.nf_betaiota env sigma new_type_of_hyp in + let new_ctxt, new_end_of_type = + decompose_prod_n_assum sigma ctxt_size new_type_of_hyp + in + let prove_new_hyp : tactic = + tclTHEN + (tclDO ctxt_size (Proofview.V82.of_tactic intro)) + (fun g -> + let all_ids = pf_ids_of_hyps g in + let new_ids, _ = list_chop ctxt_size all_ids in + let to_refine = applist (witness_fun, List.rev_map mkVar new_ids) in + let evm, _ = pf_apply Typing.type_of g to_refine in + tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g) + in + let simpl_eq_tac = + change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp + prove_new_hyp + in + (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) + (* str "removing an equation " ++ fnl ()++ *) + (* str "old_typ_of_hyp :=" ++ *) + (* Printer.pr_lconstr_env *) + (* env *) + (* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) + (* ++ fnl () ++ *) + (* str "new_typ_of_hyp := "++ *) + (* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) + (* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) + (* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) + (* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) + (* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) + (* ); *) + (new_ctxt, new_end_of_type, simpl_eq_tac) + +let is_property sigma (ptes_info : ptes_info) t_x full_type_of_hyp = + if isApp sigma t_x then + let pte, args = destApp sigma t_x in + if isVar sigma pte && Array.for_all (closed0 sigma) args then try let info = Id.Map.find (destVar sigma pte) ptes_info in info.is_valid full_type_of_hyp @@ -297,19 +285,13 @@ let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp = else false let isLetIn sigma t = - match EConstr.kind sigma t with - | LetIn _ -> true - | _ -> false - + match EConstr.kind sigma t with LetIn _ -> true | _ -> false let h_reduce_with_zeta cl = - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) cl) - - + Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + cl) let rewrite_until_var arg_num eq_ids : tactic = (* tests if the declares recursive argument is neither a Constructor nor @@ -318,268 +300,247 @@ let rewrite_until_var arg_num eq_ids : tactic = *) let test_var g = let sigma = project g in - let _,args = destApp sigma (pf_concl g) in - not ((isConstruct sigma args.(arg_num)) || isAppConstruct sigma args.(arg_num)) + let _, args = destApp sigma (pf_concl g) in + not (isConstruct sigma args.(arg_num) || isAppConstruct sigma args.(arg_num)) in - let rec do_rewrite eq_ids g = - if test_var g - then tclIDTAC g + let rec do_rewrite eq_ids g = + if test_var g then tclIDTAC g else match eq_ids with - | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property."); - | eq_id::eq_ids -> - tclTHEN - (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) - (do_rewrite eq_ids) - g + | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property.") + | eq_id :: eq_ids -> + tclTHEN + (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) + (do_rewrite eq_ids) g in do_rewrite eq_ids - let rec_pte_id = Id.of_string "Hrec" + let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type") in - let coq_True = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.type") in - let coq_I = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in - let rec scan_type context type_of_hyp : tactic = + let coq_False = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type") + in + let coq_True = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.type") + in + let coq_I = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") + in + let rec scan_type context type_of_hyp : tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in - let reduced_type_of_hyp = Reductionops.nf_betaiotazeta env sigma real_type_of_hyp in + let reduced_type_of_hyp = + Reductionops.nf_betaiotazeta env sigma real_type_of_hyp + in (* length of context didn't change ? *) - let new_context,new_typ_of_hyp = - decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp + let new_context, new_typ_of_hyp = + decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp in + tclTHENLIST + [ h_reduce_with_zeta (Locusops.onHyp hyp_id) + ; scan_type new_context new_typ_of_hyp ] + else if isProd sigma type_of_hyp then + let x, t_x, t' = destProd sigma type_of_hyp in + let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in + if is_property sigma ptes_infos t_x actual_real_type_of_hyp then + let pte, pte_args = destApp sigma t_x in + let (* fix_info *) prove_rec_hyp = + (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac + in + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let prove_new_type_of_hyp = + let context_length = List.length context in + tclTHENLIST + [ tclDO context_length (Proofview.V82.of_tactic intro) + ; (fun g -> + let context_hyps_ids = + fst + (list_chop ~msg:"rec hyp : context_hyps" context_length + (pf_ids_of_hyps g)) + in + let rec_pte_id = pf_get_new_id rec_pte_id g in + let to_refine = + applist + ( mkVar hyp_id + , List.rev_map mkVar (rec_pte_id :: context_hyps_ids) ) + in + (* observe_tac "rec hyp " *) + (tclTHENS + (Proofview.V82.of_tactic + (assert_before (Name rec_pte_id) t_x)) + [ (* observe_tac "prove rec hyp" *) + prove_rec_hyp eq_hyps + ; (* observe_tac "prove rec hyp" *) + refine to_refine ]) + g) ] + in tclTHENLIST - [ h_reduce_with_zeta (Locusops.onHyp hyp_id); - scan_type new_context new_typ_of_hyp ] - else if isProd sigma type_of_hyp - then - begin - let (x,t_x,t') = destProd sigma type_of_hyp in - let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in - if is_property sigma ptes_infos t_x actual_real_type_of_hyp then - begin - let pte,pte_args = (destApp sigma t_x) in - let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac in - let popped_t' = pop t' in - let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in - let prove_new_type_of_hyp = - let context_length = List.length context in - tclTHENLIST - [ - tclDO context_length (Proofview.V82.of_tactic intro); - (fun g -> - let context_hyps_ids = - fst (list_chop ~msg:"rec hyp : context_hyps" - context_length (pf_ids_of_hyps g)) - in - let rec_pte_id = pf_get_new_id rec_pte_id g in - let to_refine = - applist(mkVar hyp_id, - List.rev_map mkVar (rec_pte_id::context_hyps_ids) - ) - in -(* observe_tac "rec hyp " *) - (tclTHENS - (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) - [ - (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); -(* observe_tac "prove rec hyp" *) - (refine to_refine) - ]) - g - ) - ] - in - tclTHENLIST - [ -(* observe_tac "hyp rec" *) - (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); - scan_type context popped_t' - ] - end - else if eq_constr sigma t_x coq_False then - begin -(* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) -(* str " since it has False in its preconds " *) -(* ); *) - raise TOREMOVE; (* False -> .. useless *) - end - else if is_incompatible_eq env sigma t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) - else if eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) - then -(* observe (str "In "++Ppconstr.pr_id hyp_id++ *) -(* str " removing useless precond True" *) -(* ); *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn popped_t' context - in - let prove_trivial = - let nb_intro = List.length context in - tclTHENLIST [ - tclDO nb_intro (Proofview.V82.of_tactic intro); - (fun g -> - let context_hyps = - fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) - in - let to_refine = - applist (mkVar hyp_id, - List.rev (coq_I::List.map mkVar context_hyps) - ) - in - refine to_refine g - ) - ] - in - tclTHENLIST[ - change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp - ((* observe_tac "prove_trivial" *) prove_trivial); - scan_type context popped_t' - ] - else if is_trivial_eq sigma t_x - then (* t_x := t = t => we remove this precond *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn popped_t' context - in - let hd,args = destApp sigma t_x in - let get_args hd args = - if eq_constr sigma hd (Lazy.force eq) - then (Lazy.force refl_equal,args.(0),args.(1)) - else (jmeq_refl (),args.(0),args.(1)) - in + [ (* observe_tac "hyp rec" *) + change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp + prove_new_type_of_hyp + ; scan_type context popped_t' ] + else if eq_constr sigma t_x coq_False then + (* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) + (* str " since it has False in its preconds " *) + (* ); *) + raise TOREMOVE (* False -> .. useless *) + else if is_incompatible_eq env sigma t_x then raise TOREMOVE + (* t_x := C1 ... = C2 ... *) + else if + eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) + then + (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) + (* str " removing useless precond True" *) + (* ); *) + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let prove_trivial = + let nb_intro = List.length context in tclTHENLIST - [ - change_hyp_with_using - "prove_trivial_eq" - hyp_id - real_type_of_hyp - ((* observe_tac "prove_trivial_eq" *) - (prove_trivial_eq hyp_id context (get_args hd args))); - scan_type context popped_t' - ] - else - begin - try - let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in - tclTHEN - tac - (scan_type new_context new_t') - with NoChange -> - (* Last thing todo : push the rel in the context and continue *) - scan_type (LocalAssum (x,t_x) :: context) t' - end - end - else - tclIDTAC - in - try - scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id] - with TOREMOVE -> - thin [hyp_id],[] - - -let clean_goal_with_heq ptes_infos continue_tac (dyn_infos:body_info) = - fun g -> - let env = pf_env g - and sigma = project g - in - let tac,new_hyps = - List.fold_left ( - fun (hyps_tac,new_hyps) hyp_id -> - let hyp_tac,new_hyp = - clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + [ tclDO nb_intro (Proofview.V82.of_tactic intro) + ; (fun g -> + let context_hyps = + fst + (list_chop ~msg:"removing True : context_hyps " nb_intro + (pf_ids_of_hyps g)) + in + let to_refine = + applist + ( mkVar hyp_id + , List.rev (coq_I :: List.map mkVar context_hyps) ) + in + refine to_refine g) ] + in + tclTHENLIST + [ change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp + (* observe_tac "prove_trivial" *) prove_trivial + ; scan_type context popped_t' ] + else if is_trivial_eq sigma t_x then + (* t_x := t = t => we remove this precond *) + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let hd, args = destApp sigma t_x in + let get_args hd args = + if eq_constr sigma hd (Lazy.force eq) then + (Lazy.force refl_equal, args.(0), args.(1)) + else (jmeq_refl (), args.(0), args.(1)) + in + tclTHENLIST + [ change_hyp_with_using "prove_trivial_eq" hyp_id real_type_of_hyp + ((* observe_tac "prove_trivial_eq" *) + prove_trivial_eq hyp_id context (get_args hd args)) + ; scan_type context popped_t' ] + else + try + let new_context, new_t', tac = + change_eq env sigma hyp_id context x t_x t' in - (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps - ) - (tclIDTAC,[]) - dyn_infos.rec_hyps - in - let new_infos = - { dyn_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps - } - in - tclTHENLIST - [ - tac ; - (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos) - ] - g + tclTHEN tac (scan_type new_context new_t') + with NoChange -> + (* Last thing todo : push the rel in the context and continue *) + scan_type (LocalAssum (x, t_x) :: context) t' + else tclIDTAC + in + try (scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id]) + with TOREMOVE -> (thin [hyp_id], []) + +let clean_goal_with_heq ptes_infos continue_tac (dyn_infos : body_info) g = + let env = pf_env g and sigma = project g in + let tac, new_hyps = + List.fold_left + (fun (hyps_tac, new_hyps) hyp_id -> + let hyp_tac, new_hyp = + clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + in + (tclTHEN hyp_tac hyps_tac, new_hyp @ new_hyps)) + (tclIDTAC, []) dyn_infos.rec_hyps + in + let new_infos = + {dyn_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps} + in + tclTHENLIST + [tac; (* observe_tac "clean_hyp_with_heq continue" *) continue_tac new_infos] + g let heq_id = Id.of_string "Heq" -let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = - fun g -> - let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in - tclTHENLIST - [ - (* We first introduce the variables *) - tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))); - (* Then the equation itself *) - Proofview.V82.of_tactic (intro_using heq_id); - onLastHypId (fun heq_id -> tclTHENLIST [ - (* Then the new hypothesis *) - tclMAP (fun id -> Proofview.V82.of_tactic (introduction id)) dyn_infos.rec_hyps; - observe_tac "after_introduction" (fun g' -> - (* We get infos on the equations introduced*) - let new_term_value_eq = pf_get_hyp_typ g' heq_id in - (* compute the new value of the body *) - let new_term_value = - match EConstr.kind (project g') new_term_value_eq with - | App(f,[| _;_;args2 |]) -> args2 - | _ -> - observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ - pr_leconstr_env (pf_env g') (project g') new_term_value_eq - ); - anomaly (Pp.str "cannot compute new term value.") - in - let g', termtyp = tac_type_of g' term in - let fun_body = - mkLambda(make_annot Anonymous Sorts.Relevant, - termtyp, - Termops.replace_term (project g') term (mkRel 1) dyn_infos.info - ) - in - let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in - let new_infos = - {dyn_infos with - info = new_body; - eq_hyps = heq_id::dyn_infos.eq_hyps - } - in - clean_goal_with_heq ptes_infos continue_tac new_infos g' - )]) - ] - g - +let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos g = + let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in + tclTHENLIST + [ (* We first introduce the variables *) + tclDO nb_first_intro + (Proofview.V82.of_tactic + (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))) + ; (* Then the equation itself *) + Proofview.V82.of_tactic (intro_using heq_id) + ; onLastHypId (fun heq_id -> + tclTHENLIST + [ (* Then the new hypothesis *) + tclMAP + (fun id -> Proofview.V82.of_tactic (introduction id)) + dyn_infos.rec_hyps + ; observe_tac "after_introduction" (fun g' -> + (* We get infos on the equations introduced*) + let new_term_value_eq = pf_get_hyp_typ g' heq_id in + (* compute the new value of the body *) + let new_term_value = + match EConstr.kind (project g') new_term_value_eq with + | App (f, [|_; _; args2|]) -> args2 + | _ -> + observe + ( str "cannot compute new term value : " + ++ pr_gls g' ++ fnl () ++ str "last hyp is" + ++ pr_leconstr_env (pf_env g') (project g') + new_term_value_eq ); + anomaly (Pp.str "cannot compute new term value.") + in + let g', termtyp = tac_type_of g' term in + let fun_body = + mkLambda + ( make_annot Anonymous Sorts.Relevant + , termtyp + , Termops.replace_term (project g') term (mkRel 1) + dyn_infos.info ) + in + let new_body = + pf_nf_betaiota g' (mkApp (fun_body, [|new_term_value|])) + in + let new_infos = + { dyn_infos with + info = new_body + ; eq_hyps = heq_id :: dyn_infos.eq_hyps } + in + clean_goal_with_heq ptes_infos continue_tac new_infos g') ]) + ] + g let my_orelse tac1 tac2 g = - try - tac1 g + try tac1 g with e when CErrors.noncritical e -> -(* observe (str "using snd tac since : " ++ CErrors.print e); *) + (* observe (str "using snd tac since : " ++ CErrors.print e); *) tac2 g -let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = - let args = Array.of_list (List.map mkVar args_id) in +let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = + let args = Array.of_list (List.map mkVar args_id) in let instantiate_one_hyp hid = my_orelse - ( (* we instantiate the hyp if possible *) - fun g -> - let prov_hid = pf_get_new_id hid g in - let c = mkApp(mkVar hid,args) in - let evm, _ = pf_apply Typing.type_of g c in - tclTHENLIST[ - Refiner.tclEVARS evm; - Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); - thin [hid]; - Proofview.V82.of_tactic (rename_hyp [prov_hid,hid]) - ] g - ) - ( (* + (fun (* we instantiate the hyp if possible *) + g -> + let prov_hid = pf_get_new_id hid g in + let c = mkApp (mkVar hid, args) in + let evm, _ = pf_apply Typing.type_of g c in + tclTHENLIST + [ Refiner.tclEVARS evm + ; Proofview.V82.of_tactic (pose_proof (Name prov_hid) c) + ; thin [hid] + ; Proofview.V82.of_tactic (rename_hyp [(prov_hid, hid)]) ] + g) + (fun (* if not then we are in a mutual function block and this hyp is a recursive hyp on an other function. @@ -587,350 +548,314 @@ let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = principle so that we can trash it *) - (fun g -> -(* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) - thin [hid] g - ) - ) + g -> + (* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) + thin [hid] g) in - if List.is_empty args_id - then - tclTHENLIST [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; - do_prove hyps - ] + if List.is_empty args_id then + tclTHENLIST + [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps + ; do_prove hyps ] else tclTHENLIST - [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; - tclMAP instantiate_one_hyp hyps; - (fun g -> - let all_g_hyps_id = - List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty - in - let remaining_hyps = - List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps - in - do_prove remaining_hyps g - ) - ] + [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps + ; tclMAP instantiate_one_hyp hyps + ; (fun g -> + let all_g_hyps_id = + List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty + in + let remaining_hyps = + List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps + in + do_prove remaining_hyps g) ] -let build_proof - (interactive_proof:bool) - (fnames:Constant.t list) - ptes_infos - dyn_infos - : tactic = +let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos + dyn_infos : tactic = let rec build_proof_aux do_finalize dyn_infos : tactic = - fun g -> - let env = pf_env g in - let sigma = project g in -(* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match EConstr.kind sigma dyn_infos.info with - | Case(ci,ct,t,cb) -> - let do_finalize_t dyn_info' = - fun g -> - let t = dyn_info'.info in - let dyn_infos = {dyn_info' with info = - mkCase(ci,ct,t,cb)} in - let g_nb_prod = nb_prod (project g) (pf_concl g) in - let g, type_of_term = tac_type_of g t in - let term_eq = - make_refl_eq (Lazy.force refl_equal) type_of_term t - in - tclTHENLIST - [ - Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps))); - thin dyn_infos.rec_hyps; - Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); - (fun g -> observe_tac "toto" ( - tclTHENLIST [Proofview.V82.of_tactic (Simple.case t); - (fun g' -> - let g'_nb_prod = nb_prod (project g') (pf_concl g') in - let nb_instantiate_partial = g'_nb_prod - g_nb_prod in - observe_tac "treat_new_case" - (treat_new_case - ptes_infos - nb_instantiate_partial - (build_proof do_finalize) - t - dyn_infos) - g' - ) - - ]) g - ) - ] - g - in - build_proof do_finalize_t {dyn_infos with info = t} g - | Lambda(n,t,b) -> - begin - match EConstr.kind sigma (pf_concl g) with - | Prod _ -> - tclTHEN - (Proofview.V82.of_tactic intro) - (fun g' -> - let open Context.Named.Declaration in - let id = pf_last_hyp g' |> get_id in - let new_term = - pf_nf_betaiota g' - (mkApp(dyn_infos.info,[|mkVar id|])) - in - let new_infos = {dyn_infos with info = new_term} in - let do_prove new_hyps = - build_proof do_finalize - {new_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps - } - in -(* observe_tac "Lambda" *) (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' - (* build_proof do_finalize new_infos g' *) - ) g - | _ -> - do_finalize dyn_infos g - end - | Cast(t,_,_) -> - build_proof do_finalize {dyn_infos with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ | Float _ -> - do_finalize dyn_infos g - | App(_,_) -> - let f,args = decompose_app sigma dyn_infos.info in - begin - match EConstr.kind sigma f with - | Int _ -> user_err Pp.(str "integer cannot be applied") - | Float _ -> user_err Pp.(str "float cannot be applied") - | App _ -> assert false (* we have collected all the app in decompose_app *) - | Proj _ -> assert false (*FIXME*) - | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in - build_proof_args env sigma do_finalize new_infos g - | Const (c,_) when not (List.mem_f Constant.equal c fnames) -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in -(* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) - build_proof_args env sigma do_finalize new_infos g - | Const _ -> - do_finalize dyn_infos g - | Lambda _ -> - let new_term = - Reductionops.nf_beta env sigma dyn_infos.info in - build_proof do_finalize {dyn_infos with info = new_term} - g - | LetIn _ -> - let new_infos = - { dyn_infos with info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> - h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Locusops.onConcl; - build_proof do_finalize new_infos - ] - g - | Cast(b,_,_) -> - build_proof do_finalize {dyn_infos with info = b } g - | Case _ | Fix _ | CoFix _ -> - let new_finalize dyn_infos = - let new_infos = - { dyn_infos with - info = dyn_infos.info,args - } - in - build_proof_args env sigma do_finalize new_infos - in - build_proof new_finalize {dyn_infos with info = f } g - end - | Fix _ | CoFix _ -> - user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) - - - | Proj _ -> user_err Pp.(str "Prod") - | Prod _ -> do_finalize dyn_infos g - | LetIn _ -> - let new_infos = - { dyn_infos with - info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info - } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Locusops.onConcl; - build_proof do_finalize new_infos - ] g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - and build_proof do_finalize dyn_infos g = -(* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - Indfun_common.observe_tac (fun env sigma -> - str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g - and build_proof_args env sigma do_finalize dyn_infos (* f_args' args *) :tactic = - fun g -> - let (f_args',args) = dyn_infos.info in - let tac : tactic = - fun g -> - match args with - | [] -> - do_finalize {dyn_infos with info = f_args'} g - | arg::args -> - (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) - (* fnl () ++ *) - (* pr_goal (Tacmach.sig_it g) *) - (* ); *) - let do_finalize dyn_infos = - let new_arg = dyn_infos.info in - (* tclTRYD *) - (build_proof_args env sigma - do_finalize - {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} - ) - in + fun g -> + let env = pf_env g in + let sigma = project g in + (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) + match EConstr.kind sigma dyn_infos.info with + | Case (ci, ct, t, cb) -> + let do_finalize_t dyn_info' g = + let t = dyn_info'.info in + let dyn_infos = {dyn_info' with info = mkCase (ci, ct, t, cb)} in + let g_nb_prod = nb_prod (project g) (pf_concl g) in + let g, type_of_term = tac_type_of g t in + let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in + tclTHENLIST + [ Proofview.V82.of_tactic + (generalize (term_eq :: List.map mkVar dyn_infos.rec_hyps)) + ; thin dyn_infos.rec_hyps + ; Proofview.V82.of_tactic + (pattern_option [(Locus.AllOccurrencesBut [1], t)] None) + ; (fun g -> + observe_tac "toto" + (tclTHENLIST + [ Proofview.V82.of_tactic (Simple.case t) + ; (fun g' -> + let g'_nb_prod = nb_prod (project g') (pf_concl g') in + let nb_instantiate_partial = g'_nb_prod - g_nb_prod in + observe_tac "treat_new_case" + (treat_new_case ptes_infos nb_instantiate_partial + (build_proof do_finalize) t dyn_infos) + g') ]) + g) ] + g + in + build_proof do_finalize_t {dyn_infos with info = t} g + | Lambda (n, t, b) -> ( + match EConstr.kind sigma (pf_concl g) with + | Prod _ -> + tclTHEN + (Proofview.V82.of_tactic intro) + (fun g' -> + let open Context.Named.Declaration in + let id = pf_last_hyp g' |> get_id in + let new_term = + pf_nf_betaiota g' (mkApp (dyn_infos.info, [|mkVar id|])) + in + let new_infos = {dyn_infos with info = new_term} in + let do_prove new_hyps = build_proof do_finalize - {dyn_infos with info = arg } - g + { new_infos with + rec_hyps = new_hyps + ; nb_rec_hyps = List.length new_hyps } + in + (* observe_tac "Lambda" *) + (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' + (* build_proof do_finalize new_infos g' *)) + g + | _ -> do_finalize dyn_infos g ) + | Cast (t, _, _) -> build_proof do_finalize {dyn_infos with info = t} g + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ + |Float _ -> + do_finalize dyn_infos g + | App (_, _) -> ( + let f, args = decompose_app sigma dyn_infos.info in + match EConstr.kind sigma f with + | Int _ -> user_err Pp.(str "integer cannot be applied") + | Float _ -> user_err Pp.(str "float cannot be applied") + | App _ -> + assert false (* we have collected all the app in decompose_app *) + | Proj _ -> assert false (*FIXME*) + | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ + -> + let new_infos = {dyn_infos with info = (f, args)} in + build_proof_args env sigma do_finalize new_infos g + | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> + let new_infos = {dyn_infos with info = (f, args)} in + (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) + build_proof_args env sigma do_finalize new_infos g + | Const _ -> do_finalize dyn_infos g + | Lambda _ -> + let new_term = Reductionops.nf_beta env sigma dyn_infos.info in + build_proof do_finalize {dyn_infos with info = new_term} g + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } + in + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + g + | Cast (b, _, _) -> build_proof do_finalize {dyn_infos with info = b} g + | Case _ | Fix _ | CoFix _ -> + let new_finalize dyn_infos = + let new_infos = {dyn_infos with info = (dyn_infos.info, args)} in + build_proof_args env sigma do_finalize new_infos + in + build_proof new_finalize {dyn_infos with info = f} g ) + | Fix _ | CoFix _ -> + user_err Pp.(str "Anonymous local (co)fixpoints are not handled yet") + | Proj _ -> user_err Pp.(str "Prod") + | Prod _ -> do_finalize dyn_infos g + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } in - (* observe_tac "build_proof_args" *) (tac ) g + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + g + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + and build_proof do_finalize dyn_infos g = + (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) + Indfun_common.observe_tac + (fun env sigma -> + str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info) + (build_proof_aux do_finalize dyn_infos) + g + and build_proof_args env sigma do_finalize dyn_infos : tactic = + (* f_args' args *) + fun g -> + let f_args', args = dyn_infos.info in + let tac : tactic = + fun g -> + match args with + | [] -> do_finalize {dyn_infos with info = f_args'} g + | arg :: args -> + (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) + (* fnl () ++ *) + (* pr_goal (Tacmach.sig_it g) *) + (* ); *) + let do_finalize dyn_infos = + let new_arg = dyn_infos.info in + (* tclTRYD *) + build_proof_args env sigma do_finalize + {dyn_infos with info = (mkApp (f_args', [|new_arg|]), args)} + in + build_proof do_finalize {dyn_infos with info = arg} g + in + (* observe_tac "build_proof_args" *) tac g in let do_finish_proof dyn_infos = - (* tclTRYD *) (clean_goal_with_heq - ptes_infos - finish_proof dyn_infos) + (* tclTRYD *) clean_goal_with_heq ptes_infos finish_proof dyn_infos in - (* observe_tac "build_proof" *) + (* observe_tac "build_proof" *) fun g -> build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g - (* Proof of principles from structural functions *) type static_fix_info = - { - idx : int; - name : Id.t; - types : types; - offset : int; - nb_realargs : int; - body_with_param : constr; - num_in_block : int - } - - - -let prove_rec_hyp_for_struct fix_info = - (fun eq_hyps -> tclTHEN - (rewrite_until_var (fix_info.idx) eq_hyps) - (fun g -> - let _,pte_args = destApp (project g) (pf_concl g) in - let rec_hyp_proof = - mkApp(mkVar fix_info.name,array_get_start pte_args) - in - refine rec_hyp_proof g - )) + { idx : int + ; name : Id.t + ; types : types + ; offset : int + ; nb_realargs : int + ; body_with_param : constr + ; num_in_block : int } + +let prove_rec_hyp_for_struct fix_info eq_hyps = + tclTHEN (rewrite_until_var fix_info.idx eq_hyps) (fun g -> + let _, pte_args = destApp (project g) (pf_concl g) in + let rec_hyp_proof = + mkApp (mkVar fix_info.name, array_get_start pte_args) + in + refine rec_hyp_proof g) -let prove_rec_hyp fix_info = - { proving_tac = prove_rec_hyp_for_struct fix_info - ; - is_valid = fun _ -> true - } +let prove_rec_hyp fix_info = + {proving_tac = prove_rec_hyp_for_struct fix_info; is_valid = (fun _ -> true)} let generalize_non_dep hyp g = -(* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) + (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in let env = Global.env () in let hyp_typ = pf_get_hyp_typ g hyp in - let to_revert,_ = + let to_revert, _ = let open Context.Named.Declaration in - Environ.fold_named_context_reverse (fun (clear,keep) decl -> - let decl = map_named_decl EConstr.of_constr decl in - let hyp = get_id decl in - if Id.List.mem hyp hyps - || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep - || Termops.occur_var env (project g) hyp hyp_typ - || Termops.is_section_variable hyp (* should be dangerous *) - then (clear,decl::keep) - else (hyp::clear,keep)) - ~init:([],[]) (pf_env g) + Environ.fold_named_context_reverse + (fun (clear, keep) decl -> + let decl = map_named_decl EConstr.of_constr decl in + let hyp = get_id decl in + if + Id.List.mem hyp hyps + || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep + || Termops.occur_var env (project g) hyp hyp_typ + || Termops.is_section_variable hyp + (* should be dangerous *) + then (clear, decl :: keep) + else (hyp :: clear, keep)) + ~init:([], []) (pf_env g) in -(* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) + (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN - ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize (List.map mkVar to_revert) ))) - ((* observe_tac "thin" *) (thin to_revert)) + ((* observe_tac "h_generalize" *) Proofview.V82.of_tactic + (generalize (List.map mkVar to_revert))) + ((* observe_tac "thin" *) thin to_revert) g let id_of_decl = RelDecl.get_name %> Nameops.Name.get_id let var_of_decl = id_of_decl %> mkVar + let revert idl = - tclTHEN - (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) - (thin idl) + tclTHEN (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) (thin idl) -let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num = -(* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) -(* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) -(* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) +let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num + = + (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) + (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) + (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) let f_def = Global.lookup_constant (fst (destConst evd f)) in - let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in - let (f_body, _, _) = Option.get (Global.body_of_constant_body Library.indirect_accessor f_def) in + let eq_lhs = + mkApp + ( f + , Array.init (nb_params + nb_args) (fun i -> + mkRel (nb_params + nb_args - i)) ) + in + let f_body, _, _ = + Option.get (Global.body_of_constant_body Library.indirect_accessor f_def) + in let f_body = EConstr.of_constr f_body in - let params,f_body_with_params = decompose_lam_n evd nb_params f_body in - let (_,num),(_,_,bodies) = destFix evd f_body_with_params in + let params, f_body_with_params = decompose_lam_n evd nb_params f_body in + let (_, num), (_, _, bodies) = destFix evd f_body_with_params in let fnames_with_params = - let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in - let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in + let params = Array.init nb_params (fun i -> mkRel (nb_params - i)) in + let fnames = + List.rev (Array.to_list (Array.map (fun f -> mkApp (f, params)) fnames)) + in fnames in -(* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) -(* observe (str "body " ++ pr_lconstr bodies.(num)); *) - let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in -(* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) - let eq_rhs = Reductionops.nf_betaiotazeta (Global.env ()) evd (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in + (* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) + (* observe (str "body " ++ pr_lconstr bodies.(num)); *) + let f_body_with_params_and_other_fun = + substl fnames_with_params bodies.(num) + in + (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) + let eq_rhs = + Reductionops.nf_betaiotazeta (Global.env ()) evd + (mkApp + ( compose_lam params f_body_with_params_and_other_fun + , Array.init (nb_params + nb_args) (fun i -> + mkRel (nb_params + nb_args - i)) )) + in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) - let (type_ctxt,type_of_f),evd = - let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f - in - decompose_prod_n_assum evd - (nb_params + nb_args) t,evd + let (type_ctxt, type_of_f), evd = + let evd, t = Typing.type_of ~refresh:true (Global.env ()) evd f in + (decompose_prod_n_assum evd (nb_params + nb_args) t, evd) in - let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in + let eqn = mkApp (Lazy.force eq, [|type_of_f; eq_lhs; eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in (* Pp.msgnl (str "lemma type " ++ Printer.pr_lconstr lemma_type ++ fnl () ++ str "f_body " ++ Printer.pr_lconstr f_body); *) let f_id = Label.to_id (Constant.label (fst (destConst evd f))) in let prove_replacement = tclTHENLIST - [ - tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro); - observe_tac "" (fun g -> - let rec_id = pf_nth_hyp_id g 1 in - tclTHENLIST - [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id); - observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); - (Proofview.V82.of_tactic intros_reflexivity)] g - ) - ] + [ tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro) + ; observe_tac "" (fun g -> + let rec_id = pf_nth_hyp_id g 1 in + tclTHENLIST + [ observe_tac "generalize_non_dep in generate_equation_lemma" + (generalize_non_dep rec_id) + ; observe_tac "h_case" + (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))) + ; Proofview.V82.of_tactic intros_reflexivity ] + g) ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) - let lemma = Lemmas.start_lemma ~name:(mk_equation_id f_id) ~poly:false evd lemma_type in - let lemma,_ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in + let lemma = + Lemmas.start_lemma ~name:(mk_equation_id f_id) ~poly:false evd lemma_type + in + let lemma, _ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in + let () = + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent ~idopt:None + in evd -let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = +let do_replace (evd : Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num + all_funs g = let equation_lemma = try let finfos = @@ -939,376 +864,366 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a | Some finfos -> finfos in mkConst (Option.get finfos.equation_lemma) - with (Not_found | Option.IsNone as e) -> + with (Not_found | Option.IsNone) as e -> let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) - let equation_lemma_id = (mk_equation_id f_id) in - evd := generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; + let equation_lemma_id = mk_equation_id f_id in + evd := + generate_equation_lemma !evd all_funs f fun_num (List.length params) + (List.length rev_args_id) rec_arg_num; let _ = match e with - | Option.IsNone -> - let finfos = match find_Function_infos (fst (destConst !evd f)) with - | None -> raise Not_found - | Some finfos -> finfos - in - update_Function - {finfos with - equation_lemma = Some ( - match Nametab.locate (qualid_of_ident equation_lemma_id) with - | GlobRef.ConstRef c -> c - | _ -> CErrors.anomaly (Pp.str "Not a constant.") - ) - } - | _ -> () + | Option.IsNone -> + let finfos = + match find_Function_infos (fst (destConst !evd f)) with + | None -> raise Not_found + | Some finfos -> finfos + in + update_Function + { finfos with + equation_lemma = + Some + ( match Nametab.locate (qualid_of_ident equation_lemma_id) with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } + | _ -> () in (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) - let evd',res = - Evd.fresh_global - (Global.env ()) !evd + let evd', res = + Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in - evd:=evd'; + evd := evd'; let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd res in evd := sigma; res in let nb_intro_to_do = nb_prod (project g) (pf_concl g) in - tclTHEN - (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) - ( - fun g' -> - let just_introduced = nLastDecls nb_intro_to_do g' in - let open Context.Named.Declaration in - let just_introduced_id = List.map get_id just_introduced in - tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) - (revert just_introduced_id) g' - ) - g + tclTHEN + (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) + (fun g' -> + let just_introduced = nLastDecls nb_intro_to_do g' in + let open Context.Named.Declaration in + let just_introduced_id = List.map get_id just_introduced in + tclTHEN + (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) + (revert just_introduced_id) + g') + g -let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnames all_funs _nparams : tactic = - fun g -> +let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num + fnames all_funs _nparams : tactic = + fun g -> let princ_type = pf_concl g in (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) (* Pp.msgnl (str "all_funs "); *) (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) - let princ_info = compute_elim_sig (project g) princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps g) in - (fun na -> - let new_id = - match na with - Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" - in - avoid := new_id :: !avoid; - (Name new_id) - ) - in - let fresh_decl = RelDecl.map_name fresh_id in - let princ_info : elim_scheme = - { princ_info with - params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; - args = List.map fresh_decl princ_info.args - } - in - let get_body const = - match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let env = Global.env () in - let sigma = Evd.from_env env in - Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - env - sigma - (EConstr.of_constr body) - | None -> user_err Pp.(str "Cannot define a principle over an axiom ") - in - let fbody = get_body fnames.(fun_num) in - let f_ctxt,f_body = decompose_lam (project g) fbody in - let f_ctxt_length = List.length f_ctxt in - let diff_params = princ_info.nparams - f_ctxt_length in - let full_params,princ_params,fbody_with_full_params = - if diff_params > 0 - then - let princ_params,full_params = - list_chop diff_params princ_info.params - in - (full_params, (* real params *) - princ_params, (* the params of the principle which are not params of the function *) - substl (* function instantiated with real params *) - (List.map var_of_decl full_params) - f_body - ) - else - let f_ctxt_other,f_ctxt_params = - list_chop (- diff_params) f_ctxt in - let f_body = compose_lam f_ctxt_other f_body in - (princ_info.params, (* real params *) - [],(* all params are full params *) - substl (* function instantiated with real params *) - (List.map var_of_decl princ_info.params) - f_body - ) - in - observe (str "full_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - full_params - ); - observe (str "princ_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - princ_params - ); - observe (str "fbody_with_full_params := " ++ - pr_leconstr_env (Global.env ()) !evd fbody_with_full_params - ); - let all_funs_with_full_params = - Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs - in - let fix_offset = List.length princ_params in - let ptes_to_fix,infos = - match EConstr.kind (project g) fbody_with_full_params with - | Fix((idxs,i),(names,typess,bodies)) -> - let bodies_with_all_params = - Array.map - (fun body -> - Reductionops.nf_betaiota (pf_env g) (project g) - (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, - List.rev_map var_of_decl princ_params)) - ) - bodies + let princ_info = compute_elim_sig (project g) princ_type in + let fresh_id = + let avoid = ref (pf_ids_of_hyps g) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + Name new_id + in + let fresh_decl = RelDecl.map_name fresh_id in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } + in + let get_body const = + match Global.body_of_constant Library.indirect_accessor const with + | Some (body, _, _) -> + let env = Global.env () in + let sigma = Evd.from_env env in + Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + env sigma (EConstr.of_constr body) + | None -> user_err Pp.(str "Cannot define a principle over an axiom ") + in + let fbody = get_body fnames.(fun_num) in + let f_ctxt, f_body = decompose_lam (project g) fbody in + let f_ctxt_length = List.length f_ctxt in + let diff_params = princ_info.nparams - f_ctxt_length in + let full_params, princ_params, fbody_with_full_params = + if diff_params > 0 then + let princ_params, full_params = list_chop diff_params princ_info.params in + ( full_params + , (* real params *) + princ_params + , (* the params of the principle which are not params of the function *) + substl (* function instantiated with real params *) + (List.map var_of_decl full_params) + f_body ) + else + let f_ctxt_other, f_ctxt_params = list_chop (-diff_params) f_ctxt in + let f_body = compose_lam f_ctxt_other f_body in + ( princ_info.params + , (* real params *) + [] + , (* all params are full params *) + substl (* function instantiated with real params *) + (List.map var_of_decl princ_info.params) + f_body ) + in + observe + ( str "full_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + full_params ); + observe + ( str "princ_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + princ_params ); + observe + ( str "fbody_with_full_params := " + ++ pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); + let all_funs_with_full_params = + Array.map + (fun f -> applist (f, List.rev_map var_of_decl full_params)) + all_funs + in + let fix_offset = List.length princ_params in + let ptes_to_fix, infos = + match EConstr.kind (project g) fbody_with_full_params with + | Fix ((idxs, i), (names, typess, bodies)) -> + let bodies_with_all_params = + Array.map + (fun body -> + Reductionops.nf_betaiota (pf_env g) (project g) + (applist + ( substl + (List.rev (Array.to_list all_funs_with_full_params)) + body + , List.rev_map var_of_decl princ_params ))) + bodies + in + let info_array = + Array.mapi + (fun i types -> + let types = + prod_applist (project g) types + (List.rev_map var_of_decl princ_params) in - let info_array = - Array.mapi - (fun i types -> - let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in - { idx = idxs.(i) - fix_offset; - name = Nameops.Name.get_id (fresh_id names.(i).binder_name); - types = types; - offset = fix_offset; - nb_realargs = - List.length - (fst (decompose_lam (project g) bodies.(i))) - fix_offset; - body_with_param = bodies_with_all_params.(i); - num_in_block = i - } - ) - typess + { idx = idxs.(i) - fix_offset + ; name = Nameops.Name.get_id (fresh_id names.(i).binder_name) + ; types + ; offset = fix_offset + ; nb_realargs = + List.length (fst (decompose_lam (project g) bodies.(i))) + - fix_offset + ; body_with_param = bodies_with_all_params.(i) + ; num_in_block = i }) + typess + in + let pte_to_fix, rev_info = + List.fold_left_i + (fun i (acc_map, acc_info) decl -> + let pte = RelDecl.get_name decl in + let infos = info_array.(i) in + let type_args, _ = decompose_prod (project g) infos.types in + let nargs = List.length type_args in + let f = + applist + (mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in - let pte_to_fix,rev_info = - List.fold_left_i - (fun i (acc_map,acc_info) decl -> - let pte = RelDecl.get_name decl in - let infos = info_array.(i) in - let type_args,_ = decompose_prod (project g) infos.types in - let nargs = List.length type_args in - let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in - let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in - let app_f = mkApp(f,first_args) in - let pte_args = (Array.to_list first_args)@[app_f] in - let app_pte = applist(mkVar (Nameops.Name.get_id pte),pte_args) in - let body_with_param,num = - let body = get_body fnames.(i) in - let body_with_full_params = - Reductionops.nf_betaiota (pf_env g) (project g) ( - applist(body,List.rev_map var_of_decl full_params)) - in - match EConstr.kind (project g) body_with_full_params with - | Fix((_,num),(_,_,bs)) -> - Reductionops.nf_betaiota (pf_env g) (project g) - ( - (applist - (substl - (List.rev - (Array.to_list all_funs_with_full_params)) - bs.(num), - List.rev_map var_of_decl princ_params)) - ),num - | _ -> user_err Pp.(str "Not a mutual block") - in - let info = - {infos with - types = compose_prod type_args app_pte; - body_with_param = body_with_param; - num_in_block = num - } - in -(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) -(* str " to " ++ Ppconstr.pr_id info.name); *) - (Id.Map.add (Nameops.Name.get_id pte) info acc_map,info::acc_info) - ) - 0 - (Id.Map.empty,[]) - (List.rev princ_info.predicates) + let first_args = Array.init nargs (fun i -> mkRel (nargs - i)) in + let app_f = mkApp (f, first_args) in + let pte_args = Array.to_list first_args @ [app_f] in + let app_pte = applist (mkVar (Nameops.Name.get_id pte), pte_args) in + let body_with_param, num = + let body = get_body fnames.(i) in + let body_with_full_params = + Reductionops.nf_betaiota (pf_env g) (project g) + (applist (body, List.rev_map var_of_decl full_params)) + in + match EConstr.kind (project g) body_with_full_params with + | Fix ((_, num), (_, _, bs)) -> + ( Reductionops.nf_betaiota (pf_env g) (project g) + (applist + ( substl + (List.rev (Array.to_list all_funs_with_full_params)) + bs.(num) + , List.rev_map var_of_decl princ_params )) + , num ) + | _ -> user_err Pp.(str "Not a mutual block") in - pte_to_fix,List.rev rev_info - | _ -> - Id.Map.empty,[] - in - let mk_fixes : tactic = - let pre_info,infos = list_chop fun_num infos in - match pre_info,infos with - | _,[] -> tclIDTAC - | _, this_fix_info::others_infos -> - let other_fix_infos = - List.map - (fun fi -> fi.name,fi.idx + 1 ,fi.types) - (pre_info@others_infos) + let info = + { infos with + types = compose_prod type_args app_pte + ; body_with_param + ; num_in_block = num } in - if List.is_empty other_fix_infos - then - if this_fix_info.idx + 1 = 0 - then tclIDTAC (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) - else - Indfun_common.observe_tac (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx +1)) - (Proofview.V82.of_tactic (fix this_fix_info.name (this_fix_info.idx +1))) - else - Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) - other_fix_infos 0) - in - let first_tac : tactic = (* every operations until fix creations *) + (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) + (* str " to " ++ Ppconstr.pr_id info.name); *) + (Id.Map.add (Nameops.Name.get_id pte) info acc_map, info :: acc_info)) + 0 (Id.Map.empty, []) + (List.rev princ_info.predicates) + in + (pte_to_fix, List.rev rev_info) + | _ -> (Id.Map.empty, []) + in + let mk_fixes : tactic = + let pre_info, infos = list_chop fun_num infos in + match (pre_info, infos) with + | _, [] -> tclIDTAC + | _, this_fix_info :: others_infos -> + let other_fix_infos = + List.map + (fun fi -> (fi.name, fi.idx + 1, fi.types)) + (pre_info @ others_infos) + in + if List.is_empty other_fix_infos then + if this_fix_info.idx + 1 = 0 then tclIDTAC + (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) + else + Indfun_common.observe_tac + (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx + 1)) + (Proofview.V82.of_tactic + (fix this_fix_info.name (this_fix_info.idx + 1))) + else + Proofview.V82.of_tactic + (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) + other_fix_infos 0) + in + let first_tac : tactic = + (* every operations until fix creations *) + tclTHENLIST + [ observe_tac "introducing params" + (Proofview.V82.of_tactic + (intros_using (List.rev_map id_of_decl princ_info.params))) + ; observe_tac "introducing predictes" + (Proofview.V82.of_tactic + (intros_using (List.rev_map id_of_decl princ_info.predicates))) + ; observe_tac "introducing branches" + (Proofview.V82.of_tactic + (intros_using (List.rev_map id_of_decl princ_info.branches))) + ; observe_tac "building fixes" mk_fixes ] + in + let intros_after_fixes : tactic = + fun gl -> + let ctxt, pte_app = decompose_prod_assum (project gl) (pf_concl gl) in + let pte, pte_args = decompose_app (project gl) pte_app in + try + let pte = + try destVar (project gl) pte + with DestKO -> anomaly (Pp.str "Property is not a variable.") + in + let fix_info = Id.Map.find pte ptes_to_fix in + let nb_args = fix_info.nb_realargs in tclTHENLIST - [ observe_tac "introducing params" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params))); - observe_tac "introducing predictes" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates))); - observe_tac "introducing branches" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches))); - observe_tac "building fixes" mk_fixes; - ] - in - let intros_after_fixes : tactic = - fun gl -> - let ctxt,pte_app = (decompose_prod_assum (project gl) (pf_concl gl)) in - let pte,pte_args = (decompose_app (project gl) pte_app) in - try - let pte = - try destVar (project gl) pte - with DestKO -> anomaly (Pp.str "Property is not a variable.") - in - let fix_info = Id.Map.find pte ptes_to_fix in - let nb_args = fix_info.nb_realargs in - tclTHENLIST - [ - (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic intro)); - (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let fix_body = fix_info.body_with_param in -(* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { - nb_rec_hyps = -100; - rec_hyps = []; - info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist(fix_body,List.rev_map mkVar args_id)); - eq_hyps = [] - } + [ (* observe_tac ("introducing args") *) + tclDO nb_args (Proofview.V82.of_tactic intro) + ; (fun g -> + (* replacement of the function by its body *) + let args = nLastDecls nb_args g in + let fix_body = fix_info.body_with_param in + (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota (pf_env g) (project g) + (applist (fix_body, List.rev_map mkVar args_id)) + ; eq_hyps = [] } + in + tclTHENLIST + [ observe_tac "do_replace" + (do_replace evd full_params + (fix_info.idx + List.length princ_params) + ( args_id + @ List.map + (RelDecl.get_name %> Nameops.Name.get_id) + princ_params ) + all_funs.(fix_info.num_in_block) + fix_info.num_in_block all_funs) + ; (let do_prove = + build_proof interactive_proof (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) in - tclTHENLIST - [ - observe_tac "do_replace" - (do_replace evd - full_params - (fix_info.idx + List.length princ_params) - (args_id@(List.map (RelDecl.get_name %> Nameops.Name.get_id) princ_params)) - (all_funs.(fix_info.num_in_block)) - fix_info.num_in_block - all_funs - ); - let do_prove = - build_proof - interactive_proof - (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - {dyn_infos with - rec_hyps = branches; - nb_rec_hyps = List.length branches - } - in - observe_tac "cleaning" (clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove - dyn_infos) - in -(* observe (str "branches := " ++ *) -(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) -(* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) - -(* ); *) - (* observe_tac "instancing" *) (instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id)) - ] - g - ); - ] gl - with Not_found -> - let nb_args = min (princ_info.nargs) (List.length ctxt) in - tclTHENLIST - [ - tclDO nb_args (Proofview.V82.of_tactic intro); - (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { - nb_rec_hyps = -100; - rec_hyps = []; - info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist(fbody_with_full_params, - (List.rev_map var_of_decl princ_params)@ - (List.rev_map mkVar args_id) - )); - eq_hyps = [] - } + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + observe_tac "cleaning" + (clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos) in - let fname = destConst (project g) (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) in - tclTHENLIST - [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]); - let do_prove = - build_proof - interactive_proof - (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - {dyn_infos with - rec_hyps = branches; - nb_rec_hyps = List.length branches - } - in - clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove - dyn_infos - in - instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id) - ] - g - ) - ] - gl - in - tclTHEN - first_tac - intros_after_fixes - g - - - - - + (* observe (str "branches := " ++ *) + (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) + (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) + + (* ); *) + (* observe_tac "instancing" *) + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ] + g) ] + gl + with Not_found -> + let nb_args = min princ_info.nargs (List.length ctxt) in + tclTHENLIST + [ tclDO nb_args (Proofview.V82.of_tactic intro) + ; (fun g -> + (* replacement of the function by its body *) + let args = nLastDecls nb_args g in + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota (pf_env g) (project g) + (applist + ( fbody_with_full_params + , List.rev_map var_of_decl princ_params + @ List.rev_map mkVar args_id )) + ; eq_hyps = [] } + in + let fname = + destConst (project g) + (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) + in + tclTHENLIST + [ Proofview.V82.of_tactic + (unfold_in_concl + [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]) + ; (let do_prove = + build_proof interactive_proof (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos + in + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ] + g) ] + gl + in + tclTHEN first_tac intros_after_fixes g (* Proof of principles of general functions *) (* let hrec_id = Recdef.hrec_id *) @@ -1319,132 +1234,119 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (* and list_rewrite = Recdef.list_rewrite *) (* and evaluable_of_global_reference = Recdef.evaluable_of_global_reference *) - - - - let prove_with_tcc tcc_lemma_constr eqs : tactic = match !tcc_lemma_constr with | Undefined -> anomaly (Pp.str "No tcc proof !!") | Value lemma -> - fun gls -> -(* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) -(* let ids = hid::pf_ids_of_hyps gls in *) - tclTHENLIST - [ -(* generalize [lemma]; *) -(* h_intro hid; *) -(* Elim.h_decompose_and (mkVar hid); *) - tclTRY(list_rewrite true eqs); -(* (fun g -> *) -(* let ids' = pf_ids_of_hyps g in *) -(* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) -(* rewrite *) -(* ) *) - Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some [])) - ] - gls + fun gls -> + (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) + (* let ids = hid::pf_ids_of_hyps gls in *) + tclTHENLIST + [ (* generalize [lemma]; *) + (* h_intro hid; *) + (* Elim.h_decompose_and (mkVar hid); *) + tclTRY (list_rewrite true eqs) + ; (* (fun g -> *) + (* let ids' = pf_ids_of_hyps g in *) + (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) + (* rewrite *) + (* ) *) + Proofview.V82.of_tactic (Eauto.gen_eauto (false, 5) [] (Some [])) ] + gls | Not_needed -> tclIDTAC let backtrack_eqs_until_hrec hrec eqs : tactic = - fun gls -> - let eqs = List.map mkVar eqs in - let rewrite = - tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) - in - let _,hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in - let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in - let f = (fst (destApp (project gls) f_app)) in - let rec backtrack : tactic = - fun g -> - let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in - match EConstr.kind (project g) f_app with - | App(f',_) when eq_constr (project g) f' f -> tclIDTAC g - | _ -> tclTHEN rewrite backtrack g - in - backtrack gls - + fun gls -> + let eqs = List.map mkVar eqs in + let rewrite = + tclFIRST + (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs) + in + let _, hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in + let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in + let f = fst (destApp (project gls) f_app) in + let rec backtrack : tactic = + fun g -> + let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in + match EConstr.kind (project g) f_app with + | App (f', _) when eq_constr (project g) f' f -> tclIDTAC g + | _ -> tclTHEN rewrite backtrack g + in + backtrack gls let rec rewrite_eqs_in_eqs eqs = match eqs with - | [] -> tclIDTAC - | eq::eqs -> - - tclTHEN - (tclMAP - (fun id gl -> - observe_tac - (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) - (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences - true (* dep proofs also: *) true id (mkVar eq) false))) - gl - ) - eqs - ) - (rewrite_eqs_in_eqs eqs) + | [] -> tclIDTAC + | eq :: eqs -> + tclTHEN + (tclMAP + (fun id gl -> + observe_tac + (Format.sprintf "rewrite %s in %s " (Id.to_string eq) + (Id.to_string id)) + (tclTRY + (Proofview.V82.of_tactic + (Equality.general_rewrite_in true Locus.AllOccurrences true + (* dep proofs also: *) true id (mkVar eq) false))) + gl) + eqs) + (rewrite_eqs_in_eqs eqs) let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = - fun gls -> - (tclTHENLIST - [ - backtrack_eqs_until_hrec hrec eqs; - (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) - (tclTHENS (* We must have exactly ONE subgoal !*) - (Proofview.V82.of_tactic (apply (mkVar hrec))) - [ tclTHENLIST - [ - (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); - (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); - (fun g -> - if is_mes - then - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) g - else tclIDTAC g - ); - observe_tac "rew_and_finish" - (tclTHENLIST - [tclTRY(list_rewrite false (List.map (fun v -> (mkVar v,true)) eqs)); - observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); - (observe_tac "finishing using" - ( - tclCOMPLETE( - Proofview.V82.of_tactic @@ - Eauto.eauto_with_bases - (true,5) + fun gls -> + (tclTHENLIST + [ backtrack_eqs_until_hrec hrec eqs + ; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) + tclTHENS (* We must have exactly ONE subgoal !*) + (Proofview.V82.of_tactic (apply (mkVar hrec))) + [ tclTHENLIST + [ Proofview.V82.of_tactic (keep (tcc_hyps @ eqs)) + ; Proofview.V82.of_tactic (apply (Lazy.force acc_inv)) + ; (fun g -> + if is_mes then + Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , evaluable_of_global_reference + (delayed_force ltof_ref) ) ]) + g + else tclIDTAC g) + ; observe_tac "rew_and_finish" + (tclTHENLIST + [ tclTRY + (list_rewrite false + (List.map (fun v -> (mkVar v, true)) eqs)) + ; observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs) + ; observe_tac "finishing using" + (tclCOMPLETE + ( Proofview.V82.of_tactic + @@ Eauto.eauto_with_bases (true, 5) [(fun _ sigma -> (sigma, Lazy.force refl_equal))] - [Hints.Hint_db.empty TransparentState.empty false] - ) - ) - ) - ] - ) - ] - ]) - ]) - gls - + [ Hints.Hint_db.empty TransparentState.empty + false ] )) ]) ] ] ]) + gls let is_valid_hypothesis sigma predicates_name = - let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in + let predicates_name = + List.fold_right Id.Set.add predicates_name Id.Set.empty + in let is_pte typ = - if isApp sigma typ - then - let pte,_ = destApp sigma typ in - if isVar sigma pte - then Id.Set.mem (destVar sigma pte) predicates_name + if isApp sigma typ then + let pte, _ = destApp sigma typ in + if isVar sigma pte then Id.Set.mem (destVar sigma pte) predicates_name else false else false in let rec is_valid_hypothesis typ = - is_pte typ || - match EConstr.kind sigma typ with - | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' - | _ -> false + is_pte typ + || + match EConstr.kind sigma typ with + | Prod (_, pte, typ') -> is_pte pte && is_valid_hypothesis typ' + | _ -> false in is_valid_hypothesis -let prove_principle_for_gen - (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes +let prove_principle_for_gen (f_ref, functional_ref, eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation gl = let princ_type = pf_concl gl in let princ_info = compute_elim_sig (project gl) princ_type in @@ -1452,9 +1354,9 @@ let prove_principle_for_gen let avoid = ref (pf_ids_of_hyps gl) in fun na -> let new_id = - match na with - | Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; Name new_id @@ -1462,200 +1364,182 @@ let prove_principle_for_gen let fresh_decl = map_name fresh_id in let princ_info : elim_scheme = { princ_info with - params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; - args = List.map fresh_decl princ_info.args - } + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } in let wf_tac = - if is_mes - then - (fun b -> - Proofview.V82.of_tactic @@ - Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None) + if is_mes then fun b -> + Proofview.V82.of_tactic + @@ Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None else fun _ -> prove_with_tcc tcc_lemma_ref [] in let real_rec_arg_num = rec_arg_num - princ_info.nparams in let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in -(* observe ( *) -(* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) -(* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) - -(* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) -(* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) -(* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) -(* str "npost_rec_arg := " ++ int npost_rec_arg ); *) - let (post_rec_arg,pre_rec_arg) = + (* observe ( *) + (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) + (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) + + (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) + (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) + (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) + (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) + let post_rec_arg, pre_rec_arg = Util.List.chop npost_rec_arg princ_info.args in let rec_arg_id = match List.rev post_rec_arg with - | (LocalAssum ({binder_name=Name id},_) | LocalDef ({binder_name=Name id},_,_)) :: _ -> id - | _ -> assert false + | ( LocalAssum ({binder_name = Name id}, _) + | LocalDef ({binder_name = Name id}, _, _) ) + :: _ -> + id + | _ -> assert false + in + (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) + let subst_constrs = + List.map + (get_name %> Nameops.Name.get_id %> mkVar) + (pre_rec_arg @ princ_info.params) in -(* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (get_name %> Nameops.Name.get_id %> mkVar) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in let wf_thm_id = Nameops.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) in let acc_rec_arg_id = - Nameops.Name.get_id (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) + Nameops.Name.get_id + (fresh_id (Name (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)))) in let revert l = - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l)) + tclTHEN + (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) + (Proofview.V82.of_tactic (clear l)) in let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = - ((* observe_tac "prove_rec_arg_acc" *) - (tclCOMPLETE - (tclTHEN - (Proofview.V82.of_tactic (assert_by (Name wf_thm_id) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)))) - ( - (* observe_tac *) -(* "apply wf_thm" *) - Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))) - ) - ) - ) - ) + ((* observe_tac "prove_rec_arg_acc" *) + tclCOMPLETE + (tclTHEN + (Proofview.V82.of_tactic + (assert_by (Name wf_thm_id) + (mkApp (delayed_force well_founded, [|input_type; relation|])) + (Proofview.V82.tactic (fun g -> + (* observe_tac "prove wf" *) + (tclCOMPLETE (wf_tac is_mes)) g)))) + ((* observe_tac *) + (* "apply wf_thm" *) + Proofview.V82.of_tactic + (Tactics.Simple.apply + (mkApp (mkVar wf_thm_id, [|mkVar rec_arg_id|])))))) g in let args_ids = List.map (get_name %> Nameops.Name.get_id) princ_info.args in let lemma = match !tcc_lemma_ref with - | Undefined -> user_err Pp.(str "No tcc proof !!") - | Value lemma -> EConstr.of_constr lemma - | Not_needed -> EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") + | Undefined -> user_err Pp.(str "No tcc proof !!") + | Value lemma -> EConstr.of_constr lemma + | Not_needed -> + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in -(* let rec list_diff del_list check_list = *) -(* match del_list with *) -(* [] -> *) -(* [] *) -(* | f::r -> *) -(* if List.mem f check_list then *) -(* list_diff r check_list *) -(* else *) -(* f::(list_diff r check_list) *) -(* in *) + (* let rec list_diff del_list check_list = *) + (* match del_list with *) + (* [] -> *) + (* [] *) + (* | f::r -> *) + (* if List.mem f check_list then *) + (* list_diff r check_list *) + (* else *) + (* f::(list_diff r check_list) *) + (* in *) let tcc_list = ref [] in let start_tac gls = let hyps = pf_ids_of_hyps gls in - let hid = - next_ident_away_in_goal - (Id.of_string "prov") - (Id.Set.of_list hyps) - in - tclTHENLIST - [ - Proofview.V82.of_tactic (generalize [lemma]); - Proofview.V82.of_tactic (Simple.intro hid); - Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)); - (fun g -> - let new_hyps = pf_ids_of_hyps g in - tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps)); - if List.is_empty !tcc_list - then - begin - tcc_list := [hid]; - tclIDTAC g - end - else thin [hid] g - ) - ] - gls + let hid = + next_ident_away_in_goal (Id.of_string "prov") (Id.Set.of_list hyps) + in + tclTHENLIST + [ Proofview.V82.of_tactic (generalize [lemma]) + ; Proofview.V82.of_tactic (Simple.intro hid) + ; Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)) + ; (fun g -> + let new_hyps = pf_ids_of_hyps g in + tcc_list := List.rev (List.subtract Id.equal new_hyps (hid :: hyps)); + if List.is_empty !tcc_list then begin + tcc_list := [hid]; + tclIDTAC g + end + else thin [hid] g) ] + gls in tclTHENLIST - [ - observe_tac "start_tac" start_tac; - h_intros - (List.rev_map (get_name %> Nameops.Name.get_id) - (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) - ); - Proofview.V82.of_tactic - (assert_by - (Name acc_rec_arg_id) - (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) - (Proofview.V82.tactic prove_rec_arg_acc)); - (revert (List.rev (acc_rec_arg_id::args_ids))); - (Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1))); - h_intros (List.rev (acc_rec_arg_id::args_ids)); - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); - (fun gl' -> - let body = - let _,args = destApp (project gl') (pf_concl gl') in - Array.last args - in - let body_info rec_hyps = - { - nb_rec_hyps = List.length rec_hyps; - rec_hyps = rec_hyps; - eq_hyps = []; - info = body - } - in - let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) - in - let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in - let predicates_names = - List.map (get_name %> Nameops.Name.get_id) princ_info.predicates - in - let pte_info = - { proving_tac = - (fun eqs -> -(* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) -(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) -(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) -(* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) -(* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) - - (* observe_tac "new_prove_with_tcc" *) - (new_prove_with_tcc - is_mes acc_inv fix_id - - (!tcc_list@(List.map - (get_name %> Nameops.Name.get_id) - (princ_info.args@princ_info.params) - )@ ([acc_rec_arg_id])) eqs - ) - - ); - is_valid = is_valid_hypothesis (project gl') predicates_names - } - in - let ptes_info : pte_info Id.Map.t = - List.fold_left - (fun map pte_id -> - Id.Map.add pte_id - pte_info - map - ) - Id.Map.empty - predicates_names - in - let make_proof rec_hyps = - build_proof - false - [f_ref] - ptes_info - (body_info rec_hyps) - in - (* observe_tac "instantiate_hyps_with_args" *) - (instantiate_hyps_with_args - make_proof - (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) - (List.rev args_ids) - ) - gl' - ) - - ] + [ observe_tac "start_tac" start_tac + ; h_intros + (List.rev_map + (get_name %> Nameops.Name.get_id) + ( princ_info.args @ princ_info.branches @ princ_info.predicates + @ princ_info.params )) + ; Proofview.V82.of_tactic + (assert_by (Name acc_rec_arg_id) + (mkApp + (delayed_force acc_rel, [|input_type; relation; mkVar rec_arg_id|])) + (Proofview.V82.tactic prove_rec_arg_acc)) + ; revert (List.rev (acc_rec_arg_id :: args_ids)) + ; Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1)) + ; h_intros (List.rev (acc_rec_arg_id :: args_ids)) + ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)) + ; (fun gl' -> + let body = + let _, args = destApp (project gl') (pf_concl gl') in + Array.last args + in + let body_info rec_hyps = + { nb_rec_hyps = List.length rec_hyps + ; rec_hyps + ; eq_hyps = [] + ; info = body } + in + let acc_inv = + lazy + (mkApp + ( delayed_force acc_inv_id + , [|input_type; relation; mkVar rec_arg_id|] )) + in + let acc_inv = + lazy (mkApp (Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) + in + let predicates_names = + List.map (get_name %> Nameops.Name.get_id) princ_info.predicates + in + let pte_info = + { proving_tac = + (fun eqs -> + (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) + (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) + (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) + (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) + (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) + + (* observe_tac "new_prove_with_tcc" *) + new_prove_with_tcc is_mes acc_inv fix_id + ( !tcc_list + @ List.map + (get_name %> Nameops.Name.get_id) + (princ_info.args @ princ_info.params) + @ [acc_rec_arg_id] ) + eqs) + ; is_valid = is_valid_hypothesis (project gl') predicates_names } + in + let ptes_info : pte_info Id.Map.t = + List.fold_left + (fun map pte_id -> Id.Map.add pte_id pte_info map) + Id.Map.empty predicates_names + in + let make_proof rec_hyps = + build_proof false [f_ref] ptes_info (body_info rec_hyps) + in + (* observe_tac "instantiate_hyps_with_args" *) + (instantiate_hyps_with_args make_proof + (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) + (List.rev args_ids)) + gl') ] gl diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 64fbfaeedf..52089ca7fb 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -1,19 +1,27 @@ open Names val prove_princ_for_struct : - Evd.evar_map ref -> - bool -> - int -> Constant.t array -> EConstr.constr array -> int -> Tacmach.tactic - + Evd.evar_map ref + -> bool + -> int + -> Constant.t array + -> EConstr.constr array + -> int + -> Tacmach.tactic val prove_principle_for_gen : - Constant.t * Constant.t * Constant.t -> (* name of the function, the functional and the fixpoint equation *) - Indfun_common.tcc_lemma_value ref -> (* a pointer to the obligation proofs lemma *) - bool -> (* is that function uses measure *) - int -> (* the number of recursive argument *) - EConstr.types -> (* the type of the recursive argument *) - EConstr.constr -> (* the wf relation used to prove the function *) - Tacmach.tactic - + Constant.t * Constant.t * Constant.t + -> (* name of the function, the functional and the fixpoint equation *) + Indfun_common.tcc_lemma_value ref + -> (* a pointer to the obligation proofs lemma *) + bool + -> (* is that function uses measure *) + int + -> (* the number of recursive argument *) + EConstr.types + -> (* the type of the recursive argument *) + EConstr.constr + -> (* the wf relation used to prove the function *) + Tacmach.tactic (* val is_pte : rel_declaration -> bool *) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 163645b719..1ab747ca09 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -20,16 +20,12 @@ open Pp open Tactics open Context.Rel.Declaration open Indfun_common - module RelDecl = Context.Rel.Declaration -exception Toberemoved_with_rel of int*constr +exception Toberemoved_with_rel of int * constr exception Toberemoved -let observe s = - if do_observe () - then Feedback.msg_debug s - +let observe s = if do_observe () then Feedback.msg_debug s let pop t = Vars.lift (-1) t (* @@ -42,203 +38,211 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let env = Global.env () in let env_with_params = EConstr.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:Id.t list) (predicates:EConstr.rel_context) : EConstr.rel_context = + let rec change_predicates_names (avoid : Id.t list) + (predicates : EConstr.rel_context) : EConstr.rel_context = match predicates with | [] -> [] - | decl :: predicates -> - (match Context.Rel.Declaration.get_name decl with - | Name x -> - let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in - Hashtbl.add tbl id x; - RelDecl.set_name (Name id) decl :: change_predicates_names (id::avoid) predicates - | Anonymous -> anomaly (Pp.str "Anonymous property binder.")) + | decl :: predicates -> ( + match Context.Rel.Declaration.get_name decl with + | Name x -> + let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in + Hashtbl.add tbl id x; + RelDecl.set_name (Name id) decl + :: change_predicates_names (id :: avoid) predicates + | Anonymous -> anomaly (Pp.str "Anonymous property binder.") ) in - let avoid = (Termops.ids_of_context env_with_params ) in + let avoid = Termops.ids_of_context env_with_params in let princ_type_info = { princ_type_info with - predicates = change_predicates_names avoid princ_type_info.predicates - } + predicates = change_predicates_names avoid princ_type_info.predicates } in -(* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) -(* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) + (* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) + (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i decl = let new_sort = sorts.(i) in - let args,_ = decompose_prod_assum (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) in + let args, _ = + decompose_prod_assum (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) + in let real_args = - if princ_type_info.indarg_in_concl - then List.tl args - else args + if princ_type_info.indarg_in_concl then List.tl args else args in - Context.Named.Declaration.LocalAssum (map_annot Nameops.Name.get_id (Context.Rel.Declaration.get_annot decl), - Term.it_mkProd_or_LetIn (mkSort new_sort) real_args) + Context.Named.Declaration.LocalAssum + ( map_annot Nameops.Name.get_id (Context.Rel.Declaration.get_annot decl) + , Term.it_mkProd_or_LetIn (mkSort new_sort) real_args ) in let new_predicates = - List.map_i - change_predicate_sort - 0 - princ_type_info.predicates + List.map_i change_predicate_sort 0 princ_type_info.predicates + in + let env_with_params_and_predicates = + List.fold_right Environ.push_named new_predicates env_with_params in - let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in let rel_as_kn = - fst (match princ_type_info.indref with - | Some (GlobRef.IndRef ind) -> ind - | _ -> user_err Pp.(str "Not a valid predicate") - ) + fst + ( match princ_type_info.indref with + | Some (GlobRef.IndRef ind) -> ind + | _ -> user_err Pp.(str "Not a valid predicate") ) in let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in let is_pte = let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in - fun t -> - match Constr.kind t with - | Var id -> Id.Set.mem id set - | _ -> false + fun t -> match Constr.kind t with Var id -> Id.Set.mem id set | _ -> false in let pre_princ = let open EConstr in it_mkProd_or_LetIn (it_mkProd_or_LetIn - (Option.fold_right - mkProd_or_LetIn - princ_type_info.indarg - princ_type_info.concl - ) - princ_type_info.args - ) + (Option.fold_right mkProd_or_LetIn princ_type_info.indarg + princ_type_info.concl) + princ_type_info.args) princ_type_info.branches in let pre_princ = EConstr.Unsafe.to_constr pre_princ in let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match Constr.kind c with - | Ind((u,_),_) -> MutInd.equal u rel_as_kn - | Construct(((u,_),_),_) -> MutInd.equal u rel_as_kn - | _ -> false + | Ind ((u, _), _) -> MutInd.equal u rel_as_kn + | Construct (((u, _), _), _) -> MutInd.equal u rel_as_kn + | _ -> false in let get_fun_num c = match Constr.kind c with - | Ind((_,num),_) -> num - | Construct(((_,num),_),_) -> num - | _ -> assert false + | Ind ((_, num), _) -> num + | Construct (((_, num), _), _) -> num + | _ -> assert false in let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i), Array.map pop (array_get_start args)) in - observe (str "replacing " ++ - pr_lconstr_env env Evd.empty c ++ str " by " ++ - pr_lconstr_env env Evd.empty res); + let res = mkApp (rel_to_fun.(i), Array.map pop (array_get_start args)) in + observe + ( str "replacing " + ++ pr_lconstr_env env Evd.empty c + ++ str " by " + ++ pr_lconstr_env env Evd.empty res ); res in - let rec compute_new_princ_type remove env pre_princ : types*(constr list) = - let (new_princ_type,_) as res = + let rec compute_new_princ_type remove env pre_princ : types * constr list = + let ((new_princ_type, _) as res) = match Constr.kind pre_princ with - | Rel n -> - begin - try match Environ.lookup_rel n env with - | LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved - | _ -> pre_princ,[] - with Not_found -> assert false - end - | Prod(x,t,b) -> - compute_new_princ_type_for_binder remove mkProd env x t b - | Lambda(x,t,b) -> - compute_new_princ_type_for_binder remove mkLambda env x t b - | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved - | App(f,args) when is_dom f -> - let var_to_be_removed = destRel (Array.last args) in - let num = get_fun_num f in - raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) - | App(f,args) -> - let args = - if is_pte f && remove - then array_get_start args - else args - in - let new_args,binders_to_remove = - Array.fold_right (compute_new_princ_type_with_acc remove env) - args - ([],[]) - in - let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in - applistc new_f new_args, - list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove - | LetIn(x,v,t,b) -> - compute_new_princ_type_for_letin remove env x v t b - | _ -> pre_princ,[] + | Rel n -> ( + try + match Environ.lookup_rel n env with + | (LocalAssum (_, t) | LocalDef (_, _, t)) when is_dom t -> + raise Toberemoved + | _ -> (pre_princ, []) + with Not_found -> assert false ) + | Prod (x, t, b) -> + compute_new_princ_type_for_binder remove mkProd env x t b + | Lambda (x, t, b) -> + compute_new_princ_type_for_binder remove mkLambda env x t b + | (Ind _ | Construct _) when is_dom pre_princ -> raise Toberemoved + | App (f, args) when is_dom f -> + let var_to_be_removed = destRel (Array.last args) in + let num = get_fun_num f in + raise + (Toberemoved_with_rel + (var_to_be_removed, mk_replacement pre_princ num args)) + | App (f, args) -> + let args = if is_pte f && remove then array_get_start args else args in + let new_args, binders_to_remove = + Array.fold_right + (compute_new_princ_type_with_acc remove env) + args ([], []) + in + let new_f, binders_to_remove_from_f = + compute_new_princ_type remove env f + in + ( applistc new_f new_args + , list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove + ) + | LetIn (x, v, t, b) -> + compute_new_princ_type_for_letin remove env x v t b + | _ -> (pre_princ, []) in -(* let _ = match Constr.kind pre_princ with *) -(* | Prod _ -> *) -(* observe(str "compute_new_princ_type for "++ *) -(* pr_lconstr_env env pre_princ ++ *) -(* str" is "++ *) -(* pr_lconstr_env env new_princ_type ++ fnl ()) *) -(* | _ -> () in *) + (* let _ = match Constr.kind pre_princ with *) + (* | Prod _ -> *) + (* observe(str "compute_new_princ_type for "++ *) + (* pr_lconstr_env env pre_princ ++ *) + (* str" is "++ *) + (* pr_lconstr_env env new_princ_type ++ fnl ()) *) + (* | _ -> () in *) res - and compute_new_princ_type_for_binder remove bind_fun env x t b = - begin - try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_x = map_annot (get_name (Termops.ids_of_context env)) x in - let new_env = Environ.push_rel (LocalAssum (x,t)) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b - then (pop new_b), filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b - else - ( - bind_fun(new_x,new_t,new_b), - list_union_eq - Constr.equal - binders_to_remove_from_t - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) - end + try + let new_t, binders_to_remove_from_t = + compute_new_princ_type remove env t + in + let new_x = map_annot (get_name (Termops.ids_of_context env)) x in + let new_env = Environ.push_rel (LocalAssum (x, t)) env in + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove new_env b + in + if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b then + ( pop new_b + , filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b ) + else + ( bind_fun (new_x, new_t, new_b) + , list_union_eq Constr.equal binders_to_remove_from_t + (List.map pop binders_to_remove_from_b) ) + with + | Toberemoved -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [dummy_var] 1 b) + in + (new_b, List.map pop binders_to_remove_from_b) + | Toberemoved_with_rel (n, c) -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [c] n b) + in + ( new_b + , list_add_set_eq Constr.equal (mkRel n) + (List.map pop binders_to_remove_from_b) ) and compute_new_princ_type_for_letin remove env x v t b = - begin - try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in - let new_x = map_annot (get_name (Termops.ids_of_context env)) x in - let new_env = Environ.push_rel (LocalDef (x,v,t)) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b - then (pop new_b),filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b - else - ( - mkLetIn(new_x,new_v,new_t,new_b), - list_union_eq - Constr.equal - (list_union_eq Constr.equal binders_to_remove_from_t binders_to_remove_from_v) - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) - end - and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = - let new_e,to_remove_from_e = compute_new_princ_type remove env e - in - new_e::c_acc,list_union_eq Constr.equal to_remove_from_e to_remove_acc + try + let new_t, binders_to_remove_from_t = + compute_new_princ_type remove env t + in + let new_v, binders_to_remove_from_v = + compute_new_princ_type remove env v + in + let new_x = map_annot (get_name (Termops.ids_of_context env)) x in + let new_env = Environ.push_rel (LocalDef (x, v, t)) env in + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove new_env b + in + if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b then + ( pop new_b + , filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b ) + else + ( mkLetIn (new_x, new_v, new_t, new_b) + , list_union_eq Constr.equal + (list_union_eq Constr.equal binders_to_remove_from_t + binders_to_remove_from_v) + (List.map pop binders_to_remove_from_b) ) + with + | Toberemoved -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [dummy_var] 1 b) + in + (new_b, List.map pop binders_to_remove_from_b) + | Toberemoved_with_rel (n, c) -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [c] n b) + in + ( new_b + , list_add_set_eq Constr.equal (mkRel n) + (List.map pop binders_to_remove_from_b) ) + and compute_new_princ_type_with_acc remove env e (c_acc, to_remove_acc) = + let new_e, to_remove_from_e = compute_new_princ_type remove env e in + (new_e :: c_acc, list_union_eq Constr.equal to_remove_from_e to_remove_acc) in -(* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) - let pre_res,_ = - compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ + (* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) + let pre_res, _ = + compute_new_princ_type princ_type_info.indarg_in_concl + env_with_params_and_predicates pre_princ in let pre_res = replace_vars @@ -246,12 +250,18 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (lift (List.length ptes_vars) pre_res) in it_mkProd_or_LetIn - (it_mkProd_or_LetIn - pre_res (List.map (function - | Context.Named.Declaration.LocalAssum (id,b) -> - LocalAssum (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, b) - | Context.Named.Declaration.LocalDef (id,t,b) -> - LocalDef (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, t, b)) - new_predicates) - ) - (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_type_info.params) + (it_mkProd_or_LetIn pre_res + (List.map + (function + | Context.Named.Declaration.LocalAssum (id, b) -> + LocalAssum + (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, b) + | Context.Named.Declaration.LocalDef (id, t, b) -> + LocalDef + ( map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id + , t + , b )) + new_predicates)) + (List.map + (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) + princ_type_info.params) diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index c870603a43..4bbb7180f0 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -8,8 +8,5 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val compute_new_princ_type_from_rel - : Constr.constr array - -> Sorts.t array - -> Constr.t - -> Constr.types +val compute_new_princ_type_from_rel : + Constr.constr array -> Sorts.t array -> Constr.t -> Constr.types diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index d38c3c869b..55e659d487 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -10,9 +10,7 @@ open Util open Names - open Indfun_common - module RelDecl = Context.Rel.Declaration let observe_tac s = observe_tac (fun _ _ -> Pp.str s) @@ -23,73 +21,92 @@ let observe_tac s = observe_tac (fun _ _ -> Pp.str s) *) let rec abstract_glob_constr c = function | [] -> c - | Constrexpr.CLocalDef (x,b,t)::bl -> Constrexpr_ops.mkLetInC(x,b,t,abstract_glob_constr c bl) - | Constrexpr.CLocalAssum (idl,k,t)::bl -> - List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl + | Constrexpr.CLocalDef (x, b, t) :: bl -> + Constrexpr_ops.mkLetInC (x, b, t, abstract_glob_constr c bl) + | Constrexpr.CLocalAssum (idl, k, t) :: bl -> + List.fold_right + (fun x b -> Constrexpr_ops.mkLambdaC ([x], k, t, b)) + idl (abstract_glob_constr c bl) - | Constrexpr.CLocalPattern _::bl -> assert false + | Constrexpr.CLocalPattern _ :: bl -> assert false -let interp_casted_constr_with_implicits env sigma impls c = +let interp_casted_constr_with_implicits env sigma impls c = Constrintern.intern_gen Pretyping.WithoutTypeConstraint env sigma ~impls c let build_newrecursive lnameargsardef = - let env0 = Global.env() in + let env0 = Global.env () in let sigma = Evd.from_env env0 in - let (rec_sign,rec_impls) = + let rec_sign, rec_impls = List.fold_left - (fun (env,impls) { Vernacexpr.fname={CAst.v=recname}; binders; rtype } -> - let arityc = Constrexpr_ops.mkCProdN binders rtype in - let arity,_ctx = Constrintern.interp_type env0 sigma arityc in - let evd = Evd.from_env env0 in - let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd binders in - let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in - let open Context.Named.Declaration in - let r = Sorts.Relevant in (* TODO relevance *) - (EConstr.push_named (LocalAssum (Context.make_annot recname r,arity)) env, Id.Map.add recname impl impls)) - (env0,Constrintern.empty_internalization_env) lnameargsardef in + (fun (env, impls) {Vernacexpr.fname = {CAst.v = recname}; binders; rtype} -> + let arityc = Constrexpr_ops.mkCProdN binders rtype in + let arity, _ctx = Constrintern.interp_type env0 sigma arityc in + let evd = Evd.from_env env0 in + let evd, (_, (_, impls')) = + Constrintern.interp_context_evars ~program_mode:false env evd binders + in + let impl = + Constrintern.compute_internalization_data env0 evd recname + Constrintern.Recursive arity impls' + in + let open Context.Named.Declaration in + let r = Sorts.Relevant in + (* TODO relevance *) + ( EConstr.push_named + (LocalAssum (Context.make_annot recname r, arity)) + env + , Id.Map.add recname impl impls )) + (env0, Constrintern.empty_internalization_env) + lnameargsardef + in let recdef = (* Declare local notations *) - let f { Vernacexpr.binders; body_def } = + let f {Vernacexpr.binders; body_def} = match body_def with | Some body_def -> let def = abstract_glob_constr body_def binders in - interp_casted_constr_with_implicits - rec_sign sigma rec_impls def - | None -> CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") + interp_casted_constr_with_implicits rec_sign sigma rec_impls def + | None -> + CErrors.user_err ~hdr:"Function" + (Pp.str "Body of Function must be given") in States.with_state_protection (List.map f) lnameargsardef in - recdef,rec_impls + (recdef, rec_impls) (* Checks whether or not the mutual bloc is recursive *) let is_rec names = let open Glob_term in let names = List.fold_right Id.Set.add names Id.Set.empty in - let check_id id names = Id.Set.mem id names in - let rec lookup names gt = match DAst.get gt with - | GVar(id) -> check_id id names - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> false - | GCast(b,_) -> lookup names b + let check_id id names = Id.Set.mem id names in + let rec lookup names gt = + match DAst.get gt with + | GVar id -> check_id id names + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> + false + | GCast (b, _) -> lookup names b | GRec _ -> CErrors.user_err (Pp.str "GRec not handled") - | GIf(b,_,lhs,rhs) -> - (lookup names b) || (lookup names lhs) || (lookup names rhs) - | GProd(na,_,t,b) | GLambda(na,_,t,b) -> - lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b - | GLetIn(na,b,t,c) -> - lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c - | GLetTuple(nal,_,t,b) -> lookup names t || - lookup - (List.fold_left - (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) - names - nal - ) - b - | GApp(f,args) -> List.exists (lookup names) (f::args) - | GCases(_,_,el,brl) -> - List.exists (fun (e,_) -> lookup names e) el || - List.exists (lookup_br names) brl - and lookup_br names {CAst.v=(idl,_,rt)} = + | GIf (b, _, lhs, rhs) -> + lookup names b || lookup names lhs || lookup names rhs + | GProd (na, _, t, b) | GLambda (na, _, t, b) -> + lookup names t + || lookup (Nameops.Name.fold_right Id.Set.remove na names) b + | GLetIn (na, b, t, c) -> + lookup names b + || Option.cata (lookup names) true t + || lookup (Nameops.Name.fold_right Id.Set.remove na names) c + | GLetTuple (nal, _, t, b) -> + lookup names t + || lookup + (List.fold_left + (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) + names nal) + b + | GApp (f, args) -> List.exists (lookup names) (f :: args) + | GCases (_, _, el, brl) -> + List.exists (fun (e, _) -> lookup names e) el + || List.exists (lookup_br names) brl + and lookup_br names {CAst.v = idl, _, rt} = let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt in @@ -97,114 +114,138 @@ let is_rec names = let rec rebuild_bl aux bl typ = let open Constrexpr in - match bl,typ with - | [], _ -> List.rev aux,typ - | (CLocalAssum(nal,bk,_))::bl',typ -> - rebuild_nal aux bk bl' nal typ - | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } -> - rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux) - bl' typ' + match (bl, typ) with + | [], _ -> (List.rev aux, typ) + | CLocalAssum (nal, bk, _) :: bl', typ -> rebuild_nal aux bk bl' nal typ + | CLocalDef (na, _, _) :: bl', {CAst.v = CLetIn (_, nat, ty, typ')} -> + rebuild_bl (Constrexpr.CLocalDef (na, nat, ty) :: aux) bl' typ' | _ -> assert false + and rebuild_nal aux bk bl' nal typ = let open Constrexpr in - match nal,typ with - | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ + match (nal, typ) with + | _, {CAst.v = CProdN ([], typ)} -> rebuild_nal aux bk bl' nal typ | [], _ -> rebuild_bl aux bl' typ - | na::nal,{ CAst.v = CProdN(CLocalAssum(na'::nal',bk',nal't)::rest,typ') } -> - if Name.equal (na.CAst.v) (na'.CAst.v) || Name.is_anonymous (na'.CAst.v) - then - let assum = CLocalAssum([na],bk,nal't) in - let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - nal - (CAst.make @@ CProdN(new_rest,typ')) + | ( na :: nal + , {CAst.v = CProdN (CLocalAssum (na' :: nal', bk', nal't) :: rest, typ')} ) + -> + if Name.equal na.CAst.v na'.CAst.v || Name.is_anonymous na'.CAst.v then + let assum = CLocalAssum ([na], bk, nal't) in + let new_rest = + if nal' = [] then rest else CLocalAssum (nal', bk', nal't) :: rest + in + rebuild_nal (assum :: aux) bk bl' nal + (CAst.make @@ CProdN (new_rest, typ')) else - let assum = CLocalAssum([na'],bk,nal't) in - let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - (na::nal) - (CAst.make @@ CProdN(new_rest,typ')) - | _ -> - assert false + let assum = CLocalAssum ([na'], bk, nal't) in + let new_rest = + if nal' = [] then rest else CLocalAssum (nal', bk', nal't) :: rest + in + rebuild_nal (assum :: aux) bk bl' (na :: nal) + (CAst.make @@ CProdN (new_rest, typ')) + | _ -> assert false let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list fixpoint_exprl = let fixl = - List.map (fun fix -> Vernacexpr.{ - fix - with rec_order = ComFixpoint.adjust_rec_order ~structonly:false fix.binders fix.rec_order }) fixpoint_exprl in - let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl in + List.map + (fun fix -> + Vernacexpr. + { fix with + rec_order = + ComFixpoint.adjust_rec_order ~structonly:false fix.binders + fix.rec_order }) + fixpoint_exprl + in + let (_, _, _, typel), _, ctx, _ = + ComFixpoint.interp_fixpoint ~cofix:false fixl + in let constr_expr_typel = - with_full_print (List.map (fun c -> Constrextern.extern_constr (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in + with_full_print + (List.map (fun c -> + Constrextern.extern_constr (Global.env ()) (Evd.from_ctx ctx) + (EConstr.of_constr c))) + typel + in let fixpoint_exprl_with_new_bl = - List.map2 (fun ({ Vernacexpr.binders } as fp) fix_typ -> + List.map2 + (fun ({Vernacexpr.binders} as fp) fix_typ -> let binders, rtype = rebuild_bl [] binders fix_typ in - { fp with Vernacexpr.binders; rtype } - ) fixpoint_exprl constr_expr_typel + {fp with Vernacexpr.binders; rtype}) + fixpoint_exprl constr_expr_typel in fixpoint_exprl_with_new_bl let rec local_binders_length = function (* Assume that no `{ ... } contexts occur *) | [] -> 0 - | Constrexpr.CLocalDef _::bl -> 1 + local_binders_length bl - | Constrexpr.CLocalAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl - | Constrexpr.CLocalPattern _::bl -> assert false + | Constrexpr.CLocalDef _ :: bl -> 1 + local_binders_length bl + | Constrexpr.CLocalAssum (idl, _, _) :: bl -> + List.length idl + local_binders_length bl + | Constrexpr.CLocalPattern _ :: bl -> assert false -let prepare_body { Vernacexpr.binders } rt = +let prepare_body {Vernacexpr.binders} rt = let n = local_binders_length binders in (* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *) - let fun_args,rt' = chop_rlambda_n n rt in - (fun_args,rt') + let fun_args, rt' = chop_rlambda_n n rt in + (fun_args, rt') -let build_functional_principle ?(opaque=Proof_global.Transparent) (evd:Evd.evar_map ref) old_princ_type sorts funs _i proof_tac hook = +let build_functional_principle ?(opaque = Declare.Transparent) + (evd : Evd.evar_map ref) old_princ_type sorts funs _i proof_tac hook = (* First we get the type of the old graph principle *) - let mutr_nparams = (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)).Tactics.nparams in + let mutr_nparams = + (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)) + .Tactics.nparams + in (* let time1 = System.get_time () in *) let new_principle_type = Functional_principles_types.compute_new_princ_type_from_rel (Array.map Constr.mkConstU funs) - sorts - old_princ_type + sorts old_princ_type in (* let time2 = System.get_time () in *) (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) let new_princ_name = - Namegen.next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty + Namegen.next_ident_away_in_goal + (Id.of_string "___________princ_________") + Id.Set.empty + in + let sigma, _ = + Typing.type_of ~refresh:true (Global.env ()) !evd + (EConstr.of_constr new_principle_type) in - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in evd := sigma; let hook = DeclareDef.Hook.make (hook new_principle_type) in let lemma = - Lemmas.start_lemma - ~name:new_princ_name - ~poly:false - !evd + Lemmas.start_lemma ~name:new_princ_name ~poly:false !evd (EConstr.of_constr new_principle_type) in (* let _tim1 = System.get_time () in *) let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - let lemma,_ = Lemmas.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) lemma in + let lemma, _ = + Lemmas.by + (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) + lemma + in (* let _tim2 = System.get_time () in *) (* begin *) (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) - - let open Proof_global in - let { entries } = Lemmas.pf_fold (close_proof ~opaque ~keep_body_ucst_separate:false) lemma in + let {Declare.entries} = + Lemmas.pf_fold + (Declare.close_proof ~opaque ~keep_body_ucst_separate:false) + lemma + in match entries with - | [entry] -> - entry, hook + | [entry] -> (entry, hook) | _ -> - CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") + CErrors.anomaly + Pp.( + str + "[build_functional_principle] close_proof returned more than one \ + proof term") let change_property_sort evd toSort princ princName = let open Context.Rel.Declaration in @@ -212,207 +253,221 @@ let change_property_sort evd toSort princ princName = let princ_info = Tactics.compute_elim_sig evd princ in let change_sort_in_predicate decl = LocalAssum - (get_annot decl, - let args,ty = Term.decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in - let s = Constr.destSort ty in - Global.add_constraints (Univ.enforce_leq (Sorts.univ_of_sort toSort) (Sorts.univ_of_sort s) Univ.Constraint.empty); - Term.compose_prod args (Constr.mkSort toSort) - ) + ( get_annot decl + , let args, ty = + Term.decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) + in + let s = Constr.destSort ty in + Global.add_constraints + (Univ.enforce_leq + (Sorts.univ_of_sort toSort) + (Sorts.univ_of_sort s) Univ.Constraint.empty); + Term.compose_prod args (Constr.mkSort toSort) ) + in + let evd, princName_as_constr = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in - let evd,princName_as_constr = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in let init = - let nargs = (princ_info.Tactics.nparams + (List.length princ_info.Tactics.predicates)) in - Constr.mkApp(EConstr.Unsafe.to_constr princName_as_constr, - Array.init nargs - (fun i -> Constr.mkRel (nargs - i ))) + let nargs = + princ_info.Tactics.nparams + List.length princ_info.Tactics.predicates + in + Constr.mkApp + ( EConstr.Unsafe.to_constr princName_as_constr + , Array.init nargs (fun i -> Constr.mkRel (nargs - i)) ) in - evd, Term.it_mkLambda_or_LetIn - (Term.it_mkLambda_or_LetIn init - (List.map change_sort_in_predicate princ_info.Tactics.predicates) - ) - (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.Tactics.params) - -let generate_functional_principle (evd: Evd.evar_map ref) - old_princ_type sorts new_princ_name funs i proof_tac - = + ( evd + , Term.it_mkLambda_or_LetIn + (Term.it_mkLambda_or_LetIn init + (List.map change_sort_in_predicate princ_info.Tactics.predicates)) + (List.map + (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) + princ_info.Tactics.params) ) + +let generate_functional_principle (evd : Evd.evar_map ref) old_princ_type sorts + new_princ_name funs i proof_tac = try - - let f = funs.(i) in - let sigma, type_sort = Evd.fresh_sort_in_family !evd Sorts.InType in - evd := sigma; - let new_sorts = - match sorts with - | None -> Array.make (Array.length funs) (type_sort) + let f = funs.(i) in + let sigma, type_sort = Evd.fresh_sort_in_family !evd Sorts.InType in + evd := sigma; + let new_sorts = + match sorts with + | None -> Array.make (Array.length funs) type_sort | Some a -> a - in - let base_new_princ_name,new_princ_name = - match new_princ_name with - | Some (id) -> id,id + in + let base_new_princ_name, new_princ_name = + match new_princ_name with + | Some id -> (id, id) | None -> - let id_of_f = Label.to_id (Constant.label (fst f)) in - id_of_f,Indrec.make_elimination_ident id_of_f (Sorts.family type_sort) - in - let names = ref [new_princ_name] in - let hook = - fun new_principle_type _ -> - if Option.is_empty sorts - then - (* let id_of_f = Label.to_id (con_label f) in *) - let register_with_sort fam_sort = - let evd' = Evd.from_env (Global.env ()) in - let evd',s = Evd.fresh_sort_in_family evd' fam_sort in - let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let evd',value = change_property_sort evd' s new_principle_type new_princ_name in - let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in - (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let univs = Evd.univ_entry ~poly:false evd' in - let ce = Declare.definition_entry ~univs value in - ignore( - Declare.declare_constant - ~name - ~kind:Decls.(IsDefinition Scheme) - (Declare.DefinitionEntry ce) - ); - Declare.definition_message name; - names := name :: !names - in - register_with_sort Sorts.InProp; - register_with_sort Sorts.InSet - in - let entry, hook = - build_functional_principle evd old_princ_type new_sorts funs i - proof_tac hook + let id_of_f = Label.to_id (Constant.label (fst f)) in + (id_of_f, Indrec.make_elimination_ident id_of_f (Sorts.family type_sort)) + in + let names = ref [new_princ_name] in + let hook new_principle_type _ = + if Option.is_empty sorts then ( + (* let id_of_f = Label.to_id (con_label f) in *) + let register_with_sort fam_sort = + let evd' = Evd.from_env (Global.env ()) in + let evd', s = Evd.fresh_sort_in_family evd' fam_sort in + let name = + Indrec.make_elimination_ident base_new_princ_name fam_sort + in + let evd', value = + change_property_sort evd' s new_principle_type new_princ_name + in + let evd' = + fst + (Typing.type_of ~refresh:true (Global.env ()) evd' + (EConstr.of_constr value)) + in + (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let univs = Evd.univ_entry ~poly:false evd' in + let ce = Declare.definition_entry ~univs value in + ignore + (Declare.declare_constant ~name + ~kind:Decls.(IsDefinition Scheme) + (Declare.DefinitionEntry ce)); + Declare.definition_message name; + names := name :: !names + in + register_with_sort Sorts.InProp; + register_with_sort Sorts.InSet ) + in + let entry, hook = + build_functional_principle evd old_princ_type new_sorts funs i proof_tac + hook + in + (* Pr 1278 : + Don't forget to close the goal if an error is raised !!!! + *) + let uctx = Evd.evar_universe_context sigma in + let (_ : Names.GlobRef.t) = + DeclareDef.declare_entry ~name:new_princ_name ~hook + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~kind:Decls.(IsProof Theorem) + ~impargs:[] ~uctx entry + in + () + with e when CErrors.noncritical e -> raise (Defining_principle e) + +let generate_principle (evd : Evd.evar_map ref) pconstants on_error is_general + do_built fix_rec_l recdefs + (continue_proof : + int + -> Names.Constant.t array + -> EConstr.constr array + -> int + -> Tacmach.tactic) : unit = + let names = + List.map (function {Vernacexpr.fname = {CAst.v = name}} -> name) fix_rec_l in - (* Pr 1278 : - Don't forget to close the goal if an error is raised !!!! - *) - let uctx = Evd.evar_universe_context sigma in - let _ : Names.GlobRef.t = DeclareDef.declare_entry - ~name:new_princ_name ~hook - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.(IsProof Theorem) - ~impargs:[] - ~uctx entry in - () - with e when CErrors.noncritical e -> - raise (Defining_principle e) - -let generate_principle (evd:Evd.evar_map ref) pconstants on_error - is_general do_built fix_rec_l recdefs - (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int -> - Tacmach.tactic) : unit = - let names = List.map (function { Vernacexpr.fname = {CAst.v=name} } -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in - let funs_types = List.map (function { Vernacexpr.rtype } -> rtype) fix_rec_l in + let funs_types = + List.map (function {Vernacexpr.rtype} -> rtype) fix_rec_l + in try (* We then register the Inductive graphs of the functions *) - Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types recdefs; - if do_built - then - begin - (*i The next call to mk_rel_id is valid since we have just construct the graph - Ensures by : do_built - i*) - let f_R_mut = Libnames.qualid_of_ident @@ mk_rel_id (List.nth names 0) in - let ind_kn = - fst (locate_with_msg - Pp.(Libnames.pr_qualid f_R_mut ++ str ": Not an inductive type!") - locate_ind - f_R_mut) - in - let fname_kn { Vernacexpr.fname } = - let f_ref = Libnames.qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in - locate_with_msg - Pp.(Libnames.pr_qualid f_ref++str ": Not an inductive type!") - locate_constant - f_ref - in - let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in - let _ = - List.map_i - (fun i _x -> - let env = Global.env () in - let princ = Indrec.lookup_eliminator env (ind_kn,i) (Sorts.InProp) in - let evd = ref (Evd.from_env env) in - let evd',uprinc = Evd.fresh_global env !evd princ in - let _ = evd := evd' in - let sigma, princ_type = Typing.type_of ~refresh:true env !evd uprinc in - evd := sigma; - let princ_type = EConstr.Unsafe.to_constr princ_type in - generate_functional_principle - evd - princ_type - None - None - (Array.of_list pconstants) - (* funs_kn *) - i - (continue_proof 0 [|funs_kn.(i)|]) - ) - 0 - fix_rec_l - in - Array.iter (add_Function is_general) funs_kn; - () - end - with e when CErrors.noncritical e -> - on_error names e + Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types + recdefs; + if do_built then begin + (*i The next call to mk_rel_id is valid since we have just construct the graph + Ensures by : do_built + i*) + let f_R_mut = Libnames.qualid_of_ident @@ mk_rel_id (List.nth names 0) in + let ind_kn = + fst + (locate_with_msg + Pp.(Libnames.pr_qualid f_R_mut ++ str ": Not an inductive type!") + locate_ind f_R_mut) + in + let fname_kn {Vernacexpr.fname} = + let f_ref = Libnames.qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in + locate_with_msg + Pp.(Libnames.pr_qualid f_ref ++ str ": Not an inductive type!") + locate_constant f_ref + in + let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in + let _ = + List.map_i + (fun i _x -> + let env = Global.env () in + let princ = Indrec.lookup_eliminator env (ind_kn, i) Sorts.InProp in + let evd = ref (Evd.from_env env) in + let evd', uprinc = Evd.fresh_global env !evd princ in + let _ = evd := evd' in + let sigma, princ_type = + Typing.type_of ~refresh:true env !evd uprinc + in + evd := sigma; + let princ_type = EConstr.Unsafe.to_constr princ_type in + generate_functional_principle evd princ_type None None + (Array.of_list pconstants) (* funs_kn *) + i + (continue_proof 0 [|funs_kn.(i)|])) + 0 fix_rec_l + in + Array.iter (add_Function is_general) funs_kn; + () + end + with e when CErrors.noncritical e -> on_error names e let register_struct is_rec fixpoint_exprl = let open EConstr in match fixpoint_exprl with - | [{ Vernacexpr.fname; univs; binders; rtype; body_def }] when not is_rec -> + | [{Vernacexpr.fname; univs; binders; rtype; body_def}] when not is_rec -> let body = match body_def with | Some body -> body | None -> - CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in - ComDefinition.do_definition - ~name:fname.CAst.v - ~poly:false + CErrors.user_err ~hdr:"Function" + Pp.(str "Body of Function must be given") + in + ComDefinition.do_definition ~name:fname.CAst.v ~poly:false ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.Definition univs - binders None body (Some rtype); - let evd,rev_pconstants = + ~kind:Decls.Definition univs binders None body (Some rtype); + let evd, rev_pconstants = List.fold_left - (fun (evd,l) { Vernacexpr.fname } -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in - let (cst, u) = destConst evd c in - let u = EInstance.kind evd u in - evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) + (fun (evd, l) {Vernacexpr.fname} -> + let evd, c = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference + (Libnames.qualid_of_ident fname.CAst.v)) + in + let cst, u = destConst evd c in + let u = EInstance.kind evd u in + (evd, (cst, u) :: l)) + (Evd.from_env (Global.env ()), []) fixpoint_exprl in - None, evd,List.rev rev_pconstants + (None, evd, List.rev rev_pconstants) | _ -> - ComFixpoint.do_fixpoint ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false fixpoint_exprl; - let evd,rev_pconstants = + ComFixpoint.do_fixpoint + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false + fixpoint_exprl; + let evd, rev_pconstants = List.fold_left - (fun (evd,l) { Vernacexpr.fname } -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in - let (cst, u) = destConst evd c in - let u = EInstance.kind evd u in - evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) + (fun (evd, l) {Vernacexpr.fname} -> + let evd, c = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference + (Libnames.qualid_of_ident fname.CAst.v)) + in + let cst, u = destConst evd c in + let u = EInstance.kind evd u in + (evd, (cst, u) :: l)) + (Evd.from_env (Global.env ()), []) fixpoint_exprl in - None,evd,List.rev rev_pconstants + (None, evd, List.rev rev_pconstants) -let generate_correction_proof_wf f_ref tcc_lemma_ref - is_mes functional_ref eq_ref rec_arg_num rec_arg_type relation - (_: int) (_:Names.Constant.t array) (_:EConstr.constr array) (_:int) : Tacmach.tactic = +let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref + eq_ref rec_arg_num rec_arg_type relation (_ : int) + (_ : Names.Constant.t array) (_ : EConstr.constr array) (_ : int) : + Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen - (f_ref,functional_ref,eq_ref) - tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation + (f_ref, functional_ref, eq_ref) + tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. @@ -431,34 +486,38 @@ let generate_type evd g_to_f f graph = let open EConstr in let open EConstr.Vars in (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let evd',graph = - Evd.fresh_global (Global.env ()) !evd (GlobRef.IndRef (fst (destInd !evd graph))) + let evd', graph = + Evd.fresh_global (Global.env ()) !evd + (GlobRef.IndRef (fst (destInd !evd graph))) in - evd:=evd'; + evd := evd'; let sigma, graph_arity = Typing.type_of (Global.env ()) !evd graph in evd := sigma; - let ctxt,_ = decompose_prod_assum !evd graph_arity in - let fun_ctxt,res_type = + let ctxt, _ = decompose_prod_assum !evd graph_arity in + let fun_ctxt, res_type = match ctxt with | [] | [_] -> CErrors.anomaly (Pp.str "Not a valid context.") - | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl + | decl :: fun_ctxt -> (fun_ctxt, RelDecl.get_type decl) in let rec args_from_decl i accu = function | [] -> accu - | LocalDef _ :: l -> - args_from_decl (succ i) accu l + | LocalDef _ :: l -> args_from_decl (succ i) accu l | _ :: l -> let t = mkRel i in args_from_decl (succ i) (t :: accu) l in (*i We need to name the vars [res] and [fv] i*) - let filter = fun decl -> match RelDecl.get_name decl with - | Name id -> Some id - | Anonymous -> None + let filter decl = + match RelDecl.get_name decl with Name id -> Some id | Anonymous -> None in let named_ctxt = Id.Set.of_list (List.map_filter filter fun_ctxt) in - let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in - let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (Id.Set.add res_id named_ctxt) in + let res_id = + Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt + in + let fv_id = + Namegen.next_ident_away_in_goal (Id.of_string "fv") + (Id.Set.add res_id named_ctxt) + in (*i we can then type the argument to be applied to the function [f] i*) let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in (*i @@ -467,7 +526,7 @@ let generate_type evd g_to_f f graph = i*) let make_eq = make_eq () in let res_eq_f_of_args = - mkApp(make_eq ,[|lift 2 res_type;mkRel 1;mkRel 2|]) + mkApp (make_eq, [|lift 2 res_type; mkRel 1; mkRel 2|]) in (*i The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed @@ -475,18 +534,29 @@ let generate_type evd g_to_f f graph = i*) let args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in - let graph_applied = mkApp(graph, args_and_res_as_rels) in + let graph_applied = mkApp (graph, args_and_res_as_rels) in (*i The [pre_context] is the defined to be the context corresponding to \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) let pre_ctxt = - LocalAssum (Context.make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) :: - LocalDef (Context.make_annot (Name fv_id) Sorts.Relevant, mkApp (f,args_as_rels), res_type) :: fun_ctxt + LocalAssum (Context.make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) + :: LocalDef + ( Context.make_annot (Name fv_id) Sorts.Relevant + , mkApp (f, args_as_rels) + , res_type ) + :: fun_ctxt in (*i and we can return the solution depending on which lemma type we are defining i*) - if g_to_f - then LocalAssum (Context.make_annot Anonymous Sorts.Relevant,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph - else LocalAssum (Context.make_annot Anonymous Sorts.Relevant,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph + if g_to_f then + ( LocalAssum (Context.make_annot Anonymous Sorts.Relevant, graph_applied) + :: pre_ctxt + , lift 1 res_eq_f_of_args + , graph ) + else + ( LocalAssum (Context.make_annot Anonymous Sorts.Relevant, res_eq_f_of_args) + :: pre_ctxt + , lift 1 graph_applied + , graph ) (** [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] @@ -494,21 +564,25 @@ let generate_type evd g_to_f f graph = WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle evd f = - let f_as_constant, _u = match EConstr.kind !evd f with + let f_as_constant, _u = + match EConstr.kind !evd f with | Constr.Const c' -> c' | _ -> CErrors.user_err Pp.(str "Must be used with a function") in match find_Function_infos f_as_constant with - | None -> - raise Not_found - | Some infos -> + | None -> raise Not_found + | Some infos -> ( match infos.rect_lemma with | None -> raise Not_found | Some rect_lemma -> - let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) in - let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in - evd:=evd'; - rect_lemma,typ + let evd', rect_lemma = + Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) + in + let evd', typ = + Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma + in + evd := evd'; + (rect_lemma, typ) ) (* [prove_fun_correct funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. @@ -535,13 +609,13 @@ let find_induction_principle evd f = *) let rec generate_fresh_id x avoid i = - if i == 0 - then [] + if i == 0 then [] else let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in - id::(generate_fresh_id x (id::avoid) (pred i)) + id :: generate_fresh_id x (id :: avoid) (pred i) -let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = +let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : + Tacmach.tactic = let open Constr in let open EConstr in let open Context.Rel.Declaration in @@ -554,22 +628,25 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.t \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] *) (* we the get the definition of the graphs block *) - let graph_ind,u = destInd evd graphs_constr.(i) in + let graph_ind, u = destInd evd graphs_constr.(i) in let kn = fst graph_ind in - let mib,_ = Global.lookup_inductive graph_ind in + let mib, _ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) - let f_principle,princ_type = schemes.(i) in + let f_principle, princ_type = schemes.(i) in let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in let princ_infos = Tactics.compute_elim_sig evd princ_type in (* The number of args of the function is then easily computable *) let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in + let ids = args_names @ pf_ids_of_hyps g in (* Since we cannot ensure that the functional principle is defined in the environment and due to the bug #1174, we will need to pose the principle using a name *) - let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") (Id.Set.of_list ids) in + let principle_id = + Namegen.next_ident_away_in_goal (Id.of_string "princ") + (Id.Set.of_list ids) + in let ids = principle_id :: ids in (* We get the branches of the principle *) let branches = List.rev princ_infos.Tactics.branches in @@ -577,28 +654,28 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.t let intro_pats = List.map (fun decl -> - List.map - (fun id -> CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) - ) + List.map + (fun id -> + CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) + (generate_fresh_id (Id.of_string "y") ids + (List.length + (fst (decompose_prod_assum evd (RelDecl.get_type decl)))))) branches in (* before building the full intro pattern for the principle *) let eq_ind = make_eq () in let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) - let ind_number = ref 0 - and min_constr_number = ref 0 in + let ind_number = ref 0 and min_constr_number = ref 0 in (* The tactic to prove the ith branch of the principle *) let prove_branche i g = (* We get the identifiers of this branch *) let pre_args = List.fold_right - (fun {CAst.v=pat} acc -> - match pat with - | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id::acc - | _ -> CErrors.anomaly (Pp.str "Not an identifier.") - ) + (fun {CAst.v = pat} acc -> + match pat with + | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id :: acc + | _ -> CErrors.anomaly (Pp.str "Not an identifier.")) (List.nth intro_pats (pred i)) [] in @@ -613,32 +690,35 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.t let constructor_args g = List.fold_right (fun hid acc -> - let type_of_hid = pf_get_hyp_typ g hid in - let sigma = project g in - match EConstr.kind sigma type_of_hid with - | Prod(_,_,t') -> - begin - match EConstr.kind sigma t' with - | Prod(_,t'',t''') -> - begin - match EConstr.kind sigma t'',EConstr.kind sigma t''' with - | App(eq,args), App(graph',_) - when - (EConstr.eq_constr sigma eq eq_ind) && - Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> - (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) - ::acc) - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - ) pre_args [] + let type_of_hid = pf_get_hyp_typ g hid in + let sigma = project g in + match EConstr.kind sigma type_of_hid with + | Prod (_, _, t') -> ( + match EConstr.kind sigma t' with + | Prod (_, t'', t''') -> ( + match (EConstr.kind sigma t'', EConstr.kind sigma t''') with + | App (eq, args), App (graph', _) + when EConstr.eq_constr sigma eq eq_ind + && Array.exists + (EConstr.eq_constr_nounivs sigma graph') + graphs_constr -> + args.(2) + :: mkApp + ( mkVar hid + , [| args.(2) + ; mkApp (eq_construct, [|args.(0); args.(2)|]) |] ) + :: acc + | _ -> mkVar hid :: acc ) + | _ -> mkVar hid :: acc ) + | _ -> mkVar hid :: acc) + pre_args [] in (* in fact we must also add the parameters to the constructor args *) let constructor_args g = - let params_id = fst (List.chop princ_infos.Tactics.nparams args_names) in - (List.map mkVar params_id)@((constructor_args g)) + let params_id = + fst (List.chop princ_infos.Tactics.nparams args_names) + in + List.map mkVar params_id @ constructor_args g in (* We then get the constructor corresponding to this branch and modifies the references has needed i.e. @@ -648,120 +728,136 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.t *) let constructor = let constructor_num = i - !min_constr_number in - let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then - begin - (kn,!ind_number),constructor_num - end - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length ; - (kn,!ind_number),1 - end + let length = + Array.length + mib.Declarations.mind_packets.(!ind_number) + .Declarations.mind_consnames + in + if constructor_num <= length then ((kn, !ind_number), constructor_num) + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + ((kn, !ind_number), 1) + end in (* we can then build the final proof term *) - let app_constructor g = applist((mkConstructU(constructor,u)),constructor_args g) in + let app_constructor g = + applist (mkConstructU (constructor, u), constructor_args g) + in (* an apply the tactic *) - let res,hres = - match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with - | [res;hres] -> res,hres + let res, hres = + match + generate_fresh_id (Id.of_string "z") ids (* @this_branche_ids *) 2 + with + | [res; hres] -> (res, hres) | _ -> assert false in (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) - ( - tclTHENLIST - [ - observe_tac ("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in - match l with - | [] -> tclIDTAC - | _ -> Proofview.V82.of_tactic (intro_patterns false l)); - (* unfolding of all the defined variables introduced by this branch *) - (* observe_tac "unfolding" pre_tac; *) - (* $zeta$ normalizing of the conclusion *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - { Redops.all_flags with - Genredexpr.rDelta = false ; - Genredexpr.rConst = [] - } - ) - Locusops.onConcl); - observe_tac ("toto ") tclIDTAC; - - (* introducing the result of the graph and the equality hypothesis *) - observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); - (* replacing [res] with its value *) - observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); - (* Conclusion *) - observe_tac "exact" (fun g -> - Proofview.V82.of_tactic (exact_check (app_constructor g)) g) - ] - ) + (tclTHENLIST + [ observe_tac "h_intro_patterns " + (let l = List.nth intro_pats (pred i) in + match l with + | [] -> tclIDTAC + | _ -> Proofview.V82.of_tactic (intro_patterns false l)) + ; (* unfolding of all the defined variables introduced by this branch *) + (* observe_tac "unfolding" pre_tac; *) + (* $zeta$ normalizing of the conclusion *) + Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv + { Redops.all_flags with + Genredexpr.rDelta = false + ; Genredexpr.rConst = [] }) + Locusops.onConcl) + ; observe_tac "toto " tclIDTAC + ; (* introducing the result of the graph and the equality hypothesis *) + observe_tac "introducing" + (tclMAP + (fun x -> Proofview.V82.of_tactic (Simple.intro x)) + [res; hres]) + ; (* replacing [res] with its value *) + observe_tac "rewriting res value" + (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))) + ; (* Conclusion *) + observe_tac "exact" (fun g -> + Proofview.V82.of_tactic (exact_check (app_constructor g)) g) ]) g in (* end of branche proof *) let lemmas = Array.map - (fun ((_,(ctxt,concl))) -> - match ctxt with - | [] | [_] | [_;_] -> CErrors.anomaly (Pp.str "bad context.") - | hres::res::decl::ctxt -> - let res = EConstr.it_mkLambda_or_LetIn - (EConstr.it_mkProd_or_LetIn concl [hres;res]) - (LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) :: ctxt) - in - res) + (fun (_, (ctxt, concl)) -> + match ctxt with + | [] | [_] | [_; _] -> CErrors.anomaly (Pp.str "bad context.") + | hres :: res :: decl :: ctxt -> + let res = + EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres; res]) + ( LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) + :: ctxt ) + in + res) lemmas_types_infos in let param_names = fst (List.chop princ_infos.nparams args_names) in let params = List.map mkVar param_names in - let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in + let lemmas = + Array.to_list (Array.map (fun c -> applist (c, params)) lemmas) + in (* The bindings of the principle that is the params of the principle and the different lemma types *) let bindings = - let params_bindings,avoid = + let params_bindings, avoid = List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - p::bindings,id::avoid - ) - ([],pf_ids_of_hyps g) - princ_infos.params - (List.rev params) + (fun (bindings, avoid) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + (p :: bindings, id :: avoid)) + ([], pf_ids_of_hyps g) + princ_infos.params (List.rev params) in let lemmas_bindings = - List.rev (fst (List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - (Reductionops.nf_zeta (pf_env g) (project g) p)::bindings,id::avoid) - ([],avoid) - princ_infos.predicates - (lemmas))) + List.rev + (fst + (List.fold_left2 + (fun (bindings, avoid) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + ( Reductionops.nf_zeta (pf_env g) (project g) p :: bindings + , id :: avoid )) + ([], avoid) princ_infos.predicates lemmas)) in - (params_bindings@lemmas_bindings) + params_bindings @ lemmas_bindings in tclTHENLIST - [ - observe_tac "principle" (Proofview.V82.of_tactic (assert_by - (Name principle_id) - princ_type - (exact_check f_principle))); - observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); - (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) - observe_tac "idtac" tclIDTAC; - tclTHEN_i - (observe_tac - "functional_induction" ( - (fun gl -> - let term = mkApp (mkVar principle_id,Array.of_list bindings) in - let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in - Proofview.V82.of_tactic (apply term) gl') - )) - (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) - ] + [ observe_tac "principle" + (Proofview.V82.of_tactic + (assert_by (Name principle_id) princ_type + (exact_check f_principle))) + ; observe_tac "intro args_names" + (tclMAP + (fun id -> Proofview.V82.of_tactic (Simple.intro id)) + args_names) + ; (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) + observe_tac "idtac" tclIDTAC + ; tclTHEN_i + (observe_tac "functional_induction" (fun gl -> + let term = mkApp (mkVar principle_id, Array.of_list bindings) in + let gl', _ty = + pf_eapply (Typing.type_of ~refresh:true) gl term + in + Proofview.V82.of_tactic (apply term) gl')) + (fun i g -> + observe_tac + ("proving branche " ^ string_of_int i) + (prove_branche i) g) ] g (* [prove_fun_complete funs graphs schemes lemmas_types_infos i] @@ -798,13 +894,12 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl *) let tauto = let open Ltac_plugin in - let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in + let dp = List.map Id.of_string ["Tauto"; "Init"; "Coq"] in let mp = ModPath.MPfile (DirPath.make dp) in let kn = KerName.make mp (Label.make "tauto") in - Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> - let body = Tacenv.interp_ltac kn in - Tacinterp.eval_tactic body - end + Proofview.tclBIND (Proofview.tclUNIT ()) (fun () -> + let body = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic body) (* [generalize_dependent_of x hyp g] generalize every hypothesis which depends of [x] but [hyp] @@ -815,16 +910,18 @@ let generalize_dependent_of x hyp g = let open Tacticals in tclMAP (function - | LocalAssum ({Context.binder_name=id},t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) (project g) x t) -> - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) (thin [id]) - | _ -> tclIDTAC - ) - (pf_hyps g) - g + | LocalAssum ({Context.binder_name = id}, t) + when (not (Id.equal id hyp)) + && Termops.occur_var (pf_env g) (project g) x t -> + tclTHEN + (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) + (thin [id]) + | _ -> tclIDTAC) + (pf_hyps g) g let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g + and intros_with_rewrite_aux : Tacmach.tactic = let open Constr in let open EConstr in @@ -835,88 +932,111 @@ and intros_with_rewrite_aux : Tacmach.tactic = let eq_ind = make_eq () in let sigma = project g in match EConstr.kind sigma (pf_concl g) with - | Prod(_,t,t') -> - begin - match EConstr.kind sigma t with - | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> - if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g - else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(1) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(1)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] - g - else if isVar sigma args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(2)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); - intros_with_rewrite - ] - g - else - begin - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST[ - Proofview.V82.of_tactic (Simple.intro id); - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] g - end - | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type")) -> - Proofview.V82.of_tactic tauto g - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - intros_with_rewrite - ] g - | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g - | _ -> - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g - end + | Prod (_, t, t') -> ( + match EConstr.kind sigma t with + | App (eq, args) when EConstr.eq_constr sigma eq eq_ind -> + if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; thin [id] + ; intros_with_rewrite ] + g + else if + isVar sigma args.(1) + && Environ.evaluable_named (destVar sigma args.(1)) (pf_env g) + then + tclTHENLIST + [ Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ]) + ; tclMAP + (fun id -> + tclTRY + (Proofview.V82.of_tactic + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ] + (destVar sigma args.(1), Locus.InHyp)))) + (pf_ids_of_hyps g) + ; intros_with_rewrite ] + g + else if + isVar sigma args.(2) + && Environ.evaluable_named (destVar sigma args.(2)) (pf_env g) + then + tclTHENLIST + [ Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ]) + ; tclMAP + (fun id -> + tclTRY + (Proofview.V82.of_tactic + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ] + (destVar sigma args.(2), Locus.InHyp)))) + (pf_ids_of_hyps g) + ; intros_with_rewrite ] + g + else if isVar sigma args.(1) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; generalize_dependent_of (destVar sigma args.(1)) id + ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) + ; intros_with_rewrite ] + g + else if isVar sigma args.(2) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; generalize_dependent_of (destVar sigma args.(2)) id + ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))) + ; intros_with_rewrite ] + g + else + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) + ; intros_with_rewrite ] + g + | Ind _ + when EConstr.eq_constr sigma t + (EConstr.of_constr + ( UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.False.type" )) -> + Proofview.V82.of_tactic tauto g + | Case (_, _, v, _) -> + tclTHENLIST + [Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite] + g + | LetIn _ -> + tclTHENLIST + [ Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv + {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl) + ; intros_with_rewrite ] + g + | _ -> + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [Proofview.V82.of_tactic (Simple.intro id); intros_with_rewrite] + g ) | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g + tclTHENLIST + [ Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl) + ; intros_with_rewrite ] + g | _ -> tclIDTAC g let rec reflexivity_with_destruct_cases g = @@ -927,52 +1047,66 @@ let rec reflexivity_with_destruct_cases g = let open Tacticals in let destruct_case () = try - match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - Proofview.V82.of_tactic intros; - observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases - ] + match + EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) + with + | Case (_, _, v, _) -> + tclTHENLIST + [ Proofview.V82.of_tactic (simplest_case v) + ; Proofview.V82.of_tactic intros + ; observe_tac "reflexivity_with_destruct_cases" + reflexivity_with_destruct_cases ] | _ -> Proofview.V82.of_tactic reflexivity with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity in let eq_ind = make_eq () in - let my_inj_flags = Some { - Equality.keep_proof_equalities = false; - injection_in_context = false; (* for compatibility, necessary *) - injection_pattern_l2r_order = false; (* probably does not matter; except maybe with dependent hyps *) - } in + let my_inj_flags = + Some + { Equality.keep_proof_equalities = false + ; injection_in_context = false + ; (* for compatibility, necessary *) + injection_pattern_l2r_order = + false (* probably does not matter; except maybe with dependent hyps *) + } + in let discr_inject = - Tacticals.onAllHypsAndConcl ( - fun sc g -> + Tacticals.onAllHypsAndConcl (fun sc g -> match sc with - None -> tclIDTAC g - | Some id -> + | None -> tclIDTAC g + | Some id -> ( match EConstr.kind (project g) (pf_get_hyp_typ g id) with - | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> - if Equality.discriminable (pf_env g) (project g) t1 t2 - then Proofview.V82.of_tactic (Equality.discrHyp id) g - else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 - then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g + | App (eq, [|_; t1; t2|]) when EConstr.eq_constr (project g) eq eq_ind + -> + if Equality.discriminable (pf_env g) (project g) t1 t2 then + Proofview.V82.of_tactic (Equality.discrHyp id) g + else if + Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 + then + tclTHENLIST + [ Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id) + ; thin [id] + ; intros_with_rewrite ] + g else tclIDTAC g - | _ -> tclIDTAC g - ) + | _ -> tclIDTAC g )) in (tclFIRST - [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity); - observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); - (* We reach this point ONLY if - the same value is matched (at least) two times - along binding path. - In this case, either we have a discriminable hypothesis and we are done, - either at least an injectable one and we do the injection before continuing + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" + (Proofview.V82.of_tactic reflexivity) + ; observe_tac "reflexivity_with_destruct_cases : destruct_case" + (destruct_case ()) + ; (* We reach this point ONLY if + the same value is matched (at least) two times + along binding path. + In this case, either we have a discriminable hypothesis and we are done, + either at least an injectable one and we do the injection before continuing *) - observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) - ]) + observe_tac "reflexivity_with_destruct_cases : others" + (tclTHEN (tclPROGRESS discr_inject) reflexivity_with_destruct_cases) ]) g -let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tactic = +let prove_fun_complete funcs graphs schemes lemmas_types_infos i : + Tacmach.tactic = let open EConstr in let open Tacmach in let open Tactics in @@ -983,12 +1117,17 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let lemmas = Array.map - (fun (_,(ctxt,concl)) -> Reductionops.nf_zeta (pf_env g) (project g) (EConstr.it_mkLambda_or_LetIn concl ctxt)) + (fun (_, (ctxt, concl)) -> + Reductionops.nf_zeta (pf_env g) (project g) + (EConstr.it_mkLambda_or_LetIn concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in - let graph_principle = Reductionops.nf_zeta (pf_env g) (project g) (EConstr.of_constr schemes.(i)) in + let graph_principle = + Reductionops.nf_zeta (pf_env g) (project g) + (EConstr.of_constr schemes.(i)) + in let g, princ_type = tac_type_of g graph_principle in let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function @@ -996,24 +1135,24 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in + let ids = args_names @ pf_ids_of_hyps g in (* and fresh names for res H and the principle (cf bug bug #1174) *) - let res,hres,graph_principle_id = + let res, hres, graph_principle_id = match generate_fresh_id (Id.of_string "z") ids 3 with - | [res;hres;graph_principle_id] -> res,hres,graph_principle_id + | [res; hres; graph_principle_id] -> (res, hres, graph_principle_id) | _ -> assert false in - let ids = res::hres::graph_principle_id::ids in + let ids = res :: hres :: graph_principle_id :: ids in (* we also compute fresh names for each hyptohesis of each branch of the principle *) let branches = List.rev princ_infos.branches in let intro_pats = List.map (fun decl -> - List.map - (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (Termops.nb_prod (project g) (RelDecl.get_type decl))) - ) + List.map + (fun id -> id) + (generate_fresh_id (Id.of_string "y") ids + (Termops.nb_prod (project g) (RelDecl.get_type decl)))) branches in (* We will need to change the function by its body @@ -1022,34 +1161,38 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let rewrite_tac j ids : Tacmach.tactic = let graph_def = graphs.(j) in - let infos = match find_Function_infos (fst (destConst (project g) funcs.(j))) with - | None -> - CErrors.user_err Pp.(str "No graph found") + let infos = + match find_Function_infos (fst (destConst (project g) funcs.(j))) with + | None -> CErrors.user_err Pp.(str "No graph found") | Some infos -> infos in - if infos.is_general || Rtree.is_infinite Declareops.eq_recarg graph_def.Declarations.mind_recargs + if + infos.is_general + || Rtree.is_infinite Declareops.eq_recarg + graph_def.Declarations.mind_recargs then let eq_lemma = - try Option.get (infos).equation_lemma - with Option.IsNone -> CErrors.anomaly (Pp.str "Cannot find equation lemma.") + try Option.get infos.equation_lemma + with Option.IsNone -> + CErrors.anomaly (Pp.str "Cannot find equation lemma.") in - tclTHENLIST[ - tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); - (* Don't forget to $\zeta$ normlize the term since the principles - have been $\zeta$-normalized *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - Proofview.V82.of_tactic (generalize (List.map mkVar ids)); - thin ids - ] + tclTHENLIST + [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids + ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)) + ; (* Don't forget to $\zeta$ normlize the term since the principles + have been $\zeta$-normalized *) + Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv + {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl) + ; Proofview.V82.of_tactic (generalize (List.map mkVar ids)) + ; thin ids ] else - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))]) + Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalConstRef (fst (destConst (project g) f)) ) ]) in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -1058,40 +1201,49 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti (* we fist compute the inductive corresponding to the branch *) let this_ind_number = let constructor_num = i - !min_constr_number in - let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then !ind_number - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length; - !ind_number - end + let length = + Array.length graphs.(!ind_number).Declarations.mind_consnames + in + if constructor_num <= length then !ind_number + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + !ind_number + end in let this_branche_ids = List.nth intro_pats (pred i) in - tclTHENLIST[ - (* we expand the definition of the function *) - observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); - (* introduce hypothesis with some rewrite *) - observe_tac "intros_with_rewrite (all)" intros_with_rewrite; - (* The proof is (almost) complete *) - observe_tac "reflexivity" (reflexivity_with_destruct_cases) - ] + tclTHENLIST + [ (* we expand the definition of the function *) + observe_tac "rewrite_tac" + (rewrite_tac this_ind_number this_branche_ids) + ; (* introduce hypothesis with some rewrite *) + observe_tac "intros_with_rewrite (all)" intros_with_rewrite + ; (* The proof is (almost) complete *) + observe_tac "reflexivity" reflexivity_with_destruct_cases ] g in let params_names = fst (List.chop princ_infos.nparams args_names) in let open EConstr in let params = List.map mkVar params_names in tclTHENLIST - [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); - observe_tac "h_generalize" - (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); - Proofview.V82.of_tactic (Simple.intro graph_principle_id); - observe_tac "" (tclTHEN_i - (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres, Tactypes.NoBindings) - (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) - (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) - ] + [ tclMAP + (fun id -> Proofview.V82.of_tactic (Simple.intro id)) + (args_names @ [res; hres]) + ; observe_tac "h_generalize" + (Proofview.V82.of_tactic + (generalize + [ mkApp + ( applist (graph_principle, params) + , Array.map (fun c -> applist (c, params)) lemmas ) ])) + ; Proofview.V82.of_tactic (Simple.intro graph_principle_id) + ; observe_tac "" + (tclTHEN_i + (observe_tac "elim" + (Proofview.V82.of_tactic + (elim false None + (mkVar hres, Tactypes.NoBindings) + (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) + (fun i g -> observe_tac "prove_branche" (prove_branche i) g)) ] g exception No_graph_found @@ -1099,35 +1251,35 @@ exception No_graph_found let get_funs_constant mp = let open Constr in let exception Not_Rec in - let get_funs_constant const e : (Names.Constant.t*int) array = + let get_funs_constant const e : (Names.Constant.t * int) array = match Constr.kind (Term.strip_lam e) with - | Fix((_,(na,_,_))) -> + | Fix (_, (na, _, _)) -> Array.mapi (fun i na -> - match na.Context.binder_name with - | Name id -> - let const = Constant.make2 mp (Label.of_id id) in - const,i - | Anonymous -> - CErrors.anomaly (Pp.str "Anonymous fix.") - ) + match na.Context.binder_name with + | Name id -> + let const = Constant.make2 mp (Label.of_id id) in + (const, i) + | Anonymous -> CErrors.anomaly (Pp.str "Anonymous fix.")) na - | _ -> [|const,0|] + | _ -> [|(const, 0)|] in - function const -> + function + | const -> let find_constant_body const = match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let body = Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - (Global.env ()) - (Evd.from_env (Global.env ())) - (EConstr.of_constr body) - in - let body = EConstr.Unsafe.to_constr body in - body - | None -> - CErrors.user_err Pp.(str ( "Cannot define a principle over an axiom ")) + | Some (body, _, _) -> + let body = + Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + (Global.env ()) + (Evd.from_env (Global.env ())) + (EConstr.of_constr body) + in + let body = EConstr.Unsafe.to_constr body in + body + | None -> + CErrors.user_err Pp.(str "Cannot define a principle over an axiom ") in let f = find_constant_body const in let l_const = get_funs_constant const f in @@ -1135,17 +1287,24 @@ let get_funs_constant mp = We need to check that all the functions found are in the same block to prevent Reset strange thing *) - let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in - let l_params, _l_fixes = List.split (List.map Term.decompose_lam l_bodies) in + let l_bodies = + List.map find_constant_body (Array.to_list (Array.map fst l_const)) + in + let l_params, _l_fixes = + List.split (List.map Term.decompose_lam l_bodies) + in (* all the parameters must be equal*) let _check_params = - let first_params = List.hd l_params in + let first_params = List.hd l_params in List.iter (fun params -> - if not (List.equal (fun (n1, c1) (n2, c2) -> - Context.eq_annot Name.equal n1 n2 && Constr.equal c1 c2) first_params params) - then CErrors.user_err Pp.(str "Not a mutal recursive block") - ) + if + not + (List.equal + (fun (n1, c1) (n2, c2) -> + Context.eq_annot Name.equal n1 n2 && Constr.equal c1 c2) + first_params params) + then CErrors.user_err Pp.(str "Not a mutal recursive block")) l_params in (* The bodies has to be very similar *) @@ -1153,27 +1312,30 @@ let get_funs_constant mp = try let extract_info is_first body = match Constr.kind body with - | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) - | _ -> - if is_first && Int.equal (List.length l_bodies) 1 - then raise Not_Rec - else CErrors.user_err Pp.(str "Not a mutal recursive block") + | Fix ((idxs, _), (na, ta, ca)) -> (idxs, na, ta, ca) + | _ -> + if is_first && Int.equal (List.length l_bodies) 1 then raise Not_Rec + else CErrors.user_err Pp.(str "Not a mutal recursive block") in let first_infos = extract_info true (List.hd l_bodies) in - let check body = (* Hope this is correct *) + let check body = + (* Hope this is correct *) let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = - Array.equal Int.equal ia1 ia2 && Array.equal (Context.eq_annot Name.equal) na1 na2 && - Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 + Array.equal Int.equal ia1 ia2 + && Array.equal (Context.eq_annot Name.equal) na1 na2 + && Array.equal Constr.equal ta1 ta2 + && Array.equal Constr.equal ca1 ca2 in - if not (eq_infos first_infos (extract_info false body)) - then CErrors.user_err Pp.(str "Not a mutal recursive block") + if not (eq_infos first_infos (extract_info false body)) then + CErrors.user_err Pp.(str "Not a mutal recursive block") in List.iter check l_bodies with Not_Rec -> () in l_const -let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_effects Declare.proof_entry list = +let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : + Evd.side_effects Declare.proof_entry list = let exception Found_type of int in let env = Global.env () in let funs = List.map fst fas in @@ -1185,42 +1347,47 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef | Some finfos -> fst finfos.graph_ind in let this_block_funs_indexes = get_funs_constant funs_mp (fst first_fun) in - let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) this_block_funs_indexes in + let this_block_funs = + Array.map (fun (c, _) -> (c, snd first_fun)) this_block_funs_indexes + in let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.map - (function cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) + (function + | cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) funs in let ind_list = List.map - (fun (idx) -> - let ind = first_fun_kn,idx in - (ind,snd first_fun),true,prop_sort - ) + (fun idx -> + let ind = (first_fun_kn, idx) in + ((ind, snd first_fun), true, prop_sort)) funs_indexes in - let sigma, schemes = - Indrec.build_mutual_induction_scheme env !evd ind_list - in + let sigma, schemes = Indrec.build_mutual_induction_scheme env !evd ind_list in let _ = evd := sigma in let l_schemes = - List.map (EConstr.of_constr %> Retyping.get_type_of env sigma %> EConstr.Unsafe.to_constr) schemes + List.map + ( EConstr.of_constr + %> Retyping.get_type_of env sigma + %> EConstr.Unsafe.to_constr ) + schemes in let i = ref (-1) in let sorts = - List.rev_map (fun (_,x) -> + List.rev_map + (fun (_, x) -> let sigma, fs = Evd.fresh_sort_in_family !evd x in - evd := sigma; fs - ) + evd := sigma; + fs) fas in (* We create the first principle by tactic *) - let first_type,other_princ_types = + let first_type, other_princ_types = match l_schemes with - s::l_schemes -> s,l_schemes - | _ -> CErrors.anomaly (Pp.str "") + | s :: l_schemes -> (s, l_schemes) + | _ -> CErrors.anomaly (Pp.str "") in let opaque = let finfos = @@ -1228,280 +1395,298 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef | None -> raise Not_found | Some finfos -> finfos in - let open Proof_global in + let open Declare in match finfos.equation_lemma with | None -> Transparent (* non recursive definition *) | Some equation -> - if Declareops.is_opaque (Global.lookup_constant equation) then Opaque else Transparent + if Declareops.is_opaque (Global.lookup_constant equation) then Opaque + else Transparent in let entry, _hook = try - build_functional_principle ~opaque evd - first_type - (Array.of_list sorts) - this_block_funs - 0 - (Functional_principles_proofs.prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) + build_functional_principle ~opaque evd first_type (Array.of_list sorts) + this_block_funs 0 + (Functional_principles_proofs.prove_princ_for_struct evd false 0 + (Array.of_list (List.map fst funs))) (fun _ _ -> ()) - with e when CErrors.noncritical e -> - raise (Defining_principle e) - + with e when CErrors.noncritical e -> raise (Defining_principle e) in incr i; (* The others are just deduced *) - if List.is_empty other_princ_types - then [entry] + if List.is_empty other_princ_types then [entry] else let other_fun_princ_types = let funs = Array.map Constr.mkConstU this_block_funs in let sorts = Array.of_list sorts in - List.map (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) other_princ_types + List.map + (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) + other_princ_types in let first_princ_body = entry.Declare.proof_entry_body in - let ctxt,fix = Term.decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) - let (idxs,_),(_,ta,_ as decl) = Constr.destFix fix in + let ctxt, fix = + Term.decompose_lam_assum (fst (fst (Future.force first_princ_body))) + in + (* the principle has for forall ...., fix .*) + let (idxs, _), ((_, ta, _) as decl) = Constr.destFix fix in let other_result = List.map (* we can now compute the other principles *) (fun scheme_type -> - incr i; - observe (Printer.pr_lconstr_env env sigma scheme_type); - let type_concl = (Term.strip_prod_assum scheme_type) in - let applied_f = List.hd (List.rev (snd (Constr.decompose_app type_concl))) in - let f = fst (Constr.decompose_app applied_f) in - try (* we search the number of the function in the fix block (name of the function) *) - Array.iteri - (fun j t -> - let t = (Term.strip_prod_assum t) in - let applied_g = List.hd (List.rev (snd (Constr.decompose_app t))) in + incr i; + observe (Printer.pr_lconstr_env env sigma scheme_type); + let type_concl = Term.strip_prod_assum scheme_type in + let applied_f = + List.hd (List.rev (snd (Constr.decompose_app type_concl))) + in + let f = fst (Constr.decompose_app applied_f) in + try + (* we search the number of the function in the fix block (name of the function) *) + Array.iteri + (fun j t -> + let t = Term.strip_prod_assum t in + let applied_g = + List.hd (List.rev (snd (Constr.decompose_app t))) + in let g = fst (Constr.decompose_app applied_g) in - if Constr.equal f g - then raise (Found_type j); - observe Pp.(Printer.pr_lconstr_env env sigma f ++ str " <> " ++ - Printer.pr_lconstr_env env sigma g) - - ) - ta; - (* If we reach this point, the two principle are not mutually recursive - We fall back to the previous method - *) - let entry, _hook = - build_functional_principle - evd - (List.nth other_princ_types (!i - 1)) - (Array.of_list sorts) - this_block_funs - !i - (Functional_principles_proofs.prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) - (fun _ _ -> ()) - in - entry - with Found_type i -> - let princ_body = - Termops.it_mkLambda_or_LetIn (Constr.mkFix((idxs,i),decl)) ctxt - in - Declare.definition_entry ~types:scheme_type princ_body - ) - other_fun_princ_types + if Constr.equal f g then raise (Found_type j); + observe + Pp.( + Printer.pr_lconstr_env env sigma f + ++ str " <> " + ++ Printer.pr_lconstr_env env sigma g)) + ta; + (* If we reach this point, the two principle are not mutually recursive + We fall back to the previous method + *) + let entry, _hook = + build_functional_principle evd + (List.nth other_princ_types (!i - 1)) + (Array.of_list sorts) this_block_funs !i + (Functional_principles_proofs.prove_princ_for_struct evd false + !i + (Array.of_list (List.map fst funs))) + (fun _ _ -> ()) + in + entry + with Found_type i -> + let princ_body = + Termops.it_mkLambda_or_LetIn (Constr.mkFix ((idxs, i), decl)) ctxt + in + Declare.definition_entry ~types:scheme_type princ_body) + other_fun_princ_types in - entry::other_result + entry :: other_result (* [derive_correctness funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] *) -let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = +let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) + = let open EConstr in assert (funs <> []); assert (graphs <> []); let funs = Array.of_list funs and graphs = Array.of_list graphs in let map (c, u) = mkConstU (c, EInstance.make u) in - let funs_constr = Array.map map funs in + let funs_constr = Array.map map funs in (* XXX STATE Why do we need this... why is the toplevel protection not enough *) funind_purify (fun () -> - let env = Global.env () in - let evd = ref (Evd.from_env env) in - let graphs_constr = Array.map mkInd graphs in - let lemmas_types_infos = - Util.Array.map2_i - (fun i f_constr graph -> - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd false f_constr graph - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in - evd := sigma; - let type_of_lemma = Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma in - observe Pp.(str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - let schemes = - (* The functional induction schemes are computed and not saved if there is more that one function - if the block contains only one function we can safely reuse [f_rect] - *) - try - if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; - [| find_induction_principle evd funs_constr.(0) |] - with Not_found -> - ( - - Array.of_list - (List.map - (fun entry -> - (EConstr.of_constr (fst (fst (Future.force entry.Declare.proof_entry_body))), - EConstr.of_constr (Option.get entry.Declare.proof_entry_type )) - ) - (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) - ) - ) - in - let proving_tac = - prove_fun_correct !evd graphs_constr schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_correct_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_correct_id f_id in - let (typ,_) = lemmas_types_infos.(i) in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false !evd typ in - let lemma = fst @@ Lemmas.by - (Proofview.V82.tactic (proving_tac i)) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = - match find_Function_infos (fst f_as_constant) with - | None -> raise Not_found - | Some finfo -> finfo + let env = Global.env () in + let evd = ref (Evd.from_env env) in + let graphs_constr = Array.map mkInd graphs in + let lemmas_types_infos = + Util.Array.map2_i + (fun i f_constr graph -> + let type_of_lemma_ctxt, type_of_lemma_concl, graph = + generate_type evd false f_constr graph in - (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = EConstr.destConst !evd lem_cst_constr in - update_Function {finfo with correctness_lemma = Some lem_cst}; - - ) - funs; - let lemmas_types_infos = - Util.Array.map2_i - (fun i f_constr graph -> - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd true f_constr graph - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = - EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt - in - let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in - observe Pp.(str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - - let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in - let mib, _mip = Global.lookup_inductive graph_ind in - let sigma, scheme = - (Indrec.build_mutual_induction_scheme (Global.env ()) !evd - (Array.to_list - (Array.mapi - (fun i _ -> ((kn,i), EInstance.kind !evd u),true, Sorts.InType) - mib.Declarations.mind_packets - ) - ) - ) - in - let schemes = - Array.of_list scheme - in - let proving_tac = - prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_complete_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_complete_id f_id in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false sigma (fst lemmas_types_infos.(i)) in - let lemma = fst (Lemmas.by - (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i))) lemma) in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = - match find_Function_infos (fst f_as_constant) with - | None -> raise Not_found - | Some finfo -> finfo + let type_info = (type_of_lemma_ctxt, type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst !evd lem_cst_constr in - update_Function {finfo with completeness_lemma = Some lem_cst} - ) - funs) + let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in + evd := sigma; + let type_of_lemma = + Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma + in + observe + Pp.( + str "type_of_lemma := " + ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); + (type_of_lemma, type_info)) + funs_constr graphs_constr + in + let schemes = + (* The functional induction schemes are computed and not saved if there is more that one function + if the block contains only one function we can safely reuse [f_rect] + *) + try + if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; + [|find_induction_principle evd funs_constr.(0)|] + with Not_found -> + Array.of_list + (List.map + (fun entry -> + ( EConstr.of_constr + (fst (fst (Future.force entry.Declare.proof_entry_body))) + , EConstr.of_constr (Option.get entry.Declare.proof_entry_type) + )) + (make_scheme evd + (Array.map_to_list (fun const -> (const, Sorts.InType)) funs))) + in + let proving_tac = + prove_fun_correct !evd graphs_constr schemes lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_correct_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_correct_id f_id in + let typ, _ = lemmas_types_infos.(i) in + let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false !evd typ in + let lemma = + fst @@ Lemmas.by (Proofview.V82.tactic (proving_tac i)) lemma + in + let () = + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent + ~idopt:None + in + let finfo = + match find_Function_infos (fst f_as_constant) with + | None -> raise Not_found + | Some finfo -> finfo + in + (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) + let _, lem_cst_constr = + Evd.fresh_global (Global.env ()) !evd + (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) + in + let lem_cst, _ = EConstr.destConst !evd lem_cst_constr in + update_Function {finfo with correctness_lemma = Some lem_cst}) + funs; + let lemmas_types_infos = + Util.Array.map2_i + (fun i f_constr graph -> + let type_of_lemma_ctxt, type_of_lemma_concl, graph = + generate_type evd true f_constr graph + in + let type_info = (type_of_lemma_ctxt, type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt + in + let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in + observe + Pp.( + str "type_of_lemma := " + ++ Printer.pr_leconstr_env env !evd type_of_lemma); + (type_of_lemma, type_info)) + funs_constr graphs_constr + in + let ((kn, _) as graph_ind), u = destInd !evd graphs_constr.(0) in + let mib, _mip = Global.lookup_inductive graph_ind in + let sigma, scheme = + Indrec.build_mutual_induction_scheme (Global.env ()) !evd + (Array.to_list + (Array.mapi + (fun i _ -> + (((kn, i), EInstance.kind !evd u), true, Sorts.InType)) + mib.Declarations.mind_packets)) + in + let schemes = Array.of_list scheme in + let proving_tac = + prove_fun_complete funs_constr mib.Declarations.mind_packets schemes + lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_complete_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_complete_id f_id in + let lemma = + Lemmas.start_lemma ~name:lem_id ~poly:false sigma + (fst lemmas_types_infos.(i)) + in + let lemma = + fst + (Lemmas.by + (Proofview.V82.tactic + (observe_tac + ("prove completeness (" ^ Id.to_string f_id ^ ")") + (proving_tac i))) + lemma) + in + let () = + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent + ~idopt:None + in + let finfo = + match find_Function_infos (fst f_as_constant) with + | None -> raise Not_found + | Some finfo -> finfo + in + let _, lem_cst_constr = + Evd.fresh_global (Global.env ()) !evd + (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) + in + let lem_cst, _ = destConst !evd lem_cst_constr in + update_Function {finfo with completeness_lemma = Some lem_cst}) + funs) () let warn_funind_cannot_build_inversion = CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind" - Pp.(fun e' -> strbrk "Cannot build inversion information" ++ - if do_observe () then (fnl() ++ CErrors.print e') else mt ()) + Pp.( + fun e' -> + strbrk "Cannot build inversion information" + ++ if do_observe () then fnl () ++ CErrors.print e' else mt ()) let derive_inversion fix_names = try let evd' = Evd.from_env (Global.env ()) in (* we first transform the fix_names identifier into their corresponding constant *) - let evd',fix_names_as_constant = + let evd', fix_names_as_constant = List.fold_right - (fun id (evd,l) -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in - let (cst, u) = EConstr.destConst evd c in - evd, (cst, EConstr.EInstance.kind evd u) :: l - ) - fix_names - (evd',[]) + (fun id (evd, l) -> + let evd, c = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference (Libnames.qualid_of_ident id)) + in + let cst, u = EConstr.destConst evd c in + (evd, (cst, EConstr.EInstance.kind evd u) :: l)) + fix_names (evd', []) in (* Then we check that the graphs have been defined If one of the graphs haven't been defined we do nothing *) - List.iter (fun c -> ignore (find_Function_infos (fst c))) fix_names_as_constant ; + List.iter + (fun c -> ignore (find_Function_infos (fst c))) + fix_names_as_constant; try let _evd', lind = List.fold_right - (fun id (evd,l) -> - let evd,id = - Evd.fresh_global - (Global.env ()) evd - (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) - in - evd,(fst (EConstr.destInd evd id))::l - ) - fix_names - (evd',[]) + (fun id (evd, l) -> + let evd, id = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference + (Libnames.qualid_of_ident (mk_rel_id id))) + in + (evd, fst (EConstr.destInd evd id) :: l)) + fix_names (evd', []) in - derive_correctness - fix_names_as_constant - lind; - with e when CErrors.noncritical e -> - warn_funind_cannot_build_inversion e - with e when CErrors.noncritical e -> - warn_funind_cannot_build_inversion e - -let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body - pre_hook - = + derive_correctness fix_names_as_constant lind + with e when CErrors.noncritical e -> warn_funind_cannot_build_inversion e + with e when CErrors.noncritical e -> warn_funind_cannot_build_inversion e + +let register_wf interactive_proof ?(is_mes = false) fname rec_impls wf_rel_expr + wf_arg using_lemmas args ret_type body pre_hook = let type_of_f = Constrexpr_ops.mkCProdN args ret_type in let rec_arg_num = let names = @@ -1513,226 +1698,233 @@ let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf in let unbounded_eq = let f_app_args = - CAst.make @@ Constrexpr.CAppExpl( - (None, Libnames.qualid_of_ident fname,None) , - (List.map - (function - | {CAst.v=Anonymous} -> assert false - | {CAst.v=Name e} -> (Constrexpr_ops.mkIdentC e) - ) - (Constrexpr_ops.names_of_local_assums args) - ) - ) + CAst.make + @@ Constrexpr.CAppExpl + ( (None, Libnames.qualid_of_ident fname, None) + , List.map + (function + | {CAst.v = Anonymous} -> assert false + | {CAst.v = Name e} -> Constrexpr_ops.mkIdentC e) + (Constrexpr_ops.names_of_local_assums args) ) in - CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (Libnames.qualid_of_string "Logic.eq")), - [(f_app_args,None);(body,None)]) + CAst.make + @@ Constrexpr.CApp + ( (None, Constrexpr_ops.mkRefC (Libnames.qualid_of_string "Logic.eq")) + , [(f_app_args, None); (body, None)] ) in let eq = Constrexpr_ops.mkCProdN args unbounded_eq in - let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type - _nb_args relation = + let hook ((f_ref, _) as fconst) tcc_lemma_ref (functional_ref, _) (eq_ref, _) + rec_arg_num rec_arg_type _nb_args relation = try pre_hook [fconst] - (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes - functional_ref eq_ref rec_arg_num rec_arg_type relation - ); + (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref + eq_ref rec_arg_num rec_arg_type relation); derive_inversion [fname] - with e when CErrors.noncritical e -> - (* No proof done *) - () + with e when CErrors.noncritical e -> (* No proof done *) + () in - Recdef.recursive_definition ~interactive_proof - ~is_mes fname rec_impls - type_of_f - wf_rel_expr - rec_arg_num - eq - hook - using_lemmas - -let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = - let wf_arg_type,wf_arg = + Recdef.recursive_definition ~interactive_proof ~is_mes fname rec_impls + type_of_f wf_rel_expr rec_arg_num eq hook using_lemmas + +let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt + wf_arg using_lemmas args ret_type body = + let wf_arg_type, wf_arg = match wf_arg with - | None -> - begin - match args with - | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],_k,t)] -> t,x - | _ -> CErrors.user_err (Pp.str "Recursive argument must be specified") - end - | Some wf_args -> + | None -> ( + match args with + | [Constrexpr.CLocalAssum ([{CAst.v = Name x}], _k, t)] -> (t, x) + | _ -> CErrors.user_err (Pp.str "Recursive argument must be specified") ) + | Some wf_args -> ( try match List.find (function - | Constrexpr.CLocalAssum(l,_k,t) -> + | Constrexpr.CLocalAssum (l, _k, t) -> List.exists - (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false) + (function + | {CAst.v = Name id} -> Id.equal id wf_args | _ -> false) l - | _ -> false - ) + | _ -> false) args with - | Constrexpr.CLocalAssum(_,_k,t) -> t,wf_args + | Constrexpr.CLocalAssum (_, _k, t) -> (t, wf_args) | _ -> assert false - with Not_found -> assert false + with Not_found -> assert false ) in - let wf_rel_from_mes,is_mes = + let wf_rel_from_mes, is_mes = match wf_rel_expr_opt with | None -> let ltof = let make_dir l = DirPath.make (List.rev_map Id.of_string l) in Libnames.qualid_of_path - (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")) + (Libnames.make_path + (make_dir ["Arith"; "Wf_nat"]) + (Id.of_string "ltof")) in let fun_from_mes = let applied_mes = - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in - Constrexpr_ops.mkLambdaC ([CAst.make @@ Name wf_arg],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) + Constrexpr_ops.mkAppC (wf_mes_expr, [Constrexpr_ops.mkIdentC wf_arg]) + in + Constrexpr_ops.mkLambdaC + ( [CAst.make @@ Name wf_arg] + , Constrexpr_ops.default_binder_kind + , wf_arg_type + , applied_mes ) in let wf_rel_from_mes = - Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) + Constrexpr_ops.mkAppC + (Constrexpr_ops.mkRefC ltof, [wf_arg_type; fun_from_mes]) in - wf_rel_from_mes,true + (wf_rel_from_mes, true) | Some wf_rel_expr -> let wf_rel_with_mes = let a = Names.Id.of_string "___a" in let b = Names.Id.of_string "___b" in - Constrexpr_ops.mkLambdaC( - [CAst.make @@ Name a; CAst.make @@ Name b], - Constrexpr.Default Glob_term.Explicit, - wf_arg_type, - Constrexpr_ops.mkAppC(wf_rel_expr, - [ - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) - ]) - ) + Constrexpr_ops.mkLambdaC + ( [CAst.make @@ Name a; CAst.make @@ Name b] + , Constrexpr.Default Glob_term.Explicit + , wf_arg_type + , Constrexpr_ops.mkAppC + ( wf_rel_expr + , [ Constrexpr_ops.mkAppC + (wf_mes_expr, [Constrexpr_ops.mkIdentC a]) + ; Constrexpr_ops.mkAppC + (wf_mes_expr, [Constrexpr_ops.mkIdentC b]) ] ) ) in - wf_rel_with_mes,false + (wf_rel_with_mes, false) in - register_wf interactive_proof ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg + register_wf interactive_proof ~is_mes fname rec_impls wf_rel_from_mes wf_arg using_lemmas args ret_type body -let do_generate_principle_aux pconstants on_error register_built interactive_proof fixpoint_exprl : Lemmas.t option = - List.iter (fun { Vernacexpr.notations } -> - if not (List.is_empty notations) - then CErrors.user_err (Pp.str "Function does not support notations for now")) fixpoint_exprl; +let do_generate_principle_aux pconstants on_error register_built + interactive_proof fixpoint_exprl : Lemmas.t option = + List.iter + (fun {Vernacexpr.notations} -> + if not (List.is_empty notations) then + CErrors.user_err (Pp.str "Function does not support notations for now")) + fixpoint_exprl; let lemma, _is_struct = match fixpoint_exprl with - | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs = _; binders; rtype; body_def } as fixpoint_expr = + | [ ( { Vernacexpr.rec_order = + Some {CAst.v = Constrexpr.CWfRec (wf_x, wf_rel)} } as + fixpoint_expr ) ] -> + let ( {Vernacexpr.fname; univs = _; binders; rtype; body_def} as + fixpoint_expr ) = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let body = match body_def with | Some body -> body | None -> - CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let body = + match body_def with + | Some body -> body + | None -> + CErrors.user_err ~hdr:"Function" + (Pp.str "Body of Function must be given") + in + let recdefs, rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs + pconstants on_error true register_built fixpoint_exprl recdefs in - if register_built - then register_wf interactive_proof fname.CAst.v rec_impls wf_rel wf_x.CAst.v using_lemmas binders rtype body pre_hook, false - else None, false - | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs = _; binders; rtype; body_def} as fixpoint_expr = + if register_built then + ( register_wf interactive_proof fname.CAst.v rec_impls wf_rel + wf_x.CAst.v using_lemmas binders rtype body pre_hook + , false ) + else (None, false) + | [ ( { Vernacexpr.rec_order = + Some {CAst.v = Constrexpr.CMeasureRec (wf_x, wf_mes, wf_rel_opt)} + } as fixpoint_expr ) ] -> + let ( {Vernacexpr.fname; univs = _; binders; rtype; body_def} as + fixpoint_expr ) = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let recdefs, rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in - let body = match body_def with + let body = + match body_def with | Some body -> body | None -> - CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in + CErrors.user_err ~hdr:"Function" + Pp.(str "Body of Function must be given") + in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs + pconstants on_error true register_built fixpoint_exprl recdefs in - if register_built - then register_mes interactive_proof fname.CAst.v rec_impls wf_mes wf_rel_opt - (Option.map (fun x -> x.CAst.v) wf_x) using_lemmas binders rtype body pre_hook, true - else None, true + if register_built then + ( register_mes interactive_proof fname.CAst.v rec_impls wf_mes wf_rel_opt + (Option.map (fun x -> x.CAst.v) wf_x) + using_lemmas binders rtype body pre_hook + , true ) + else (None, true) | _ -> - List.iter (function { Vernacexpr.rec_order } -> - match rec_order with - | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> - CErrors.user_err - (Pp.str "Cannot use mutual definition with well-founded recursion or measure") - | _ -> () - ) + List.iter + (function + | {Vernacexpr.rec_order} -> ( + match rec_order with + | Some {CAst.v = Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _} -> + CErrors.user_err + (Pp.str + "Cannot use mutual definition with well-founded recursion \ + or measure") + | _ -> () )) fixpoint_exprl; let fixpoint_exprl = recompute_binder_list fixpoint_exprl in - let fix_names = List.map (function { Vernacexpr.fname } -> fname.CAst.v) fixpoint_exprl in + let fix_names = + List.map (function {Vernacexpr.fname} -> fname.CAst.v) fixpoint_exprl + in (* ok all the expressions are structural *) let recdefs, _rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in - let lemma,evd,pconstants = - if register_built - then register_struct is_rec fixpoint_exprl - else None, Evd.from_env (Global.env ()), pconstants + let lemma, evd, pconstants = + if register_built then register_struct is_rec fixpoint_exprl + else (None, Evd.from_env (Global.env ()), pconstants) in let evd = ref evd in - generate_principle - (ref !evd) - pconstants - on_error - false - register_built - fixpoint_exprl - recdefs - (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); - if register_built then - begin derive_inversion fix_names; end; - lemma, true + generate_principle (ref !evd) pconstants on_error false register_built + fixpoint_exprl recdefs + (Functional_principles_proofs.prove_princ_for_struct evd + interactive_proof); + if register_built then derive_inversion fix_names; + (lemma, true) in lemma let warn_cannot_define_graph = CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind" - (fun (names,error) -> - Pp.(strbrk "Cannot define graph(s) for " ++ - h 1 names ++ error)) + (fun (names, error) -> + Pp.(strbrk "Cannot define graph(s) for " ++ h 1 names ++ error)) let warn_cannot_define_principle = CWarnings.create ~name:"funind-cannot-define-principle" ~category:"funind" - (fun (names,error) -> - Pp.(strbrk "Cannot define induction principle(s) for "++ - h 1 names ++ error)) + (fun (names, error) -> + Pp.( + strbrk "Cannot define induction principle(s) for " ++ h 1 names ++ error)) let warning_error names e = let e_explain e = match e with - | ToShow e -> - Pp.(spc () ++ CErrors.print e) - | _ -> - if do_observe () - then Pp.(spc () ++ CErrors.print e) - else Pp.mt () + | ToShow e -> Pp.(spc () ++ CErrors.print e) + | _ -> if do_observe () then Pp.(spc () ++ CErrors.print e) else Pp.mt () in match e with | Building_graph e -> - let names = Pp.(prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) in - warn_cannot_define_graph (names,e_explain e) + let names = + Pp.(prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) + in + warn_cannot_define_graph (names, e_explain e) | Defining_principle e -> - let names = Pp.(prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) in - warn_cannot_define_principle (names,e_explain e) + let names = + Pp.(prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) + in + warn_cannot_define_principle (names, e_explain e) | _ -> raise e let error_error names e = @@ -1744,9 +1936,11 @@ let error_error names e = match e with | Building_graph e -> CErrors.user_err - Pp.(str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - e_explain e) + Pp.( + str "Cannot define graph(s) for " + ++ h 1 + (prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) + ++ e_explain e) | _ -> raise e (* [chop_n_arrow n t] chops the [n] first arrows in [t] @@ -1755,272 +1949,307 @@ let error_error names e = let rec chop_n_arrow n t = let exception Stop of Constrexpr.constr_expr in let open Constrexpr in - if n <= 0 - then t (* If we have already removed all the arrows then return the type *) - else (* If not we check the form of [t] *) + if n <= 0 then t + (* If we have already removed all the arrows then return the type *) + else + (* If not we check the form of [t] *) match t.CAst.v with - | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, two results are possible : - either we need to discard more than the number of arrows contained - in this product declaration then we just recall [chop_n_arrow] on - the remaining number of arrow to chop and [t'] we discard it and - recall [chop_n_arrow], either this product contains more arrows - than the number we need to chop and then we return the new type - *) - begin - try - let new_n = - let rec aux (n:int) = function - [] -> n - | CLocalAssum(nal,k,t'')::nal_ta' -> - let nal_l = List.length nal in - if n >= nal_l - then - aux (n - nal_l) nal_ta' - else - let new_t' = CAst.make @@ - Constrexpr.CProdN( - CLocalAssum((snd (List.chop n nal)),k,t'')::nal_ta',t') - in - raise (Stop new_t') - | _ -> CErrors.anomaly (Pp.str "Not enough products.") - in - aux n nal_ta' + | Constrexpr.CProdN (nal_ta', t') -> ( + try + (* If we have a forall, two results are possible : + either we need to discard more than the number of arrows contained + in this product declaration then we just recall [chop_n_arrow] on + the remaining number of arrow to chop and [t'] we discard it and + recall [chop_n_arrow], either this product contains more arrows + than the number we need to chop and then we return the new type + *) + let new_n = + let rec aux (n : int) = function + | [] -> n + | CLocalAssum (nal, k, t'') :: nal_ta' -> + let nal_l = List.length nal in + if n >= nal_l then aux (n - nal_l) nal_ta' + else + let new_t' = + CAst.make + @@ Constrexpr.CProdN + ( CLocalAssum (snd (List.chop n nal), k, t'') :: nal_ta' + , t' ) + in + raise (Stop new_t') + | _ -> CErrors.anomaly (Pp.str "Not enough products.") in - chop_n_arrow new_n t' - with Stop t -> t - end + aux n nal_ta' + in + chop_n_arrow new_n t' + with Stop t -> t ) | _ -> CErrors.anomaly (Pp.str "Not enough products.") let rec add_args id new_args = let open Libnames in let open Constrexpr in CAst.map (function - | CRef (qid,_) as b -> - if qualid_is_ident qid && Id.equal (qualid_basename qid) id then - CAppExpl((None,qid,None),new_args) - else b - | CFix _ | CCoFix _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "todo.") - | CProdN(nal,b1) -> - CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) - | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) - | CLocalPattern _ -> - CErrors.user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) - | CLambdaN(nal,b1) -> - CLambdaN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) - | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) - | CLocalPattern _ -> - CErrors.user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) - | CLetIn(na,b1,t,b2) -> - CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) - | CAppExpl((pf,qid,us),exprl) -> - if qualid_is_ident qid && Id.equal (qualid_basename qid) id then - CAppExpl((pf,qid,us),new_args@(List.map (add_args id new_args) exprl)) - else CAppExpl((pf,qid,us),List.map (add_args id new_args) exprl) - | CApp((pf,b),bl) -> - CApp((pf,add_args id new_args b), - List.map (fun (e,o) -> add_args id new_args e,o) bl) - | CCases(sty,b_option,cel,cal) -> - CCases(sty,Option.map (add_args id new_args) b_option, - List.map (fun (b,na,b_option) -> - add_args id new_args b, - na, b_option) cel, - List.map CAst.(map (fun (cpl,e) -> (cpl,add_args id new_args e))) cal - ) - | CLetTuple(nal,(na,b_option),b1,b2) -> - CLetTuple(nal,(na,Option.map (add_args id new_args) b_option), - add_args id new_args b1, - add_args id new_args b2 - ) - - | CIf(b1,(na,b_option),b2,b3) -> - CIf(add_args id new_args b1, - (na,Option.map (add_args id new_args) b_option), - add_args id new_args b2, - add_args id new_args b3 - ) - | CHole _ - | CPatVar _ - | CEvar _ - | CPrim _ - | CSort _ as b -> b - | CCast(b1,b2) -> - CCast(add_args id new_args b1, - Glob_ops.map_cast_type (add_args id new_args) b2) - | CRecord pars -> - CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) - | CNotation _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CNotation.") - | CGeneralization _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CGeneralization.") - | CDelimiters _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CDelimiters.") - ) - -let rec get_args b t : Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr = + | CRef (qid, _) as b -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl ((None, qid, None), new_args) + else b + | CFix _ | CCoFix _ -> CErrors.anomaly ~label:"add_args " (Pp.str "todo.") + | CProdN (nal, b1) -> + CProdN + ( List.map + (function + | CLocalAssum (nal, k, b2) -> + CLocalAssum (nal, k, add_args id new_args b2) + | CLocalDef (na, b1, t) -> + CLocalDef + ( na + , add_args id new_args b1 + , Option.map (add_args id new_args) t ) + | CLocalPattern _ -> + CErrors.user_err (Pp.str "pattern with quote not allowed here.")) + nal + , add_args id new_args b1 ) + | CLambdaN (nal, b1) -> + CLambdaN + ( List.map + (function + | CLocalAssum (nal, k, b2) -> + CLocalAssum (nal, k, add_args id new_args b2) + | CLocalDef (na, b1, t) -> + CLocalDef + ( na + , add_args id new_args b1 + , Option.map (add_args id new_args) t ) + | CLocalPattern _ -> + CErrors.user_err (Pp.str "pattern with quote not allowed here.")) + nal + , add_args id new_args b1 ) + | CLetIn (na, b1, t, b2) -> + CLetIn + ( na + , add_args id new_args b1 + , Option.map (add_args id new_args) t + , add_args id new_args b2 ) + | CAppExpl ((pf, qid, us), exprl) -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl + ((pf, qid, us), new_args @ List.map (add_args id new_args) exprl) + else CAppExpl ((pf, qid, us), List.map (add_args id new_args) exprl) + | CApp ((pf, b), bl) -> + CApp + ( (pf, add_args id new_args b) + , List.map (fun (e, o) -> (add_args id new_args e, o)) bl ) + | CCases (sty, b_option, cel, cal) -> + CCases + ( sty + , Option.map (add_args id new_args) b_option + , List.map + (fun (b, na, b_option) -> (add_args id new_args b, na, b_option)) + cel + , List.map + CAst.(map (fun (cpl, e) -> (cpl, add_args id new_args e))) + cal ) + | CLetTuple (nal, (na, b_option), b1, b2) -> + CLetTuple + ( nal + , (na, Option.map (add_args id new_args) b_option) + , add_args id new_args b1 + , add_args id new_args b2 ) + | CIf (b1, (na, b_option), b2, b3) -> + CIf + ( add_args id new_args b1 + , (na, Option.map (add_args id new_args) b_option) + , add_args id new_args b2 + , add_args id new_args b3 ) + | (CHole _ | CPatVar _ | CEvar _ | CPrim _ | CSort _) as b -> b + | CCast (b1, b2) -> + CCast + ( add_args id new_args b1 + , Glob_ops.map_cast_type (add_args id new_args) b2 ) + | CRecord pars -> + CRecord (List.map (fun (e, o) -> (e, add_args id new_args o)) pars) + | CNotation _ -> CErrors.anomaly ~label:"add_args " (Pp.str "CNotation.") + | CGeneralization _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CGeneralization.") + | CDelimiters _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CDelimiters.")) + +let rec get_args b t : + Constrexpr.local_binder_expr list + * Constrexpr.constr_expr + * Constrexpr.constr_expr = let open Constrexpr in match b.CAst.v with - | Constrexpr.CLambdaN (CLocalAssum(nal,k,ta) as d::rest, b') -> - begin - let n = List.length nal in - let nal_tas,b'',t'' = get_args (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest,b')) (chop_n_arrow n t) in - d :: nal_tas, b'',t'' - end - | Constrexpr.CLambdaN ([], b) -> [],b,t - | _ -> [],b,t + | Constrexpr.CLambdaN ((CLocalAssum (nal, k, ta) as d) :: rest, b') -> + let n = List.length nal in + let nal_tas, b'', t'' = + get_args + (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest, b')) + (chop_n_arrow n t) + in + (d :: nal_tas, b'', t'') + | Constrexpr.CLambdaN ([], b) -> ([], b, t) + | _ -> ([], b, t) let make_graph (f_ref : GlobRef.t) = let open Constrexpr in - let env = Global.env() in + let env = Global.env () in let sigma = Evd.from_env env in - let c,c_body = + let c, c_body = match f_ref with - | GlobRef.ConstRef c -> - begin - try c,Global.lookup_constant c - with Not_found -> - CErrors.user_err Pp.(str "Cannot find " ++ Printer.pr_leconstr_env env sigma (EConstr.mkConst c)) - end - | _ -> - CErrors.user_err Pp.(str "Not a function reference") + | GlobRef.ConstRef c -> ( + try (c, Global.lookup_constant c) + with Not_found -> + CErrors.user_err + Pp.( + str "Cannot find " + ++ Printer.pr_leconstr_env env sigma (EConstr.mkConst c)) ) + | _ -> CErrors.user_err Pp.(str "Not a function reference") in - (match Global.body_of_constant_body Library.indirect_accessor c_body with - | None -> - CErrors.user_err (Pp.str "Cannot build a graph over an axiom!") - | Some (body, _, _) -> - let env = Global.env () in - let extern_body,extern_type = - with_full_print (fun () -> - (Constrextern.extern_constr env sigma (EConstr.of_constr body), - Constrextern.extern_type env sigma - (EConstr.of_constr (*FIXME*) c_body.Declarations.const_type) - ) - ) - () - in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b.CAst.v with - | Constrexpr.CFix(l_id,fixexprl) -> - let l = - List.map - (fun (id,recexp,bl,t,b) -> - let { CAst.loc; v=rec_id } = match Option.get recexp with - | { CAst.v = CStructRec id } -> id - | { CAst.v = CWfRec (id,_) } -> id - | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid - in - let new_args = - List.flatten - (List.map - (function - | Constrexpr.CLocalDef (na,_,_)-> [] - | Constrexpr.CLocalAssum (nal,_,_) -> - List.map - (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) - nal - | Constrexpr.CLocalPattern _ -> assert false - ) - nal_tas - ) - in - let b' = add_args id.CAst.v new_args b in - { Vernacexpr.fname=id; univs=None - ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) - ; binders = nal_tas@bl; rtype=t; body_def=Some b'; notations = []} - ) - fixexprl - in - l - | _ -> - let fname = CAst.make (Label.to_id (Constant.label c)) in - [{ Vernacexpr.fname; univs=None; rec_order = None; binders=nal_tas; rtype=t; body_def=Some b; notations=[]}] - in - let mp = Constant.modpath c in - let pstate = do_generate_principle_aux [c,Univ.Instance.empty] error_error false false expr_list in - assert (Option.is_empty pstate); - (* We register the infos *) - List.iter - (fun { Vernacexpr.fname= {CAst.v=id} } -> - add_Function false (Constant.make2 mp (Label.of_id id))) - expr_list) + match Global.body_of_constant_body Library.indirect_accessor c_body with + | None -> CErrors.user_err (Pp.str "Cannot build a graph over an axiom!") + | Some (body, _, _) -> + let env = Global.env () in + let extern_body, extern_type = + with_full_print + (fun () -> + ( Constrextern.extern_constr env sigma (EConstr.of_constr body) + , Constrextern.extern_type env sigma + (EConstr.of_constr (*FIXME*) c_body.Declarations.const_type) )) + () + in + let nal_tas, b, t = get_args extern_body extern_type in + let expr_list = + match b.CAst.v with + | Constrexpr.CFix (l_id, fixexprl) -> + let l = + List.map + (fun (id, recexp, bl, t, b) -> + let {CAst.loc; v = rec_id} = + match Option.get recexp with + | {CAst.v = CStructRec id} -> id + | {CAst.v = CWfRec (id, _)} -> id + | {CAst.v = CMeasureRec (oid, _, _)} -> Option.get oid + in + let new_args = + List.flatten + (List.map + (function + | Constrexpr.CLocalDef (na, _, _) -> [] + | Constrexpr.CLocalAssum (nal, _, _) -> + List.map + (fun {CAst.loc; v = n} -> + CAst.make ?loc + @@ CRef + ( Libnames.qualid_of_ident ?loc + @@ Nameops.Name.get_id n + , None )) + nal + | Constrexpr.CLocalPattern _ -> assert false) + nal_tas) + in + let b' = add_args id.CAst.v new_args b in + { Vernacexpr.fname = id + ; univs = None + ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) + ; binders = nal_tas @ bl + ; rtype = t + ; body_def = Some b' + ; notations = [] }) + fixexprl + in + l + | _ -> + let fname = CAst.make (Label.to_id (Constant.label c)) in + [ { Vernacexpr.fname + ; univs = None + ; rec_order = None + ; binders = nal_tas + ; rtype = t + ; body_def = Some b + ; notations = [] } ] + in + let mp = Constant.modpath c in + let pstate = + do_generate_principle_aux [(c, Univ.Instance.empty)] error_error false + false expr_list + in + assert (Option.is_empty pstate); + (* We register the infos *) + List.iter + (fun {Vernacexpr.fname = {CAst.v = id}} -> + add_Function false (Constant.make2 mp (Label.of_id id))) + expr_list (* *************** statically typed entrypoints ************************* *) let do_generate_principle_interactive fixl : Lemmas.t = - match - do_generate_principle_aux [] warning_error true true fixl - with + match do_generate_principle_aux [] warning_error true true fixl with | Some lemma -> lemma | None -> - CErrors.anomaly - (Pp.str"indfun: leaving no open proof in interactive mode") + CErrors.anomaly (Pp.str "indfun: leaving no open proof in interactive mode") let do_generate_principle fixl : unit = - match do_generate_principle_aux [] warning_error true false fixl with + match do_generate_principle_aux [] warning_error true false fixl with | Some _lemma -> CErrors.anomaly - (Pp.str"indfun: leaving a goal open in non-interactive mode") + (Pp.str "indfun: leaving a goal open in non-interactive mode") | None -> () - let build_scheme fas = - let evd = (ref (Evd.from_env (Global.env ()))) in - let pconstants = (List.map - (fun (_,f,sort) -> - let f_as_constant = - try - Smartlocate.global_with_alias f - with Not_found -> - CErrors.user_err ~hdr:"FunInd.build_scheme" - Pp.(str "Cannot find " ++ Libnames.pr_qualid f) - in - let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in - let _ = evd := evd' in - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in - evd := sigma; - let c, u = - try EConstr.destConst !evd f - with Constr.DestKO -> - CErrors.user_err Pp.(Printer.pr_econstr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") - in - (c, EConstr.EInstance.kind !evd u), sort - ) - fas - ) in + let evd = ref (Evd.from_env (Global.env ())) in + let pconstants = + List.map + (fun (_, f, sort) -> + let f_as_constant = + try Smartlocate.global_with_alias f + with Not_found -> + CErrors.user_err ~hdr:"FunInd.build_scheme" + Pp.(str "Cannot find " ++ Libnames.pr_qualid f) + in + let evd', f = Evd.fresh_global (Global.env ()) !evd f_as_constant in + let _ = evd := evd' in + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in + evd := sigma; + let c, u = + try EConstr.destConst !evd f + with Constr.DestKO -> + CErrors.user_err + Pp.( + Printer.pr_econstr_env (Global.env ()) !evd f + ++ spc () + ++ str "should be the named of a globally defined function") + in + ((c, EConstr.EInstance.kind !evd u), sort)) + fas + in let bodies_types = make_scheme evd pconstants in - List.iter2 - (fun (princ_id,_,_) def_entry -> - ignore - (Declare.declare_constant - ~name:princ_id - ~kind:Decls.(IsProof Theorem) - (Declare.DefinitionEntry def_entry)); - Declare.definition_message princ_id - ) - fas - bodies_types + (fun (princ_id, _, _) def_entry -> + ignore + (Declare.declare_constant ~name:princ_id + ~kind:Decls.(IsProof Theorem) + (Declare.DefinitionEntry def_entry)); + Declare.definition_message princ_id) + fas bodies_types let build_case_scheme fa = - let env = Global.env () - and sigma = (Evd.from_env (Global.env ())) in -(* let id_to_constr id = *) -(* Constrintern.global_reference id *) -(* in *) + let env = Global.env () and sigma = Evd.from_env (Global.env ()) in + (* let id_to_constr id = *) + (* Constrintern.global_reference id *) + (* in *) let funs = - let (_,f,_) = fa in - try (let open GlobRef in - match Smartlocate.global_with_alias f with - | ConstRef c -> c - | IndRef _ | ConstructRef _ | VarRef _ -> assert false) + let _, f, _ = fa in + try + let open GlobRef in + match Smartlocate.global_with_alias f with + | ConstRef c -> c + | IndRef _ | ConstructRef _ | VarRef _ -> assert false with Not_found -> CErrors.user_err ~hdr:"FunInd.build_case_scheme" - Pp.(str "Cannot find " ++ Libnames.pr_qualid f) in - let sigma, (_,u) = Evd.fresh_constant_instance env sigma funs in + Pp.(str "Cannot find " ++ Libnames.pr_qualid f) + in + let sigma, (_, u) = Evd.fresh_constant_instance env sigma funs in let first_fun = funs in let funs_mp = Constant.modpath first_fun in let first_fun_kn = @@ -2029,39 +2258,39 @@ let build_case_scheme fa = | Some finfos -> fst finfos.graph_ind in let this_block_funs_indexes = get_funs_constant funs_mp first_fun in - let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in + let this_block_funs = + Array.map (fun (c, _) -> (c, u)) this_block_funs_indexes + in let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.assoc_f Constant.equal funs this_block_funs_indexes in - let (ind, sf) = - let ind = first_fun_kn,funs_indexes in - (ind,Univ.Instance.empty)(*FIXME*),prop_sort + let ind, sf = + let ind = (first_fun_kn, funs_indexes) in + ((ind, Univ.Instance.empty) (*FIXME*), prop_sort) in - let (sigma, scheme) = - Indrec.build_case_analysis_scheme_default env sigma ind sf + let sigma, scheme = + Indrec.build_case_analysis_scheme_default env sigma ind sf in - let scheme_type = EConstr.Unsafe.to_constr ((Retyping.get_type_of env sigma) (EConstr.of_constr scheme)) in - let sorts = - (fun (_,_,x) -> - fst @@ UnivGen.fresh_sort_in_family x - ) - fa + let scheme_type = + EConstr.Unsafe.to_constr + ((Retyping.get_type_of env sigma) (EConstr.of_constr scheme)) in - let princ_name = (fun (x,_,_) -> x) fa in - let _ : unit = - (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ - pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs - ); - *) + let sorts = (fun (_, _, x) -> fst @@ UnivGen.fresh_sort_in_family x) fa in + let princ_name = (fun (x, _, _) -> x) fa in + let (_ : unit) = + (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ + pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs + ); + *) generate_functional_principle (ref (Evd.from_env (Global.env ()))) scheme_type - (Some ([|sorts|])) - (Some princ_name) - this_block_funs - 0 - (Functional_principles_proofs.prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|funs|]) + (Some [|sorts|]) + (Some princ_name) this_block_funs 0 + (Functional_principles_proofs.prove_princ_for_struct + (ref (Evd.from_env (Global.env ()))) + false 0 [|funs|]) in () diff --git a/plugins/funind/gen_principle.mli b/plugins/funind/gen_principle.mli index 6313a2b16e..3c04d6cb7d 100644 --- a/plugins/funind/gen_principle.mli +++ b/plugins/funind/gen_principle.mli @@ -11,13 +11,14 @@ val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit -val do_generate_principle_interactive : Vernacexpr.fixpoint_expr list -> Lemmas.t -val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit +val do_generate_principle_interactive : + Vernacexpr.fixpoint_expr list -> Lemmas.t +val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit val make_graph : Names.GlobRef.t -> unit (* Can be thrown by build_{,case}_scheme *) exception No_graph_found val build_scheme : (Names.Id.t * Libnames.qualid * Sorts.family) list -> unit -val build_case_scheme : (Names.Id.t * Libnames.qualid * Sorts.family) -> unit +val build_case_scheme : Names.Id.t * Libnames.qualid * Sorts.family -> unit diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index e08ad9af3a..11e4fa0ac7 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -10,34 +10,27 @@ open Indfun_common open CErrors open Util open Glob_termops - module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -let observe strm = - if do_observe () - then Feedback.msg_debug strm - else () +let observe strm = if do_observe () then Feedback.msg_debug strm else () + (*let observennl strm = if do_observe () then Pp.msg strm else ()*) - -type binder_type = - | Lambda of Name.t - | Prod of Name.t - | LetIn of Name.t - -type glob_context = (binder_type*glob_constr) list - +type binder_type = Lambda of Name.t | Prod of Name.t | LetIn of Name.t +type glob_context = (binder_type * glob_constr) list let rec solve_trivial_holes pat_as_term e = - match DAst.get pat_as_term, DAst.get e with - | GHole _,_ -> e - | GApp(fp,argsp),GApp(fe,argse) when glob_constr_eq fp fe -> - DAst.make (GApp((solve_trivial_holes fp fe),List.map2 solve_trivial_holes argsp argse)) - | _,_ -> pat_as_term + match (DAst.get pat_as_term, DAst.get e) with + | GHole _, _ -> e + | GApp (fp, argsp), GApp (fe, argse) when glob_constr_eq fp fe -> + DAst.make + (GApp + (solve_trivial_holes fp fe, List.map2 solve_trivial_holes argsp argse)) + | _, _ -> pat_as_term (* compose_glob_context [(bt_1,n_1,t_1);......] rt returns @@ -45,31 +38,26 @@ let rec solve_trivial_holes pat_as_term e = binders corresponding to the bt_i's *) let compose_glob_context = - let compose_binder (bt,t) acc = + let compose_binder (bt, t) acc = match bt with - | Lambda n -> mkGLambda(n,t,acc) - | Prod n -> mkGProd(n,t,acc) - | LetIn n -> mkGLetIn(n,t,None,acc) + | Lambda n -> mkGLambda (n, t, acc) + | Prod n -> mkGProd (n, t, acc) + | LetIn n -> mkGLetIn (n, t, None, acc) in List.fold_right compose_binder - (* The main part deals with building a list of globalized constructor expressions from the rhs of a fixpoint equation. *) type 'a build_entry_pre_return = - { - context : glob_context; (* the binding context of the result *) - value : 'a; (* The value *) - } + { context : glob_context + ; (* the binding context of the result *) + value : 'a (* The value *) } type 'a build_entry_return = - { - result : 'a build_entry_pre_return list; - to_avoid : Id.t list - } + {result : 'a build_entry_pre_return list; to_avoid : Id.t list} (* [combine_results combine_fun res1 res2] combine two results [res1] and [res2] @@ -81,64 +69,55 @@ type 'a build_entry_return = *) let combine_results - (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> - 'c build_entry_pre_return - ) - (res1: 'a build_entry_return) - (res2 : 'b build_entry_return) - : 'c build_entry_return - = - let pre_result = List.map - ( fun res1 -> (* for each result in arg_res *) - List.map (* we add it in each args_res *) - (fun res2 -> - combine_fun res1 res2 - ) - res2.result - ) + (combine_fun : + 'a build_entry_pre_return + -> 'b build_entry_pre_return + -> 'c build_entry_pre_return) (res1 : 'a build_entry_return) + (res2 : 'b build_entry_return) : 'c build_entry_return = + let pre_result = + List.map + (fun res1 -> + (* for each result in arg_res *) + List.map (* we add it in each args_res *) + (fun res2 -> combine_fun res1 res2) + res2.result) res1.result - in (* and then we flatten the map *) - { - result = List.concat pre_result; - to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid - } - + in + (* and then we flatten the map *) + { result = List.concat pre_result + ; to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid } (* The combination function for an argument with a list of argument *) let combine_args arg args = - { - context = arg.context@args.context; - (* Note that the binding context of [arg] MUST be placed before the one of + { context = arg.context @ args.context + ; (* Note that the binding context of [arg] MUST be placed before the one of [args] in order to preserve possible type dependencies *) - value = arg.value::args.value; - } + value = arg.value :: args.value } - -let ids_of_binder = function +let ids_of_binder = function | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> Id.Set.empty - | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> Id.Set.singleton id + | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> Id.Set.singleton id let rec change_vars_in_binder mapping = function - [] -> [] - | (bt,t)::l -> - let new_mapping = Id.Set.fold Id.Map.remove (ids_of_binder bt) mapping in - (bt,change_vars mapping t):: - (if Id.Map.is_empty new_mapping - then l - else change_vars_in_binder new_mapping l - ) + | [] -> [] + | (bt, t) :: l -> + let new_mapping = Id.Set.fold Id.Map.remove (ids_of_binder bt) mapping in + (bt, change_vars mapping t) + :: + ( if Id.Map.is_empty new_mapping then l + else change_vars_in_binder new_mapping l ) let rec replace_var_by_term_in_binder x_id term = function | [] -> [] - | (bt,t)::l -> - (bt,replace_var_by_term x_id term t):: - if Id.Set.mem x_id (ids_of_binder bt) - then l - else replace_var_by_term_in_binder x_id term l + | (bt, t) :: l -> + (bt, replace_var_by_term x_id term t) + :: + ( if Id.Set.mem x_id (ids_of_binder bt) then l + else replace_var_by_term_in_binder x_id term l ) let add_bt_names bt = Id.Set.union (ids_of_binder bt) @@ -146,128 +125,116 @@ let apply_args ctxt body args = let need_convert_id avoid id = List.exists (is_free_in id) args || Id.Set.mem id avoid in - let need_convert avoid bt = + let need_convert avoid bt = Id.Set.exists (need_convert_id avoid) (ids_of_binder bt) in - let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.Set.t) = + let next_name_away (na : Name.t) (mapping : Id.t Id.Map.t) (avoid : Id.Set.t) + = match na with - | Name id when Id.Set.mem id avoid -> - let new_id = Namegen.next_ident_away id avoid in - Name new_id,Id.Map.add id new_id mapping,Id.Set.add new_id avoid - | _ -> na,mapping,avoid + | Name id when Id.Set.mem id avoid -> + let new_id = Namegen.next_ident_away id avoid in + (Name new_id, Id.Map.add id new_id mapping, Id.Set.add new_id avoid) + | _ -> (na, mapping, avoid) in - let next_bt_away bt (avoid:Id.Set.t) = + let next_bt_away bt (avoid : Id.Set.t) = match bt with - | LetIn na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - LetIn new_na,mapping,new_avoid - | Prod na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - Prod new_na,mapping,new_avoid - | Lambda na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - Lambda new_na,mapping,new_avoid + | LetIn na -> + let new_na, mapping, new_avoid = next_name_away na Id.Map.empty avoid in + (LetIn new_na, mapping, new_avoid) + | Prod na -> + let new_na, mapping, new_avoid = next_name_away na Id.Map.empty avoid in + (Prod new_na, mapping, new_avoid) + | Lambda na -> + let new_na, mapping, new_avoid = next_name_away na Id.Map.empty avoid in + (Lambda new_na, mapping, new_avoid) in let rec do_apply avoid ctxt body args = - match ctxt,args with - | _,[] -> (* No more args *) - (ctxt,body) - | [],_ -> (* no more fun *) - let f,args' = glob_decompose_app body in - (ctxt,mkGApp(f,args'@args)) - | (Lambda Anonymous,t)::ctxt',arg::args' -> - do_apply avoid ctxt' body args' - | (Lambda (Name id),t)::ctxt',arg::args' -> - let new_avoid,new_ctxt',new_body,new_id = - if need_convert_id avoid id - then - let new_avoid = Id.Set.add id avoid in - let new_id = Namegen.next_ident_away id new_avoid in - let new_avoid' = Id.Set.add new_id new_avoid in - let mapping = Id.Map.add id new_id Id.Map.empty in - let new_ctxt' = change_vars_in_binder mapping ctxt' in - let new_body = change_vars mapping body in - new_avoid',new_ctxt',new_body,new_id - else - Id.Set.add id avoid,ctxt',body,id - in - let new_body = replace_var_by_term new_id arg new_body in - let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in - do_apply avoid new_ctxt' new_body args' - | (bt,t)::ctxt',_ -> - let new_avoid,new_ctxt',new_body,new_bt = - let new_avoid = add_bt_names bt avoid in - if need_convert avoid bt - then - let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in - ( - new_avoid, - change_vars_in_binder mapping ctxt', - change_vars mapping body, - new_bt - ) - else new_avoid,ctxt',body,bt - in - let new_ctxt',new_body = - do_apply new_avoid new_ctxt' new_body args - in - (new_bt,t)::new_ctxt',new_body + match (ctxt, args) with + | _, [] -> + (* No more args *) + (ctxt, body) + | [], _ -> + (* no more fun *) + let f, args' = glob_decompose_app body in + (ctxt, mkGApp (f, args' @ args)) + | (Lambda Anonymous, t) :: ctxt', arg :: args' -> + do_apply avoid ctxt' body args' + | (Lambda (Name id), t) :: ctxt', arg :: args' -> + let new_avoid, new_ctxt', new_body, new_id = + if need_convert_id avoid id then + let new_avoid = Id.Set.add id avoid in + let new_id = Namegen.next_ident_away id new_avoid in + let new_avoid' = Id.Set.add new_id new_avoid in + let mapping = Id.Map.add id new_id Id.Map.empty in + let new_ctxt' = change_vars_in_binder mapping ctxt' in + let new_body = change_vars mapping body in + (new_avoid', new_ctxt', new_body, new_id) + else (Id.Set.add id avoid, ctxt', body, id) + in + let new_body = replace_var_by_term new_id arg new_body in + let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in + do_apply avoid new_ctxt' new_body args' + | (bt, t) :: ctxt', _ -> + let new_avoid, new_ctxt', new_body, new_bt = + let new_avoid = add_bt_names bt avoid in + if need_convert avoid bt then + let new_bt, mapping, new_avoid = next_bt_away bt new_avoid in + ( new_avoid + , change_vars_in_binder mapping ctxt' + , change_vars mapping body + , new_bt ) + else (new_avoid, ctxt', body, bt) + in + let new_ctxt', new_body = do_apply new_avoid new_ctxt' new_body args in + ((new_bt, t) :: new_ctxt', new_body) in do_apply Id.Set.empty ctxt body args - let combine_app f args = - let new_ctxt,new_value = apply_args f.context f.value args.value in - { - (* Note that the binding context of [args] MUST be placed before the one of + let new_ctxt, new_value = apply_args f.context f.value args.value in + { (* Note that the binding context of [args] MUST be placed before the one of the applied value in order to preserve possible type dependencies *) - context = args.context@new_ctxt; - value = new_value; - } + context = args.context @ new_ctxt + ; value = new_value } let combine_lam n t b = - { - context = []; - value = mkGLambda(n, compose_glob_context t.context t.value, - compose_glob_context b.context b.value ) - } + { context = [] + ; value = + mkGLambda + ( n + , compose_glob_context t.context t.value + , compose_glob_context b.context b.value ) } let combine_prod2 n t b = - { - context = []; - value = mkGProd(n, compose_glob_context t.context t.value, - compose_glob_context b.context b.value ) - } + { context = [] + ; value = + mkGProd + ( n + , compose_glob_context t.context t.value + , compose_glob_context b.context b.value ) } let combine_prod n t b = - { context = t.context@((Prod n,t.value)::b.context); value = b.value} + {context = t.context @ ((Prod n, t.value) :: b.context); value = b.value} let combine_letin n t b = - { context = t.context@((LetIn n,t.value)::b.context); value = b.value} - + {context = t.context @ ((LetIn n, t.value) :: b.context); value = b.value} let mk_result ctxt value avoid = - { - result = - [{context = ctxt; - value = value}] - ; - to_avoid = avoid - } + {result = [{context = ctxt; value}]; to_avoid = avoid} + (************************************************* Some functions to deal with overlapping patterns **************************************************) -let coq_True_ref = lazy (Coqlib.lib_ref "core.True.type") +let coq_True_ref = lazy (Coqlib.lib_ref "core.True.type") let coq_False_ref = lazy (Coqlib.lib_ref "core.False.type") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with (the list of expressions on which we will do the matching) *) -let make_discr_match_el = - List.map (fun e -> (e,(Anonymous,None))) +let make_discr_match_el = List.map (fun e -> (e, (Anonymous, None))) (* [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. @@ -283,23 +250,21 @@ let make_discr_match_el = *) let make_discr_match_brl i = List.map_i - (fun j {CAst.v=(idl,patl,_)} -> CAst.make @@ - if Int.equal j i - then (idl,patl, mkGRef (Lazy.force coq_True_ref)) - else (idl,patl, mkGRef (Lazy.force coq_False_ref)) - ) + (fun j {CAst.v = idl, patl, _} -> + CAst.make + @@ + if Int.equal j i then (idl, patl, mkGRef (Lazy.force coq_True_ref)) + else (idl, patl, mkGRef (Lazy.force coq_False_ref))) 0 + (* [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff brl_{i} is the first branch matched by [el] Used when we want to simulate the coq pattern matching algorithm *) -let make_discr_match brl = - fun el i -> - mkGCases(None, - make_discr_match_el el, - make_discr_match_brl i brl) +let make_discr_match brl el i = + mkGCases (None, make_discr_match_el el, make_discr_match_brl i brl) (**********************************************************************) (* functions used to build case expression from lettuple and if ones *) @@ -307,140 +272,159 @@ let make_discr_match brl = (* [build_constructors_of_type] construct the array of pattern of its inductive argument*) let build_constructors_of_type ind' argl = - let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in + let mib, ind = Inductive.lookup_mind_specif (Global.env ()) ind' in let npar = mib.Declarations.mind_nparams in - Array.mapi (fun i _ -> - let construct = ind',i+1 in - let constructref = GlobRef.ConstructRef(construct) in - let _implicit_positions_of_cst = - Impargs.implicits_of_global constructref - in - let cst_narg = - Inductiveops.constructor_nallargs - (Global.env ()) - construct - in - let argl = - if List.is_empty argl then - List.make cst_narg (mkGHole ()) - else - List.make npar (mkGHole ()) @ argl - in - let pat_as_term = - mkGApp(mkGRef (GlobRef.ConstructRef(ind',i+1)),argl) - in - cases_pattern_of_glob_constr (Global.env()) Anonymous pat_as_term - ) + Array.mapi + (fun i _ -> + let construct = (ind', i + 1) in + let constructref = GlobRef.ConstructRef construct in + let _implicit_positions_of_cst = + Impargs.implicits_of_global constructref + in + let cst_narg = + Inductiveops.constructor_nallargs (Global.env ()) construct + in + let argl = + if List.is_empty argl then List.make cst_narg (mkGHole ()) + else List.make npar (mkGHole ()) @ argl + in + let pat_as_term = + mkGApp (mkGRef (GlobRef.ConstructRef (ind', i + 1)), argl) + in + cases_pattern_of_glob_constr (Global.env ()) Anonymous pat_as_term) ind.Declarations.mind_consnames (******************) (* Main functions *) (******************) - - -let raw_push_named (na,raw_value,raw_typ) env = +let raw_push_named (na, raw_value, raw_typ) env = match na with - | Anonymous -> env - | Name id -> - let typ,_ = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in - let na = make_annot id Sorts.Relevant in (* TODO relevance *) - (match raw_value with - | None -> - EConstr.push_named (NamedDecl.LocalAssum (na,typ)) env - | Some value -> - EConstr.push_named (NamedDecl.LocalDef (na, value, typ)) env) - + | Anonymous -> env + | Name id -> ( + let typ, _ = + Pretyping.understand env (Evd.from_env env) + ~expected_type:Pretyping.IsType raw_typ + in + let na = make_annot id Sorts.Relevant in + (* TODO relevance *) + match raw_value with + | None -> EConstr.push_named (NamedDecl.LocalAssum (na, typ)) env + | Some value -> EConstr.push_named (NamedDecl.LocalDef (na, value, typ)) env + ) let add_pat_variables sigma pat typ env : Environ.env = - let rec add_pat_variables env pat typ : Environ.env = - observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); - + let rec add_pat_variables env pat typ : Environ.env = + observe + (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); match DAst.get pat with - | PatVar na -> Environ.push_rel (RelDecl.LocalAssum (make_annot na Sorts.Relevant,typ)) env - | PatCstr(c,patl,na) -> - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) - with Not_found -> assert false - in - let constructors = Inductiveops.get_constructors env indf in - let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in - let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in - List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) + | PatVar na -> + Environ.push_rel + (RelDecl.LocalAssum (make_annot na Sorts.Relevant, typ)) + env + | PatCstr (c, patl, na) -> + let (Inductiveops.IndType (indf, indargs)) = + try + Inductiveops.find_rectype env (Evd.from_env env) + (EConstr.of_constr typ) + with Not_found -> assert false + in + let constructors = Inductiveops.get_constructors env indf in + let constructor : Inductiveops.constructor_summary = + List.find + (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) + (Array.to_list constructors) + in + let cs_args_types : types list = + List.map RelDecl.get_type constructor.Inductiveops.cs_args + in + List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in let res = - fst ( - Context.Rel.fold_outside - (fun decl (env,ctxt) -> + fst + (Context.Rel.fold_outside + (fun decl (env, ctxt) -> let open Context.Rel.Declaration in match decl with - | LocalAssum ({binder_name=Anonymous},_) | LocalDef ({binder_name=Anonymous},_,_) -> assert false - | LocalAssum ({binder_name=Name id} as na, t) -> - let na = {na with binder_name=id} in - let new_t = substl ctxt t in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () - ); + | LocalAssum ({binder_name = Anonymous}, _) + |LocalDef ({binder_name = Anonymous}, _, _) -> + assert false + | LocalAssum (({binder_name = Name id} as na), t) -> + let na = {na with binder_name = id} in + let new_t = substl ctxt t in + observe + ( str "for variable " ++ Ppconstr.pr_id id ++ fnl () + ++ str "old type := " + ++ Printer.pr_lconstr_env env sigma t + ++ fnl () ++ str "new type := " + ++ Printer.pr_lconstr_env env sigma new_t + ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (LocalAssum (na,new_t)) env,mkVar id::ctxt) - | LocalDef ({binder_name=Name id} as na, v, t) -> - let na = {na with binder_name=id} in - let new_t = substl ctxt t in + (Environ.push_named (LocalAssum (na, new_t)) env, mkVar id :: ctxt) + | LocalDef (({binder_name = Name id} as na), v, t) -> + let na = {na with binder_name = id} in + let new_t = substl ctxt t in let new_v = substl ctxt v in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () ++ - str "old value := " ++ Printer.pr_lconstr_env env sigma v ++ fnl () ++ - str "new value := " ++ Printer.pr_lconstr_env env sigma new_v ++ fnl () - ); + observe + ( str "for variable " ++ Ppconstr.pr_id id ++ fnl () + ++ str "old type := " + ++ Printer.pr_lconstr_env env sigma t + ++ fnl () ++ str "new type := " + ++ Printer.pr_lconstr_env env sigma new_t + ++ fnl () ++ str "old value := " + ++ Printer.pr_lconstr_env env sigma v + ++ fnl () ++ str "new value := " + ++ Printer.pr_lconstr_env env sigma new_v + ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (LocalDef (na,new_v,new_t)) env,mkVar id::ctxt) - ) - (Environ.rel_context new_env) - ~init:(env,[]) - ) + ( Environ.push_named (LocalDef (na, new_v, new_t)) env + , mkVar id :: ctxt )) + (Environ.rel_context new_env) + ~init:(env, [])) in - observe (str "new var env := " ++ Printer.pr_named_context_of res (Evd.from_env env)); + observe + (str "new var env := " ++ Printer.pr_named_context_of res (Evd.from_env env)); res - - - -let rec pattern_to_term_and_type env typ = DAst.with_val (function - | PatVar Anonymous -> assert false - | PatVar (Name id) -> - mkGVar id - | PatCstr(constr,patternl,_) -> - let cst_narg = - Inductiveops.constructor_nallargs - (Global.env ()) - constr - in - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) +let rec pattern_to_term_and_type env typ = + DAst.with_val (function + | PatVar Anonymous -> assert false + | PatVar (Name id) -> mkGVar id + | PatCstr (constr, patternl, _) -> + let cst_narg = Inductiveops.constructor_nallargs (Global.env ()) constr in + let (Inductiveops.IndType (indf, indargs)) = + try + Inductiveops.find_rectype env (Evd.from_env env) + (EConstr.of_constr typ) with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in - let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in - let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in - let _,cstl = Inductiveops.dest_ind_family indf in + let constructor = + List.find + (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) + (Array.to_list constructors) + in + let cs_args_types : types list = + List.map RelDecl.get_type constructor.Inductiveops.cs_args + in + let _, cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in let implicit_args = Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) (EConstr.of_constr csta.(i))) - ) + (fun i -> + Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) + (EConstr.of_constr csta.(i)))) in let patl_as_term = - List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl + List.map2 + (pattern_to_term_and_type env) + (List.rev cs_args_types) patternl in - mkGApp(mkGRef(GlobRef.ConstructRef constr), - implicit_args@patl_as_term - ) - ) + mkGApp (mkGRef (GlobRef.ConstructRef constr), implicit_args @ patl_as_term)) (* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the @@ -473,448 +457,427 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function but only the value of the function *) - -let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_return = +let rec build_entry_lc env sigma funnames avoid rt : + glob_constr build_entry_return = observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); let open CAst in match DAst.get rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> - (* do nothing (except changing type of course) *) - mk_result [] rt avoid - | GApp(_,_) -> - let f,args = glob_decompose_app rt in - let args_res : (glob_constr list) build_entry_return = - List.fold_right (* create the arguments lists of constructors and combine them *) - (fun arg ctxt_argsl -> - let arg_res = build_entry_lc env sigma funnames ctxt_argsl.to_avoid arg in - combine_results combine_args arg_res ctxt_argsl - ) - args - (mk_result [] [] avoid) - in - begin - match DAst.get f with - | GLambda _ -> - let rec aux t l = - match l with - | [] -> t - | u::l -> DAst.make @@ - match DAst.get t with - | GLambda(na,_,nat,b) -> - GLetIn(na,u,None,aux b l) - | _ -> - GApp(t,l) - in - build_entry_lc env sigma funnames avoid (aux f args) - | GVar id when Id.Set.mem id funnames -> - (* if we have [f t1 ... tn] with [f]$\in$[fnames] - then we create a fresh variable [res], - add [res] and its "value" (i.e. [res v1 ... vn]) to each - pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and - a pseudo value "v1 ... vn". - The "value" of this branch is then simply [res] - *) - (* XXX here and other [understand] calls drop the ctx *) - let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in - let rt_typ = Retyping.get_type_of env (Evd.from_env env) rt_as_constr in - let res_raw_type = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) rt_typ in - let res = fresh_id args_res.to_avoid "_res" in - let new_avoid = res::args_res.to_avoid in - let res_rt = mkGVar res in - let new_result = - List.map - (fun arg_res -> - let new_hyps = - [Prod (Name res),res_raw_type; - Prod Anonymous,mkGApp(res_rt,(mkGVar id)::arg_res.value)] - in - {context = arg_res.context@new_hyps; value = res_rt } - ) - args_res.result - in - { result = new_result; to_avoid = new_avoid } - | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> - (* if have [g t1 ... tn] with [g] not appearing in [funnames] - then - foreach [ctxt,v1 ... vn] in [args_res] we return - [ctxt, g v1 .... vn] - *) - { - args_res with - result = - List.map - (fun args_res -> - {args_res with value = mkGApp(f,args_res.value)}) - args_res.result - } - | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *) - | GLetIn(n,v,t,b) -> - (* if we have [(let x := v in b) t1 ... tn] , - we discard our work and compute the list of constructor for - [let x = v in (b t1 ... tn)] up to alpha conversion - *) - let new_n,new_b,new_avoid = - match n with - | Name id when List.exists (is_free_in id) args -> - (* need to alpha-convert the name *) - let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in - let new_avoid = id:: avoid in - let new_b = - replace_var_by_term - id - (DAst.make @@ GVar id) - b - in - (Name new_id,new_b,new_avoid) - | _ -> n,b,avoid - in - build_entry_lc - env - sigma - funnames - avoid - (mkGLetIn(new_n,v,t,mkGApp(new_b,args))) - | GCases _ | GIf _ | GLetTuple _ -> - (* we have [(match e1, ...., en with ..... end) t1 tn] - we first compute the result from the case and - then combine each of them with each of args one - *) - let f_res = build_entry_lc env sigma funnames args_res.to_avoid f in - combine_results combine_app f_res args_res - | GCast(b,_) -> - (* for an applied cast we just trash the cast part - and restart the work. - - WARNING: We need to restart since [b] itself should be an application term - *) - build_entry_lc env sigma funnames avoid (mkGApp(b,args)) - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GProd _ -> user_err Pp.(str "Cannot apply a type") - | GInt _ -> user_err Pp.(str "Cannot apply an integer") - | GFloat _ -> user_err Pp.(str "Cannot apply a float") - end (* end of the application treatement *) - - | GLambda(n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) - let t_res = build_entry_lc env sigma funnames avoid t in - let new_n = - match n with - | Name _ -> n - | Anonymous -> Name (Indfun_common.fresh_id [] "_x") - in - let new_env = raw_push_named (new_n,None,t) env in - let b_res = build_entry_lc new_env sigma funnames avoid b in - combine_results (combine_lam new_n) t_res b_res - | GProd(n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) - let t_res = build_entry_lc env sigma funnames avoid t in - let new_env = raw_push_named (n,None,t) env in - let b_res = build_entry_lc new_env sigma funnames avoid b in - if List.length t_res.result = 1 && List.length b_res.result = 1 - then combine_results (combine_prod2 n) t_res b_res - else combine_results (combine_prod n) t_res b_res - | GLetIn(n,v,typ,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the value [t] - and combine the two result - *) - let v = match typ with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in - let v_res = build_entry_lc env sigma funnames avoid v in - let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in - let v_type = Retyping.get_type_of env (Evd.from_env env) v_as_constr in - let v_r = Sorts.Relevant in (* TODO relevance *) - let new_env = - match n with - Anonymous -> env - | Name id -> EConstr.push_named (NamedDecl.LocalDef (make_annot id v_r,v_as_constr,v_type)) env - in - let b_res = build_entry_lc new_env sigma funnames avoid b in - combine_results (combine_letin n) v_res b_res - | GCases(_,_,el,brl) -> - (* we create the discrimination function - and treat the case itself - *) - let make_discr = make_discr_match brl in - build_entry_lc_from_case env sigma funnames make_discr el brl avoid - | GIf(b,(na,e_option),lhs,rhs) -> - let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) b_typ - with Not_found -> - user_err (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr_env env b ++ str " in " ++ - Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") - in - let case_pats = build_constructors_of_type (fst ind) [] in - assert (Int.equal (Array.length case_pats) 2); - let brl = - List.map_i - (fun i x -> CAst.make ([],[case_pats.(i)],x)) - 0 - [lhs;rhs] - in - let match_expr = - mkGCases(None,[(b,(Anonymous,None))],brl) - in - (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) - build_entry_lc env sigma funnames avoid match_expr - | GLetTuple(nal,_,b,e) -> - begin - let nal_as_glob_constr = - List.map - (function - Name id -> mkGVar id - | Anonymous -> mkGHole () - ) - nal - in - let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) b_typ - with Not_found -> - user_err (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr_env env b ++ str " in " ++ - Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ + |GFloat _ -> + (* do nothing (except changing type of course) *) + mk_result [] rt avoid + | GApp (_, _) -> ( + let f, args = glob_decompose_app rt in + let args_res : glob_constr list build_entry_return = + List.fold_right + (* create the arguments lists of constructors and combine them *) + (fun arg ctxt_argsl -> + let arg_res = + build_entry_lc env sigma funnames ctxt_argsl.to_avoid arg in - let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in - assert (Int.equal (Array.length case_pats) 1); - let br = CAst.make ([],[case_pats.(0)],e) in - let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in - build_entry_lc env sigma funnames avoid match_expr - - end + combine_results combine_args arg_res ctxt_argsl) + args (mk_result [] [] avoid) + in + match DAst.get f with + | GLambda _ -> + let rec aux t l = + match l with + | [] -> t + | u :: l -> ( + DAst.make + @@ + match DAst.get t with + | GLambda (na, _, nat, b) -> GLetIn (na, u, None, aux b l) + | _ -> GApp (t, l) ) + in + build_entry_lc env sigma funnames avoid (aux f args) + | GVar id when Id.Set.mem id funnames -> + (* if we have [f t1 ... tn] with [f]$\in$[fnames] + then we create a fresh variable [res], + add [res] and its "value" (i.e. [res v1 ... vn]) to each + pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and + a pseudo value "v1 ... vn". + The "value" of this branch is then simply [res] + *) + (* XXX here and other [understand] calls drop the ctx *) + let rt_as_constr, ctx = Pretyping.understand env (Evd.from_env env) rt in + let rt_typ = Retyping.get_type_of env (Evd.from_env env) rt_as_constr in + let res_raw_type = + Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) + rt_typ + in + let res = fresh_id args_res.to_avoid "_res" in + let new_avoid = res :: args_res.to_avoid in + let res_rt = mkGVar res in + let new_result = + List.map + (fun arg_res -> + let new_hyps = + [ (Prod (Name res), res_raw_type) + ; (Prod Anonymous, mkGApp (res_rt, mkGVar id :: arg_res.value)) ] + in + {context = arg_res.context @ new_hyps; value = res_rt}) + args_res.result + in + {result = new_result; to_avoid = new_avoid} + | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> + (* if have [g t1 ... tn] with [g] not appearing in [funnames] + then + foreach [ctxt,v1 ... vn] in [args_res] we return + [ctxt, g v1 .... vn] + *) + { args_res with + result = + List.map + (fun args_res -> {args_res with value = mkGApp (f, args_res.value)}) + args_res.result } + | GApp _ -> + assert false (* we have collected all the app in [glob_decompose_app] *) + | GLetIn (n, v, t, b) -> + (* if we have [(let x := v in b) t1 ... tn] , + we discard our work and compute the list of constructor for + [let x = v in (b t1 ... tn)] up to alpha conversion + *) + let new_n, new_b, new_avoid = + match n with + | Name id when List.exists (is_free_in id) args -> + (* need to alpha-convert the name *) + let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in + let new_avoid = id :: avoid in + let new_b = replace_var_by_term id (DAst.make @@ GVar id) b in + (Name new_id, new_b, new_avoid) + | _ -> (n, b, avoid) + in + build_entry_lc env sigma funnames avoid + (mkGLetIn (new_n, v, t, mkGApp (new_b, args))) + | GCases _ | GIf _ | GLetTuple _ -> + (* we have [(match e1, ...., en with ..... end) t1 tn] + we first compute the result from the case and + then combine each of them with each of args one + *) + let f_res = build_entry_lc env sigma funnames args_res.to_avoid f in + combine_results combine_app f_res args_res + | GCast (b, _) -> + (* for an applied cast we just trash the cast part + and restart the work. + + WARNING: We need to restart since [b] itself should be an application term + *) + build_entry_lc env sigma funnames avoid (mkGApp (b, args)) | GRec _ -> user_err Pp.(str "Not handled GRec") - | GCast(b,_) -> - build_entry_lc env sigma funnames avoid b -and build_entry_lc_from_case env sigma funname make_discr - (el:tomatch_tuples) - (brl:Glob_term.cases_clauses) avoid : - glob_constr build_entry_return = + | GProd _ -> user_err Pp.(str "Cannot apply a type") + | GInt _ -> user_err Pp.(str "Cannot apply an integer") + | GFloat _ -> user_err Pp.(str "Cannot apply a float") + (* end of the application treatement *) ) + | GLambda (n, _, t, b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) + let t_res = build_entry_lc env sigma funnames avoid t in + let new_n = + match n with + | Name _ -> n + | Anonymous -> Name (Indfun_common.fresh_id [] "_x") + in + let new_env = raw_push_named (new_n, None, t) env in + let b_res = build_entry_lc new_env sigma funnames avoid b in + combine_results (combine_lam new_n) t_res b_res + | GProd (n, _, t, b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) + let t_res = build_entry_lc env sigma funnames avoid t in + let new_env = raw_push_named (n, None, t) env in + let b_res = build_entry_lc new_env sigma funnames avoid b in + if List.length t_res.result = 1 && List.length b_res.result = 1 then + combine_results (combine_prod2 n) t_res b_res + else combine_results (combine_prod n) t_res b_res + | GLetIn (n, v, typ, b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the value [t] + and combine the two result + *) + let v = + match typ with + | None -> v + | Some t -> DAst.make ?loc:rt.loc @@ GCast (v, CastConv t) + in + let v_res = build_entry_lc env sigma funnames avoid v in + let v_as_constr, ctx = Pretyping.understand env (Evd.from_env env) v in + let v_type = Retyping.get_type_of env (Evd.from_env env) v_as_constr in + let v_r = Sorts.Relevant in + (* TODO relevance *) + let new_env = + match n with + | Anonymous -> env + | Name id -> + EConstr.push_named + (NamedDecl.LocalDef (make_annot id v_r, v_as_constr, v_type)) + env + in + let b_res = build_entry_lc new_env sigma funnames avoid b in + combine_results (combine_letin n) v_res b_res + | GCases (_, _, el, brl) -> + (* we create the discrimination function + and treat the case itself + *) + let make_discr = make_discr_match brl in + build_entry_lc_from_case env sigma funnames make_discr el brl avoid + | GIf (b, (na, e_option), lhs, rhs) -> + let b_as_constr, ctx = Pretyping.understand env (Evd.from_env env) b in + let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in + let ind, _ = + try Inductiveops.find_inductive env (Evd.from_env env) b_typ + with Not_found -> + user_err + ( str "Cannot find the inductive associated to " + ++ Printer.pr_glob_constr_env env b + ++ str " in " + ++ Printer.pr_glob_constr_env env rt + ++ str ". try again with a cast" ) + in + let case_pats = build_constructors_of_type (fst ind) [] in + assert (Int.equal (Array.length case_pats) 2); + let brl = + List.map_i (fun i x -> CAst.make ([], [case_pats.(i)], x)) 0 [lhs; rhs] + in + let match_expr = mkGCases (None, [(b, (Anonymous, None))], brl) in + (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) + build_entry_lc env sigma funnames avoid match_expr + | GLetTuple (nal, _, b, e) -> + let nal_as_glob_constr = + List.map (function Name id -> mkGVar id | Anonymous -> mkGHole ()) nal + in + let b_as_constr, ctx = Pretyping.understand env (Evd.from_env env) b in + let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in + let ind, _ = + try Inductiveops.find_inductive env (Evd.from_env env) b_typ + with Not_found -> + user_err + ( str "Cannot find the inductive associated to " + ++ Printer.pr_glob_constr_env env b + ++ str " in " + ++ Printer.pr_glob_constr_env env rt + ++ str ". try again with a cast" ) + in + let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in + assert (Int.equal (Array.length case_pats) 1); + let br = CAst.make ([], [case_pats.(0)], e) in + let match_expr = mkGCases (None, [(b, (Anonymous, None))], [br]) in + build_entry_lc env sigma funnames avoid match_expr + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GCast (b, _) -> build_entry_lc env sigma funnames avoid b + +and build_entry_lc_from_case env sigma funname make_discr (el : tomatch_tuples) + (brl : Glob_term.cases_clauses) avoid : glob_constr build_entry_return = match el with - | [] -> assert false (* this case correspond to match <nothing> with .... !*) - | el -> - (* this case correspond to - match el with brl end - we first compute the list of lists corresponding to [el] and - combine them . - Then for each element of the combinations, - we compute the result we compute one list per branch in [brl] and - finally we just concatenate those list - *) - let case_resl = - List.fold_right - (fun (case_arg,_) ctxt_argsl -> - let arg_res = build_entry_lc env sigma funname ctxt_argsl.to_avoid case_arg in - combine_results combine_args arg_res ctxt_argsl - ) - el - (mk_result [] [] avoid) - in - let types = - List.map (fun (case_arg,_) -> - let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in - EConstr.Unsafe.to_constr (Retyping.get_type_of env (Evd.from_env env) case_arg_as_constr) - ) el - in - (****** The next works only if the match is not dependent ****) - let results = - List.map - (fun ca -> - let res = build_entry_lc_from_case_term - env sigma types - funname (make_discr) - [] brl - case_resl.to_avoid - ca - in - res - ) - case_resl.result - in - { - result = List.concat (List.map (fun r -> r.result) results); - to_avoid = - List.fold_left (fun acc r -> List.union Id.equal acc r.to_avoid) - [] results - } - -and build_entry_lc_from_case_term env sigma types funname make_discr patterns_to_prevent brl avoid - matched_expr = + | [] -> assert false (* this case correspond to match <nothing> with .... !*) + | el -> + (* this case correspond to + match el with brl end + we first compute the list of lists corresponding to [el] and + combine them . + Then for each element of the combinations, + we compute the result we compute one list per branch in [brl] and + finally we just concatenate those list + *) + let case_resl = + List.fold_right + (fun (case_arg, _) ctxt_argsl -> + let arg_res = + build_entry_lc env sigma funname ctxt_argsl.to_avoid case_arg + in + combine_results combine_args arg_res ctxt_argsl) + el (mk_result [] [] avoid) + in + let types = + List.map + (fun (case_arg, _) -> + let case_arg_as_constr, ctx = + Pretyping.understand env (Evd.from_env env) case_arg + in + EConstr.Unsafe.to_constr + (Retyping.get_type_of env (Evd.from_env env) case_arg_as_constr)) + el + in + (****** The next works only if the match is not dependent ****) + let results = + List.map + (fun ca -> + let res = + build_entry_lc_from_case_term env sigma types funname make_discr [] + brl case_resl.to_avoid ca + in + res) + case_resl.result + in + { result = List.concat (List.map (fun r -> r.result) results) + ; to_avoid = + List.fold_left + (fun acc r -> List.union Id.equal acc r.to_avoid) + [] results } + +and build_entry_lc_from_case_term env sigma types funname make_discr + patterns_to_prevent brl avoid matched_expr = match brl with - | [] -> (* computed_branches *) {result = [];to_avoid = avoid} - | br::brl' -> - (* alpha conversion to prevent name clashes *) - let {CAst.v=(idl,patl,return)} = alpha_br avoid br in - let new_avoid = idl@avoid in (* for now we can no more use idl as an identifier *) - (* building a list of precondition stating that we are not in this branch - (will be used in the following recursive calls) - *) - let new_env = List.fold_right2 (add_pat_variables sigma) patl types env in - let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = - List.map2 - (fun pat typ -> - fun avoid pat'_as_term -> - let renamed_pat,_,_ = alpha_pat avoid pat in - let pat_ids = get_pattern_id renamed_pat in - let env_with_pat_ids = add_pat_variables sigma pat typ new_env in - List.fold_right - (fun id acc -> - let typ_of_id = Typing.type_of_variable env_with_pat_ids id in - let raw_typ_of_id = - Detyping.detype Detyping.Now false Id.Set.empty - env_with_pat_ids (Evd.from_env env) typ_of_id - in - mkGProd (Name id,raw_typ_of_id,acc)) - pat_ids - (glob_make_neq pat'_as_term (pattern_to_term renamed_pat)) - ) - patl - types - in - (* Checking if we can be in this branch - (will be used in the following recursive calls) - *) - let unify_with_those_patterns : (cases_pattern -> bool*bool) list = - List.map - (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') - patl - in - (* + | [] -> (* computed_branches *) {result = []; to_avoid = avoid} + | br :: brl' -> + (* alpha conversion to prevent name clashes *) + let {CAst.v = idl, patl, return} = alpha_br avoid br in + let new_avoid = idl @ avoid in + (* for now we can no more use idl as an identifier *) + (* building a list of precondition stating that we are not in this branch + (will be used in the following recursive calls) + *) + let new_env = List.fold_right2 (add_pat_variables sigma) patl types env in + let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = + List.map2 + (fun pat typ avoid pat'_as_term -> + let renamed_pat, _, _ = alpha_pat avoid pat in + let pat_ids = get_pattern_id renamed_pat in + let env_with_pat_ids = add_pat_variables sigma pat typ new_env in + List.fold_right + (fun id acc -> + let typ_of_id = Typing.type_of_variable env_with_pat_ids id in + let raw_typ_of_id = + Detyping.detype Detyping.Now false Id.Set.empty env_with_pat_ids + (Evd.from_env env) typ_of_id + in + mkGProd (Name id, raw_typ_of_id, acc)) + pat_ids + (glob_make_neq pat'_as_term (pattern_to_term renamed_pat))) + patl types + in + (* Checking if we can be in this branch + (will be used in the following recursive calls) + *) + let unify_with_those_patterns : (cases_pattern -> bool * bool) list = + List.map + (fun pat pat' -> (are_unifiable pat pat', eq_cases_pattern pat pat')) + patl + in + (* we first compute the other branch result (in ordrer to keep the order of the matching as much as possible) *) - let brl'_res = - build_entry_lc_from_case_term - env - sigma - types - funname - make_discr - ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) - brl' - avoid - matched_expr - in - (* We now create the precondition of this branch i.e. - 1- the list of variable appearing in the different patterns of this branch and - the list of equation stating than el = patl (List.flatten ...) - 2- If there exists a previous branch which pattern unify with the one of this branch - then a discrimination precond stating that we are not in a previous branch (if List.exists ...) - *) - let those_pattern_preconds = - (List.flatten - ( - List.map3 - (fun pat e typ_as_constr -> - let this_pat_ids = ids_of_pat pat in - let typ_as_constr = EConstr.of_constr typ_as_constr in - let typ = Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_as_constr in - let pat_as_term = pattern_to_term pat in - (* removing trivial holes *) - let pat_as_term = solve_trivial_holes pat_as_term e in - (* observe (str "those_pattern_preconds" ++ spc () ++ *) - (* str "pat" ++ spc () ++ pr_glob_constr pat_as_term ++ spc ()++ *) - (* str "e" ++ spc () ++ pr_glob_constr e ++spc ()++ *) - (* str "typ_as_constr" ++ spc () ++ pr_lconstr typ_as_constr); *) - List.fold_right - (fun id acc -> - if Id.Set.mem id this_pat_ids - then (Prod (Name id), - let typ_of_id = Typing.type_of_variable new_env id in - let raw_typ_of_id = - Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_of_id - in - raw_typ_of_id - )::acc - else acc - ) - idl - [(Prod Anonymous,glob_make_eq ~typ pat_as_term e)] - ) - patl - matched_expr.value - types - ) - ) - @ - (if List.exists (function (unifl,_) -> - let (unif,_) = - List.split (List.map2 (fun x y -> x y) unifl patl) - in - List.for_all (fun x -> x) unif) patterns_to_prevent - then - let i = List.length patterns_to_prevent in - let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in - [(Prod Anonymous,make_discr pats_as_constr i )] - else - [] - ) - in - (* We compute the result of the value returned by the branch*) - let return_res = build_entry_lc new_env sigma funname new_avoid return in - (* and combine it with the preconds computed for this branch *) - let this_branch_res = - List.map - (fun res -> - { context = matched_expr.context@those_pattern_preconds@res.context ; - value = res.value} - ) - return_res.result + let brl'_res = + build_entry_lc_from_case_term env sigma types funname make_discr + ((unify_with_those_patterns, not_those_patterns) :: patterns_to_prevent) + brl' avoid matched_expr + in + (* We now create the precondition of this branch i.e. + 1- the list of variable appearing in the different patterns of this branch and + the list of equation stating than el = patl (List.flatten ...) + 2- If there exists a previous branch which pattern unify with the one of this branch + then a discrimination precond stating that we are not in a previous branch (if List.exists ...) + *) + let those_pattern_preconds = + List.flatten + (List.map3 + (fun pat e typ_as_constr -> + let this_pat_ids = ids_of_pat pat in + let typ_as_constr = EConstr.of_constr typ_as_constr in + let typ = + Detyping.detype Detyping.Now false Id.Set.empty new_env + (Evd.from_env env) typ_as_constr + in + let pat_as_term = pattern_to_term pat in + (* removing trivial holes *) + let pat_as_term = solve_trivial_holes pat_as_term e in + (* observe (str "those_pattern_preconds" ++ spc () ++ *) + (* str "pat" ++ spc () ++ pr_glob_constr pat_as_term ++ spc ()++ *) + (* str "e" ++ spc () ++ pr_glob_constr e ++spc ()++ *) + (* str "typ_as_constr" ++ spc () ++ pr_lconstr typ_as_constr); *) + List.fold_right + (fun id acc -> + if Id.Set.mem id this_pat_ids then + ( Prod (Name id) + , let typ_of_id = Typing.type_of_variable new_env id in + let raw_typ_of_id = + Detyping.detype Detyping.Now false Id.Set.empty new_env + (Evd.from_env env) typ_of_id + in + raw_typ_of_id ) + :: acc + else acc) + idl + [(Prod Anonymous, glob_make_eq ~typ pat_as_term e)]) + patl matched_expr.value types) + @ + if + List.exists + (function + | unifl, _ -> + let unif, _ = + List.split (List.map2 (fun x y -> x y) unifl patl) + in + List.for_all (fun x -> x) unif) + patterns_to_prevent + then + let i = List.length patterns_to_prevent in + let pats_as_constr = + List.map2 (pattern_to_term_and_type new_env) types patl in - { brl'_res with result = this_branch_res@brl'_res.result } - + [(Prod Anonymous, make_discr pats_as_constr i)] + else [] + in + (* We compute the result of the value returned by the branch*) + let return_res = build_entry_lc new_env sigma funname new_avoid return in + (* and combine it with the preconds computed for this branch *) + let this_branch_res = + List.map + (fun res -> + { context = matched_expr.context @ those_pattern_preconds @ res.context + ; value = res.value }) + return_res.result + in + {brl'_res with result = this_branch_res @ brl'_res.result} -let is_res r = match DAst.get r with -| GVar id -> - begin try - String.equal (String.sub (Id.to_string id) 0 4) "_res" - with Invalid_argument _ -> false end -| _ -> false +let is_res r = + match DAst.get r with + | GVar id -> ( + try String.equal (String.sub (Id.to_string id) 0 4) "_res" + with Invalid_argument _ -> false ) + | _ -> false -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> GlobRef.equal r gr -| _ -> false +let is_gr c gr = + match DAst.get c with GRef (r, _) -> GlobRef.equal r gr | _ -> false -let is_gvar c = match DAst.get c with -| GVar id -> true -| _ -> false +let is_gvar c = match DAst.get c with GVar id -> true | _ -> false let same_raw_term rt1 rt2 = - match DAst.get rt1, DAst.get rt2 with - | GRef(r1,_), GRef (r2,_) -> GlobRef.equal r1 r2 - | GHole _, GHole _ -> true - | _ -> false + match (DAst.get rt1, DAst.get rt2) with + | GRef (r1, _), GRef (r2, _) -> GlobRef.equal r1 r2 + | GHole _, GHole _ -> true + | _ -> false + let decompose_raw_eq env lhs rhs = let rec decompose_raw_eq lhs rhs acc = - observe (str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " ++ pr_glob_constr_env env rhs); - let (rhd,lrhs) = glob_decompose_app rhs in - let (lhd,llhs) = glob_decompose_app lhs in + observe + ( str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " + ++ pr_glob_constr_env env rhs ); + let rhd, lrhs = glob_decompose_app rhs in + let lhd, llhs = glob_decompose_app lhs in observe (str "lhd := " ++ pr_glob_constr_env env lhd); observe (str "rhd := " ++ pr_glob_constr_env env rhd); observe (str "llhs := " ++ int (List.length llhs)); observe (str "lrhs := " ++ int (List.length lrhs)); let sllhs = List.length llhs in let slrhs = List.length lrhs in - if same_raw_term lhd rhd && Int.equal sllhs slrhs - then + if same_raw_term lhd rhd && Int.equal sllhs slrhs then (* let _ = assert false in *) - List.fold_right2 decompose_raw_eq llhs lrhs acc - else (lhs,rhs)::acc + List.fold_right2 decompose_raw_eq llhs lrhs acc + else (lhs, rhs) :: acc in decompose_raw_eq lhs rhs [] exception Continue + (* The second phase which reconstruct the real type of the constructor. rebuild the globalized constructors expression. @@ -925,304 +888,283 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let open Context.Rel.Declaration in let open CAst in match DAst.get rt with - | GProd(n,k,t,b) -> - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t::crossed_types in - begin - match DAst.get t with - | GApp(res_rt ,args') when is_res res_rt -> - begin - let arg = List.hd args' in - match DAst.get arg with - | GVar this_relname -> - (*i The next call to mk_rel_id is - valid since we are constructing the graph - Ensures by: obvious - i*) - - let new_t = - mkGApp(mkGVar(mk_rel_id this_relname),List.tl args'@[res_rt]) - in - let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - mkGProd(n,new_t,new_b), - Id.Set.filter not_free_in_t id_to_exclude - | _ -> (* the first args is the name of the function! *) - assert false - end - | GApp(eq_as_ref,[ty; id ;rt]) - when is_gvar id && is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous - -> - let loc1 = rt.CAst.loc in - let loc2 = eq_as_ref.CAst.loc in - let loc3 = id.CAst.loc in - let id = match DAst.get id with GVar id -> id | _ -> assert false in - begin - try - observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt); - let t' = - try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) - with e when CErrors.noncritical e -> raise Continue - in - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = List.map (replace_var_by_term id rt) args in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons - new_env - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkGProd(n,t,new_b),id_to_exclude - with Continue -> - let jmeq = GlobRef.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in - let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in - let ind,args' = Inductiveops.find_inductive env Evd.(from_env env) ty' in - let mib,_ = Global.lookup_inductive (fst ind) in - let nparam = mib.Declarations.mind_nparams in - let params,arg' = - ((Util.List.chop nparam args')) - in - let rt_typ = DAst.make @@ - GApp(DAst.make @@ GRef (GlobRef.IndRef (fst ind),None), - (List.map - (fun p -> Detyping.detype Detyping.Now false Id.Set.empty - env (Evd.from_env env) - (EConstr.of_constr p)) params)@(Array.to_list - (Array.make - (List.length args' - nparam) - (mkGHole ())))) - in - let eq' = - DAst.make ?loc:loc1 @@ GApp(DAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;DAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) - in - observe (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq'); - let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in - observe (str " computing new type for jmeq : done") ; - let sigma = Evd.(from_env env) in - let new_args = - match EConstr.kind sigma eq'_as_constr with - | App(_,[|_;_;ty;_|]) -> - let ty = Array.to_list (snd (EConstr.destApp sigma ty)) in - let ty' = snd (Util.List.chop nparam ty) in - List.fold_left2 - (fun acc var_as_constr arg -> - if isRel var_as_constr - then - let na = RelDecl.get_name (Environ.lookup_rel (destRel var_as_constr) env) in - match na with - | Anonymous -> acc - | Name id' -> - (id',Detyping.detype Detyping.Now false Id.Set.empty - env - (Evd.from_env env) - arg)::acc - else if isVar var_as_constr - then (destVar var_as_constr,Detyping.detype Detyping.Now false Id.Set.empty - env - (Evd.from_env env) - arg)::acc - else acc - ) - [] - arg' - ty' - | _ -> assert false - in - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = - List.fold_left - (fun args (id,rt) -> - List.map (replace_var_by_term id rt) args - ) - args - ((id,rt)::new_args) - in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in - let new_env = - let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in - let r = Sorts.Relevant in (* TODO relevance *) - EConstr.push_rel (LocalAssum (make_annot n r,t')) env - in - let new_b,id_to_exclude = - rebuild_cons - new_env - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkGProd(n,eq',new_b),id_to_exclude - end - (* J.F:. keep this comment it explain how to remove some meaningless equalities - if keep_eq then - mkGProd(n,t,new_b),id_to_exclude - else new_b, Id.Set.add id id_to_exclude - *) - | GApp(eq_as_ref,[ty;rt1;rt2]) - when is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous - -> - begin - try - let l = decompose_raw_eq env rt1 rt2 in - if List.length l > 1 - then - let new_rt = - List.fold_left - (fun acc (lhs,rhs) -> - mkGProd(Anonymous, - mkGApp(mkGRef Coqlib.(lib_ref "core.eq.type"),[mkGHole ();lhs;rhs]),acc) - ) - b - l - in - rebuild_cons env nb_args relname args crossed_types depth new_rt - else raise Continue - with Continue -> - observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id - (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - end - | _ -> - observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id - (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - end - | GLambda(n,k,t,b) -> - begin - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t :: crossed_types in - observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - match n with - | Name id -> - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - (args@[mkGVar id])new_crossed_types - (depth + 1 ) b - in - if Id.Set.mem id id_to_exclude && depth >= nb_args - then - new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - else - DAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - | _ -> anomaly (Pp.str "Should not have an anonymous function here.") - (* We have renamed all the anonymous functions during alpha_renaming phase *) - - end - | GLetIn(n,v,t,b) -> - begin - let t = match t with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in - let not_free_in_t id = not (is_free_in id t) in - let evd = (Evd.from_env env) in - let t',ctx = Pretyping.understand env evd t in - let evd = Evd.from_ctx ctx in - let type_t' = Retyping.get_type_of env evd t' in - let t' = EConstr.Unsafe.to_constr t' in - let type_t' = EConstr.Unsafe.to_constr type_t' in - let new_env = Environ.push_rel (LocalDef (make_annot n Sorts.Relevant,t',type_t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args (t::crossed_types) - (depth + 1 ) b in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> DAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *) - Id.Set.filter not_free_in_t id_to_exclude - end - | GLetTuple(nal,(na,rto),t,b) -> - assert (Option.is_empty rto); - begin - let not_free_in_t id = not (is_free_in id t) in - let new_t,id_to_exclude' = - rebuild_cons env - nb_args - relname - args (crossed_types) - depth t - in - let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot na r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args (t::crossed_types) - (depth + 1) b + | GProd (n, k, t, b) -> ( + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t :: crossed_types in + match DAst.get t with + | GApp (res_rt, args') when is_res res_rt -> ( + let arg = List.hd args' in + match DAst.get arg with + | GVar this_relname -> + (*i The next call to mk_rel_id is + valid since we are constructing the graph + Ensures by: obvious + i*) + let new_t = + mkGApp (mkGVar (mk_rel_id this_relname), List.tl args' @ [res_rt]) + in + let t', ctx = Pretyping.understand env (Evd.from_env env) new_t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args new_crossed_types + (depth + 1) b + in + (mkGProd (n, new_t, new_b), Id.Set.filter not_free_in_t id_to_exclude) + | _ -> + (* the first args is the name of the function! *) + assert false ) + | GApp (eq_as_ref, [ty; id; rt]) + when is_gvar id + && is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") + && n == Anonymous -> ( + let loc1 = rt.CAst.loc in + let loc2 = eq_as_ref.CAst.loc in + let loc3 = id.CAst.loc in + let id = match DAst.get id with GVar id -> id | _ -> assert false in + try + observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt); + let t' = + try fst (Pretyping.understand env (Evd.from_env env) t) (*FIXME*) + with e when CErrors.noncritical e -> raise Continue + in + let is_in_b = is_free_in id b in + let _keep_eq = + (not (List.exists (is_free_in id) args)) + || is_in_b + || List.exists (is_free_in id) crossed_types + in + let new_args = List.map (replace_var_by_term id rt) args in + let subst_b = if is_in_b then b else replace_var_by_term id rt b in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname new_args new_crossed_types + (depth + 1) subst_b + in + (mkGProd (n, t, new_b), id_to_exclude) + with Continue -> + let jmeq = GlobRef.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in + let ty', ctx = Pretyping.understand env (Evd.from_env env) ty in + let ind, args' = + Inductiveops.find_inductive env Evd.(from_env env) ty' + in + let mib, _ = Global.lookup_inductive (fst ind) in + let nparam = mib.Declarations.mind_nparams in + let params, arg' = Util.List.chop nparam args' in + let rt_typ = + DAst.make + @@ GApp + ( DAst.make @@ GRef (GlobRef.IndRef (fst ind), None) + , List.map + (fun p -> + Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) (EConstr.of_constr p)) + params + @ Array.to_list + (Array.make (List.length args' - nparam) (mkGHole ())) ) + in + let eq' = + DAst.make ?loc:loc1 + @@ GApp + ( DAst.make ?loc:loc2 @@ GRef (jmeq, None) + , [ty; DAst.make ?loc:loc3 @@ GVar id; rt_typ; rt] ) + in + observe + (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq'); + let eq'_as_constr, ctx = + Pretyping.understand env (Evd.from_env env) eq' + in + observe (str " computing new type for jmeq : done"); + let sigma = Evd.(from_env env) in + let new_args = + match EConstr.kind sigma eq'_as_constr with + | App (_, [|_; _; ty; _|]) -> + let ty = Array.to_list (snd (EConstr.destApp sigma ty)) in + let ty' = snd (Util.List.chop nparam ty) in + List.fold_left2 + (fun acc var_as_constr arg -> + if isRel var_as_constr then + let na = + RelDecl.get_name + (Environ.lookup_rel (destRel var_as_constr) env) + in + match na with + | Anonymous -> acc + | Name id' -> + ( id' + , Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) arg ) + :: acc + else if isVar var_as_constr then + ( destVar var_as_constr + , Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) arg ) + :: acc + else acc) + [] arg' ty' + | _ -> assert false + in + let is_in_b = is_free_in id b in + let _keep_eq = + (not (List.exists (is_free_in id) args)) + || is_in_b + || List.exists (is_free_in id) crossed_types + in + let new_args = + List.fold_left + (fun args (id, rt) -> List.map (replace_var_by_term id rt) args) + args ((id, rt) :: new_args) + in + let subst_b = if is_in_b then b else replace_var_by_term id rt b in + let new_env = + let t', ctx = Pretyping.understand env (Evd.from_env env) eq' in + let r = Sorts.Relevant in + (* TODO relevance *) + EConstr.push_rel (LocalAssum (make_annot n r, t')) env + in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname new_args new_crossed_types + (depth + 1) subst_b + in + (mkGProd (n, eq', new_b), id_to_exclude) + (* J.F:. keep this comment it explain how to remove some meaningless equalities + if keep_eq then + mkGProd(n,t,new_b),id_to_exclude + else new_b, Id.Set.add id id_to_exclude + *) ) + | GApp (eq_as_ref, [ty; rt1; rt2]) + when is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous + -> ( + try + let l = decompose_raw_eq env rt1 rt2 in + if List.length l > 1 then + let new_rt = + List.fold_left + (fun acc (lhs, rhs) -> + mkGProd + ( Anonymous + , mkGApp + ( mkGRef Coqlib.(lib_ref "core.eq.type") + , [mkGHole (); lhs; rhs] ) + , acc )) + b l in -(* match n with *) -(* | Name id when Id.Set.mem id id_to_exclude -> *) -(* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) -(* | _ -> *) - DAst.make @@ GLetTuple(nal,(na,None),t,new_b), - Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') - - end - - | _ -> mkGApp(mkGVar relname,args@[rt]),Id.Set.empty - + rebuild_cons env nb_args relname args crossed_types depth new_rt + else raise Continue + with Continue -> ( + observe + (str "computing new type for prod : " ++ pr_glob_constr_env env rt); + let t', ctx = Pretyping.understand env (Evd.from_env env) t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args new_crossed_types + (depth + 1) b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + | _ -> (mkGProd (n, t, new_b), Id.Set.filter not_free_in_t id_to_exclude) ) + ) + | _ -> ( + observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); + let t', ctx = Pretyping.understand env (Evd.from_env env) t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) + b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + | _ -> (mkGProd (n, t, new_b), Id.Set.filter not_free_in_t id_to_exclude) + ) ) + | GLambda (n, k, t, b) -> ( + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t :: crossed_types in + observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt); + let t', ctx = Pretyping.understand env (Evd.from_env env) t in + match n with + | Name id -> + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname + (args @ [mkGVar id]) + new_crossed_types (depth + 1) b + in + if Id.Set.mem id id_to_exclude && depth >= nb_args then + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + else + ( DAst.make @@ GProd (n, k, t, new_b) + , Id.Set.filter not_free_in_t id_to_exclude ) + | _ -> anomaly (Pp.str "Should not have an anonymous function here.") + (* We have renamed all the anonymous functions during alpha_renaming phase *) + ) + | GLetIn (n, v, t, b) -> ( + let t = + match t with + | None -> v + | Some t -> DAst.make ?loc:rt.loc @@ GCast (v, CastConv t) + in + let not_free_in_t id = not (is_free_in id t) in + let evd = Evd.from_env env in + let t', ctx = Pretyping.understand env evd t in + let evd = Evd.from_ctx ctx in + let type_t' = Retyping.get_type_of env evd t' in + let t' = EConstr.Unsafe.to_constr t' in + let type_t' = EConstr.Unsafe.to_constr type_t' in + let new_env = + Environ.push_rel (LocalDef (make_annot n Sorts.Relevant, t', type_t')) env + in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args (t :: crossed_types) (depth + 1) + b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + | _ -> + ( DAst.make @@ GLetIn (n, t, None, new_b) + , (* HOPING IT WOULD WORK *) + Id.Set.filter not_free_in_t id_to_exclude ) ) + | GLetTuple (nal, (na, rto), t, b) -> + assert (Option.is_empty rto); + let not_free_in_t id = not (is_free_in id t) in + let new_t, id_to_exclude' = + rebuild_cons env nb_args relname args crossed_types depth t + in + let t', ctx = Pretyping.understand env (Evd.from_env env) new_t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot na r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args (t :: crossed_types) (depth + 1) + b + in + (* match n with *) + (* | Name id when Id.Set.mem id id_to_exclude -> *) + (* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) + (* | _ -> *) + ( DAst.make @@ GLetTuple (nal, (na, None), t, new_b) + , Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') ) + | _ -> (mkGApp (mkGVar relname, args @ [rt]), Id.Set.empty) (* debugging wrapper *) let rebuild_cons env nb_args relname args crossed_types rt = -(* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *) -(* str "nb_args := " ++ str (string_of_int nb_args)); *) - let res = - rebuild_cons env nb_args relname args crossed_types 0 rt - in -(* observe (str " leads to "++ pr_glob_constr (fst res)); *) + (* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *) + (* str "nb_args := " ++ str (string_of_int nb_args)); *) + let res = rebuild_cons env nb_args relname args crossed_types 0 rt in + (* observe (str " leads to "++ pr_glob_constr (fst res)); *) res - (* naive implementation of parameter detection. A parameter is an argument which is only preceded by parameters and whose @@ -1230,92 +1172,103 @@ let rebuild_cons env nb_args relname args crossed_types rt = TODO: Find a valid way to deal with implicit arguments here! *) -let rec compute_cst_params relnames params gt = DAst.with_val (function - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GInt _ | GFloat _ -> params - | GApp(f,args) -> - begin match DAst.get f with - | GVar relname' when Id.Set.mem relname' relnames -> - compute_cst_params_from_app [] (params,args) - | _ -> - List.fold_left (compute_cst_params relnames) params (f::args) - end - | GLambda(_,_,t,b) | GProd(_,_,t,b) | GLetTuple(_,_,t,b) -> - let t_params = compute_cst_params relnames params t in - compute_cst_params relnames t_params b - | GLetIn(_,v,t,b) -> - let v_params = compute_cst_params relnames params v in - let t_params = Option.fold_left (compute_cst_params relnames) v_params t in - compute_cst_params relnames t_params b - | GCases _ -> - params (* If there is still cases at this point they can only be - discrimination ones *) - | GSort _ -> params - | GHole _ -> params - | GIf _ | GRec _ | GCast _ -> - CErrors.user_err ~hdr:"compute_cst_params" (str "Not handled case") - ) gt -and compute_cst_params_from_app acc (params,rtl) = - let is_gid id c = match DAst.get c with GVar id' -> Id.equal id id' | _ -> false in - match params,rtl with - | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,None) as param)::params', c::rtl' when is_gid id c -> - compute_cst_params_from_app (param::acc) (params',rtl') - | _ -> List.rev acc - -let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * glob_constr option) list array) csts = +let rec compute_cst_params relnames params gt = + DAst.with_val + (function + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GInt _ | GFloat _ -> params + | GApp (f, args) -> ( + match DAst.get f with + | GVar relname' when Id.Set.mem relname' relnames -> + compute_cst_params_from_app [] (params, args) + | _ -> List.fold_left (compute_cst_params relnames) params (f :: args) ) + | GLambda (_, _, t, b) | GProd (_, _, t, b) | GLetTuple (_, _, t, b) -> + let t_params = compute_cst_params relnames params t in + compute_cst_params relnames t_params b + | GLetIn (_, v, t, b) -> + let v_params = compute_cst_params relnames params v in + let t_params = + Option.fold_left (compute_cst_params relnames) v_params t + in + compute_cst_params relnames t_params b + | GCases _ -> + params + (* If there is still cases at this point they can only be + discrimination ones *) + | GSort _ -> params + | GHole _ -> params + | GIf _ | GRec _ | GCast _ -> + CErrors.user_err ~hdr:"compute_cst_params" (str "Not handled case")) + gt + +and compute_cst_params_from_app acc (params, rtl) = + let is_gid id c = + match DAst.get c with GVar id' -> Id.equal id id' | _ -> false + in + match (params, rtl) with + | _ :: _, [] -> assert false (* the rel has at least nargs + 1 arguments ! *) + | ((Name id, _, None) as param) :: params', c :: rtl' when is_gid id c -> + compute_cst_params_from_app (param :: acc) (params', rtl') + | _ -> List.rev acc + +let compute_params_name relnames + (args : (Name.t * Glob_term.glob_constr * glob_constr option) list array) + csts = let rels_params = Array.mapi (fun i args -> - List.fold_left - (fun params (_,cst) -> compute_cst_params relnames params cst) - args - csts.(i) - ) + List.fold_left + (fun params (_, cst) -> compute_cst_params relnames params cst) + args csts.(i)) args in let l = ref [] in let _ = try List.iteri - (fun i ((n,nt,typ) as param) -> - if Array.for_all - (fun l -> - let (n',nt',typ') = List.nth l i in - Name.equal n n' && glob_constr_eq nt nt' && Option.equal glob_constr_eq typ typ') - rels_params - then - l := param::!l - ) + (fun i ((n, nt, typ) as param) -> + if + Array.for_all + (fun l -> + let n', nt', typ' = List.nth l i in + Name.equal n n' && glob_constr_eq nt nt' + && Option.equal glob_constr_eq typ typ') + rels_params + then l := param :: !l) rels_params.(0) - with e when CErrors.noncritical e -> - () + with e when CErrors.noncritical e -> () in List.rev !l let rec rebuild_return_type rt = let loc = rt.CAst.loc in match rt.CAst.v with - | Constrexpr.CProdN(n,t') -> - CAst.make ?loc @@ Constrexpr.CProdN(n,rebuild_return_type t') - | Constrexpr.CLetIn(na,v,t,t') -> - CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type t') - | _ -> CAst.make ?loc @@ Constrexpr.CProdN([Constrexpr.CLocalAssum ([CAst.make Anonymous], - Constrexpr.Default Explicit, rt)], - CAst.make @@ Constrexpr.CSort(UAnonymous {rigid=true})) - -let do_build_inductive - evd (funconstants: pconstant list) (funsargs: (Name.t * glob_constr * glob_constr option) list list) - returned_types - (rtl:glob_constr list) = + | Constrexpr.CProdN (n, t') -> + CAst.make ?loc @@ Constrexpr.CProdN (n, rebuild_return_type t') + | Constrexpr.CLetIn (na, v, t, t') -> + CAst.make ?loc @@ Constrexpr.CLetIn (na, v, t, rebuild_return_type t') + | _ -> + CAst.make ?loc + @@ Constrexpr.CProdN + ( [ Constrexpr.CLocalAssum + ([CAst.make Anonymous], Constrexpr.Default Explicit, rt) ] + , CAst.make @@ Constrexpr.CSort (UAnonymous {rigid = true}) ) + +let do_build_inductive evd (funconstants : pconstant list) + (funsargs : (Name.t * glob_constr * glob_constr option) list list) + returned_types (rtl : glob_constr list) = let _time1 = System.get_time () in - let funnames = List.map (fun c -> Label.to_id (KerName.label (Constant.canonical (fst c)))) funconstants in + let funnames = + List.map + (fun c -> Label.to_id (KerName.label (Constant.canonical (fst c)))) + funconstants + in (* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) let funnames_as_set = List.fold_right Id.Set.add funnames Id.Set.empty in let funnames = Array.of_list funnames in let funsargs = Array.of_list funsargs in let returned_types = Array.of_list returned_types in (* alpha_renaming of the body to prevent variable capture during manipulation *) - let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in + let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in let rta = Array.of_list rtl_alpha in (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious @@ -1324,46 +1277,64 @@ let do_build_inductive let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in (* Construction of the pseudo constructors *) let open Context.Named.Declaration in - let evd,env = + let evd, env = Array.fold_right2 - (fun id (c, u) (evd,env) -> - let u = EConstr.EInstance.make u in - let evd,t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in - let t = EConstr.Unsafe.to_constr t in - evd, - Environ.push_named (LocalAssum (make_annot id Sorts.Relevant,t)) - env - ) + (fun id (c, u) (evd, env) -> + let u = EConstr.EInstance.make u in + let evd, t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in + let t = EConstr.Unsafe.to_constr t in + ( evd + , Environ.push_named (LocalAssum (make_annot id Sorts.Relevant, t)) env + )) funnames (Array.of_list funconstants) - (evd,Global.env ()) + (evd, Global.env ()) in (* we solve and replace the implicits *) let rta = - Array.mapi (fun i rt -> - let _,t = Typing.type_of env evd (EConstr.of_constr (mkConstU ((Array.of_list funconstants).(i)))) in - resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env evd rt - ) rta + Array.mapi + (fun i rt -> + let _, t = + Typing.type_of env evd + (EConstr.of_constr (mkConstU (Array.of_list funconstants).(i))) + in + resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env + evd rt) + rta in let resa = Array.map (build_entry_lc env evd funnames_as_set []) rta in let env_with_graphs = - let rel_arity i funargs = (* Rebuilding arities (with parameters) *) - let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = + let rel_arity i funargs = + (* Rebuilding arities (with parameters) *) + let rel_first_args : + (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list = funargs in List.fold_right - (fun (n,t,typ) acc -> + (fun (n, t, typ) acc -> match typ with | Some typ -> - CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, - Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), - acc) + CAst.make + @@ Constrexpr.CLetIn + ( CAst.make n + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t + , Some + (with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + typ) + , acc ) | None -> - CAst.make @@ Constrexpr.CProdN - ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], - acc - ) - ) + CAst.make + @@ Constrexpr.CProdN + ( [ Constrexpr.CLocalAssum + ( [CAst.make n] + , Constrexpr_ops.default_binder_kind + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t ) ] + , acc )) rel_first_args (rebuild_return_type returned_types.(i)) in @@ -1372,67 +1343,87 @@ let do_build_inductive Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in - Util.Array.fold_left2 (fun env rel_name rel_ar -> - let rex = fst (with_full_print (Constrintern.interp_constr env evd) rel_ar) in + Util.Array.fold_left2 + (fun env rel_name rel_ar -> + let rex = + fst (with_full_print (Constrintern.interp_constr env evd) rel_ar) + in let rex = EConstr.Unsafe.to_constr rex in - let r = Sorts.Relevant in (* TODO relevance *) - Environ.push_named (LocalAssum (make_annot rel_name r,rex)) env) env relnames rel_arities + let r = Sorts.Relevant in + (* TODO relevance *) + Environ.push_named (LocalAssum (make_annot rel_name r, rex)) env) + env relnames rel_arities in (* and of the real constructors*) let constr i res = List.map - (function result (* (args',concl') *) -> - let rt = compose_glob_context result.context result.value in - let nb_args = List.length funsargs.(i) in - (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) - fst ( - rebuild_cons env_with_graphs nb_args relnames.(i) - [] - [] - rt - ) - ) + (function + | result (* (args',concl') *) -> + let rt = compose_glob_context result.context result.value in + let nb_args = List.length funsargs.(i) in + (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) + fst (rebuild_cons env_with_graphs nb_args relnames.(i) [] [] rt)) res.result in (* adding names to constructors *) - let next_constructor_id = ref (-1) in + let next_constructor_id = ref (-1) in let mk_constructor_id i = incr next_constructor_id; (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) - Id.of_string ((Id.to_string (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) + Id.of_string + ( Id.to_string (mk_rel_id funnames.(i)) + ^ "_" + ^ string_of_int !next_constructor_id ) in - let rel_constructors i rt : (Id.t*glob_constr) list = - next_constructor_id := (-1); - List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) + let rel_constructors i rt : (Id.t * glob_constr) list = + next_constructor_id := -1; + List.map (fun constr -> (mk_constructor_id i, constr)) (constr i rt) in let rel_constructors = Array.mapi rel_constructors resa in (* Computing the set of parameters if asked *) - let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in + let rels_params = + compute_params_name relnames_as_set funsargs rel_constructors + in let nrel_params = List.length rels_params in - let rel_constructors = (* Taking into account the parameters in constructors *) - Array.map (List.map - (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) - rel_constructors + let rel_constructors = + (* Taking into account the parameters in constructors *) + Array.map + (List.map (fun (id, rt) -> (id, snd (chop_rprod_n nrel_params rt)))) + rel_constructors in - let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = - (snd (List.chop nrel_params funargs)) + let rel_arity i funargs = + (* Reduilding arities (with parameters) *) + let rel_first_args : + (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list = + snd (List.chop nrel_params funargs) in List.fold_right - (fun (n,t,typ) acc -> - match typ with - | Some typ -> - CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, - Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), - acc) - | None -> - CAst.make @@ Constrexpr.CProdN - ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], - acc - ) - ) + (fun (n, t, typ) acc -> + match typ with + | Some typ -> + CAst.make + @@ Constrexpr.CLetIn + ( CAst.make n + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t + , Some + (with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + typ) + , acc ) + | None -> + CAst.make + @@ Constrexpr.CProdN + ( [ Constrexpr.CLocalAssum + ( [CAst.make n] + , Constrexpr_ops.default_binder_kind + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t ) ] + , acc )) rel_first_args (rebuild_return_type returned_types.(i)) in @@ -1443,103 +1434,123 @@ let do_build_inductive let rel_arities = Array.mapi rel_arity funsargs in let rel_params_ids = List.fold_left - (fun acc (na,_,_) -> - match na with - Anonymous -> acc - | Name id -> id::acc - ) - [] - rels_params + (fun acc (na, _, _) -> + match na with Anonymous -> acc | Name id -> id :: acc) + [] rels_params in let rel_params = List.map - (fun (n,t,typ) -> - match typ with - | Some typ -> - Constrexpr.CLocalDef((CAst.make n), Constrextern.extern_glob_constr Id.Set.empty t, - Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ)) - | None -> - Constrexpr.CLocalAssum - ([(CAst.make n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t) - ) + (fun (n, t, typ) -> + match typ with + | Some typ -> + Constrexpr.CLocalDef + ( CAst.make n + , Constrextern.extern_glob_constr Id.Set.empty t + , Some + (with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + typ) ) + | None -> + Constrexpr.CLocalAssum + ( [CAst.make n] + , Constrexpr_ops.default_binder_kind + , Constrextern.extern_glob_constr Id.Set.empty t )) rels_params in let ext_rels_constructors = - Array.map (List.map - (fun (id,t) -> - false,((CAst.make id), - with_full_print - (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t)) - ) - )) - (rel_constructors) + Array.map + (List.map (fun (id, t) -> + ( false + , ( CAst.make id + , with_full_print + (Constrextern.extern_glob_type Id.Set.empty) + ((* zeta_normalize *) alpha_rt rel_params_ids t) ) ))) + rel_constructors in let rel_ind i ext_rel_constructors = - ((CAst.make @@ relnames.(i)), - (rel_params,None), - Some rel_arities.(i), - ext_rel_constructors),[] + ( ( CAst.make @@ relnames.(i) + , (rel_params, None) + , Some rel_arities.(i) + , ext_rel_constructors ) + , [] ) in - let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in + let ext_rel_constructors = Array.mapi rel_ind ext_rels_constructors in let rel_inds = Array.to_list ext_rel_constructors in -(* let _ = *) -(* Pp.msgnl (\* observe *\) ( *) -(* str "Inductive" ++ spc () ++ *) -(* prlist_with_sep *) -(* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) -(* (function ((_,id),_,params,ar,constr) -> *) -(* Ppconstr.pr_id id ++ spc () ++ *) -(* Ppconstr.pr_binders params ++ spc () ++ *) -(* str ":" ++ spc () ++ *) -(* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) -(* prlist_with_sep *) -(* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) -(* (function (_,((_,id),t)) -> *) -(* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) -(* Ppconstr.pr_lconstr_expr t) *) -(* constr *) -(* ) *) -(* rel_inds *) -(* ) *) -(* in *) + (* let _ = *) + (* Pp.msgnl (\* observe *\) ( *) + (* str "Inductive" ++ spc () ++ *) + (* prlist_with_sep *) + (* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) + (* (function ((_,id),_,params,ar,constr) -> *) + (* Ppconstr.pr_id id ++ spc () ++ *) + (* Ppconstr.pr_binders params ++ spc () ++ *) + (* str ":" ++ spc () ++ *) + (* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) + (* prlist_with_sep *) + (* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) + (* (function (_,((_,id),t)) -> *) + (* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) + (* Ppconstr.pr_lconstr_expr t) *) + (* constr *) + (* ) *) + (* rel_inds *) + (* ) *) + (* in *) let _time2 = System.get_time () in try with_full_print - (Flags.silently (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds ~cumulative:false ~poly:false ~private_ind:false ~uniform:ComInductive.NonUniformParameters)) + (Flags.silently + (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds + ~cumulative:false ~poly:false ~private_ind:false + ~uniform:ComInductive.NonUniformParameters)) Declarations.Finite with - | UserError(s,msg) as e -> - let _time3 = System.get_time () in -(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(Vernacexpr.Inductive_kw,repacked_rel_inds)}) - ++ fnl () ++ - msg - in - observe (msg); - raise e - | reraise -> - let _time3 = System.get_time () in -(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (CAst.make @@ Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(Vernacexpr.Inductive_kw,repacked_rel_inds)}) - ++ fnl () ++ - CErrors.print reraise - in - observe msg; - raise reraise - - + | UserError (s, msg) as e -> + let _time3 = System.get_time () in + (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map + (fun ((a, b, c, l), ntn) -> + (((false, (a, None)), b, c, Vernacexpr.Constructors l), ntn)) + rel_inds + in + let msg = + str "while trying to define" + ++ spc () + ++ Ppvernac.pr_vernac + (CAst.make + Vernacexpr. + { control = [] + ; attrs = [] + ; expr = + VernacInductive (Vernacexpr.Inductive_kw, repacked_rel_inds) + }) + ++ fnl () ++ msg + in + observe msg; raise e + | reraise -> + let _time3 = System.get_time () in + (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map + (fun ((a, b, c, l), ntn) -> + (((false, (a, None)), b, c, Vernacexpr.Constructors l), ntn)) + rel_inds + in + let msg = + str "while trying to define" + ++ spc () + ++ Ppvernac.pr_vernac + ( CAst.make + @@ Vernacexpr. + { control = [] + ; attrs = [] + ; expr = + VernacInductive (Vernacexpr.Inductive_kw, repacked_rel_inds) + } ) + ++ fnl () ++ CErrors.print reraise + in + observe msg; raise reraise let build_inductive evd funconstants funsargs returned_types rtl = let pu = !Detyping.print_universes in diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index a29e5dff23..8dfeafe7c9 100644 --- a/plugins/funind/glob_term_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -7,13 +7,15 @@ open Names *) val build_inductive : -(* (ModPath.t * DirPath.t) option -> - Id.t list -> (* The list of function name *) - *) - Evd.evar_map -> - Constr.pconstant list -> - (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list list -> (* The list of function args *) - Constrexpr.constr_expr list -> (* The list of function returned type *) - Glob_term.glob_constr list -> (* the list of body *) - unit - + (* (ModPath.t * DirPath.t) option -> + Id.t list -> (* The list of function name *) + *) + Evd.evar_map + -> Constr.pconstant list + -> (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list list + -> (* The list of function args *) + Constrexpr.constr_expr list + -> (* The list of function returned type *) + Glob_term.glob_constr list + -> (* the list of body *) + unit diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 9fa72919ce..5026120849 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -18,14 +18,17 @@ open Names Some basic functions to rebuild glob_constr In each of them the location is Loc.ghost *) -let mkGRef ref = DAst.make @@ GRef(ref,None) -let mkGVar id = DAst.make @@ GVar(id) -let mkGApp(rt,rtl) = DAst.make @@ GApp(rt,rtl) -let mkGLambda(n,t,b) = DAst.make @@ GLambda(n,Explicit,t,b) -let mkGProd(n,t,b) = DAst.make @@ GProd(n,Explicit,t,b) -let mkGLetIn(n,b,t,c) = DAst.make @@ GLetIn(n,b,t,c) -let mkGCases(rto,l,brl) = DAst.make @@ GCases(RegularStyle,rto,l,brl) -let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) +let mkGRef ref = DAst.make @@ GRef (ref, None) +let mkGVar id = DAst.make @@ GVar id +let mkGApp (rt, rtl) = DAst.make @@ GApp (rt, rtl) +let mkGLambda (n, t, b) = DAst.make @@ GLambda (n, Explicit, t, b) +let mkGProd (n, t, b) = DAst.make @@ GProd (n, Explicit, t, b) +let mkGLetIn (n, b, t, c) = DAst.make @@ GLetIn (n, b, t, c) +let mkGCases (rto, l, brl) = DAst.make @@ GCases (RegularStyle, rto, l, brl) + +let mkGHole () = + DAst.make + @@ GHole (Evar_kinds.BinderType Anonymous, Namegen.IntroAnonymous, None) (* Some basic functions to decompose glob_constrs @@ -33,532 +36,483 @@ let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Nam *) let glob_decompose_app = let rec decompose_rapp acc rt = -(* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) + (* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) match DAst.get rt with - | GApp(rt,rtl) -> - decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt - | _ -> rt,List.rev acc + | GApp (rt, rtl) -> + decompose_rapp (List.fold_left (fun y x -> x :: y) acc rtl) rt + | _ -> (rt, List.rev acc) in decompose_rapp [] - - - (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) -let glob_make_eq ?(typ= mkGHole ()) t1 t2 = - mkGApp(mkGRef (Coqlib.lib_ref "core.eq.type"),[typ;t2;t1]) +let glob_make_eq ?(typ = mkGHole ()) t1 t2 = + mkGApp (mkGRef (Coqlib.lib_ref "core.eq.type"), [typ; t2; t1]) (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) let glob_make_neq t1 t2 = - mkGApp(mkGRef (Coqlib.lib_ref "core.not.type"),[glob_make_eq t1 t2]) + mkGApp (mkGRef (Coqlib.lib_ref "core.not.type"), [glob_make_eq t1 t2]) let remove_name_from_mapping mapping na = - match na with - | Anonymous -> mapping - | Name id -> Id.Map.remove id mapping + match na with Anonymous -> mapping | Name id -> Id.Map.remove id mapping let change_vars = let rec change_vars mapping rt = - DAst.map_with_loc (fun ?loc -> function - | GRef _ as x -> x - | GVar id -> - let new_id = - try - Id.Map.find id mapping - with Not_found -> id + DAst.map_with_loc + (fun ?loc -> function GRef _ as x -> x + | GVar id -> + let new_id = try Id.Map.find id mapping with Not_found -> id in + GVar new_id | GEvar _ as x -> x | GPatVar _ as x -> x + | GApp (rt', rtl) -> + GApp (change_vars mapping rt', List.map (change_vars mapping) rtl) + | GLambda (name, k, t, b) -> + GLambda + ( name + , k + , change_vars mapping t + , change_vars (remove_name_from_mapping mapping name) b ) + | GProd (name, k, t, b) -> + GProd + ( name + , k + , change_vars mapping t + , change_vars (remove_name_from_mapping mapping name) b ) + | GLetIn (name, def, typ, b) -> + GLetIn + ( name + , change_vars mapping def + , Option.map (change_vars mapping) typ + , change_vars (remove_name_from_mapping mapping name) b ) + | GLetTuple (nal, (na, rto), b, e) -> + let new_mapping = + List.fold_left remove_name_from_mapping mapping nal in - GVar(new_id) - | GEvar _ as x -> x - | GPatVar _ as x -> x - | GApp(rt',rtl) -> - GApp(change_vars mapping rt', - List.map (change_vars mapping) rtl - ) - | GLambda(name,k,t,b) -> - GLambda(name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) - | GProd(name,k,t,b) -> - GProd( name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) - | GLetIn(name,def,typ,b) -> - GLetIn(name, - change_vars mapping def, - Option.map (change_vars mapping) typ, - change_vars (remove_name_from_mapping mapping name) b - ) - | GLetTuple(nal,(na,rto),b,e) -> - let new_mapping = List.fold_left remove_name_from_mapping mapping nal in - GLetTuple(nal, - (na, Option.map (change_vars mapping) rto), - change_vars mapping b, - change_vars new_mapping e - ) - | GCases(sty,infos,el,brl) -> - GCases(sty, - infos, - List.map (fun (e,x) -> (change_vars mapping e,x)) el, - List.map (change_vars_br mapping) brl - ) - | GIf(b,(na,e_option),lhs,rhs) -> - GIf(change_vars mapping b, - (na,Option.map (change_vars mapping) e_option), - change_vars mapping lhs, - change_vars mapping rhs - ) - | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported") - | GSort _ as x -> x - | GHole _ as x -> x - | GInt _ as x -> x - | GFloat _ as x -> x - | GCast(b,c) -> - GCast(change_vars mapping b, - Glob_ops.map_cast_type (change_vars mapping) c) - ) rt - and change_vars_br mapping ({CAst.loc;v=(idl,patl,res)} as br) = + GLetTuple + ( nal + , (na, Option.map (change_vars mapping) rto) + , change_vars mapping b + , change_vars new_mapping e ) + | GCases (sty, infos, el, brl) -> + GCases + ( sty + , infos + , List.map (fun (e, x) -> (change_vars mapping e, x)) el + , List.map (change_vars_br mapping) brl ) + | GIf (b, (na, e_option), lhs, rhs) -> + GIf + ( change_vars mapping b + , (na, Option.map (change_vars mapping) e_option) + , change_vars mapping lhs + , change_vars mapping rhs ) + | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported") + | GSort _ as x -> x | GHole _ as x -> x | GInt _ as x -> x + | GFloat _ as x -> x + | GCast (b, c) -> + GCast + ( change_vars mapping b + , Glob_ops.map_cast_type (change_vars mapping) c )) + rt + and change_vars_br mapping ({CAst.loc; v = idl, patl, res} as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in - if Id.Map.is_empty new_mapping - then br - else CAst.make ?loc (idl,patl,change_vars new_mapping res) + if Id.Map.is_empty new_mapping then br + else CAst.make ?loc (idl, patl, change_vars new_mapping res) in change_vars - - let rec alpha_pat excluded pat = let loc = pat.CAst.loc in match DAst.get pat with - | PatVar Anonymous -> - let new_id = Indfun_common.fresh_id excluded "_x" in - (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty - | PatVar(Name id) -> - if Id.List.mem id excluded - then - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), - (Id.Map.add id new_id Id.Map.empty) - else pat, excluded,Id.Map.empty - | PatCstr(constr,patl,na) -> - let new_na,new_excluded,map = - match na with - | Name id when Id.List.mem id excluded -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty - | _ -> na,excluded,Id.Map.empty - in - let new_patl,new_excluded,new_map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - (new_pat::patl,new_excluded,Id.Map.fold Id.Map.add new_map map) - ) - ([],new_excluded,map) - patl - in - (DAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map - -let alpha_patl excluded patl = - let patl,new_excluded,map = + | PatVar Anonymous -> + let new_id = Indfun_common.fresh_id excluded "_x" in + (DAst.make ?loc @@ PatVar (Name new_id), new_id :: excluded, Id.Map.empty) + | PatVar (Name id) -> + if Id.List.mem id excluded then + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + ( DAst.make ?loc @@ PatVar (Name new_id) + , new_id :: excluded + , Id.Map.add id new_id Id.Map.empty ) + else (pat, excluded, Id.Map.empty) + | PatCstr (constr, patl, na) -> + let new_na, new_excluded, map = + match na with + | Name id when Id.List.mem id excluded -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + (Name new_id, new_id :: excluded, Id.Map.add id new_id Id.Map.empty) + | _ -> (na, excluded, Id.Map.empty) + in + let new_patl, new_excluded, new_map = + List.fold_left + (fun (patl, excluded, map) pat -> + let new_pat, new_excluded, new_map = alpha_pat excluded pat in + (new_pat :: patl, new_excluded, Id.Map.fold Id.Map.add new_map map)) + ([], new_excluded, map) patl + in + ( DAst.make ?loc @@ PatCstr (constr, List.rev new_patl, new_na) + , new_excluded + , new_map ) + +let alpha_patl excluded patl = + let patl, new_excluded, map = List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - new_pat::patl,new_excluded,(Id.Map.fold Id.Map.add new_map map) - ) - ([],excluded,Id.Map.empty) + (fun (patl, excluded, map) pat -> + let new_pat, new_excluded, new_map = alpha_pat excluded pat in + (new_pat :: patl, new_excluded, Id.Map.fold Id.Map.add new_map map)) + ([], excluded, Id.Map.empty) patl in - (List.rev patl,new_excluded,map) - - - + (List.rev patl, new_excluded, map) let raw_get_pattern_id pat acc = let rec get_pattern_id pat = match DAst.get pat with - | PatVar(Anonymous) -> assert false - | PatVar(Name id) -> - [id] - | PatCstr(constr,patternl,_) -> - List.fold_right - (fun pat idl -> - let idl' = get_pattern_id pat in - idl'@idl - ) - patternl - [] + | PatVar Anonymous -> assert false + | PatVar (Name id) -> [id] + | PatCstr (constr, patternl, _) -> + List.fold_right + (fun pat idl -> + let idl' = get_pattern_id pat in + idl' @ idl) + patternl [] in - (get_pattern_id pat)@acc + get_pattern_id pat @ acc let get_pattern_id pat = raw_get_pattern_id pat [] let rec alpha_rt excluded rt = let loc = rt.CAst.loc in - let new_rt = DAst.make ?loc @@ + let new_rt = + DAst.make ?loc + @@ match DAst.get rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ as rt -> rt - | GLambda(Anonymous,k,t,b) -> - let new_id = Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) in - let new_excluded = new_id :: excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GLambda(Name new_id,k,new_t,new_b) - | GProd(Anonymous,k,t,b) -> - let new_t = alpha_rt excluded t in - let new_b = alpha_rt excluded b in - GProd(Anonymous,k,new_t,new_b) - | GLetIn(Anonymous,b,t,c) -> - let new_b = alpha_rt excluded b in - let new_t = Option.map (alpha_rt excluded) t in - let new_c = alpha_rt excluded c in - GLetIn(Anonymous,new_b,new_t,new_c) - | GLambda(Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let t,b = - if Id.equal new_id id - then t, b - else - let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in - (t,replace b) - in - let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GLambda(Name new_id,k,new_t,new_b) - | GProd(Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let new_excluded = new_id::excluded in - let t,b = - if Id.equal new_id id - then t,b - else - let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in - (t,replace b) - in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GProd(Name new_id,k,new_t,new_b) - | GLetIn(Name id,b,t,c) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let c = - if Id.equal new_id id then c - else change_vars (Id.Map.add id new_id Id.Map.empty) c - in - let new_excluded = new_id::excluded in - let new_b = alpha_rt new_excluded b in - let new_t = Option.map (alpha_rt new_excluded) t in - let new_c = alpha_rt new_excluded c in - GLetIn(Name new_id,new_b,new_t,new_c) - - | GLetTuple(nal,(na,rto),t,b) -> - let rev_new_nal,new_excluded,mapping = - List.fold_left - (fun (nal,excluded,mapping) na -> - match na with - | Anonymous -> (na::nal,excluded,mapping) - | Name id -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - if Id.equal new_id id - then - na::nal,id::excluded,mapping - else - (Name new_id)::nal,id::excluded,(Id.Map.add id new_id mapping) - ) - ([],excluded,Id.Map.empty) - nal - in - let new_nal = List.rev rev_new_nal in - let new_rto,new_t,new_b = - if Id.Map.is_empty mapping - then rto,t,b - else let replace = change_vars mapping in - (Option.map replace rto, t,replace b) - in - let new_t = alpha_rt new_excluded new_t in - let new_b = alpha_rt new_excluded new_b in - let new_rto = Option.map (alpha_rt new_excluded) new_rto in - GLetTuple(new_nal,(na,new_rto),new_t,new_b) - | GCases(sty,infos,el,brl) -> - let new_el = - List.map (function (rt,i) -> alpha_rt excluded rt, i) el - in - GCases(sty,infos,new_el,List.map (alpha_br excluded) brl) - | GIf(b,(na,e_o),lhs,rhs) -> - GIf(alpha_rt excluded b, - (na,Option.map (alpha_rt excluded) e_o), - alpha_rt excluded lhs, - alpha_rt excluded rhs - ) + | (GRef _ | GVar _ | GEvar _ | GPatVar _) as rt -> rt + | GLambda (Anonymous, k, t, b) -> + let new_id = + Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) + in + let new_excluded = new_id :: excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GLambda (Name new_id, k, new_t, new_b) + | GProd (Anonymous, k, t, b) -> + let new_t = alpha_rt excluded t in + let new_b = alpha_rt excluded b in + GProd (Anonymous, k, new_t, new_b) + | GLetIn (Anonymous, b, t, c) -> + let new_b = alpha_rt excluded b in + let new_t = Option.map (alpha_rt excluded) t in + let new_c = alpha_rt excluded c in + GLetIn (Anonymous, new_b, new_t, new_c) + | GLambda (Name id, k, t, b) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let t, b = + if Id.equal new_id id then (t, b) + else + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in + (t, replace b) + in + let new_excluded = new_id :: excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GLambda (Name new_id, k, new_t, new_b) + | GProd (Name id, k, t, b) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let new_excluded = new_id :: excluded in + let t, b = + if Id.equal new_id id then (t, b) + else + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in + (t, replace b) + in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GProd (Name new_id, k, new_t, new_b) + | GLetIn (Name id, b, t, c) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let c = + if Id.equal new_id id then c + else change_vars (Id.Map.add id new_id Id.Map.empty) c + in + let new_excluded = new_id :: excluded in + let new_b = alpha_rt new_excluded b in + let new_t = Option.map (alpha_rt new_excluded) t in + let new_c = alpha_rt new_excluded c in + GLetIn (Name new_id, new_b, new_t, new_c) + | GLetTuple (nal, (na, rto), t, b) -> + let rev_new_nal, new_excluded, mapping = + List.fold_left + (fun (nal, excluded, mapping) na -> + match na with + | Anonymous -> (na :: nal, excluded, mapping) + | Name id -> + let new_id = + Namegen.next_ident_away id (Id.Set.of_list excluded) + in + if Id.equal new_id id then (na :: nal, id :: excluded, mapping) + else + ( Name new_id :: nal + , id :: excluded + , Id.Map.add id new_id mapping )) + ([], excluded, Id.Map.empty) + nal + in + let new_nal = List.rev rev_new_nal in + let new_rto, new_t, new_b = + if Id.Map.is_empty mapping then (rto, t, b) + else + let replace = change_vars mapping in + (Option.map replace rto, t, replace b) + in + let new_t = alpha_rt new_excluded new_t in + let new_b = alpha_rt new_excluded new_b in + let new_rto = Option.map (alpha_rt new_excluded) new_rto in + GLetTuple (new_nal, (na, new_rto), new_t, new_b) + | GCases (sty, infos, el, brl) -> + let new_el = + List.map (function rt, i -> (alpha_rt excluded rt, i)) el + in + GCases (sty, infos, new_el, List.map (alpha_br excluded) brl) + | GIf (b, (na, e_o), lhs, rhs) -> + GIf + ( alpha_rt excluded b + , (na, Option.map (alpha_rt excluded) e_o) + , alpha_rt excluded lhs + , alpha_rt excluded rhs ) | GRec _ -> user_err Pp.(str "Not handled GRec") - | GSort _ - | GInt _ - | GFloat _ - | GHole _ as rt -> rt - | GCast (b,c) -> - GCast(alpha_rt excluded b, - Glob_ops.map_cast_type (alpha_rt excluded) c) - | GApp(f,args) -> - GApp(alpha_rt excluded f, - List.map (alpha_rt excluded) args - ) + | (GSort _ | GInt _ | GFloat _ | GHole _) as rt -> rt + | GCast (b, c) -> + GCast (alpha_rt excluded b, Glob_ops.map_cast_type (alpha_rt excluded) c) + | GApp (f, args) -> + GApp (alpha_rt excluded f, List.map (alpha_rt excluded) args) in new_rt -and alpha_br excluded {CAst.loc;v=(ids,patl,res)} = - let new_patl,new_excluded,mapping = alpha_patl excluded patl in +and alpha_br excluded {CAst.loc; v = ids, patl, res} = + let new_patl, new_excluded, mapping = alpha_patl excluded patl in let new_ids = List.fold_right raw_get_pattern_id new_patl [] in - let new_excluded = new_ids@excluded in + let new_excluded = new_ids @ excluded in let renamed_res = change_vars mapping res in let new_res = alpha_rt new_excluded renamed_res in - CAst.make ?loc (new_ids,new_patl,new_res) + CAst.make ?loc (new_ids, new_patl, new_res) (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) let is_free_in id = - let rec is_free_in x = DAst.with_loc_val (fun ?loc -> function - | GRef _ -> false - | GVar id' -> Id.compare id' id == 0 - | GEvar _ -> false - | GPatVar _ -> false - | GApp(rt,rtl) -> List.exists is_free_in (rt::rtl) - | GLambda(n,_,t,b) | GProd(n,_,t,b) -> - let check_in_b = - match n with - | Name id' -> not (Id.equal id' id) - | _ -> true - in - is_free_in t || (check_in_b && is_free_in b) - | GLetIn(n,b,t,c) -> - let check_in_c = - match n with - | Name id' -> not (Id.equal id' id) - | _ -> true - in - is_free_in b || Option.cata is_free_in true t || (check_in_c && is_free_in c) - | GCases(_,_,el,brl) -> - (List.exists (fun (e,_) -> is_free_in e) el) || - List.exists is_free_in_br brl - | GLetTuple(nal,_,b,t) -> - let check_in_nal = - not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal) - in - is_free_in t || (check_in_nal && is_free_in b) - - | GIf(cond,_,br1,br2) -> - is_free_in cond || is_free_in br1 || is_free_in br2 - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GSort _ -> false - | GHole _ -> false - | GCast (b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t - | GCast (b,CastCoerce) -> is_free_in b - | GInt _ | GFloat _ -> false - ) x - and is_free_in_br {CAst.v=(ids,_,rt)} = + let rec is_free_in x = + DAst.with_loc_val + (fun ?loc -> function GRef _ -> false | GVar id' -> Id.compare id' id == 0 + | GEvar _ -> false | GPatVar _ -> false + | GApp (rt, rtl) -> List.exists is_free_in (rt :: rtl) + | GLambda (n, _, t, b) | GProd (n, _, t, b) -> + let check_in_b = + match n with Name id' -> not (Id.equal id' id) | _ -> true + in + is_free_in t || (check_in_b && is_free_in b) + | GLetIn (n, b, t, c) -> + let check_in_c = + match n with Name id' -> not (Id.equal id' id) | _ -> true + in + is_free_in b + || Option.cata is_free_in true t + || (check_in_c && is_free_in c) + | GCases (_, _, el, brl) -> + List.exists (fun (e, _) -> is_free_in e) el + || List.exists is_free_in_br brl + | GLetTuple (nal, _, b, t) -> + let check_in_nal = + not + (List.exists + (function Name id' -> Id.equal id' id | _ -> false) + nal) + in + is_free_in t || (check_in_nal && is_free_in b) + | GIf (cond, _, br1, br2) -> + is_free_in cond || is_free_in br1 || is_free_in br2 + | GRec _ -> user_err Pp.(str "Not handled GRec") | GSort _ -> false + | GHole _ -> false + | GCast (b, (CastConv t | CastVM t | CastNative t)) -> + is_free_in b || is_free_in t | GCast (b, CastCoerce) -> is_free_in b + | GInt _ | GFloat _ -> false) + x + and is_free_in_br {CAst.v = ids, _, rt} = (not (Id.List.mem id ids)) && is_free_in rt in is_free_in - - -let rec pattern_to_term pt = DAst.with_val (function - | PatVar Anonymous -> assert false - | PatVar(Name id) -> - mkGVar id - | PatCstr(constr,patternl,_) -> - let cst_narg = - Inductiveops.constructor_nallargs - (Global.env ()) - constr - in - let implicit_args = - Array.to_list - (Array.init - (cst_narg - List.length patternl) - (fun _ -> mkGHole ()) - ) - in - let patl_as_term = - List.map pattern_to_term patternl - in - mkGApp(mkGRef(GlobRef.ConstructRef constr), - implicit_args@patl_as_term - ) - ) pt - +let rec pattern_to_term pt = + DAst.with_val + (function + | PatVar Anonymous -> assert false + | PatVar (Name id) -> mkGVar id + | PatCstr (constr, patternl, _) -> + let cst_narg = + Inductiveops.constructor_nallargs (Global.env ()) constr + in + let implicit_args = + Array.to_list + (Array.init (cst_narg - List.length patternl) (fun _ -> mkGHole ())) + in + let patl_as_term = List.map pattern_to_term patternl in + mkGApp + (mkGRef (GlobRef.ConstructRef constr), implicit_args @ patl_as_term)) + pt let replace_var_by_term x_id term = - let rec replace_var_by_pattern x = DAst.map (function - | GVar id when Id.compare id x_id == 0 -> DAst.get term - | GRef _ - | GVar _ - | GEvar _ - | GPatVar _ as rt -> rt - | GApp(rt',rtl) -> - GApp(replace_var_by_pattern rt', - List.map replace_var_by_pattern rtl - ) - | GLambda(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt - | GLambda(name,k,t,b) -> - GLambda(name, - k, - replace_var_by_pattern t, - replace_var_by_pattern b - ) - | GProd(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt - | GProd(name,k,t,b) -> - GProd( name, - k, - replace_var_by_pattern t, - replace_var_by_pattern b - ) - | GLetIn(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt - | GLetIn(name,def,typ,b) -> - GLetIn(name, - replace_var_by_pattern def, - Option.map (replace_var_by_pattern) typ, - replace_var_by_pattern b - ) - | GLetTuple(nal,_,_,_) as rt - when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal -> + let rec replace_var_by_pattern x = + DAst.map + (function + | GVar id when Id.compare id x_id == 0 -> DAst.get term + | (GRef _ | GVar _ | GEvar _ | GPatVar _) as rt -> rt + | GApp (rt', rtl) -> + GApp (replace_var_by_pattern rt', List.map replace_var_by_pattern rtl) + | GLambda (Name id, _, _, _) as rt when Id.compare id x_id == 0 -> rt + | GLambda (name, k, t, b) -> + GLambda (name, k, replace_var_by_pattern t, replace_var_by_pattern b) + | GProd (Name id, _, _, _) as rt when Id.compare id x_id == 0 -> rt + | GProd (name, k, t, b) -> + GProd (name, k, replace_var_by_pattern t, replace_var_by_pattern b) + | GLetIn (Name id, _, _, _) as rt when Id.compare id x_id == 0 -> rt + | GLetIn (name, def, typ, b) -> + GLetIn + ( name + , replace_var_by_pattern def + , Option.map replace_var_by_pattern typ + , replace_var_by_pattern b ) + | GLetTuple (nal, _, _, _) as rt + when List.exists + (function Name id -> Id.equal id x_id | _ -> false) + nal -> rt - | GLetTuple(nal,(na,rto),def,b) -> - GLetTuple(nal, - (na,Option.map replace_var_by_pattern rto), - replace_var_by_pattern def, - replace_var_by_pattern b - ) - | GCases(sty,infos,el,brl) -> - GCases(sty, - infos, - List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, - List.map replace_var_by_pattern_br brl - ) - | GIf(b,(na,e_option),lhs,rhs) -> - GIf(replace_var_by_pattern b, - (na,Option.map replace_var_by_pattern e_option), - replace_var_by_pattern lhs, - replace_var_by_pattern rhs - ) - | GRec _ -> - CErrors.user_err (Pp.str "Not handled GRec") - | GSort _ - | GHole _ as rt -> rt - | GInt _ as rt -> rt - | GFloat _ as rt -> rt - | GCast(b,c) -> - GCast(replace_var_by_pattern b, - Glob_ops.map_cast_type replace_var_by_pattern c) - ) x - and replace_var_by_pattern_br ({CAst.loc;v=(idl,patl,res)} as br) = - if List.exists (fun id -> Id.compare id x_id == 0) idl - then br - else CAst.make ?loc (idl,patl,replace_var_by_pattern res) + | GLetTuple (nal, (na, rto), def, b) -> + GLetTuple + ( nal + , (na, Option.map replace_var_by_pattern rto) + , replace_var_by_pattern def + , replace_var_by_pattern b ) + | GCases (sty, infos, el, brl) -> + GCases + ( sty + , infos + , List.map (fun (e, x) -> (replace_var_by_pattern e, x)) el + , List.map replace_var_by_pattern_br brl ) + | GIf (b, (na, e_option), lhs, rhs) -> + GIf + ( replace_var_by_pattern b + , (na, Option.map replace_var_by_pattern e_option) + , replace_var_by_pattern lhs + , replace_var_by_pattern rhs ) + | GRec _ -> CErrors.user_err (Pp.str "Not handled GRec") + | (GSort _ | GHole _) as rt -> rt + | GInt _ as rt -> rt + | GFloat _ as rt -> rt + | GCast (b, c) -> + GCast + ( replace_var_by_pattern b + , Glob_ops.map_cast_type replace_var_by_pattern c )) + x + and replace_var_by_pattern_br ({CAst.loc; v = idl, patl, res} as br) = + if List.exists (fun id -> Id.compare id x_id == 0) idl then br + else CAst.make ?loc (idl, patl, replace_var_by_pattern res) in replace_var_by_pattern - - - (* checking unifiability of patterns *) exception NotUnifiable -let rec are_unifiable_aux = function +let rec are_unifiable_aux = function | [] -> () - | (l, r) ::eqs -> - match DAst.get l, DAst.get r with - | PatVar _ ,_ | _, PatVar _-> are_unifiable_aux eqs - | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> - if not (eq_constructor constructor2 constructor1) - then raise NotUnifiable - else - let eqs' = - try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.") - in - are_unifiable_aux eqs' + | (l, r) :: eqs -> ( + match (DAst.get l, DAst.get r) with + | PatVar _, _ | _, PatVar _ -> are_unifiable_aux eqs + | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> + if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + else + let eqs' = + try List.combine cpl1 cpl2 @ eqs + with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.") + in + are_unifiable_aux eqs' ) let are_unifiable pat1 pat2 = try - are_unifiable_aux [pat1,pat2]; + are_unifiable_aux [(pat1, pat2)]; true with NotUnifiable -> false - -let rec eq_cases_pattern_aux = function +let rec eq_cases_pattern_aux = function | [] -> () - | (l, r) ::eqs -> - match DAst.get l, DAst.get r with - | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs - | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> - if not (eq_constructor constructor2 constructor1) - then raise NotUnifiable - else - let eqs' = - try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.") - in - eq_cases_pattern_aux eqs' - | _ -> raise NotUnifiable + | (l, r) :: eqs -> ( + match (DAst.get l, DAst.get r) with + | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs + | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> + if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + else + let eqs' = + try List.combine cpl1 cpl2 @ eqs + with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.") + in + eq_cases_pattern_aux eqs' + | _ -> raise NotUnifiable ) let eq_cases_pattern pat1 pat2 = try - eq_cases_pattern_aux [pat1,pat2]; + eq_cases_pattern_aux [(pat1, pat2)]; true with NotUnifiable -> false - - let ids_of_pat = - let rec ids_of_pat ids = DAst.with_val (function - | PatVar Anonymous -> ids - | PatVar(Name id) -> Id.Set.add id ids - | PatCstr(_,patl,_) -> List.fold_left ids_of_pat ids patl - ) + let rec ids_of_pat ids = + DAst.with_val (function + | PatVar Anonymous -> ids + | PatVar (Name id) -> Id.Set.add id ids + | PatCstr (_, patl, _) -> List.fold_left ids_of_pat ids patl) in ids_of_pat Id.Set.empty let expand_as = - let rec add_as map rt = match DAst.get rt with - | PatVar _ -> map - | PatCstr(_,patl,Name id) -> - Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) - | PatCstr(_,patl,_) -> List.fold_left add_as map patl + | PatVar _ -> map + | PatCstr (_, patl, Name id) -> + Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) + | PatCstr (_, patl, _) -> List.fold_left add_as map patl in - let rec expand_as map = DAst.map (function - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ as rt -> rt - | GVar id as rt -> - begin - try - DAst.get (Id.Map.find id map) - with Not_found -> rt - end - | GApp(f,args) -> GApp(expand_as map f,List.map (expand_as map) args) - | GLambda(na,k,t,b) -> GLambda(na,k,expand_as map t, expand_as map b) - | GProd(na,k,t,b) -> GProd(na,k,expand_as map t, expand_as map b) - | GLetIn(na,v,typ,b) -> GLetIn(na, expand_as map v,Option.map (expand_as map) typ,expand_as map b) - | GLetTuple(nal,(na,po),v,b) -> - GLetTuple(nal,(na,Option.map (expand_as map) po), - expand_as map v, expand_as map b) - | GIf(e,(na,po),br1,br2) -> - GIf(expand_as map e,(na,Option.map (expand_as map) po), - expand_as map br1, expand_as map br2) - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GCast(b,c) -> - GCast(expand_as map b, - Glob_ops.map_cast_type (expand_as map) c) - | GCases(sty,po,el,brl) -> - GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, - List.map (expand_as_br map) brl) - ) - and expand_as_br map {CAst.loc; v=(idl,cpl,rt)} = - CAst.make ?loc (idl,cpl, expand_as (List.fold_left add_as map cpl) rt) + let rec expand_as map = + DAst.map (function + | (GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _) + as rt -> + rt + | GVar id as rt -> ( + try DAst.get (Id.Map.find id map) with Not_found -> rt ) + | GApp (f, args) -> GApp (expand_as map f, List.map (expand_as map) args) + | GLambda (na, k, t, b) -> + GLambda (na, k, expand_as map t, expand_as map b) + | GProd (na, k, t, b) -> GProd (na, k, expand_as map t, expand_as map b) + | GLetIn (na, v, typ, b) -> + GLetIn + (na, expand_as map v, Option.map (expand_as map) typ, expand_as map b) + | GLetTuple (nal, (na, po), v, b) -> + GLetTuple + ( nal + , (na, Option.map (expand_as map) po) + , expand_as map v + , expand_as map b ) + | GIf (e, (na, po), br1, br2) -> + GIf + ( expand_as map e + , (na, Option.map (expand_as map) po) + , expand_as map br1 + , expand_as map br2 ) + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GCast (b, c) -> + GCast (expand_as map b, Glob_ops.map_cast_type (expand_as map) c) + | GCases (sty, po, el, brl) -> + GCases + ( sty + , Option.map (expand_as map) po + , List.map (fun (rt, t) -> (expand_as map rt, t)) el + , List.map (expand_as_br map) brl )) + and expand_as_br map {CAst.loc; v = idl, cpl, rt} = + CAst.make ?loc (idl, cpl, expand_as (List.fold_left add_as map cpl) rt) in expand_as Id.Map.empty @@ -566,65 +520,75 @@ let expand_as = *) exception Found of Evd.evar_info -let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expected_type=Pretyping.WithoutTypeConstraint) env sigma rt = + +let resolve_and_replace_implicits ?(flags = Pretyping.all_and_fail_flags) + ?(expected_type = Pretyping.WithoutTypeConstraint) env sigma rt = let open Evd in let open Evar_kinds in (* we first (pseudo) understand [rt] and get back the computed evar_map *) (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. -If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) - let ctx,_,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in + If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) + let ctx, _, _ = + Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type + rt + in let ctx = Evd.minimize_universes ctx in - let f c = EConstr.of_constr (Evarutil.nf_evars_universes ctx (EConstr.Unsafe.to_constr c)) in - + let f c = + EConstr.of_constr + (Evarutil.nf_evars_universes ctx (EConstr.Unsafe.to_constr c)) + in (* then we map [rt] to replace the implicit holes by their values *) let rec change rt = match DAst.get rt with - | GHole(ImplicitArg(grk,pk,bk),_,_) -> (* we only want to deal with implicit arguments *) - ( - try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) - Evd.fold (* to simulate an iter *) - (fun _ evi _ -> - match evi.evar_source with - | (loc_evi,ImplicitArg(gr_evi,p_evi,b_evi)) -> - if GlobRef.equal grk gr_evi && pk=p_evi && bk=b_evi && rt.CAst.loc = loc_evi - then raise (Found evi) - | _ -> () - ) - ctx - (); - (* the hole was not solved : we do nothing *) - rt - with Found evi -> (* we found the evar corresponding to this hole *) - match evi.evar_body with - | Evar_defined c -> - (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) - | Evar_empty -> rt (* the hole was not solved : we do nothing *) - ) - | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) - ( - let res = - try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) - Evd.fold (* to simulate an iter *) - (fun _ evi _ -> - match evi.evar_source with - | (loc_evi,BinderType na') -> - if Name.equal na na' && rt.CAst.loc = loc_evi then raise (Found evi) - | _ -> () - ) - ctx - (); - (* the hole was not solved : we do nothing *) - rt - with Found evi -> (* we found the evar corresponding to this hole *) - match evi.evar_body with - | Evar_defined c -> - (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) - | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) - in - res - ) + | GHole (ImplicitArg (grk, pk, bk), _, _) -> ( + try + (* we only want to deal with implicit arguments *) + + (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) + Evd.fold (* to simulate an iter *) + (fun _ evi _ -> + match evi.evar_source with + | loc_evi, ImplicitArg (gr_evi, p_evi, b_evi) -> + if + GlobRef.equal grk gr_evi && pk = p_evi && bk = b_evi + && rt.CAst.loc = loc_evi + then raise (Found evi) + | _ -> ()) + ctx (); + (* the hole was not solved : we do nothing *) + rt + with Found evi -> ( + (* we found the evar corresponding to this hole *) + match evi.evar_body with + | Evar_defined c -> + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) + | Evar_empty -> rt (* the hole was not solved : we do nothing *) ) ) + | GHole (BinderType na, _, _) -> + (* we only want to deal with implicit arguments *) + let res = + try + (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) + Evd.fold (* to simulate an iter *) + (fun _ evi _ -> + match evi.evar_source with + | loc_evi, BinderType na' -> + if Name.equal na na' && rt.CAst.loc = loc_evi then + raise (Found evi) + | _ -> ()) + ctx (); + (* the hole was not solved : we do nothing *) + rt + with Found evi -> ( + (* we found the evar corresponding to this hole *) + match evi.evar_body with + | Evar_defined c -> + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) + | Evar_empty -> rt ) + (* the hole was not solved : we d when falseo nothing *) + in + res | _ -> Glob_ops.map_glob_constr change rt in change rt diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index c55fdc017c..8eff7926da 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -25,33 +25,37 @@ val pattern_to_term : cases_pattern -> glob_constr *) val mkGRef : GlobRef.t -> glob_constr val mkGVar : Id.t -> glob_constr -val mkGApp : glob_constr*(glob_constr list) -> glob_constr +val mkGApp : glob_constr * glob_constr list -> glob_constr val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr val mkGProd : Name.t * glob_constr * glob_constr -> glob_constr -val mkGLetIn : Name.t * glob_constr * glob_constr option * glob_constr -> glob_constr -val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr -val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *) + +val mkGLetIn : + Name.t * glob_constr * glob_constr option * glob_constr -> glob_constr + +val mkGCases : + glob_constr option * tomatch_tuples * cases_clauses -> glob_constr + +val mkGHole : unit -> glob_constr + +(* we only build Evd.BinderType Anonymous holes *) + (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) -val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) - +val glob_decompose_app : glob_constr -> glob_constr * glob_constr list (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) -val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr +val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr + (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) -val glob_make_neq : glob_constr -> glob_constr -> glob_constr +val glob_make_neq : glob_constr -> glob_constr -> glob_constr (* alpha_conversion functions *) - - (* Replace the var mapped in the glob_constr/context *) val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr - - (* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. the result does not share variables with [avoid]. This function create a fresh variable for each occurrence of the anonymous pattern. @@ -59,11 +63,10 @@ val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr Also returns a mapping from old variables to new ones and the concatenation of [avoid] with the variables appearing in the result. *) - val alpha_pat : - Id.Map.key list -> - Glob_term.cases_pattern -> - Glob_term.cases_pattern * Id.Map.key list * - Id.t Id.Map.t +val alpha_pat : + Id.Map.key list + -> Glob_term.cases_pattern + -> Glob_term.cases_pattern * Id.Map.key list * Id.t Id.Map.t (* [alpha_rt avoid rt] alpha convert [rt] s.t. the result respects barendregt conventions and does not share bound variables with avoid @@ -71,38 +74,35 @@ val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr val alpha_rt : Id.t list -> glob_constr -> glob_constr (* same as alpha_rt but for case branches *) -val alpha_br : Id.t list -> - Glob_term.cases_clause -> - Glob_term.cases_clause +val alpha_br : Id.t list -> Glob_term.cases_clause -> Glob_term.cases_clause (* Reduction function *) -val replace_var_by_term : - Id.t -> - Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr - - +val replace_var_by_term : + Id.t + -> Glob_term.glob_constr + -> Glob_term.glob_constr + -> Glob_term.glob_constr (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) val is_free_in : Id.t -> glob_constr -> bool - - val are_unifiable : cases_pattern -> cases_pattern -> bool val eq_cases_pattern : cases_pattern -> cases_pattern -> bool - - (* ids_of_pat : cases_pattern -> Id.Set.t returns the set of variables appearing in a pattern *) -val ids_of_pat : cases_pattern -> Id.Set.t - +val ids_of_pat : cases_pattern -> Id.Set.t val expand_as : glob_constr -> glob_constr (* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution *) val resolve_and_replace_implicits : - ?flags:Pretyping.inference_flags -> - ?expected_type:Pretyping.typing_constraint -> Environ.env -> Evd.evar_map -> glob_constr -> glob_constr + ?flags:Pretyping.inference_flags + -> ?expected_type:Pretyping.typing_constraint + -> Environ.env + -> Evd.evar_map + -> glob_constr + -> glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 1f2f56ec34..4e0e2dc501 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -15,48 +15,49 @@ open Names open Sorts open Constr open EConstr - open Tacmach.New open Tacticals.New open Tactics - open Indfun_common - module RelDecl = Context.Rel.Declaration let is_rec_info sigma scheme_info = let test_branche min acc decl = - acc || ( - let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) in - let free_rels_in_br = Termops.free_rels sigma new_branche in - let max = min + scheme_info.Tactics.npredicates in - Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br - ) + acc + || + let new_branche = + it_mkProd_or_LetIn mkProp + (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) + in + let free_rels_in_br = Termops.free_rels sigma new_branche in + let max = min + scheme_info.Tactics.npredicates in + Int.Set.exists (fun i -> i >= min && i < max) free_rels_in_br in List.fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) let choose_dest_or_ind scheme_info args = Proofview.tclBIND Proofview.tclEVARMAP (fun sigma -> - Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) + Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) let functional_induction with_clean c princl pat = let open Proofview.Notations in Proofview.Goal.enter_one (fun gl -> - let sigma = project gl in - let f,args = decompose_app sigma c in - match princl with - | None -> (* No principle is given let's find the good one *) - begin + let sigma = project gl in + let f, args = decompose_app sigma c in + match princl with + | None -> ( + (* No principle is given let's find the good one *) match EConstr.kind sigma f with - | Const (c',u) -> + | Const (c', u) -> let princ_option = - let finfo = (* we first try to find out a graph on f *) + let finfo = + (* we first try to find out a graph on f *) match find_Function_infos c' with | Some finfo -> finfo | None -> - user_err (str "Cannot find induction information on "++ - Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) + user_err + ( str "Cannot find induction information on " + ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) in match elimination_sort_of_goal gl with | InSProp -> finfo.sprop_lemma @@ -64,7 +65,8 @@ let functional_induction with_clean c princl pat = | InSet -> finfo.rec_lemma | InType -> finfo.rect_lemma in - let sigma, princ = (* then we get the principle *) + let sigma, princ = + (* then we get the principle *) match princ_option with | Some princ -> Evd.fresh_global (pf_env gl) (project gl) (GlobRef.ConstRef princ) @@ -79,66 +81,74 @@ let functional_induction with_clean c princl pat = in let princ_ref = try - Constrintern.locate_reference (Libnames.qualid_of_ident princ_name) - with - | Not_found -> - user_err (str "Cannot find induction principle for " - ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) + Constrintern.locate_reference + (Libnames.qualid_of_ident princ_name) + with Not_found -> + user_err + ( str "Cannot find induction principle for " + ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) in Evd.fresh_global (pf_env gl) (project gl) princ_ref in let princt = Retyping.get_type_of (pf_env gl) sigma princ in - Proofview.Unsafe.tclEVARS sigma <*> - Proofview.tclUNIT (princ, Tactypes.NoBindings, princt, args) + Proofview.Unsafe.tclEVARS sigma + <*> Proofview.tclUNIT (princ, Tactypes.NoBindings, princt, args) | _ -> - CErrors.user_err (str "functional induction must be used with a function" ) - end - | Some ((princ,binding)) -> - let sigma, princt = pf_type_of gl princ in - Proofview.Unsafe.tclEVARS sigma <*> - Proofview.tclUNIT (princ, binding, princt, args) - ) >>= fun (princ, bindings, princ_type, args) -> + CErrors.user_err + (str "functional induction must be used with a function") ) + | Some (princ, binding) -> + let sigma, princt = pf_type_of gl princ in + Proofview.Unsafe.tclEVARS sigma + <*> Proofview.tclUNIT (princ, binding, princt, args)) + >>= fun (princ, bindings, princ_type, args) -> Proofview.Goal.enter (fun gl -> - let sigma = project gl in - let princ_infos = compute_elim_sig (project gl) princ_type in - let args_as_induction_constr = - let c_list = - if princ_infos.Tactics.farg_in_concl - then [c] else [] - in - if List.length args + List.length c_list = 0 - then user_err Pp.(str "Cannot recognize a valid functional scheme" ); - let encoded_pat_as_patlist = - List.make (List.length args + List.length c_list - 1) None @ [pat] - in - List.map2 - (fun c pat -> - ((None, ElimOnConstr (fun env sigma -> (sigma,(c,Tactypes.NoBindings)))), - (None,pat), None)) - (args@c_list) - encoded_pat_as_patlist - in - let princ' = Some (princ,bindings) in - let princ_vars = - List.fold_right - (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) - args - Id.Set.empty - in - let old_idl = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in - let old_idl = Id.Set.diff old_idl princ_vars in - let subst_and_reduce gl = - if with_clean - then - let idl = List.filter (fun id -> not (Id.Set.mem id old_idl))(pf_ids_of_hyps gl) in - let flag = Genredexpr.Cbv { Redops.all_flags with Genredexpr.rDelta = false } in + let sigma = project gl in + let princ_infos = compute_elim_sig (project gl) princ_type in + let args_as_induction_constr = + let c_list = if princ_infos.Tactics.farg_in_concl then [c] else [] in + if List.length args + List.length c_list = 0 then + user_err Pp.(str "Cannot recognize a valid functional scheme"); + let encoded_pat_as_patlist = + List.make (List.length args + List.length c_list - 1) None @ [pat] + in + List.map2 + (fun c pat -> + ( ( None + , ElimOnConstr + (fun env sigma -> (sigma, (c, Tactypes.NoBindings))) ) + , (None, pat) + , None )) + (args @ c_list) encoded_pat_as_patlist + in + let princ' = Some (princ, bindings) in + let princ_vars = + List.fold_right + (fun a acc -> + try Id.Set.add (destVar sigma a) acc with DestKO -> acc) + args Id.Set.empty + in + let old_idl = + List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty + in + let old_idl = Id.Set.diff old_idl princ_vars in + let subst_and_reduce gl = + if with_clean then + let idl = + List.filter + (fun id -> not (Id.Set.mem id old_idl)) + (pf_ids_of_hyps gl) + in + let flag = + Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false} + in + tclTHEN + (tclMAP + (fun id -> + tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) + idl) + (reduce flag Locusops.allHypsAndConcl) + else tclIDTAC + in tclTHEN - (tclMAP (fun id -> tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl) - (reduce flag Locusops.allHypsAndConcl) - else tclIDTAC - in - tclTHEN - (choose_dest_or_ind - princ_infos - (args_as_induction_constr,princ')) - (Proofview.Goal.enter subst_and_reduce)) + (choose_dest_or_ind princ_infos (args_as_induction_constr, princ')) + (Proofview.Goal.enter subst_and_reduce)) diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 4f3d4a1587..daabc4e7c6 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -8,8 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val functional_induction - : bool +val functional_induction : + bool -> EConstr.constr -> (EConstr.constr * EConstr.constr Tactypes.bindings) option -> Ltac_plugin.Tacexpr.or_and_intro_pattern option diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 7d87fc0220..e83fe56cc9 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -4,112 +4,96 @@ open Constr open Libnames open Refiner -let mk_prefix pre id = Id.of_string (pre^(Id.to_string id)) +let mk_prefix pre id = Id.of_string (pre ^ Id.to_string id) let mk_rel_id = mk_prefix "R_" let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" let mk_equation_id id = Nameops.add_suffix id "_equation" -let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) +let fresh_id avoid s = + Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) let fresh_name avoid s = Name (fresh_id avoid s) -let get_name avoid ?(default="H") = function +let get_name avoid ?(default = "H") = function | Anonymous -> fresh_name avoid default | Name n -> Name n -let array_get_start a = - Array.init - (Array.length a - 1) - (fun i -> a.(i)) - +let array_get_start a = Array.init (Array.length a - 1) (fun i -> a.(i)) let locate qid = Nametab.locate qid let locate_ind ref = - match locate ref with - | GlobRef.IndRef x -> x - | _ -> raise Not_found + match locate ref with GlobRef.IndRef x -> x | _ -> raise Not_found let locate_constant ref = - match locate ref with - | GlobRef.ConstRef x -> x - | _ -> raise Not_found - - -let locate_with_msg msg f x = - try f x - with - | Not_found -> - CErrors.user_err msg + match locate ref with GlobRef.ConstRef x -> x | _ -> raise Not_found +let locate_with_msg msg f x = try f x with Not_found -> CErrors.user_err msg let filter_map filter f = let rec it = function | [] -> [] - | e::l -> - if filter e - then - (f e) :: it l - else it l + | e :: l -> if filter e then f e :: it l else it l in it - -let chop_rlambda_n = +let chop_rlambda_n = let rec chop_lambda_n acc n rt = - if n == 0 - then List.rev acc,rt - else - match DAst.get rt with - | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b - | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b - | _ -> - CErrors.user_err ~hdr:"chop_rlambda_n" (str "chop_rlambda_n: Not enough Lambdas") + if n == 0 then (List.rev acc, rt) + else + match DAst.get rt with + | Glob_term.GLambda (name, k, t, b) -> + chop_lambda_n ((name, t, None) :: acc) (n - 1) b + | Glob_term.GLetIn (name, v, t, b) -> + chop_lambda_n ((name, v, t) :: acc) (n - 1) b + | _ -> + CErrors.user_err ~hdr:"chop_rlambda_n" + (str "chop_rlambda_n: Not enough Lambdas") in chop_lambda_n [] -let chop_rprod_n = +let chop_rprod_n = let rec chop_prod_n acc n rt = - if n == 0 - then List.rev acc,rt - else - match DAst.get rt with - | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> - CErrors.user_err ~hdr:"chop_rprod_n" (str "chop_rprod_n: Not enough products") + if n == 0 then (List.rev acc, rt) + else + match DAst.get rt with + | Glob_term.GProd (name, k, t, b) -> + chop_prod_n ((name, t) :: acc) (n - 1) b + | _ -> + CErrors.user_err ~hdr:"chop_rprod_n" + (str "chop_rprod_n: Not enough products") in chop_prod_n [] - - let list_union_eq eq_fun l1 l2 = let rec urec = function | [] -> l2 - | a::l -> if List.exists (eq_fun a) l2 then urec l else a::urec l + | a :: l -> if List.exists (eq_fun a) l2 then urec l else a :: urec l in urec l1 -let list_add_set_eq eq_fun x l = - if List.exists (eq_fun x) l then l else x::l - -let coq_constant s = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s;; +let list_add_set_eq eq_fun x l = if List.exists (eq_fun x) l then l else x :: l +let coq_constant s = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in Nametab.locate (make_qualid dp (Id.of_string s)) -let eq = lazy(EConstr.of_constr (coq_constant "core.eq.type")) -let refl_equal = lazy(EConstr.of_constr (coq_constant "core.eq.refl")) +let eq = lazy (EConstr.of_constr (coq_constant "core.eq.type")) +let refl_equal = lazy (EConstr.of_constr (coq_constant "core.eq.refl")) let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () - and old_strict_implicit_args = Impargs.is_strict_implicit_args () + and old_strict_implicit_args = Impargs.is_strict_implicit_args () and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in let old_rawprint = !Flags.raw_print in let old_printuniverses = !Constrextern.print_universes in - let old_printallowmatchdefaultclause = !Detyping.print_allow_match_default_clause in + let old_printallowmatchdefaultclause = + Detyping.print_allow_match_default_clause () + in Constrextern.print_universes := true; - Detyping.print_allow_match_default_clause := false; + Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name + false; Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; @@ -122,47 +106,41 @@ let with_full_print f a = Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Constrextern.print_universes := old_printuniverses; - Detyping.print_allow_match_default_clause := old_printallowmatchdefaultclause; + Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name + old_printallowmatchdefaultclause; Dumpglob.continue (); res - with - | reraise -> - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Flags.raw_print := old_rawprint; - Constrextern.print_universes := old_printuniverses; - Detyping.print_allow_match_default_clause := old_printallowmatchdefaultclause; - Dumpglob.continue (); - raise reraise - - - - - + with reraise -> + Impargs.make_implicit_args old_implicit_args; + Impargs.make_strict_implicit_args old_strict_implicit_args; + Impargs.make_contextual_implicit_args old_contextual_implicit_args; + Flags.raw_print := old_rawprint; + Constrextern.print_universes := old_printuniverses; + Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name + old_printallowmatchdefaultclause; + Dumpglob.continue (); + raise reraise (**********************) type function_info = - { - function_constant : Constant.t; - graph_ind : inductive; - equation_lemma : Constant.t option; - correctness_lemma : Constant.t option; - completeness_lemma : Constant.t option; - rect_lemma : Constant.t option; - rec_lemma : Constant.t option; - prop_lemma : Constant.t option; - sprop_lemma : Constant.t option; - is_general : bool; (* Has this function been defined using general recursive definition *) - } - + { function_constant : Constant.t + ; graph_ind : inductive + ; equation_lemma : Constant.t option + ; correctness_lemma : Constant.t option + ; completeness_lemma : Constant.t option + ; rect_lemma : Constant.t option + ; rec_lemma : Constant.t option + ; prop_lemma : Constant.t option + ; sprop_lemma : Constant.t option + ; is_general : bool + (* Has this function been defined using general recursive definition *) + } (* type function_db = function_info list *) (* let function_table = ref ([] : function_db) *) - let from_function = Summary.ref Cmap_env.empty ~name:"functions_db_fn" let from_graph = Summary.ref Indmap.empty ~name:"functions_db_gr" @@ -187,91 +165,105 @@ let cache_Function (_,(finfos)) = then function_table := new_tbl *) -let cache_Function (_,finfos) = +let cache_Function (_, finfos) = from_function := Cmap_env.add finfos.function_constant finfos !from_function; from_graph := Indmap.add finfos.graph_ind finfos !from_graph - -let subst_Function (subst,finfos) = +let subst_Function (subst, finfos) = let do_subst_con c = Mod_subst.subst_constant subst c - and do_subst_ind i = Mod_subst.subst_ind subst i - in + and do_subst_ind i = Mod_subst.subst_ind subst i in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in let equation_lemma' = Option.Smart.map do_subst_con finfos.equation_lemma in - let correctness_lemma' = Option.Smart.map do_subst_con finfos.correctness_lemma in - let completeness_lemma' = Option.Smart.map do_subst_con finfos.completeness_lemma in + let correctness_lemma' = + Option.Smart.map do_subst_con finfos.correctness_lemma + in + let completeness_lemma' = + Option.Smart.map do_subst_con finfos.completeness_lemma + in let rect_lemma' = Option.Smart.map do_subst_con finfos.rect_lemma in let rec_lemma' = Option.Smart.map do_subst_con finfos.rec_lemma in - let prop_lemma' = Option.Smart.map do_subst_con finfos.prop_lemma in + let prop_lemma' = Option.Smart.map do_subst_con finfos.prop_lemma in let sprop_lemma' = Option.Smart.map do_subst_con finfos.sprop_lemma in - if function_constant' == finfos.function_constant && - graph_ind' == finfos.graph_ind && - equation_lemma' == finfos.equation_lemma && - correctness_lemma' == finfos.correctness_lemma && - completeness_lemma' == finfos.completeness_lemma && - rect_lemma' == finfos.rect_lemma && - rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma && - sprop_lemma' == finfos.sprop_lemma + if + function_constant' == finfos.function_constant + && graph_ind' == finfos.graph_ind + && equation_lemma' == finfos.equation_lemma + && correctness_lemma' == finfos.correctness_lemma + && completeness_lemma' == finfos.completeness_lemma + && rect_lemma' == finfos.rect_lemma + && rec_lemma' == finfos.rec_lemma + && prop_lemma' == finfos.prop_lemma + && sprop_lemma' == finfos.sprop_lemma then finfos else - { function_constant = function_constant'; - graph_ind = graph_ind'; - equation_lemma = equation_lemma' ; - correctness_lemma = correctness_lemma' ; - completeness_lemma = completeness_lemma' ; - rect_lemma = rect_lemma' ; - rec_lemma = rec_lemma'; - prop_lemma = prop_lemma'; - sprop_lemma = sprop_lemma'; - is_general = finfos.is_general - } - -let discharge_Function (_,finfos) = Some finfos + { function_constant = function_constant' + ; graph_ind = graph_ind' + ; equation_lemma = equation_lemma' + ; correctness_lemma = correctness_lemma' + ; completeness_lemma = completeness_lemma' + ; rect_lemma = rect_lemma' + ; rec_lemma = rec_lemma' + ; prop_lemma = prop_lemma' + ; sprop_lemma = sprop_lemma' + ; is_general = finfos.is_general } + +let discharge_Function (_, finfos) = Some finfos let pr_ocst env sigma c = - Option.fold_right (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) c (mt ()) + Option.fold_right + (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) + c (mt ()) let pr_info env sigma f_info = - str "function_constant := " ++ - Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant)++ fnl () ++ - str "function_constant_type := " ++ - (try - Printer.pr_lconstr_env env sigma - (fst (Typeops.type_of_global_in_context env (GlobRef.ConstRef f_info.function_constant))) - with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ - str "equation_lemma := " ++ pr_ocst env sigma f_info.equation_lemma ++ fnl () ++ - str "completeness_lemma :=" ++ pr_ocst env sigma f_info.completeness_lemma ++ fnl () ++ - str "correctness_lemma := " ++ pr_ocst env sigma f_info.correctness_lemma ++ fnl () ++ - str "rect_lemma := " ++ pr_ocst env sigma f_info.rect_lemma ++ fnl () ++ - str "rec_lemma := " ++ pr_ocst env sigma f_info.rec_lemma ++ fnl () ++ - str "prop_lemma := " ++ pr_ocst env sigma f_info.prop_lemma ++ fnl () ++ - str "graph_ind := " ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) ++ fnl () + str "function_constant := " + ++ Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant) + ++ fnl () + ++ str "function_constant_type := " + ++ ( try + Printer.pr_lconstr_env env sigma + (fst + (Typeops.type_of_global_in_context env + (GlobRef.ConstRef f_info.function_constant))) + with e when CErrors.noncritical e -> mt () ) + ++ fnl () ++ str "equation_lemma := " + ++ pr_ocst env sigma f_info.equation_lemma + ++ fnl () + ++ str "completeness_lemma :=" + ++ pr_ocst env sigma f_info.completeness_lemma + ++ fnl () + ++ str "correctness_lemma := " + ++ pr_ocst env sigma f_info.correctness_lemma + ++ fnl () ++ str "rect_lemma := " + ++ pr_ocst env sigma f_info.rect_lemma + ++ fnl () ++ str "rec_lemma := " + ++ pr_ocst env sigma f_info.rec_lemma + ++ fnl () ++ str "prop_lemma := " + ++ pr_ocst env sigma f_info.prop_lemma + ++ fnl () ++ str "graph_ind := " + ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) + ++ fnl () let pr_table env sigma tb = - let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in + let l = Cmap_env.fold (fun k v acc -> v :: acc) tb [] in Pp.prlist_with_sep fnl (pr_info env sigma) l let in_Function : function_info -> Libobject.obj = let open Libobject in - declare_object @@ superglobal_object "FUNCTIONS_DB" - ~cache:cache_Function - ~subst:(Some subst_Function) - ~discharge:discharge_Function - + declare_object + @@ superglobal_object "FUNCTIONS_DB" ~cache:cache_Function + ~subst:(Some subst_Function) ~discharge:discharge_Function let find_or_none id = - try Some - (match Nametab.locate (qualid_of_ident id) with GlobRef.ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant.") - ) + try + Some + ( match Nametab.locate (qualid_of_ident id) with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) with Not_found -> None -let find_Function_infos f = - Cmap_env.find_opt f !from_function - -let find_Function_of_graph ind = - Indmap.find_opt ind !from_graph +let find_Function_infos f = Cmap_env.find_opt f !from_function +let find_Function_of_graph ind = Indmap.find_opt ind !from_graph let update_Function finfo = (* Pp.msgnl (pr_info finfo); *) @@ -287,136 +279,102 @@ let add_Function is_general f = and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") and sprop_lemma = find_or_none (Nameops.add_suffix f_id "_sind") and graph_ind = - match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) - with | GlobRef.IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive.") + match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) with + | GlobRef.IndRef ind -> ind + | _ -> CErrors.anomaly (Pp.str "Not an inductive.") in let finfos = - { function_constant = f; - equation_lemma = equation_lemma; - completeness_lemma = completeness_lemma; - correctness_lemma = correctness_lemma; - rect_lemma = rect_lemma; - rec_lemma = rec_lemma; - prop_lemma = prop_lemma; - sprop_lemma = sprop_lemma; - graph_ind = graph_ind; - is_general = is_general - - } + { function_constant = f + ; equation_lemma + ; completeness_lemma + ; correctness_lemma + ; rect_lemma + ; rec_lemma + ; prop_lemma + ; sprop_lemma + ; graph_ind + ; is_general } in update_Function finfos let pr_table env sigma = pr_table env sigma !from_function + (*********************************) (* Debugging *) -let functional_induction_rewrite_dependent_proofs = ref true -let function_debug = ref false -open Goptions - -let functional_induction_rewrite_dependent_proofs_sig = - { - optdepr = false; - optkey = ["Functional";"Induction";"Rewrite";"Dependent"]; - optread = (fun () -> !functional_induction_rewrite_dependent_proofs); - optwrite = (fun b -> functional_induction_rewrite_dependent_proofs := b) - } -let () = declare_bool_option functional_induction_rewrite_dependent_proofs_sig - -let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = true - -let function_debug_sig = - { - optdepr = false; - optkey = ["Function_debug"]; - optread = (fun () -> !function_debug); - optwrite = (fun b -> function_debug := b) - } - -let () = declare_bool_option function_debug_sig - -let do_observe () = !function_debug +let do_rewrite_dependent = + Goptions.declare_bool_option_and_ref ~depr:false + ~key:["Functional"; "Induction"; "Rewrite"; "Dependent"] + ~value:true -let observe strm = - if do_observe () - then Feedback.msg_debug strm - else () +let do_observe = + Goptions.declare_bool_option_and_ref ~depr:false ~key:["Function_debug"] + ~value:false +let observe strm = if do_observe () then Feedback.msg_debug strm else () let debug_queue = Stack.create () let print_debug_queue b e = - if not (Stack.is_empty debug_queue) - then - let lmsg,goal = Stack.pop debug_queue in - (if b then - Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) - else - Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)) - (* print_debug_queue false e; *) - ) + if not (Stack.is_empty debug_queue) then + let lmsg, goal = Stack.pop debug_queue in + if b then + Feedback.msg_debug + (hov 1 + ( lmsg + ++ (str " raised exception " ++ CErrors.print e) + ++ str " on goal" ++ fnl () ++ goal )) + else + Feedback.msg_debug + (hov 1 (str " from " ++ lmsg ++ str " on goal" ++ fnl () ++ goal)) + +(* print_debug_queue false e; *) let do_observe_tac s tac g = let goal = Printer.pr_goal g in let s = s (pf_env g) (project g) in - let lmsg = (str "observation : ") ++ s in - Stack.push (lmsg,goal) debug_queue; + let lmsg = str "observation : " ++ s in + Stack.push (lmsg, goal) debug_queue; try let v = tac g in - ignore(Stack.pop debug_queue); + ignore (Stack.pop debug_queue); v with reraise -> let reraise = Exninfo.capture reraise in - if not (Stack.is_empty debug_queue) - then print_debug_queue true (fst reraise); + if not (Stack.is_empty debug_queue) then + print_debug_queue true (fst reraise); Exninfo.iraise reraise let observe_tac s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g + if do_observe () then do_observe_tac s tac g else tac g module New = struct - -let do_observe_tac ~header s tac = - let open Proofview.Notations in - let open Proofview in - Goal.enter begin fun gl -> - let goal = Printer.pr_goal (Goal.print gl) in - let env, sigma = Goal.env gl, Goal.sigma gl in - let s = s env sigma in - let lmsg = seq [header; str " : " ++ s] in - tclLIFT (NonLogical.make (fun () -> - Feedback.msg_debug (s++fnl()))) >>= fun () -> - tclOR ( - Stack.push (lmsg, goal) debug_queue; - tac >>= fun v -> - ignore(Stack.pop debug_queue); - Proofview.tclUNIT v) - (fun (exn, info) -> - if not (Stack.is_empty debug_queue) - then print_debug_queue true exn; - tclZERO ~info exn) - end - -let observe_tac ~header s tac = - if do_observe () - then do_observe_tac ~header s tac - else tac - + let do_observe_tac ~header s tac = + let open Proofview.Notations in + let open Proofview in + Goal.enter (fun gl -> + let goal = Printer.pr_goal (Goal.print gl) in + let env, sigma = (Goal.env gl, Goal.sigma gl) in + let s = s env sigma in + let lmsg = seq [header; str " : " ++ s] in + tclLIFT (NonLogical.make (fun () -> Feedback.msg_debug (s ++ fnl ()))) + >>= fun () -> + tclOR + ( Stack.push (lmsg, goal) debug_queue; + tac + >>= fun v -> + ignore (Stack.pop debug_queue); + Proofview.tclUNIT v ) + (fun (exn, info) -> + if not (Stack.is_empty debug_queue) then print_debug_queue true exn; + tclZERO ~info exn)) + + let observe_tac ~header s tac = + if do_observe () then do_observe_tac ~header s tac else tac end -let strict_tcc = ref false -let is_strict_tcc () = !strict_tcc -let strict_tcc_sig = - { - optdepr = false; - optkey = ["Function_raw_tcc"]; - optread = (fun () -> !strict_tcc); - optwrite = (fun b -> strict_tcc := b) - } - -let () = declare_bool_option strict_tcc_sig - +let is_strict_tcc = + Goptions.declare_bool_option_and_ref ~depr:false ~key:["Function_raw_tcc"] + ~value:false exception Building_graph of exn exception Defining_principle of exn @@ -425,17 +383,15 @@ exception ToShow of exn let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - EConstr.of_constr @@ - UnivGen.constr_of_monomorphic_global @@ - Coqlib.lib_ref "core.JMeq.type" + EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.JMeq.type" with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - EConstr.of_constr @@ - UnivGen.constr_of_monomorphic_global @@ - Coqlib.lib_ref "core.JMeq.refl" + EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.JMeq.refl" with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = @@ -443,49 +399,67 @@ let h_intros l = let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" -let well_founded = function () -> EConstr.of_constr (coq_constant "core.wf.well_founded") + +let well_founded = function + | () -> EConstr.of_constr (coq_constant "core.wf.well_founded") + let acc_rel = function () -> EConstr.of_constr (coq_constant "core.wf.acc") -let acc_inv_id = function () -> EConstr.of_constr (coq_constant "core.wf.acc_inv") -let well_founded_ltof () = EConstr.of_constr (coq_constant "num.nat.well_founded_ltof") +let acc_inv_id = function + | () -> EConstr.of_constr (coq_constant "core.wf.acc_inv") + +let well_founded_ltof () = + EConstr.of_constr (coq_constant "num.nat.well_founded_ltof") -let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") +let ltof_ref = function () -> find_reference ["Coq"; "Arith"; "Wf_nat"] "ltof" let make_eq () = - try EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) + try + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) with _ -> assert false -let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) +let evaluable_of_global_reference r = + (* Tacred.evaluable_of_global_reference (Global.env ()) *) match r with - GlobRef.ConstRef sp -> EvalConstRef sp - | GlobRef.VarRef id -> EvalVarRef id - | _ -> assert false;; + | GlobRef.ConstRef sp -> EvalConstRef sp + | GlobRef.VarRef id -> EvalVarRef id + | _ -> assert false -let list_rewrite (rev:bool) (eqs: (EConstr.constr*bool) list) = +let list_rewrite (rev : bool) (eqs : (EConstr.constr * bool) list) = tclREPEAT (List.fold_right - (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i) - (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; + (fun (eq, b) i -> + tclORELSE + (Proofview.V82.of_tactic + ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) + i) + (if rev then List.rev eqs else eqs) + (tclFAIL 0 (mt ()))) let decompose_lam_n sigma n = - if n < 0 then CErrors.user_err Pp.(str "decompose_lam_n: integer parameter must be positive"); + if n < 0 then + CErrors.user_err + Pp.(str "decompose_lam_n: integer parameter must be positive"); let rec lamdec_rec l n c = - if Int.equal n 0 then l,c - else match EConstr.kind sigma c with - | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c - | Cast (c,_,_) -> lamdec_rec l n c - | _ -> CErrors.user_err Pp.(str "decompose_lam_n: not enough abstractions") + if Int.equal n 0 then (l, c) + else + match EConstr.kind sigma c with + | Lambda (x, t, c) -> lamdec_rec ((x, t) :: l) (n - 1) c + | Cast (c, _, _) -> lamdec_rec l n c + | _ -> + CErrors.user_err Pp.(str "decompose_lam_n: not enough abstractions") in lamdec_rec [] n let lamn n env b = let open EConstr in let rec lamrec = function - | (0, env, b) -> b - | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) + | 0, env, b -> b + | n, (v, t) :: l, b -> lamrec (n - 1, l, mkLambda (v, t, b)) | _ -> assert false in - lamrec (n,env,b) + lamrec (n, env, b) (* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) let compose_lam l b = lamn (List.length l) l b @@ -494,19 +468,16 @@ let compose_lam l b = lamn (List.length l) l b let prodn n env b = let open EConstr in let rec prodrec = function - | (0, env, b) -> b - | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) + | 0, env, b -> b + | n, (v, t) :: l, b -> prodrec (n - 1, l, mkProd (v, t, b)) | _ -> assert false in - prodrec (n,env,b) + prodrec (n, env, b) (* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) let compose_prod l b = prodn (List.length l) l b -type tcc_lemma_value = - | Undefined - | Value of constr - | Not_needed +type tcc_lemma_value = Undefined | Value of constr | Not_needed (* We only "purify" on exceptions. XXX: What is this doing here? *) let funind_purify f x = @@ -519,4 +490,4 @@ let funind_purify f x = let tac_type_of g c = let sigma, t = Tacmach.pf_type_of g c in - {g with Evd.sigma}, t + ({g with Evd.sigma}, t) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index bd8b34088b..396db55458 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -8,30 +8,27 @@ val mk_rel_id : Id.t -> Id.t val mk_correct_id : Id.t -> Id.t val mk_complete_id : Id.t -> Id.t val mk_equation_id : Id.t -> Id.t - val fresh_id : Id.t list -> string -> Id.t val fresh_name : Id.t list -> string -> Name.t val get_name : Id.t list -> ?default:string -> Name.t -> Name.t - val array_get_start : 'a array -> 'a array - val locate_ind : Libnames.qualid -> inductive val locate_constant : Libnames.qualid -> Constant.t -val locate_with_msg : - Pp.t -> (Libnames.qualid -> 'a) -> - Libnames.qualid -> 'a - +val locate_with_msg : Pp.t -> (Libnames.qualid -> 'a) -> Libnames.qualid -> 'a val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list -val list_union_eq : - ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list -val list_add_set_eq : - ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list +val list_union_eq : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list +val list_add_set_eq : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list -val chop_rlambda_n : int -> Glob_term.glob_constr -> - (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list * Glob_term.glob_constr +val chop_rlambda_n : + int + -> Glob_term.glob_constr + -> (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list + * Glob_term.glob_constr -val chop_rprod_n : int -> Glob_term.glob_constr -> - (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr +val chop_rprod_n : + int + -> Glob_term.glob_constr + -> (Name.t * Glob_term.glob_constr) list * Glob_term.glob_constr val eq : EConstr.constr Lazy.t val refl_equal : EConstr.constr Lazy.t @@ -45,44 +42,41 @@ val make_eq : unit -> EConstr.constr *) val with_full_print : ('a -> 'b) -> 'a -> 'b - (*****************) type function_info = - { - function_constant : Constant.t; - graph_ind : inductive; - equation_lemma : Constant.t option; - correctness_lemma : Constant.t option; - completeness_lemma : Constant.t option; - rect_lemma : Constant.t option; - rec_lemma : Constant.t option; - prop_lemma : Constant.t option; - sprop_lemma : Constant.t option; - is_general : bool; - } + { function_constant : Constant.t + ; graph_ind : inductive + ; equation_lemma : Constant.t option + ; correctness_lemma : Constant.t option + ; completeness_lemma : Constant.t option + ; rect_lemma : Constant.t option + ; rec_lemma : Constant.t option + ; prop_lemma : Constant.t option + ; sprop_lemma : Constant.t option + ; is_general : bool } val find_Function_infos : Constant.t -> function_info option val find_Function_of_graph : inductive -> function_info option + (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> Constant.t -> unit val update_Function : function_info -> unit (** debugging *) val pr_info : Environ.env -> Evd.evar_map -> function_info -> Pp.t + val pr_table : Environ.env -> Evd.evar_map -> Pp.t -val observe_tac - : (Environ.env -> Evd.evar_map -> Pp.t) - -> Tacmach.tactic -> Tacmach.tactic +val observe_tac : + (Environ.env -> Evd.evar_map -> Pp.t) -> Tacmach.tactic -> Tacmach.tactic module New : sig - - val observe_tac - : header:Pp.t + val observe_tac : + header:Pp.t -> (Environ.env -> Evd.evar_map -> Pp.t) - -> unit Proofview.tactic -> unit Proofview.tactic - + -> unit Proofview.tactic + -> unit Proofview.tactic end (* val function_debug : bool ref *) @@ -96,28 +90,35 @@ exception Defining_principle of exn exception ToShow of exn val is_strict_tcc : unit -> bool - -val h_intros: Names.Id.t list -> Tacmach.tactic -val h_id : Names.Id.t -val hrec_id : Names.Id.t -val acc_inv_id : EConstr.constr Util.delayed +val h_intros : Names.Id.t list -> Tacmach.tactic +val h_id : Names.Id.t +val hrec_id : Names.Id.t +val acc_inv_id : EConstr.constr Util.delayed val ltof_ref : GlobRef.t Util.delayed val well_founded_ltof : EConstr.constr Util.delayed val acc_rel : EConstr.constr Util.delayed val well_founded : EConstr.constr Util.delayed -val evaluable_of_global_reference : GlobRef.t -> Names.evaluable_global_reference -val list_rewrite : bool -> (EConstr.constr*bool) list -> Tacmach.tactic -val decompose_lam_n : Evd.evar_map -> int -> EConstr.t -> - (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t -val compose_lam : (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t -val compose_prod : (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t +val evaluable_of_global_reference : + GlobRef.t -> Names.evaluable_global_reference + +val list_rewrite : bool -> (EConstr.constr * bool) list -> Tacmach.tactic + +val decompose_lam_n : + Evd.evar_map + -> int + -> EConstr.t + -> (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t + +val compose_lam : + (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t + +val compose_prod : + (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t -type tcc_lemma_value = - | Undefined - | Value of Constr.t - | Not_needed +type tcc_lemma_value = Undefined | Value of Constr.t | Not_needed -val funind_purify : ('a -> 'b) -> ('a -> 'b) +val funind_purify : ('a -> 'b) -> 'a -> 'b -val tac_type_of : Goal.goal Evd.sigma -> EConstr.constr -> Goal.goal Evd.sigma * EConstr.types +val tac_type_of : + Goal.goal Evd.sigma -> EConstr.constr -> Goal.goal Evd.sigma * EConstr.types diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 44d2cb4a3d..5d631aac84 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -15,7 +15,6 @@ open EConstr open Tacmach.New open Tactics open Tacticals.New - open Indfun_common (***********************************************) @@ -26,36 +25,40 @@ open Indfun_common if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) -let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> - let sigma = project gl in - let typ = pf_get_hyp_typ hid gl in - match EConstr.kind sigma typ with - | App(i,args) when isInd sigma i -> - let ((kn',num) as ind'),u = destInd sigma i in - if MutInd.equal kn kn' - then (* We have generated a graph hypothesis so that we must change it if we can *) - let info = match find_Function_of_graph ind' with - | Some info -> info - | None -> - (* The graphs are mutually recursive but we cannot find one of them !*) - CErrors.anomaly (Pp.str "Cannot retrieve infos about a mutual block.") - in - (* if we can find a completeness lemma for this function - then we can come back to the functional form. If not, we do nothing - *) - match info.completeness_lemma with - | None -> tclIDTAC - | Some f_complete -> - let f_args,res = Array.chop (Array.length args - 1) args in - tclTHENLIST - [ generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])] - ; clear [hid] - ; Simple.intro hid - ; post_tac hid - ] - else tclIDTAC - | _ -> tclIDTAC - ) +let revert_graph kn post_tac hid = + Proofview.Goal.enter (fun gl -> + let sigma = project gl in + let typ = pf_get_hyp_typ hid gl in + match EConstr.kind sigma typ with + | App (i, args) when isInd sigma i -> + let ((kn', num) as ind'), u = destInd sigma i in + if MutInd.equal kn kn' then + (* We have generated a graph hypothesis so that we must change it if we can *) + let info = + match find_Function_of_graph ind' with + | Some info -> info + | None -> + (* The graphs are mutually recursive but we cannot find one of them !*) + CErrors.anomaly + (Pp.str "Cannot retrieve infos about a mutual block.") + in + (* if we can find a completeness lemma for this function + then we can come back to the functional form. If not, we do nothing + *) + match info.completeness_lemma with + | None -> tclIDTAC + | Some f_complete -> + let f_args, res = Array.chop (Array.length args - 1) args in + tclTHENLIST + [ generalize + [ applist + ( mkConst f_complete + , Array.to_list f_args @ [res.(0); mkVar hid] ) ] + ; clear [hid] + ; Simple.intro hid + ; post_tac hid ] + else tclIDTAC + | _ -> tclIDTAC) (* [functional_inversion hid fconst f_correct ] is the functional version of [inversion] @@ -74,52 +77,55 @@ let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> \end{enumerate} *) -let functional_inversion kn hid fconst f_correct = Proofview.Goal.enter (fun gl -> - let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in - let sigma = project gl in - let type_of_h = pf_get_hyp_typ hid gl in - match EConstr.kind sigma type_of_h with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - let pre_tac,f_args,res = - match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with - | App(f,f_args),_ when EConstr.eq_constr sigma f fconst -> - ((fun hid -> intros_symmetry (Locusops.onHyp hid))),f_args,args.(2) - |_,App(f,f_args) when EConstr.eq_constr sigma f fconst -> - ((fun hid -> tclIDTAC),f_args,args.(1)) - | _ -> (fun hid -> tclFAIL 1 Pp.(mt ())),[||],args.(2) - in - tclTHENLIST - [ pre_tac hid - ; generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])] - ; clear [hid] - ; Simple.intro hid - ; Inv.inv Inv.FullInversion None (Tactypes.NamedHyp hid) - ; Proofview.Goal.enter (fun gl -> - let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps gl) in - tclMAP (revert_graph kn pre_tac) (hid::new_ids) - ) - ] - | _ -> tclFAIL 1 Pp.(mt ()) - ) +let functional_inversion kn hid fconst f_correct = + Proofview.Goal.enter (fun gl -> + let old_ids = + List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty + in + let sigma = project gl in + let type_of_h = pf_get_hyp_typ hid gl in + match EConstr.kind sigma type_of_h with + | App (eq, args) when EConstr.eq_constr sigma eq (make_eq ()) -> + let pre_tac, f_args, res = + match (EConstr.kind sigma args.(1), EConstr.kind sigma args.(2)) with + | App (f, f_args), _ when EConstr.eq_constr sigma f fconst -> + ((fun hid -> intros_symmetry (Locusops.onHyp hid)), f_args, args.(2)) + | _, App (f, f_args) when EConstr.eq_constr sigma f fconst -> + ((fun hid -> tclIDTAC), f_args, args.(1)) + | _ -> ((fun hid -> tclFAIL 1 Pp.(mt ())), [||], args.(2)) + in + tclTHENLIST + [ pre_tac hid + ; generalize + [applist (f_correct, Array.to_list f_args @ [res; mkVar hid])] + ; clear [hid] + ; Simple.intro hid + ; Inv.inv Inv.FullInversion None (Tactypes.NamedHyp hid) + ; Proofview.Goal.enter (fun gl -> + let new_ids = + List.filter + (fun id -> not (Id.Set.mem id old_ids)) + (pf_ids_of_hyps gl) + in + tclMAP (revert_graph kn pre_tac) (hid :: new_ids)) ] + | _ -> tclFAIL 1 Pp.(mt ())) -let invfun qhyp f = +let invfun qhyp f = let f = match f with | GlobRef.ConstRef f -> f - | _ -> - CErrors.user_err Pp.(str "Not a function") + | _ -> CErrors.user_err Pp.(str "Not a function") in match find_Function_infos f with - | None -> - CErrors.user_err (Pp.str "No graph found") - | Some finfos -> + | None -> CErrors.user_err (Pp.str "No graph found") + | Some finfos -> ( match finfos.correctness_lemma with - | None -> - CErrors.user_err (Pp.str "Cannot use equivalence with graph!") + | None -> CErrors.user_err (Pp.str "Cannot use equivalence with graph!") | Some f_correct -> - let f_correct = mkConst f_correct - and kn = fst finfos.graph_ind in - Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp + let f_correct = mkConst f_correct and kn = fst finfos.graph_ind in + Tactics.try_intros_until + (fun hid -> functional_inversion kn hid (mkConst f) f_correct) + qhyp ) let invfun qhyp f = let exception NoFunction in @@ -128,41 +134,55 @@ let invfun qhyp f = | None -> let tac_action hid gl = let sigma = project gl in - let hyp_typ = pf_get_hyp_typ hid gl in + let hyp_typ = pf_get_hyp_typ hid gl in match EConstr.kind sigma hyp_typ with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - begin - let f1,_ = decompose_app sigma args.(1) in - try - if not (isConst sigma f1) then raise NoFunction; - let finfos = Option.get (find_Function_infos (fst (destConst sigma f1))) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f1 f_correct - with - | NoFunction | Option.IsNone -> - let f2,_ = decompose_app sigma args.(2) in - if isConst sigma f2 then - match find_Function_infos (fst (destConst sigma f2)) with + | App (eq, args) when EConstr.eq_constr sigma eq (make_eq ()) -> ( + let f1, _ = decompose_app sigma args.(1) in + try + if not (isConst sigma f1) then raise NoFunction; + let finfos = + Option.get (find_Function_infos (fst (destConst sigma f1))) + in + let f_correct = mkConst (Option.get finfos.correctness_lemma) + and kn = fst finfos.graph_ind in + functional_inversion kn hid f1 f_correct + with NoFunction | Option.IsNone -> + let f2, _ = decompose_app sigma args.(2) in + if isConst sigma f2 then + match find_Function_infos (fst (destConst sigma f2)) with + | None -> + if do_observe () then + CErrors.user_err + (Pp.str "No graph found for any side of equality") + else + CErrors.user_err + Pp.( + str "Cannot find inversion information for hypothesis " + ++ Ppconstr.pr_id hid) + | Some finfos -> ( + match finfos.correctness_lemma with | None -> - if do_observe () - then CErrors.user_err (Pp.str "No graph found for any side of equality") - else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Some finfos -> - match finfos.correctness_lemma with - | None -> - if do_observe () - then CErrors.user_err (Pp.str "Cannot use equivalence with graph for any side of the equality") - else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Some f_correct -> - let f_correct = mkConst f_correct - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f2 f_correct - else (* NoFunction *) - CErrors.user_err Pp.(str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") - end - | _ -> CErrors.user_err Pp.(Ppconstr.pr_id hid ++ str " must be an equality ") + if do_observe () then + CErrors.user_err + (Pp.str + "Cannot use equivalence with graph for any side of the \ + equality") + else + CErrors.user_err + Pp.( + str "Cannot find inversion information for hypothesis " + ++ Ppconstr.pr_id hid) + | Some f_correct -> + let f_correct = mkConst f_correct + and kn = fst finfos.graph_ind in + functional_inversion kn hid f2 f_correct ) + else + (* NoFunction *) + CErrors.user_err + Pp.( + str "Hypothesis " ++ Ppconstr.pr_id hid + ++ str " must contain at least one Function") ) + | _ -> + CErrors.user_err Pp.(Ppconstr.pr_id hid ++ str " must be an equality ") in try_intros_until (tac_action %> Proofview.Goal.enter) qhyp diff --git a/plugins/funind/invfun.mli b/plugins/funind/invfun.mli index 41dbe1437c..a117df32df 100644 --- a/plugins/funind/invfun.mli +++ b/plugins/funind/invfun.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val invfun - : Tactypes.quantified_hypothesis +val invfun : + Tactypes.quantified_hypothesis -> Names.GlobRef.t option -> unit Proofview.tactic diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 19a762d33d..ffb9a7e69b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -8,9 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) - module CVars = Vars - open Constr open Context open EConstr @@ -29,7 +27,6 @@ open Tacticals open Tacmach open Tactics open Nametab -open Declare open Tacred open Glob_term open Pretyping @@ -37,58 +34,58 @@ open Termops open Constrintern open Tactypes open Genredexpr - open Equality open Auto open Eauto - open Indfun_common open Context.Rel.Declaration (* Ugly things which should not be here *) -let coq_constant s = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ - Coqlib.lib_ref s +let coq_constant s = + EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s let coq_init_constant s = - EConstr.of_constr(UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s) -;; + EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s) let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in locate (make_qualid dp (Id.of_string s)) let declare_fun name kind ?univs value = - let ce = definition_entry ?univs value (*FIXME *) in - GlobRef.ConstRef(declare_constant ~name ~kind (DefinitionEntry ce)) + let ce = Declare.definition_entry ?univs value (*FIXME *) in + GlobRef.ConstRef + (Declare.declare_constant ~name ~kind (Declare.DefinitionEntry ce)) let defined lemma = - Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent ~idopt:None let def_of_const t = - match (Constr.kind t) with - Const sp -> - (try (match constant_opt_value_in (Global.env ()) sp with - | Some c -> c - | _ -> raise Not_found) - with Not_found -> - anomaly (str "Cannot find definition of constant " ++ - (Id.print (Label.to_id (Constant.label (fst sp)))) ++ str ".") - ) - |_ -> assert false + match Constr.kind t with + | Const sp -> ( + try + match constant_opt_value_in (Global.env ()) sp with + | Some c -> c + | _ -> raise Not_found + with Not_found -> + anomaly + ( str "Cannot find definition of constant " + ++ Id.print (Label.to_id (Constant.label (fst sp))) + ++ str "." ) ) + | _ -> assert false let type_of_const sigma t = - match (EConstr.kind sigma t) with - | Const (sp, u) -> - let u = EInstance.kind sigma u in - (* FIXME discarding universe constraints *) - Typeops.type_of_constant_in (Global.env()) (sp, u) - |_ -> assert false + match EConstr.kind sigma t with + | Const (sp, u) -> + let u = EInstance.kind sigma u in + (* FIXME discarding universe constraints *) + Typeops.type_of_constant_in (Global.env ()) (sp, u) + | _ -> assert false let constant sl s = UnivGen.constr_of_monomorphic_global (find_reference sl s) let const_of_ref = function - GlobRef.ConstRef kn -> kn + | GlobRef.ConstRef kn -> kn | _ -> anomaly (Pp.str "ConstRef expected.") (* Generic values *) @@ -96,16 +93,16 @@ let pf_get_new_ids idl g = let ids = pf_ids_of_hyps g in let ids = Id.Set.of_list ids in List.fold_right - (fun id acc -> next_global_ident_away id (Id.Set.union (Id.Set.of_list acc) ids)::acc) - idl - [] + (fun id acc -> + next_global_ident_away id (Id.Set.union (Id.Set.of_list acc) ids) :: acc) + idl [] let next_ident_away_in_goal ids avoid = next_ident_away_in_goal ids (Id.Set.of_list avoid) let compute_renamed_type gls id = - rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty (*no rels*) [] - (pf_get_hyp_typ gls id) + rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty + (*no rels*) [] (pf_get_hyp_typ gls id) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" @@ -115,112 +112,140 @@ let k_id = Id.of_string "k" let v_id = Id.of_string "v" let def_id = Id.of_string "def" let p_id = Id.of_string "p" -let rec_res_id = Id.of_string "rec_res";; -let lt = function () -> (coq_init_constant "num.nat.lt") +let rec_res_id = Id.of_string "rec_res" +let lt = function () -> coq_init_constant "num.nat.lt" let le = function () -> Coqlib.lib_ref "num.nat.le" +let ex = function () -> coq_init_constant "core.ex.type" +let nat = function () -> coq_init_constant "num.nat.type" -let ex = function () -> (coq_init_constant "core.ex.type") -let nat = function () -> (coq_init_constant "num.nat.type") let iter_ref () = try find_reference ["Recdef"] "iter" with Not_found -> user_err Pp.(str "module Recdef not loaded") -let iter_rd = function () -> (constr_of_monomorphic_global (delayed_force iter_ref)) -let eq = function () -> (coq_init_constant "core.eq.type") -let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") -let le_lt_n_Sm = function () -> (coq_constant "num.nat.le_lt_n_Sm") -let le_trans = function () -> (coq_constant "num.nat.le_trans") -let le_lt_trans = function () -> (coq_constant "num.nat.le_lt_trans") -let lt_S_n = function () -> (coq_constant "num.nat.lt_S_n") -let le_n = function () -> (coq_init_constant "num.nat.le_n") -let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig") -let coq_O = function () -> (coq_init_constant "num.nat.O") -let coq_S = function () -> (coq_init_constant"num.nat.S") -let lt_n_O = function () -> (coq_constant "num.nat.nlt_0_r") -let max_ref = function () -> (find_reference ["Recdef"] "max") -let max_constr = function () -> EConstr.of_constr (constr_of_monomorphic_global (delayed_force max_ref)) - -let f_S t = mkApp(delayed_force coq_S, [|t|]);; + +let iter_rd = function + | () -> constr_of_monomorphic_global (delayed_force iter_ref) + +let eq = function () -> coq_init_constant "core.eq.type" +let le_lt_SS = function () -> constant ["Recdef"] "le_lt_SS" +let le_lt_n_Sm = function () -> coq_constant "num.nat.le_lt_n_Sm" +let le_trans = function () -> coq_constant "num.nat.le_trans" +let le_lt_trans = function () -> coq_constant "num.nat.le_lt_trans" +let lt_S_n = function () -> coq_constant "num.nat.lt_S_n" +let le_n = function () -> coq_init_constant "num.nat.le_n" + +let coq_sig_ref = function + | () -> find_reference ["Coq"; "Init"; "Specif"] "sig" + +let coq_O = function () -> coq_init_constant "num.nat.O" +let coq_S = function () -> coq_init_constant "num.nat.S" +let lt_n_O = function () -> coq_constant "num.nat.nlt_0_r" +let max_ref = function () -> find_reference ["Recdef"] "max" + +let max_constr = function + | () -> + EConstr.of_constr (constr_of_monomorphic_global (delayed_force max_ref)) + +let f_S t = mkApp (delayed_force coq_S, [|t|]) let rec n_x_id ids n = if Int.equal n 0 then [] - else let x = next_ident_away_in_goal x_id ids in - x::n_x_id (x::ids) (n-1);; - + else + let x = next_ident_away_in_goal x_id ids in + x :: n_x_id (x :: ids) (n - 1) let simpl_iter clause = reduce (Lazy - {rBeta=true;rMatch=true;rFix=true;rCofix=true;rZeta=true;rDelta=false; - rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) + { rBeta = true + ; rMatch = true + ; rFix = true + ; rCofix = true + ; rZeta = true + ; rDelta = false + ; rConst = [EvalConstRef (const_of_ref (delayed_force iter_ref))] }) clause (* Others ugly things ... *) -let (value_f: Constr.t list -> GlobRef.t -> Constr.t) = +let (value_f : Constr.t list -> GlobRef.t -> Constr.t) = let open Term in let open Constr in fun al fterm -> let rev_x_id_l = - ( - List.fold_left - (fun x_id_l _ -> - let x_id = next_ident_away_in_goal x_id x_id_l in - x_id::x_id_l - ) - [] - al - ) + List.fold_left + (fun x_id_l _ -> + let x_id = next_ident_away_in_goal x_id x_id_l in + x_id :: x_id_l) + [] al in - let context = List.map - (fun (x, c) -> LocalAssum (make_annot (Name x) Sorts.Relevant, c)) (List.combine rev_x_id_l (List.rev al)) + let context = + List.map + (fun (x, c) -> LocalAssum (make_annot (Name x) Sorts.Relevant, c)) + (List.combine rev_x_id_l (List.rev al)) in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = - DAst.make @@ - GCases - (RegularStyle,None, - [DAst.make @@ GApp(DAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> DAst.make @@ GVar x_id) rev_x_id_l), - (Anonymous,None)], - [CAst.make ([v_id], [DAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), - [DAst.make @@ PatVar(Name v_id); DAst.make @@ PatVar Anonymous], - Anonymous)], - DAst.make @@ GVar v_id)]) + DAst.make + @@ GCases + ( RegularStyle + , None + , [ ( DAst.make + @@ GApp + ( DAst.make @@ GRef (fterm, None) + , List.rev_map + (fun x_id -> DAst.make @@ GVar x_id) + rev_x_id_l ) + , (Anonymous, None) ) ] + , [ CAst.make + ( [v_id] + , [ DAst.make + @@ PatCstr + ( (destIndRef (delayed_force coq_sig_ref), 1) + , [ DAst.make @@ PatVar (Name v_id) + ; DAst.make @@ PatVar Anonymous ] + , Anonymous ) ] + , DAst.make @@ GVar v_id ) ] ) in - let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in + let body = fst (understand env (Evd.from_env env) glob_body) (*FIXME*) in let body = EConstr.Unsafe.to_constr body in it_mkLambda_or_LetIn body context -let (declare_f : Id.t -> Decls.logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = - fun f_id kind input_type fterm_ref -> - declare_fun f_id kind (value_f input_type fterm_ref);; +let (declare_f : + Id.t -> Decls.logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = + fun f_id kind input_type fterm_ref -> + declare_fun f_id kind (value_f input_type fterm_ref) let observe_tclTHENLIST s tacl = - if do_observe () - then + if do_observe () then let rec aux n = function | [] -> tclIDTAC - | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac - | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) + | [tac] -> + observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac :: tacl -> + observe_tac + (fun env sigma -> s env sigma ++ spc () ++ int n) + (tclTHEN tac (aux (succ n) tacl)) in aux 0 tacl else tclTHENLIST tacl module New = struct - open Tacticals.New - let observe_tac = New.observe_tac ~header:(Pp.mt()) + let observe_tac = New.observe_tac ~header:(Pp.mt ()) let observe_tclTHENLIST s tacl = - if do_observe () - then - let rec aux n = function - | [] -> tclIDTAC - | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac - | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) - in - aux 0 tacl - else tclTHENLIST tacl - + if do_observe () then + let rec aux n = function + | [] -> tclIDTAC + | [tac] -> + observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac :: tacl -> + observe_tac + (fun env sigma -> s env sigma ++ spc () ++ int n) + (tclTHEN tac (aux (succ n) tacl)) + in + aux 0 tacl + else tclTHENLIST tacl end (* Conclusion tactics *) @@ -234,23 +259,25 @@ let tclUSER tac is_mes l = | None -> tclIDTAC | Some l -> tclMAP (fun id -> tclTRY (clear [id])) (List.rev l) in - New.observe_tclTHENLIST (fun _ _ -> str "tclUSER1") - [ clear_tac; - if is_mes - then - New.observe_tclTHENLIST (fun _ _ -> str "tclUSER2") - [ unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference - (delayed_force Indfun_common.ltof_ref))] - ; tac - ] - else tac - ] + New.observe_tclTHENLIST + (fun _ _ -> str "tclUSER1") + [ clear_tac + ; ( if is_mes then + New.observe_tclTHENLIST + (fun _ _ -> str "tclUSER2") + [ unfold_in_concl + [ ( Locus.AllOccurrences + , evaluable_of_global_reference + (delayed_force Indfun_common.ltof_ref) ) ] + ; tac ] + else tac ) ] let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = - if is_mes - then Tacticals.New.tclCOMPLETE (Simple.apply (delayed_force well_founded_ltof)) - else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) - (tclUSER concl_tac is_mes names_to_suppress) + if is_mes then + Tacticals.New.tclCOMPLETE (Simple.apply (delayed_force well_founded_ltof)) + else + (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) + tclUSER concl_tac is_mes names_to_suppress (* Traveling term. Both definitions of [f_terminate] and [f_equation] use the same generic @@ -263,210 +290,243 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = let check_not_nested env sigma forbidden e = let rec check_not_nested e = match EConstr.kind sigma e with - | Rel _ -> () - | Int _ | Float _ -> () - | Var x -> - if Id.List.mem x forbidden - then user_err ~hdr:"Recdef.check_not_nested" - (str "check_not_nested: failure " ++ Id.print x) - | Meta _ | Evar _ | Sort _ -> () - | Cast(e,_,t) -> check_not_nested e;check_not_nested t - | Prod(_,t,b) -> check_not_nested t;check_not_nested b - | Lambda(_,t,b) -> check_not_nested t;check_not_nested b - | LetIn(_,v,t,b) -> check_not_nested t;check_not_nested b;check_not_nested v - | App(f,l) -> check_not_nested f;Array.iter check_not_nested l - | Proj (p,c) -> check_not_nested c - | Const _ -> () - | Ind _ -> () - | Construct _ -> () - | Case(_,t,e,a) -> - check_not_nested t;check_not_nested e;Array.iter check_not_nested a - | Fix _ -> user_err Pp.(str "check_not_nested : Fix") - | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") + | Rel _ -> () + | Int _ | Float _ -> () + | Var x -> + if Id.List.mem x forbidden then + user_err ~hdr:"Recdef.check_not_nested" + (str "check_not_nested: failure " ++ Id.print x) + | Meta _ | Evar _ | Sort _ -> () + | Cast (e, _, t) -> check_not_nested e; check_not_nested t + | Prod (_, t, b) -> check_not_nested t; check_not_nested b + | Lambda (_, t, b) -> check_not_nested t; check_not_nested b + | LetIn (_, v, t, b) -> + check_not_nested t; check_not_nested b; check_not_nested v + | App (f, l) -> + check_not_nested f; + Array.iter check_not_nested l + | Proj (p, c) -> check_not_nested c + | Const _ -> () + | Ind _ -> () + | Construct _ -> () + | Case (_, t, e, a) -> + check_not_nested t; + check_not_nested e; + Array.iter check_not_nested a + | Fix _ -> user_err Pp.(str "check_not_nested : Fix") + | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") in - try - check_not_nested e - with UserError(_,p) -> - user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) + try check_not_nested e + with UserError (_, p) -> + user_err ~hdr:"_" + (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = - { nb_arg : int; (* function number of arguments *) - concl_tac : unit Proofview.tactic; (* final tactic to finish proofs *) - rec_arg_id : Id.t; (*name of the declared recursive argument *) - is_mes : bool; (* type of recursion *) - ih : Id.t; (* induction hypothesis name *) - f_id : Id.t; (* function name *) - f_constr : constr; (* function term *) - f_terminate : constr; (* termination proof term *) - func : GlobRef.t; (* functional reference *) - info : 'a; - is_main_branch : bool; (* on the main branch or on a matched expression *) - is_final : bool; (* final first order term or not *) - values_and_bounds : (Id.t*Id.t) list; - eqs : Id.t list; - forbidden_ids : Id.t list; - acc_inv : constr lazy_t; - acc_id : Id.t; - args_assoc : ((constr list)*constr) list; - } - - -type ('a,'b) journey_info_tac = - 'a -> (* the arguments of the constructor *) - 'b infos -> (* infos of the caller *) - ('b infos -> tactic) -> (* the continuation tactic of the caller *) - 'b infos -> (* argument of the tactic *) - tactic + { nb_arg : int + ; (* function number of arguments *) + concl_tac : unit Proofview.tactic + ; (* final tactic to finish proofs *) + rec_arg_id : Id.t + ; (*name of the declared recursive argument *) + is_mes : bool + ; (* type of recursion *) + ih : Id.t + ; (* induction hypothesis name *) + f_id : Id.t + ; (* function name *) + f_constr : constr + ; (* function term *) + f_terminate : constr + ; (* termination proof term *) + func : GlobRef.t + ; (* functional reference *) + info : 'a + ; is_main_branch : bool + ; (* on the main branch or on a matched expression *) + is_final : bool + ; (* final first order term or not *) + values_and_bounds : (Id.t * Id.t) list + ; eqs : Id.t list + ; forbidden_ids : Id.t list + ; acc_inv : constr lazy_t + ; acc_id : Id.t + ; args_assoc : (constr list * constr) list } + +type ('a, 'b) journey_info_tac = + 'a + -> (* the arguments of the constructor *) + 'b infos + -> (* infos of the caller *) + ('b infos -> tactic) + -> (* the continuation tactic of the caller *) + 'b infos + -> (* argument of the tactic *) + tactic (* journey_info : specifies the actions to do on the different term constructors during the traveling of the term *) type journey_info = - { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac; - lambdA : ((Name.t*types*constr),constr) journey_info_tac; - casE : ((constr infos -> tactic) -> constr infos -> tactic) -> - ((case_info * constr * constr * constr array),constr) journey_info_tac; - otherS : (unit,constr) journey_info_tac; - apP : (constr*(constr list),constr) journey_info_tac; - app_reC : (constr*(constr list),constr) journey_info_tac; - message : string - } - - + { letiN : (Name.t * constr * types * constr, constr) journey_info_tac + ; lambdA : (Name.t * types * constr, constr) journey_info_tac + ; casE : + ((constr infos -> tactic) -> constr infos -> tactic) + -> (case_info * constr * constr * constr array, constr) journey_info_tac + ; otherS : (unit, constr) journey_info_tac + ; apP : (constr * constr list, constr) journey_info_tac + ; app_reC : (constr * constr list, constr) journey_info_tac + ; message : string } let add_vars sigma forbidden e = let rec aux forbidden e = - match EConstr.kind sigma e with - | Var x -> x::forbidden + match EConstr.kind sigma e with + | Var x -> x :: forbidden | _ -> EConstr.fold sigma aux forbidden e in aux forbidden e let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = - fun g -> - let rev_context,b = decompose_lam_n (project g) nb_lam e in - let ids = List.fold_left (fun acc (na,_) -> - let pre_id = - match na.binder_name with - | Name x -> x - | Anonymous -> ano_id - in - pre_id::acc - ) [] rev_context in - let rev_ids = pf_get_new_ids (List.rev ids) g in - let new_b = substl (List.map mkVar rev_ids) b in - observe_tclTHENLIST (fun _ _ -> str "treat_case1") - [ - h_intros (List.rev rev_ids); - Proofview.V82.of_tactic (intro_using teq_id); - onLastHypId (fun heq -> - observe_tclTHENLIST (fun _ _ -> str "treat_case2")[ - Proofview.V82.of_tactic (clear to_intros); - h_intros to_intros; - (fun g' -> - let ty_teq = pf_get_hyp_typ g' heq in - let teq_lhs,teq_rhs = - let _,args = try destApp (project g') ty_teq with DestKO -> assert false in - args.(1),args.(2) - in - let new_b' = Termops.replace_term (project g') teq_lhs teq_rhs new_b in - let new_infos = { - infos with - info = new_b'; - eqs = heq::infos.eqs; - forbidden_ids = - if forbid_new_ids - then add_vars (project g') infos.forbidden_ids new_b' - else infos.forbidden_ids - } in - finalize_tac new_infos g' - ) - ] - ) - ] g - -let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = + fun g -> + let rev_context, b = decompose_lam_n (project g) nb_lam e in + let ids = + List.fold_left + (fun acc (na, _) -> + let pre_id = + match na.binder_name with Name x -> x | Anonymous -> ano_id + in + pre_id :: acc) + [] rev_context + in + let rev_ids = pf_get_new_ids (List.rev ids) g in + let new_b = substl (List.map mkVar rev_ids) b in + observe_tclTHENLIST + (fun _ _ -> str "treat_case1") + [ h_intros (List.rev rev_ids) + ; Proofview.V82.of_tactic (intro_using teq_id) + ; onLastHypId (fun heq -> + observe_tclTHENLIST + (fun _ _ -> str "treat_case2") + [ Proofview.V82.of_tactic (clear to_intros) + ; h_intros to_intros + ; (fun g' -> + let ty_teq = pf_get_hyp_typ g' heq in + let teq_lhs, teq_rhs = + let _, args = + try destApp (project g') ty_teq + with DestKO -> assert false + in + (args.(1), args.(2)) + in + let new_b' = + Termops.replace_term (project g') teq_lhs teq_rhs new_b + in + let new_infos = + { infos with + info = new_b' + ; eqs = heq :: infos.eqs + ; forbidden_ids = + ( if forbid_new_ids then + add_vars (project g') infos.forbidden_ids new_b' + else infos.forbidden_ids ) } + in + finalize_tac new_infos g') ]) ] + g + +let rec travel_aux jinfo continuation_tac (expr_info : constr infos) g = let sigma = project g in let env = pf_env g in match EConstr.kind sigma expr_info.info with - | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") - | Proj _ -> user_err Pp.(str "Function cannot treat projections") - | LetIn(na,b,t,e) -> - begin + | CoFix _ | Fix _ -> + user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") + | Proj _ -> user_err Pp.(str "Function cannot treat projections") + | LetIn (na, b, t, e) -> + let new_continuation_tac = + jinfo.letiN (na.binder_name, b, t, e) expr_info continuation_tac + in + travel jinfo new_continuation_tac + {expr_info with info = b; is_final = false} + g + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + | Prod _ -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Lambda (n, t, b) -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Case (ci, t, a, l) -> + let continuation_tac_a = + jinfo.casE (travel jinfo) (ci, t, a, l) expr_info continuation_tac + in + travel jinfo continuation_tac_a + {expr_info with info = a; is_main_branch = false; is_final = false} + g + | App _ -> ( + let f, args = decompose_app sigma expr_info.info in + if EConstr.eq_constr sigma f expr_info.f_constr then + jinfo.app_reC (f, args) expr_info continuation_tac expr_info g + else + match EConstr.kind sigma f with + | App _ -> assert false (* f is coming from a decompose_app *) + | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ + |Prod _ | Var _ -> + let new_infos = {expr_info with info = (f, args)} in let new_continuation_tac = - jinfo.letiN (na.binder_name,b,t,e) expr_info continuation_tac + jinfo.apP (f, args) expr_info continuation_tac in - travel jinfo new_continuation_tac - {expr_info with info = b; is_final=false} g - end - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - | Prod _ -> - begin - try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) - end - | Lambda(n,t,b) -> - begin - try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) - end - | Case(ci,t,a,l) -> - begin - let continuation_tac_a = - jinfo.casE - (travel jinfo) (ci,t,a,l) - expr_info continuation_tac in - travel - jinfo continuation_tac_a - {expr_info with info = a; is_main_branch = false; - is_final = false} g - end - | App _ -> - let f,args = decompose_app sigma expr_info.info in - if EConstr.eq_constr sigma f (expr_info.f_constr) - then jinfo.app_reC (f,args) expr_info continuation_tac expr_info g - else - begin - match EConstr.kind sigma f with - | App _ -> assert false (* f is coming from a decompose_app *) - | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ - | Sort _ | Prod _ | Var _ -> - let new_infos = {expr_info with info=(f,args)} in - let new_continuation_tac = - jinfo.apP (f,args) expr_info continuation_tac in - travel_args jinfo - expr_info.is_main_branch new_continuation_tac new_infos g - | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") - | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env env sigma expr_info.info ++ Pp.str ".") - end - | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ | Float _ -> - let new_continuation_tac = - jinfo.otherS () expr_info continuation_tac in - new_continuation_tac expr_info g + travel_args jinfo expr_info.is_main_branch new_continuation_tac + new_infos g + | Case _ -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str + " can not contain an applied match (See Limitation in Section \ + 2.3 of refman)" ) + | _ -> + anomaly + ( Pp.str "travel_aux : unexpected " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ Pp.str "." ) ) + | Cast (t, _, _) -> travel jinfo continuation_tac {expr_info with info = t} g + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ + |Float _ -> + let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in + new_continuation_tac expr_info g + and travel_args jinfo is_final continuation_tac infos = - let (f_args',args) = infos.info in + let f_args', args = infos.info in match args with - | [] -> - continuation_tac {infos with info = f_args'; is_final = is_final} - | arg::args' -> - let new_continuation_tac new_infos = - let new_arg = new_infos.info in - travel_args jinfo is_final - continuation_tac - {new_infos with info = (mkApp(f_args',[|new_arg|]),args')} - in - travel jinfo new_continuation_tac - {infos with info=arg;is_final=false} + | [] -> continuation_tac {infos with info = f_args'; is_final} + | arg :: args' -> + let new_continuation_tac new_infos = + let new_arg = new_infos.info in + travel_args jinfo is_final continuation_tac + {new_infos with info = (mkApp (f_args', [|new_arg|]), args')} + in + travel jinfo new_continuation_tac {infos with info = arg; is_final = false} + and travel jinfo continuation_tac expr_info = observe_tac - (fun env sigma -> str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) + (fun env sigma -> + str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) @@ -475,164 +535,185 @@ let rec prove_lt hyple g = let sigma = project g in begin try - let (varx,varz) = match decompose_app sigma (pf_concl g) with - | _, x::z::_ when isVar sigma x && isVar sigma z -> x, z + let varx, varz = + match decompose_app sigma (pf_concl g) with + | _, x :: z :: _ when isVar sigma x && isVar sigma z -> (x, z) | _ -> assert false in let h = - List.find (fun id -> - match decompose_app sigma (pf_get_hyp_typ g id) with - | _, t::_ -> EConstr.eq_constr sigma t varx - | _ -> false - ) hyple + List.find + (fun id -> + match decompose_app sigma (pf_get_hyp_typ g id) with + | _, t :: _ -> EConstr.eq_constr sigma t varx + | _ -> false) + hyple in let y = - List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) in - observe_tclTHENLIST (fun _ _ -> str "prove_lt1")[ - Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); - observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) - ] + List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) + in + observe_tclTHENLIST + (fun _ _ -> str "prove_lt1") + [ Proofview.V82.of_tactic + (apply (mkApp (le_lt_trans (), [|varx; y; varz; mkVar h|]))) + ; observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] with Not_found -> - ( - ( - observe_tclTHENLIST (fun _ _ -> str "prove_lt2")[ - Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); - (observe_tac (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) - ]) - ) + observe_tclTHENLIST + (fun _ _ -> str "prove_lt2") + [ Proofview.V82.of_tactic (apply (delayed_force lt_S_n)) + ; observe_tac + (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) + (Proofview.V82.of_tactic assumption) ] end g -let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = +let rec destruct_bounds_aux infos (bound, hyple, rechyps) lbounds g = match lbounds with - | [] -> - let ids = pf_ids_of_hyps g in - let s_max = mkApp(delayed_force coq_S, [|bound|]) in - let k = next_ident_away_in_goal k_id ids in - let ids = k::ids in - let h' = next_ident_away_in_goal (h'_id) ids in - let ids = h'::ids in - let def = next_ident_away_in_goal def_id ids in - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux1")[ - Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); - Proofview.V82.of_tactic (intro_then - (fun id -> - Proofview.V82.tactic begin - observe_tac (fun _ _ -> str "destruct_bounds_aux") - (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) - [ - observe_tclTHENLIST (fun _ _ -> str "")[Proofview.V82.of_tactic (intro_using h_id); - Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); - Proofview.V82.of_tactic default_full_auto]; - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux2")[ - observe_tac (fun _ _ -> str "clearing k ") (Proofview.V82.of_tactic (clear [id])); - h_intros [k;h';def]; - observe_tac (fun _ _ -> str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); - observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference infos.func)])); - ( - observe_tclTHENLIST (fun _ _ -> str "test")[ - list_rewrite true - (List.fold_right - (fun e acc -> (mkVar e,true)::acc) - infos.eqs - (List.map (fun e -> (e,true)) rechyps) - ); - (* list_rewrite true *) - (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) - (* ; *) - - (observe_tac (fun _ _ -> str "finishing") - (tclORELSE - (Proofview.V82.of_tactic intros_reflexivity) - (observe_tac (fun _ _ -> str "calling prove_lt") (prove_lt hyple))))]) - ] - ] - )end)) - ] g - | (_,v_bound)::l -> - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux3")[ - Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); - Proofview.V82.of_tactic (clear [v_bound]); - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 - (fun p_hyp -> - (onNthHypId 2 - (fun p -> - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux4")[ - Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); - tclDO 3 (Proofview.V82.of_tactic intro); - onNLastHypsId 3 (fun lids -> - match lids with - [hle2;hle1;pmax] -> - destruct_bounds_aux infos - ((mkVar pmax), - hle1::hle2::hyple,(mkVar p_hyp)::rechyps) - l - | _ -> assert false) ; - ] - ) - ) - ) - ] g + | [] -> + let ids = pf_ids_of_hyps g in + let s_max = mkApp (delayed_force coq_S, [|bound|]) in + let k = next_ident_away_in_goal k_id ids in + let ids = k :: ids in + let h' = next_ident_away_in_goal h'_id ids in + let ids = h' :: ids in + let def = next_ident_away_in_goal def_id ids in + observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux1") + [ Proofview.V82.of_tactic (split (ImplicitBindings [s_max])) + ; Proofview.V82.of_tactic + (intro_then (fun id -> + Proofview.V82.tactic + (observe_tac + (fun _ _ -> str "destruct_bounds_aux") + (tclTHENS + (Proofview.V82.of_tactic (simplest_case (mkVar id))) + [ observe_tclTHENLIST + (fun _ _ -> str "") + [ Proofview.V82.of_tactic (intro_using h_id) + ; Proofview.V82.of_tactic + (simplest_elim + (mkApp (delayed_force lt_n_O, [|s_max|]))) + ; Proofview.V82.of_tactic default_full_auto ] + ; observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux2") + [ observe_tac + (fun _ _ -> str "clearing k ") + (Proofview.V82.of_tactic (clear [id])) + ; h_intros [k; h'; def] + ; observe_tac + (fun _ _ -> str "simple_iter") + (Proofview.V82.of_tactic + (simpl_iter Locusops.onConcl)) + ; observe_tac + (fun _ _ -> str "unfold functional") + (Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference + infos.func ) ])) + ; observe_tclTHENLIST + (fun _ _ -> str "test") + [ list_rewrite true + (List.fold_right + (fun e acc -> (mkVar e, true) :: acc) + infos.eqs + (List.map (fun e -> (e, true)) rechyps)) + ; (* list_rewrite true *) + (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) + (* ; *) + observe_tac + (fun _ _ -> str "finishing") + (tclORELSE + (Proofview.V82.of_tactic + intros_reflexivity) + (observe_tac + (fun _ _ -> str "calling prove_lt") + (prove_lt hyple))) ] ] ])))) ] + g + | (_, v_bound) :: l -> + observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux3") + [ Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)) + ; Proofview.V82.of_tactic (clear [v_bound]) + ; tclDO 2 (Proofview.V82.of_tactic intro) + ; onNthHypId 1 (fun p_hyp -> + onNthHypId 2 (fun p -> + observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux4") + [ Proofview.V82.of_tactic + (simplest_elim + (mkApp (delayed_force max_constr, [|bound; mkVar p|]))) + ; tclDO 3 (Proofview.V82.of_tactic intro) + ; onNLastHypsId 3 (fun lids -> + match lids with + | [hle2; hle1; pmax] -> + destruct_bounds_aux infos + ( mkVar pmax + , hle1 :: hle2 :: hyple + , mkVar p_hyp :: rechyps ) + l + | _ -> assert false) ])) ] + g let destruct_bounds infos = - destruct_bounds_aux infos (delayed_force coq_O,[],[]) infos.values_and_bounds + destruct_bounds_aux infos + (delayed_force coq_O, [], []) + infos.values_and_bounds let terminate_app f_and_args expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_app1")[ - continuation_tac infos; - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds (1)") (destruct_bounds infos) - ] - else continuation_tac infos + if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "terminate_app1") + [ continuation_tac infos + ; observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) + ; observe_tac + (fun _ _ -> str "destruct_bounds (1)") + (destruct_bounds infos) ] + else continuation_tac infos let terminate_others _ expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_others")[ - continuation_tac infos; - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) - ] + if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "terminate_others") + [ continuation_tac infos + ; observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) + ; observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) + ] else continuation_tac infos -let terminate_letin (na,b,t,e) expr_info continuation_tac info g = +let terminate_letin (na, b, t, e) expr_info continuation_tac info g = let sigma = project g in let env = pf_env g in let new_e = subst1 info.info e in let new_forbidden = let forbid = try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) b; + check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in - if forbid - then + if forbid then match na with - | Anonymous -> info.forbidden_ids - | Name id -> id::info.forbidden_ids + | Anonymous -> info.forbidden_ids + | Name id -> id :: info.forbidden_ids else info.forbidden_ids in continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g let pf_type c tac gl = let evars, ty = Typing.type_of (pf_env gl) (project gl) c in - tclTHEN (Refiner.tclEVARS evars) (tac ty) gl + tclTHEN (Refiner.tclEVARS evars) (tac ty) gl let pf_typel l tac = let rec aux tys l = match l with | [] -> tac (List.rev tys) - | hd :: tl -> pf_type hd (fun ty -> aux (ty::tys) tl) - in aux [] l + | hd :: tl -> pf_type hd (fun ty -> aux (ty :: tys) tl) + in + aux [] l (* This is like the previous one except that it also rewrite on all hypotheses except the ones given in the first argument. All the @@ -646,351 +727,431 @@ let mkDestructEq not_on_hyp expr g = (fun decl -> let open Context.Named.Declaration in let id = get_id decl in - if Id.List.mem id not_on_hyp || not (Termops.dependent (project g) expr (get_type decl)) - then None else Some id) hyps in + if + Id.List.mem id not_on_hyp + || not (Termops.dependent (project g) expr (get_type decl)) + then None + else Some id) + hyps + in let to_revert_constr = List.rev_map mkVar to_revert in let g, type_of_expr = tac_type_of g expr in - let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|])::to_revert_constr in + let new_hyps = + mkApp (Lazy.force refl_equal, [|type_of_expr; expr|]) :: to_revert_constr + in let tac = pf_typel new_hyps (fun _ -> - observe_tclTHENLIST (fun _ _ -> str "mkDestructEq") - [Proofview.V82.of_tactic (generalize new_hyps); - (fun g2 -> - let changefun patvars env sigma = - pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) - in - Proofview.V82.of_tactic (change_in_concl ~check:true None changefun) g2); - Proofview.V82.of_tactic (simplest_case expr)]) + observe_tclTHENLIST + (fun _ _ -> str "mkDestructEq") + [ Proofview.V82.of_tactic (generalize new_hyps) + ; (fun g2 -> + let changefun patvars env sigma = + pattern_occs + [(Locus.AllOccurrencesBut [1], expr)] + (pf_env g2) sigma (pf_concl g2) + in + Proofview.V82.of_tactic + (change_in_concl ~check:true None changefun) + g2) + ; Proofview.V82.of_tactic (simplest_case expr) ]) in - g, tac, to_revert + (g, tac, to_revert) -let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = +let terminate_case next_step (ci, a, t, l) expr_info continuation_tac infos g = let sigma = project g in let env = pf_env g in let f_is_present = try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) a; + check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) a; false - with e when CErrors.noncritical e -> - true + with e when CErrors.noncritical e -> true in let a' = infos.info in let new_info = - {infos with - info = mkCase(ci,t,a',l); - is_main_branch = expr_info.is_main_branch; - is_final = expr_info.is_final} in - let g,destruct_tac,rev_to_thin_intro = - mkDestructEq [expr_info.rec_arg_id] a' g in + { infos with + info = mkCase (ci, t, a', l) + ; is_main_branch = expr_info.is_main_branch + ; is_final = expr_info.is_final } + in + let g, destruct_tac, rev_to_thin_intro = + mkDestructEq [expr_info.rec_arg_id] a' g + in let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac (fun _ _ -> str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') - (try - (tclTHENS - destruct_tac - (List.map_i (fun i e -> observe_tac (fun _ _ -> str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) - )) - with - | UserError(Some "Refiner.thensn_tac3",_) - | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (fun _ _ -> str "is computable " ++ Printer.pr_leconstr_env env sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) - )) + observe_tac + (fun _ _ -> + str "treating cases (" + ++ int (Array.length l) + ++ str ")" ++ spc () + ++ Printer.pr_leconstr_env (pf_env g) sigma a') + ( try + tclTHENS destruct_tac + (List.map_i + (fun i e -> + observe_tac + (fun _ _ -> str "do treat case") + (treat_case f_is_present to_thin_intro + (next_step continuation_tac) + ci.ci_cstr_ndecls.(i) e new_info)) + 0 (Array.to_list l)) + with + | UserError (Some "Refiner.thensn_tac3", _) + |UserError (Some "Refiner.tclFAIL_s", _) + -> + observe_tac + (fun _ _ -> + str "is computable " + ++ Printer.pr_leconstr_env env sigma new_info.info) + (next_step continuation_tac + { new_info with + info = + Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info }) + ) g -let terminate_app_rec (f,args) expr_info continuation_tac _ g = +let terminate_app_rec (f, args) expr_info continuation_tac _ g = let sigma = project g in let env = pf_env g in - List.iter (check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids)) + List.iter + (check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids)) args; - begin - try - let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in - let new_infos = {expr_info with info = v} in - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec")[ - continuation_tac new_infos; - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec1")[ - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds (3)") - (destruct_bounds new_infos) - ] - else - tclIDTAC - ] g - with Not_found -> - observe_tac (fun _ _ -> str "terminate_app_rec not found") (tclTHENS - (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) - [ - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec2")[ - Proofview.V82.of_tactic (intro_using rec_res_id); - Proofview.V82.of_tactic intro; - onNthHypId 1 - (fun v_bound -> - (onNthHypId 2 - (fun v -> - let new_infos = { expr_info with - info = (mkVar v); - values_and_bounds = - (v,v_bound)::expr_info.values_and_bounds; - args_assoc=(args,mkVar v)::expr_info.args_assoc - } in - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec3")[ - continuation_tac new_infos; - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec4")[ - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds (2)") - (destruct_bounds new_infos) - ] - else - tclIDTAC - ] - ) - ) - ) - ]; - observe_tac (fun _ _ -> str "proving decreasing") ( - tclTHENS (* proof of args < formal args *) - (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) - [ - observe_tac (fun _ _ -> str "assumption") (Proofview.V82.of_tactic assumption); - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec5") - [ - tclTRY(list_rewrite true - (List.map - (fun e -> mkVar e,true) - expr_info.eqs - ) - ); - Proofview.V82.of_tactic @@ - tclUSER expr_info.concl_tac true - (Some ( - expr_info.ih::expr_info.acc_id:: - (fun (x,y) -> y) - (List.split expr_info.values_and_bounds) - ) - ); - ] - ]) - ]) g - end + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec") + [ continuation_tac new_infos + ; ( if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec1") + [ observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic + (split (ImplicitBindings [new_infos.info]))) + ; observe_tac + (fun _ _ -> str "destruct_bounds (3)") + (destruct_bounds new_infos) ] + else tclIDTAC ) ] + g + with Not_found -> + observe_tac + (fun _ _ -> str "terminate_app_rec not found") + (tclTHENS + (Proofview.V82.of_tactic + (simplest_elim (mkApp (mkVar expr_info.ih, Array.of_list args)))) + [ observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec2") + [ Proofview.V82.of_tactic (intro_using rec_res_id) + ; Proofview.V82.of_tactic intro + ; onNthHypId 1 (fun v_bound -> + onNthHypId 2 (fun v -> + let new_infos = + { expr_info with + info = mkVar v + ; values_and_bounds = + (v, v_bound) :: expr_info.values_and_bounds + ; args_assoc = (args, mkVar v) :: expr_info.args_assoc + } + in + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec3") + [ continuation_tac new_infos + ; ( if expr_info.is_final && expr_info.is_main_branch + then + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec4") + [ observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic + (split + (ImplicitBindings [new_infos.info]))) + ; observe_tac + (fun _ _ -> str "destruct_bounds (2)") + (destruct_bounds new_infos) ] + else tclIDTAC ) ])) ] + ; observe_tac + (fun _ _ -> str "proving decreasing") + (tclTHENS (* proof of args < formal args *) + (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) + [ observe_tac + (fun _ _ -> str "assumption") + (Proofview.V82.of_tactic assumption) + ; observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec5") + [ tclTRY + (list_rewrite true + (List.map (fun e -> (mkVar e, true)) expr_info.eqs)) + ; Proofview.V82.of_tactic + @@ tclUSER expr_info.concl_tac true + (Some + ( expr_info.ih :: expr_info.acc_id + :: (fun (x, y) -> y) + (List.split expr_info.values_and_bounds) )) + ] ]) ]) + g let terminate_info = - { message = "prove_terminate with term "; - letiN = terminate_letin; - lambdA = (fun _ _ _ _ -> assert false); - casE = terminate_case; - otherS = terminate_others; - apP = terminate_app; - app_reC = terminate_app_rec; - } + { message = "prove_terminate with term " + ; letiN = terminate_letin + ; lambdA = (fun _ _ _ _ -> assert false) + ; casE = terminate_case + ; otherS = terminate_others + ; apP = terminate_app + ; app_reC = terminate_app_rec } let prove_terminate = travel terminate_info - (* Equation proof *) -let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = - observe_tac (fun _ _ -> str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) +let equation_case next_step (ci, a, t, l) expr_info continuation_tac infos = + observe_tac + (fun _ _ -> str "equation case") + (terminate_case next_step (ci, a, t, l) expr_info continuation_tac infos) let rec prove_le g = let sigma = project g in - let x,z = - let _,args = decompose_app sigma (pf_concl g) in - (List.hd args,List.hd (List.tl args)) + let x, z = + let _, args = decompose_app sigma (pf_concl g) in + (List.hd args, List.hd (List.tl args)) in - tclFIRST[ - Proofview.V82.of_tactic assumption; - Proofview.V82.of_tactic (apply (delayed_force le_n)); - begin - try - let matching_fun c = match EConstr.kind sigma c with - | App (c, [| x0 ; _ |]) -> - EConstr.isVar sigma x0 && - Id.equal (destVar sigma x0) (destVar sigma x) && - EConstr.isRefX sigma (le ()) c - | _ -> false - in - let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in - let h = h.binder_name in - let y = - let _,args = decompose_app sigma t in - List.hd (List.tl args) - in - observe_tclTHENLIST (fun _ _ -> str "prove_le")[ - Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); - observe_tac (fun _ _ -> str "prove_le (rec)") (prove_le) - ] - with Not_found -> tclFAIL 0 (mt()) - end; - ] + tclFIRST + [ Proofview.V82.of_tactic assumption + ; Proofview.V82.of_tactic (apply (delayed_force le_n)) + ; begin + try + let matching_fun c = + match EConstr.kind sigma c with + | App (c, [|x0; _|]) -> + EConstr.isVar sigma x0 + && Id.equal (destVar sigma x0) (destVar sigma x) + && EConstr.isRefX sigma (le ()) c + | _ -> false + in + let h, t = + List.find (fun (_, t) -> matching_fun t) (pf_hyps_types g) + in + let h = h.binder_name in + let y = + let _, args = decompose_app sigma t in + List.hd (List.tl args) + in + observe_tclTHENLIST + (fun _ _ -> str "prove_le") + [ Proofview.V82.of_tactic + (apply (mkApp (le_trans (), [|x; y; z; mkVar h|]))) + ; observe_tac (fun _ _ -> str "prove_le (rec)") prove_le ] + with Not_found -> tclFAIL 0 (mt ()) + end ] g let rec make_rewrite_list expr_info max = function | [] -> tclIDTAC - | (_,p,hp)::l -> - observe_tac (fun _ _ -> str "make_rewrite_list") (tclTHENS - (observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p ) ( - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k,def = - let k_na,_,t = destProd sigma t_eq in - let _,_,t = destProd sigma t in - let def_na,_,_ = destProd sigma t in - Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name - in - Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences - true (* dep proofs also: *) true - (mkVar hp, - ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); - CAst.make @@ (NamedHyp k, f_S max)]) false) g) ) - ) - [make_rewrite_list expr_info max l; - observe_tclTHENLIST (fun _ _ -> str "make_rewrite_list")[ (* x < S max proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); - observe_tac (fun _ _ -> str "prove_le(2)") prove_le - ] - ] ) + | (_, p, hp) :: l -> + observe_tac + (fun _ _ -> str "make_rewrite_list") + (tclTHENS + (observe_tac + (fun _ _ -> str "rewrite heq on " ++ Id.print p) + (fun g -> + let sigma = project g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + Proofview.V82.of_tactic + (general_rewrite_bindings false Locus.AllOccurrences true + (* dep proofs also: *) true + ( mkVar hp + , ExplicitBindings + [ CAst.make @@ (NamedHyp def, expr_info.f_constr) + ; CAst.make @@ (NamedHyp k, f_S max) ] ) + false) + g)) + [ make_rewrite_list expr_info max l + ; observe_tclTHENLIST + (fun _ _ -> str "make_rewrite_list") + [ (* x < S max proof *) + Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)) + ; observe_tac (fun _ _ -> str "prove_le(2)") prove_le ] ]) let make_rewrite expr_info l hp max = tclTHENFIRST - (observe_tac (fun _ _ -> str "make_rewrite") (make_rewrite_list expr_info max l)) - (observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k,def = - let k_na,_,t = destProd sigma t_eq in - let _,_,t = destProd sigma t in - let def_na,_,_ = destProd sigma t in - Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name - in - observe_tac (fun _ _ -> str "general_rewrite_bindings") - (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences - true (* dep proofs also: *) true - (mkVar hp, - ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); - CAst.make @@ (NamedHyp k, f_S (f_S max))]) false)) g) - [observe_tac(fun _ _ -> str "make_rewrite finalize") ( - (* tclORELSE( h_reflexivity) *) - (observe_tclTHENLIST (fun _ _ -> str "make_rewrite")[ - Proofview.V82.of_tactic (simpl_iter Locusops.onConcl); - observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference expr_info.func)])); - - (list_rewrite true - (List.map (fun e -> mkVar e,true) expr_info.eqs)); - (observe_tac (fun _ _ -> str "h_reflexivity") - (Proofview.V82.of_tactic intros_reflexivity) - ) - ])) - ; - observe_tclTHENLIST (fun _ _ -> str "make_rewrite1")[ (* x < S (S max) proof *) - Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS))); - observe_tac (fun _ _ -> str "prove_le (3)") prove_le - ] - ]) - ) + (observe_tac + (fun _ _ -> str "make_rewrite") + (make_rewrite_list expr_info max l)) + (observe_tac + (fun _ _ -> str "make_rewrite") + (tclTHENS + (fun g -> + let sigma = project g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + observe_tac + (fun _ _ -> str "general_rewrite_bindings") + (Proofview.V82.of_tactic + (general_rewrite_bindings false Locus.AllOccurrences true + (* dep proofs also: *) true + ( mkVar hp + , ExplicitBindings + [ CAst.make @@ (NamedHyp def, expr_info.f_constr) + ; CAst.make @@ (NamedHyp k, f_S (f_S max)) ] ) + false)) + g) + [ observe_tac + (fun _ _ -> str "make_rewrite finalize") + ((* tclORELSE( h_reflexivity) *) + observe_tclTHENLIST + (fun _ _ -> str "make_rewrite") + [ Proofview.V82.of_tactic (simpl_iter Locusops.onConcl) + ; observe_tac + (fun _ _ -> str "unfold functional") + (Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference expr_info.func ) ])) + ; list_rewrite true + (List.map (fun e -> (mkVar e, true)) expr_info.eqs) + ; observe_tac + (fun _ _ -> str "h_reflexivity") + (Proofview.V82.of_tactic intros_reflexivity) ]) + ; observe_tclTHENLIST + (fun _ _ -> str "make_rewrite1") + [ (* x < S (S max) proof *) + Proofview.V82.of_tactic + (apply (EConstr.of_constr (delayed_force le_lt_SS))) + ; observe_tac (fun _ _ -> str "prove_le (3)") prove_le ] ])) let rec compute_max rew_tac max l = match l with - | [] -> rew_tac max - | (_,p,_)::l -> - observe_tclTHENLIST (fun _ _ -> str "compute_max")[ - Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| max; mkVar p|]))); - tclDO 3 (Proofview.V82.of_tactic intro); - onNLastHypsId 3 (fun lids -> - match lids with - | [hle2;hle1;pmax] -> compute_max rew_tac (mkVar pmax) l - | _ -> assert false - )] + | [] -> rew_tac max + | (_, p, _) :: l -> + observe_tclTHENLIST + (fun _ _ -> str "compute_max") + [ Proofview.V82.of_tactic + (simplest_elim (mkApp (delayed_force max_constr, [|max; mkVar p|]))) + ; tclDO 3 (Proofview.V82.of_tactic intro) + ; onNLastHypsId 3 (fun lids -> + match lids with + | [hle2; hle1; pmax] -> compute_max rew_tac (mkVar pmax) l + | _ -> assert false) ] let rec destruct_hex expr_info acc l = match l with - | [] -> - begin - match List.rev acc with - | [] -> tclIDTAC - | (_,p,hp)::tl -> - observe_tac (fun _ _ -> str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) - end - | (v,hex)::l -> - observe_tclTHENLIST (fun _ _ -> str "destruct_hex")[ - Proofview.V82.of_tactic (simplest_case (mkVar hex)); - Proofview.V82.of_tactic (clear [hex]); - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 (fun hp -> - onNthHypId 2 (fun p -> - observe_tac - (fun _ _ -> str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) - (destruct_hex expr_info ((v,p,hp)::acc) l) - ) - ) - ] + | [] -> ( + match List.rev acc with + | [] -> tclIDTAC + | (_, p, hp) :: tl -> + observe_tac + (fun _ _ -> str "compute max ") + (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) ) + | (v, hex) :: l -> + observe_tclTHENLIST + (fun _ _ -> str "destruct_hex") + [ Proofview.V82.of_tactic (simplest_case (mkVar hex)) + ; Proofview.V82.of_tactic (clear [hex]) + ; tclDO 2 (Proofview.V82.of_tactic intro) + ; onNthHypId 1 (fun hp -> + onNthHypId 2 (fun p -> + observe_tac + (fun _ _ -> + str "destruct_hex after " ++ Id.print hp ++ spc () + ++ Id.print p) + (destruct_hex expr_info ((v, p, hp) :: acc) l))) ] let rec intros_values_eq expr_info acc = - tclORELSE( - observe_tclTHENLIST (fun _ _ -> str "intros_values_eq")[ - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 (fun hex -> - (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) - ) - ]) - (tclCOMPLETE ( - destruct_hex expr_info [] acc - )) + tclORELSE + (observe_tclTHENLIST + (fun _ _ -> str "intros_values_eq") + [ tclDO 2 (Proofview.V82.of_tactic intro) + ; onNthHypId 1 (fun hex -> + onNthHypId 2 (fun v -> + intros_values_eq expr_info ((v, hex) :: acc))) ]) + (tclCOMPLETE (destruct_hex expr_info [] acc)) let equation_others _ expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then - observe_tac (fun env sigma -> str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) - (tclTHEN + if expr_info.is_final && expr_info.is_main_branch then + observe_tac + (fun env sigma -> + str "equation_others (cont_tac +intros) " + ++ Printer.pr_leconstr_env env sigma expr_info.info) + (tclTHEN (continuation_tac infos) + (observe_tac + (fun env sigma -> + str "intros_values_eq equation_others " + ++ Printer.pr_leconstr_env env sigma expr_info.info) + (intros_values_eq expr_info []))) + else + observe_tac + (fun env sigma -> + str "equation_others (cont_tac) " + ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) - (observe_tac (fun env sigma -> str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []))) - else observe_tac (fun env sigma -> str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then ((observe_tac (fun _ _ -> str "intros_values_eq equation_app") (intros_values_eq expr_info []))) - else continuation_tac infos + if expr_info.is_final && expr_info.is_main_branch then + observe_tac + (fun _ _ -> str "intros_values_eq equation_app") + (intros_values_eq expr_info []) + else continuation_tac infos -let equation_app_rec (f,args) expr_info continuation_tac info g = +let equation_app_rec (f, args) expr_info continuation_tac info g = let sigma = project g in - begin - try - let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in - let new_infos = {expr_info with info = v} in - observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g - with Not_found -> - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "equation_app_rec") - [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); - continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; - observe_tac (fun _ _ -> str "app_rec intros_values_eq") (intros_values_eq expr_info []) - ] g - else - observe_tclTHENLIST (fun _ _ -> str "equation_app_rec1")[ - Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); - observe_tac (fun _ _ -> str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) - ] g - end + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g + with Not_found -> + if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec") + [ Proofview.V82.of_tactic + (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) + ; continuation_tac + { expr_info with + args_assoc = (args, delayed_force coq_O) :: expr_info.args_assoc + } + ; observe_tac + (fun _ _ -> str "app_rec intros_values_eq") + (intros_values_eq expr_info []) ] + g + else + observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec1") + [ Proofview.V82.of_tactic + (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) + ; observe_tac + (fun _ _ -> str "app_rec not_found") + (continuation_tac + { expr_info with + args_assoc = + (args, delayed_force coq_O) :: expr_info.args_assoc }) ] + g let equation_info = - {message = "prove_equation with term "; - letiN = (fun _ -> assert false); - lambdA = (fun _ _ _ _ -> assert false); - casE = equation_case; - otherS = equation_others; - apP = equation_app; - app_reC = equation_app_rec -} + { message = "prove_equation with term " + ; letiN = (fun _ -> assert false) + ; lambdA = (fun _ _ _ _ -> assert false) + ; casE = equation_case + ; otherS = equation_others + ; apP = equation_app + ; app_reC = equation_app_rec } let prove_eq = travel equation_info @@ -1001,271 +1162,268 @@ let compute_terminate_type nb_args func = let open Term in let open Constr in let open CVars in - let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_monomorphic_global func)) in - let rev_args,b = decompose_prod_n nb_args a_arrow_b in + let _, a_arrow_b, _ = + destLambda (def_of_const (constr_of_monomorphic_global func)) + in + let rev_args, b = decompose_prod_n nb_args a_arrow_b in let left = - mkApp(delayed_force iter_rd, - Array.of_list - (lift 5 a_arrow_b:: mkRel 3:: - constr_of_monomorphic_global func::mkRel 1:: - List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args) - ) - ) + mkApp + ( delayed_force iter_rd + , Array.of_list + ( lift 5 a_arrow_b :: mkRel 3 + :: constr_of_monomorphic_global func + :: mkRel 1 + :: List.rev (List.map_i (fun i _ -> mkRel (6 + i)) 0 rev_args) ) ) in let right = mkRel 5 in let delayed_force c = EConstr.Unsafe.to_constr (delayed_force c) in - let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in - let result = (mkProd (make_annot (Name def_id) Sorts.Relevant, lift 4 a_arrow_b, equality)) in - let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in + let equality = mkApp (delayed_force eq, [|lift 5 b; left; right|]) in + let result = + mkProd (make_annot (Name def_id) Sorts.Relevant, lift 4 a_arrow_b, equality) + in + let cond = mkApp (delayed_force lt, [|mkRel 2; mkRel 1|]) in let nb_iter = - mkApp(delayed_force ex, - [|delayed_force nat; - (mkLambda - (make_annot (Name p_id) Sorts.Relevant, - delayed_force nat, - (mkProd (make_annot (Name k_id) Sorts.Relevant, delayed_force nat, - mkArrow cond Sorts.Relevant result))))|])in - let value = mkApp(constr_of_monomorphic_global (Util.delayed_force coq_sig_ref), - [|b; - (mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter))|]) in + mkApp + ( delayed_force ex + , [| delayed_force nat + ; mkLambda + ( make_annot (Name p_id) Sorts.Relevant + , delayed_force nat + , mkProd + ( make_annot (Name k_id) Sorts.Relevant + , delayed_force nat + , mkArrow cond Sorts.Relevant result ) ) |] ) + in + let value = + mkApp + ( constr_of_monomorphic_global (Util.delayed_force coq_sig_ref) + , [|b; mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter)|] ) + in compose_prod rev_args value - -let termination_proof_header is_mes input_type ids args_id relation - rec_arg_num rec_arg_id tac wf_tac : tactic = - begin - fun g -> - let nargs = List.length args_id in - let pre_rec_args = - List.rev_map - mkVar (fst (List.chop (rec_arg_num - 1) args_id)) - in - let relation = substl pre_rec_args relation in - let input_type = substl pre_rec_args input_type in - let wf_thm = next_ident_away_in_goal (Id.of_string ("wf_R")) ids in - let wf_rec_arg = - next_ident_away_in_goal - (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))) - (wf_thm::ids) - in - let hrec = next_ident_away_in_goal hrec_id - (wf_rec_arg::wf_thm::ids) in - let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) - in - tclTHEN - (h_intros args_id) - (tclTHENS +let termination_proof_header is_mes input_type ids args_id relation rec_arg_num + rec_arg_id tac wf_tac : tactic = + fun g -> + let nargs = List.length args_id in + let pre_rec_args = + List.rev_map mkVar (fst (List.chop (rec_arg_num - 1) args_id)) + in + let relation = substl pre_rec_args relation in + let input_type = substl pre_rec_args input_type in + let wf_thm = next_ident_away_in_goal (Id.of_string "wf_R") ids in + let wf_rec_arg = + next_ident_away_in_goal + (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)) + (wf_thm :: ids) + in + let hrec = next_ident_away_in_goal hrec_id (wf_rec_arg :: wf_thm :: ids) in + let acc_inv = + lazy + (mkApp + (delayed_force acc_inv_id, [|input_type; relation; mkVar rec_arg_id|])) + in + tclTHEN (h_intros args_id) + (tclTHENS + (observe_tac + (fun _ _ -> str "first assert") + (Proofview.V82.of_tactic + (assert_before (Name wf_rec_arg) + (mkApp + ( delayed_force acc_rel + , [|input_type; relation; mkVar rec_arg_id|] ))))) + [ (* accesibility proof *) + tclTHENS (observe_tac - (fun _ _ -> str "first assert") - (Proofview.V82.of_tactic (assert_before - (Name wf_rec_arg) - (mkApp (delayed_force acc_rel, - [|input_type;relation;mkVar rec_arg_id|]) - ) - )) - ) - [ - (* accesibility proof *) - tclTHENS - (observe_tac - (fun _ _ -> str "second assert") - (Proofview.V82.of_tactic (assert_before - (Name wf_thm) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - )) - ) - [ - (* interactive proof that the relation is well_founded *) - observe_tac (fun _ _ -> str "wf_tac") (wf_tac is_mes (Some args_id)); - (* this gives the accessibility argument *) - observe_tac - (fun _ _ -> str "apply wf_thm") - (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) - ) - ] - ; - (* rest of the proof *) - observe_tclTHENLIST (fun _ _ -> str "rest of proof") - [observe_tac (fun _ _ -> str "generalize") - (onNLastHypsId (nargs+1) - (tclMAP (fun id -> - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) - )) - ; - observe_tac (fun _ _ -> str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); - h_intros args_id; - Proofview.V82.of_tactic (Simple.intro wf_rec_arg); - observe_tac (fun _ _ -> str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) - ] + (fun _ _ -> str "second assert") + (Proofview.V82.of_tactic + (assert_before (Name wf_thm) + (mkApp + (delayed_force well_founded, [|input_type; relation|]))))) + [ (* interactive proof that the relation is well_founded *) + observe_tac + (fun _ _ -> str "wf_tac") + (wf_tac is_mes (Some args_id)) + ; (* this gives the accessibility argument *) + observe_tac + (fun _ _ -> str "apply wf_thm") + (Proofview.V82.of_tactic + (Simple.apply (mkApp (mkVar wf_thm, [|mkVar rec_arg_id|])))) ] - ) g - end - - + ; (* rest of the proof *) + observe_tclTHENLIST + (fun _ _ -> str "rest of proof") + [ observe_tac + (fun _ _ -> str "generalize") + (onNLastHypsId (nargs + 1) + (tclMAP (fun id -> + tclTHEN + (Proofview.V82.of_tactic + (Tactics.generalize [mkVar id])) + (Proofview.V82.of_tactic (clear [id]))))) + ; observe_tac + (fun _ _ -> str "fix") + (Proofview.V82.of_tactic (fix hrec (nargs + 1))) + ; h_intros args_id + ; Proofview.V82.of_tactic (Simple.intro wf_rec_arg) + ; observe_tac + (fun _ _ -> str "tac") + (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ]) + g let rec instantiate_lambda sigma t l = match l with | [] -> t - | a::l -> - let (_, _, body) = destLambda sigma t in - instantiate_lambda sigma (subst1 a body) l + | a :: l -> + let _, _, body = destLambda sigma t in + instantiate_lambda sigma (subst1 a body) l -let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : tactic = - begin - fun g -> - let sigma = project g in - let ids = Termops.ids_of_named_context (pf_hyps g) in - let func_body = (def_of_const (constr_of_monomorphic_global func)) in - let func_body = EConstr.of_constr func_body in - let (f_name, _, body1) = destLambda sigma func_body in - let f_id = - match f_name.binder_name with - | Name f_id -> next_ident_away_in_goal f_id ids - | Anonymous -> anomaly (Pp.str "Anonymous function.") - in - let n_names_types,_ = decompose_lam_n sigma nb_args body1 in - let n_ids,ids = - List.fold_left - (fun (n_ids,ids) (n_name,_) -> - match n_name.binder_name with - | Name id -> - let n_id = next_ident_away_in_goal id ids in - n_id::n_ids,n_id::ids - | _ -> anomaly (Pp.str "anonymous argument.") - ) - ([],(f_id::ids)) - n_names_types - in - let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = instantiate_lambda sigma func_body (mkVar f_id::(List.map mkVar n_ids)) in - termination_proof_header - is_mes - input_type - ids - n_ids - relation - rec_arg_num - rec_arg_id - (fun rec_arg_id hrec acc_id acc_inv g -> - (prove_terminate (fun infos -> tclIDTAC) - { is_main_branch = true; (* we are on the main branche (i.e. still on a match ... with .... end *) - is_final = true; (* and on leaf (more or less) *) - f_terminate = delayed_force coq_O; - nb_arg = nb_args; - concl_tac; - rec_arg_id = rec_arg_id; - is_mes = is_mes; - ih = hrec; - f_id = f_id; - f_constr = mkVar f_id; - func = func; - info = expr; - acc_inv = acc_inv; - acc_id = acc_id; - values_and_bounds = []; - eqs = []; - forbidden_ids = []; - args_assoc = [] - } - ) - g - ) - (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) - g - end +let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : + tactic = + fun g -> + let sigma = project g in + let ids = Termops.ids_of_named_context (pf_hyps g) in + let func_body = def_of_const (constr_of_monomorphic_global func) in + let func_body = EConstr.of_constr func_body in + let f_name, _, body1 = destLambda sigma func_body in + let f_id = + match f_name.binder_name with + | Name f_id -> next_ident_away_in_goal f_id ids + | Anonymous -> anomaly (Pp.str "Anonymous function.") + in + let n_names_types, _ = decompose_lam_n sigma nb_args body1 in + let n_ids, ids = + List.fold_left + (fun (n_ids, ids) (n_name, _) -> + match n_name.binder_name with + | Name id -> + let n_id = next_ident_away_in_goal id ids in + (n_id :: n_ids, n_id :: ids) + | _ -> anomaly (Pp.str "anonymous argument.")) + ([], f_id :: ids) + n_names_types + in + let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in + let expr = + instantiate_lambda sigma func_body (mkVar f_id :: List.map mkVar n_ids) + in + termination_proof_header is_mes input_type ids n_ids relation rec_arg_num + rec_arg_id + (fun rec_arg_id hrec acc_id acc_inv g -> + (prove_terminate + (fun infos -> tclIDTAC) + { is_main_branch = true + ; (* we are on the main branche (i.e. still on a match ... with .... end *) + is_final = true + ; (* and on leaf (more or less) *) + f_terminate = delayed_force coq_O + ; nb_arg = nb_args + ; concl_tac + ; rec_arg_id + ; is_mes + ; ih = hrec + ; f_id + ; f_constr = mkVar f_id + ; func + ; info = expr + ; acc_inv + ; acc_id + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; args_assoc = [] }) + g) + (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) + g let get_current_subgoals_types pstate = - let p = Proof_global.get_proof pstate in - let Proof.{ goals=sgs; sigma; _ } = Proof.data p in - sigma, List.map (Goal.V82.abstract_type sigma) sgs + let p = Declare.Proof.get_proof pstate in + let Proof.{goals = sgs; sigma; _} = Proof.data p in + (sigma, List.map (Goal.V82.abstract_type sigma) sgs) exception EmptySubgoals + let build_and_l sigma l = - let and_constr = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.and.type" in + let and_constr = + UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.and.type" + in let conj_constr = Coqlib.lib_ref "core.and.conj" in - let mk_and p1 p2 = - mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in + let mk_and p1 p2 = mkApp (EConstr.of_constr and_constr, [|p1; p2|]) in let rec is_well_founded t = match EConstr.kind sigma t with - | Prod(_,_,t') -> is_well_founded t' - | App(_,_) -> - let (f,_) = decompose_app sigma t in - EConstr.eq_constr sigma f (well_founded ()) - | _ -> - false + | Prod (_, _, t') -> is_well_founded t' + | App (_, _) -> + let f, _ = decompose_app sigma t in + EConstr.eq_constr sigma f (well_founded ()) + | _ -> false in let compare t1 t2 = - let b1,b2= is_well_founded t1,is_well_founded t2 in - if (b1&&b2) || not (b1 || b2) then 0 - else if b1 && not b2 then 1 else -1 + let b1, b2 = (is_well_founded t1, is_well_founded t2) in + if (b1 && b2) || not (b1 || b2) then 0 else if b1 && not b2 then 1 else -1 in let l = List.sort compare l in - let rec f = function + let rec f = function | [] -> raise EmptySubgoals - | [p] -> p,tclIDTAC,1 - | p1::pl -> - let c,tac,nb = f pl in - mk_and p1 c, - tclTHENS - (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) - [tclIDTAC; - tac - ],nb+1 - in f l - + | [p] -> (p, tclIDTAC, 1) + | p1 :: pl -> + let c, tac, nb = f pl in + ( mk_and p1 c + , tclTHENS + (Proofview.V82.of_tactic + (apply + (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) + [tclIDTAC; tac] + , nb + 1 ) + in + f l let is_rec_res id = - let rec_res_name = Id.to_string rec_res_id in + let rec_res_name = Id.to_string rec_res_id in let id_name = Id.to_string id in try - String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name + String.equal + (String.sub id_name 0 (String.length rec_res_name)) + rec_res_name with Invalid_argument _ -> false let clear_goals sigma = let rec clear_goal t = match EConstr.kind sigma t with - | Prod({binder_name=Name id} as na,t',b) -> - let b' = clear_goal b in - if noccurn sigma 1 b' && (is_rec_res id) - then Vars.lift (-1) b' - else if b' == b then t - else mkProd(na,t',b') - | _ -> EConstr.map sigma clear_goal t + | Prod (({binder_name = Name id} as na), t', b) -> + let b' = clear_goal b in + if noccurn sigma 1 b' && is_rec_res id then Vars.lift (-1) b' + else if b' == b then t + else mkProd (na, t', b') + | _ -> EConstr.map sigma clear_goal t in List.map clear_goal - let build_new_goal_type lemma = let sigma, sub_gls_types = Lemmas.pf_fold get_current_subgoals_types lemma in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sigma sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let res = build_and_l sigma sub_gls_types in - sigma, res + (sigma, res) let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with - | Declarations.OpaqueDef _ -> Proof_global.Opaque - | Declarations.Undef _ -> Proof_global.Opaque - | Declarations.Def _ -> Proof_global.Transparent - | Declarations.Primitive _ -> Proof_global.Opaque + | Declarations.OpaqueDef _ -> Declare.Opaque + | Declarations.Undef _ -> Declare.Opaque + | Declarations.Def _ -> Declare.Transparent + | Declarations.Primitive _ -> Declare.Opaque -let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name + (gls_type, decompose_and_tac, nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) - let current_proof_name = Lemmas.pf_fold Proof_global.get_proof_name lemma in - let name = match goal_name with + let current_proof_name = Lemmas.pf_fold Declare.Proof.get_proof_name lemma in + let name = + match goal_name with | Some s -> s - | None -> - try add_suffix current_proof_name "_subproof" - with e when CErrors.noncritical e -> - anomaly (Pp.str "open_new_goal with an unnamed theorem.") + | None -> ( + try add_suffix current_proof_name "_subproof" + with e when CErrors.noncritical e -> + anomaly (Pp.str "open_new_goal with an unnamed theorem.") ) in let na = next_global_ident_away name Id.Set.empty in if Termops.occur_existential sigma gls_type then @@ -1275,8 +1433,8 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let na_ref = qualid_of_ident na in let na_global = Smartlocate.global_with_alias na_ref in match na_global with - GlobRef.ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") + | GlobRef.ConstRef c -> is_opaque_constant c + | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in ref_ := Value (EConstr.Unsafe.to_constr lemma); @@ -1288,7 +1446,8 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let open Tacticals.New in Proofview.Goal.enter (fun gl -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gl) in - New.observe_tclTHENLIST (fun _ _ -> mt ()) + New.observe_tclTHENLIST + (fun _ _ -> mt ()) [ generalize [lemma] ; Simple.intro hid ; Proofview.Goal.enter (fun gl -> @@ -1299,195 +1458,252 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let ids' = pf_ids_of_hyps gl in lid := List.rev (List.subtract Id.equal ids' ids); if List.is_empty !lid then lid := [hid]; - tclIDTAC))) - ]) in + tclIDTAC))) ]) + in let end_tac = let open Tacmach.New in let open Tacticals.New in Proofview.Goal.enter (fun gl -> let sigma = project gl in match EConstr.kind sigma (pf_concl gl) with - | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> + | App (f, _) when EConstr.eq_constr sigma f (well_founded ()) -> Auto.h_auto None [] (Some []) | _ -> incr h_num; - tclCOMPLETE( - tclFIRST - [ tclTHEN - (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) - e_assumption - ; Eauto.eauto_with_bases - (true,5) - [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] - [Hints.Hint_db.empty TransparentState.empty false - ] - ] - )) in + tclCOMPLETE + (tclFIRST + [ tclTHEN + (eapply_with_bindings + (mkVar (List.nth !lid !h_num), NoBindings)) + e_assumption + ; Eauto.eauto_with_bases (true, 5) + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] + [Hints.Hint_db.empty TransparentState.empty false] ])) + in let lemma = build_proof env (Evd.from_env env) start_tac end_tac in Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None in let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) () in - let lemma = Lemmas.start_lemma - ~name:na - ~poly:false (* FIXME *) ~info - sigma gls_type in - let lemma = if Indfun_common.is_strict_tcc () - then - fst @@ Lemmas.by (Proofview.V82.tactic (tclIDTAC)) lemma - else - fst @@ Lemmas.by (Proofview.V82.tactic begin - fun g -> - tclTHEN - (decompose_and_tac) - (tclORELSE - (tclFIRST - (List.map - (fun c -> - Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST - [intros; - Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*); - Tacticals.New.tclCOMPLETE Auto.default_auto - ]) - ) - using_lemmas) - ) tclIDTAC) - g end) lemma + let lemma = + Lemmas.start_lemma ~name:na ~poly:false (* FIXME *) ~info sigma gls_type + in + let lemma = + if Indfun_common.is_strict_tcc () then + fst @@ Lemmas.by (Proofview.V82.tactic tclIDTAC) lemma + else + fst + @@ Lemmas.by + (Proofview.V82.tactic (fun g -> + tclTHEN decompose_and_tac + (tclORELSE + (tclFIRST + (List.map + (fun c -> + Proofview.V82.of_tactic + (Tacticals.New.tclTHENLIST + [ intros + ; Simple.apply + (fst + (interp_constr (Global.env ()) + Evd.empty c)) + (*FIXME*) + ; Tacticals.New.tclCOMPLETE Auto.default_auto + ])) + using_lemmas)) + tclIDTAC) + g)) + lemma in - if Lemmas.(pf_fold Proof_global.get_open_goals) lemma = 0 then (defined lemma; None) else Some lemma - -let com_terminate - interactive_proof - tcc_lemma_name - tcc_lemma_ref - is_mes - fonctional_ref - input_type - relation - rec_arg_num - thm_name using_lemmas - nb_args ctx - hook = + if Lemmas.(pf_fold Declare.Proof.get_open_goals) lemma = 0 then ( + defined lemma; None ) + else Some lemma + +let com_terminate interactive_proof tcc_lemma_name tcc_lemma_ref is_mes + fonctional_ref input_type relation rec_arg_num thm_name using_lemmas nb_args + ctx hook = let start_proof env ctx tac_start tac_end = let info = Lemmas.Info.make ~hook () in - let lemma = Lemmas.start_lemma ~name:thm_name - ~poly:false (*FIXME*) - ~info - ctx - (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) in - let lemma = fst @@ Lemmas.by (New.observe_tac (fun _ _ -> str "starting_tac") tac_start) lemma in - fst @@ Lemmas.by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref - input_type relation rec_arg_num ))) lemma + let lemma = + Lemmas.start_lemma ~name:thm_name ~poly:false (*FIXME*) ~info ctx + (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) + in + let lemma = + fst + @@ Lemmas.by + (New.observe_tac (fun _ _ -> str "starting_tac") tac_start) + lemma + in + fst + @@ Lemmas.by + (Proofview.V82.tactic + (observe_tac + (fun _ _ -> str "whole_start") + (whole_start tac_end nb_args is_mes fonctional_ref input_type + relation rec_arg_num))) + lemma + in + let lemma = + start_proof + Global.(env ()) + ctx Tacticals.New.tclIDTAC Tacticals.New.tclIDTAC in - let lemma = start_proof Global.(env ()) ctx Tacticals.New.tclIDTAC Tacticals.New.tclIDTAC in try let sigma, new_goal_type = build_new_goal_type lemma in let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in - open_new_goal ~lemma start_proof sigma - using_lemmas tcc_lemma_ref - (Some tcc_lemma_name) - (new_goal_type) + open_new_goal ~lemma start_proof sigma using_lemmas tcc_lemma_ref + (Some tcc_lemma_name) new_goal_type with EmptySubgoals -> (* a non recursive function declared with measure ! *) tcc_lemma_ref := Not_needed; - if interactive_proof then Some lemma - else (defined lemma; None) + if interactive_proof then Some lemma else (defined lemma; None) -let start_equation (f:GlobRef.t) (term_f:GlobRef.t) - (cont_tactic:Id.t list -> tactic) g = +let start_equation (f : GlobRef.t) (term_f : GlobRef.t) + (cont_tactic : Id.t list -> tactic) g = let sigma = project g in let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_monomorphic_global term_f in let terminate_constr = EConstr.of_constr terminate_constr in - let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in + let nargs = + nb_prod (project g) + (EConstr.of_constr (type_of_const sigma terminate_constr)) + in let x = n_x_id ids nargs in - observe_tac (fun _ _ -> str "start_equation") (observe_tclTHENLIST (fun _ _ -> str "start_equation") [ - h_intros x; - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); - observe_tac (fun _ _ -> str "simplest_case") - (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, - Array.of_list (List.map mkVar x))))); - observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x)]) g;; - -let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type = - let open CVars in - let opacity = - match terminate_ref with - | GlobRef.ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") - in - let evd = Evd.from_ctx uctx in - let f_constr = constr_of_monomorphic_global f_ref in - let equation_lemma_type = subst1 f_constr equation_lemma_type in - let lemma = Lemmas.start_lemma ~name:eq_name ~poly:false evd - (EConstr.of_constr equation_lemma_type) in - let lemma = fst @@ Lemmas.by - (Proofview.V82.tactic (start_equation f_ref terminate_ref - (fun x -> - prove_eq (fun _ -> tclIDTAC) - {nb_arg=nb_arg; - f_terminate = EConstr.of_constr (constr_of_monomorphic_global terminate_ref); - f_constr = EConstr.of_constr f_constr; - concl_tac = Tacticals.New.tclIDTAC; - func=functional_ref; - info=(instantiate_lambda Evd.empty - (EConstr.of_constr (def_of_const (constr_of_monomorphic_global functional_ref))) - (EConstr.of_constr f_constr::List.map mkVar x) - ); - is_main_branch = true; - is_final = true; - values_and_bounds = []; - eqs = []; - forbidden_ids = []; - acc_inv = lazy (assert false); - acc_id = Id.of_string "____"; - args_assoc = []; - f_id = Id.of_string "______"; - rec_arg_id = Id.of_string "______"; - is_mes = false; - ih = Id.of_string "______"; - } - ) - )) lemma in - let _ = Flags.silently (fun () -> Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None) () in - () -(* Pp.msgnl (fun _ _ -> str "eqn finished"); *) + observe_tac + (fun _ _ -> str "start_equation") + (observe_tclTHENLIST + (fun _ _ -> str "start_equation") + [ h_intros x + ; Proofview.V82.of_tactic + (unfold_in_concl + [(Locus.AllOccurrences, evaluable_of_global_reference f)]) + ; observe_tac + (fun _ _ -> str "simplest_case") + (Proofview.V82.of_tactic + (simplest_case + (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))) + ; observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x) ]) + g +let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref + equation_lemma_type = + let open CVars in + let opacity = + match terminate_ref with + | GlobRef.ConstRef c -> is_opaque_constant c + | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") + in + let evd = Evd.from_ctx uctx in + let f_constr = constr_of_monomorphic_global f_ref in + let equation_lemma_type = subst1 f_constr equation_lemma_type in + let lemma = + Lemmas.start_lemma ~name:eq_name ~poly:false evd + (EConstr.of_constr equation_lemma_type) + in + let lemma = + fst + @@ Lemmas.by + (Proofview.V82.tactic + (start_equation f_ref terminate_ref (fun x -> + prove_eq + (fun _ -> tclIDTAC) + { nb_arg + ; f_terminate = + EConstr.of_constr + (constr_of_monomorphic_global terminate_ref) + ; f_constr = EConstr.of_constr f_constr + ; concl_tac = Tacticals.New.tclIDTAC + ; func = functional_ref + ; info = + instantiate_lambda Evd.empty + (EConstr.of_constr + (def_of_const + (constr_of_monomorphic_global functional_ref))) + (EConstr.of_constr f_constr :: List.map mkVar x) + ; is_main_branch = true + ; is_final = true + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; acc_inv = lazy (assert false) + ; acc_id = Id.of_string "____" + ; args_assoc = [] + ; f_id = Id.of_string "______" + ; rec_arg_id = Id.of_string "______" + ; is_mes = false + ; ih = Id.of_string "______" }))) + lemma + in + let _ = + Flags.silently + (fun () -> Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None) + () + in + () -let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type_of_f r rec_arg_num eq - generate_induction_principle using_lemmas : Lemmas.t option = +(* Pp.msgnl (fun _ _ -> str "eqn finished"); *) + +let recursive_definition ~interactive_proof ~is_mes function_name rec_impls + type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : + Lemmas.t option = let open Term in let open Constr in let open CVars in - let env = Global.env() in + let env = Global.env () in let evd = Evd.from_env env in - let evd, function_type = interp_type_evars ~program_mode:false env evd type_of_f in - let function_r = Sorts.Relevant in (* TODO relevance *) - let env = EConstr.push_named (Context.Named.Declaration.LocalAssum (make_annot function_name function_r,function_type)) env in + let evd, function_type = + interp_type_evars ~program_mode:false env evd type_of_f + in + let function_r = Sorts.Relevant in + (* TODO relevance *) + let env = + EConstr.push_named + (Context.Named.Declaration.LocalAssum + (make_annot function_name function_r, function_type)) + env + in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let evd, ty = interp_type_evars ~program_mode:false env evd ~impls:rec_impls eq in + let evd, ty = + interp_type_evars ~program_mode:false env evd ~impls:rec_impls eq + in let evd = Evd.minimize_universes evd in - let equation_lemma_type = Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) in - let function_type = EConstr.to_constr ~abort_on_undefined_evars:false evd function_type in + let equation_lemma_type = + Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) + in + let function_type = + EConstr.to_constr ~abort_on_undefined_evars:false evd function_type + in let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in - (* Pp.msgnl (fun _ _ -> str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) - let res_vars,eq' = decompose_prod equation_lemma_type in - let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in + (* Pp.msgnl (fun _ _ -> str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) + let res_vars, eq' = decompose_prod equation_lemma_type in + let env_eq' = + Environ.push_rel_context + (List.map (fun (x, y) -> LocalAssum (x, y)) res_vars) + env + in let eq' = Reductionops.nf_zeta env_eq' evd (EConstr.of_constr eq') in let eq' = EConstr.Unsafe.to_constr eq' in let res = -(* Pp.msgnl (fun _ _ -> str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) -(* Pp.msgnl (fun _ _ -> str "rec_arg_num := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) -(* Pp.msgnl (fun _ _ -> str "eq' := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) + (* Pp.msgnl (fun _ _ -> str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) + (* Pp.msgnl (fun _ _ -> str "rec_arg_num := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) + (* Pp.msgnl (fun _ _ -> str "eq' := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) match Constr.kind eq' with - | App(e,[|_;_;eq_fix|]) -> - mkLambda (make_annot (Name function_name) Sorts.Relevant,function_type,subst_var function_name (compose_lam res_vars eq_fix)) - | _ -> failwith "Recursive Definition (res not eq)" + | App (e, [|_; _; eq_fix|]) -> + mkLambda + ( make_annot (Name function_name) Sorts.Relevant + , function_type + , subst_var function_name (compose_lam res_vars eq_fix) ) + | _ -> failwith "Recursive Definition (res not eq)" + in + let pre_rec_args, function_type_before_rec_arg = + decompose_prod_n (rec_arg_num - 1) function_type + in + let _, rec_arg_type, _ = destProd function_type_before_rec_arg in + let arg_types = + List.rev_map snd + (fst (decompose_prod_n (List.length res_vars) function_type)) in - let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in - let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in - let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in let equation_id = add_suffix function_name "_equation" in - let functional_id = add_suffix function_name "_F" in + let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = let univs = Evd.univ_entry ~poly:false evd in @@ -1495,57 +1711,61 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type in (* Refresh the global universes, now including those of _F *) let evd = Evd.from_env (Global.env ()) in - let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in - let relation, evuctx = - interp_constr env_with_pre_rec_args evd r + let env_with_pre_rec_args = + push_rel_context + (List.map (function x, t -> LocalAssum (x, t)) pre_rec_args) + env in + let relation, evuctx = interp_constr env_with_pre_rec_args evd r in let evd = Evd.from_ctx evuctx in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref Undefined in (* let _ = Pp.msgnl (fun _ _ -> str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook { DeclareDef.Hook.S.uctx ; _ } = + let hook {DeclareDef.Hook.S.uctx; _} = let term_ref = Nametab.locate (qualid_of_ident term_id) in - let f_ref = declare_f function_name Decls.(IsProof Lemma) arg_types term_ref in - let _ = Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] in + let f_ref = + declare_f function_name Decls.(IsProof Lemma) arg_types term_ref + in + let _ = + Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] + in (* message "start second proof"; *) let stop = (* XXX: What is the correct way to get sign at hook time *) try - com_eqn uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); + com_eqn uctx (List.length res_vars) equation_id functional_ref f_ref + term_ref + (subst_var function_name equation_lemma_type); false with e when CErrors.noncritical e -> - begin - if do_observe () - then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e) - else CErrors.user_err ~hdr:"Cannot create equation Lemma" - (str "Cannot create equation lemma." ++ spc () ++ - str "This may be because the function is nested-recursive.") - ; - true - end + if do_observe () then + Feedback.msg_debug + (str "Cannot create equation Lemma " ++ CErrors.print e) + else + CErrors.user_err ~hdr:"Cannot create equation Lemma" + ( str "Cannot create equation lemma." + ++ spc () + ++ str "This may be because the function is nested-recursive." ); + true in - if not stop - then - let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in + if not stop then + let eq_ref = Nametab.locate (qualid_of_ident equation_id) in let f_ref = destConst (constr_of_monomorphic_global f_ref) - and functional_ref = destConst (constr_of_monomorphic_global functional_ref) + and functional_ref = + destConst (constr_of_monomorphic_global functional_ref) and eq_ref = destConst (constr_of_monomorphic_global eq_ref) in - generate_induction_principle f_ref tcc_lemma_constr - functional_ref eq_ref rec_arg_num + generate_induction_principle f_ref tcc_lemma_constr functional_ref eq_ref + rec_arg_num (EConstr.of_constr rec_arg_type) - (nb_prod evd (EConstr.of_constr res)) relation + (nb_prod evd (EConstr.of_constr res)) + relation in (* XXX STATE Why do we need this... why is the toplevel protection not enough *) - funind_purify (fun () -> - com_terminate - interactive_proof - tcc_lemma_name - tcc_lemma_constr - is_mes functional_ref + funind_purify + (fun () -> + com_terminate interactive_proof tcc_lemma_name tcc_lemma_constr is_mes + functional_ref (EConstr.of_constr rec_arg_type) - relation rec_arg_num - term_id - using_lemmas - (List.length res_vars) - evd (DeclareDef.Hook.make hook)) + relation rec_arg_num term_id using_lemmas (List.length res_vars) evd + (DeclareDef.Hook.make hook)) () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 3225411c85..4e5146e37c 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -1,13 +1,13 @@ open Constr -val tclUSER_if_not_mes - : unit Proofview.tactic +val tclUSER_if_not_mes : + unit Proofview.tactic -> bool -> Names.Id.t list option -> unit Proofview.tactic -val recursive_definition - : interactive_proof:bool +val recursive_definition : + interactive_proof:bool -> is_mes:bool -> Names.Id.t -> Constrintern.internalization_env @@ -15,7 +15,14 @@ val recursive_definition -> Constrexpr.constr_expr -> int -> Constrexpr.constr_expr - -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) + -> ( pconstant + -> Indfun_common.tcc_lemma_value ref + -> pconstant + -> pconstant + -> int + -> EConstr.types + -> int + -> EConstr.constr + -> unit) -> Constrexpr.constr_expr list -> Lemmas.t option diff --git a/plugins/ltac/plugin_base.dune b/plugins/ltac/dune index 5611f5ba16..6558ecbfe8 100644 --- a/plugins/ltac/plugin_base.dune +++ b/plugins/ltac/dune @@ -11,3 +11,5 @@ (synopsis "Coq's tauto tactic") (modules tauto) (libraries coq.plugins.ltac)) + +(coq.pp (modules extratactics g_tactic g_rewrite g_eqdecide g_auto g_obligations g_ltac profile_ltac_tactics coretactics g_class extraargs)) diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 7b1aa7a07a..0bad3cbe5b 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -312,7 +312,7 @@ let add_rewrite_hint ~poly bases ort t lcsr = 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 ~poly:false ctx; + (DeclareUctx.declare_universe_context ~poly:false ctx; Univ.ContextSet.empty) in CAst.make ?loc:(Constrexpr_ops.constr_loc ce) ((c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t) in @@ -346,7 +346,7 @@ open Vars let constr_flags () = { Pretyping.use_typeclasses = Pretyping.UseTC; - Pretyping.solve_unification_constraints = Pfedit.use_unification_heuristics (); + Pretyping.solve_unification_constraints = Proof.use_unification_heuristics (); Pretyping.fail_evar = false; Pretyping.expand_evars = true; Pretyping.program_mode = false; @@ -918,7 +918,7 @@ END VERNAC COMMAND EXTEND GrabEvars STATE proof | [ "Grab" "Existential" "Variables" ] => { classify_as_proofstep } - -> { fun ~pstate -> Proof_global.map_proof (fun p -> Proof.V82.grab_evars p) pstate } + -> { fun ~pstate -> Declare.Proof.map_proof (fun p -> Proof.V82.grab_evars p) pstate } END (* Shelves all the goals under focus. *) @@ -950,7 +950,7 @@ END VERNAC COMMAND EXTEND Unshelve STATE proof | [ "Unshelve" ] => { classify_as_proofstep } - -> { fun ~pstate -> Proof_global.map_proof (fun p -> Proof.unshelve p) pstate } + -> { fun ~pstate -> Declare.Proof.map_proof (fun p -> Proof.unshelve p) pstate } END (* Gives up on the goals under focus: the goals are considered solved, @@ -1102,7 +1102,7 @@ END VERNAC COMMAND EXTEND OptimizeProof | ![ proof ] [ "Optimize" "Proof" ] => { classify_as_proofstep } -> - { fun ~pstate -> Proof_global.compact_the_proof pstate } + { fun ~pstate -> Declare.Proof.compact pstate } | [ "Optimize" "Heap" ] => { classify_as_proofstep } -> { Gc.compact () } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 50c3ed1248..5baa23b3e9 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -342,7 +342,7 @@ GRAMMAR EXTEND Gram hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; tac = Pltac.tactic -> - { Hints.HintsExtern (n,c, in_tac tac) } ] ] + { ComHints.HintsExtern (n,c, in_tac tac) } ] ] ; operconstr: LEVEL "0" [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> @@ -359,23 +359,17 @@ open Vernacextend open Goptions open Libnames -let print_info_trace = ref None - -let () = declare_int_option { - optdepr = false; - optkey = ["Info" ; "Level"]; - optread = (fun () -> !print_info_trace); - optwrite = fun n -> print_info_trace := n; -} +let print_info_trace = + declare_intopt_option_and_ref ~depr:false ~key:["Info" ; "Level"] let vernac_solve ~pstate n info tcom b = let open Goal_select in - let pstate, status = Proof_global.map_fold_proof_endline (fun etac p -> + let pstate, status = Declare.Proof.map_fold_proof_endline (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 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 + Proof.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 *) diff --git a/plugins/ltac/leminv.ml b/plugins/ltac/leminv.ml new file mode 100644 index 0000000000..5a8ec404ee --- /dev/null +++ b/plugins/ltac/leminv.ml @@ -0,0 +1,297 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Names +open Termops +open Environ +open Constr +open Context +open EConstr +open Vars +open Namegen +open Evd +open Printer +open Reductionops +open Inductiveops +open Tacmach.New +open Clenv +open Tacticals.New +open Tactics +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration + +let no_inductive_inconstr env sigma constr = + (str "Cannot recognize an inductive predicate in " ++ + pr_leconstr_env env sigma constr ++ + str "." ++ spc () ++ str "If there is one, may be the structure of the arity" ++ + spc () ++ str "or of the type of constructors" ++ spc () ++ + str "is hidden by constant definitions.") + +(* Inversion stored in lemmas *) + +(* ALGORITHM: + + An inversion stored in a lemma is computed from a term-pattern, in + a signature, as follows: + + Suppose we have an inductive relation, (I abar), in a signature Gamma: + + Gamma |- (I abar) + + Then we compute the free-variables of abar. Suppose that Gamma is + thinned out to only include these. + + [We need technically to require that all free-variables of the + types of the free variables of abar are themselves free-variables + of abar. This needs to be checked, but it should not pose a + problem - it is hard to imagine cases where it would not hold.] + + Now, we pose the goal: + + (P:(Gamma)Prop)(Gamma)(I abar)->(P vars[Gamma]). + + We execute the tactic: + + REPEAT Intro THEN (OnLastHyp (Inv NONE false o outSOME)) + + This leaves us with some subgoals. All the assumptions after "P" + in these subgoals are new assumptions. I.e. if we have a subgoal, + + P:(Gamma)Prop, Gamma, Hbar:Tbar |- (P ybar) + + then the assumption we needed to have was + + (Hbar:Tbar)(P ybar) + + So we construct all the assumptions we need, and rebuild the goal + with these assumptions. Then, we can re-apply the same tactic as + above, but instead of stopping after the inversion, we just apply + the respective assumption in each subgoal. + + *) + +(* returns the sub_signature of sign corresponding to those identifiers that + * are not global. *) +(* +let get_local_sign sign = + let lid = ids_of_sign sign in + let globsign = Global.named_context() in + let add_local id res_sign = + if not (mem_sign globsign id) then + add_sign (lookup_sign id sign) res_sign + else + res_sign + in + List.fold_right add_local lid nil_sign +*) +(* returns the identifier of lid that was the latest declared in sign. + * (i.e. is the identifier id of lid such that + * sign_length (sign_prefix id sign) > sign_length (sign_prefix id' sign) > + * for any id'<>id in lid). + * it returns both the pair (id,(sign_prefix id sign)) *) +(* +let max_prefix_sign lid sign = + let rec max_rec (resid,prefix) = function + | [] -> (resid,prefix) + | (id::l) -> + let pre = sign_prefix id sign in + if sign_length pre > sign_length prefix then + max_rec (id,pre) l + else + max_rec (resid,prefix) l + in + match lid with + | [] -> nil_sign + | id::l -> snd (max_rec (id, sign_prefix id sign) l) +*) +let rec add_prods_sign env sigma t = + match EConstr.kind sigma (whd_all env sigma t) with + | Prod (na,c1,b) -> + let id = id_of_name_using_hdchar env sigma t na.binder_name in + let b'= subst1 (mkVar id) b in + add_prods_sign (push_named (LocalAssum ({na with binder_name=id},c1)) env) sigma b' + | LetIn (na,c1,t1,b) -> + let id = id_of_name_using_hdchar env sigma t na.binder_name in + let b'= subst1 (mkVar id) b in + add_prods_sign (push_named (LocalDef ({na with binder_name=id},c1,t1)) env) sigma b' + | _ -> (env,t) + +(* [dep_option] indicates whether the inversion lemma is dependent or not. + If it is dependent and I is of the form (x_bar:T_bar)(I t_bar) then + the stated goal will be (x_bar:T_bar)(H:(I t_bar))(P t_bar H) + where P:(x_bar:T_bar)(H:(I x_bar))[sort]. + The generalisation of such a goal at the moment of the dependent case should + be easy. + + If it is non dependent, then if [I]=(I t_bar) and (x_bar:T_bar) are the + variables occurring in [I], then the stated goal will be: + (x_bar:T_bar)(I t_bar)->(P x_bar) + where P: P:(x_bar:T_bar)[sort]. +*) + +let compute_first_inversion_scheme env sigma ind sort dep_option = + let indf,realargs = dest_ind_type ind in + let allvars = vars_of_env env in + let p = next_ident_away (Id.of_string "P") allvars in + let pty,goal = + if dep_option then + let pty = make_arity env sigma true indf sort in + let r = relevance_of_inductive_type env ind in + let goal = + mkProd + (make_annot Anonymous r, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1])) + in + pty,goal + else + let i = mkAppliedInd ind in + let ivars = global_vars env sigma i in + let revargs,ownsign = + fold_named_context + (fun env d (revargs,hyps) -> + let d = map_named_decl EConstr.of_constr d in + let id = NamedDecl.get_id d in + if Id.List.mem id ivars then + ((mkVar id)::revargs, Context.Named.add d hyps) + else + (revargs,hyps)) + env ~init:([],[]) + in + let pty = it_mkNamedProd_or_LetIn (mkSort sort) ownsign in + let goal = mkArrow i Sorts.Relevant (applist(mkVar p, List.rev revargs)) in + (pty,goal) + in + let npty = nf_all env sigma pty in + let extenv = push_named (LocalAssum (make_annot p Sorts.Relevant,npty)) env in + extenv, goal + +(* [inversion_scheme sign I] + + Given a local signature, [sign], and an instance of an inductive + relation, [I], inversion_scheme will prove the associated inversion + scheme on sort [sort]. Depending on the value of [dep_option] it will + build a dependent lemma or a non-dependent one *) + +let inversion_scheme ~name ~poly env sigma t sort dep_option inv_op = + let (env,i) = add_prods_sign env sigma t in + let ind = + try find_rectype env sigma i + with Not_found -> + user_err ~hdr:"inversion_scheme" (no_inductive_inconstr env sigma i) + in + let (invEnv,invGoal) = + compute_first_inversion_scheme env sigma ind sort dep_option + in + assert + (List.subset + (global_vars env sigma invGoal) + (ids_of_named_context (named_context invEnv))); + (* + user_err ~hdr:"lemma_inversion" + (str"Computed inversion goal was not closed in initial signature."); + *) + let pf = Proof.start ~name ~poly (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in + let pf, _, () = Proof.run_tactic env (tclTHEN intro (onLastHypId inv_op)) pf in + let pfterm = List.hd (Proof.partial_proof pf) in + let global_named_context = Global.named_context_val () in + let ownSign = ref begin + fold_named_context + (fun env d sign -> + let d = map_named_decl EConstr.of_constr d in + if mem_named_context_val (NamedDecl.get_id d) global_named_context then sign + else Context.Named.add d sign) + invEnv ~init:Context.Named.empty + end in + let avoid = ref Id.Set.empty in + let Proof.{sigma} = Proof.data pf in + let sigma = Evd.minimize_universes sigma in + let rec fill_holes c = + match EConstr.kind sigma c with + | Evar (e,args) -> + let h = next_ident_away (Id.of_string "H") !avoid in + let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in + avoid := Id.Set.add h !avoid; + ownSign := Context.Named.add (LocalAssum (make_annot h Sorts.Relevant,ty)) !ownSign; + applist (mkVar h, inst) + | _ -> EConstr.map sigma fill_holes c + in + let c = fill_holes pfterm in + (* warning: side-effect on ownSign *) + let invProof = it_mkNamedLambda_or_LetIn c !ownSign in + let p = EConstr.to_constr sigma invProof in + p, sigma + +let add_inversion_lemma ~poly name env sigma t sort dep inv_op = + let invProof, sigma = inversion_scheme ~name ~poly env sigma t sort dep inv_op in + let univs = Evd.univ_entry ~poly sigma in + let entry = Declare.definition_entry ~univs invProof in + let _ : Names.Constant.t = Declare.declare_constant ~name ~kind:Decls.(IsProof Lemma) (Declare.DefinitionEntry entry) in + () + +(* inv_op = Inv (derives de complete inv. lemma) + * inv_op = InvNoThining (derives de semi inversion lemma) *) + +let add_inversion_lemma_exn ~poly na com comsort bool tac = + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, c = Constrintern.interp_type_evars ~program_mode:false env sigma com in + let sigma, sort = Evd.fresh_sort_in_family ~rigid:univ_rigid sigma comsort in + try + add_inversion_lemma ~poly na env sigma c sort bool tac + with + | UserError (Some "Case analysis",s) -> (* Reference to Indrec *) + user_err ~hdr:"Inv needs Nodep Prop Set" s + +(* ================================= *) +(* Applying a given inversion lemma *) +(* ================================= *) + +let lemInv id c = + Proofview.Goal.enter begin fun gls -> + try + let clause = mk_clenv_from_env (pf_env gls) (project gls) None (c, pf_get_type_of gls c) in + let clause = clenv_constrain_last_binding (EConstr.mkVar id) clause in + Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false + with + | NoSuchBinding -> + user_err + (hov 0 (pr_econstr_env (pf_env gls) (project gls) c ++ spc () ++ str "does not refer to an inversion lemma.")) + | UserError (a,b) -> + user_err ~hdr:"LemInv" + (str "Cannot refine current goal with the lemma " ++ + pr_leconstr_env (pf_env gls) (project gls) c) + end + +let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id + +let lemInvIn id c ids = + Proofview.Goal.enter begin fun gl -> + let hyps = List.map (fun id -> pf_get_hyp id gl) ids in + let intros_replace_ids = + let concl = Proofview.Goal.concl gl in + let sigma = project gl in + let nb_of_new_hyp = nb_prod sigma concl - List.length ids in + if nb_of_new_hyp < 1 then + intros_replacing ids + else + (tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)) + in + ((tclTHEN (tclTHEN (bring_hyps hyps) (lemInv id c)) + (intros_replace_ids))) + end + +let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id + +let lemInv_clause id c = function + | [] -> lemInv_gen id c + | l -> lemInvIn_gen id c l diff --git a/plugins/ltac/leminv.mli b/plugins/ltac/leminv.mli new file mode 100644 index 0000000000..5a5de7b58f --- /dev/null +++ b/plugins/ltac/leminv.mli @@ -0,0 +1,21 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open EConstr +open Constrexpr +open Tactypes + +val lemInv_clause : + quantified_hypothesis -> constr -> Id.t list -> unit Proofview.tactic + +val add_inversion_lemma_exn : poly:bool -> + Id.t -> constr_expr -> Sorts.family -> bool -> (Id.t -> unit Proofview.tactic) -> + unit diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index e83eab20dc..f31361279c 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -9,6 +9,7 @@ Tactic_debug Tacintern Profile_ltac Tactic_matching +Leminv Tacinterp Tacentries Evar_tactics diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 14fab251d0..0dbf16a821 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -25,27 +25,20 @@ let is_profiling = Flags.profile_ltac let set_profiling b = is_profiling := b let get_profiling () = !is_profiling -(** LtacProf cannot yet handle backtracking into multi-success tactics. - To properly support this, we'd have to somehow recreate our location in the - call-stack, and stop/restart the intervening timers. This is tricky and - possibly expensive, so instead we currently just emit a warning that - profiling results will be off. *) -let encountered_multi_success_backtracking = ref false - -let warn_profile_backtracking = - CWarnings.create ~name:"profile-backtracking" ~category:"ltac" - (fun () -> 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 +let encountered_invalid_stack_no_self = ref false + +let warn_invalid_stack_no_self = + CWarnings.create ~name:"profile-invalid-stack-no-self" ~category:"ltac" + (fun () -> strbrk + "Ltac Profiler encountered an invalid stack (no self \ + node). This can happen if you reset the profile during \ + tactic execution.") + +let encounter_invalid_stack_no_self () = + if not !encountered_invalid_stack_no_self then begin - encountered_multi_success_backtracking := true; - warn_encountered_multi_success_backtracking () + encountered_invalid_stack_no_self := true; + warn_invalid_stack_no_self () end @@ -76,8 +69,7 @@ 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 + Local.(stack := [empty_treenode root]) (* ************** XML Serialization ********************* *) @@ -218,7 +210,6 @@ let to_string ~filter ?(cutoff=0.0) node = 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))) ++ @@ -296,13 +287,15 @@ let exit_tactic ~count_call start_time c = match Local.(!stack) with | [] | [_] -> (* oops, our stack is invalid *) - encounter_multi_success_backtracking (); + encounter_invalid_stack_no_self (); 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 (); + CErrors.anomaly + (Pp.strbrk "Ltac Profiler encountered an invalid stack (wrong self node) \ + likely due to backtracking into multi-success tactics."); let node = { node with total = node.total +. diff; local = node.local +. diff; @@ -332,38 +325,56 @@ let exit_tactic ~count_call start_time c = (* Calls are over, we reset the stack and send back data *) if rest == [] && get_profiling () then begin assert(String.equal root parent.name); + encountered_invalid_stack_no_self := false; reset_profile_tmp (); feedback_results parent end -let tclFINALLY tac (finally : unit Proofview.tactic) = +(** [tclWRAPFINALLY before tac finally] runs [before] before each + entry-point of [tac] and passes the result of [before] to + [finally], which is then run at each exit-point of [tac], + regardless of whether it succeeds or fails. Said another way, if + [tac] succeeds, then it behaves as [before >>= fun v -> tac >>= fun + ret -> finally v <*> tclUNIT ret]; otherwise, if [tac] fails with + [e], it behaves as [before >>= fun v -> finally v <*> tclZERO + e]. *) +let rec tclWRAPFINALLY before tac finally = + let open Proofview in let open Proofview.Notations in - Proofview.tclIFCATCH - tac - (fun v -> finally <*> Proofview.tclUNIT v) - (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn) + before >>= fun v -> tclCASE tac >>= function + | Fail (e, info) -> finally v >>= fun () -> tclZERO ~info e + | Next (ret, tac') -> tclOR + (finally v >>= fun () -> tclUNIT ret) + (fun e -> tclWRAPFINALLY before (tac' e) finally) let do_profile s call_trace ?(count_call=true) 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 + (* We do an early check to [is_profiling] so that we save the + overhead of [tclWRAPFINALLY] when profiling is not set + *) + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> !is_profiling)) >>= function + | false -> tac + | true -> + tclWRAPFINALLY (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> - (match call_trace with - | (_, c) :: _ -> exit_tactic ~count_call start_time c - | [] -> ())))) - | None -> tac + 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))) + tac + (function + | Some start_time -> + (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> + (match call_trace with + | (_, c) :: _ -> exit_tactic ~count_call start_time c + | [] -> ())))) + | None -> Proofview.tclUNIT ()) (* ************** Accumulation of data from workers ************************* *) @@ -396,6 +407,7 @@ let _ = | _ -> ())) let reset_profile () = + encountered_invalid_stack_no_self := false; reset_profile_tmp (); data := SM.empty diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 321b05b97c..3834b21a14 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -639,7 +639,7 @@ let solve_remaining_by env sigma holes by = let env = Environ.reset_with_named_context evi.evar_hyps env in let ty = evi.evar_concl in let name, poly = Id.of_string "rewrite", false in - let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma ty solve_tac in + let c, sigma = Proof.refine_by_tactic ~name ~poly env sigma ty solve_tac in Evd.define evk (EConstr.of_constr c) sigma in List.fold_left solve sigma indep @@ -952,10 +952,11 @@ let fold_match env sigma c = 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 then - dep, pred, exists, Ind_tables.lookup_scheme sk ci.ci_ind - else raise Not_found + match Ind_tables.lookup_scheme sk ci.ci_ind with + | Some cst -> + dep, pred, true, cst + | None -> + raise Not_found in let app = let ind, args = Inductiveops.find_mrectype env sigma cty in @@ -1559,7 +1560,7 @@ let assert_replacing id newt tac = if Id.equal n id then ev' else mkVar n in let (e, _) = destEvar sigma ev in - (sigma, mkEvar (e, Array.map_of_list map nc)) + (sigma, mkEvar (e, List.map map nc)) end end in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) @@ -1864,14 +1865,14 @@ let proper_projection env sigma r ty = Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx -let declare_projection n instance_id r = +let declare_projection name 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 env sigma c ty in - let sigma, typ = Typing.type_of env sigma term in + let body = proper_projection env sigma c ty in + let sigma, typ = Typing.type_of env sigma body in let ctx, typ = decompose_prod_assum sigma typ in let typ = let n = @@ -1892,14 +1893,11 @@ let declare_projection n instance_id r = let ctx,ccl = Reductionops.splay_prod_n env sigma (3 * n) typ in it_mkProd_or_LetIn ccl ctx in - let typ = it_mkProd_or_LetIn typ ctx in - let univs = Evd.univ_entry ~poly sigma in - let typ = EConstr.to_constr sigma typ in - let term = EConstr.to_constr sigma term in - let cst = Declare.definition_entry ~types:typ ~univs term in - let _ : Constant.t = - Declare.declare_constant ~name:n ~kind:Decls.(IsDefinition Definition) - (Declare.DefinitionEntry cst) + let types = Some (it_mkProd_or_LetIn typ ctx) in + let kind, opaque, scope = Decls.(IsDefinition Definition), false, DeclareDef.Global Declare.ImportDefaultBehavior in + let impargs, udecl = [], UState.default_univ_decl in + let _r : GlobRef.t = + DeclareDef.declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ~poly ~types ~body sigma in () let build_morphism_signature env sigma m = @@ -1927,10 +1925,7 @@ let build_morphism_signature env sigma m = in let morph = e_app_poly env evd (PropGlobal.proper_type env) [| t; sig_; m |] in let evd = solve_constraints env !evd in - let evd = Evd.minimize_universes evd in - let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in - Pretyping.check_evars env evd (EConstr.of_constr m); - Evd.evar_universe_context evd, m + evd, morph let default_morphism sign m = let env = Global.env () in @@ -1965,22 +1960,24 @@ let add_morphism_as_parameter atts m n : unit = 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 - let uctx = UState.univ_entry ~poly:atts.polymorphic uctx in - let cst = Declare.declare_constant ~name:instance_id - ~kind:Decls.(IsAssumption Logical) - (Declare.ParameterEntry (None,(instance,uctx),None)) - in - Classes.add_instance (Classes.mk_instance - (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (GlobRef.ConstRef cst)); - declare_projection n instance_id (GlobRef.ConstRef cst) + let poly = atts.polymorphic in + let kind, opaque, scope = Decls.(IsAssumption Logical), false, DeclareDef.Global Declare.ImportDefaultBehavior in + let impargs, udecl = [], UState.default_univ_decl in + let evd, types = build_morphism_signature env evd m in + let evd, pe = DeclareDef.prepare_parameter ~poly ~udecl ~types evd in + let cst = Declare.declare_constant ~name:instance_id ~kind (Declare.ParameterEntry pe) in + let cst = GlobRef.ConstRef cst in + Classes.add_instance + (Classes.mk_instance + (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global cst); + declare_projection n instance_id cst let add_morphism_interactive atts m n : Lemmas.t = init_setoid (); 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 + let evd, morph = build_morphism_signature env evd m in let poly = atts.polymorphic in let kind = Decls.(IsDefinition Instance) in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in @@ -1996,7 +1993,7 @@ let add_morphism_interactive atts m n : Lemmas.t = let info = Lemmas.Info.make ~hook ~kind () in Flags.silently (fun () -> - let lemma = Lemmas.start_lemma ~name:instance_id ~poly ~info (Evd.from_ctx uctx) (EConstr.of_constr instance) in + let lemma = Lemmas.start_lemma ~name:instance_id ~poly ~info evd morph in fst (Lemmas.by (Tacinterp.interp tac) lemma)) () let add_morphism atts binders m s n = diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 4127d28bae..9910796d9c 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -299,7 +299,7 @@ let classify_tactic_notation tacobj = Substitute tacobj let inTacticGrammar : tactic_grammar_obj -> obj = declare_object {(default_object "TacticGrammar") with - open_function = open_tactic_notation; + open_function = simple_open open_tactic_notation; load_function = load_tactic_notation; cache_function = cache_tactic_notation; subst_function = subst_tactic_notation; diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index ce9189792e..76d47f5482 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -182,7 +182,7 @@ let inMD : bool * ltac_constant option * bool * glob_tactic_expr * declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; - open_function = open_md; + open_function = simple_open open_md; subst_function = subst_md; classify_function = classify_md} diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index b0e26e1def..dda7f0742c 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -2070,7 +2070,7 @@ let _ = *) let name, poly = Id.of_string "ltac_gen", poly in let name, poly = Id.of_string "ltac_gen", poly in - let (c, sigma) = Pfedit.refine_by_tactic ~name ~poly env sigma ty tac in + let (c, sigma) = Proof.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in GlobEnv.register_constr_interp0 wit_tactic eval diff --git a/plugins/ltac/tactic_option.ml b/plugins/ltac/tactic_option.ml index 4f00f17892..922d2f7792 100644 --- a/plugins/ltac/tactic_option.ml +++ b/plugins/ltac/tactic_option.ml @@ -32,7 +32,7 @@ let declare_tactic_option ?(default=Tacexpr.TacId []) name = { (default_object name) with cache_function = cache; load_function = (fun _ -> load); - open_function = (fun _ -> load); + open_function = simple_open (fun _ -> load); classify_function = (fun (local, tac) -> if local then Dispose else Substitute (local, tac)); subst_function = subst} diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 1958fff4cc..9eeba614c7 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -27,7 +27,13 @@ open NumCompat open Q.Notations open Mutils -let use_simplex = ref true +let use_simplex = + Goptions.declare_bool_option_and_ref ~depr:false ~key:["Simplex"] ~value:true + +(* If set to some [file], arithmetic goals are dumped in [file].v *) + +let dump_file = + Goptions.declare_stringopt_option_and_ref ~depr:false ~key:["Dump"; "Arith"] type ('prf, 'model) res = Prf of 'prf | Model of 'model | Unknown type zres = (Mc.zArithProof, int * Mc.z list) res @@ -203,19 +209,19 @@ let fourier_linear_prover l = | Inl _ -> None let direct_linear_prover l = - if !use_simplex then Simplex.find_unsat_certificate l + if use_simplex () then Simplex.find_unsat_certificate l else fourier_linear_prover l let find_point l = let open Util in - if !use_simplex then Simplex.find_point l + if use_simplex () then Simplex.find_point l else match Mfourier.Fourier.find_point l with | Inr _ -> None | Inl cert -> Some cert let optimise v l = - if !use_simplex then Simplex.optimise v l else Mfourier.Fourier.optimise v l + if use_simplex () then Simplex.optimise v l else Mfourier.Fourier.optimise v l let dual_raw_certificate l = if debug then begin @@ -981,13 +987,11 @@ let xlia_simplex env red sys = with FoundProof prf -> compile_prf sys (Step (0, prf, Done)) let xlia env0 en red sys = - if !use_simplex then xlia_simplex env0 red sys else xlia en red sys - -let dump_file = ref None + if use_simplex () then xlia_simplex env0 red sys else xlia en red sys let gen_bench (tac, prover) can_enum prfdepth sys = let res = prover can_enum prfdepth sys in - ( match !dump_file with + ( match dump_file () with | None -> () | Some file -> let o = open_out (Filename.temp_file ~temp_dir:(Sys.getcwd ()) file ".v") in diff --git a/plugins/micromega/certificate.mli b/plugins/micromega/certificate.mli index cabd36ebb7..5b215549b0 100644 --- a/plugins/micromega/certificate.mli +++ b/plugins/micromega/certificate.mli @@ -12,16 +12,12 @@ module Mc = Micromega (** [use_simplex] is bound to the Coq option Simplex. If set, use the Simplex method, otherwise use Fourier *) -val use_simplex : bool ref +val use_simplex : unit -> bool type ('prf, 'model) res = Prf of 'prf | Model of 'model | Unknown type zres = (Mc.zArithProof, int * Mc.z list) res type qres = (Mc.q Mc.psatz, int * Mc.q list) res -(** [dump_file] is bound to the Coq option Dump Arith. - If set to some [file], arithmetic goals are dumped in filexxx.v *) -val dump_file : string option ref - (** [q_cert_of_pos prf] converts a Sos proof into a rational Coq proof *) val q_cert_of_pos : Sos_types.positivstellensatz -> Mc.q Mc.psatz diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 43f6f5a35e..7e4c4ce5c6 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -37,74 +37,31 @@ let debug = false let max_depth = max_int (* Search limit for provers over Q R *) -let lra_proof_depth = ref max_depth +let lra_proof_depth = + declare_int_option_and_ref ~depr:false ~key:["Lra"; "Depth"] ~value:max_depth (* Search limit for provers over Z *) -let lia_enum = ref true -let lia_proof_depth = ref max_depth -let get_lia_option () = (!Certificate.use_simplex, !lia_enum, !lia_proof_depth) -let get_lra_option () = !lra_proof_depth +let lia_enum = + declare_bool_option_and_ref ~depr:false ~key:["Lia"; "Enum"] ~value:true + +let lia_proof_depth = + declare_int_option_and_ref ~depr:false ~key:["Lia"; "Depth"] ~value:max_depth + +let get_lia_option () = + (Certificate.use_simplex (), lia_enum (), lia_proof_depth ()) (* Enable/disable caches *) -let use_lia_cache = ref true -let use_nia_cache = ref true -let use_nra_cache = ref true -let use_csdp_cache = ref true - -let () = - let int_opt l vref = - { optdepr = false - ; optkey = l - ; optread = (fun () -> Some !vref) - ; optwrite = - (fun x -> vref := match x with None -> max_depth | Some v -> v) } - in - let lia_enum_opt = - { optdepr = false - ; optkey = ["Lia"; "Enum"] - ; optread = (fun () -> !lia_enum) - ; optwrite = (fun x -> lia_enum := x) } - in - let solver_opt = - { optdepr = false - ; optkey = ["Simplex"] - ; optread = (fun () -> !Certificate.use_simplex) - ; optwrite = (fun x -> Certificate.use_simplex := x) } - in - let dump_file_opt = - { optdepr = false - ; optkey = ["Dump"; "Arith"] - ; optread = (fun () -> !Certificate.dump_file) - ; optwrite = (fun x -> Certificate.dump_file := x) } - in - let lia_cache_opt = - { optdepr = false - ; optkey = ["Lia"; "Cache"] - ; optread = (fun () -> !use_lia_cache) - ; optwrite = (fun x -> use_lia_cache := x) } - in - let nia_cache_opt = - { optdepr = false - ; optkey = ["Nia"; "Cache"] - ; optread = (fun () -> !use_nia_cache) - ; optwrite = (fun x -> use_nia_cache := x) } - in - let nra_cache_opt = - { optdepr = false - ; optkey = ["Nra"; "Cache"] - ; optread = (fun () -> !use_nra_cache) - ; optwrite = (fun x -> use_nra_cache := x) } - in - let () = declare_bool_option solver_opt in - let () = declare_bool_option lia_cache_opt in - let () = declare_bool_option nia_cache_opt in - let () = declare_bool_option nra_cache_opt in - let () = declare_stringopt_option dump_file_opt in - let () = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in - let () = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in - let () = declare_bool_option lia_enum_opt in - () +let use_lia_cache = + declare_bool_option_and_ref ~depr:false ~key:["Lia"; "Cache"] ~value:true + +let use_nia_cache = + declare_bool_option_and_ref ~depr:false ~key:["Nia"; "Cache"] ~value:true + +let use_nra_cache = + declare_bool_option_and_ref ~depr:false ~key:["Nra"; "Cache"] ~value:true + +let use_csdp_cache () = true (** * Initialize a tag type to the Tag module declaration (see Mutils). @@ -2101,7 +2058,7 @@ struct let memo_opt use_cache cache_file f = let memof = memo cache_file f in - fun x -> if !use_cache then memof x else f x + fun x -> if use_cache () then memof x else f x end module CacheCsdp = MakeCache (struct @@ -2281,7 +2238,7 @@ let memo_nra = let linear_prover_Q = { name = "linear prover" - ; get_option = get_lra_option + ; get_option = lra_proof_depth ; prover = (fun (o, l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o) l) @@ -2292,7 +2249,7 @@ let linear_prover_Q = let linear_prover_R = { name = "linear prover" - ; get_option = get_lra_option + ; get_option = lra_proof_depth ; prover = (fun (o, l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o) l) @@ -2303,7 +2260,7 @@ let linear_prover_R = let nlinear_prover_R = { name = "nra" - ; get_option = get_lra_option + ; get_option = lra_proof_depth ; prover = memo_nra ; hyps = hyps_of_cone ; compact = compact_cone diff --git a/plugins/micromega/plugin_base.dune b/plugins/micromega/dune index 4153d06161..33ad3a0138 100644 --- a/plugins/micromega/plugin_base.dune +++ b/plugins/micromega/dune @@ -20,3 +20,5 @@ (modules g_zify zify) (synopsis "Coq's zify plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_micromega g_zify)) diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index f157a807ad..9051bbb5ca 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -41,13 +41,21 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct type mode = Closed | Open type 'a t = {outch : out_channel; mutable status : mode; htbl : 'a Table.t} - let finally f rst = - try - let res = f () in - rst (); res - with reraise -> - (try rst () with any -> raise reraise); - raise reraise + (* XXX: Move to Fun.protect once in Ocaml 4.08 *) + let fun_protect ~(finally : unit -> unit) work = + let finally_no_exn () = + let exception Finally_raised of exn in + try finally () + with e -> + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace (Finally_raised e) bt + in + match work () with + | result -> finally_no_exn (); result + | exception work_exn -> + let work_bt = Printexc.get_raw_backtrace () in + finally_no_exn (); + Printexc.raise_with_backtrace work_exn work_bt let read_key_elem inch = try Some (Marshal.from_channel inch) with @@ -76,21 +84,23 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct let unlock fd = let pos = lseek fd 0 SEEK_CUR in - try - ignore (lseek fd 0 SEEK_SET); - lockf fd F_ULOCK 1 - with Unix.Unix_error (_, _, _) -> - () - (* Here, this is really bad news -- - there is a pending lock which could cause a deadlock. - Should it be an anomaly or produce a warning ? - *); - ignore (lseek fd pos SEEK_SET) + let () = + try + ignore (lseek fd 0 SEEK_SET); + lockf fd F_ULOCK 1 + with Unix.Unix_error (_, _, _) -> + (* Here, this is really bad news -- + there is a pending lock which could cause a deadlock. + Should it be an anomaly or produce a warning ? + *) + () + in + ignore (lseek fd pos SEEK_SET) (* We make the assumption that an acquired lock can always be released *) let do_under_lock kd fd f = - if lock kd fd then finally f (fun () -> unlock fd) else f () + if lock kd fd then fun_protect f ~finally:(fun () -> unlock fd) else f () let open_in f = let flags = [O_RDONLY; O_CREAT] in diff --git a/plugins/nsatz/plugin_base.dune b/plugins/nsatz/dune index 9da5b39972..b921c9c408 100644 --- a/plugins/nsatz/plugin_base.dune +++ b/plugins/nsatz/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.nsatz) (synopsis "Coq's nsatz solver plugin") (libraries num coq.plugins.ltac)) + +(coq.pp (modules g_nsatz)) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 2eef459217..79d6c05e1d 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1899,8 +1899,15 @@ let destructure_goal = let destructure_goal = destructure_goal +let warn_omega_is_deprecated = + let name = "omega-is-deprecated" in + let category = "deprecated" in + CWarnings.create ~name ~category (fun () -> + Pp.str "omega is deprecated since 8.12; use “lia” instead.") + let omega_solver = Proofview.tclUNIT () >>= fun () -> (* delay for [check_required_library] *) + warn_omega_is_deprecated (); Coqlib.check_required_library ["Coq";"omega";"Omega"]; reset_all (); destructure_goal diff --git a/plugins/omega/plugin_base.dune b/plugins/omega/dune index f512501c78..0db71ed6fb 100644 --- a/plugins/omega/plugin_base.dune +++ b/plugins/omega/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.omega) (synopsis "Coq's omega plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_omega)) diff --git a/plugins/rtauto/plugin_base.dune b/plugins/rtauto/dune index 233845ae0f..43efa0eca5 100644 --- a/plugins/rtauto/plugin_base.dune +++ b/plugins/rtauto/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.rtauto) (synopsis "Coq's rtauto plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_rtauto)) diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 537c37810e..1371c671a2 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -45,15 +45,11 @@ let reset_info () = s_info.branch_successes <- 0; s_info.nd_branching <- 0 -let pruning = ref true - -let opt_pruning= - {optdepr=false; - optkey=["Rtauto";"Pruning"]; - optread=(fun () -> !pruning); - optwrite=(fun b -> pruning:=b)} - -let () = declare_bool_option opt_pruning +let pruning = + declare_bool_option_and_ref + ~depr:false + ~key:["Rtauto";"Pruning"] + ~value:true type form= Atom of int @@ -182,7 +178,7 @@ let rec fill stack proof = [] -> Complete proof.dep_it | slice::super -> if - !pruning && + pruning () && List.is_empty slice.proofs_done && not (slice.changes_goal && proof.dep_goal) && not (Int.Set.exists @@ -529,7 +525,7 @@ let pp = let pp_info () = let count_info = - if !pruning then + if pruning () then str "Proof steps : " ++ int s_info.created_steps ++ str " created / " ++ int s_info.pruned_steps ++ str " pruned" ++ fnl () ++ diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 63dae1417e..d464ec4c06 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -221,27 +221,17 @@ let build_env gamma= mkApp(force node_count l_push,[|mkProp;p;e|])) gamma.env (mkApp (force node_count l_empty,[|mkProp|])) -open Goptions - -let verbose = ref false - -let opt_verbose= - {optdepr=false; - optkey=["Rtauto";"Verbose"]; - optread=(fun () -> !verbose); - optwrite=(fun b -> verbose:=b)} - -let () = declare_bool_option opt_verbose - -let check = ref false - -let opt_check= - {optdepr=false; - optkey=["Rtauto";"Check"]; - optread=(fun () -> !check); - optwrite=(fun b -> check:=b)} - -let () = declare_bool_option opt_check +let verbose = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Rtauto";"Verbose"] + ~value:false + +let check = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Rtauto";"Check"] + ~value:false open Pp @@ -267,7 +257,7 @@ let rtauto_tac = let () = begin reset_info (); - if !verbose then + if verbose () then Feedback.msg_info (str "Starting proof-search ..."); end in let search_start_time = System.get_time () in @@ -276,7 +266,7 @@ let rtauto_tac = with Not_found -> user_err ~hdr:"rtauto" (Pp.str "rtauto couldn't find any proof") in let search_end_time = System.get_time () in - let () = if !verbose then + let () = if verbose () then begin Feedback.msg_info (str "Proof tree found in " ++ System.fmt_time_difference search_start_time search_end_time); @@ -292,7 +282,7 @@ let rtauto_tac = let term= applistc main (List.rev_map (fun (id,_) -> mkVar id.binder_name) hyps) in let build_end_time=System.get_time () in - let () = if !verbose then + let () = if verbose () then begin Feedback.msg_info (str "Proof term built in " ++ System.fmt_time_difference build_start_time build_end_time ++ @@ -306,14 +296,14 @@ let rtauto_tac = let tac_start_time = System.get_time () in let term = EConstr.of_constr term in let result= - if !check then + if check () then Tactics.exact_check term else Tactics.exact_no_check term in let tac_end_time = System.get_time () in let () = - if !check then Feedback.msg_info (str "Proof term type-checking is on"); - if !verbose then + if check () then Feedback.msg_info (str "Proof term type-checking is on"); + if verbose () then Feedback.msg_info (str "Internal tactic executed in " ++ System.fmt_time_difference tac_start_time tac_end_time) in result diff --git a/plugins/setoid_ring/plugin_base.dune b/plugins/setoid_ring/dune index d83857edad..60522cd3f5 100644 --- a/plugins/setoid_ring/plugin_base.dune +++ b/plugins/setoid_ring/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.setoid_ring) (synopsis "Coq's setoid ring plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_newring)) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 0646af3552..633cdbd735 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -150,7 +150,7 @@ let decl_constant na univs c = let open Constr in let vars = CVars.universes_of_constr c in let univs = UState.restrict_universe_context ~lbound:(Global.universes_lbound ()) univs vars in - let () = Declare.declare_universe_context ~poly:false univs in + let () = DeclareUctx.declare_universe_context ~poly:false univs in let types = (Typeops.infer (Global.env ()) c).uj_type in let univs = Monomorphic_entry Univ.ContextSet.empty in mkConst(declare_constant ~name:(Id.of_string na) diff --git a/plugins/ssr/plugin_base.dune b/plugins/ssr/dune index a13524bb52..a117d09a16 100644 --- a/plugins/ssr/plugin_base.dune +++ b/plugins/ssr/dune @@ -5,3 +5,5 @@ (modules_without_implementation ssrast) (flags :standard -open Gramlib) (libraries coq.plugins.ssrmatching)) + +(coq.pp (modules ssrvernac ssrparser)) diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index 6a9a0657a3..42b9248979 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -55,18 +55,18 @@ let pf_pr_glob_constr gl = pr_glob_constr_env (pf_env gl) let interp_nbargs ist gl rc = try let rc6 = mkRApp rc (mkRHoles 6) in - let sigma, t = interp_open_constr ist gl (rc6, None) in + let sigma, t = interp_open_constr (pf_env gl) (project gl) ist (rc6, None) in let si = sig_it gl in let gl = re_sig si sigma in - 6 + Ssrcommon.nbargs_open_constr gl t + 6 + Ssrcommon.nbargs_open_constr (pf_env gl) t with _ -> 5 let interp_view_nbimps ist gl rc = try - let sigma, t = interp_open_constr ist gl (rc, None) in + let sigma, t = interp_open_constr (pf_env gl) (project gl) ist (rc, None) in let si = sig_it gl in let gl = re_sig si sigma in - let pl, c = splay_open_constr gl t in + let pl, c = splay_open_constr (pf_env gl) t in if Ssrcommon.isAppInd (pf_env gl) (project gl) c then List.length pl else (-(List.length pl)) with _ -> 0 @@ -88,7 +88,7 @@ let pf_match = pf_apply (fun e s c t -> understand_tcc e s ~expected_type:t c) let apply_rconstr ?ist t gl = (* ppdebug(lazy(str"sigma@apply_rconstr=" ++ pr_evar_map None (project gl))); *) let n = match ist, DAst.get t with - | None, (GVar id | GRef (Names.GlobRef.VarRef id,_)) -> pf_nbargs gl (EConstr.mkVar id) + | None, (GVar id | GRef (Names.GlobRef.VarRef id,_)) -> pf_nbargs (pf_env gl) (project gl) (EConstr.mkVar id) | Some ist, _ -> interp_nbargs ist gl t | _ -> anomaly "apply_rconstr without ist and not RVar" in let mkRlemma i = mkRApp t (mkRHoles i) in @@ -97,7 +97,7 @@ let apply_rconstr ?ist t gl = if i > n then errorstrm Pp.(str"Cannot apply lemma "++pf_pr_glob_constr gl t) else try pf_match gl (mkRlemma i) (OfType cl) with _ -> loop (i + 1) in - refine_with (loop 0) gl + Proofview.V82.of_tactic (refine_with (loop 0)) gl let mkRAppView ist gl rv gv = let nb_view_imps = interp_view_nbimps ist gl rv in @@ -112,18 +112,20 @@ let refine_interp_apply_view dbl ist gl gv = interp_refine ist gl (mkRApp hint (v :: mkRHoles i)) in let rec loop = function | [] -> (try apply_rconstr ~ist rv gl with _ -> view_error "apply" gv) - | h :: hs -> (try refine_with (snd (interp_with h)) gl with _ -> loop hs) in + | h :: hs -> (try Proofview.V82.of_tactic (refine_with (snd (interp_with h))) gl with _ -> loop hs) in loop (pair dbl (Ssrview.AdaptorDb.get dbl) @ if dbl = Ssrview.AdaptorDb.Equivalence then pair Ssrview.AdaptorDb.Backward (Ssrview.AdaptorDb.(get Backward)) else []) let apply_top_tac = - Tacticals.tclTHENLIST [ + Proofview.Goal.enter begin fun _ -> + Tacticals.New.tclTHENLIST [ introid top_id; - apply_rconstr (mkRVar top_id); - old_cleartac [SsrHyp(None,top_id)] + Proofview.V82.tactic (apply_rconstr (mkRVar top_id)); + cleartac [SsrHyp(None,top_id)] ] + end let inner_ssrapplytac gviews (ggenl, gclr) ist = Proofview.V82.tactic ~nf_evars:false (fun gl -> let _, clr = interp_hyps ist gl gclr in @@ -131,7 +133,7 @@ let inner_ssrapplytac gviews (ggenl, gclr) ist = Proofview.V82.tactic ~nf_evars: let ggenl, tclGENTAC = if gviews <> [] && ggenl <> [] then let ggenl= List.map (fun (x,g) -> x, cpattern_of_term g ist) (List.hd ggenl) in - [], Tacticals.tclTHEN (genstac (ggenl,[])) + [], Tacticals.tclTHEN (Proofview.V82.of_tactic (genstac (ggenl,[]))) else ggenl, Tacticals.tclTHEN Tacticals.tclIDTAC in tclGENTAC (fun gl -> match gviews, ggenl with @@ -148,9 +150,9 @@ let inner_ssrapplytac gviews (ggenl, gclr) ist = Proofview.V82.tactic ~nf_evars: | [], [agens] -> let clr', (sigma, lemma) = interp_agens ist gl agens in let gl = pf_merge_uc_of sigma gl in - Tacticals.tclTHENLIST [old_cleartac clr; refine_with ~beta:true lemma; old_cleartac clr'] gl + Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST [cleartac clr; refine_with ~beta:true lemma; cleartac clr']) gl | _, _ -> - Tacticals.tclTHENLIST [apply_top_tac; old_cleartac clr] gl) gl + Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST [apply_top_tac; cleartac clr]) gl) gl ) -let apply_top_tac = Proofview.V82.tactic ~nf_evars:false apply_top_tac +let apply_top_tac = apply_top_tac diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index e0b083a70a..e05c4c26dd 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -221,8 +221,8 @@ let intern_term ist env (_, c) = glob_constr ist env c (* FUNCLASS, which is probably just as well since these can *) (* lead to infinite arities. *) -let splay_open_constr gl (sigma, c) = - let env = pf_env gl in let t = Retyping.get_type_of env sigma c in +let splay_open_constr env (sigma, c) = + let t = Retyping.get_type_of env sigma c in Reductionops.splay_prod env sigma t let isAppInd env sigma c = @@ -253,11 +253,11 @@ let interp_refine ist gl rc = (sigma, (sigma, c)) -let interp_open_constr ist gl gc = - let (sigma, (c, _)) = Tacinterp.interp_open_constr_with_bindings ist (pf_env gl) (project gl) (gc, Tactypes.NoBindings) in - (project gl, (sigma, c)) +let interp_open_constr env sigma0 ist gc = + let (sigma, (c, _)) = Tacinterp.interp_open_constr_with_bindings ist env sigma0 (gc, Tactypes.NoBindings) in + (sigma0, (sigma, c)) -let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) +let interp_term env sigma ist (_, c) = snd (interp_open_constr env sigma ist c) let of_ftactic ftac gl = let r = ref None in @@ -322,10 +322,10 @@ let ssrdgens_of_parsed_dgens = function | _ -> assert false -let nbargs_open_constr gl oc = - let pl, _ = splay_open_constr gl oc in List.length pl +let nbargs_open_constr env oc = + let pl, _ = splay_open_constr env oc in List.length pl -let pf_nbargs gl c = nbargs_open_constr gl (project gl, c) +let pf_nbargs env sigma c = nbargs_open_constr env (sigma, c) let internal_names = ref [] let add_internal_name pt = internal_names := pt :: !internal_names @@ -521,10 +521,10 @@ let resolve_typeclasses ~where ~fail env sigma = let nf_evar sigma t = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr t)) -let pf_abs_evars2 gl rigid (sigma, c0) = +let abs_evars2 env sigma0 rigid (sigma, c0) = let c0 = EConstr.to_constr ~abort_on_undefined_evars:false sigma c0 in - let sigma0, ucst = project gl, Evd.evar_universe_context sigma in - let nenv = env_size (pf_env gl) in + let sigma0, ucst = sigma0, Evd.evar_universe_context sigma in + let nenv = env_size env in let abs_evar n k = let evi = Evd.find sigma k in let concl = EConstr.Unsafe.to_constr evi.evar_concl in @@ -537,7 +537,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = let rec put evlist c = match Constr.kind c with | Evar (k, a) -> if List.mem_assoc k evlist || Evd.mem sigma0 k || List.mem k rigid then evlist else - let n = max 0 (Array.length a - nenv) in + let n = max 0 (List.length a - nenv) in let t = abs_evar n k in (k, (n, t)) :: put evlist t | _ -> Constr.fold put evlist c in let evlist = put [] c0 in @@ -549,6 +549,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = | Evar (ev, a) -> let j, n = lookup ev i evlist in if j = 0 then Constr.map (get i) c else if n = 0 then mkRel j else + let a = Array.of_list a in mkApp (mkRel j, Array.init n (fun k -> get i a.(n - 1 - k))) | _ -> Constr.map_with_binders ((+) 1) get i c in let rec loop c i = function @@ -557,6 +558,11 @@ let pf_abs_evars2 gl rigid (sigma, c0) = | [] -> c in List.length evlist, EConstr.of_constr (loop (get 1 c0) 1 evlist), List.map fst evlist, ucst +let pf_abs_evars2 gl rigid c = + abs_evars2 (pf_env gl) (project gl) rigid c + +let abs_evars env sigma t = abs_evars2 env sigma [] t + let pf_abs_evars gl t = pf_abs_evars2 gl [] t @@ -568,7 +574,7 @@ let pf_abs_evars gl t = pf_abs_evars2 gl [] t * the corresponding lambda looks like (fun evar_i : T(c)) where c is * the solution found by ssrautoprop. *) -let ssrautoprop_tac = ref (fun gl -> assert false) +let ssrautoprop_tac = ref (Proofview.Goal.enter (fun gl -> assert false)) (* Thanks to Arnaud Spiwack for this snippet *) let call_on_evar tac e s = @@ -580,12 +586,11 @@ open Pp let pp _ = () (* FIXME *) module Intset = Evar.Set -let pf_abs_evars_pirrel gl (sigma, c0) = +let abs_evars_pirrel env sigma0 (sigma, c0) = pp(lazy(str"==PF_ABS_EVARS_PIRREL==")); - pp(lazy(str"c0= " ++ Printer.pr_constr_env (pf_env gl) sigma c0)); - let sigma0 = project gl in + pp(lazy(str"c0= " ++ Printer.pr_constr_env env sigma c0)); let c0 = nf_evar sigma0 (nf_evar sigma c0) in - let nenv = env_size (pf_env gl) in + let nenv = env_size env in let abs_evar n k = let evi = Evd.find sigma k in let concl = EConstr.Unsafe.to_constr evi.evar_concl in @@ -598,16 +603,16 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let rec put evlist c = match Constr.kind c with | Evar (k, a) -> if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else - let n = max 0 (Array.length a - nenv) in + let n = max 0 (List.length a - nenv) in let k_ty = Retyping.get_sort_family_of - (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in + env sigma (Evd.evar_concl (Evd.find sigma k)) in let is_prop = k_ty = InProp in let t = abs_evar n k in (k, (n, t, is_prop)) :: put evlist t | _ -> Constr.fold put evlist c in let evlist = put [] c0 in if evlist = [] then 0, c0 else - let pr_constr t = Printer.pr_econstr_env (pf_env gl) sigma (Reductionops.nf_beta (pf_env gl) (project gl) (EConstr.of_constr t)) in + let pr_constr t = Printer.pr_econstr_env env sigma (Reductionops.nf_beta env sigma0 (EConstr.of_constr t)) in pp(lazy(str"evlist=" ++ pr_list (fun () -> str";") (fun (k,_) -> Evar.print k) evlist)); let evplist = @@ -619,7 +624,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = if evplist = [] then evlist, [], sigma else List.fold_left (fun (ev, evp, sigma) (i, (_,t,_) as p) -> try - let ng, sigma = call_on_evar !ssrautoprop_tac i sigma in + let ng, sigma = call_on_evar (Proofview.V82.of_tactic !ssrautoprop_tac) i sigma in if (ng <> []) then errorstrm (str "Should we tell the user?"); List.filter (fun (j,_) -> j <> i) ev, evp, sigma with _ -> ev, p::evp, sigma) (evlist, [], sigma) (List.rev evplist) in @@ -636,6 +641,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = | Evar (ev, a) -> let j, n = lookup ev i evlist in if j = 0 then Constr.map (get evlist i) c else if n = 0 then mkRel j else + let a = Array.of_list a in mkApp (mkRel j, Array.init n (fun k -> get evlist i a.(n - 1 - k))) | _ -> Constr.map_with_binders ((+) 1) (get evlist) i c in let rec app extra_args i c = match decompose_app c with @@ -665,6 +671,9 @@ let pf_abs_evars_pirrel gl (sigma, c0) = pp(lazy(str"res= " ++ pr_constr res)); List.length evlist, res +let pf_abs_evars_pirrel gl c = + abs_evars_pirrel (pf_env gl) (project gl) c + (* Strip all non-essential dependencies from an abstracted term, generating *) (* standard names for the abstracted holes. *) @@ -676,7 +685,8 @@ let nb_evar_deps = function (try int_of_string (String.sub s m (String.length s - 1 - m)) with _ -> 0) | _ -> 0 -let pf_type_id gl t = Id.of_string (Namegen.hdchar (pf_env gl) (project gl) t) +let type_id env sigma t = Id.of_string (Namegen.hdchar env sigma t) +let pf_type_id gl t = type_id (pf_env gl) (project gl) t let pfe_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty @@ -691,7 +701,7 @@ let pf_type_of gl t = let sigma, ty = pf_type_of gl (EConstr.of_constr t) in re_sig (sig_it gl) sigma, EConstr.Unsafe.to_constr ty -let pf_abs_cterm gl n c0 = +let abs_cterm env sigma n c0 = if n <= 0 then c0 else let c0 = EConstr.Unsafe.to_constr c0 in let noargs = [|0|] in @@ -723,13 +733,15 @@ let pf_abs_cterm gl n c0 = let na' = List.length dl in eva.(i) <- Array.of_list (na - na' :: dl); let x' = - if na' = 0 then Name (pf_type_id gl (EConstr.of_constr t2)) else mk_evar_name na' in + if na' = 0 then Name (type_id env sigma (EConstr.of_constr t2)) else mk_evar_name na' in mkLambda ({x with binder_name=x'}, t2, strip_evars (i + 1) c1) (* if noccurn 1 c2 then lift (-1) c2 else mkLambda (Name (pf_type_id gl t2), t2, c2) *) | _ -> strip i c in EConstr.of_constr (strip_evars 0 c0) +let pf_abs_cterm gl n c0 = abs_cterm (pf_env gl) (project gl) n c0 + (* }}} *) let pf_merge_uc uc gl = @@ -833,7 +845,7 @@ open Locus let rewritetac ?(under=false) dir c = (* Due to the new optional arg ?tac, application shouldn't be too partial *) let open Proofview.Notations in - Proofview.V82.of_tactic begin + Proofview.Goal.enter begin fun _ -> Equality.general_rewrite (dir = L2R) AllOccurrences true false c <*> if under then Proofview.cycle 1 else Proofview.tclUNIT () end @@ -843,7 +855,7 @@ let rewritetac ?(under=false) dir c = type name_hint = (int * EConstr.types array) option ref let pf_abs_ssrterm ?(resolve_typeclasses=false) ist gl t = - let sigma, ct as t = interp_term ist gl t in + let sigma, ct as t = interp_term (pf_env gl) (project gl) ist t in let sigma, _ as t = let env = pf_env gl in if not resolve_typeclasses then t @@ -855,7 +867,8 @@ let pf_abs_ssrterm ?(resolve_typeclasses=false) ist gl t = let top_id = mk_internal_id "top assumption" -let ssr_n_tac seed n gl = +let ssr_n_tac seed n = + Proofview.Goal.enter begin fun gl -> let name = if n = -1 then seed else ("ssr" ^ seed ^ string_of_int n) in let fail msg = CErrors.user_err (Pp.str msg) in let tacname = @@ -865,9 +878,10 @@ let ssr_n_tac seed n gl = if n = -1 then fail "The ssreflect library was not loaded" else fail ("The tactic "^name^" was not found") in let tacexpr = CAst.make @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in - Proofview.V82.of_tactic (Tacinterp.eval_tactic (Tacexpr.TacArg tacexpr)) gl + Tacinterp.eval_tactic (Tacexpr.TacArg tacexpr) + end -let donetac n gl = ssr_n_tac "done" n gl +let donetac n = ssr_n_tac "done" n open Constrexpr open Util @@ -888,7 +902,7 @@ let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, CastConv ty) let rec isCHoles = function { CAst.v = CHole _ } :: cl -> isCHoles cl | cl -> cl = [] let rec isCxHoles = function ({ CAst.v = CHole _ }, None) :: ch -> isCxHoles ch | _ -> false -let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = +let pf_interp_ty ?(resolve_typeclasses=false) env sigma0 ist ty = let n_binders = ref 0 in let ty = match ty with | a, (t, None) -> @@ -913,15 +927,14 @@ let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = | LetInType(n,v,ty,t) -> decr n_binders; mkLetIn (n, v, ty, aux t) | _ -> anomaly "pf_interp_ty: ssr Type cast deleted by typecheck" in sigma, aux t in - let sigma, cty as ty = strip_cast (interp_term ist gl ty) in + let sigma, cty as ty = strip_cast (interp_term env sigma0 ist ty) in let ty = - let env = pf_env gl in if not resolve_typeclasses then ty else let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in sigma, Evarutil.nf_evar sigma cty in - let n, c, _, ucst = pf_abs_evars gl ty in - let lam_c = pf_abs_cterm gl n c in + let n, c, _, ucst = abs_evars env sigma0 ty in + let lam_c = abs_cterm env sigma0 n c in let ctx, c = EConstr.decompose_lam_n_assum sigma n lam_c in n, EConstr.it_mkProd_or_LetIn c ctx, lam_c, ucst ;; @@ -979,7 +992,8 @@ let dependent_apply_error = * * Refiner.refiner that does not handle metas with a non ground type but works * with dependently typed higher order metas. *) -let applyn ~with_evars ?beta ?(with_shelve=false) ?(first_goes_last=false) n t gl = +let applyn ~with_evars ?beta ?(with_shelve=false) ?(first_goes_last=false) n t = + Proofview.V82.tactic begin fun gl -> if with_evars then let refine gl = let t, ty, args, gl = pf_saturate ?beta ~bi_types:true gl t n in @@ -1012,16 +1026,22 @@ let applyn ~with_evars ?beta ?(with_shelve=false) ?(first_goes_last=false) n t g pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr_env (pf_env gl) (project gl) t)); Proofview.(V82.of_tactic (Tacticals.New.tclTHENLIST [ - V82.tactic (Refiner.refiner ~check:false EConstr.Unsafe.(to_constr t)); + Refiner.refiner ~check:false EConstr.Unsafe.(to_constr t); (if first_goes_last then cycle 1 else tclUNIT ()) ])) gl + end -let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = +let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let uct = Evd.evar_universe_context (fst oc) in - let n, oc = pf_abs_evars_pirrel gl (fst oc, EConstr.to_constr ~abort_on_undefined_evars:false (fst oc) (snd oc)) in - let gl = pf_unsafe_merge_uc uct gl in - try applyn ~with_evars ~first_goes_last ~with_shelve:true ?beta n (EConstr.of_constr oc) gl - with e when CErrors.noncritical e -> raise dependent_apply_error + let n, oc = abs_evars_pirrel env sigma (fst oc, EConstr.to_constr ~abort_on_undefined_evars:false (fst oc) (snd oc)) in + Proofview.Unsafe.tclEVARS (Evd.set_universe_context sigma uct) <*> + Proofview.tclOR (applyn ~with_evars ~first_goes_last ~with_shelve:true ?beta n (EConstr.of_constr oc)) + (fun _ -> Proofview.tclZERO dependent_apply_error) + end (* We wipe out all the keywords generated by the grammar rules we defined. *) (* The user is supposed to Require Import ssreflect or Require ssreflect *) @@ -1039,23 +1059,24 @@ let rec fst_prod red tac = Proofview.Goal.enter begin fun gl -> else Tacticals.New.tclTHEN Tactics.hnf_in_concl (fst_prod true tac) end -let introid ?(orig=ref Anonymous) name = tclTHEN (fun gl -> - let g, env = Tacmach.pf_concl gl, pf_env gl in - let sigma = project gl in +let introid ?(orig=ref Anonymous) name = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let g = Proofview.Goal.concl gl in match EConstr.kind sigma g with | App (hd, _) when EConstr.isLambda sigma hd -> - Proofview.V82.of_tactic (convert_concl_no_check (Reductionops.whd_beta sigma g)) gl - | _ -> tclIDTAC gl) - (Proofview.V82.of_tactic - (fst_prod false (fun id -> orig := id; Tactics.intro_mustbe_force name))) -;; + convert_concl_no_check (Reductionops.whd_beta sigma g) + | _ -> Tacticals.New.tclIDTAC + end <*> + (fst_prod false (fun id -> orig := id; Tactics.intro_mustbe_force name)) let anontac decl gl = let id = match RelDecl.get_name decl with | Name id -> if is_discharged_id id then id else mk_anon_id (Id.to_string id) (Tacmach.pf_ids_of_hyps gl) | _ -> mk_anon_id ssr_anon_hyp (Tacmach.pf_ids_of_hyps gl) in - introid id gl + Proofview.V82.of_tactic (introid id) gl let rec intro_anon gl = try anontac (List.hd (fst (EConstr.decompose_prod_n_assum (project gl) 1 (Tacmach.pf_concl gl)))) gl @@ -1083,16 +1104,17 @@ let interp_clr sigma = function let tclID tac = tac let tclDOTRY n tac = + let open Tacticals.New in if n <= 0 then tclIDTAC else - let rec loop i gl = - if i = n then tclTRY tac gl else - tclTRY (tclTHEN tac (loop (i + 1))) gl in + let rec loop i = + if i = n then tclTRY tac else + tclTRY (tclTHEN tac (loop (i + 1))) in loop 1 let tclDO n tac = let prefix i = str"At iteration " ++ int i ++ str": " in let tac_err_at i gl = - try tac gl + try Proofview.V82.of_tactic tac gl with | CErrors.UserError (l, s) as e -> let _, info = Exninfo.capture e in @@ -1103,11 +1125,15 @@ let tclDO n tac = let rec loop i gl = if i = n then tac_err_at i gl else (tclTHEN (tac_err_at i) (loop (i + 1))) gl in - loop 1 + Proofview.V82.tactic ~nf_evars:false (loop 1) + +let tclAT_LEAST_ONCE t = + let open Tacticals.New in + tclTHEN t (tclREPEAT t) let tclMULT = function - | 0, May -> tclREPEAT - | 1, May -> tclTRY + | 0, May -> Tacticals.New.tclREPEAT + | 1, May -> Tacticals.New.tclTRY | n, May -> tclDOTRY n | 0, Must -> tclAT_LEAST_ONCE | n, Must when n > 1 -> tclDO n @@ -1122,7 +1148,7 @@ let cleartac clr = check_hyps_uniq [] clr; Tactics.clear (hyps_ids clr) (* XXX the k of the redex should percolate out *) let pf_interp_gen_aux gl to_ind ((oclr, occ), t) = - let pat = interp_cpattern gl t None in (* UGLY API *) + let pat = interp_cpattern (pf_env gl) (project gl) t None in (* UGLY API *) let gl = pf_merge_uc_of (fst pat) gl in let cl, env, sigma = Tacmach.pf_concl gl, pf_env gl, project gl in let (c, ucst), cl = @@ -1169,7 +1195,8 @@ let genclrtac cl cs clr = gl)) (old_cleartac clr) -let gentac gen gl = +let gentac gen = + Proofview.V82.tactic begin fun gl -> (* ppdebug(lazy(str"sigma@gentac=" ++ pr_evar_map None (project gl))); *) let conv, _, cl, c, clr, ucst,gl = pf_interp_gen_aux gl false gen in ppdebug(lazy(str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c)); @@ -1177,9 +1204,10 @@ let gentac gen gl = if conv then tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl)) (old_cleartac clr) gl else genclrtac cl [c] clr gl + end let genstac (gens, clr) = - tclTHENLIST (old_cleartac clr :: List.rev_map gentac gens) + Tacticals.New.tclTHENLIST (cleartac clr :: List.rev_map gentac gens) let gen_tmp_ids ?(ist=Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty })) gl @@ -1189,7 +1217,7 @@ let gen_tmp_ids (tclTHENLIST (List.map (fun (id,orig_ref) -> tclTHEN - (gentac ((None,Some(false,[])),cpattern_of_id id)) + (Proofview.V82.of_tactic (gentac ((None,Some(false,[])),cpattern_of_id id))) (rename_hd_prod orig_ref)) ctx.tmp_ids) gl) ;; @@ -1212,24 +1240,6 @@ let pfLIFT f = Proofview.tclUNIT x ;; -(* TASSI: This version of unprotects inlines the unfold tactic definition, - * since we don't want to wipe out let-ins, and it seems there is no flag - * to change that behaviour in the standard unfold code *) -let unprotecttac gl = - let c, gl = pf_mkSsrConst "protect_term" gl in - let prot, _ = EConstr.destConst (project gl) c in - Tacticals.onClause (fun idopt -> - let hyploc = Option.map (fun id -> id, InHyp) idopt in - Proofview.V82.of_tactic (Tactics.reduct_option ~check:false - (Reductionops.clos_norm_flags - (CClosure.RedFlags.mkflags - [CClosure.RedFlags.fBETA; - CClosure.RedFlags.fCONST prot; - CClosure.RedFlags.fMATCH; - CClosure.RedFlags.fFIX; - CClosure.RedFlags.fCOFIX]), DEFAULTcast) hyploc)) - allHypsAndConcl gl - let is_protect hd env sigma = let _, protectC = mkSsrConst "protect_term" env sigma in EConstr.eq_constr_nounivs sigma hd protectC @@ -1257,7 +1267,7 @@ let abs_wgen keep_let f gen (gl,args,c) = gl, EConstr.mkVar x :: args, prod | _, Some ((x, "@"), Some p) -> let x = hoi_id x in - let cp = interp_cpattern gl p None in + let cp = interp_cpattern (pf_env gl) (project gl) p None in let gl = pf_merge_uc_of (fst cp) gl in let (t, ucst), c = try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr c) cp None 1 @@ -1270,7 +1280,7 @@ let abs_wgen keep_let f gen (gl,args,c) = pf_merge_uc ucst gl, args, EConstr.mkLetIn(make_annot (Name (f x)) r, ut, ty, c) | _, Some ((x, _), Some p) -> let x = hoi_id x in - let cp = interp_cpattern gl p None in + let cp = interp_cpattern (pf_env gl) (project gl) p None in let gl = pf_merge_uc_of (fst cp) gl in let (t, ucst), c = try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr c) cp None 1 @@ -1285,8 +1295,8 @@ let abs_wgen keep_let f gen (gl,args,c) = let clr_of_wgen gen clrs = match gen with | clr, Some ((x, _), None) -> let x = hoi_id x in - old_cleartac clr :: old_cleartac [SsrHyp(Loc.tag x)] :: clrs - | clr, _ -> old_cleartac clr :: clrs + cleartac clr :: cleartac [SsrHyp(Loc.tag x)] :: clrs + | clr, _ -> cleartac clr :: clrs let reduct_in_concl ~check t = Tactics.reduct_in_concl ~check (t, DEFAULTcast) @@ -1319,7 +1329,8 @@ end let tacREDUCE_TO_QUANTIFIED_IND ty = tacSIGMA >>= fun gl -> - tclUNIT (Tacmach.pf_reduce_to_quantified_ind gl ty) + try tclUNIT (Tacmach.pf_reduce_to_quantified_ind gl ty) + with e -> tclZERO e let tacTYPEOF c = Goal.enter_one ~__LOC__ (fun g -> let sigma, env = Goal.sigma g, Goal.env g in @@ -1458,7 +1469,7 @@ end let tacINTERP_CPATTERN cp = tacSIGMA >>= begin fun gl -> - tclUNIT (Ssrmatching.interp_cpattern gl cp None) + tclUNIT (Ssrmatching.interp_cpattern (pf_env gl) (project gl) cp None) end let tacUNIFY a b = @@ -1486,12 +1497,38 @@ let tclWITHTOP tac = Goal.enter begin fun gl -> Tactics.clear [top] end -let tacMK_SSR_CONST name = Goal.enter_one ~__LOC__ begin fun g -> - let sigma, env = Goal.(sigma g, env g) in - let sigma, c = mkSsrConst name env sigma in - Unsafe.tclEVARS sigma <*> - tclUNIT c -end +let tacMK_SSR_CONST name = + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + match mkSsrConst name env sigma with + | sigma, c -> Unsafe.tclEVARS sigma <*> tclUNIT c + | exception e when CErrors.noncritical e -> + tclLIFT (Proofview.NonLogical.raise (e, Exninfo.null)) + +let tacDEST_CONST c = + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.destConst sigma c with + | c, _ -> tclUNIT c + | exception e when CErrors.noncritical e -> + tclLIFT (Proofview.NonLogical.raise (e, Exninfo.null)) + +(* TASSI: This version of unprotects inlines the unfold tactic definition, + * since we don't want to wipe out let-ins, and it seems there is no flag + * to change that behaviour in the standard unfold code *) +let unprotecttac = + tacMK_SSR_CONST "protect_term" >>= tacDEST_CONST >>= fun prot -> + Tacticals.New.onClause (fun idopt -> + let hyploc = Option.map (fun id -> id, InHyp) idopt in + Tactics.reduct_option ~check:false + (Reductionops.clos_norm_flags + (CClosure.RedFlags.mkflags + [CClosure.RedFlags.fBETA; + CClosure.RedFlags.fCONST prot; + CClosure.RedFlags.fMATCH; + CClosure.RedFlags.fFIX; + CClosure.RedFlags.fCOFIX]), DEFAULTcast) hyploc) + allHypsAndConcl + module type StateType = sig type state diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 3f92eab0bd..d1ad24496e 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -131,7 +131,8 @@ val pf_intern_term : ssrterm -> Glob_term.glob_constr val interp_term : - Tacinterp.interp_sign -> Goal.goal Evd.sigma -> + Environ.env -> Evd.evar_map -> + Tacinterp.interp_sign -> ssrterm -> evar_map * EConstr.t val interp_wit : @@ -145,7 +146,8 @@ val interp_refine : Glob_term.glob_constr -> evar_map * (evar_map * EConstr.constr) val interp_open_constr : - Tacinterp.interp_sign -> Goal.goal Evd.sigma -> + Environ.env -> Evd.evar_map -> + Tacinterp.interp_sign -> Genintern.glob_constr_and_expr -> evar_map * (evar_map * EConstr.t) val pf_e_type_of : @@ -153,7 +155,7 @@ val pf_e_type_of : EConstr.constr -> Goal.goal Evd.sigma * EConstr.types val splay_open_constr : - Goal.goal Evd.sigma -> + Environ.env -> evar_map * EConstr.t -> (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t val isAppInd : Environ.env -> Evd.evar_map -> EConstr.types -> bool @@ -179,8 +181,23 @@ val mk_internal_id : string -> Id.t val mk_tagged_id : string -> int -> Id.t val mk_evar_name : int -> Name.t val ssr_anon_hyp : string +val type_id : Environ.env -> Evd.evar_map -> EConstr.types -> Id.t val pf_type_id : Goal.goal Evd.sigma -> EConstr.types -> Id.t +val abs_evars : + Environ.env -> Evd.evar_map -> + evar_map * EConstr.t -> + int * EConstr.t * Evar.t list * + UState.t +val abs_evars2 : (* ssr2 *) + Environ.env -> Evd.evar_map -> Evar.t list -> + evar_map * EConstr.t -> + int * EConstr.t * Evar.t list * + UState.t +val abs_cterm : + Environ.env -> Evd.evar_map -> int -> EConstr.t -> EConstr.t + + val pf_abs_evars : Goal.goal Evd.sigma -> evar_map * EConstr.t -> @@ -216,15 +233,8 @@ val pf_abs_prod : EConstr.t -> Goal.goal Evd.sigma * EConstr.types val mkSsrRRef : string -> Glob_term.glob_constr * 'a option -val mkSsrConst : - string -> - env -> evar_map -> evar_map * EConstr.t -val pf_mkSsrConst : - string -> - Goal.goal Evd.sigma -> - EConstr.t * Goal.goal Evd.sigma -val new_wild_id : tac_ctx -> Names.Id.t * tac_ctx +val new_wild_id : tac_ctx -> Names.Id.t * tac_ctx val pf_fresh_global : GlobRef.t -> @@ -239,11 +249,14 @@ val ssrqid : string -> Libnames.qualid val new_tmp_id : tac_ctx -> (Names.Id.t * Name.t ref) * tac_ctx val mk_anon_id : string -> Id.t list -> Id.t +val abs_evars_pirrel : + Environ.env -> Evd.evar_map -> + evar_map * Constr.constr -> int * Constr.constr val pf_abs_evars_pirrel : Goal.goal Evd.sigma -> evar_map * Constr.constr -> int * Constr.constr -val nbargs_open_constr : Goal.goal Evd.sigma -> Evd.evar_map * EConstr.t -> int -val pf_nbargs : Goal.goal Evd.sigma -> EConstr.t -> int +val nbargs_open_constr : Environ.env -> Evd.evar_map * EConstr.t -> int +val pf_nbargs : Environ.env -> Evd.evar_map -> EConstr.t -> int val gen_tmp_ids : ?ist:Geninterp.interp_sign -> (Goal.goal * tac_ctx) Evd.sigma -> @@ -263,7 +276,7 @@ val red_product_skip_id : env -> evar_map -> EConstr.t -> EConstr.t val ssrautoprop_tac : - (Evar.t Evd.sigma -> Evar.t list Evd.sigma) ref + unit Proofview.tactic ref val mkProt : EConstr.t -> @@ -300,14 +313,15 @@ val pf_abs_ssrterm : val pf_interp_ty : ?resolve_typeclasses:bool -> + Environ.env -> + Evd.evar_map -> Tacinterp.interp_sign -> - Goal.goal Evd.sigma -> Ssrast.ssrtermkind * (Glob_term.glob_constr * Constrexpr.constr_expr option) -> int * EConstr.t * EConstr.t * UState.t -val ssr_n_tac : string -> int -> v82tac -val donetac : int -> v82tac +val ssr_n_tac : string -> int -> unit Proofview.tactic +val donetac : int -> unit Proofview.tactic val applyn : with_evars:bool -> @@ -315,7 +329,7 @@ val applyn : ?with_shelve:bool -> ?first_goes_last:bool -> int -> - EConstr.t -> v82tac + EConstr.t -> unit Proofview.tactic exception NotEnoughProducts val pf_saturate : ?beta:bool -> @@ -339,7 +353,7 @@ val refine_with : ?first_goes_last:bool -> ?beta:bool -> ?with_evars:bool -> - evar_map * EConstr.t -> v82tac + evar_map * EConstr.t -> unit Proofview.tactic val pf_resolve_typeclasses : where:EConstr.t -> @@ -350,18 +364,18 @@ val resolve_typeclasses : (*********************** Wrapped Coq tactics *****************************) -val rewritetac : ?under:bool -> ssrdir -> EConstr.t -> tactic +val rewritetac : ?under:bool -> ssrdir -> EConstr.t -> unit Proofview.tactic type name_hint = (int * EConstr.types array) option ref val gentac : - Ssrast.ssrdocc * Ssrmatching.cpattern -> v82tac + Ssrast.ssrdocc * Ssrmatching.cpattern -> unit Proofview.tactic val genstac : ((Ssrast.ssrhyp list option * Ssrmatching.occ) * Ssrmatching.cpattern) list * Ssrast.ssrhyp list -> - Tacmach.tactic + unit Proofview.tactic val pf_interp_gen : bool -> @@ -378,7 +392,7 @@ val pfLIFT (** Basic tactics *) -val introid : ?orig:Name.t ref -> Id.t -> v82tac +val introid : ?orig:Name.t ref -> Id.t -> unit Proofview.tactic val intro_anon : v82tac val interp_clr : @@ -390,9 +404,9 @@ val genclrtac : val old_cleartac : ssrhyps -> v82tac val cleartac : ssrhyps -> unit Proofview.tactic -val tclMULT : int * ssrmmod -> Tacmach.tactic -> Tacmach.tactic +val tclMULT : int * ssrmmod -> unit Proofview.tactic -> unit Proofview.tactic -val unprotecttac : Goal.goal Evd.sigma -> Goal.goal list Evd.sigma +val unprotecttac : unit Proofview.tactic val is_protect : EConstr.t -> Environ.env -> Evd.evar_map -> bool val abs_wgen : @@ -407,7 +421,7 @@ val abs_wgen : val clr_of_wgen : ssrhyps * ((ssrhyp_or_id * 'a) * 'b option) option -> - Proofview.V82.tac list -> Proofview.V82.tac list + unit Proofview.tactic list -> unit Proofview.tactic list val unfold : EConstr.t list -> unit Proofview.tactic diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index b44600a8cf..8e75ba7a2b 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -183,7 +183,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = else let c = Option.get oc in let gl, c_ty = pfe_type_of gl c in let pc = match c_gen with - | Some p -> interp_cpattern orig_gl p None + | Some p -> interp_cpattern (pf_env orig_gl) (project orig_gl) p None | _ -> mkTpat gl c in Some(c, c_ty, pc), gl in seed, cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl @@ -233,7 +233,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in let pred = List.assoc pred_id elim_args in let pc = match n_c_args, c_gen with - | 0, Some p -> interp_cpattern orig_gl p None + | 0, Some p -> interp_cpattern (pf_env orig_gl) (project orig_gl) p None | _ -> mkTpat gl c in let cty = Some (c, c_ty, pc) in let elimty = Reductionops.whd_all env (project gl) elimty in @@ -312,7 +312,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let rec loop patterns clr i = function | [],[] -> patterns, clr, gl | ((oclr, occ), t):: deps, inf_t :: inf_deps -> - let p = interp_cpattern orig_gl t None in + let p = interp_cpattern (pf_env orig_gl) (project orig_gl) t None in let clr_t = interp_clr (project gl) (oclr,(tag_of_cpattern t,EConstr.of_constr (fst (redex_of_pattern env p)))) in (* if we are the index for the equation we do not clear *) @@ -392,10 +392,15 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let erefl = fire_subst gl erefl in let erefl_ty = Retyping.get_type_of (pf_env gl) (project gl) erefl in let eq_ty = Retyping.get_type_of (pf_env gl) (project gl) erefl_ty in - let gen_eq_tac s = + let gen_eq_tac = + let open Proofview.Notations in + Proofview.Goal.enter begin fun s -> + let sigma = Proofview.Goal.sigma s in let open Evd in - let sigma = merge_universe_context s.sigma (evar_universe_context (project gl)) in - apply_type new_concl [erefl] { s with sigma } + let sigma = merge_universe_context sigma (evar_universe_context (project gl)) in + Proofview.Unsafe.tclEVARS sigma <*> + Tactics.apply_type ~typecheck:true new_concl [erefl] + end in gen_eq_tac, eq_ty, gl in let rel = k + if c_is_head_p then 1 else 0 in @@ -403,7 +408,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let concl = EConstr.mkArrow src Sorts.Relevant (EConstr.Vars.lift 1 concl) in let clr = if deps <> [] then clr else [] in concl, gen_eq_tac, clr, gl - | _ -> concl, Tacticals.tclIDTAC, clr, gl in + | _ -> concl, Tacticals.New.tclIDTAC, clr, gl in let mk_lam t r = EConstr.mkLambda_or_LetIn r t in let concl = List.fold_left mk_lam concl pred_rctx in let gl, concl = @@ -453,9 +458,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let elim_tac = Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (refine_with ~with_evars:false elim); + refine_with ~with_evars:false elim; cleartac clr] in - let gen_eq_tac = Proofview.V82.tactic gen_eq_tac in Tacticals.New.tclTHENLIST [gen_eq_tac; elim_intro_tac ?seed:(Some seed) what eqid elim_tac is_rec clr] ;; @@ -467,19 +471,22 @@ let casetac x k = let k ?seed _what _eqid elim_tac _is_rec _clr = k ?seed elim_tac in ssrelim ~is_case:true [] (`EConstr ([],None,x)) None k -let pf_nb_prod gl = nb_prod (project gl) (pf_concl gl) - let rev_id = mk_internal_id "rev concl" let injecteq_id = mk_internal_id "injection equation" -let revtoptac n0 gl = - let n = pf_nb_prod gl - n0 in - let dc, cl = EConstr.decompose_prod_n_assum (project gl) n (pf_concl gl) in +let revtoptac n0 = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let n = nb_prod sigma concl - n0 in + let dc, cl = EConstr.decompose_prod_n_assum sigma n concl in let dc' = dc @ [Context.Rel.Declaration.LocalAssum(make_annot (Name rev_id) Sorts.Relevant, EConstr.it_mkProd_or_LetIn cl (List.rev dc))] in let f = EConstr.it_mkLambda_or_LetIn (mkEtaApp (EConstr.mkRel (n + 1)) (-n) 1) dc' in - Refiner.refiner ~check:true EConstr.Unsafe.(to_constr (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|]))) gl + Refiner.refiner ~check:true EConstr.Unsafe.(to_constr (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|]))) + end -let equality_inj l b id c gl = +let equality_inj l b id c = + Proofview.V82.tactic begin fun gl -> let msg = ref "" in try Proofview.V82.of_tactic (Equality.inj None l b None c) gl with @@ -490,37 +497,53 @@ let equality_inj l b id c gl = !msg = "Nothing to inject." -> Feedback.msg_warning (Pp.str !msg); discharge_hyp (id, (id, "")) gl + end -let injectidl2rtac id c gl = - Tacticals.tclTHEN (equality_inj None true id c) (revtoptac (pf_nb_prod gl)) gl +let injectidl2rtac id c = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + Tacticals.New.tclTHEN (equality_inj None true id c) (revtoptac (nb_prod sigma concl)) + end let injectl2rtac sigma c = match EConstr.kind sigma c with | Var id -> injectidl2rtac id (EConstr.mkVar id, NoBindings) | _ -> let id = injecteq_id in - let xhavetac id c = Proofview.V82.of_tactic (Tactics.pose_proof (Name id) c) in - Tacticals.tclTHENLIST [xhavetac id c; injectidl2rtac id (EConstr.mkVar id, NoBindings); Proofview.V82.of_tactic (Tactics.clear [id])] + let xhavetac id c = Tactics.pose_proof (Name id) c in + Tacticals.New.tclTHENLIST [xhavetac id c; injectidl2rtac id (EConstr.mkVar id, NoBindings); Tactics.clear [id]] -let is_injection_case c gl = - let gl, cty = pfe_type_of gl c in - let (mind,_), _ = pf_reduce_to_quantified_ind gl cty in +let is_injection_case env sigma c = + let sigma, cty = Typing.type_of env sigma c in + let (mind,_), _ = Tacred.reduce_to_quantified_ind env sigma cty in Coqlib.check_ind_ref "core.eq.type" mind -let perform_injection c gl = - let gl, cty = pfe_type_of gl c in - let mind, t = pf_reduce_to_quantified_ind gl cty in - let dc, eqt = EConstr.decompose_prod (project gl) t in - if dc = [] then injectl2rtac (project gl) c gl else - if not (EConstr.Vars.closed0 (project gl) eqt) then +let perform_injection c = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let sigma, cty = Typing.type_of env sigma c in + let mind, t = Tacred.reduce_to_quantified_ind env sigma cty in + let dc, eqt = EConstr.decompose_prod sigma t in + if dc = [] then injectl2rtac sigma c else + if not (EConstr.Vars.closed0 sigma eqt) then CErrors.user_err (Pp.str "can't decompose a quantified equality") else - let cl = pf_concl gl in let n = List.length dc in + let cl = Proofview.Goal.concl gl in + let n = List.length dc in let c_eq = mkEtaApp c n 2 in let cl1 = EConstr.mkLambda EConstr.(make_annot Anonymous Sorts.Relevant, mkArrow eqt Sorts.Relevant cl, mkApp (mkRel 1, [|c_eq|])) in let id = injecteq_id in let id_with_ebind = (EConstr.mkVar id, NoBindings) in - let injtac = Tacticals.tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in - Tacticals.tclTHENLAST (Proofview.V82.of_tactic (Tactics.apply (EConstr.compose_lam dc cl1))) injtac gl + let injtac = Tacticals.New.tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in + Proofview.Unsafe.tclEVARS sigma <*> + Tacticals.New.tclTHENLAST (Tactics.apply (EConstr.compose_lam dc cl1)) injtac + end -let ssrscase_or_inj_tac c = Proofview.V82.tactic ~nf_evars:false (fun gl -> - if is_injection_case c gl then perform_injection c gl - else Proofview.V82.of_tactic (casetac c (fun ?seed:_ k -> k)) gl) +let ssrscase_or_inj_tac c = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + if is_injection_case env sigma c then perform_injection c + else casetac c (fun ?seed:_ k -> k) + end diff --git a/plugins/ssr/ssrelim.mli b/plugins/ssr/ssrelim.mli index 7b9cfed5ba..7f74fc78a2 100644 --- a/plugins/ssr/ssrelim.mli +++ b/plugins/ssr/ssrelim.mli @@ -41,10 +41,10 @@ val casetac : (?seed:Names.Name.t list array -> unit Proofview.tactic -> unit Proofview.tactic) -> unit Proofview.tactic -val is_injection_case : EConstr.t -> Goal.goal Evd.sigma -> bool +val is_injection_case : Environ.env -> Evd.evar_map -> EConstr.t -> bool val perform_injection : EConstr.constr -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic val ssrscase_or_inj_tac : EConstr.constr -> diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index d4303e9e8b..ab07dd5be9 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -42,29 +42,36 @@ let () = (* We must avoid zeta-converting any "let"s created by the "in" tactical. *) -let tacred_simpl gl = +let tacred_simpl env = let simpl_expr = Genredexpr.( Simpl(Redops.make_red_flag[FBeta;FMatch;FZeta;FDeltaBut []],None)) in - let esimpl, _ = Redexpr.reduction_of_red_expr (pf_env gl) simpl_expr in + let esimpl, _ = Redexpr.reduction_of_red_expr env simpl_expr in let esimpl e sigma c = let (_,t) = esimpl e sigma c in t in let simpl env sigma c = (esimpl env sigma c) in simpl -let safe_simpltac n gl = +let safe_simpltac n = if n = ~-1 then - let cl= red_safe (tacred_simpl gl) (pf_env gl) (project gl) (pf_concl gl) in - Proofview.V82.of_tactic (convert_concl_no_check cl) gl + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let cl = red_safe (tacred_simpl env) env sigma concl in + convert_concl_no_check cl + end else - ssr_n_tac "simpl" n gl + ssr_n_tac "simpl" n let simpltac = function | Simpl n -> safe_simpltac n - | Cut n -> tclTRY (donetac n) - | SimplCut (n,m) -> tclTHEN (safe_simpltac m) (tclTRY (donetac n)) - | Nop -> tclIDTAC + | Cut n -> Tacticals.New.tclTRY (donetac n) + | SimplCut (n,m) -> Tacticals.New.tclTHEN (safe_simpltac m) (Tacticals.New.tclTRY (donetac n)) + | Nop -> Tacticals.New.tclIDTAC + +let simpltac s = Proofview.Goal.enter (fun _ -> simpltac s) (** The "congr" tactic *) @@ -87,13 +94,13 @@ let pattern_id = mk_internal_id "pattern value" let congrtac ((n, t), ty) ist gl = ppdebug(lazy (Pp.str"===congr===")); ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (Tacmach.pf_concl gl))); - let sigma, _ as it = interp_term ist gl t in + let sigma, _ as it = interp_term (pf_env gl) (project gl) ist t in let gl = pf_merge_uc_of sigma gl in let _, f, _, _ucst = pf_abs_evars gl it in let ist' = {ist with lfun = Id.Map.add pattern_id (Tacinterp.Value.of_constr f) Id.Map.empty } in let rf = mkRltacVar pattern_id in - let m = pf_nbargs gl f in + let m = pf_nbargs (pf_env gl) (project gl) f in let _, cf = if n > 0 then match interp_congrarg_at ist' gl n rf ty m with | Some cf -> cf @@ -105,14 +112,18 @@ let congrtac ((n, t), ty) ist gl = | Some cf -> cf | None -> loop (i + 1) in loop 1 in - tclTHEN (refine_with cf) (tclTRY (Proofview.V82.of_tactic Tactics.reflexivity)) gl + Proofview.V82.of_tactic Tacticals.New.(tclTHEN (refine_with cf) (tclTRY Tactics.reflexivity)) gl let pf_typecheck t gl = let it = sig_it gl in let sigma,_ = pf_type_of gl t in re_sig [it] sigma -let newssrcongrtac arg ist gl = +let newssrcongrtac arg ist = + let open Proofview.Notations in + Proofview.Goal.enter_one ~__LOC__ begin fun _g -> + (Ssrcommon.tacMK_SSR_CONST "ssr_congr_arrow") end >>= fun arr -> + Proofview.V82.tactic begin fun gl -> ppdebug(lazy Pp.(str"===newcongr===")); ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); (* utils *) @@ -129,7 +140,6 @@ let newssrcongrtac arg ist gl = let sigma = Evd.create_evar_defs sigma in let (sigma, x) = Evarutil.new_evar env sigma ty in x, re_sig si sigma in - let arr, gl = pf_mkSsrConst "ssr_congr_arrow" gl in let ssr_congr lr = EConstr.mkApp (arr, lr) in let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in (* here the two cases: simple equality or arrow *) @@ -150,6 +160,7 @@ let newssrcongrtac arg ist gl = ; congrtac (arg, mkRType) ist ]) (fun _ _ -> errorstrm Pp.(str"Conclusion is not an equality nor an arrow"))) gl + end (** 7. Rewriting tactics (rewrite, unlock) *) @@ -188,24 +199,28 @@ let mk_rwarg (d, (n, _ as m)) ((clr, occ as docc), rx) (rt, _ as r) : ssrrwarg = let norwmult = L2R, nomult let norwocc = noclr, None -let simplintac occ rdx sim gl = - let simptac m gl = +let simplintac occ rdx sim = + let simptac m = + Proofview.Goal.enter begin fun gl -> if m <> ~-1 then begin if rdx <> None then CErrors.user_err (Pp.str "Custom simpl tactic does not support patterns"); if occ <> None then CErrors.user_err (Pp.str "Custom simpl tactic does not support occurrence numbers"); - simpltac (Simpl m) gl + simpltac (Simpl m) end else - let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let sigma0, concl0, env0 = Proofview.Goal.(sigma gl, concl gl, env gl) in let simp env c _ _ = EConstr.Unsafe.to_constr (red_safe Tacred.simpl env sigma0 (EConstr.of_constr c)) in - Proofview.V82.of_tactic - (convert_concl_no_check (EConstr.of_constr (eval_pattern env0 sigma0 (EConstr.Unsafe.to_constr concl0) rdx occ simp))) - gl in + convert_concl_no_check (EConstr.of_constr (eval_pattern env0 sigma0 (EConstr.to_constr ~abort_on_undefined_evars:false sigma0 concl0) rdx occ simp)) + end + in + let open Tacticals.New in + Proofview.Goal.enter begin fun _ -> match sim with - | Simpl m -> simptac m gl - | SimplCut (n,m) -> tclTHEN (simptac m) (tclTRY (donetac n)) gl - | _ -> simpltac sim gl + | Simpl m -> simptac m + | SimplCut (n,m) -> tclTHEN (simptac m) (tclTRY (donetac n)) + | _ -> simpltac sim + end let rec get_evalref env sigma c = match EConstr.kind sigma c with | Var id -> EvalVarRef id @@ -233,7 +248,8 @@ let all_ok _ _ = true let fake_pmatcher_end () = mkProp, L2R, (Evd.empty, UState.empty, mkProp) -let unfoldintac occ rdx t (kt,_) gl = +let unfoldintac occ rdx t (kt,_) = + Proofview.V82.tactic begin fun gl -> let fs sigma x = Reductionops.nf_evar sigma x in let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in let (sigma, t), const = strip_unfold_term env0 t kt in @@ -286,9 +302,10 @@ let unfoldintac occ rdx t (kt,_) gl = with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_econstr_pat env0 sigma t) in let _ = conclude () in Proofview.V82.of_tactic (convert_concl ~check:true concl) gl -;; + end -let foldtac occ rdx ft gl = +let foldtac occ rdx ft = + Proofview.V82.tactic begin fun gl -> let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in let sigma, t = ft in let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in @@ -313,7 +330,7 @@ let foldtac occ rdx ft gl = let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in let _ = conclude () in Proofview.V82.of_tactic (convert_concl ~check:true (EConstr.of_constr concl)) gl -;; + end let converse_dir = function L2R -> R2L | R2L -> L2R @@ -337,7 +354,8 @@ exception PRtype_error of (Environ.env * Evd.evar_map * Pretype_errors.pretype_e let id_map_redex _ sigma ~before:_ ~after = sigma, after -let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = +let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_rdx dir (sigma, c) c_ty = + Proofview.V82.tactic begin fun gl -> (* ppdebug(lazy(str"sigma@pirrel_rewrite=" ++ pr_evar_map None sigma)); *) let env = pf_env gl in let beta = Reductionops.clos_norm_flags CClosure.beta env sigma in @@ -369,8 +387,8 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ in ppdebug(lazy Pp.(str"pirrel_rewrite: proof term: " ++ pr_econstr_env env sigma proof)); ppdebug(lazy Pp.(str"pirrel_rewrite of type: " ++ pr_econstr_env env sigma proof_ty)); - try refine_with - ~first_goes_last:(not !ssroldreworder || under) ~with_evars:under (sigma, proof) gl + try Proofview.V82.of_tactic (refine_with + ~first_goes_last:(not !ssroldreworder || under) ~with_evars:under (sigma, proof)) gl with _ -> (* we generate a msg like: "Unable to find an instance for the variable" *) let hd_ty, miss = match EConstr.kind sigma c with @@ -393,62 +411,73 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ | _ -> anomaly "rewrite rule not an application" in errorstrm Pp.(Himsg.explain_refiner_error env sigma (Logic.UnresolvedBindings miss)++ (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_econstr_env env sigma hd_ty)) -;; + end + +let pf_merge_uc_of s sigma = + Evd.merge_universe_context sigma (Evd.evar_universe_context s) -let rwcltac ?under ?map_redex cl rdx dir sr gl = +let rwcltac ?under ?map_redex cl rdx dir sr = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma0 = Proofview.Goal.sigma gl in let sr = let sigma, r = sr in - let sigma = resolve_typeclasses ~where:r ~fail:false (pf_env gl) sigma in + let sigma = resolve_typeclasses ~where:r ~fail:false env sigma in sigma, r in - let n, r_n,_, ucst = pf_abs_evars gl sr in - let r_n' = pf_abs_cterm gl n r_n in + let n, r_n,_, ucst = abs_evars env sigma0 sr in + let r_n' = abs_cterm env sigma0 n r_n in let r' = EConstr.Vars.subst_var pattern_id r_n' in - let gl = pf_unsafe_merge_uc ucst gl in - let rdxt = Retyping.get_type_of (pf_env gl) (fst sr) rdx in + let sigma0 = Evd.set_universe_context sigma0 ucst in + let rdxt = Retyping.get_type_of env (fst sr) rdx in (* ppdebug(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) - ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env (pf_env gl) (project gl) (snd sr))); - let cvtac, rwtac, gl = - if EConstr.Vars.closed0 (project gl) r' then - let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.(lib_ref "core.eq.type") in + ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env env sigma0 (snd sr))); + let cvtac, rwtac, sigma0 = + if EConstr.Vars.closed0 sigma0 r' then + let sigma, c, c_eq = fst sr, snd sr, Coqlib.(lib_ref "core.eq.type") in let sigma, c_ty = Typing.type_of env sigma c in ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); let open EConstr in match kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with | AtomicType(e, a) when Ssrcommon.is_ind_ref sigma e c_eq -> let new_rdx = if dir = L2R then a.(2) else a.(1) in - pirrel_rewrite ?under ?map_redex cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl + pirrel_rewrite ?under ?map_redex cl rdx rdxt new_rdx dir (sigma,c) c_ty, Tacticals.New.tclIDTAC, sigma0 | _ -> let cl' = EConstr.mkApp (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl, [|rdx|]) in let sigma, _ = Typing.type_of env sigma cl' in - let gl = pf_merge_uc_of sigma gl in - Proofview.V82.of_tactic (convert_concl ~check:true cl'), rewritetac ?under dir r', gl + let sigma0 = pf_merge_uc_of sigma sigma0 in + convert_concl ~check:true cl', rewritetac ?under dir r', sigma0 else - let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in + let dc, r2 = EConstr.decompose_lam_n_assum sigma0 n r' in let r3, _, r3t = - try EConstr.destCast (project gl) r2 with _ -> - errorstrm Pp.(str "no cast from " ++ pr_econstr_pat (pf_env gl) (project gl) (snd sr) - ++ str " to " ++ pr_econstr_env (pf_env gl) (project gl) r2) in + try EConstr.destCast sigma0 r2 with _ -> + errorstrm Pp.(str "no cast from " ++ pr_econstr_pat env sigma0 (snd sr) + ++ str " to " ++ pr_econstr_env env sigma0 r2) in let cl' = EConstr.mkNamedProd (make_annot rule_id Sorts.Relevant) (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in let cl'' = EConstr.mkNamedProd (make_annot pattern_id Sorts.Relevant) rdxt cl' in let itacs = [introid pattern_id; introid rule_id] in - let cltac = Proofview.V82.of_tactic (Tactics.clear [pattern_id; rule_id]) in + let cltac = Tactics.clear [pattern_id; rule_id] in let rwtacs = [rewritetac ?under dir (EConstr.mkVar rule_id); cltac] in - apply_type cl'' [rdx; EConstr.it_mkLambda_or_LetIn r3 dc], tclTHENLIST (itacs @ rwtacs), gl + Tactics.apply_type ~typecheck:true cl'' [rdx; EConstr.it_mkLambda_or_LetIn r3 dc], Tacticals.New.tclTHENLIST (itacs @ rwtacs), sigma0 in - let cvtac' _ = - try cvtac gl with - | PRtype_error e -> + let cvtac' = + Proofview.tclOR cvtac begin function + | (PRtype_error e, _) -> let error = Option.cata (fun (env, sigma, te) -> Pp.(fnl () ++ str "Type error was: " ++ Himsg.explain_pretype_error env sigma te)) (Pp.mt ()) e in - if occur_existential (project gl) (Tacmach.pf_concl gl) - then errorstrm Pp.(str "Rewriting impacts evars" ++ error) - else errorstrm Pp.(str "Dependent type error in rewrite of " - ++ pr_econstr_env (pf_env gl) (project gl) + if occur_existential sigma0 (Tacmach.New.pf_concl gl) + then Tacticals.New.tclZEROMSG Pp.(str "Rewriting impacts evars" ++ error) + else Tacticals.New.tclZEROMSG Pp.(str "Dependent type error in rewrite of " + ++ pr_econstr_env env sigma0 (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl) ++ error) + | (e, info) -> Proofview.tclZERO ~info e + end in - tclTHEN cvtac' rwtac gl + Proofview.Unsafe.tclEVARS sigma0 <*> + Tacticals.New.tclTHEN cvtac' rwtac + end [@@@ocaml.warning "-3"] let lz_coq_prod = @@ -474,14 +503,13 @@ let ssr_is_setoid env = Rewrite.is_applied_rewrite_relation env sigma [] (EConstr.mkApp (r, args)) <> None -let closed0_check cl p gl = +let closed0_check env sigma cl p = if closed0 cl then - errorstrm Pp.(str"No occurrence of redex "++ pr_constr_env (pf_env gl) (project gl) p) + errorstrm Pp.(str"No occurrence of redex "++ pr_constr_env env sigma p) let dir_org = function L2R -> 1 | R2L -> 2 -let rwprocess_rule dir rule gl = - let env = pf_env gl in +let rwprocess_rule env dir rule = let coq_prod = lz_coq_prod () in let is_setoid = ssr_is_setoid env in let r_sigma, rules = @@ -558,15 +586,17 @@ let rwprocess_rule dir rule gl = in r_sigma, rules -let rwrxtac ?under ?map_redex occ rdx_pat dir rule gl = - let env = pf_env gl in - let r_sigma, rules = rwprocess_rule dir rule gl in +let rwrxtac ?under ?map_redex occ rdx_pat dir rule = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma0 = Proofview.Goal.sigma gl in + let r_sigma, rules = rwprocess_rule env dir rule in let find_rule rdx = let rec rwtac = function | [] -> - errorstrm Pp.(str "pattern " ++ pr_econstr_pat env (project gl) rdx ++ + errorstrm Pp.(str "pattern " ++ pr_econstr_pat env sigma0 rdx ++ str " does not match " ++ pr_dir_side dir ++ - str " of " ++ pr_econstr_pat env (project gl) (snd rule)) + str " of " ++ pr_econstr_pat env sigma0 (snd rule)) | (d, r, lhs, rhs) :: rs -> try let ise = unify_HO env (Evd.create_evar_defs r_sigma) lhs rdx in @@ -574,7 +604,8 @@ let rwrxtac ?under ?map_redex occ rdx_pat dir rule gl = d, (ise, Evd.evar_universe_context ise, Reductionops.nf_evar ise r) with _ -> rwtac rs in rwtac rules in - let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in + let env0 = env in + let concl0 = Proofview.Goal.concl gl in let find_R, conclude = match rdx_pat with | Some (_, (In_T _ | In_X_In_T _)) | None -> let upats_origin = dir, EConstr.Unsafe.to_constr (snd rule) in @@ -586,23 +617,26 @@ let rwrxtac ?under ?map_redex occ rdx_pat dir rule gl = let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in let find_R, end_R = mk_tpattern_matcher sigma0 occ ~upats_origin rpats in (fun e c _ i -> find_R ~k:(fun _ _ _ h -> mkRel h) e c i), - fun cl -> let rdx,d,r = end_R () in closed0_check cl rdx gl; (d,r),rdx + fun cl -> let rdx,d,r = end_R () in closed0_check env0 sigma0 cl rdx; (d,r),rdx | Some(_, (T e | X_In_T (_,e) | E_As_X_In_T (e,_,_) | E_In_X_In_T (e,_,_))) -> let r = ref None in (fun env c _ h -> do_once r (fun () -> find_rule (EConstr.of_constr c), c); mkRel h), - (fun concl -> closed0_check concl e gl; + (fun concl -> closed0_check env0 sigma0 concl e; let (d,(ev,ctx,c)) , x = assert_done r in (d,(ev,ctx, EConstr.to_constr ~abort_on_undefined_evars:false ev c)) , x) in - let concl0 = EConstr.Unsafe.to_constr concl0 in + let concl0 = EConstr.to_constr ~abort_on_undefined_evars:false sigma0 concl0 in let concl = eval_pattern env0 sigma0 concl0 rdx_pat occ find_R in let (d, r), rdx = conclude concl in let r = Evd.merge_universe_context (pi1 r) (pi2 r), EConstr.of_constr (pi3 r) in - rwcltac ?under ?map_redex (EConstr.of_constr concl) (EConstr.of_constr rdx) d r gl -;; - -let ssrinstancesofrule ist dir arg gl = - let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in - let rule = interp_term ist gl arg in - let r_sigma, rules = rwprocess_rule dir rule gl in + rwcltac ?under ?map_redex (EConstr.of_constr concl) (EConstr.of_constr rdx) d r + end + +let ssrinstancesofrule ist dir arg = + Proofview.Goal.enter begin fun gl -> + let env0 = Proofview.Goal.env gl in + let sigma0 = Proofview.Goal.sigma gl in + let concl0 = Proofview.Goal.concl gl in + let rule = interp_term env0 sigma0 ist arg in + let r_sigma, rules = rwprocess_rule env0 dir rule in let find, conclude = let upats_origin = dir, EConstr.Unsafe.to_constr (snd rule) in let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = @@ -619,33 +653,47 @@ let ssrinstancesofrule ist dir arg gl = Feedback.msg_info Pp.(str"BEGIN INSTANCES"); try while true do - ignore(find env0 (EConstr.Unsafe.to_constr concl0) 1 ~k:print) + ignore(find env0 (EConstr.to_constr ~abort_on_undefined_evars:false sigma0 concl0) 1 ~k:print) done; raise NoMatch - with NoMatch -> Feedback.msg_info Pp.(str"END INSTANCES"); tclIDTAC gl - -let ipat_rewrite occ dir c gl = rwrxtac occ None dir (project gl, c) gl - -let rwargtac ?under ?map_redex ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = + with NoMatch -> Feedback.msg_info Pp.(str"END INSTANCES"); Tacticals.New.tclIDTAC + end + +let ipat_rewrite occ dir c = Proofview.Goal.enter begin fun gl -> + rwrxtac occ None dir (Proofview.Goal.sigma gl, c) +end + +let rwargtac ?under ?map_redex ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let fail = ref false in - let interp_rpattern gl gc = - try interp_rpattern gl gc - with _ when snd mult = May -> fail := true; project gl, T mkProp in - let interp gc gl = - try interp_term ist gl gc - with _ when snd mult = May -> fail := true; (project gl, EConstr.mkProp) in - let rwtac gl = - let rx = Option.map (interp_rpattern gl) grx in - let gl = match rx with - | None -> gl - | Some (s,_) -> pf_merge_uc_of s gl in - let t = interp gt gl in - let gl = pf_merge_uc_of (fst t) gl in + let interp_rpattern env sigma gc = + try interp_rpattern env sigma gc + with _ when snd mult = May -> fail := true; sigma, T mkProp in + let interp env sigma gc = + try interp_term env sigma ist gc + with _ when snd mult = May -> fail := true; (sigma, EConstr.mkProp) in + let rwtac = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let rx = Option.map (interp_rpattern env sigma) grx in + let sigma = match rx with + | None -> sigma + | Some (s,_) -> pf_merge_uc_of s sigma in + let t = interp env sigma gt in + let sigma = pf_merge_uc_of (fst t) sigma in + Proofview.Unsafe.tclEVARS sigma <*> (match kind with | RWred sim -> simplintac occ rx sim | RWdef -> if dir = R2L then foldtac occ rx t else unfoldintac occ rx t gt - | RWeq -> rwrxtac ?under ?map_redex occ rx dir t) gl in - let ctac = old_cleartac (interp_clr (project gl) (oclr, (fst gt, snd (interp gt gl)))) in - if !fail then ctac gl else tclTHEN (tclMULT mult rwtac) ctac gl + | RWeq -> rwrxtac ?under ?map_redex occ rx dir t) + end + in + let ctac = cleartac (interp_clr sigma (oclr, (fst gt, snd (interp env sigma gt)))) in + if !fail then ctac else Tacticals.New.tclTHEN (tclMULT mult rwtac) ctac + end (** Rewrite argument sequence *) @@ -654,24 +702,37 @@ let rwargtac ?under ?map_redex ist ((dir, mult), (((oclr, occ), grx), (kind, gt) (** The "rewrite" tactic *) let ssrrewritetac ?under ?map_redex ist rwargs = - tclTHENLIST (List.map (rwargtac ?under ?map_redex ist) rwargs) + Proofview.Goal.enter begin fun _ -> + Tacticals.New.tclTHENLIST (List.map (rwargtac ?under ?map_redex ist) rwargs) + end (** The "unlock" tactic *) -let unfoldtac occ ko t kt gl = - let env = pf_env gl in - let cl, c = pf_fill_occ_term gl occ (fst (strip_unfold_term env t kt)) in - let cl' = EConstr.Vars.subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref env (project gl) c] gl c) cl in +let unfoldtac occ ko t kt = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let concl = Evarutil.nf_evar sigma concl in + let cl, c = fill_occ_term env sigma concl occ (fst (strip_unfold_term env t kt)) in + let cl' = EConstr.Vars.subst1 (Tacred.unfoldn [OnlyOccurrences [1], get_evalref env sigma c] env sigma c) cl in let f = if ko = None then CClosure.betaiotazeta else CClosure.betaiota in - Proofview.V82.of_tactic - (convert_concl ~check:true (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl - -let unlocktac ist args gl = - let utac (occ, gt) gl = - unfoldtac occ occ (interp_term ist gl gt) (fst gt) gl in - let locked, gl = pf_mkSsrConst "locked" gl in - let key, gl = pf_mkSsrConst "master_key" gl in + convert_concl ~check:true (Reductionops.clos_norm_flags f env sigma cl') + end + +let unlocktac ist args = + let open Proofview.Notations in + let utac (occ, gt) = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + unfoldtac occ occ (interp_term env sigma ist gt) (fst gt) + end + in + Ssrcommon.tacMK_SSR_CONST "locked" >>= fun locked -> + Ssrcommon.tacMK_SSR_CONST "master_key" >>= fun key -> let ktacs = [ - (fun gl -> unfoldtac None None (project gl,locked) xInParens gl); - Proofview.V82.of_tactic (Ssrelim.casetac key (fun ?seed:_ k -> k)) ] in - tclTHENLIST (List.map utac args @ ktacs) gl + (Proofview.tclEVARMAP >>= fun sigma -> unfoldtac None None (sigma, locked) xInParens); + Ssrelim.casetac key (fun ?seed:_ k -> k) + ] in + Tacticals.New.tclTHENLIST (List.map utac args @ ktacs) diff --git a/plugins/ssr/ssrequality.mli b/plugins/ssr/ssrequality.mli index 0bb67c99db..1c3b1bb018 100644 --- a/plugins/ssr/ssrequality.mli +++ b/plugins/ssr/ssrequality.mli @@ -26,12 +26,12 @@ val mkclr : ssrclear -> ssrdocc val nodocc : ssrdocc val noclr : ssrdocc -val simpltac : Ssrast.ssrsimpl -> Tacmach.tactic +val simpltac : Ssrast.ssrsimpl -> unit Proofview.tactic val newssrcongrtac : int * Ssrast.ssrterm -> Ltac_plugin.Tacinterp.interp_sign -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic val mk_rwarg : @@ -49,7 +49,7 @@ val ssrinstancesofrule : Ltac_plugin.Tacinterp.interp_sign -> Ssrast.ssrdir -> Ssrast.ssrterm -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic (* map_redex (by default the identity on after) is called on the * redex (before) and its replacement (after). It is used to @@ -59,11 +59,11 @@ val ssrrewritetac : ?map_redex:(Environ.env -> Evd.evar_map -> before:EConstr.t -> after:EConstr.t -> Evd.evar_map * EConstr.t) -> Ltac_plugin.Tacinterp.interp_sign -> - ssrrwarg list -> Tacmach.tactic + ssrrwarg list -> unit Proofview.tactic -val ipat_rewrite : ssrocc -> ssrdir -> EConstr.t -> Tacmach.tactic +val ipat_rewrite : ssrocc -> ssrdir -> EConstr.t -> unit Proofview.tactic val unlocktac : Ltac_plugin.Tacinterp.interp_sign -> (Ssrmatching.occ * Ssrast.ssrterm) list -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 43b527c32b..4961138190 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -28,19 +28,22 @@ module RelDecl = Context.Rel.Declaration let posetac id cl = Proofview.V82.of_tactic (Tactics.pose_tac (Name id) cl) -let ssrposetac (id, (_, t)) gl = +let ssrposetac (id, (_, t)) = + Proofview.V82.tactic begin fun gl -> let ist, t = match t.Ssrast.interp_env with | Some ist -> ist, Ssrcommon.ssrterm_of_ast_closure_term t | None -> assert false in let sigma, t, ucst, _ = pf_abs_ssrterm ist gl t in posetac id t (pf_merge_uc ucst gl) + end -let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = +let ssrsettac id ((_, (pat, pty)), (_, occ)) = + Proofview.V82.tactic begin fun gl -> let pty = Option.map (fun { Ssrast.body; interp_env } -> let ist = Option.get interp_env in (mkRHole, Some body), ist) pty in - let pat = interp_cpattern gl pat pty in + let pat = interp_cpattern (pf_env gl) (project gl) pat pty in let cl, sigma, env = pf_concl gl, project gl, pf_env gl in let (c, ucst), cl = let cl = EConstr.Unsafe.to_constr cl in @@ -56,7 +59,8 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) | _ -> c, pfe_type_of gl c in let cl' = EConstr.mkLetIn (make_annot (Name id) Sorts.Relevant, c, cty, cl) in - Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl')) (introid id) gl + Proofview.V82.of_tactic (Tacticals.New.tclTHEN (convert_concl ~check:true cl') (introid id)) gl + end open Util @@ -85,18 +89,30 @@ let combineCG t1 t2 f g = match t1, t2 with | _, (_, (_, None)) -> anomaly "have: mixed C-G constr" | _ -> anomaly "have: mixed G-C constr" -let basecuttac name c gl = - let hd, gl = pf_mkSsrConst name gl in - let t = EConstr.mkApp (hd, [|c|]) in - let gl, _ = pf_e_type_of gl t in - Proofview.V82.of_tactic (Tactics.apply t) gl +let basecuttac name t = + let open Proofview.Notations in + Ssrcommon.tacMK_SSR_CONST name >>= fun hd -> + let t = EConstr.mkApp (hd, [|t|]) in + Ssrcommon.tacTYPEOF t >>= fun _ty -> + Tactics.apply t -let introstac ipats = Proofview.V82.of_tactic (tclIPAT ipats) +let evarcuttac name cs = + let open Proofview.Notations in + Ssrcommon.tacMK_SSR_CONST name >>= fun hd -> + let t = EConstr.mkApp (hd, cs) in + Ssrcommon.tacTYPEOF t >>= fun _ty -> + applyn ~with_evars:true ~with_shelve:false (Array.length cs) t + +let introstac ipats = tclIPAT ipats let havetac ist (transp,((((clr, orig_pats), binders), simpl), (((fk, _), t), hint))) - suff namefst gl + suff namefst = + let open Proofview.Notations in + Ssrcommon.tacMK_SSR_CONST "abstract_key" >>= fun abstract_key -> + Ssrcommon.tacMK_SSR_CONST "abstract" >>= fun abstract -> + Proofview.V82.tactic begin fun gl -> let concl = pf_concl gl in let pats = tclCompileIPats orig_pats in let binders = tclCompileIPats binders in @@ -108,34 +124,30 @@ let havetac ist match clr with | None -> introstac pats, [] | Some clr -> introstac (tclCompileIPats (IPatClear clr :: orig_pats)), clr in - let itac, id, clr = introstac pats, Tacticals.tclIDTAC, old_cleartac clr in + let itac, id, clr = introstac pats, Tacticals.New.tclIDTAC, cleartac clr in let binderstac n = let rec aux = function 0 -> [] | n -> IOpInaccessible None :: aux (n-1) in - Tacticals.tclTHEN (if binders <> [] then introstac (aux n) else Tacticals.tclIDTAC) + Tacticals.New.tclTHEN (if binders <> [] then introstac (aux n) else Tacticals.New.tclIDTAC) (introstac binders) in let simpltac = introstac simpl in let fixtc = not !ssrhaveNOtcresolution && match fk with FwdHint(_,true) -> false | _ -> true in let hint = hinttac ist true hint in - let cuttac t gl = - if transp then - let have_let, gl = pf_mkSsrConst "ssr_have_let" gl in - let step = EConstr.mkApp (have_let, [|concl;t|]) in - let gl, _ = pf_e_type_of gl step in - applyn ~with_evars:true ~with_shelve:false 2 step gl - else basecuttac "ssr_have" t gl in + let cuttac t = Proofview.Goal.enter begin fun gl -> + if transp then evarcuttac "ssr_have_let" [|concl;t|] + else basecuttac "ssr_have" t + end in (* Introduce now abstract constants, so that everything sees them *) - let abstract_key, gl = pf_mkSsrConst "abstract_key" gl in let unlock_abs (idty,args_id) gl = let gl, _ = pf_e_type_of gl idty in pf_unify_HO gl args_id.(2) abstract_key in - Tacticals.tclTHENFIRST itac_mkabs (fun gl -> + Tacticals.tclTHENFIRST (Proofview.V82.of_tactic itac_mkabs) (fun gl -> let mkt t = mk_term xNoFlag t in let mkl t = (xNoFlag, (t, None)) in let interp gl rtc t = pf_abs_ssrterm ~resolve_typeclasses:rtc ist gl t in let interp_ty gl rtc t = - let a,b,_,u = pf_interp_ty ~resolve_typeclasses:rtc ist gl t in a,b,u in + let a,b,_,u = pf_interp_ty ~resolve_typeclasses:rtc (pf_env gl) (project gl) ist t in a,b,u in let open CAst in let ct, cty, hole, loc = match Ssrcommon.ssrterm_of_ast_closure_term t with | _, (_, Some { loc; v = CCast (ct, CastConv cty)}) -> @@ -163,7 +175,7 @@ let havetac ist try Proofview.V82.of_tactic (convert_concl ~check:true (EConstr.it_mkProd_or_LetIn concl ctx)) gl with _ -> errorstrm (str "Given proof term is not of type " ++ pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) Sorts.Relevant concl)) in - gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c + gl, ty, Tacticals.New.tclTHEN (Proofview.V82.tactic assert_is_conv) (Tactics.apply t), id, itac_c | FwdHave, false, false -> let skols = List.flatten (List.map (function | IOpAbstractVars ids -> ids @@ -181,13 +193,12 @@ let havetac ist let gs = List.map (fun (_,a) -> Ssripats.Internal.pf_find_abstract_proof false gl (EConstr.Unsafe.to_constr a.(1))) skols_args in - let tacopen_skols gl = re_sig (gs @ [gl.Evd.it]) gl.Evd.sigma in + let tacopen_skols = Proofview.V82.tactic (fun gl -> re_sig (gs @ [gl.Evd.it]) gl.Evd.sigma) in let gl, ty = pf_e_type_of gl t in - gl, ty, Proofview.V82.of_tactic (Tactics.apply t), id, - Tacticals.tclTHEN (Tacticals.tclTHEN itac_c simpltac) - (Tacticals.tclTHEN tacopen_skols (fun gl -> - let abstract, gl = pf_mkSsrConst "abstract" gl in - Proofview.V82.of_tactic (unfold [abstract; abstract_key]) gl)) + gl, ty, Tactics.apply t, id, + Tacticals.New.tclTHEN (Tacticals.New.tclTHEN itac_c simpltac) + (Tacticals.New.tclTHEN tacopen_skols (Proofview.V82.tactic (fun gl -> + Proofview.V82.of_tactic (unfold [abstract; abstract_key]) gl))) | _,true,true -> let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in gl, EConstr.mkArrow ty Sorts.Relevant concl, hint, itac, clr @@ -196,11 +207,11 @@ let havetac ist gl, EConstr.mkArrow ty Sorts.Relevant concl, hint, id, itac_c | _, false, false -> let n, cty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in - gl, cty, Tacticals.tclTHEN (binderstac n) hint, id, Tacticals.tclTHEN itac_c simpltac + gl, cty, Tacticals.New.tclTHEN (binderstac n) hint, id, Tacticals.New.tclTHEN itac_c simpltac | _, true, false -> assert false in - Tacticals.tclTHENS (cuttac cut) [ Tacticals.tclTHEN sol itac1; itac2 ] gl) + Proofview.V82.of_tactic (Tacticals.New.tclTHENS (cuttac cut) [ Tacticals.New.tclTHEN sol itac1; itac2 ]) gl) gl -;; +end let destProd_or_LetIn sigma c = match EConstr.kind sigma c with @@ -208,7 +219,8 @@ let destProd_or_LetIn sigma c = | LetIn (n,bo,ty,c) -> RelDecl.LocalDef (n, bo, ty), c | _ -> raise DestKO -let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = +let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave = + Proofview.V82.tactic begin fun gl -> let clr0 = Option.default [] clr0 in let pats = tclCompileIPats pats in let mkabs gen = abs_wgen false (fun x -> x) gen in @@ -243,7 +255,7 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = let (sigma, ev) = Evarutil.new_evar env sigma EConstr.mkProp in let k, _ = EConstr.destEvar sigma ev in let fake_gl = {Evd.it = k; Evd.sigma = sigma} in - let _, ct, _, uc = pf_interp_ty ist fake_gl ct in + let _, ct, _, uc = pf_interp_ty (pf_env fake_gl) sigma ist ct in let rec var2rel c g s = match EConstr.kind sigma c, g with | Prod({binder_name=Anonymous} as x,_,c), [] -> EConstr.mkProd(x, EConstr.Vars.subst_vars s ct, c) | Sort _, [] -> EConstr.Vars.subst_vars s ct @@ -260,39 +272,40 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = c, args, pired c args, pf_merge_uc uc gl in let tacipat pats = introstac pats in let tacigens = - Tacticals.tclTHEN - (Tacticals.tclTHENLIST(List.rev(List.fold_right mkclr gens [old_cleartac clr0]))) + Tacticals.New.tclTHEN + (Tacticals.New.tclTHENLIST(List.rev(List.fold_right mkclr gens [cleartac clr0]))) (introstac (List.fold_right mkpats gens [])) in let hinttac = hinttac ist true hint in let cut_kind, fst_goal_tac, snd_goal_tac = match suff, ghave with - | true, `NoGen -> "ssr_wlog", Tacticals.tclTHEN hinttac (tacipat pats), tacigens - | false, `NoGen -> "ssr_wlog", hinttac, Tacticals.tclTHEN tacigens (tacipat pats) + | true, `NoGen -> "ssr_wlog", Tacticals.New.tclTHEN hinttac (tacipat pats), tacigens + | false, `NoGen -> "ssr_wlog", hinttac, Tacticals.New.tclTHEN tacigens (tacipat pats) | true, `Gen _ -> assert false | false, `Gen id -> if gens = [] then errorstrm(str"gen have requires some generalizations"); - let clear0 = old_cleartac clr0 in + let clear0 = cleartac clr0 in let id, name_general_hyp, cleanup, pats = match id, pats with | None, (IOpId id as ip)::pats -> Some id, tacipat [ip], clear0, pats - | None, _ -> None, Tacticals.tclIDTAC, clear0, pats + | None, _ -> None, Tacticals.New.tclIDTAC, clear0, pats | Some (Some id),_ -> Some id, introid id, clear0, pats | Some _,_ -> let id = mk_anon_id "tmp" (Tacmach.pf_ids_of_hyps gl) in - Some id, introid id, Tacticals.tclTHEN clear0 (Proofview.V82.of_tactic (Tactics.clear [id])), pats in + Some id, introid id, Tacticals.New.tclTHEN clear0 (Tactics.clear [id]), pats in let tac_specialize = match id with - | None -> Tacticals.tclIDTAC + | None -> Tacticals.New.tclIDTAC | Some id -> - if pats = [] then Tacticals.tclIDTAC else + if pats = [] then Tacticals.New.tclIDTAC else let args = Array.of_list args in ppdebug(lazy(str"specialized="++ pr_econstr_env (pf_env gl) (project gl) EConstr.(mkApp (mkVar id,args)))); ppdebug(lazy(str"specialized_ty="++ pr_econstr_env (pf_env gl) (project gl) ct)); - Tacticals.tclTHENS (basecuttac "ssr_have" ct) - [Proofview.V82.of_tactic (Tactics.apply EConstr.(mkApp (mkVar id,args))); Tacticals.tclIDTAC] in + Tacticals.New.tclTHENS (basecuttac "ssr_have" ct) + [Tactics.apply EConstr.(mkApp (mkVar id,args)); Tacticals.New.tclIDTAC] in "ssr_have", (if hint = nohint then tacigens else hinttac), - Tacticals.tclTHENLIST [name_general_hyp; tac_specialize; tacipat pats; cleanup] + Tacticals.New.tclTHENLIST [name_general_hyp; tac_specialize; tacipat pats; cleanup] in - Tacticals.tclTHENS (basecuttac cut_kind c) [fst_goal_tac; snd_goal_tac] gl + Proofview.V82.of_tactic (Tacticals.New.tclTHENS (basecuttac cut_kind c) [fst_goal_tac; snd_goal_tac]) gl + end (** The "suffice" tactic *) @@ -301,7 +314,7 @@ let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = let pats = tclCompileIPats pats in let binders = tclCompileIPats binders in let simpl = tclCompileIPats simpl in - let htac = Tacticals.tclTHEN (introstac pats) (hinttac ist true hint) in + let htac = Tacticals.New.tclTHEN (introstac pats) (hinttac ist true hint) in let c = match Ssrcommon.ssrterm_of_ast_closure_term c with | (a, (b, Some ct)) -> begin match ct.CAst.v with @@ -314,10 +327,12 @@ let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = | _ -> anomaly "suff: ssr cast hole deleted by typecheck" end in - let ctac gl = - let _,ty,_,uc = pf_interp_ty ist gl c in let gl = pf_merge_uc uc gl in - basecuttac "ssr_suff" ty gl in - Tacticals.tclTHENS ctac [htac; Tacticals.tclTHEN (old_cleartac clr) (introstac (binders@simpl))] + let ctac = + Proofview.V82.tactic begin fun gl -> + let _,ty,_,uc = pf_interp_ty (pf_env gl) (project gl) ist c in let gl = pf_merge_uc uc gl in + Proofview.V82.of_tactic (basecuttac "ssr_suff" ty) gl + end in + Tacticals.New.tclTHENS ctac [htac; Tacticals.New.tclTHEN (cleartac clr) (introstac (binders@simpl))] open Proofview.Notations @@ -340,16 +355,14 @@ let intro_lock ipats = Proofview.tclDISPATCH (ncons (ng - 1) ssrsmovetac @ [Proofview.tclUNIT ()]) in let protect_subgoal env sigma hd args = + Ssrcommon.tacMK_SSR_CONST "Under_rel" >>= fun under_rel -> + Ssrcommon.tacMK_SSR_CONST "Under_rel_from_rel" >>= fun under_from_rel -> Tactics.New.refine ~typecheck:true (fun sigma -> let lm2 = Array.length args - 2 in let sigma, carrier = Typing.type_of env sigma args.(lm2) in let rel = EConstr.mkApp (hd, Array.sub args 0 lm2) in let rel_args = Array.sub args lm2 2 in - let sigma, under_rel = - Ssrcommon.mkSsrConst "Under_rel" env sigma in - let sigma, under_from_rel = - Ssrcommon.mkSsrConst "Under_rel_from_rel" env sigma in let under_rel_args = Array.append [|carrier; rel|] rel_args in let ty = EConstr.mkApp (under_rel, under_rel_args) in let sigma, t = Evarutil.new_evar env sigma ty in @@ -408,7 +421,7 @@ let pretty_rename evar_map term varnames = in aux term varnames -let overtac = Proofview.V82.tactic (ssr_n_tac "over" ~-1) +let overtac = ssr_n_tac "over" ~-1 let check_numgoals ?(minus = 0) nh = Proofview.numgoals >>= fun ng -> @@ -492,7 +505,6 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = @ [betaiota]) in let rew = - Proofview.V82.tactic - (Ssrequality.ssrrewritetac ~under:true ~map_redex ist [rule]) + Ssrequality.ssrrewritetac ~under:true ~map_redex ist [rule] in rew <*> intro_lock ipats <*> undertacs diff --git a/plugins/ssr/ssrfwd.mli b/plugins/ssr/ssrfwd.mli index 8aacae39af..33bf56cfa9 100644 --- a/plugins/ssr/ssrfwd.mli +++ b/plugins/ssr/ssrfwd.mli @@ -16,9 +16,9 @@ open Ltac_plugin open Ssrast -val ssrsettac : Id.t -> ((ssrfwdfmt * (Ssrmatching_plugin.Ssrmatching.cpattern * ast_closure_term option)) * ssrdocc) -> v82tac +val ssrsettac : Id.t -> ((ssrfwdfmt * (Ssrmatching_plugin.Ssrmatching.cpattern * ast_closure_term option)) * ssrdocc) -> unit Proofview.tactic -val ssrposetac : Id.t * (ssrfwdfmt * ast_closure_term) -> v82tac +val ssrposetac : Id.t * (ssrfwdfmt * ast_closure_term) -> unit Proofview.tactic val havetac : ist -> bool * @@ -27,11 +27,9 @@ val havetac : ist -> (((Ssrast.ssrfwdkind * 'a) * ast_closure_term) * (bool * Tacinterp.Value.t option list))) -> bool -> - bool -> v82tac + bool -> unit Proofview.tactic -val basecuttac : - string -> - EConstr.t -> Goal.goal Evd.sigma -> Evar.t list Evd.sigma +val basecuttac : string -> EConstr.t -> unit Proofview.tactic val wlogtac : Ltac_plugin.Tacinterp.interp_sign -> @@ -46,7 +44,7 @@ val wlogtac : Ltac_plugin.Tacinterp.Value.t Ssrast.ssrhint -> bool -> [< `Gen of Names.Id.t option option | `NoGen > `NoGen ] -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic val sufftac : Ssrast.ist -> @@ -55,7 +53,7 @@ val sufftac : (('a * ast_closure_term) * (bool * Tacinterp.Value.t option list)) -> - Tacmach.tactic + unit Proofview.tactic (* pad_intro (by default false) indicates whether the intro-pattern "=> i..." must be turned into "=> [i...|i...|i...|]" (n+1 branches, diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 1edec8e8a0..46f90a7ee1 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -191,7 +191,7 @@ let isGEN_PUSH dg = (* generalize `id` as `new_name` *) let gen_astac id new_name = let gen = ((None,Some(false,[])),Ssrmatching.cpattern_of_id id) in - V82.tactic (Ssrcommon.gentac gen) + Ssrcommon.gentac gen <*> Ssrcommon.tclRENAME_HD_PROD new_name (* performs and resets all delayed generalizations *) @@ -337,7 +337,7 @@ let tac_case t = Ssrcommon.tacTYPEOF t >>= fun ty -> Ssrcommon.tacIS_INJECTION_CASE ~ty t >>= fun is_inj -> if is_inj then - V82.tactic ~nf_evars:false (Ssrelim.perform_injection t) + Ssrelim.perform_injection t else Goal.enter begin fun g -> (Ssrelim.casetac t (fun ?seed k -> @@ -384,13 +384,11 @@ end let tclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> let env, concl = Goal.(env gl, concl gl) in - let step = begin fun sigma -> + let step ablock abstract = begin fun sigma -> let (sigma, (abstract_proof, abstract_ty)) = let (sigma, (ty, _)) = Evarutil.new_type_evar env sigma Evd.univ_flexible_alg in - let (sigma, ablock) = Ssrcommon.mkSsrConst "abstract_lock" env sigma in let (sigma, lock) = Evarutil.new_evar env sigma ablock in - let (sigma, abstract) = Ssrcommon.mkSsrConst "abstract" env sigma in let (sigma, abstract_id) = mk_abstract_id env sigma in let abstract_ty = EConstr.mkApp(abstract, [|ty; abstract_id; lock|]) in let sigma, m = Evarutil.new_evar env sigma abstract_ty in @@ -405,7 +403,9 @@ let tclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> let sigma, _ = Typing.type_of env sigma term in sigma, term end in - Tactics.New.refine ~typecheck:false step <*> + Ssrcommon.tacMK_SSR_CONST "abstract_lock" >>= fun ablock -> + Ssrcommon.tacMK_SSR_CONST "abstract" >>= fun abstract -> + Tactics.New.refine ~typecheck:false (step ablock abstract) <*> tclFOCUS 1 3 Proofview.shelve end @@ -477,7 +477,7 @@ let rec ipat_tac1 ipat : bool tactic = | IOpInj ipatss -> tclIORPAT (Ssrcommon.tclWITHTOP - (fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t))) + (fun t -> Ssrelim.perform_injection t)) ipatss <*> notTAC @@ -494,11 +494,11 @@ let rec ipat_tac1 ipat : bool tactic = notTAC | IOpSimpl x -> - V82.tactic ~nf_evars:false (Ssrequality.simpltac x) <*> notTAC + Ssrequality.simpltac x <*> notTAC | IOpRewrite (occ,dir) -> Ssrcommon.tclWITHTOP - (fun x -> V82.tactic ~nf_evars:false (Ssrequality.ipat_rewrite occ dir x)) <*> notTAC + (fun x -> Ssrequality.ipat_rewrite occ dir x) <*> notTAC | IOpAbstractVars ids -> tclMK_ABSTRACT_VARS ids <*> notTAC @@ -622,7 +622,7 @@ end let with_dgens { dgens; gens; clr } maintac = match gens with | [] -> with_defective maintac dgens clr | gen :: gens -> - V82.tactic ~nf_evars:false (Ssrcommon.genstac (gens, clr)) <*> maintac dgens gen + Ssrcommon.genstac (gens, clr) <*> maintac dgens gen let mkCoqEq env sigma = let eq = Coqlib.((build_coq_eq_data ()).eq) in @@ -647,7 +647,7 @@ let elim_intro_tac ipats ?seed what eqid ssrelim is_rec clr = | ProdType (_, src, tgt) -> begin match kind_of_type sigma src with | AtomicType (hd, _) when Ssrcommon.is_protect hd env sigma -> - V82.tactic ~nf_evars:false Ssrcommon.unprotecttac <*> + Ssrcommon.unprotecttac <*> Ssrcommon.tclINTRO_ID ipat | _ -> Ssrcommon.tclINTRO_ANON () <*> intro_eq () end @@ -700,7 +700,7 @@ let elim_intro_tac ipats ?seed what eqid ssrelim is_rec clr = | _ -> tclUNIT () in let unprotect = if eqid <> None && is_rec - then V82.tactic ~nf_evars:false Ssrcommon.unprotecttac else tclUNIT () in + then Ssrcommon.unprotecttac else tclUNIT () in begin match seed with | None -> ssrelim | Some s -> IpatMachine.tclSEED_SUBGOALS s ssrelim end <*> @@ -727,7 +727,7 @@ let mkEq dir cl c t n env sigma = let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin Ssrcommon.tacSIGMA >>= fun sigma0 -> Goal.enter_one begin fun g -> - let pat = Ssrmatching.interp_cpattern sigma0 t None in + let pat = Ssrmatching.interp_cpattern (Tacmach.pf_env sigma0) (Tacmach.project sigma0) t None in let cl0, env, sigma, hyps = Goal.(concl g, env g, sigma g, hyps g) in let cl = EConstr.to_constr ~abort_on_undefined_evars:false sigma cl0 in let (c, ucst), cl = @@ -816,7 +816,7 @@ let ssrcasetac (view, (eqid, (dgens, ipats))) = Ssrcommon.tacIS_INJECTION_CASE vc >>= fun inj -> let simple = (eqid = None && deps = [] && occ = None) in if simple && inj then - V82.tactic ~nf_evars:false (Ssrelim.perform_injection vc) <*> + Ssrelim.perform_injection vc <*> Tactics.clear (List.map Ssrcommon.hyp_id clear) <*> tclIPATssr ipats else @@ -870,7 +870,7 @@ let tclIPAT ip = let ssrmovetac = function | _::_ as view, (_, ({ gens = lastgen :: gens; clr }, ipats)) -> - let gentac = V82.tactic ~nf_evars:false (Ssrcommon.genstac (gens, [])) in + let gentac = Ssrcommon.genstac (gens, []) in let conclusion _ t clear ccl = Tactics.apply_type ~typecheck:true ccl [t] <*> Tactics.clear (List.map Ssrcommon.hyp_id clear) in @@ -884,7 +884,7 @@ let ssrmovetac = function let dgentac = with_dgens dgens eqmovetac in dgentac <*> tclIPAT (eqmoveipats (IpatMachine.tclCompileIPats [pat]) (IpatMachine.tclCompileIPats ipats)) | _, (_, ({ gens = (_ :: _ as gens); dgens = []; clr}, ipats)) -> - let gentac = V82.tactic ~nf_evars:false (Ssrcommon.genstac (gens, clr)) in + let gentac = Ssrcommon.genstac (gens, clr) in gentac <*> tclIPAT (IpatMachine.tclCompileIPats ipats) | _, (_, ({ clr }, ipats)) -> Tacticals.New.tclTHENLIST [ssrsmovetac; Tactics.clear (List.map Ssrcommon.hyp_id clr); tclIPAT (IpatMachine.tclCompileIPats ipats)] @@ -985,7 +985,7 @@ let ssrabstract dgens = Ssrcommon.tacSIGMA >>= fun gl0 -> let open Ssrmatching in let ipats = List.map (fun (_,cp) -> - match id_of_pattern (interp_cpattern gl0 cp None) with + match id_of_pattern (interp_cpattern (Tacmach.pf_env gl0) (Tacmach.project gl0) cp None) with | None -> IPatAnon (One None) | Some id -> IPatId id) (List.tl gens) in diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 442b40221b..0307728819 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -1611,17 +1611,6 @@ let tactic_expr = Pltac.tactic_expr (** 1. Utilities *) -(** Tactic-level diagnosis *) - -(* debug *) - -{ - -(* Let's play with the new proof engine API *) -let old_tac = V82.tactic - -} - (** Name generation *) (* Since Coq now does repeated internal checks of its external lexical *) @@ -1731,18 +1720,20 @@ END { -let ssrautoprop gl = +let ssrautoprop = + Proofview.Goal.enter begin fun gl -> try let tacname = try Tacenv.locate_tactic (qualid_of_ident (Id.of_string "ssrautoprop")) with Not_found -> Tacenv.locate_tactic (ssrqid "ssrautoprop") in let tacexpr = CAst.make @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in - V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl - with Not_found -> V82.of_tactic (Auto.full_trivial []) gl + eval_tactic (Tacexpr.TacArg tacexpr) + with Not_found -> Auto.full_trivial [] + end let () = ssrautoprop_tac := ssrautoprop -let tclBY tac = Tacticals.tclTHEN tac (donetac ~-1) +let tclBY tac = Tacticals.New.tclTHEN tac (donetac ~-1) (** Tactical arguments. *) @@ -1760,7 +1751,7 @@ open Ssrfwd } TACTIC EXTEND ssrtclby -| [ "by" ssrhintarg(tac) ] -> { V82.tactic (hinttac ist true tac) } +| [ "by" ssrhintarg(tac) ] -> { hinttac ist true tac } END (* We can't parse "by" in ARGUMENT EXTEND because it will only be made *) @@ -1778,7 +1769,7 @@ END let () = register_ssrtac "tcldo" begin fun args ist -> match args with | [arg] -> let arg = cast_arg wit_ssrdoarg arg in - V82.tactic (ssrdotac ist arg) + ssrdotac ist arg | _ -> assert false end @@ -1827,7 +1818,7 @@ let () = register_ssrtac "tclseq" begin fun args ist -> match args with let tac = cast_arg wit_ssrtclarg tac in let dir = cast_arg wit_ssrseqdir dir in let arg = cast_arg wit_ssrseqarg arg in - V82.tactic (tclSEQAT ist tac dir arg) + tclSEQAT ist tac dir arg | _ -> assert false end @@ -2191,9 +2182,9 @@ let vmexacttac pf = TACTIC EXTEND ssrexact | [ "exact" ssrexactarg(arg) ] -> { let views, (gens_clr, _) = arg in - V82.tactic (tclBY (V82.of_tactic (inner_ssrapplytac views gens_clr ist))) } + tclBY (inner_ssrapplytac views gens_clr ist) } | [ "exact" ] -> { - V82.tactic (Tacticals.tclORELSE (donetac ~-1) (tclBY (V82.of_tactic apply_top_tac))) } + Tacticals.New.tclORELSE (donetac ~-1) (tclBY apply_top_tac) } | [ "exact" "<:" lconstr(pf) ] -> { vmexacttac pf } END @@ -2220,9 +2211,9 @@ END TACTIC EXTEND ssrcongr | [ "congr" ssrcongrarg(arg) ] -> { let arg, dgens = arg in - V82.tactic begin + Proofview.Goal.enter begin fun _ -> match dgens with - | [gens], clr -> Tacticals.tclTHEN (genstac (gens,clr)) (newssrcongrtac arg ist) + | [gens], clr -> Tacticals.New.tclTHEN (genstac (gens,clr)) (newssrcongrtac arg ist) | _ -> errorstrm (str"Dependent family abstractions not allowed in congr") end } END @@ -2342,10 +2333,10 @@ ARGUMENT EXTEND ssrrwarg END TACTIC EXTEND ssrinstofruleL2R -| [ "ssrinstancesofruleL2R" ssrterm(arg) ] -> { V82.tactic (ssrinstancesofrule ist L2R arg) } +| [ "ssrinstancesofruleL2R" ssrterm(arg) ] -> { ssrinstancesofrule ist L2R arg } END TACTIC EXTEND ssrinstofruleR2L -| [ "ssrinstancesofruleR2L" ssrterm(arg) ] -> { V82.tactic (ssrinstancesofrule ist R2L arg) } +| [ "ssrinstancesofruleR2L" ssrterm(arg) ] -> { ssrinstancesofrule ist R2L arg } END (** Rewrite argument sequence *) @@ -2395,7 +2386,7 @@ END TACTIC EXTEND ssrrewrite | [ "rewrite" ssrrwargs(args) ssrclauses(clauses) ] -> - { tclCLAUSES (old_tac (ssrrewritetac ist args)) clauses } + { tclCLAUSES (ssrrewritetac ist args) clauses } END (** The "unlock" tactic *) @@ -2426,16 +2417,16 @@ END TACTIC EXTEND ssrunlock | [ "unlock" ssrunlockargs(args) ssrclauses(clauses) ] -> - { tclCLAUSES (old_tac (unlocktac ist args)) clauses } + { tclCLAUSES (unlocktac ist args) clauses } END (** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) TACTIC EXTEND ssrpose -| [ "pose" ssrfixfwd(ffwd) ] -> { V82.tactic (ssrposetac ffwd) } -| [ "pose" ssrcofixfwd(ffwd) ] -> { V82.tactic (ssrposetac ffwd) } -| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> { V82.tactic (ssrposetac (id, fwd)) } +| [ "pose" ssrfixfwd(ffwd) ] -> { ssrposetac ffwd } +| [ "pose" ssrcofixfwd(ffwd) ] -> { ssrposetac ffwd } +| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> { ssrposetac (id, fwd) } END (** The "set" tactic *) @@ -2444,7 +2435,7 @@ END TACTIC EXTEND ssrset | [ "set" ssrfwdid(id) ssrsetfwd(fwd) ssrclauses(clauses) ] -> - { tclCLAUSES (old_tac (ssrsettac id fwd)) clauses } + { tclCLAUSES (ssrsettac id fwd) clauses } END (** The "have" tactic *) @@ -2471,27 +2462,27 @@ END TACTIC EXTEND ssrhave | [ "have" ssrhavefwdwbinders(fwd) ] -> - { V82.tactic (havetac ist fwd false false) } + { havetac ist fwd false false } END TACTIC EXTEND ssrhavesuff | [ "have" "suff" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - { V82.tactic (havetac ist (false,(pats,fwd)) true false) } + { havetac ist (false,(pats,fwd)) true false } END TACTIC EXTEND ssrhavesuffices | [ "have" "suffices" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - { V82.tactic (havetac ist (false,(pats,fwd)) true false) } + { havetac ist (false,(pats,fwd)) true false } END TACTIC EXTEND ssrsuffhave | [ "suff" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - { V82.tactic (havetac ist (false,(pats,fwd)) true true) } + { havetac ist (false,(pats,fwd)) true true } END TACTIC EXTEND ssrsufficeshave | [ "suffices" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - { V82.tactic (havetac ist (false,(pats,fwd)) true true) } + { havetac ist (false,(pats,fwd)) true true } END (** The "suffice" tactic *) @@ -2515,11 +2506,11 @@ END TACTIC EXTEND ssrsuff -| [ "suff" ssrsufffwd(fwd) ] -> { V82.tactic (sufftac ist fwd) } +| [ "suff" ssrsufffwd(fwd) ] -> { sufftac ist fwd } END TACTIC EXTEND ssrsuffices -| [ "suffices" ssrsufffwd(fwd) ] -> { V82.tactic (sufftac ist fwd) } +| [ "suffices" ssrsufffwd(fwd) ] -> { sufftac ist fwd } END (** The "wlog" (Without Loss Of Generality) tactic *) @@ -2541,34 +2532,34 @@ END TACTIC EXTEND ssrwlog | [ "wlog" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - { V82.tactic (wlogtac ist pats fwd hint false `NoGen) } + { wlogtac ist pats fwd hint false `NoGen } END TACTIC EXTEND ssrwlogs | [ "wlog" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } + { wlogtac ist pats fwd hint true `NoGen } END TACTIC EXTEND ssrwlogss | [ "wlog" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> - { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } + { wlogtac ist pats fwd hint true `NoGen } END TACTIC EXTEND ssrwithoutloss | [ "without" "loss" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - { V82.tactic (wlogtac ist pats fwd hint false `NoGen) } + { wlogtac ist pats fwd hint false `NoGen } END TACTIC EXTEND ssrwithoutlosss | [ "without" "loss" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } + { wlogtac ist pats fwd hint true `NoGen } END TACTIC EXTEND ssrwithoutlossss | [ "without" "loss" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> - { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } + { wlogtac ist pats fwd hint true `NoGen } END { @@ -2617,14 +2608,14 @@ TACTIC EXTEND ssrgenhave | [ "gen" "have" ssrclear(clr) ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> { let pats = augment_preclr clr pats in - V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) } + wlogtac ist pats fwd hint false (`Gen id) } END TACTIC EXTEND ssrgenhave2 | [ "generally" "have" ssrclear(clr) ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> { let pats = augment_preclr clr pats in - V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) } + wlogtac ist pats fwd hint false (`Gen id) } END { diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index 00d1296291..cbc352126e 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -30,10 +30,12 @@ let get_index = function Locus.ArgArg i -> i | _ -> (** The "first" and "last" tacticals. *) -let tclPERM perm tac gls = - let subgls = tac gls in +let tclPERM perm tac = + Proofview.V82.tactic begin fun gls -> + let subgls = Proofview.V82.of_tactic tac gls in let subgll' = perm subgls.Evd.it in re_sig subgll' subgls.Evd.sigma + end let rot_hyps dir i hyps = let n = List.length hyps in @@ -46,17 +48,17 @@ let rot_hyps dir i hyps = let tclSEQAT ist atac1 dir (ivar, ((_, atacs2), atac3)) = let i = get_index ivar in - let evtac t = Proofview.V82.of_tactic (ssrevaltac ist t) in + let evtac t = ssrevaltac ist t in let tac1 = evtac atac1 in if atacs2 = [] && atac3 <> None then tclPERM (rot_hyps dir i) tac1 else - let evotac = function Some atac -> evtac atac | _ -> Tacticals.tclIDTAC in + let evotac = function Some atac -> evtac atac | _ -> Tacticals.New.tclIDTAC in let tac3 = evotac atac3 in let rec mk_pad n = if n > 0 then tac3 :: mk_pad (n - 1) else [] in match dir, mk_pad (i - 1), List.map evotac atacs2 with - | L2R, [], [tac2] when atac3 = None -> Tacticals.tclTHENFIRST tac1 tac2 - | L2R, [], [tac2] when atac3 = None -> Tacticals.tclTHENLAST tac1 tac2 - | L2R, pad, tacs2 -> Tacticals.tclTHENSFIRSTn tac1 (Array.of_list (pad @ tacs2)) tac3 - | R2L, pad, tacs2 -> Tacticals.tclTHENSLASTn tac1 tac3 (Array.of_list (tacs2 @ pad)) + | L2R, [], [tac2] when atac3 = None -> Tacticals.New.tclTHENFIRST tac1 tac2 + | L2R, [], [tac2] when atac3 = None -> Tacticals.New.tclTHENLAST tac1 tac2 + | L2R, pad, tacs2 -> Tacticals.New.tclTHENSFIRSTn tac1 (Array.of_list (pad @ tacs2)) tac3 + | R2L, pad, tacs2 -> Tacticals.New.tclTHENSLASTn tac1 tac3 (Array.of_list (tacs2 @ pad)) (** The "in" pseudo-tactical *)(* {{{ **********************************************) @@ -74,7 +76,7 @@ let check_wgen_uniq gens = | [] -> () in check [] ids -let pf_clauseids gl gens clseq = +let pf_clauseids gens clseq = let keep_clears = List.map (fun (x, _) -> x, None) in if gens <> [] then (check_wgen_uniq gens; gens) else if clseq <> InAll && clseq <> InAllHyps then keep_clears gens else @@ -82,14 +84,15 @@ let pf_clauseids gl gens clseq = let hidden_clseq = function InHyps | InHypsSeq | InAllHyps -> true | _ -> false -let posetac id cl = Proofview.V82.of_tactic (Tactics.pose_tac (Name id) cl) +let posetac id cl = Tactics.pose_tac (Name id) cl let hidetacs clseq idhide cl0 = if not (hidden_clseq clseq) then [] else [posetac idhide cl0; - Proofview.V82.of_tactic (convert_concl_no_check (EConstr.mkVar idhide))] + convert_concl_no_check (EConstr.mkVar idhide)] -let endclausestac id_map clseq gl_id cl0 gl = +let endclausestac id_map clseq gl_id cl0 = + Proofview.V82.tactic begin fun gl -> let not_hyp' id = not (List.mem_assoc id id_map) in let orig_id id = try List.assoc id id_map with Not_found -> id in let dc, c = EConstr.decompose_prod_assum (project gl) (pf_concl gl) in @@ -124,40 +127,45 @@ let endclausestac id_map clseq gl_id cl0 gl = let all_ids = ids_of_rel_context dc @ pf_ids_of_hyps gl in if List.for_all not_hyp' all_ids && not c_hidden then mktac [] gl else errorstrm Pp.(str "tampering with discharged assumptions of \"in\" tactical") - -let tclCLAUSES tac (gens, clseq) gl = - if clseq = InGoal || clseq = InSeqGoal then tac gl else - let clr_gens = pf_clauseids gl gens clseq in - let clear = Tacticals.tclTHENLIST (List.rev(List.fold_right clr_of_wgen clr_gens [])) in - let gl_id = mk_anon_id hidden_goal_tag (Tacmach.pf_ids_of_hyps gl) in - let cl0 = pf_concl gl in - let dtac gl = + end + +let tclCLAUSES tac (gens, clseq) = + Proofview.Goal.enter begin fun gl -> + if clseq = InGoal || clseq = InSeqGoal then tac else + let clr_gens = pf_clauseids gens clseq in + let clear = Tacticals.New.tclTHENLIST (List.rev(List.fold_right clr_of_wgen clr_gens [])) in + let gl_id = mk_anon_id hidden_goal_tag (Tacmach.New.pf_ids_of_hyps gl) in + let cl0 = Proofview.Goal.concl gl in + let dtac = + Proofview.V82.tactic begin fun gl -> let c = pf_concl gl in let gl, args, c = List.fold_right (abs_wgen true mk_discharged_id) gens (gl,[], c) in - apply_type c args gl in + apply_type c args gl + end + in let endtac = let id_map = CList.map_filter (function | _, Some ((x,_),_) -> let id = hoi_id x in Some (mk_discharged_id id, id) | _, None -> None) gens in endclausestac id_map clseq gl_id cl0 in - Tacticals.tclTHENLIST (hidetacs clseq gl_id cl0 @ [dtac; clear; tac; endtac]) gl + Tacticals.New.tclTHENLIST (hidetacs clseq gl_id cl0 @ [dtac; clear; tac; endtac]) + end (** The "do" tactical. ********************************************************) let hinttac ist is_by (is_or, atacs) = - let dtac = if is_by then donetac ~-1 else Tacticals.tclIDTAC in + Proofview.Goal.enter begin fun _ -> + let dtac = if is_by then donetac ~-1 else Tacticals.New.tclIDTAC in let mktac = function - | Some atac -> Tacticals.tclTHEN (Proofview.V82.of_tactic (ssrevaltac ist atac)) dtac + | Some atac -> Tacticals.New.tclTHEN (ssrevaltac ist atac) dtac | _ -> dtac in match List.map mktac atacs with - | [] -> if is_or then dtac else Tacticals.tclIDTAC + | [] -> if is_or then dtac else Tacticals.New.tclIDTAC | [tac] -> tac - | tacs -> Tacticals.tclFIRST tacs + | tacs -> Tacticals.New.tclFIRST tacs + end let ssrdotac ist (((n, m), tac), clauses) = let mul = get_index n, m in tclCLAUSES (tclMULT mul (hinttac ist false tac)) clauses - -let tclCLAUSES tac g_c = - Proofview.V82.(tactic (tclCLAUSES (of_tactic tac) g_c)) diff --git a/plugins/ssr/ssrtacticals.mli b/plugins/ssr/ssrtacticals.mli index c5b0deb752..f907ac3801 100644 --- a/plugins/ssr/ssrtacticals.mli +++ b/plugins/ssr/ssrtacticals.mli @@ -20,7 +20,7 @@ val tclSEQAT : int Locus.or_var * (('a * Tacinterp.Value.t option list) * Tacinterp.Value.t option) -> - Tacmach.tactic + unit Proofview.tactic val tclCLAUSES : unit Proofview.tactic -> @@ -33,7 +33,7 @@ val tclCLAUSES : val hinttac : Tacinterp.interp_sign -> - bool -> bool * Tacinterp.Value.t option list -> Ssrast.v82tac + bool -> bool * Tacinterp.Value.t option list -> unit Proofview.tactic val ssrdotac : Tacinterp.interp_sign -> @@ -44,5 +44,5 @@ val ssrdotac : Ssrmatching.cpattern option) option) list * Ssrast.ssrclseq) -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic diff --git a/plugins/ssrmatching/plugin_base.dune b/plugins/ssrmatching/dune index 06f67c3774..629d723816 100644 --- a/plugins/ssrmatching/plugin_base.dune +++ b/plugins/ssrmatching/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.ssrmatching) (synopsis "Coq ssrmatching plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_ssrmatching)) diff --git a/plugins/ssrmatching/g_ssrmatching.mlg b/plugins/ssrmatching/g_ssrmatching.mlg index 33e523a4a4..2252435658 100644 --- a/plugins/ssrmatching/g_ssrmatching.mlg +++ b/plugins/ssrmatching/g_ssrmatching.mlg @@ -107,7 +107,7 @@ ARGUMENT EXTEND ssrpatternarg TYPED AS rpattern PRINTED BY { pr_rpattern } END TACTIC EXTEND ssrinstoftpat -| [ "ssrinstancesoftpat" cpattern(arg) ] -> { Proofview.V82.tactic (ssrinstancesof arg) } +| [ "ssrinstancesoftpat" cpattern(arg) ] -> { ssrinstancesof arg } END { diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 1c776398e7..adaf7c8cc1 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -14,7 +14,6 @@ open Ltac_plugin open Names open Pp open Genarg -open Stdarg open Term open Context module CoqConstr = Constr @@ -22,7 +21,6 @@ open CoqConstr open Vars open Libnames open Tactics -open Tacticals open Termops open Recordops open Tacmach @@ -173,8 +171,6 @@ let loc_ofCG = function let mk_term k c ist = k, (mkRHole, Some c), ist let mk_lterm = mk_term ' ' -let pf_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty - let nf_evar sigma c = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr c)) @@ -263,7 +259,7 @@ let nf_open_term sigma0 ise c = let rec nf c' = match kind c' with | Evar ex -> begin try nf (existential_value0 s ex) with _ -> - let k, a = ex in let a' = Array.map nf a in + let k, a = ex in let a' = List.map nf a in if not (Evd.mem !s' k) then s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k)); mkEvar (k, a') @@ -307,7 +303,7 @@ let pf_unify_HO gl t1 t2 = (* This is what the definition of iter_constr should be... *) let iter_constr_LR f c = match kind c with - | Evar (k, a) -> Array.iter f a + | Evar (k, a) -> List.iter f a | Cast (cc, _, t) -> f cc; f t | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b | LetIn (_, v, t, b) -> f v; f t; f b @@ -387,7 +383,7 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = with NotInstantiatedEvar -> if Evd.mem sigma0 k then map put c else let evi = Evd.find !sigma k in - let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in + let dc = List.firstn (max 0 (List.length a - nenv)) (evar_filtered_context evi) in let abs_dc (d, c) = function | Context.Named.Declaration.LocalDef (x, b, t) -> d, mkNamedLetIn x (put b) (put t) c @@ -601,7 +597,8 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = | KpatFixed | KpatConst -> ise | KpatEvar _ -> let _, pka = destEvar u.up_f and _, ka = destEvar f in - unif_HO_args env ise pka 0 ka + let fold ise pk k = unif_HO env ise (EConstr.of_constr pk) (EConstr.of_constr k) in + List.fold_left2 fold ise pka ka | KpatLet -> let x, v, t, b = destLetIn f in let _, pv, _, pb = destLetIn u.up_f in @@ -931,31 +928,15 @@ let id_of_Cterm t = match id_of_cpattern t with | Some x -> x | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here" -let of_ftactic ftac gl = - let r = ref None in - let tac = Ftactic.run ftac (fun ans -> r := Some ans; Proofview.tclUNIT ()) in - let tac = Proofview.V82.of_tactic tac in - let { sigma = sigma } = tac gl in - let ans = match !r with - | None -> assert false (* If the tactic failed we should not reach this point *) - | Some ans -> ans - in - (sigma, ans) - -let interp_wit wit ist gl x = - let globarg = in_gen (glbwit wit) x in - let arg = interp_genarg ist globarg in - let (sigma, arg) = of_ftactic arg gl in - sigma, Value.cast (topwit wit) arg -let interp_open_constr ist gl gc = - interp_wit wit_open_constr ist gl gc -let pf_intern_term gl (_, c, ist) = glob_constr ist (pf_env gl) (project gl) c +let interp_open_constr ist env sigma gc = + Tacinterp.interp_open_constr ist env sigma gc +let pf_intern_term env sigma (_, c, ist) = glob_constr ist env sigma c let interp_ssrterm ist gl t = Tacmach.project gl, interp_ssrterm ist t -let interp_term gl = function +let interp_term env sigma = function | (_, c, Some ist) -> - on_snd EConstr.Unsafe.to_constr (interp_open_constr ist gl c) + on_snd EConstr.Unsafe.to_constr (interp_open_constr ist env sigma c) | _ -> errorstrm (str"interpreting a term with no ist") let thin id sigma goal = @@ -981,7 +962,7 @@ let pr_ist { lfun= lfun } = pr_id id ++ str":" ++ Geninterp.Val.pr ty) (Id.Map.bindings lfun) *) -let interp_pattern ?wit_ssrpatternarg gl red redty = +let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = pp(lazy(str"interpreting: " ++ pr_pattern red)); let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in @@ -989,7 +970,7 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = let mkG ?(k=' ') x ist = k,(x,None), ist in let ist_of (_,_,ist) = ist in let decode (_,_,ist as t) ?reccall f g = - try match DAst.get (pf_intern_term gl t) with + try match DAst.get (pf_intern_term env sigma0 t) with | GCast(t,CastConv c) when isGHole t && isGLambda c-> let (x, c) = destGLambda c in f x (' ',(c,None),ist) @@ -1007,7 +988,7 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = let cleanup_XinE h x rp sigma = let h_k = match kind h with Evar (k,_) -> k | _ -> assert false in let to_clean, update = (* handle rename if x is already used *) - let ctx = pf_hyps gl in + let ctx = Environ.named_context env in let len = Context.Named.length ctx in let name = ref None in try ignore(Context.Named.lookup x ctx); (name, fun k -> @@ -1018,7 +999,6 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = name := Some (Context.Named.Declaration.get_id (List.nth nctx (nlen - len - 1))) end) with Not_found -> ref (Some x), fun _ -> () in - let sigma0 = project gl in let new_evars = let rec aux acc t = match kind t with | Evar (k,_) -> @@ -1071,13 +1051,13 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = match red with | T t -> T (combineCG t ty (mkCCast ?loc:(loc_ofCG t)) mkRCast) | X_In_T (x,t) -> - let gty = pf_intern_term gl ty in + let gty = pf_intern_term env sigma0 ty in E_As_X_In_T (mkG (mkRCast mkRHole gty) (ist_of ty), x, t) | E_In_X_In_T (e,x,t) -> - let ty = mkG (pf_intern_term gl ty) (ist_of ty) in + let ty = mkG (pf_intern_term env sigma0 ty) (ist_of ty) in E_In_X_In_T (combineCG e ty (mkCCast ?loc:(loc_ofCG t)) mkRCast, x, t) | E_As_X_In_T (e,x,t) -> - let ty = mkG (pf_intern_term gl ty) (ist_of ty) in + let ty = mkG (pf_intern_term env sigma0 ty) (ist_of ty) in E_As_X_In_T (combineCG e ty (mkCCast ?loc:(loc_ofCG t)) mkRCast, x, t) | red -> red in pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); @@ -1085,12 +1065,12 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = | Some b -> a,(g,Some (mkCLetIn ?loc x (mkCHole ~loc) b)), ist | None -> a,(DAst.make ?loc @@ GLetIn (x, DAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None), ist in match red with - | T t -> let sigma, t = interp_term gl t in sigma, T t - | In_T t -> let sigma, t = interp_term gl t in sigma, In_T t + | T t -> let sigma, t = interp_term env sigma0 t in sigma, T t + | In_T t -> let sigma, t = interp_term env sigma0 t in sigma, In_T t | X_In_T (x, rp) | In_X_In_T (x, rp) -> let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in let rp = mkXLetIn (Name x) rp in - let sigma, rp = interp_term gl rp in + let sigma, rp = interp_term env sigma0 rp in let _, h, _, rp = destLetIn rp in let sigma = cleanup_XinE h x rp sigma in let rp = subst1 h (nf_evar sigma rp) in @@ -1099,15 +1079,15 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = let mk e x p = match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in let rp = mkXLetIn (Name x) rp in - let sigma, rp = interp_term gl rp in + let sigma, rp = interp_term env sigma0 rp in let _, h, _, rp = destLetIn rp in let sigma = cleanup_XinE h x rp sigma in let rp = subst1 h (nf_evar sigma rp) in - let sigma, e = interp_term (re_sig (sig_it gl) sigma) e in + let sigma, e = interp_term env sigma e in sigma, mk e h rp ;; -let interp_cpattern gl red redty = interp_pattern gl (T red) redty;; -let interp_rpattern ~wit_ssrpatternarg gl red = interp_pattern ~wit_ssrpatternarg gl red None;; +let interp_cpattern env sigma red redty = interp_pattern env sigma (T red) redty;; +let interp_rpattern ~wit_ssrpatternarg env sigma red = interp_pattern ~wit_ssrpatternarg env sigma red None;; let id_of_pattern = function | _, T t -> (match kind t with Var id -> Some id | _ -> None) @@ -1244,23 +1224,23 @@ let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h = let rdx, _, (sigma, uc, p) = end_U () in sigma, uc, EConstr.of_constr p, EConstr.of_constr concl, EConstr.of_constr rdx -let fill_occ_term env cl occ sigma0 (sigma, t) = +let fill_occ_term env sigma0 cl occ (sigma, t) = try let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in if sigma' != sigma0 then CErrors.user_err Pp.(str "matching impacts evars") - else cl, (Evd.merge_universe_context sigma' uc, t') + else cl, t' with NoMatch -> try let sigma', uc, t' = unif_end env sigma0 (create_evar_defs sigma) t (fun _ -> true) in if sigma' != sigma0 then raise NoMatch - else cl, (Evd.merge_universe_context sigma' uc, t') + else cl, t' with _ -> errorstrm (str "partial term " ++ pr_econstr_pat env sigma t ++ str " does not match any subterm of the goal") let pf_fill_occ_term gl occ t = let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in - let cl,(_,t) = fill_occ_term env concl occ sigma0 t in + let cl, t = fill_occ_term env sigma0 concl occ t in cl, t let cpattern_of_id id = @@ -1285,18 +1265,23 @@ let wit_ssrpatternarg = wit_rpatternty let interp_rpattern = interp_rpattern ~wit_ssrpatternarg -let ssrpatterntac _ist arg gl = - let pat = interp_rpattern gl arg in - let sigma0 = project gl in - let concl0 = pf_concl gl in +let ssrpatterntac _ist arg = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let sigma0 = Proofview.Goal.sigma gl in + let concl0 = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let pat = interp_rpattern env sigma0 arg in let concl0 = EConstr.Unsafe.to_constr concl0 in let (t, uc), concl_x = - fill_occ_pattern (pf_env gl) sigma0 concl0 pat noindex 1 in + fill_occ_pattern env sigma0 concl0 pat noindex 1 in let t = EConstr.of_constr t in let concl_x = EConstr.of_constr concl_x in - let gl, tty = pf_type_of gl t in + let sigma, tty = Typing.type_of env sigma0 t in let concl = EConstr.mkLetIn (make_annot (Name (Id.of_string "selected")) Sorts.Relevant, t, tty, concl_x) in - Proofview.V82.of_tactic (convert_concl ~check:true concl DEFAULTcast) gl + Proofview.Unsafe.tclEVARS sigma <*> + convert_concl ~check:true concl DEFAULTcast + end (* Register "ssrpattern" tactic *) let () = @@ -1304,7 +1289,7 @@ let () = let arg = let v = Id.Map.find (Names.Id.of_string "pattern") ist.lfun in Value.cast (topwit wit_ssrpatternarg) v in - Proofview.V82.tactic (ssrpatterntac ist arg) in + ssrpatterntac ist arg in let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in let () = Tacenv.register_ml_tactic name [|mltac|] in let tac = @@ -1314,25 +1299,29 @@ let () = Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in Mltop.declare_cache_obj obj "ssrmatching_plugin" -let ssrinstancesof arg gl = +let ssrinstancesof arg = + Proofview.Goal.enter begin fun gl -> let ok rhs lhs ise = true in (* not (equal lhs (Evarutil.nf_evar ise rhs)) in *) - let env, sigma, concl = pf_env gl, project gl, pf_concl gl in - let concl = EConstr.Unsafe.to_constr concl in - let sigma0, cpat = interp_cpattern gl arg None in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let concl = EConstr.to_constr ~abort_on_undefined_evars:false sigma concl in + let sigma0, cpat = interp_cpattern env sigma arg None in let pat = match cpat with T x -> x | _ -> errorstrm (str"Not supported") in let etpat, tpat = mk_tpattern env sigma (sigma0,pat) (ok pat) L2R pat in let find, conclude = mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma None (etpat,[tpat]) in - let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr_env (pf_env gl) (gl.sigma) p ++ spc() - ++ str "matches:" ++ spc() ++ pr_constr_env (pf_env gl) (gl.sigma) c)); c in + let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr_env env (Proofview.Goal.sigma gl) p ++ spc() + ++ str "matches:" ++ spc() ++ pr_constr_env env (Proofview.Goal.sigma gl) c)); c in ppnl (str"BEGIN INSTANCES"); try while true do ignore(find env concl 1 ~k:print) done; raise NoMatch - with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl + with NoMatch -> ppnl (str"END INSTANCES"); Tacticals.New.tclIDTAC + end module Internal = struct diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 31b414cc42..17b47227cb 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -57,7 +57,7 @@ val redex_of_pattern : (** [interp_rpattern ise gl rpat] "internalizes" and "interprets" [rpat] in the current [Ltac] interpretation signature [ise] and tactic input [gl]*) val interp_rpattern : - goal sigma -> + Environ.env -> Evd.evar_map -> rpattern -> pattern @@ -65,7 +65,7 @@ val interp_rpattern : in the current [Ltac] interpretation signature [ise] and tactic input [gl]. [ty] is an optional type for the redex of [cpat] *) val interp_cpattern : - goal sigma -> + Environ.env -> Evd.evar_map -> cpattern -> (glob_constr_and_expr * Geninterp.interp_sign) option -> pattern @@ -191,6 +191,8 @@ val mk_tpattern_matcher : * by [Rel 1] and the instance of [t] *) val pf_fill_occ_term : goal sigma -> occ -> evar_map * EConstr.t -> EConstr.t * EConstr.t +val fill_occ_term : Environ.env -> Evd.evar_map -> EConstr.t -> occ -> evar_map * EConstr.t -> EConstr.t * EConstr.t + (* It may be handy to inject a simple term into the first form of cpattern *) val cpattern_of_term : char * glob_constr_and_expr -> Geninterp.interp_sign -> cpattern @@ -230,7 +232,7 @@ val pf_unsafe_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma (* One can also "Set SsrMatchingDebug" from a .v *) val debug : bool -> unit -val ssrinstancesof : cpattern -> Tacmach.tactic +val ssrinstancesof : cpattern -> unit Proofview.tactic (** Functions used for grammar extensions. Do not use. *) diff --git a/plugins/syntax/plugin_base.dune b/plugins/syntax/dune index 512752135d..b395695c8a 100644 --- a/plugins/syntax/plugin_base.dune +++ b/plugins/syntax/dune @@ -32,3 +32,5 @@ (synopsis "Coq syntax plugin: float") (modules float_syntax) (libraries coq.vernac)) + +(coq.pp (modules g_numeral g_string)) |