diff options
Diffstat (limited to 'plugins')
54 files changed, 582 insertions, 571 deletions
diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index ac2058ba1b..343fb0b1fe 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -112,13 +112,13 @@ module Bool = struct else if head === negb && Array.length args = 1 then Negb (aux args.(0)) else Var (Env.add env c) - | Case (info, r, _iv, arg, pats) -> + | Case (info, _, _, _, _, arg, pats) -> let is_bool = let i = info.ci_ind in Names.Ind.CanOrd.equal i (Lazy.force ind) in if is_bool then - Ifb ((aux arg), (aux pats.(0)), (aux pats.(1))) + Ifb ((aux arg), (aux (snd pats.(0))), (aux (snd pats.(1)))) else Var (Env.add env c) | _ -> diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 129b220680..6617f4726e 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -19,20 +19,12 @@ open Sorts open Constr open Context open Vars -open Goptions open Tacmach open Util let init_size=5 -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 debug_congruence = CDebug.create ~name:"congruence" () (* Signature table *) @@ -576,7 +568,7 @@ let add_inst state (inst,int_subst) = Control.check_for_interrupt (); if state.rew_depth > 0 then if is_redundant state inst.qe_hyp_id int_subst then - debug (fun () -> str "discarding redundant (dis)equality") + debug_congruence (fun () -> str "discarding redundant (dis)equality") else begin Identhash.add state.q_history inst.qe_hyp_id int_subst; @@ -591,7 +583,7 @@ let add_inst state (inst,int_subst) = state.rew_depth<-pred state.rew_depth; if inst.qe_pol then begin - debug (fun () -> + debug_congruence (fun () -> (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ pr_term state.env state.sigma s ++ str " == " ++ pr_term state.env state.sigma t ++ str "]")); @@ -599,7 +591,7 @@ let add_inst state (inst,int_subst) = end else begin - debug (fun () -> + debug_congruence (fun () -> (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ pr_term state.env state.sigma s ++ str " <> " ++ pr_term state.env state.sigma t ++ str "]")); @@ -630,7 +622,7 @@ let join_path uf i j= min_path (down_path uf i [],down_path uf j []) let union state i1 i2 eq= - debug (fun () -> str "Linking " ++ pr_idx_term state.env state.sigma state.uf i1 ++ + debug_congruence (fun () -> str "Linking " ++ pr_idx_term state.env state.sigma state.uf i1 ++ str " and " ++ pr_idx_term state.env state.sigma state.uf i2 ++ str "."); let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in @@ -670,7 +662,7 @@ let union state i1 i2 eq= | _,_ -> () let merge eq state = (* merge and no-merge *) - debug + debug_congruence (fun () -> str "Merging " ++ pr_idx_term state.env state.sigma state.uf eq.lhs ++ str " and " ++ pr_idx_term state.env state.sigma state.uf eq.rhs ++ str "."); let uf=state.uf in @@ -683,7 +675,7 @@ let merge eq state = (* merge and no-merge *) union state j i (swap eq) let update t state = (* update 1 and 2 *) - debug + debug_congruence (fun () -> str "Updating term " ++ pr_idx_term state.env state.sigma state.uf t ++ str "."); let (i,j) as sign = signature state.uf t in let (u,v) = subterms state.uf t in @@ -745,7 +737,7 @@ let process_constructor_mark t i rep pac state = end let process_mark t m state = - debug + debug_congruence (fun () -> str "Processing mark for term " ++ pr_idx_term state.env state.sigma state.uf t ++ str "."); let i=find state.uf t in let rep=get_representative state.uf i in @@ -766,7 +758,7 @@ let check_disequalities state = if Int.equal (find uf dis.lhs) (find uf dis.rhs) then (str "Yes", Some dis) else (str "No", check_aux q) in - let _ = debug + let _ = debug_congruence (fun () -> str "Checking if " ++ pr_idx_term state.env state.sigma state.uf dis.lhs ++ str " = " ++ pr_idx_term state.env state.sigma state.uf dis.rhs ++ str " ... " ++ info) in ans @@ -953,7 +945,7 @@ let find_instances state = let pb_stack= init_pb_stack state in let res =ref [] in let _ = - debug (fun () -> str "Running E-matching algorithm ... "); + debug_congruence (fun () -> str "Running E-matching algorithm ... "); try while true do Control.check_for_interrupt (); @@ -964,7 +956,7 @@ let find_instances state = !res let rec execute first_run state = - debug (fun () -> str "Executing ... "); + debug_congruence (fun () -> str "Executing ... "); try while Control.check_for_interrupt (); @@ -974,7 +966,7 @@ let rec execute first_run state = None -> if not(Int.Set.is_empty state.pa_classes) then begin - debug (fun () -> str "First run was incomplete, completing ... "); + debug_congruence (fun () -> str "First run was incomplete, completing ... "); complete state; execute false state end @@ -989,12 +981,12 @@ let rec execute first_run state = end else begin - debug (fun () -> str "Out of instances ... "); + debug_congruence (fun () -> str "Out of instances ... "); None end else begin - debug (fun () -> str "Out of depth ... "); + debug_congruence (fun () -> str "Out of depth ... "); None end | Some dis -> Some diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 3270f74479..047756deef 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -121,7 +121,7 @@ val term_equal : term -> term -> bool val constr_of_term : term -> constr -val debug : (unit -> Pp.t) -> unit +val debug_congruence : CDebug.t val forest : state -> forest diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 53d8c5bdd9..e7e0822916 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -95,13 +95,13 @@ let pinject p c n a = p_rule=Inject(p,c,n,a)} let rec equal_proof env sigma uf i j= - debug (fun () -> str "equal_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "equal_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in ptrans (path_proof env sigma uf i li) (psym (path_proof env sigma uf j lj)) and edge_proof env sigma uf ((i,j),eq)= - debug (fun () -> str "edge_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "edge_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let pi=equal_proof env sigma uf i eq.lhs in let pj=psym (equal_proof env sigma uf j eq.rhs) in let pij= @@ -117,7 +117,7 @@ and edge_proof env sigma uf ((i,j),eq)= ptrans (ptrans pi pij) pj and constr_proof env sigma uf i ipac= - debug (fun () -> str "constr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20)); + debug_congruence (fun () -> str "constr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20)); let t=find_oldest_pac uf i ipac in let eq_it=equal_proof env sigma uf i t in if ipac.args=[] then @@ -130,20 +130,20 @@ and constr_proof env sigma uf i ipac= ptrans eq_it (pcongr p (prefl targ)) and path_proof env sigma uf i l= - debug (fun () -> str "path_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ str "{" ++ + debug_congruence (fun () -> str "path_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ str "{" ++ (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}"); match l with | [] -> prefl (term uf i) | x::q->ptrans (path_proof env sigma uf (snd (fst x)) q) (edge_proof env sigma uf x) and congr_proof env sigma uf i j= - debug (fun () -> str "congr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "congr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let (i1,i2) = subterms uf i and (j1,j2) = subterms uf j in pcongr (equal_proof env sigma uf i1 j1) (equal_proof env sigma uf i2 j2) and ind_proof env sigma uf i ipac j jpac= - debug (fun () -> str "ind_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "ind_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let p=equal_proof env sigma uf i j and p1=constr_proof env sigma uf i ipac and p2=constr_proof env sigma uf j jpac in diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 499c9684b2..341fde7b77 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -420,16 +420,16 @@ let cc_tactic depth additionnal_terms = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in Coqlib.(check_required_library logic_module_name); - let _ = debug (fun () -> Pp.str "Reading subgoal ...") in + let _ = debug_congruence (fun () -> Pp.str "Reading goal ...") in let state = make_prb gl depth additionnal_terms in - let _ = debug (fun () -> Pp.str "Problem built, solving ...") in + let _ = debug_congruence (fun () -> Pp.str "Problem built, solving ...") in let sol = execute true state in - let _ = debug (fun () -> Pp.str "Computation completed.") in + let _ = debug_congruence (fun () -> Pp.str "Computation completed.") in let uf=forest state in match sol with None -> Tacticals.New.tclFAIL 0 (str "congruence failed") | Some reason -> - debug (fun () -> Pp.str "Goal solved, generating proof ..."); + debug_congruence (fun () -> Pp.str "Goal solved, generating proof ..."); match reason with Discrimination (i,ipac,j,jpac) -> let p=build_proof (Tacmach.New.pf_env gl) sigma uf (`Discr (i,ipac,j,jpac)) in diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 6869f9c47e..0cad192332 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -672,9 +672,11 @@ let rec extract_term env sg mle mlt c args = (* we unify it with an fresh copy of the stored type of [Rel n]. *) let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n) in extract_app env sg mle mlt extract_rel args - | Case ({ci_ind=ip},_,iv,c0,br) -> - (* If invert_case then this is a match that will get erased later, but right now we don't care. *) - extract_app env sg mle mlt (extract_case env sg mle (ip,c0,br)) args + | Case (ci, u, pms, r, iv, c0, br) -> + (* If invert_case then this is a match that will get erased later, but right now we don't care. *) + let (ip, r, iv, c0, br) = EConstr.expand_case env sg (ci, u, pms, r, iv, c0, br) in + let ip = ci.ci_ind in + extract_app env sg mle mlt (extract_case env sg mle (ip,c0,br)) args | Fix ((_,i),recd) -> extract_app env sg mle mlt (extract_fix env sg mle i recd) args | CoFix (i,recd) -> @@ -1078,9 +1080,13 @@ let fake_match_projection env p = let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:arg lab in fold (arg+1) (j+1) (mkProj (Projection.make kn false, mkRel 1)::subst) rem else - let p = mkLambda (x, lift 1 indty, liftn 1 2 ty) in - let branch = lift 1 (it_mkLambda_or_LetIn (mkRel (List.length ctx - (j-1))) ctx) in - let body = mkCase (ci, p, NoInvert, mkRel 1, [|branch|]) in + let p = ([|x|], liftn 1 2 ty) in + let branch = + let nas = Array.of_list (List.rev_map Context.Rel.Declaration.get_annot ctx) in + (nas, mkRel (List.length ctx - (j - 1))) + in + let params = Context.Rel.to_extended_vect mkRel 1 paramslet in + let body = mkCase (ci, u, params, p, NoInvert, mkRel 1, [|branch|]) in it_mkLambda_or_LetIn (mkLambda (x,indty,body)) mib.mind_params_ctxt | LocalDef (_,c,t) :: rem -> let c = liftn 1 j c in diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index c62bc73e41..e208ba9a5c 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -67,10 +67,13 @@ let unif env evd t1 t2= | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast evd nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> Queue.add (a,c) bige;Queue.add (pop b,pop d) bige - | Case (_,pa,_,ca,va),Case (_,pb,_,cb,vb)-> - Queue.add (pa,pb) bige; - Queue.add (ca,cb) bige; - let l=Array.length va in + | Case (cia,ua,pmsa,pa,iva,ca,va),Case (cib,ub,pmsb,pb,ivb,cb,vb)-> + let env = Global.env () in + let (cia,pa,iva,ca,va) = EConstr.expand_case env evd (cia,ua,pmsa,pa,iva,ca,va) in + let (cib,pb,iva,cb,vb) = EConstr.expand_case env evd (cib,ub,pmsb,pb,ivb,cb,vb) in + Queue.add (pa,pb) bige; + Queue.add (ca,cb) bige; + let l=Array.length va in if not (Int.equal l (Array.length vb)) then raise (UFAIL (nt1,nt2)) else diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 73eb943418..3234d40f73 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -598,12 +598,12 @@ let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos let sigma = Proofview.Goal.sigma 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, iv, t, cb) -> + | Case (ci, u, pms, ct, iv, t, cb) -> let do_finalize_t dyn_info' = Proofview.Goal.enter (fun g -> let t = dyn_info'.info in let dyn_infos = - {dyn_info' with info = mkCase (ci, ct, iv, t, cb)} + {dyn_info' with info = mkCase (ci, u, pms, ct, iv, t, cb)} in let g_nb_prod = nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.concl g) @@ -1260,7 +1260,7 @@ let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num tclTHENLIST [ unfold_in_concl [ ( Locus.AllOccurrences - , Names.EvalConstRef (fst fname) ) ] + , Tacred.EvalConstRef (fst fname) ) ] ; (let do_prove = build_proof interactive_proof (Array.to_list fnames) diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index ca6ae150a7..15cf88f827 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -195,16 +195,29 @@ let is_interactive recsl = } +(* For usability we temporarily switch off some flags during the call + to Function. However this is not satisfactory: + + 1- Function should not warn "non-recursive" and call the Definition + mechanism instead of Fixpoint when needed + + 2- Only for automatically generated names should + unused-pattern-matching-variable be ignored. *) + VERNAC COMMAND EXTEND Function STATE CUSTOM | ["Function" ne_function_fix_definition_list_sep(recsl,"with")] => { classify_funind recsl } -> { - if is_interactive recsl then - Vernacextend.VtOpenProof (fun () -> - Gen_principle.do_generate_principle_interactive (List.map snd recsl)) - else - Vernacextend.VtDefault (fun () -> - Gen_principle.do_generate_principle (List.map snd recsl)) } + let warn = "-unused-pattern-matching-variable,-matching-variable,-non-recursive" in + if is_interactive recsl then + Vernacextend.VtOpenProof (fun () -> + CWarnings.with_warn warn + Gen_principle.do_generate_principle_interactive (List.map snd recsl)) + else + Vernacextend.VtDefault (fun () -> + CWarnings.with_warn warn + Gen_principle.do_generate_principle (List.map snd recsl)) + } END { diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 314c8abcaf..cbdebb7bbc 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -917,13 +917,13 @@ and intros_with_rewrite_aux () : unit Proofview.tactic = tclTHENLIST [ unfold_in_concl [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(1)) ) ] + , Tacred.EvalVarRef (destVar sigma args.(1)) ) ] ; tclMAP (fun id -> tclTRY (unfold_in_hyp [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(1)) ) ] + , Tacred.EvalVarRef (destVar sigma args.(1)) ) ] (destVar sigma args.(1), Locus.InHyp))) (pf_ids_of_hyps g) ; intros_with_rewrite () ] @@ -936,13 +936,13 @@ and intros_with_rewrite_aux () : unit Proofview.tactic = tclTHENLIST [ unfold_in_concl [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(2)) ) ] + , Tacred.EvalVarRef (destVar sigma args.(2)) ) ] ; tclMAP (fun id -> tclTRY (unfold_in_hyp [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(2)) ) ] + , Tacred.EvalVarRef (destVar sigma args.(2)) ) ] (destVar sigma args.(2), Locus.InHyp))) (pf_ids_of_hyps g) ; intros_with_rewrite () ] @@ -972,7 +972,7 @@ and intros_with_rewrite_aux () : unit Proofview.tactic = ( UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type" )) -> tauto - | Case (_, _, _, v, _) -> + | Case (_, _, _, _, _, v, _) -> tclTHENLIST [simplest_case v; intros_with_rewrite ()] | LetIn _ -> tclTHENLIST @@ -1005,7 +1005,7 @@ let rec reflexivity_with_destruct_cases () = (snd (destApp (Proofview.Goal.sigma g) (Proofview.Goal.concl g))).( 2) with - | Case (_, _, _, v, _) -> + | Case (_, _, _, _, _, v, _) -> tclTHENLIST [ simplest_case v ; intros @@ -1158,7 +1158,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : else unfold_in_concl [ ( Locus.AllOccurrences - , Names.EvalConstRef + , Tacred.EvalConstRef (fst (destConst (Proofview.Goal.sigma g) f)) ) ] in (* The proof of each branche itself *) diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 6464556e4e..266345a324 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -418,6 +418,7 @@ let make_eq () = with _ -> assert false let evaluable_of_global_reference r = + let open Tacred in (* Tacred.evaluable_of_global_reference (Global.env ()) *) match r with | GlobRef.ConstRef sp -> EvalConstRef sp diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 7b7044fdaf..e25f413fe4 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -100,7 +100,7 @@ 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 + GlobRef.t -> Tacred.evaluable_global_reference val list_rewrite : bool -> (EConstr.constr * bool) list -> unit Proofview.tactic diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 9d896e9182..9e9444951f 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -301,10 +301,11 @@ let check_not_nested env sigma forbidden e = | Const _ -> () | Ind _ -> () | Construct _ -> () - | Case (_, t, _, e, a) -> + | Case (_, _, pms, (_, t), _, e, a) -> + Array.iter check_not_nested pms; check_not_nested t; check_not_nested e; - Array.iter check_not_nested a + Array.iter (fun (_, c) -> check_not_nested c) a | Fix _ -> user_err Pp.(str "check_not_nested : Fix") | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") in @@ -367,7 +368,7 @@ type journey_info = -> unit Proofview.tactic) -> ( case_info * constr - * (constr, EInstance.t) case_invert + * case_invert * constr * constr array , constr ) @@ -472,7 +473,8 @@ let rec travel_aux jinfo continuation_tac (expr_info : constr infos) = ++ 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, iv, a, l) -> + | Case (ci, u, pms, t, iv, a, l) -> + let (ci, t, iv, a, l) = EConstr.expand_case env sigma (ci, u, pms, t, iv, a, l) in let continuation_tac_a = jinfo.casE (travel jinfo) (ci, t, iv, a, l) expr_info continuation_tac in @@ -776,7 +778,7 @@ let terminate_case next_step (ci, a, iv, t, l) expr_info continuation_tac infos let a' = infos.info in let new_info = { infos with - info = mkCase (ci, a, iv, a', l) + info = mkCase (EConstr.contract_case env sigma (ci, a, iv, a', l)) ; is_main_branch = expr_info.is_main_branch ; is_final = expr_info.is_final } in diff --git a/plugins/ltac/coretactics.mlg b/plugins/ltac/coretactics.mlg index e39c066c95..b20c4d173d 100644 --- a/plugins/ltac/coretactics.mlg +++ b/plugins/ltac/coretactics.mlg @@ -259,13 +259,6 @@ TACTIC EXTEND simple_destruct | [ "simple" "destruct" quantified_hypothesis(h) ] -> { simple_destruct h } END -(** Double induction *) - -TACTIC EXTEND double_induction DEPRECATED { Deprecation.make () } -| [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> - { Elim.h_double_induction h1 h2 } -END - (* Admit *) TACTIC EXTEND admit diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 4a2c298caa..d9da47134d 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -299,7 +299,7 @@ TACTIC EXTEND rewrite_star { -let add_rewrite_hint ~poly bases ort t lcsr = +let add_rewrite_hint ~locality ~poly bases ort t lcsr = let env = Global.env() in let sigma = Evd.from_env env in let f ce = @@ -315,7 +315,7 @@ let add_rewrite_hint ~poly bases ort t lcsr = in CAst.make ?loc:(Constrexpr_ops.constr_loc ce) ((c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t) in let eqs = List.map f lcsr in - let add_hints base = add_rew_rules base eqs in + let add_hints base = add_rew_rules ~locality base eqs in List.iter add_hints bases let classify_hint _ = VtSideff ([], VtLater) @@ -323,15 +323,15 @@ let classify_hint _ = VtSideff ([], VtLater) } VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY { classify_hint } -| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> - { add_rewrite_hint ~poly:polymorphic bl o None l } -| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) +| #[ polymorphic; locality = option_locality; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> + { add_rewrite_hint ~locality ~poly:polymorphic bl o None l } +| #[ polymorphic; locality = option_locality; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ":" preident_list(bl) ] -> - { add_rewrite_hint ~poly:polymorphic bl o (Some t) l } -| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> - { add_rewrite_hint ~poly:polymorphic ["core"] o None l } -| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> - { add_rewrite_hint ~poly:polymorphic ["core"] o (Some t) l } + { add_rewrite_hint ~locality ~poly:polymorphic bl o (Some t) l } +| #[ polymorphic; locality = option_locality; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> + { add_rewrite_hint ~locality ~poly:polymorphic ["core"] o None l } +| #[ polymorphic; locality = option_locality; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> + { add_rewrite_hint ~locality ~poly:polymorphic ["core"] o (Some t) l } END (**********************************************************************) @@ -774,7 +774,7 @@ let rec find_a_destructable_match sigma t = let cl = [cl, (None, None), None], None in let dest = TacAtom (CAst.make @@ TacInductionDestruct(false, false, cl)) in match EConstr.kind sigma t with - | Case (_,_,_,x,_) when closed0 sigma x -> + | Case (_,_,_,_,_,x,_) when closed0 sigma x -> if isVar sigma x then (* TODO check there is no rel n. *) raise (Found (Tacinterp.eval_tactic dest)) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 069a342b2a..82b41e41bd 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -11,7 +11,6 @@ { open Pp -open Constr open Stdarg open Pcoq.Prim open Pcoq.Constr @@ -199,20 +198,6 @@ TACTIC EXTEND unify END { -let deprecated_convert_concl_no_check = - CWarnings.create - ~name:"convert_concl_no_check" ~category:"deprecated" - (fun () -> Pp.str "The syntax [convert_concl_no_check] is deprecated. Use [change_no_check] instead.") -} - -TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> { - deprecated_convert_concl_no_check (); - Tactics.convert_concl ~check:false x DEFAULTcast - } -END - -{ let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_qualid let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index b1b96ea9a7..3da5b2bfc4 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -147,7 +147,7 @@ GRAMMAR EXTEND Gram | IDENT "solve" ; "["; l = LIST0 ltac_expr SEP "|"; "]" -> { TacSolve l } | IDENT "idtac"; l = LIST0 message_token -> { TacId l } - | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; + | g=failkw; n = [ n = nat_or_var -> { n } | -> { fail_default_value } ]; l = LIST0 message_token -> { TacFail (g,n,l) } | st = simple_tactic -> { st } | a = tactic_value -> { TacArg(CAst.make ~loc a) } diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index 6bf330c830..e7902d06eb 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -151,13 +151,13 @@ VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY END VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY STATE read_program -| [ "Obligations" "of" ident(name) ] -> { show_obligations (Some name) } -| [ "Obligations" ] -> { show_obligations None } +| [ "Obligations" "of" ident(name) ] -> { fun ~stack:_ -> show_obligations (Some name) } +| [ "Obligations" ] -> { fun ~stack:_ -> show_obligations None } END VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY STATE read_program -| [ "Preterm" "of" ident(name) ] -> { fun ~pm -> Feedback.msg_notice (show_term ~pm (Some name)) } -| [ "Preterm" ] -> { fun ~pm -> Feedback.msg_notice (show_term ~pm None) } +| [ "Preterm" "of" ident(name) ] -> { fun ~stack:_ ~pm -> Feedback.msg_notice (show_term ~pm (Some name)) } +| [ "Preterm" ] -> { fun ~stack:_ ~pm -> Feedback.msg_notice (show_term ~pm None) } END { diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 43957bbde5..cb430efb40 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -182,6 +182,11 @@ let merge_occurrences loc cl = function in (Some p, ans) +let deprecated_conversion_at_with = + CWarnings.create + ~name:"conversion_at_with" ~category:"deprecated" + (fun () -> Pp.str "The syntax [at ... with ...] is deprecated. Use [with ... at ...] instead.") + (* Auxiliary grammar rules *) open Pvernac.Vernac_ @@ -230,7 +235,8 @@ GRAMMAR EXTEND Gram [ [ c = constr -> { (None, c) } | c1 = constr; "with"; c2 = constr -> { (Some (AllOccurrences,c1),c2) } | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr -> - { (Some (occs,c1), c2) } ] ] + { deprecated_conversion_at_with (); (* 8.14 *) + (Some (occs,c1), c2) } ] ] ; occs_nums: [ [ nl = LIST1 nat_or_var -> { OnlyOccurrences nl } diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index faad792ea9..6ebb01703f 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -191,8 +191,8 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_and_short_name pr (c,_) = pr c let pr_evaluable_reference = function - | EvalVarRef id -> pr_id id - | EvalConstRef sp -> pr_global (GlobRef.ConstRef sp) + | Tacred.EvalVarRef id -> pr_id id + | Tacred.EvalConstRef sp -> pr_global (GlobRef.ConstRef sp) let pr_quantified_hypothesis = function | AnonHyp n -> int n @@ -381,8 +381,8 @@ let string_of_genarg_arg (ArgumentType arg) = str "<" ++ KerName.print kn ++ str ">" let pr_evaluable_reference_env env = function - | EvalVarRef id -> pr_id id - | EvalConstRef sp -> + | Tacred.EvalVarRef id -> pr_id id + | Tacred.EvalConstRef sp -> Nametab.pr_global_env (Termops.vars_of_env env) (GlobRef.ConstRef sp) let pr_as_disjunctive_ipat prc ipatl = diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 79e0adf9f7..4f58eceb59 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -106,7 +106,7 @@ val pr_may_eval : val pr_and_short_name : ('a -> Pp.t) -> 'a Genredexpr.and_short_name -> Pp.t -val pr_evaluable_reference_env : env -> evaluable_global_reference -> Pp.t +val pr_evaluable_reference_env : env -> Tacred.evaluable_global_reference -> Pp.t val pr_quantified_hypothesis : quantified_hypothesis -> Pp.t diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index aa2449d962..937d579012 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -436,11 +436,7 @@ let finish_timing ~prefix name = (* ******************** *) let print_results_filter ~cutoff ~filter = - (* The STM doesn't provide yet a proper document query and traversal - API, thus we need to re-check if some states are current anymore - (due to backtracking) using the `state_of_id` API. *) - let valid (did,id) _ = Stm.(state_of_id ~doc:(get_doc did) id) <> `Expired in - data := SM.filter valid !data; + data := SM.filter (fun (doc,id) _ -> Stateid.is_valid ~doc id) !data; let results = SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in let results = merge_roots results Local.(CList.last !stack) in diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 59533eb3e3..6d0e0c36b3 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -918,7 +918,8 @@ let reset_env env = Environ.push_rel_context (Environ.rel_context env) env' let fold_match ?(force=false) env sigma c = - let (ci, p, iv, c, brs) = destCase sigma c in + let case = destCase sigma c in + let (ci, p, iv, c, brs) = EConstr.expand_case env sigma case in let cty = Retyping.get_type_of env sigma c in let dep, pred, exists, sk = let env', ctx, body = @@ -986,7 +987,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let argty = Retyping.get_type_of env (goalevars evars) arg in let state, res = s.strategy { state ; env ; unfresh ; - term1 = arg ; ty1 = argty ; + term1 = arg ; ty1 = argty ; cstr = (prop,None) ; evars } in let res' = @@ -1153,7 +1154,8 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Fail | Identity -> b' in state, res - | Case (ci, p, iv, c, brs) -> + | Case (ci, u, pms, p, iv, c, brs) -> + let (ci, p, iv, c, brs) = EConstr.expand_case env (goalevars evars) (ci, u, pms, p, iv, c, brs) in let cty = Retyping.get_type_of env (goalevars evars) c in let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in let cstr' = Some eqty in @@ -1163,7 +1165,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let state, res = match c' with | Success r -> - let case = mkCase (ci, lift 1 p, map_invert (lift 1) iv, mkRel 1, Array.map (lift 1) brs) in + let case = mkCase (EConstr.contract_case env (goalevars evars) (ci, lift 1 p, map_invert (lift 1) iv, mkRel 1, Array.map (lift 1) brs)) in let res = make_leibniz_proof env case ty r in state, Success (coerce env (prop,cstr) res) | Fail | Identity -> @@ -1185,7 +1187,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = in match found with | Some r -> - let ctxc = mkCase (ci, lift 1 p, map_invert (lift 1) iv, lift 1 c, Array.of_list (List.rev (brs' c'))) in + let ctxc = mkCase (EConstr.contract_case env (goalevars evars) (ci, lift 1 p, map_invert (lift 1) iv, lift 1 c, Array.of_list (List.rev (brs' c')))) in state, Success (make_leibniz_proof env ctxc ty r) | None -> state, c' else @@ -1386,7 +1388,7 @@ module Strategies = let fold_glob c : 'a pure_strategy = { strategy = fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> -(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) +(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in let unfolded = try Tacred.try_red_product env sigma c diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 9abdc2ddbe..5e88bf7c79 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -276,6 +276,7 @@ let coerce_to_closed_constr env v = c let coerce_to_evaluable_ref env sigma v = + let open Tacred in let fail () = raise (CannotCoerceTo "an evaluable reference") in let ev = match is_intro_pattern v with diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index b8592c5c76..8ca2510459 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -69,7 +69,7 @@ val coerce_to_uconstr : Value.t -> Ltac_pretype.closed_glob_constr val coerce_to_closed_constr : Environ.env -> Value.t -> constr val coerce_to_evaluable_ref : - Environ.env -> Evd.evar_map -> Value.t -> evaluable_global_reference + Environ.env -> Evd.evar_map -> Value.t -> Tacred.evaluable_global_reference val coerce_to_constr_list : Environ.env -> Value.t -> constr list diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 7b2c8e1d04..a880a3305e 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -270,7 +270,7 @@ constraint 'a = < type g_trm = Genintern.glob_constr_and_expr type g_pat = Genintern.glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference Genredexpr.and_short_name or_var +type g_cst = Tacred.evaluable_global_reference Genredexpr.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -324,7 +324,7 @@ type raw_tactic_arg = type t_trm = EConstr.constr type t_pat = constr_pattern -type t_cst = evaluable_global_reference +type t_cst = Tacred.evaluable_global_reference type t_ref = ltac_constant located type t_nam = Id.t diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 2382dcfbb9..3bb20b9d19 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -269,7 +269,7 @@ constraint 'a = < type g_trm = Genintern.glob_constr_and_expr type g_pat = Genintern.glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference Genredexpr.and_short_name or_var +type g_cst = Tacred.evaluable_global_reference Genredexpr.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -323,7 +323,7 @@ type raw_tactic_arg = type t_trm = EConstr.constr type t_pat = constr_pattern -type t_cst = evaluable_global_reference +type t_cst = Tacred.evaluable_global_reference type t_ref = ltac_constant located type t_nam = Id.t diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 8bee7afa2c..ae7a10ce52 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -308,8 +308,8 @@ let short_name qid = else None let evalref_of_globref ?loc ?short = function - | GlobRef.ConstRef cst -> ArgArg (EvalConstRef cst, short) - | GlobRef.VarRef id -> ArgArg (EvalVarRef id, short) + | GlobRef.ConstRef cst -> ArgArg (Tacred.EvalConstRef cst, short) + | GlobRef.VarRef id -> ArgArg (Tacred.EvalVarRef id, short) | r -> let tpe = match r with | GlobRef.IndRef _ -> "inductive" diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 90546ea939..6148f0d23f 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -89,7 +89,7 @@ let subst_global_reference subst = Locusops.or_var_map (subst_located (subst_global_reference subst)) let subst_evaluable subst = - let subst_eval_ref = subst_evaluable_reference subst in + let subst_eval_ref = Tacred.subst_evaluable_reference subst in Locusops.or_var_map (subst_and_short_name subst_eval_ref) let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index a7b571d3db..7d959aa788 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -189,6 +189,7 @@ let flatten_contravariant_disj _ ist = | _ -> fail let evalglobref_of_globref = + let open Tacred in function | GlobRef.VarRef v -> EvalVarRef v | GlobRef.ConstRef c -> EvalConstRef c diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 74d5374193..53aa619d10 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -28,7 +28,7 @@ open Q.Notations open Mutils let use_simplex = - Goptions.declare_bool_option_and_ref ~depr:false ~key:["Simplex"] ~value:true + Goptions.declare_bool_option_and_ref ~depr:true ~key:["Simplex"] ~value:true (* If set to some [file], arithmetic goals are dumped in [file].v *) @@ -223,6 +223,28 @@ let find_point l = let optimise v l = if use_simplex () then Simplex.optimise v l else Mfourier.Fourier.optimise v l +let output_cstr_sys o sys = + List.iter + (fun (c, wp) -> + Printf.fprintf o "%a by %a\n" output_cstr c ProofFormat.output_prf_rule wp) + sys + +let output_sys o sys = + List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys + +let tr_sys str f sys = + let sys' = f sys in + if debug then + Printf.fprintf stdout "[%s\n%a=>\n%a]\n" str output_sys sys output_sys sys'; + sys' + +let tr_cstr_sys str f sys = + let sys' = f sys in + if debug then + Printf.fprintf stdout "[%s\n%a=>\n%a]\n" str output_cstr_sys sys + output_cstr_sys sys'; + sys' + let dual_raw_certificate l = if debug then begin Printf.printf "dual_raw_certificate\n"; @@ -375,25 +397,7 @@ let elim_simple_linear_equality sys0 = in iterate_until_stable elim sys0 -let output_sys o sys = - List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys - -let subst sys = - let sys' = WithProof.subst sys in - if debug then - Printf.fprintf stdout "[subst:\n%a\n==>\n%a\n]" output_sys sys output_sys - sys'; - sys' - -let tr_sys str f sys = - let sys' = f sys in - if debug then ( - Printf.fprintf stdout "[%s\n" str; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; - Printf.fprintf stdout "\n => \n"; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys'; - Printf.fprintf stdout "]\n" ); - sys' +let subst sys = tr_sys "subst" WithProof.subst sys (** [saturate_linear_equality sys] generate new constraints obtained by eliminating linear equalities by pivoting. @@ -489,12 +493,10 @@ let nlinear_preprocess (sys : WithProof.t list) = ISet.fold (fun i acc -> square_of_var i :: acc) collect_vars sys in let sys = sys @ all_pairs WithProof.product sys in - if debug then begin - Printf.fprintf stdout "Preprocessed\n"; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys - end; List.map (WithProof.annot "P") sys +let nlinear_preprocess = tr_sys "nlinear_preprocess" nlinear_preprocess + let nlinear_prover prfdepth sys = let sys = develop_constraints prfdepth q_spec sys in let sys1 = elim_simple_linear_equality sys in @@ -698,6 +700,15 @@ let pivot v (c1, p1) (c2, p2) = Some (xpivot cv1 cv2) else None +let pivot v c1 c2 = + let res = pivot v c1 c2 in + ( match res with + | None -> () + | Some (c, _) -> + if Vect.get v c.coeffs =/ Q.zero then () + else Printf.printf "pivot error %a\n" output_cstr c ); + res + (* op2 could be Eq ... this might happen *) let simpl_sys sys = @@ -762,6 +773,8 @@ let reduce_coprime psys = in Some (pivot_sys v (cstr, prf) ((c1, p1) :: sys)) +(*let pivot_sys v pc sys = tr_cstr_sys "pivot_sys" (pivot_sys v pc) sys*) + (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) let reduce_unary psys = let is_unary_equation (cstr, prf) = @@ -820,6 +833,8 @@ let reduction_equations psys = [reduce_unary; reduce_coprime; reduce_var_change (*; reduce_pivot*)]) psys +let reduction_equations = tr_cstr_sys "reduction_equations" reduction_equations + (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) let get_bound sys = let is_small (v, i) = @@ -891,11 +906,6 @@ let check_sys sys = open ProofFormat -let output_cstr_sys sys = - (pp_list ";" (fun o (c, wp) -> - Printf.fprintf o "%a by %a" output_cstr c ProofFormat.output_prf_rule wp)) - sys - let xlia (can_enum : bool) reduction_equations sys = let rec enum_proof (id : int) (sys : prf_sys) = if debug then ( @@ -1170,7 +1180,9 @@ let nlia enum prfdepth sys = No: if a wrong equation is chosen, the proof may fail. It would only be safe if the variable is linear... *) - let sys1 = elim_simple_linear_equality sys in + let sys1 = + elim_simple_linear_equality (WithProof.subst_constant true sys) + in let sys2 = saturate_by_linear_equalities sys1 in let sys3 = nlinear_preprocess (sys1 @ sys2) in let sys4 = make_cstr_system (*sys2@*) sys3 in diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index e119ceb241..91f7e27911 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -38,14 +38,14 @@ let max_depth = max_int (* Search limit for provers over Q R *) let lra_proof_depth = - declare_int_option_and_ref ~depr:false ~key:["Lra"; "Depth"] ~value:max_depth + declare_int_option_and_ref ~depr:true ~key:["Lra"; "Depth"] ~value:max_depth (* Search limit for provers over Z *) let lia_enum = - declare_bool_option_and_ref ~depr:false ~key:["Lia"; "Enum"] ~value:true + declare_bool_option_and_ref ~depr:true ~key:["Lia"; "Enum"] ~value:true let lia_proof_depth = - declare_int_option_and_ref ~depr:false ~key:["Lia"; "Depth"] ~value:max_depth + declare_int_option_and_ref ~depr:true ~key:["Lia"; "Depth"] ~value:max_depth let get_lia_option () = (Certificate.use_simplex (), lia_enum (), lia_proof_depth ()) @@ -930,7 +930,8 @@ let is_prop env sigma term = Sorts.is_prop sort type formula_op = - { op_and : EConstr.t + { op_impl : EConstr.t option (* only for booleans *) + ; op_and : EConstr.t ; op_or : EConstr.t ; op_iff : EConstr.t ; op_not : EConstr.t @@ -939,7 +940,8 @@ type formula_op = let prop_op = lazy - { op_and = Lazy.force coq_and + { op_impl = None (* implication is Prod *) + ; op_and = Lazy.force coq_and ; op_or = Lazy.force coq_or ; op_iff = Lazy.force coq_iff ; op_not = Lazy.force coq_not @@ -948,13 +950,17 @@ let prop_op = let bool_op = lazy - { op_and = Lazy.force coq_andb + { op_impl = Some (Lazy.force coq_implb) + ; op_and = Lazy.force coq_andb ; op_or = Lazy.force coq_orb ; op_iff = Lazy.force coq_eqb ; op_not = Lazy.force coq_negb ; op_tt = Lazy.force coq_true ; op_ff = Lazy.force coq_false } +let is_implb sigma l o = + match o with None -> false | Some c -> EConstr.eq_constr sigma l c + let parse_formula (genv, sigma) parse_atom env tg term = let parse_atom b env tg t = try @@ -970,6 +976,10 @@ let parse_formula (genv, sigma) parse_atom env tg term = match EConstr.kind sigma term with | App (l, rst) -> ( match rst with + | [|a; b|] when is_implb sigma l op.op_impl -> + let f, env, tg = xparse_formula op k env tg a in + let g, env, tg = xparse_formula op k env tg b in + (mkformula_binary k (mkIMPL k) term f g, env, tg) | [|a; b|] when EConstr.eq_constr sigma l op.op_and -> let f, env, tg = xparse_formula op k env tg a in let g, env, tg = xparse_formula op k env tg b in @@ -2075,12 +2085,11 @@ module MakeCache (T : sig val hash_coeff : int -> coeff -> int val eq_prover_option : prover_option -> prover_option -> bool val eq_coeff : coeff -> coeff -> bool -end) : -sig +end) : sig type key = T.prover_option * (T.coeff Mc.pol * Mc.op1) list + val memo_opt : (unit -> bool) -> string -> (key -> 'a) -> key -> 'a -end = -struct +end = struct module E = struct type t = T.prover_option * (T.coeff Mc.pol * Mc.op1) list diff --git a/plugins/micromega/g_zify.mlg b/plugins/micromega/g_zify.mlg index 0e5cac2d4a..74b0708743 100644 --- a/plugins/micromega/g_zify.mlg +++ b/plugins/micromega/g_zify.mlg @@ -19,12 +19,6 @@ let warn_deprecated_Spec = (fun () -> Pp.strbrk ("Show Zify Spec is deprecated. Use either \"Show Zify BinOpSpec\" or \"Show Zify UnOpSpec\".")) -let warn_deprecated_Add = - CWarnings.create ~name:"deprecated-Zify-Add" ~category:"deprecated" - (fun () -> - Pp.strbrk ("Add <X> is deprecated. Use instead Add Zify <X>.")) - - } DECLARE PLUGIN "zify_plugin" @@ -41,17 +35,6 @@ VERNAC COMMAND EXTEND DECLAREINJECTION CLASSIFIED AS SIDEFF | ["Add" "Zify" "BinOpSpec" constr(t) ] -> { Zify.BinOpSpec.register t } | ["Add" "Zify" "UnOpSpec" constr(t) ] -> { Zify.UnOpSpec.register t } | ["Add" "Zify" "Saturate" constr(t) ] -> { Zify.Saturate.register t } -| ["Add" "InjTyp" constr(t) ] -> { warn_deprecated_Add (); Zify.InjTable.register t } -| ["Add" "BinOp" constr(t) ] -> { warn_deprecated_Add (); Zify.BinOp.register t } -| ["Add" "UnOp" constr(t) ] -> { warn_deprecated_Add (); Zify.UnOp.register t } -| ["Add" "CstOp" constr(t) ] -> { warn_deprecated_Add (); Zify.CstOp.register t } -| ["Add" "BinRel" constr(t) ] -> { warn_deprecated_Add (); Zify.BinRel.register t } -| ["Add" "PropOp" constr(t) ] -> { warn_deprecated_Add (); Zify.PropBinOp.register t } -| ["Add" "PropBinOp" constr(t) ] -> { warn_deprecated_Add (); Zify.PropBinOp.register t } -| ["Add" "PropUOp" constr(t) ] -> { warn_deprecated_Add (); Zify.PropUnOp.register t } -| ["Add" "BinOpSpec" constr(t) ] -> { warn_deprecated_Add (); Zify.BinOpSpec.register t } -| ["Add" "UnOpSpec" constr(t) ] -> { warn_deprecated_Add (); Zify.UnOpSpec.register t } -| ["Add" "Saturate" constr(t) ] -> { warn_deprecated_Add (); Zify.Saturate.register t } END TACTIC EXTEND ITER @@ -73,7 +56,4 @@ VERNAC COMMAND EXTEND ZifyPrint CLASSIFIED AS SIDEFF |[ "Show" "Zify" "BinRel"] -> { Zify.BinRel.print () } |[ "Show" "Zify" "UnOpSpec"] -> { Zify.UnOpSpec.print() } |[ "Show" "Zify" "BinOpSpec"] -> { Zify.BinOpSpec.print() } -|[ "Show" "Zify" "Spec"] -> { - warn_deprecated_Spec () ; - Zify.UnOpSpec.print() ; Zify.BinOpSpec.print ()} END diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 7b29aa15f9..024fc6dade 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -485,7 +485,7 @@ module ProofFormat = struct let rec output_proof o = function | Done -> Printf.fprintf o "." | Step (i, p, pf) -> - Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf + Printf.fprintf o "%i:= %a\n ; %a" i output_prf_rule p output_proof pf | Split (i, v, p1, p2) -> Printf.fprintf o "%i:=%a ; { %a } { %a }" i Vect.pp v output_proof p1 output_proof p2 @@ -496,6 +496,48 @@ module ProofFormat = struct Printf.fprintf o "%i := %i = %i - %i ; %i := %i >= 0 ; %i := %i >= 0 ; %a" i x z t j z k t output_proof pr + module OrdPrfRule = struct + type t = prf_rule + + let id_of_constr = function + | Annot _ -> 0 + | Hyp _ -> 1 + | Def _ -> 2 + | Cst _ -> 3 + | Zero -> 4 + | Square _ -> 5 + | MulC _ -> 6 + | Gcd _ -> 7 + | MulPrf _ -> 8 + | AddPrf _ -> 9 + | CutPrf _ -> 10 + + let cmp_pair c1 c2 (x1, x2) (y1, y2) = + match c1 x1 y1 with 0 -> c2 x2 y2 | i -> i + + let rec compare p1 p2 = + match (p1, p2) with + | Annot (s1, p1), Annot (s2, p2) -> + if s1 = s2 then compare p1 p2 else String.compare s1 s2 + | Hyp i, Hyp j -> Int.compare i j + | Def i, Def j -> Int.compare i j + | Cst n, Cst m -> Q.compare n m + | Zero, Zero -> 0 + | Square v1, Square v2 -> Vect.compare v1 v2 + | MulC (v1, p1), MulC (v2, p2) -> + cmp_pair Vect.compare compare (v1, p1) (v2, p2) + | Gcd (b1, p1), Gcd (b2, p2) -> + cmp_pair Z.compare compare (b1, p1) (b2, p2) + | MulPrf (p1, q1), MulPrf (p2, q2) -> + cmp_pair compare compare (p1, q1) (p2, q2) + | AddPrf (p1, q1), AddPrf (p2, q2) -> + cmp_pair compare compare (p1, q1) (p2, q2) + | CutPrf p, CutPrf p' -> compare p p' + | _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2) + end + + module PrfRuleMap = Map.Make (OrdPrfRule) + let rec pr_size = function | Annot (_, p) -> pr_size p | Zero | Square _ -> Q.zero @@ -537,33 +579,38 @@ module ProofFormat = struct (** [pr_rule_def_cut id pr] gives an explicit [id] to cut rules. This is because the Coq proof format only accept they as a proof-step *) - let rec pr_rule_def_cut id = function - | Annot (_, p) -> pr_rule_def_cut id p - | MulC (p, prf) -> - let bds, id', prf' = pr_rule_def_cut id prf in - (bds, id', MulC (p, prf')) - | MulPrf (p1, p2) -> - let bds1, id, p1 = pr_rule_def_cut id p1 in - let bds2, id, p2 = pr_rule_def_cut id p2 in - (bds2 @ bds1, id, MulPrf (p1, p2)) - | AddPrf (p1, p2) -> - let bds1, id, p1 = pr_rule_def_cut id p1 in - let bds2, id, p2 = pr_rule_def_cut id p2 in - (bds2 @ bds1, id, AddPrf (p1, p2)) - | CutPrf p -> - let bds, id, p = pr_rule_def_cut id p in - ((id, p) :: bds, id + 1, Def id) - | Gcd (c, p) -> - let bds, id, p = pr_rule_def_cut id p in - ((id, p) :: bds, id + 1, Def id) - | (Square _ | Cst _ | Def _ | Hyp _ | Zero) as x -> ([], id, x) + let pr_rule_def_cut m id p = + let rec pr_rule_def_cut m id = function + | Annot (_, p) -> pr_rule_def_cut m id p + | MulC (p, prf) -> + let bds, m, id', prf' = pr_rule_def_cut m id prf in + (bds, m, id', MulC (p, prf')) + | MulPrf (p1, p2) -> + let bds1, m, id, p1 = pr_rule_def_cut m id p1 in + let bds2, m, id, p2 = pr_rule_def_cut m id p2 in + (bds2 @ bds1, m, id, MulPrf (p1, p2)) + | AddPrf (p1, p2) -> + let bds1, m, id, p1 = pr_rule_def_cut m id p1 in + let bds2, m, id, p2 = pr_rule_def_cut m id p2 in + (bds2 @ bds1, m, id, AddPrf (p1, p2)) + | CutPrf p | Gcd (_, p) -> ( + let bds, m, id, p = pr_rule_def_cut m id p in + try + let id' = PrfRuleMap.find p m in + (bds, m, id, Def id') + with Not_found -> + let m = PrfRuleMap.add p id m in + ((id, p) :: bds, m, id + 1, Def id) ) + | (Square _ | Cst _ | Def _ | Hyp _ | Zero) as x -> ([], m, id, x) + in + pr_rule_def_cut m id p (* Do not define top-level cuts *) - let pr_rule_def_cut id = function + let pr_rule_def_cut m id = function | CutPrf p -> - let bds, ids, p' = pr_rule_def_cut id p in - (bds, ids, CutPrf p') - | p -> pr_rule_def_cut id p + let bds, m, ids, p' = pr_rule_def_cut m id p in + (bds, m, ids, CutPrf p') + | p -> pr_rule_def_cut m id p let rec implicit_cut p = match p with CutPrf p -> implicit_cut p | _ -> p @@ -577,6 +624,69 @@ module ProofFormat = struct | MulPrf (p1, p2) | AddPrf (p1, p2) -> ISet.union (pr_rule_collect_defs p1) (pr_rule_collect_defs p2) + let add_proof x y = + match (x, y) with Zero, p | p, Zero -> p | _ -> AddPrf (x, y) + + let rec mul_cst_proof c p = + match p with + | Annot (s, p) -> Annot (s, mul_cst_proof c p) + | MulC (v, p') -> MulC (Vect.mul c v, p') + | _ -> ( + match Q.sign c with + | 0 -> Zero (* This is likely to be a bug *) + | -1 -> + MulC (LinPoly.constant c, p) (* [p] should represent an equality *) + | 1 -> if Q.one =/ c then p else MulPrf (Cst c, p) + | _ -> assert false ) + + let sMulC v p = + let c, v' = Vect.decomp_cst v in + if Vect.is_null v' then mul_cst_proof c p else MulC (v, p) + + let mul_proof p1 p2 = + match (p1, p2) with + | Zero, _ | _, Zero -> Zero + | Cst c, p | p, Cst c -> mul_cst_proof c p + | _, _ -> MulPrf (p1, p2) + + let prf_rule_of_map m = + PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero + + let rec dev_prf_rule p = + match p with + | Annot (s, p) -> dev_prf_rule p + | Hyp _ | Def _ | Cst _ | Zero | Square _ -> + PrfRuleMap.singleton p (LinPoly.constant Q.one) + | MulC (v, p) -> + PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) + | AddPrf (p1, p2) -> + PrfRuleMap.merge + (fun k o1 o2 -> + match (o1, o2) with + | None, None -> None + | None, Some v | Some v, None -> Some v + | Some v1, Some v2 -> Some (LinPoly.addition v1 v2)) + (dev_prf_rule p1) (dev_prf_rule p2) + | MulPrf (p1, p2) -> ( + let p1' = dev_prf_rule p1 in + let p2' = dev_prf_rule p2 in + let p1'' = prf_rule_of_map p1' in + let p2'' = prf_rule_of_map p2' in + match p1'' with + | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' + | _ -> PrfRuleMap.singleton (MulPrf (p1'', p2'')) (LinPoly.constant Q.one) + ) + | Gcd (c, p) -> + PrfRuleMap.singleton + (Gcd (c, prf_rule_of_map (dev_prf_rule p))) + (LinPoly.constant Q.one) + | CutPrf p -> + PrfRuleMap.singleton + (CutPrf (prf_rule_of_map (dev_prf_rule p))) + (LinPoly.constant Q.one) + + let simplify_prf_rule p = prf_rule_of_map (dev_prf_rule p) + (** [simplify_proof p] removes proof steps that are never re-used. *) let rec simplify_proof p = match p with @@ -618,7 +728,9 @@ module ProofFormat = struct | Done -> (id, Done) | Step (i, Gcd (c, p), Done) -> normalise_proof id (Step (i, p, Done)) | Step (i, p, prf) -> - let bds, id, p' = pr_rule_def_cut id p in + let bds, m, id, p' = + pr_rule_def_cut PrfRuleMap.empty id (simplify_prf_rule p) + in let id, prf = normalise_proof id prf in let prf = List.fold_left @@ -642,8 +754,10 @@ module ProofFormat = struct (List.fold_left max 0 ids , Enum(i,p1,v,p2,prfs)) *) - let bds1, id, p1' = pr_rule_def_cut id (implicit_cut p1) in - let bds2, id, p2' = pr_rule_def_cut id (implicit_cut p2) in + let bds1, m, id, p1' = + pr_rule_def_cut PrfRuleMap.empty id (implicit_cut p1) + in + let bds2, m, id, p2' = pr_rule_def_cut m id (implicit_cut p2) in let ids, prfs = List.split (List.map (normalise_proof id) pl) in ( List.fold_left max 0 ids , List.fold_left @@ -659,104 +773,6 @@ module ProofFormat = struct (snd res); res - module OrdPrfRule = struct - type t = prf_rule - - let id_of_constr = function - | Annot _ -> 0 - | Hyp _ -> 1 - | Def _ -> 2 - | Cst _ -> 3 - | Zero -> 4 - | Square _ -> 5 - | MulC _ -> 6 - | Gcd _ -> 7 - | MulPrf _ -> 8 - | AddPrf _ -> 9 - | CutPrf _ -> 10 - - let cmp_pair c1 c2 (x1, x2) (y1, y2) = - match c1 x1 y1 with 0 -> c2 x2 y2 | i -> i - - let rec compare p1 p2 = - match (p1, p2) with - | Annot (s1, p1), Annot (s2, p2) -> - if s1 = s2 then compare p1 p2 else String.compare s1 s2 - | Hyp i, Hyp j -> Int.compare i j - | Def i, Def j -> Int.compare i j - | Cst n, Cst m -> Q.compare n m - | Zero, Zero -> 0 - | Square v1, Square v2 -> Vect.compare v1 v2 - | MulC (v1, p1), MulC (v2, p2) -> - cmp_pair Vect.compare compare (v1, p1) (v2, p2) - | Gcd (b1, p1), Gcd (b2, p2) -> - cmp_pair Z.compare compare (b1, p1) (b2, p2) - | MulPrf (p1, q1), MulPrf (p2, q2) -> - cmp_pair compare compare (p1, p2) (q1, q2) - | AddPrf (p1, q1), AddPrf (p2, q2) -> - cmp_pair compare compare (p1, p2) (q1, q2) - | CutPrf p, CutPrf p' -> compare p p' - | _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2) - end - - let add_proof x y = - match (x, y) with Zero, p | p, Zero -> p | _ -> AddPrf (x, y) - - let rec mul_cst_proof c p = - match p with - | Annot (s, p) -> Annot (s, mul_cst_proof c p) - | MulC (v, p') -> MulC (Vect.mul c v, p') - | _ -> ( - match Q.sign c with - | 0 -> Zero (* This is likely to be a bug *) - | -1 -> - MulC (LinPoly.constant c, p) (* [p] should represent an equality *) - | 1 -> if Q.one =/ c then p else MulPrf (Cst c, p) - | _ -> assert false ) - - let sMulC v p = - let c, v' = Vect.decomp_cst v in - if Vect.is_null v' then mul_cst_proof c p else MulC (v, p) - - let mul_proof p1 p2 = - match (p1, p2) with - | Zero, _ | _, Zero -> Zero - | Cst c, p | p, Cst c -> mul_cst_proof c p - | _, _ -> MulPrf (p1, p2) - - module PrfRuleMap = Map.Make (OrdPrfRule) - - let prf_rule_of_map m = - PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero - - let rec dev_prf_rule p = - match p with - | Annot (s, p) -> dev_prf_rule p - | Hyp _ | Def _ | Cst _ | Zero | Square _ -> - PrfRuleMap.singleton p (LinPoly.constant Q.one) - | MulC (v, p) -> - PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) - | AddPrf (p1, p2) -> - PrfRuleMap.merge - (fun k o1 o2 -> - match (o1, o2) with - | None, None -> None - | None, Some v | Some v, None -> Some v - | Some v1, Some v2 -> Some (LinPoly.addition v1 v2)) - (dev_prf_rule p1) (dev_prf_rule p2) - | MulPrf (p1, p2) -> ( - let p1' = dev_prf_rule p1 in - let p2' = dev_prf_rule p2 in - let p1'' = prf_rule_of_map p1' in - let p2'' = prf_rule_of_map p2' in - match p1'' with - | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' - | _ -> PrfRuleMap.singleton (MulPrf (p1'', p2'')) (LinPoly.constant Q.one) - ) - | _ -> PrfRuleMap.singleton p (LinPoly.constant Q.one) - - let simplify_prf_rule p = prf_rule_of_map (dev_prf_rule p) - (* let mul_proof p1 p2 = let res = mul_proof p1 p2 in @@ -835,7 +851,8 @@ module ProofFormat = struct Printf.printf "cmpl_pol_z %s %a\n" (Printexc.to_string x) LinPoly.pp lp; raise x - let rec cmpl_proof env = function + let rec cmpl_proof env prf = + match prf with | Done -> Mc.DoneProof | Step (i, p, prf) -> ( match p with @@ -1097,15 +1114,33 @@ module WithProof = struct in List.sort cmp (List.rev_map (fun wp -> (size wp, wp)) sys) - let subst sys0 = + let iterate_pivot p sys0 = let elim sys = - let oeq, sys' = extract (is_substitution true) sys in + let oeq, sys' = extract p sys in match oeq with | None -> None | Some (v, pc) -> simplify (linear_pivot sys0 pc v) sys' in iterate_until_stable elim (List.map snd (sort sys0)) + let subst_constant is_int sys = + let is_integer q = Q.(q =/ floor q) in + let is_constant ((c, o), p) = + match o with + | Ge | Gt -> None + | Eq -> ( + Vect.Bound.( + match of_vect c with + | None -> None + | Some b -> + if (not is_int) || is_integer (b.cst // b.coeff) then + Monomial.get_var (LinPoly.MonT.retrieve b.var) + else None) ) + in + iterate_pivot is_constant sys + + let subst sys0 = iterate_pivot (is_substitution true) sys0 + let saturate_subst b sys0 = let select = is_substitution b in let gen (v, pc) ((c, op), prf) = diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 84b5421207..81c131fe78 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -393,6 +393,10 @@ module WithProof : sig val subst : t list -> t list + (** [subst_constant b sys] performs the equivalent of the 'subst' tactic of Coq + only if there is an equation a.x = c for a,c a constant and a divides c if b= true*) + val subst_constant : bool -> t list -> t list + (** [subst1 sys] performs a single substitution *) val subst1 : t list -> t list diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index d1403558ad..61966b60c0 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -14,7 +14,7 @@ open Pp open Lazy module NamedDecl = Context.Named.Declaration -let debug = false +let debug_zify = CDebug.create ~name:"zify" () (* The following [constr] are necessary for constructing the proof terms *) @@ -805,12 +805,11 @@ let pp_prf prf = let interp_prf evd inj source prf = let t, prf' = interp_prf evd inj source prf in - if debug then - Feedback.msg_debug + debug_zify (fun () -> Pp.( str "interp_prf " ++ gl_pr_constr inj.EInjT.inj ++ str " " ++ gl_pr_constr source ++ str " = " ++ gl_pr_constr t ++ str " by " - ++ gl_pr_constr prf' ++ str " from " ++ pp_prf prf ++ fnl ()); + ++ gl_pr_constr prf' ++ str " from " ++ pp_prf prf ++ fnl ())); (t, prf') let mkvar evd inj e = @@ -888,13 +887,12 @@ let app_unop evd src unop arg prf = let app_unop evd src unop arg prf = let res = app_unop evd src unop arg prf in - if debug then - Feedback.msg_debug + debug_zify (fun () -> Pp.( str "\napp_unop " ++ pp_prf evd unop.EUnOpT.inj1_t arg prf ++ str " => " - ++ pp_prf evd unop.EUnOpT.inj2_t src res); + ++ pp_prf evd unop.EUnOpT.inj2_t src res)); res let app_binop evd src binop arg1 prf1 arg2 prf2 = @@ -1066,8 +1064,7 @@ let match_operator env evd hd args (t, d) = let pp_trans_expr env evd e res = let {deriv = inj} = get_injection env evd e.typ in - if debug then - Feedback.msg_debug Pp.(str "\ntrans_expr " ++ pp_prf evd inj e.constr res); + debug_zify (fun () -> Pp.(str "\ntrans_expr " ++ pp_prf evd inj e.constr res)); res let declared_term env evd hd args = @@ -1187,7 +1184,7 @@ let trans_binrel evd src rop a1 prf1 a2 prf2 = let trans_binrel evd src rop a1 prf1 a2 prf2 = let res = trans_binrel evd src rop a1 prf1 a2 prf2 in - if debug then Feedback.msg_debug Pp.(str "\ntrans_binrel " ++ pp_prfp res); + debug_zify (fun () -> Pp.(str "\ntrans_binrel " ++ pp_prfp res)); res let mkprf t p = @@ -1199,11 +1196,10 @@ let mkprf t p = let mkprf t p = let t', p = mkprf t p in - if debug then - Feedback.msg_debug + debug_zify (fun () -> Pp.( str "mkprf " ++ gl_pr_constr t ++ str " <-> " ++ gl_pr_constr t' - ++ str " by " ++ gl_pr_constr p); + ++ str " by " ++ gl_pr_constr p)); (t', p) let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = @@ -1221,7 +1217,7 @@ let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = let prf = trans_bin_prop op_constr op_iff t1 p1 t2 p2 in - if debug then Feedback.msg_debug (pp_prfp prf); + debug_zify (fun () -> pp_prfp prf); prf let trans_un_prop op_constr op_iff p1 prf1 = @@ -1285,8 +1281,7 @@ let trans_hyps env evd l = [] l let trans_hyp h t0 prfp = - if debug then - Feedback.msg_debug Pp.(str "trans_hyp: " ++ pp_prfp prfp ++ fnl ()); + debug_zify (fun () -> Pp.(str "trans_hyp: " ++ pp_prfp prfp ++ fnl ())); match prfp with | IProof -> Tacticals.New.tclIDTAC (* Should detect before *) | CProof t' -> @@ -1313,8 +1308,7 @@ let trans_hyp h t0 prfp = (tclTHEN (Tactics.clear [h]) (Tactics.rename_hyp [(h', h)]))))) let trans_concl prfp = - if debug then - Feedback.msg_debug Pp.(str "trans_concl: " ++ pp_prfp prfp ++ fnl ()); + debug_zify (fun () -> Pp.(str "trans_concl: " ++ pp_prfp prfp ++ fnl ())); match prfp with | IProof -> Tacticals.New.tclIDTAC | CProof t -> diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml index 1caa042db6..19bdcbac58 100644 --- a/plugins/nsatz/utile.ml +++ b/plugins/nsatz/utile.ml @@ -1,9 +1,9 @@ (* Printing *) let pr x = - if !Flags.debug then (Format.printf "@[%s@]" x; flush(stdout);)else () + if CDebug.(get_flag misc) then (Format.printf "@[%s@]" x; flush(stdout);)else () let prt0 s = () (* print_string s;flush(stdout)*) -let sinfo s = if !Flags.debug then Feedback.msg_debug (Pp.str s) -let info s = if !Flags.debug then Feedback.msg_debug (Pp.str (s ())) +let sinfo s = if CDebug.(get_flag misc) then Feedback.msg_debug (Pp.str s) +let info s = if CDebug.(get_flag misc) then Feedback.msg_debug (Pp.str (s ())) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 4f7b3fbe74..9d92ffde74 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -354,8 +354,9 @@ let coq_True = gen_constant "core.True.type" let evaluable_ref_of_constr s c = let env = Global.env () in let evd = Evd.from_env env in + let open Tacred in match EConstr.kind evd (Lazy.force c) with - | Const (kn,u) when Tacred.is_evaluable env (EvalConstRef kn) -> + | Const (kn,u) when is_evaluable env (EvalConstRef kn) -> EvalConstRef kn | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant.")) diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index f6a741f468..5fbabd7ca1 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -46,7 +46,11 @@ type ssrclear = ssrhyps type ssrdocc = ssrclear option * ssrocc (* OLD ssr terms *) -type ssrtermkind = char (* FIXME, make algebraic *) +(* terms are pre constr, the kind is a parsing/printing flag to distinguish + * between x, @x and (x). It affects automatic clear and let-in preservation. *) +(* FIXME *) +(* Cpattern is a temporary flag that becomes InParens ASAP. *) +type ssrtermkind = Ssrmatching_plugin.Ssrmatching.ssrtermkind type ssrterm = ssrtermkind * Genintern.glob_constr_and_expr (* NEW ssr term *) diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index 61643c2aa3..37eba7d399 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -19,30 +19,21 @@ open Ssrmatching_plugin open Ssrmatching open Ssrast -open Ssrprinters open Ssrcommon -let char_to_kind = function - | '(' -> xInParens - | '@' -> xWithAt - | ' ' -> xNoFlag - | 'x' -> xCpattern - | _ -> assert false - (** Backward chaining tactics: apply, exact, congr. *) (** The "apply" tactic *) let interp_agen ist gl ((goclr, _), (k, gc as c)) (clr, rcs) = (* ppdebug(lazy(str"sigma@interp_agen=" ++ pr_evar_map None (project gl))); *) - let k = char_to_kind k in let rc = pf_intern_term ist gl c in let rcs' = rc :: rcs in match goclr with | None -> clr, rcs' | Some ghyps -> let clr' = snd (interp_hyps ist gl ghyps) @ clr in - if k <> xNoFlag then clr', rcs' else + if k <> NoFlag then clr', rcs' else let loc = rc.CAst.loc in match DAst.get rc with | GVar id when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' @@ -132,7 +123,7 @@ let inner_ssrapplytac gviews (ggenl, gclr) ist = Proofview.V82.tactic ~nf_evars: let vtac gv i gl' = refine_interp_apply_view i ist gl' gv in let ggenl, tclGENTAC = if gviews <> [] && ggenl <> [] then - let ggenl= List.map (fun (x,g) -> x, cpattern_of_term g ist) (List.hd ggenl) in + let ggenl= List.map (fun (x,(k,p)) -> x, {kind=k; pattern=p; interpretation= Some ist}) (List.hd ggenl) in [], Tacticals.tclTHEN (Proofview.V82.of_tactic (genstac (ggenl,[]))) else ggenl, Tacticals.tclTHEN Tacticals.tclIDTAC in tclGENTAC (fun gl -> diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index cd219838d5..41fd96ccb5 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -252,7 +252,7 @@ let interp_refine ist gl rc = in let sigma, c = Pretyping.understand_ltac flags (pf_env gl) (project gl) vars kind rc in (* ppdebug(lazy(str"sigma@interp_refine=" ++ pr_evar_map None sigma)); *) - ppdebug(lazy(str"c@interp_refine=" ++ Printer.pr_econstr_env (pf_env gl) sigma c)); + debug_ssr (fun () -> str"c@interp_refine=" ++ Printer.pr_econstr_env (pf_env gl) sigma c); (sigma, (sigma, c)) @@ -290,7 +290,7 @@ let interp_hyps ist gl ghyps = (* Old terms *) let mk_term k c = k, (mkRHole, Some c) -let mk_lterm c = mk_term xNoFlag c +let mk_lterm c = mk_term NoFlag c (* New terms *) @@ -318,9 +318,9 @@ let interp_ast_closure_term (ist : Geninterp.interp_sign) (gl : 'goal Evd.sigma) let ssrterm_of_ast_closure_term { body; annotation } = let c = match annotation with - | `Parens -> xInParens - | `At -> xWithAt - | _ -> xNoFlag in + | `Parens -> InParens + | `At -> WithAt + | _ -> NoFlag in mk_term c body let ssrdgens_of_parsed_dgens = function @@ -926,7 +926,7 @@ let pf_interp_ty ?(resolve_typeclasses=false) env sigma0 ist ty = CProdN (abs, force_type t) | CLetIn (n, v, oty, t) -> incr n_binders; CLetIn (n, v, oty, force_type t) | _ -> (mkCCast ty (mkCType None)).v)) ty in - mk_term ' ' (force_type ty) in + mk_term NoFlag (force_type ty) in let strip_cast (sigma, t) = let open EConstr in let rec aux t = match kind_of_type sigma t with @@ -1099,7 +1099,7 @@ let hyp_of_var sigma v = SsrHyp (Loc.tag @@ EConstr.destVar sigma v) let interp_clr sigma = function | Some clr, (k, c) - when (k = xNoFlag || k = xWithAt) && is_pf_var sigma c -> + when (k = NoFlag || k = WithAt) && is_pf_var sigma c -> hyp_of_var sigma c :: clr | Some clr, _ -> clr | None, _ -> [] @@ -1167,7 +1167,7 @@ let pf_interp_gen_aux gl to_ind ((oclr, occ), t) = let cl = EConstr.of_constr cl in let clr = interp_clr sigma (oclr, (tag_of_cpattern t, c)) in if not(occur_existential sigma c) then - if tag_of_cpattern t = xWithAt then + if tag_of_cpattern t = WithAt then if not (EConstr.isVar sigma c) then errorstrm (str "@ can be used with variables only") else match Tacmach.pf_get_hyp gl (EConstr.destVar sigma c) with @@ -1207,7 +1207,7 @@ 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)); + debug_ssr (fun () -> str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c); let gl = pf_merge_uc ucst gl in if conv then tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl)) (old_cleartac clr) gl diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 582c45cde1..78a59abda9 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -126,17 +126,17 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = fun (oc, orig_clr, occ, c_gen) -> pfLIFT begin fun gl -> let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in - ppdebug(lazy(Pp.str(if is_case then "==CASE==" else "==ELIM=="))); + debug_ssr (fun () -> (Pp.str(if is_case then "==CASE==" else "==ELIM=="))); let fire_subst gl t = Reductionops.nf_evar (project gl) t in let is_undef_pat = function | sigma, T t -> EConstr.isEvar sigma (EConstr.of_constr t) | _ -> false in let match_pat env p occ h cl = let sigma0 = project orig_gl in - ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern env p)); + debug_ssr (fun () -> Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern env p)); let (c,ucst), cl = fill_occ_pattern ~raise_NoMatch:true env sigma0 (EConstr.Unsafe.to_constr cl) p occ h in - ppdebug(lazy Pp.(str" got: " ++ pr_constr_env env sigma0 c)); + debug_ssr (fun () -> Pp.(str" got: " ++ pr_constr_env env sigma0 c)); c, EConstr.of_constr cl, ucst in let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in @@ -212,10 +212,10 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let renamed_tys = Array.mapi (fun j (ctx, cty) -> let t = Term.it_mkProd_or_LetIn cty ctx in - ppdebug(lazy Pp.(str "Search" ++ Printer.pr_constr_env env (project gl) t)); + debug_ssr (fun () -> Pp.(str "Search" ++ Printer.pr_constr_env env (project gl) t)); let t = Arguments_renaming.rename_type t (GlobRef.ConstructRef((kn,i),j+1)) in - ppdebug(lazy Pp.(str"Done Search " ++ Printer.pr_constr_env env (project gl) t)); + debug_ssr (fun () -> Pp.(str"Done Search " ++ Printer.pr_constr_env env (project gl) t)); t) tys in @@ -241,8 +241,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = in let () = let sigma = project gl in - ppdebug(lazy Pp.(str"elim= "++ pr_econstr_pat env sigma elim)); - ppdebug(lazy Pp.(str"elimty= "++ pr_econstr_pat env sigma elimty)) in + debug_ssr (fun () -> Pp.(str"elim= "++ pr_econstr_pat env sigma elim)); + debug_ssr (fun () -> Pp.(str"elimty= "++ pr_econstr_pat env sigma elimty)) in let open EConstr in let inf_deps_r = match kind_of_type (project gl) elimty with | AtomicType (_, args) -> List.rev (Array.to_list args) @@ -301,7 +301,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = | Some (c, _, _,gl) -> Some(true, gl) | None -> None in first [try_c_last_arg;try_c_last_pattern] in - ppdebug(lazy Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); + debug_ssr (fun () -> Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); let gl, predty = pfe_type_of gl pred in (* Patterns for the inductive types indexes to be bound in pred are computed * looking at the ones provided by the user and the inferred ones looking at @@ -321,7 +321,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = loop (patterns @ [i, p, inf_t, occ]) (clr_t @ clr) (i+1) (deps, inf_deps) | [], c :: inf_deps -> - ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_econstr_pat env (project gl) c)); + debug_ssr (fun () -> Pp.(str"adding inf pattern " ++ pr_econstr_pat env (project gl) c)); loop (patterns @ [i, mkTpat gl c, c, allocc]) clr (i+1) ([], inf_deps) | _::_, [] -> errorstrm Pp.(str "Too many dependent abstractions") in @@ -337,8 +337,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = loop [] orig_clr (List.length head_p+1) (List.rev deps, inf_deps_r) in head_p @ patterns, Util.List.uniquize clr, gl in - ppdebug(lazy Pp.(pp_concat (str"patterns=") (List.map pp_pat patterns))); - ppdebug(lazy Pp.(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); + debug_ssr (fun () -> Pp.(pp_concat (str"patterns=") (List.map pp_pat patterns))); + debug_ssr (fun () -> Pp.(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); (* Predicate generation, and (if necessary) tactic to generalize the * equation asked by the user *) let elim_pred, gen_eq_tac, clr, gl = @@ -348,7 +348,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = let p = unif_redex gl p inf_t in if is_undef_pat p then - let () = ppdebug(lazy Pp.(str"postponing " ++ pp_pattern env p)) in + let () = debug_ssr (fun () -> Pp.(str"postponing " ++ pp_pattern env p)) in cl, gl, post @ [h, p, inf_t, occ] else try let c, cl, ucst = match_pat env p occ h cl in @@ -420,8 +420,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = else gl, concl in concl, gen_eq_tac, clr, gl in let gl, pty = pf_e_type_of gl elim_pred in - ppdebug(lazy Pp.(str"elim_pred=" ++ pp_term gl elim_pred)); - ppdebug(lazy Pp.(str"elim_pred_ty=" ++ pp_term gl pty)); + debug_ssr (fun () -> Pp.(str"elim_pred=" ++ pp_term gl elim_pred)); + debug_ssr (fun () -> Pp.(str"elim_pred_ty=" ++ pp_term gl pty)); let gl = pf_unify_HO gl pred elim_pred in let elim = fire_subst gl elim in let gl = pf_resolve_typeclasses ~where:elim ~fail:false gl in diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index fdfba48024..92a481dd18 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -76,7 +76,7 @@ let simpltac s = Proofview.Goal.enter (fun _ -> simpltac s) (** The "congr" tactic *) let interp_congrarg_at ist gl n rf ty m = - ppdebug(lazy Pp.(str"===interp_congrarg_at===")); + debug_ssr (fun () -> Pp.(str"===interp_congrarg_at===")); let congrn, _ = mkSsrRRef "nary_congruence" in let args1 = mkRnat n :: mkRHoles n @ [ty] in let args2 = mkRHoles (3 * n) in @@ -84,7 +84,7 @@ let interp_congrarg_at ist gl n rf ty m = if i + n > m then None else try let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in - ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) (project gl) rt)); + debug_ssr (fun () -> Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) (project gl) rt)); Some (interp_refine ist gl rt) with _ -> loop (i + 1) in loop 0 @@ -92,8 +92,8 @@ let interp_congrarg_at ist gl n rf ty m = 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))); + debug_ssr (fun () -> (Pp.str"===congr===")); + debug_ssr (fun () -> Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (Tacmach.pf_concl gl))); 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 @@ -124,8 +124,8 @@ let newssrcongrtac arg ist = 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))); + debug_ssr (fun () -> Pp.(str"===newcongr===")); + debug_ssr (fun () -> Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); (* utils *) let fs gl t = Reductionops.nf_evar (project gl) t in let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = @@ -223,16 +223,16 @@ let simplintac occ rdx sim = end let rec get_evalref env sigma c = match EConstr.kind sigma c with - | Var id -> EvalVarRef id - | Const (k,_) -> EvalConstRef k + | Var id -> Tacred.EvalVarRef id + | Const (k,_) -> Tacred.EvalConstRef k | App (c', _) -> get_evalref env sigma c' | Cast (c', _, _) -> get_evalref env sigma c' - | Proj(c,_) -> EvalConstRef(Projection.constant c) + | Proj(c,_) -> Tacred.EvalConstRef(Projection.constant c) | _ -> errorstrm Pp.(str "The term " ++ pr_econstr_pat (Global.env ()) sigma c ++ str " is not unfoldable") (* Strip a pattern generated by a prenex implicit to its constant. *) let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with - | App (f, a) when kt = xNoFlag && Array.for_all (EConstr.isEvar sigma) a && EConstr.isConst sigma f -> + | App (f, a) when kt = NoFlag && Array.for_all (EConstr.isEvar sigma) a && EConstr.isConst sigma f -> (sigma, f), true | Const _ | Var _ -> p, true | Proj _ -> p, true @@ -385,8 +385,8 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ | Pretype_errors.PretypeError (env, sigma, te) -> raise (PRtype_error (Some (env, sigma, te))) | e when CErrors.noncritical e -> raise (PRtype_error None) 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)); + debug_ssr (fun () -> Pp.(str"pirrel_rewrite: proof term: " ++ pr_econstr_env env sigma proof)); + debug_ssr (fun () -> Pp.(str"pirrel_rewrite of type: " ++ pr_econstr_env env sigma proof_ty)); try Proofview.V82.of_tactic (refine_with ~first_goes_last:(not !ssroldreworder || under) ~with_evars:under (sigma, proof)) gl with e when CErrors.noncritical e -> @@ -435,12 +435,12 @@ let rwcltac ?under ?map_redex cl rdx dir sr = 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 env sigma0 (snd sr))); + debug_ssr (fun () -> 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)); + debug_ssr (fun () -> 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 -> @@ -521,7 +521,7 @@ let rwprocess_rule env dir rule = let t = if red = 1 then Tacred.hnf_constr env sigma t0 else Reductionops.whd_betaiotazeta env sigma t0 in - ppdebug(lazy Pp.(str"rewrule="++pr_econstr_pat env sigma t)); + debug_ssr (fun () -> Pp.(str"rewrule="++pr_econstr_pat env sigma t)); match EConstr.kind sigma t with | Prod (_, xt, at) -> let sigma = Evd.create_evar_defs sigma in @@ -736,7 +736,7 @@ let unlocktac ist args = Ssrcommon.tacMK_SSR_CONST "locked" >>= fun locked -> Ssrcommon.tacMK_SSR_CONST "master_key" >>= fun key -> let ktacs = [ - (Proofview.tclEVARMAP >>= fun sigma -> unfoldtac None None (sigma, locked) xInParens); + (Proofview.tclEVARMAP >>= fun sigma -> unfoldtac None None (sigma, locked) InParens); Ssrelim.casetac key (fun ?seed:_ k -> k) ] in Tacticals.New.tclTHENLIST (List.map utac args @ ktacs) diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 4961138190..bc46c23761 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -143,8 +143,8 @@ let havetac ist let gl, _ = pf_e_type_of gl idty in pf_unify_HO gl args_id.(2) abstract_key in 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 mkt t = mk_term NoFlag t in + let mkl t = (NoFlag, (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 (pf_env gl) (project gl) ist t in a,b,u in @@ -296,8 +296,8 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave = | Some id -> 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)); + debug_ssr (fun () -> str"specialized="++ pr_econstr_env (pf_env gl) (project gl) EConstr.(mkApp (mkVar id,args))); + debug_ssr (fun () -> str"specialized_ty="++ pr_econstr_env (pf_env gl) (project gl) ct); Tacticals.New.tclTHENS (basecuttac "ssr_have" ct) [Tactics.apply EConstr.(mkApp (mkVar id,args)); Tacticals.New.tclIDTAC] in "ssr_have", @@ -395,7 +395,7 @@ let intro_lock ipats = Array.length args = 3 && is_app_evar sigma args.(2) -> protect_subgoal env sigma hd args | _ -> - ppdebug(lazy Pp.(str"under: stop:" ++ pr_econstr_env env sigma t)); + debug_ssr (fun () -> Pp.(str"under: stop:" ++ pr_econstr_env env sigma t)); Proofview.tclUNIT () end) @@ -468,13 +468,13 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = | Some l -> [IPatCase(Regular [l;[]])] in let map_redex env evar_map ~before:_ ~after:t = - ppdebug(lazy Pp.(str"under vars: " ++ prlist Names.Name.print varnames)); + debug_ssr (fun () -> Pp.(str"under vars: " ++ prlist Names.Name.print varnames)); let evar_map, ty = Typing.type_of env evar_map t in let new_t = (* pretty-rename the bound variables *) try begin match EConstr.destApp evar_map t with (f, ar) -> let lam = Array.last ar in - ppdebug(lazy Pp.(str"under: mapping:" ++ + debug_ssr(fun () -> Pp.(str"under: mapping:" ++ pr_econstr_env env evar_map lam)); let new_lam = pretty_rename evar_map lam varnames in let new_ar, len1 = Array.copy ar, pred (Array.length ar) in @@ -482,10 +482,10 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = EConstr.mkApp (f, new_ar) end with | DestKO -> - ppdebug(lazy Pp.(str"under: cannot pretty-rename bound variables with destApp")); + debug_ssr (fun () -> Pp.(str"under: cannot pretty-rename bound variables with destApp")); t in - ppdebug(lazy Pp.(str"under: to:" ++ pr_econstr_env env evar_map new_t)); + debug_ssr (fun () -> Pp.(str"under: to:" ++ pr_econstr_env env evar_map new_t)); evar_map, new_t in let undertacs = diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 46f90a7ee1..f8abed5482 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -324,7 +324,7 @@ end `tac`, where k is the size of `seeds` *) let tclSEED_SUBGOALS seeds tac = tclTHENin tac (fun i n -> - Ssrprinters.ppdebug (lazy Pp.(str"seeding")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"seeding")); (* eg [case: (H _ : nat)] generates 3 goals: - 1 for _ - 2 for the nat constructors *) @@ -416,11 +416,11 @@ let tclMK_ABSTRACT_VARS ids = (* Debugging *) let tclLOG p t = tclUNIT () >>= begin fun () -> - Ssrprinters.ppdebug (lazy Pp.(str "exec: " ++ pr_ipatop p)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "exec: " ++ pr_ipatop p)); tclUNIT () end <*> Goal.enter begin fun g -> - Ssrprinters.ppdebug (lazy Pp.(str" on state:" ++ spc () ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str" on state:" ++ spc () ++ isPRINT g ++ str" goal:" ++ spc () ++ Printer.pr_goal (Goal.print g))); tclUNIT () @@ -429,7 +429,7 @@ let tclLOG p t = t p >>= fun ret -> Goal.enter begin fun g -> - Ssrprinters.ppdebug (lazy Pp.(str "done: " ++ isPRINT g)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "done: " ++ isPRINT g)); tclUNIT () end >>= fun () -> tclUNIT ret @@ -579,10 +579,10 @@ let tclCompileIPats l = elab l ;; let tclCompileIPats l = - Ssrprinters.ppdebug (lazy Pp.(str "tclCompileIPats input: " ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str "tclCompileIPats input: " ++ prlist_with_sep spc Ssrprinters.pr_ipat l)); let ops = tclCompileIPats l in - Ssrprinters.ppdebug (lazy Pp.(str "tclCompileIPats output: " ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str "tclCompileIPats output: " ++ prlist_with_sep spc pr_ipatop ops)); ops @@ -597,11 +597,11 @@ let main ?eqtac ~first_case_is_dispatch iops = end (* }}} *) let tclIPAT_EQ eqtac ip = - Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); IpatMachine.(main ~eqtac ~first_case_is_dispatch:true (tclCompileIPats ip)) let tclIPATssr ip = - Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); IpatMachine.(main ~first_case_is_dispatch:true (tclCompileIPats ip)) let tclCompileIPats = IpatMachine.tclCompileIPats @@ -741,7 +741,7 @@ let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin [A.. -> Ind] and opens new goals for [A..] as well as for the branches of [Ind], see the [~to_ind] argument *) if not(Termops.occur_existential sigma c) then - if Ssrmatching.tag_of_cpattern t = Ssrprinters.xWithAt then + if Ssrmatching.tag_of_cpattern t = Ssrmatching.WithAt then if not (EConstr.isVar sigma c) then Ssrcommon.errorstrm Pp.(str "@ can be used with variables only") else match Context.Named.lookup (EConstr.destVar sigma c) hyps with diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index f06b460ee9..935cef58b9 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -38,6 +38,8 @@ open Constrexpr_ops open Proofview open Proofview.Notations +open Ssrmatching_plugin.Ssrmatching + open Ssrprinters open Ssrcommon open Ssrtacticals @@ -455,9 +457,9 @@ END (* Old kinds of terms *) let input_ssrtermkind _ strm = match Util.stream_nth 0 strm with - | Tok.KEYWORD "(" -> xInParens - | Tok.KEYWORD "@" -> xWithAt - | _ -> xNoFlag + | Tok.KEYWORD "(" -> InParens + | Tok.KEYWORD "@" -> WithAt + | _ -> NoFlag let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind @@ -554,9 +556,9 @@ END GRAMMAR EXTEND Gram GLOBAL: ssrbwdview; ssrbwdview: [ - [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> { [mk_term xNoFlag c] } + [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> { [mk_term NoFlag c] } | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrbwdview -> { - (mk_term xNoFlag c) :: w } ]]; + (mk_term NoFlag c) :: w } ]]; END (* New Views *) @@ -2201,10 +2203,10 @@ let pr_ssrcongrarg _ _ _ ((n, f), dgens) = ARGUMENT EXTEND ssrcongrarg TYPED AS ((int * ssrterm) * ssrdgens) PRINTED BY { pr_ssrcongrarg } -| [ natural(n) constr(c) ssrdgens(dgens) ] -> { (n, mk_term xNoFlag c), dgens } -| [ natural(n) constr(c) ] -> { (n, mk_term xNoFlag c),([[]],[]) } -| [ constr(c) ssrdgens(dgens) ] -> { (0, mk_term xNoFlag c), dgens } -| [ constr(c) ] -> { (0, mk_term xNoFlag c), ([[]],[]) } +| [ natural(n) constr(c) ssrdgens(dgens) ] -> { (n, mk_term NoFlag c), dgens } +| [ natural(n) constr(c) ] -> { (n, mk_term NoFlag c),([[]],[]) } +| [ constr(c) ssrdgens(dgens) ] -> { (0, mk_term NoFlag c), dgens } +| [ constr(c) ] -> { (0, mk_term NoFlag c), ([[]],[]) } END @@ -2260,7 +2262,7 @@ let pr_rule = function let pr_ssrrule _ _ _ = pr_rule -let noruleterm loc = mk_term xNoFlag (mkCProp loc) +let noruleterm loc = mk_term NoFlag (mkCProp loc) } diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 95c8024e89..434568b554 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -15,7 +15,6 @@ open Names open Printer open Tacmach -open Ssrmatching_plugin open Ssrast let pr_spc () = str " " @@ -28,16 +27,6 @@ let pp_concat hd ?(sep=str", ") = function [] -> hd | x :: xs -> let pp_term gl t = let t = Reductionops.nf_evar (project gl) t in pr_econstr_env (pf_env gl) (project gl) t -(* FIXME *) -(* terms are pre constr, the kind is parsing/printing flag to distinguish - * between x, @x and (x). It affects automatic clear and let-in preservation. - * Cpattern is a temporary flag that becomes InParens ASAP. *) -(* type ssrtermkind = InParens | WithAt | NoFlag | Cpattern *) -let xInParens = '(' -let xWithAt = '@' -let xNoFlag = ' ' -let xCpattern = 'x' - (* Term printing utilities functions for deciding bracketing. *) let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") (* String lexing utilities *) @@ -45,10 +34,10 @@ let skip_wschars s = let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop (* We also guard characters that might interfere with the ssreflect *) (* tactic syntax. *) -let guard_term ch1 s i = match s.[i] with +let guard_term kind s i = match s.[i] with | '(' -> false | '{' | '/' | '=' -> true - | _ -> ch1 = xInParens + | _ -> kind = Ssrmatching_plugin.Ssrmatching.InParens (* We also guard characters that might interfere with the ssreflect *) (* tactic syntax. *) @@ -131,15 +120,4 @@ and pr_block = function (Prefix id) -> str"^" ++ Id.print id | (SuffixId id) -> str"^~" ++ Id.print id | (SuffixNum n) -> str"^~" ++ int n -(* 0 cost pp function. Active only if Debug Ssreflect is Set *) -let ppdebug_ref = ref (fun _ -> ()) -let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s) -let () = - Goptions.(declare_bool_option - { optkey = ["Debug";"Ssreflect"]; - optdepr = false; - optread = (fun _ -> !ppdebug_ref == ssr_pp); - optwrite = (fun b -> - Ssrmatching.debug b; - if b then ppdebug_ref := ssr_pp else ppdebug_ref := fun _ -> ()) }) -let ppdebug s = !ppdebug_ref s +let debug_ssr = CDebug.create ~name:"ssreflect" () diff --git a/plugins/ssr/ssrprinters.mli b/plugins/ssr/ssrprinters.mli index 87eb05b667..994577a0c9 100644 --- a/plugins/ssr/ssrprinters.mli +++ b/plugins/ssr/ssrprinters.mli @@ -24,11 +24,6 @@ val pp_concat : Pp.t -> ?sep:Pp.t -> Pp.t list -> Pp.t -val xInParens : ssrtermkind -val xWithAt : ssrtermkind -val xNoFlag : ssrtermkind -val xCpattern : ssrtermkind - val pr_clear : (unit -> Pp.t) -> ssrclear -> Pp.t val pr_clear_ne : ssrclear -> Pp.t val pr_dir : ssrdir -> Pp.t @@ -56,5 +51,4 @@ val pr_guarded : val pr_occ : ssrocc -> Pp.t -val ppdebug : Pp.t Lazy.t -> unit - +val debug_ssr : CDebug.t diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index cbc352126e..c822675589 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -40,7 +40,7 @@ let tclPERM perm tac = let rot_hyps dir i hyps = let n = List.length hyps in if i = 0 then List.rev hyps else - if i > n then CErrors.user_err (Pp.str "Not enough subgoals") else + if i > n then CErrors.user_err (Pp.str "Not enough goals") else let rec rot i l_hyps = function | hyp :: hyps' when i > 0 -> rot (i - 1) (hyp :: l_hyps) hyps' | hyps' -> hyps' @ (List.rev l_hyps) in diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 97926753f5..b3a9e71a3f 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -194,17 +194,17 @@ let mkGApp f args = let interp_glob ist glob = Goal.enter_one ~__LOC__ begin fun goal -> let env = Goal.env goal in let sigma = Goal.sigma goal in - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"interp-in: " ++ Printer.pr_glob_constr_env env sigma glob)); try let sigma,term = Tacinterp.interp_open_constr ist env sigma (glob,None) in - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"interp-out: " ++ Printer.pr_econstr_env env sigma term)); tclUNIT (env,sigma,term) with e -> (* XXX this is another catch all! *) let e, info = Exninfo.capture e in - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"interp-err: " ++ Printer.pr_glob_constr_env env sigma glob)); tclZERO ~info e end @@ -217,7 +217,7 @@ end let tclKeepOpenConstr (_env, sigma, t) = Unsafe.tclEVARS sigma <*> tclUNIT t let tclADD_CLEAR_IF_ID (env, ist, t) x = - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"tclADD_CLEAR_IF_ID: " ++ Printer.pr_econstr_env env ist t)); let hd, args = EConstr.decompose_app ist t in match EConstr.kind ist hd with @@ -269,11 +269,11 @@ let interp_view ~clear_if_id ist v p = let p_id = DAst.make p_id in match DAst.get v with | Glob_term.GApp (hd, rargs) when is_specialize hd -> - Ssrprinters.ppdebug (lazy Pp.(str "specialize")); + Ssrprinters.debug_ssr (fun () -> Pp.(str "specialize")); interp_glob ist (mkGApp p_id rargs) >>= tclKeepOpenConstr >>= tclPAIR [] | _ -> - Ssrprinters.ppdebug (lazy Pp.(str "view")); + Ssrprinters.debug_ssr (fun () -> Pp.(str "view")); (* We find out how to build (v p) eventually using an adaptor *) let adaptors = AdaptorDb.(get Forward) in Proofview.tclORELSE @@ -324,7 +324,7 @@ Goal.enter_one ~__LOC__ begin fun g -> let rigid = rigid_of und0 in let n, p, to_prune, _ucst = pf_abs_evars2 s0 rigid (sigma, p) in let p = if simple_types then pf_abs_cterm s0 n p else p in - Ssrprinters.ppdebug (lazy Pp.(str"view@finalized: " ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str"view@finalized: " ++ Printer.pr_econstr_env env sigma p)); let sigma = List.fold_left Evd.remove sigma to_prune in Unsafe.tclEVARS sigma <*> @@ -349,26 +349,26 @@ let rec apply_all_views_aux ~clear_if_id vs finalization conclusion s0 = pose_proof name p <*> conclusion ~to_clear:name) <*> tclUNIT false) | v :: vs -> - Ssrprinters.ppdebug (lazy Pp.(str"piling...")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"piling...")); is_tac_in_term ~extra_scope:"ssripat" v >>= function | `Term v -> - Ssrprinters.ppdebug (lazy Pp.(str"..a term")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..a term")); pile_up_view ~clear_if_id v <*> apply_all_views_aux ~clear_if_id vs finalization conclusion s0 | `Tac tac -> - Ssrprinters.ppdebug (lazy Pp.(str"..a tactic")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..a tactic")); finalization s0 (fun name p -> (match p with | None -> tclUNIT () | Some p -> pose_proof name p) <*> Tacinterp.eval_tactic tac <*> if vs = [] then begin - Ssrprinters.ppdebug (lazy Pp.(str"..was the last view")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..was the last view")); conclusion ~to_clear:name <*> tclUNIT true end else Tactics.clear name <*> tclINDEPENDENTL begin - Ssrprinters.ppdebug (lazy Pp.(str"..was NOT the last view")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..was NOT the last view")); Ssrcommon.tacSIGMA >>= apply_all_views_aux ~clear_if_id vs finalization conclusion end >>= reduce_or) diff --git a/plugins/ssrmatching/g_ssrmatching.mlg b/plugins/ssrmatching/g_ssrmatching.mlg index 2252435658..7022949ab6 100644 --- a/plugins/ssrmatching/g_ssrmatching.mlg +++ b/plugins/ssrmatching/g_ssrmatching.mlg @@ -67,9 +67,9 @@ END { let input_ssrtermkind _ strm = match Util.stream_nth 0 strm with - | Tok.KEYWORD "(" -> '(' - | Tok.KEYWORD "@" -> '@' - | _ -> ' ' + | Tok.KEYWORD "(" -> InParens + | Tok.KEYWORD "@" -> WithAt + | _ -> NoFlag let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind } @@ -78,8 +78,8 @@ GRAMMAR EXTEND Gram GLOBAL: cpattern; cpattern: [[ k = ssrtermkind; c = constr -> { let pattern = mk_term k c None in - if loc_of_cpattern pattern <> Some loc && k = '(' - then mk_term 'x' c None + if loc_of_cpattern pattern <> Some loc && k = InParens + then mk_term Cpattern c None else pattern } ]]; END @@ -97,8 +97,8 @@ GRAMMAR EXTEND Gram GLOBAL: lcpattern; lcpattern: [[ k = ssrtermkind; c = lconstr -> { let pattern = mk_term k c None in - if loc_of_cpattern pattern <> Some loc && k = '(' - then mk_term 'x' c None + if loc_of_cpattern pattern <> Some loc && k = InParens + then mk_term Cpattern c None else pattern } ]]; END diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index ea014250ca..7774258fca 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -37,6 +37,8 @@ open Evar_kinds open Constrexpr open Constrexpr_ops +type ssrtermkind = | InParens | WithAt | NoFlag | Cpattern + let errorstrm = CErrors.user_err ~hdr:"ssrmatching" let loc_error loc msg = CErrors.user_err ?loc ~hdr:msg (str msg) let ppnl = Feedback.msg_info @@ -78,10 +80,10 @@ let skip_wschars s = let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop (* We also guard characters that might interfere with the ssreflect *) (* tactic syntax. *) -let guard_term ch1 s i = match s.[i] with +let guard_term kind s i = match s.[i] with | '(' -> false | '{' | '/' | '=' -> true - | _ -> ch1 = '(' + | _ -> kind = InParens (* The call 'guard s i' should return true if the contents of s *) (* starting at i need bracketing to avoid ambiguities. *) let pr_guarded guard prc c = @@ -102,14 +104,6 @@ let prl_glob_constr_and_expr env sigma = function let pr_glob_constr_and_expr env sigma = function | _, Some c -> pr_constr_expr env sigma c | c, None -> pr_glob_constr c -let pr_term (k, c, _) = - let env = Global.env () in - let sigma = Evd.from_env env in - pr_guarded (guard_term k) (pr_glob_constr_and_expr env sigma) c -let prl_term (k, c, _) = - let env = Global.env () in - let sigma = Evd.from_env env in - pr_guarded (guard_term k) (prl_glob_constr_and_expr env sigma) c (** Adding a new uninterpreted generic argument type *) let add_genarg tag pr = @@ -153,28 +147,6 @@ let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) let mkRCast rc rt = DAst.make @@ GCast (rc, dC rt) let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) -(* ssrterm conbinators *) -let combineCG t1 t2 f g = - let mk_ist i1 i2 = match i1, i2 with - | None, Some i -> Some i - | Some i, None -> Some i - | None, None -> None - | Some i, Some j when i == j -> Some i - | _ -> CErrors.anomaly (Pp.str "combineCG: different ist") in - match t1, t2 with - | (x, (t1, None), i1), (_, (t2, None), i2) -> - x, (g t1 t2, None), mk_ist i1 i2 - | (x, (_, Some t1), i1), (_, (_, Some t2), i2) -> - x, (mkRHole, Some (f t1 t2)), mk_ist i1 i2 - | _, (_, (_, None), _) -> CErrors.anomaly (str"have: mixed C-G constr.") - | _ -> CErrors.anomaly (str"have: mixed G-C constr.") -let loc_ofCG = function - | (_, (s, None), _) -> Glob_ops.loc_of_glob_constr s - | (_, (_, Some s), _) -> Constrexpr_ops.constr_loc s - -let mk_term k c ist = k, (mkRHole, Some c), ist -let mk_lterm = mk_term ' ' - let nf_evar sigma c = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr c)) @@ -313,7 +285,8 @@ let iter_constr_LR f c = match kind c with | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b | LetIn (_, v, t, b) -> f v; f t; f b | App (cf, a) -> f cf; Array.iter f a - | Case (_, p, iv, v, b) -> f v; iter_invert f iv; f p; Array.iter f b + | Case (_, _, pms, (_, p), iv, v, b) -> + f v; Array.iter f pms; f p; iter_invert f iv; Array.iter (fun (_, c) -> f c) b | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done | Proj(_,a) -> f a @@ -777,7 +750,7 @@ let rec uniquize = function EConstr.push_rel ctx_item env, h' + 1 in let self acc c = EConstr.of_constr (subst_loop acc (EConstr.Unsafe.to_constr c)) in let f = EConstr.of_constr f in - let f' = map_constr_with_binders_left_to_right sigma inc_h self acc f in + let f' = map_constr_with_binders_left_to_right env sigma inc_h self acc f in let f' = EConstr.Unsafe.to_constr f' in mkApp (f', Array.map_left (subst_loop acc) a) in subst_loop (env,h) c) : find_P), @@ -803,25 +776,15 @@ type ('ident, 'term) ssrpattern = | E_In_X_In_T of 'term * 'ident * 'term | E_As_X_In_T of 'term * 'ident * 'term -let pr_pattern = function - | T t -> prl_term t - | In_T t -> str "in " ++ prl_term t - | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t - | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t +let pr_pattern pr_ident pr_term = function + | T t -> pr_term t + | In_T t -> str "in " ++ pr_term t + | X_In_T (x,t) -> pr_ident x ++ str " in " ++ pr_term t + | In_X_In_T (x,t) -> str "in " ++ pr_ident x ++ str " in " ++ pr_term t | E_In_X_In_T (e,x,t) -> - prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t + pr_term e ++ str " in " ++ pr_ident x ++ str " in " ++ pr_term t | E_As_X_In_T (e,x,t) -> - prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t - -let pr_pattern_w_ids = function - | T t -> prl_term t - | In_T t -> str "in " ++ prl_term t - | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t - | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t - | E_In_X_In_T (e,x,t) -> - prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t - | E_As_X_In_T (e,x,t) -> - prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t + pr_term e ++ str " as " ++ pr_ident x ++ str " in " ++ pr_term t let pr_pattern_aux pr_constr = function | T t -> pr_constr t @@ -834,16 +797,53 @@ let pr_pattern_aux pr_constr = function pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t let pp_pattern env (sigma, p) = pr_pattern_aux (fun t -> pr_econstr_pat env sigma (pi3 (nf_open_term sigma sigma (EConstr.of_constr t)))) p + +type cpattern = + { kind : ssrtermkind + ; pattern : Genintern.glob_constr_and_expr + ; interpretation : Geninterp.interp_sign option } + +let pr_term {kind; pattern; _} = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_guarded (guard_term kind) (pr_glob_constr_and_expr env sigma) pattern +let prl_term {kind; pattern; _} = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_guarded (guard_term kind) (prl_glob_constr_and_expr env sigma) pattern + let pr_cpattern = pr_term -let wit_rpatternty = add_genarg "rpatternty" (fun env sigma -> pr_pattern) +let pr_pattern_w_ids = pr_pattern pr_id prl_term + +let mk_term k c ist = {kind=k; pattern=(mkRHole, Some c); interpretation=ist} +let mk_lterm = mk_term NoFlag let glob_ssrterm gs = function - | k, (_, Some c), None -> - let x = Tacintern.intern_constr gs c in - k, (fst x, Some c), None + | {kind; pattern=(_, Some c); interpretation=None} -> + let x = Tacintern.intern_constr gs c in + {kind; pattern=(fst x, Some c); interpretation=None} | ct -> ct +(* ssrterm conbinators *) +let combineCG t1 t2 f g = + let mk_ist i1 i2 = match i1, i2 with + | None, Some i -> Some i + | Some i, None -> Some i + | None, None -> None + | Some i, Some j when i == j -> Some i + | _ -> CErrors.anomaly (Pp.str "combineCG: different ist") in + match t1, t2 with + | {kind=x; pattern=(t1, None); interpretation=i1}, {pattern=(t2, None); interpretation=i2} -> + {kind=x; pattern=(g t1 t2, None); interpretation = mk_ist i1 i2} + | {kind=x; pattern=(_, Some t1); interpretation=i1}, {pattern=(_, Some t2); interpretation=i2} -> + {kind=x; pattern=(mkRHole, Some (f t1 t2)); interpretation = mk_ist i1 i2} + | _, {pattern=(_, None); _} -> CErrors.anomaly (str"have: mixed C-G constr.") + | _ -> CErrors.anomaly (str"have: mixed G-C constr.") +let loc_ofCG = function + | {pattern = (s, None); _} -> Glob_ops.loc_of_glob_constr s + | {pattern = (_, Some s); _} -> Constrexpr_ops.constr_loc s + (* This piece of code asserts the following notations are reserved *) (* Reserved Notation "( a 'in' b )" (at level 0). *) (* Reserved Notation "( a 'as' b )" (at level 0). *) @@ -851,19 +851,19 @@ let glob_ssrterm gs = function (* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *) let glob_cpattern gs p = pp(lazy(str"globbing pattern: " ++ pr_term p)); - let glob x = pi2 (glob_ssrterm gs (mk_lterm x None)) in + let glob x = (glob_ssrterm gs (mk_lterm x None)).pattern in let encode k s l = let name = Name (Id.of_string ("_ssrpat_" ^ s)) in - k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None), None in + {kind=k; pattern=(mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None); interpretation=None} in let bind_in t1 t2 = let mkCHole = mkCHole ~loc:None in let n = Name (destCVar t1) in fst (glob (mkCCast mkCHole (mkCLambda n mkCHole t2))) in let check_var t2 = if not (isCVar t2) then loc_error (constr_loc t2) "Only identifiers are allowed here" in match p with - | _, (_, None), _ as x -> x - | k, (v, Some t), _ as orig -> - if k = 'x' then glob_ssrterm gs ('(', (v, Some t), None) else + | {pattern = (_, None); _} as x -> x + | {kind=k; pattern=(v, Some t); _} as orig -> + if k = Cpattern then glob_ssrterm gs {kind=InParens; pattern=(v, Some t); interpretation=None} else match t.CAst.v with | CNotation(_,(InConstrEntry,"( _ in _ )"), ([t1; t2], [], [], [])) -> (try match glob t1, glob t2 with @@ -891,8 +891,8 @@ let glob_rpattern s p = | E_In_X_In_T(e,x,t) -> E_In_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) | E_As_X_In_T(e,x,t) -> E_As_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) -let subst_ssrterm s (k, c, ist) = - k, Tacsubst.subst_glob_constr_and_expr s c, ist +let subst_ssrterm s {kind; pattern; interpretation} = + {kind; pattern=Tacsubst.subst_glob_constr_and_expr s pattern; interpretation} let subst_rpattern s = function | T t -> T (subst_ssrterm s t) @@ -902,7 +902,7 @@ let subst_rpattern s = function | E_In_X_In_T(e,x,t) -> E_In_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) | E_As_X_In_T(e,x,t) -> E_As_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) -let interp_ssrterm ist (k,t,_) = k, t, Some ist +let interp_ssrterm ist {kind; pattern; _} = {kind; pattern; interpretation = Some ist} let interp_rpattern s = function | T t -> T (interp_ssrterm s t) @@ -910,23 +910,24 @@ let interp_rpattern s = function | X_In_T(x,t) -> X_In_T (interp_ssrterm s x,interp_ssrterm s t) | In_X_In_T(x,t) -> In_X_In_T (interp_ssrterm s x,interp_ssrterm s t) | E_In_X_In_T(e,x,t) -> - E_In_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) + E_In_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) | E_As_X_In_T(e,x,t) -> - E_As_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) + E_As_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) let interp_rpattern0 ist gl t = Tacmach.project gl, interp_rpattern ist t -type cpattern = char * Genintern.glob_constr_and_expr * Geninterp.interp_sign option -let tag_of_cpattern = pi1 +let tag_of_cpattern p = p.kind let loc_of_cpattern = loc_ofCG -let cpattern_of_term (c, t) ist = c, t, Some ist type occ = (bool * int list) option type rpattern = (cpattern, cpattern) ssrpattern +let pr_rpattern = pr_pattern pr_cpattern pr_cpattern + +let wit_rpatternty = add_genarg "rpatternty" (fun env sigma -> pr_pattern pr_cpattern pr_cpattern) type pattern = Evd.evar_map * (constr, constr) ssrpattern -let id_of_cpattern (_, (c1, c2), _) = +let id_of_cpattern {pattern = (c1, c2); _} = let open CAst in match DAst.get c1, c2 with | _, Some { v = CRef (qid, _) } when qualid_is_ident qid -> @@ -941,12 +942,12 @@ let id_of_Cterm t = match id_of_cpattern t with 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 pf_intern_term env sigma {pattern = c; interpretation = ist; _} = glob_constr ist env sigma c let interp_ssrterm ist gl t = Tacmach.project gl, interp_ssrterm ist t let interp_term env sigma = function - | (_, c, Some ist) -> + | {pattern = c; interpretation = Some ist; _} -> on_snd EConstr.Unsafe.to_constr (interp_open_constr ist env sigma c) | _ -> errorstrm (str"interpreting a term with no ist") @@ -974,17 +975,17 @@ let pr_ist { lfun= lfun } = *) let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = - pp(lazy(str"interpreting: " ++ pr_pattern red)); + pp(lazy(str"interpreting: " ++ pr_rpattern 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 let eAsXInT e x t = E_As_X_In_T(e,x,t) in - let mkG ?(k=' ') x ist = k,(x,None), ist in - let ist_of (_,_,ist) = ist in - let decode (_,_,ist as t) ?reccall f g = + let mkG ?(k=NoFlag) x ist = {kind = k; pattern = (x,None); interpretation = ist } in + let ist_of x = x.interpretation in + let decode ({interpretation=ist; _} as t) ?reccall f g = 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) + f x {kind = NoFlag; pattern = (c,None); interpretation = ist} | GVar id when Option.has_some ist && let ist = Option.get ist in Id.Map.mem id ist.lfun && @@ -1027,7 +1028,7 @@ let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = sigma new_evars in sigma in let red = let rec decode_red = function - | T(k,(t,None),ist) -> + | T {kind=k; pattern=(t,None); interpretation=ist} -> begin match DAst.get t with | GCast (c,CastConv t) when isGHole c && @@ -1058,7 +1059,7 @@ let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = let red = match redty with | None -> red - | Some (ty, ist) -> let ty = ' ', ty, Some ist in + | Some (ty, ist) -> let ty = {kind=NoFlag; pattern=ty; interpretation = Some ist} in match red with | T t -> T (combineCG t ty (mkCCast ?loc:(loc_ofCG t)) mkRCast) | X_In_T (x,t) -> @@ -1072,9 +1073,12 @@ let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = 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)); - let mkXLetIn ?loc x (a,(g,c),ist) = match c with - | 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 + let mkXLetIn ?loc x {kind; pattern=(g,c); interpretation} = match c with + | Some b -> {kind; pattern=(g,Some (mkCLetIn ?loc x (mkCHole ~loc) b)); interpretation} + | None -> { kind + ; pattern = DAst.make ?loc @@ GLetIn + (x, DAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None + ; interpretation} in match red with | 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 @@ -1255,16 +1259,16 @@ let pf_fill_occ_term gl occ t = cl, t let cpattern_of_id id = - ' ', (DAst.make @@ GRef (GlobRef.VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty }) + { kind= NoFlag + ; pattern = DAst.make @@ GRef (GlobRef.VarRef id, None), None + ; interpretation = Some Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty })} -let is_wildcard ((_, (l, r), _) : cpattern) : bool = match DAst.get l, r with +let is_wildcard ({pattern = (l, r); _} : cpattern) : bool = match DAst.get l, r with | _, Some { CAst.v = CHole _ } | GHole _, None -> true | _ -> false (* "ssrpattern" *) -let pr_rpattern = pr_pattern - let pf_merge_uc uc gl = re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc) diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 17b47227cb..2b90cef039 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -20,17 +20,16 @@ open Genintern (** Pattern parsing *) +type ssrtermkind = | InParens | WithAt | NoFlag | Cpattern + (** The type of context patterns, the patterns of the [set] tactic and [:] tactical. These are patterns that identify a precise subterm. *) -type cpattern +type cpattern = + { kind : ssrtermkind + ; pattern : Genintern.glob_constr_and_expr + ; interpretation : Geninterp.interp_sign option } val pr_cpattern : cpattern -> Pp.t -(** The type of rewrite patterns, the patterns of the [rewrite] tactic. - These patterns also include patterns that identify all the subterms - of a context (i.e. "in" prefix) *) -type rpattern -val pr_rpattern : rpattern -> Pp.t - (** Pattern interpretation and matching *) exception NoMatch @@ -48,6 +47,12 @@ type ('ident, 'term) ssrpattern = type pattern = evar_map * (constr, constr) ssrpattern val pp_pattern : env -> pattern -> Pp.t +(** The type of rewrite patterns, the patterns of the [rewrite] tactic. + These patterns also include patterns that identify all the subterms + of a context (i.e. "in" prefix) *) +type rpattern = (cpattern, cpattern) ssrpattern +val pr_rpattern : rpattern -> Pp.t + (** Extracts the redex and applies to it the substitution part of the pattern. @raise Anomaly if called on [In_T] or [In_X_In_T] *) val redex_of_pattern : @@ -193,9 +198,6 @@ val pf_fill_occ_term : goal sigma -> occ -> evar_map * 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 - (** Helpers to make stateful closures. Example: a [find_P] function may be called many times, but the pattern instantiation phase is performed only the first time. The corresponding [conclude] has to return the instantiated @@ -219,7 +221,7 @@ val pf_unify_HO : goal sigma -> EConstr.constr -> EConstr.constr -> goal sigma (** Some more low level functions needed to implement the full SSR language on top of the former APIs *) -val tag_of_cpattern : cpattern -> char +val tag_of_cpattern : cpattern -> ssrtermkind val loc_of_cpattern : cpattern -> Loc.t option val id_of_pattern : pattern -> Names.Id.t option val is_wildcard : cpattern -> bool @@ -245,7 +247,7 @@ sig val pr_rpattern : rpattern -> Pp.t val mk_rpattern : (cpattern, cpattern) ssrpattern -> rpattern val mk_lterm : Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern - val mk_term : char -> Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern + val mk_term : ssrtermkind -> Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern val glob_cpattern : Genintern.glob_sign -> cpattern -> cpattern val subst_ssrterm : Mod_subst.substitution -> cpattern -> cpattern diff --git a/plugins/syntax/number.ml b/plugins/syntax/number.ml index 89d757a72a..0e7640f430 100644 --- a/plugins/syntax/number.ml +++ b/plugins/syntax/number.ml @@ -387,10 +387,10 @@ let locate_global_inductive allow_params qid = | Globnames.TrueGlobal _ -> raise Not_found | Globnames.SynDef kn -> match Syntax_def.search_syntactic_definition kn with - | [], Notation_term.(NApp (NRef (GlobRef.IndRef i), l)) when allow_params -> + | [], Notation_term.(NApp (NRef (GlobRef.IndRef i,None), l)) when allow_params -> i, List.map (function - | Notation_term.NRef r -> Some r + | Notation_term.NRef (r,None) -> Some r | Notation_term.NHole _ -> None | _ -> raise Not_found) l | _ -> raise Not_found in |