diff options
Diffstat (limited to 'plugins')
49 files changed, 357 insertions, 364 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/cctac.ml b/plugins/cc/cctac.ml index 23a7b89d2c..72f77508d8 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -420,7 +420,7 @@ 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 (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 sol = execute true state in @@ -429,55 +429,55 @@ let cc_tactic depth additionnal_terms = match sol with None -> Tacticals.New.tclFAIL 0 (str "congruence failed") | Some reason -> - debug (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 - let cstr=(get_constructor_info uf ipac.cnode).ci_constr in - discriminate_tac cstr p - | Incomplete -> - let open Glob_term in - let env = Proofview.Goal.env gl in - let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in - let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in - let pr_missing (c, missing) = - let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in - let holes = List.init missing (fun _ -> hole) in - Printer.pr_glob_constr_env env sigma (DAst.make @@ GApp (c, holes)) - in - let msg = Pp.(str "Goal is solvable by congruence but some arguments are missing." - ++ fnl () ++ - str " Try " ++ - hov 8 - begin - str "\"congruence with (" ++ prlist_with_sep (fun () -> str ")" ++ spc () ++ str "(") - pr_missing terms_to_complete ++ str ")\"," - end ++ - str " replacing metavariables by arbitrary terms.") in - Tacticals.New.tclFAIL 0 msg - | Contradiction dis -> - let env = Proofview.Goal.env gl in - let p=build_proof env sigma uf (`Prove (dis.lhs,dis.rhs)) in - let ta=term uf dis.lhs and tb=term uf dis.rhs in - match dis.rule with - Goal -> proof_tac p - | Hyp id -> refute_tac (EConstr.of_constr id) ta tb p - | HeqG id -> - let id = EConstr.of_constr id in - convert_to_goal_tac id ta tb p - | HeqnH (ida,idb) -> - let ida = EConstr.of_constr ida in - let idb = EConstr.of_constr idb in - convert_to_hyp_tac ida ta idb tb p + debug (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 + let cstr=(get_constructor_info uf ipac.cnode).ci_constr in + discriminate_tac cstr p + | Incomplete -> + let open Glob_term in + let env = Proofview.Goal.env gl in + let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in + let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in + let pr_missing (c, missing) = + let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in + let holes = List.init missing (fun _ -> hole) in + Printer.pr_glob_constr_env env sigma (DAst.make @@ GApp (c, holes)) + in + let msg = Pp.(str "Goal is solvable by congruence but some arguments are missing." + ++ fnl () ++ + str " Try " ++ + hov 8 + begin + str "\"congruence with (" ++ + prlist_with_sep + (fun () -> str ")" ++ spc () ++ str "(") + pr_missing terms_to_complete ++ + str ")\"," + end ++ + fnl() ++ str " replacing metavariables by arbitrary terms") + in + Tacticals.New.tclFAIL 0 msg + | Contradiction dis -> + let env = Proofview.Goal.env gl in + let p=build_proof env sigma uf (`Prove (dis.lhs,dis.rhs)) in + let ta=term uf dis.lhs and tb=term uf dis.rhs in + match dis.rule with + Goal -> proof_tac p + | Hyp id -> refute_tac (EConstr.of_constr id) ta tb p + | HeqG id -> + let id = EConstr.of_constr id in + convert_to_goal_tac id ta tb p + | HeqnH (ida,idb) -> + let ida = EConstr.of_constr ida in + let idb = EConstr.of_constr idb in + convert_to_hyp_tac ida ta idb tb p end -let cc_fail = - Tacticals.New.tclZEROMSG (Pp.str "congruence failed.") let congruence_tac depth l = - Tacticals.New.tclORELSE - (Tacticals.New.tclTHEN (Tacticals.New.tclREPEAT introf) (cc_tactic depth l)) - cc_fail + Tacticals.New.tclTHEN (Tacticals.New.tclREPEAT introf) (cc_tactic depth l) (* Beware: reflexivity = constructor 1 = apply refl_equal might be slow now, let's rather do something equivalent diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli index 52fc3acb6f..79c7d2c676 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -14,8 +14,6 @@ val proof_tac: Ccproof.proof -> unit Proofview.tactic val cc_tactic : int -> constr list -> unit Proofview.tactic -val cc_fail : unit Proofview.tactic - val congruence_tac : int -> constr list -> unit Proofview.tactic val f_equal : unit Proofview.tactic 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 33076a876b..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, t, 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 0b5d36b845..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 (**********************************************************************) @@ -608,7 +608,7 @@ END { let subst_var_with_hole occ tid t = - let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in + let occref = if occ > 0 then ref occ else Locusops.error_invalid_occurrence [occ] in let locref = ref 0 in let rec substrec x = match DAst.get x with | GVar id -> @@ -628,7 +628,7 @@ let subst_var_with_hole occ tid t = | _ -> map_glob_constr_left_to_right substrec x in let t' = substrec t in - if !occref > 0 then Find_subterm.error_invalid_occurrence [occ] else t' + if !occref > 0 then Locusops.error_invalid_occurrence [occ] else t' let subst_hole_with_term occ tc t = let locref = ref 0 in @@ -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/pltac.ml b/plugins/ltac/pltac.ml index 80c13a3698..196a68e67c 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -47,6 +47,8 @@ let binder_tactic = Entry.create "binder_tactic" let tactic = Entry.create "tactic" (* Main entry for quotations *) +let tactic_eoi = eoi_entry tactic + let () = let open Stdarg in let open Tacarg in diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 73bce84d18..c0bf6b9f76 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -40,3 +40,4 @@ val tactic_expr : raw_tactic_expr Entry.t [@@deprecated "Deprecated in 8.13; use 'ltac_expr' instead"] val binder_tactic : raw_tactic_expr Entry.t val tactic : raw_tactic_expr Entry.t +val tactic_eoi : raw_tactic_expr Entry.t 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 77162ce89a..6d0e0c36b3 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -855,26 +855,20 @@ let coerce env cstr res = let res = { res with rew_evars = evars } in apply_constraint env res.rew_car rel prf cstr res -let apply_rule unify loccs : int pure_strategy = - let (nowhere_except_in,occs) = convert_occs loccs in - let is_occ occ = - if nowhere_except_in - then List.mem occ occs - else not (List.mem occ occs) - in - { strategy = fun { state = occ ; env ; +let apply_rule unify : occurrences_count pure_strategy = + { strategy = fun { state = occs ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> let unif = if isEvar (goalevars evars) t then None else unify env evars t in match unif with - | None -> (occ, Fail) + | None -> (occs, Fail) | Some rew -> - let occ = succ occ in - if not (is_occ occ) then (occ, Fail) - else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occ, Identity) + let b, occs = update_occurrence_counter occs in + if not b then (occs, Fail) + else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occs, Identity) else let res = { rew with rew_car = ty } in let res = Success (coerce env cstr res) in - (occ, res) + (occs, res) } let apply_lemma l2r flags oc by loccs : strategy = { strategy = @@ -890,9 +884,10 @@ let apply_lemma l2r flags oc by loccs : strategy = { strategy = | None -> None | Some rew -> Some rew in - let _, res = (apply_rule unify loccs).strategy { input with - state = 0 ; + let loccs, res = (apply_rule unify).strategy { input with + state = initialize_occurrence_counter loccs ; evars } in + check_used_occurrences loccs; (), res } @@ -923,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 = @@ -991,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' = @@ -1158,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 @@ -1168,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 -> @@ -1190,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 @@ -1391,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 @@ -1423,12 +1420,13 @@ let rewrite_with l2r flags c occs : strategy = { strategy = let (sigma, rew) = refresh_hypinfo env sigma c in unify_eqn rew l2r flags env (sigma, cstrs) None t in - let app = apply_rule unify occs in + let app = apply_rule unify in let strat = Strategies.fix (fun aux -> Strategies.choice app (subterm true default_flags aux)) in - let _, res = strat.strategy { input with state = 0 } in + let occs, res = strat.strategy { input with state = initialize_occurrence_counter occs } in + check_used_occurrences occs; ((), res) } @@ -2076,11 +2074,12 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals = Proofview.Goal.enter begin fun gl -> let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in let unify env evars t = unify_abs res l2r sort env evars t in - let app = apply_rule unify occs in + let app = apply_rule unify in let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in let substrat = Strategies.fix recstrat in let strat = { strategy = fun ({ state = () } as input) -> - let _, res = substrat.strategy { input with state = 0 } in + let occs, res = substrat.strategy { input with state = initialize_occurrence_counter occs } in + check_used_occurrences occs; (), res } in diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 4c1fe6417e..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 @@ -429,7 +430,15 @@ let pr_value env v = | TopPrinterNeedsContextAndLevel { default_already_surrounded; printer } -> pr_with_env (fun env sigma -> printer env sigma default_already_surrounded) -let error_ltac_variable ?loc id env v s = - CErrors.user_err ?loc (str "Ltac variable " ++ Id.print id ++ +exception CoercionError of Id.t * (Environ.env * Evd.evar_map) option * Val.t * string + +let () = CErrors.register_handler begin function +| CoercionError (id, env, v, s) -> + Some (str "Ltac variable " ++ Id.print id ++ strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ strbrk "which cannot be coerced to " ++ str s ++ str".") +| _ -> None +end + +let error_ltac_variable ?loc id env v s = + Loc.raise ?loc (CoercionError (id, env, v, s)) 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..ed608bb1df 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 *) 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/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..4d57abb465 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -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 diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index fdfba48024..0008d31ffd 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -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 @@ -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..f2c7f495b3 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 diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 46f90a7ee1..1e940b5ad3 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -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..6ed68094dc 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -28,16 +28,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 +35,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. *) diff --git a/plugins/ssr/ssrprinters.mli b/plugins/ssr/ssrprinters.mli index 87eb05b667..21fb28038a 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 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/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/int63_syntax.ml b/plugins/syntax/int63_syntax.ml index b14b02f3bb..110b26581f 100644 --- a/plugins/syntax/int63_syntax.ml +++ b/plugins/syntax/int63_syntax.ml @@ -20,14 +20,14 @@ open Libnames (*** Constants for locating int63 constructors ***) -let q_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.Int63.int" -let q_id_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.Int63.id_int" +let q_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.PrimInt63.int" +let q_id_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.PrimInt63.id_int" let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) (* int63 stuff *) -let int63_module = ["Coq"; "Numbers"; "Cyclic"; "Int63"; "Int63"] +let int63_module = ["Coq"; "Numbers"; "Cyclic"; "Int63"; "PrimInt63"] let int63_path = make_path int63_module "int" let int63_scope = "int63_scope" 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 |