diff options
Diffstat (limited to 'tactics')
36 files changed, 2752 insertions, 2586 deletions
diff --git a/tactics/auto.ml b/tactics/auto.ml index fc6ff03b4b..7558a707ec 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -10,7 +10,7 @@ *) open Pp open Util -open Errors +open CErrors open Names open Vars open Termops @@ -20,7 +20,6 @@ open Genredexpr open Tactics open Tacticals open Clenv -open Tacexpr open Locus open Proofview.Notations open Hints @@ -35,6 +34,10 @@ open Hints let priority l = List.filter (fun (_, hint) -> Int.equal hint.pri 0) l +let compute_secvars gl = + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + secvars_of_hyps hyps + (* tell auto not to reuse already instantiated metas in unification (for compatibility, since otherwise, apply succeeds oftener) *) @@ -94,7 +97,7 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl = let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in { clenv with evd = evd ; env = Proofview.Goal.env gl }, c in clenv, c - + let unify_resolve poly flags ((c : raw_hint), clenv) = Proofview.Goal.nf_enter { enter = begin fun gl -> let clenv, c = connect_hint_clenv poly c clenv gl in @@ -109,21 +112,11 @@ let unify_resolve_gen poly = function | Some flags -> unify_resolve poly flags let exact poly (c,clenv) = - let (c, _, _) = c in - let ctx, c' = - if poly then - let evd', subst = Evd.refresh_undefined_universes clenv.evd in - let ctx = Evd.evar_universe_context evd' in - ctx, subst_univs_level_constr subst c - else - let ctx = Evd.evar_universe_context clenv.evd in - ctx, c - in - Proofview.Goal.s_enter { s_enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in - let sigma = Evd.merge_universe_context sigma ctx in - Sigma.Unsafe.of_pair (exact_check c', sigma) + Proofview.Goal.enter { enter = begin fun gl -> + let clenv', c = connect_hint_clenv poly c clenv gl in + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) + (exact_check c) end } (* Util *) @@ -156,11 +149,16 @@ let conclPattern concl pat tac = constr_bindings env sigma >>= fun constr_bindings -> let open Genarg in let open Geninterp in - let inj c = Val.Dyn (val_tag (topwit Constrarg.wit_constr), c) in + let inj c = match val_tag (topwit Stdarg.wit_constr) with + | Val.Base tag -> Val.Dyn (tag, c) + | _ -> assert false + in let fold id c accu = Id.Map.add id (inj c) accu in let lfun = Id.Map.fold fold constr_bindings Id.Map.empty in let ist = { lfun; extra = TacStore.empty } in - Ftactic.run (Geninterp.generic_interp ist tac) (fun _ -> Proofview.tclUNIT ()) + match tac with + | GenArg (Glbwit wit, tac) -> + Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) end } (***********************************************************) @@ -224,11 +222,11 @@ let tclLOG (dbg,depth,trace) pp tac = Proofview.V82.tactic begin fun gl -> try let out = Proofview.V82.of_tactic tac gl in - msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); + Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); out with reraise -> - let reraise = Errors.push reraise in - msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); + let reraise = CErrors.push reraise in + Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); iraise reraise end | Info -> @@ -239,7 +237,7 @@ let tclLOG (dbg,depth,trace) pp tac = trace := (depth, Some pp) :: !trace; out with reraise -> - let reraise = Errors.push reraise in + let reraise = CErrors.push reraise in trace := (depth, None) :: !trace; iraise reraise end @@ -261,35 +259,29 @@ and erase_subtree depth = function | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l let pr_info_atom (d,pp) = - str (String.make d ' ') ++ pp () ++ str "." + str (String.make (d-1) ' ') ++ pp () ++ str "." let pr_info_trace = function | (Info,_,{contents=(d,Some pp)::l}) -> - prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l) - | _ -> mt () + Feedback.msg_info (prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)) + | _ -> () let pr_info_nop = function - | (Info,_,_) -> str "idtac." - | _ -> mt () + | (Info,_,_) -> Feedback.msg_info (str "idtac.") + | _ -> () let pr_dbg_header = function - | (Off,_,_) -> mt () - | (Debug,0,_) -> str "(* debug trivial : *)" - | (Debug,_,_) -> str "(* debug auto : *)" - | (Info,0,_) -> str "(* info trivial : *)" - | (Info,_,_) -> str "(* info auto : *)" + | (Off,_,_) -> () + | (Debug,0,_) -> Feedback.msg_debug (str "(* debug trivial: *)") + | (Debug,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") + | (Info,0,_) -> Feedback.msg_info (str "(* info trivial: *)") + | (Info,_,_) -> Feedback.msg_info (str "(* info auto: *)") let tclTRY_dbg d tac = - let (level, _, _) = d in let delay f = Proofview.tclUNIT () >>= fun () -> f () in - let tac = match level with - | Off -> tac - | Debug | Info -> delay (fun () -> msg_debug (pr_dbg_header d ++ fnl () ++ pr_info_trace d); tac) - in - let after = match level with - | Info -> delay (fun () -> msg_debug (pr_info_nop d); Proofview.tclUNIT ()) - | Off | Debug -> Proofview.tclUNIT () - in + let tac = delay (fun () -> pr_dbg_header d; tac) >>= + fun () -> pr_info_trace d; Proofview.tclUNIT () in + let after = delay (fun () -> pr_info_nop d; Proofview.tclUNIT ()) in Tacticals.New.tclORELSE0 tac after (**************************************************************************) @@ -306,12 +298,13 @@ let flags_of_state st = let auto_flags_of_state st = auto_unif_flags_of full_transparent_state st false -let hintmap_of hdc concl = +let hintmap_of secvars hdc concl = match hdc with - | None -> Hint_db.map_none + | None -> Hint_db.map_none ~secvars | Some hdc -> - if occur_existential concl then Hint_db.map_existential hdc concl - else Hint_db.map_auto hdc concl + if occur_existential concl then + Hint_db.map_existential ~secvars hdc concl + else Hint_db.map_auto ~secvars hdc concl let exists_evaluable_reference env = function | EvalConstRef _ -> true @@ -336,22 +329,23 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = in Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in + let secvars = compute_secvars gl in Tacticals.New.tclFIRST ((dbg_assumption dbg)::intro_tac:: (List.map Tacticals.New.tclCOMPLETE - (trivial_resolve dbg mod_delta db_list local_db concl))) + (trivial_resolve dbg mod_delta db_list local_db secvars concl))) end } -and my_find_search_nodelta db_list local_db hdc concl = +and my_find_search_nodelta db_list local_db secvars hdc concl = List.map (fun hint -> (None,hint)) - (List.map_append (hintmap_of hdc concl) (local_db::db_list)) + (List.map_append (hintmap_of secvars hdc concl) (local_db::db_list)) and my_find_search mod_delta = if mod_delta then my_find_search_delta else my_find_search_nodelta -and my_find_search_delta db_list local_db hdc concl = - let f = hintmap_of hdc concl in +and my_find_search_delta db_list local_db secvars hdc concl = + let f = hintmap_of secvars hdc concl in if occur_existential concl then List.map_append (fun db -> @@ -371,16 +365,16 @@ and my_find_search_delta db_list local_db hdc concl = let (ids, csts as st) = Hint_db.transparent_state db in let flags, l = let l = - match hdc with None -> Hint_db.map_none db + match hdc with None -> Hint_db.map_none ~secvars db | Some hdc -> if (Id.Pred.is_empty ids && Cpred.is_empty csts) - then Hint_db.map_auto hdc concl db - else Hint_db.map_existential hdc concl db + then Hint_db.map_auto ~secvars hdc concl db + else Hint_db.map_existential ~secvars hdc concl db in auto_flags_of_state st, l in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) -and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) = +and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db=dbname})) = let tactic = function | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl) | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf") @@ -399,9 +393,16 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) | Extern tacast -> conclPattern concl p tacast in - tclLOG dbg (fun () -> pr_hint t) (run_hint t tactic) + let pr_hint () = + let origin = match dbname with + | None -> mt () + | Some n -> str " (in " ++ str n ++ str ")" + in + pr_hint t ++ origin + in + tclLOG dbg pr_hint (run_hint t tactic) -and trivial_resolve dbg mod_delta db_list local_db cl = +and trivial_resolve dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound cl in @@ -410,7 +411,7 @@ and trivial_resolve dbg mod_delta db_list local_db cl = in List.map (tac_of_hint dbg db_list local_db cl) (priority - (my_find_search mod_delta db_list local_db head cl)) + (my_find_search mod_delta db_list local_db secvars head cl)) with Not_found -> [] (** The use of the "core" database can be de-activated by passing @@ -448,7 +449,7 @@ let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l (* The classical Auto tactic *) (**************************************************************************) -let possible_resolve dbg mod_delta db_list local_db cl = +let possible_resolve dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound cl in @@ -456,7 +457,7 @@ let possible_resolve dbg mod_delta db_list local_db cl = with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) - (my_find_search mod_delta db_list local_db head cl) + (my_find_search mod_delta db_list local_db secvars head cl) with Not_found -> [] let extend_local_db decl db gl = @@ -487,11 +488,12 @@ let search d n mod_delta db_list local_db = (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) ( Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in + let secvars = compute_secvars gl in let d' = incr_dbg d in Tacticals.New.tclFIRST (List.map (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) - (possible_resolve d mod_delta db_list local_db concl)) + (possible_resolve d mod_delta db_list local_db secvars concl)) end })) end [] in diff --git a/tactics/auto.mli b/tactics/auto.mli index 8c4f359041..de0dbd4831 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -6,24 +6,25 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** This files implements auto and related automation tactics *) + open Names open Term open Clenv open Pattern open Decl_kinds open Hints +open Tactypes -(** Auto and related automation tactics *) - -val priority : ('a * full_hint) list -> ('a * full_hint) list +val compute_secvars : ('a,'b) Proofview.Goal.t -> Id.Pred.t val default_search_depth : int ref val auto_flags_of_state : transparent_state -> Unification.unify_flags val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> - ([ `NF ], 'r) Proofview.Goal.t -> clausenv * constr - + ('a, 'r) Proofview.Goal.t -> clausenv * constr + (** Try unification with the precompiled clause, then use registered Apply *) val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clausenv) -> unit Proofview.tactic @@ -39,45 +40,43 @@ val conclPattern : constr -> constr_pattern option -> Genarg.glob_generic_argume (** The use of the "core" database can be de-activated by passing "nocore" amongst the databases. *) -val auto : ?debug:Tacexpr.debug -> - int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic +val auto : ?debug:debug -> + int -> delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** Auto with more delta. *) -val new_auto : ?debug:Tacexpr.debug -> - int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic +val new_auto : ?debug:debug -> + int -> delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** auto with default search depth and with the hint database "core" *) val default_auto : unit Proofview.tactic -(** auto with all hint databases except the "v62" compatibility database *) -val full_auto : ?debug:Tacexpr.debug -> - int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic +(** auto with all hint databases *) +val full_auto : ?debug:debug -> + int -> delayed_open_constr list -> unit Proofview.tactic -(** auto with all hint databases except the "v62" compatibility database - and doing delta *) -val new_full_auto : ?debug:Tacexpr.debug -> - int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic +(** auto with all hint databases and doing delta *) +val new_full_auto : ?debug:debug -> + int -> delayed_open_constr list -> unit Proofview.tactic -(** auto with default search depth and with all hint databases - except the "v62" compatibility database *) +(** auto with default search depth and with all hint databases *) val default_full_auto : unit Proofview.tactic (** The generic form of auto (second arg [None] means all bases) *) -val gen_auto : ?debug:Tacexpr.debug -> - int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic +val gen_auto : ?debug:debug -> + int option -> delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** The hidden version of auto *) -val h_auto : ?debug:Tacexpr.debug -> - int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic +val h_auto : ?debug:debug -> + int option -> delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** Trivial *) -val trivial : ?debug:Tacexpr.debug -> - Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic -val gen_trivial : ?debug:Tacexpr.debug -> - Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic -val full_trivial : ?debug:Tacexpr.debug -> - Tacexpr.delayed_open_constr list -> unit Proofview.tactic -val h_trivial : ?debug:Tacexpr.debug -> - Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic +val trivial : ?debug:debug -> + delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic +val gen_trivial : ?debug:debug -> + delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic +val full_trivial : ?debug:debug -> + delayed_open_constr list -> unit Proofview.tactic +val h_trivial : ?debug:debug -> + delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 4816f8a452..dae1cc9f1b 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -13,12 +13,10 @@ open Tacticals open Tactics open Term open Termops -open Errors +open CErrors open Util -open Tacexpr open Mod_subst open Locus -open Sigma.Notations open Proofview.Notations (* Rewriting rules *) @@ -67,7 +65,7 @@ let raw_find_base bas = String.Map.find bas !rewtab let find_base bas = try raw_find_base bas with Not_found -> - errorlabstrm "AutoRewrite" + user_err ~hdr:"AutoRewrite" (str "Rewriting base " ++ str bas ++ str " does not exist.") let find_rewrites bas = @@ -85,7 +83,7 @@ let print_rewrite_hintdb bas = str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ Option.cata (fun tac -> str " then use tactic " ++ - Pptactic.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) + Pputils.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option @@ -106,9 +104,9 @@ let one_base general_rewrite_maybe_in tac_main bas = let lrul = List.map (fun h -> let tac = match h.rew_tac with | None -> Proofview.tclUNIT () - | Some tac -> + | Some (Genarg.GenArg (Genarg.Glbwit wit, tac)) -> let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in - Ftactic.run (Geninterp.generic_interp ist tac) (fun _ -> Proofview.tclUNIT ()) + Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) in (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> @@ -153,7 +151,7 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = begin let gl'' = if !to_be_cleared then - tclTHEN (fun _ -> gl') (tclTRY (clear [!id])) gl + tclTHEN (fun _ -> gl') (tclTRY (Proofview.V82.of_tactic (clear [!id]))) gl else gl' in id := lastid ; to_be_cleared := true ; @@ -296,8 +294,8 @@ let find_applied_relation metas loc env sigma c left2right = match decompose_applied_relation metas env sigma c ctype left2right with | Some c -> c | None -> - user_err_loc (loc, "decompose_applied_relation", - str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ + user_err ~loc ~hdr:"decompose_applied_relation" + (str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ spc () ++ str"of this term does not end with an applied relation.") (* To add rewriting rules to a base *) diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index ac613b57ce..49e8588da3 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -6,8 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** This files implements the autorewrite tactic. *) + open Term -open Tacexpr open Equality (** Rewriting rules before tactic interpretation *) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 311ae19719..a85afcbf09 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -6,8 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(* TODO: + - Find an interface allowing eauto to backtrack when shelved goals remain, + e.g. to force instantiations. + *) + open Pp -open Errors +open CErrors open Util open Names open Term @@ -26,15 +31,27 @@ open Misctypes open Proofview.Notations open Hints +module NamedDecl = Context.Named.Declaration + (** Hint database named "typeclass_instances", now created directly in Auto *) -let typeclasses_debug = ref false +(** Options handling *) + +let typeclasses_debug = ref 0 let typeclasses_depth = ref None let typeclasses_modulo_eta = ref false let set_typeclasses_modulo_eta d = (:=) typeclasses_modulo_eta d let get_typeclasses_modulo_eta () = !typeclasses_modulo_eta +(** When this flag is enabled, the resolution of type classes tries to avoid + useless introductions. This is no longer useful since we have eta, but is + here for compatibility purposes. Another compatibility issues is that the + cost (in terms of search depth) can differ. *) +let typeclasses_limit_intros = ref true +let set_typeclasses_limit_intros d = (:=) typeclasses_limit_intros d +let get_typeclasses_limit_intros () = !typeclasses_limit_intros + let typeclasses_dependency_order = ref false let set_typeclasses_dependency_order d = (:=) typeclasses_dependency_order d let get_typeclasses_dependency_order () = !typeclasses_dependency_order @@ -43,12 +60,41 @@ let typeclasses_iterative_deepening = ref false let set_typeclasses_iterative_deepening d = (:=) typeclasses_iterative_deepening d let get_typeclasses_iterative_deepening () = !typeclasses_iterative_deepening +(** [typeclasses_filtered_unif] governs the unification algorithm used by type + classes. If enabled, a new algorithm based on pattern filtering and refine + will be used. When disabled, the previous algorithm based on apply will be + used. *) +let typeclasses_filtered_unification = ref false +let set_typeclasses_filtered_unification d = + (:=) typeclasses_filtered_unification d +let get_typeclasses_filtered_unification () = + !typeclasses_filtered_unification + +(** [typeclasses_legacy_resolution] falls back to the 8.5 resolution algorithm, + instead of the 8.6 one which uses the native backtracking facilities of the + proof engine. *) +let typeclasses_legacy_resolution = ref false +let set_typeclasses_legacy_resolution d = (:=) typeclasses_legacy_resolution d +let get_typeclasses_legacy_resolution () = !typeclasses_legacy_resolution + +let set_typeclasses_debug d = (:=) typeclasses_debug (if d then 1 else 0) +let get_typeclasses_debug () = if !typeclasses_debug > 0 then true else false + +let set_typeclasses_verbose = + function None -> typeclasses_debug := 0 + | Some n -> (:=) typeclasses_debug n +let get_typeclasses_verbose () = + if !typeclasses_debug = 0 then None else Some !typeclasses_debug + +let set_typeclasses_depth d = (:=) typeclasses_depth d +let get_typeclasses_depth () = !typeclasses_depth + open Goptions let _ = declare_bool_option { optsync = true; - optdepr = false; + optdepr = true; optname = "do typeclass search modulo eta conversion"; optkey = ["Typeclasses";"Modulo";"Eta"]; optread = get_typeclasses_modulo_eta; @@ -58,6 +104,16 @@ let _ = declare_bool_option { optsync = true; optdepr = false; + optname = "do typeclass search avoiding eta-expansions " ^ + " in proof terms (expensive)"; + optkey = ["Typeclasses";"Limit";"Intros"]; + optread = get_typeclasses_limit_intros; + optwrite = set_typeclasses_limit_intros; } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; optname = "during typeclass resolution, solve instances according to their dependency order"; optkey = ["Typeclasses";"Dependency";"Order"]; optread = get_typeclasses_dependency_order; @@ -72,42 +128,73 @@ let _ = optread = get_typeclasses_iterative_deepening; optwrite = set_typeclasses_iterative_deepening; } -(** We transform the evars that are concerned by this resolution - (according to predicate p) into goals. - Invariant: function p only manipulates and returns undefined evars *) +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "compat"; + optkey = ["Typeclasses";"Legacy";"Resolution"]; + optread = get_typeclasses_legacy_resolution; + optwrite = set_typeclasses_legacy_resolution; } -let top_sort evm undefs = - let l' = ref [] in - let tosee = ref undefs in - let rec visit ev evi = - let evs = Evarutil.undefined_evars_of_evar_info evm evi in - Evar.Set.iter (fun ev -> - if Evar.Map.mem ev !tosee then - visit ev (Evar.Map.find ev !tosee)) evs; - tosee := Evar.Map.remove ev !tosee; - l' := ev :: !l'; - in - while not (Evar.Map.is_empty !tosee) do - let ev, evi = Evar.Map.min_binding !tosee in - visit ev evi - done; - List.rev !l' +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "compat"; + optkey = ["Typeclasses";"Filtered";"Unification"]; + optread = get_typeclasses_filtered_unification; + optwrite = set_typeclasses_filtered_unification; } -let evars_to_goals p evm = - let goals = ref Evar.Map.empty in - let map ev evi = - let evi, goal = p evm ev evi in - let () = if goal then goals := Evar.Map.add ev evi !goals in - evi - in - let evm = Evd.raw_map_undefined map evm in - if Evar.Map.is_empty !goals then None - else Some (!goals, evm) +let set_typeclasses_debug = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "debug output for typeclasses proof search"; + optkey = ["Typeclasses";"Debug"]; + optread = get_typeclasses_debug; + optwrite = set_typeclasses_debug; } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "debug output for typeclasses proof search"; + optkey = ["Debug";"Typeclasses"]; + optread = get_typeclasses_debug; + optwrite = set_typeclasses_debug; } + +let _ = + declare_int_option + { optsync = true; + optdepr = false; + optname = "verbosity of debug output for typeclasses proof search"; + optkey = ["Typeclasses";"Debug";"Verbosity"]; + optread = get_typeclasses_verbose; + optwrite = set_typeclasses_verbose; } + +let set_typeclasses_depth = + declare_int_option + { optsync = true; + optdepr = false; + optname = "depth for typeclasses proof search"; + optkey = ["Typeclasses";"Depth"]; + optread = get_typeclasses_depth; + optwrite = set_typeclasses_depth; } + +type search_strategy = Dfs | Bfs + +let set_typeclasses_strategy = function + | Dfs -> set_typeclasses_iterative_deepening false + | Bfs -> set_typeclasses_iterative_deepening true + +let pr_ev evs ev = + Printer.pr_constr_env (Goal.V82.env evs ev) evs + (Evarutil.nf_evar evs (Goal.V82.concl evs ev)) (** Typeclasses instance search tactic / eauto *) open Auto - open Unification let auto_core_unif_flags st freeze = { @@ -125,7 +212,7 @@ let auto_core_unif_flags st freeze = { modulo_eta = !typeclasses_modulo_eta; } -let auto_unif_flags freeze st = +let auto_unif_flags freeze st = let fl = auto_core_unif_flags st freeze in { core_unify_flags = fl; merge_unify_flags = fl; @@ -134,25 +221,6 @@ let auto_unif_flags freeze st = resolve_evars = false } -let rec eq_constr_mod_evars x y = - match kind_of_term x, kind_of_term y with - | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true - | _, _ -> compare_constr eq_constr_mod_evars x y - -let progress_evars t = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let check = - Proofview.Goal.nf_enter { enter = begin fun gl' -> - let newconcl = Proofview.Goal.concl gl' in - if eq_constr_mod_evars concl newconcl - then Tacticals.New.tclFAIL 0 (str"No progress made (modulo evars)") - else Proofview.tclUNIT () - end } - in t <*> check - end } - - let e_give_exact flags poly (c,clenv) gl = let (c, _, _) = c in let c, gl = @@ -160,121 +228,276 @@ let e_give_exact flags poly (c,clenv) gl = let clenv', subst = Clenv.refresh_undefined_univs clenv in let evd = evars_reset_evd ~with_conv_pbs:true gl.sigma clenv'.evd in let c = Vars.subst_univs_level_constr subst c in - c, {gl with sigma = evd} + c, {gl with sigma = evd} else c, gl in let t1 = pf_unsafe_type_of gl c in - tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl + Proofview.V82.of_tactic (Clenvtac.unify ~flags t1 <*> exact_no_check c) gl -let unify_e_resolve poly flags = { enter = begin fun gls (c,clenv) -> +let unify_e_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> let clenv', c = connect_hint_clenv poly c clenv gls in let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in Clenvtac.clenv_refine true ~with_classes:false clenv' end } -let unify_resolve poly flags = { enter = begin fun gls (c,clenv) -> +let unify_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> let clenv', _ = connect_hint_clenv poly c clenv gls in let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in Clenvtac.clenv_refine false ~with_classes:false clenv' end } +(** Application of a lemma using [refine] instead of the old [w_unify] *) +let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) = + let open Clenv in + let env = Proofview.Goal.env gls in + let concl = Proofview.Goal.concl gls in + Refine.refine ~unsafe:true { Sigma.run = fun sigma -> + let sigma = Sigma.to_evar_map sigma in + let sigma, term, ty = + if poly then + let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in + let map c = Vars.subst_univs_level_constr subst c in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + sigma, map c, map t + else + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + sigma, c, t + in + let sigma', cl = Clenv.make_evar_clause env sigma ?len:n ty in + let term = applistc term (List.map (fun x -> x.hole_evar) cl.cl_holes) in + let sigma' = + Evarconv.the_conv_x_leq env ~ts:flags.core_unify_flags.modulo_delta + cl.cl_concl concl sigma' + in Sigma.here term (Sigma.Unsafe.of_evar_map sigma') } + +let unify_resolve_refine poly flags gl clenv = + Proofview.tclORELSE + (unify_resolve_refine poly flags gl clenv) + (fun ie -> + match fst ie with + | Evarconv.UnableToUnify _ -> + Tacticals.New.tclZEROMSG (str "Unable to unify") + | e when CErrors.noncritical e -> + Tacticals.New.tclZEROMSG (str "Unexpected error") + | _ -> iraise ie) + +(** Dealing with goals of the form A -> B and hints of the form + C -> A -> B. +*) let clenv_of_prods poly nprods (c, clenv) gl = let (c, _, _) = c in - if poly || Int.equal nprods 0 then Some clenv + if poly || Int.equal nprods 0 then Some (None, clenv) else - let ty = Tacmach.New.pf_unsafe_type_of gl c in + let ty = Retyping.get_type_of (Proofview.Goal.env gl) + (Sigma.to_evar_map (Proofview.Goal.sigma gl)) c in let diff = nb_prod ty - nprods in - if Pervasives.(>=) diff 0 then - (* Was Some clenv... *) - Some (Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) - else None + if Pervasives.(>=) diff 0 then + (* Was Some clenv... *) + Some (Some diff, + Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) + else None let with_prods nprods poly (c, clenv) f = - Proofview.Goal.nf_enter { enter = begin fun gl -> - match clenv_of_prods poly nprods (c, clenv) gl with - | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") - | Some clenv' -> f.enter gl (c, clenv') - end } + if get_typeclasses_limit_intros () then + Proofview.Goal.nf_enter { enter = begin fun gl -> + try match clenv_of_prods poly nprods (c, clenv) gl with + | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") + | Some (diff, clenv') -> f.enter gl (c, diff, clenv') + with e when CErrors.noncritical e -> + Tacticals.New.tclZEROMSG (CErrors.print e) end } + else Proofview.Goal.nf_enter + { enter = begin fun gl -> + if Int.equal nprods 0 then f.enter gl (c, None, clenv) + else Tacticals.New.tclZEROMSG (str"Not enough premisses") end } + +let matches_pattern concl pat = + let matches env sigma = + match pat with + | None -> Proofview.tclUNIT () + | Some pat -> + let sigma = Sigma.to_evar_map sigma in + if Constr_matching.is_matching env sigma pat concl then + Proofview.tclUNIT () + else + Tacticals.New.tclZEROMSG (str "pattern does not match") + in + Proofview.Goal.enter { enter = fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + matches env sigma } + +(** Semantics of type class resolution lemma application: + + - Use unification to find a well-typed substitution. There might + be evars in the goal and the lemma. Evars in the goal can get refined. + - Independent evars are turned into goals, whatever their kind is. + - Dependent evars of the lemma corresponding to arguments which appear + in independent goals or the conclusion are turned into subgoals iff + they are of typeclass kind. + - The remaining dependent evars not of typeclass type are shelved, + and resolution must fill them for it to succeed, otherwise we + backtrack. + *) + +let pr_gls sigma gls = + prlist_with_sep spc + (fun ev -> int (Evar.repr ev) ++ spc () ++ pr_ev sigma ev) gls + +(** Ensure the dependent subgoals are shelved after an apply/eapply. *) +let shelve_dependencies gls = + let open Proofview in + tclEVARMAP >>= fun sigma -> + (if !typeclasses_debug > 1 && List.length gls > 0 then + Feedback.msg_debug (str" shelving dependent subgoals: " ++ pr_gls sigma gls); + shelve_goals gls) + +let hintmap_of hdc secvars concl = + match hdc with + | None -> fun db -> Hint_db.map_none secvars db + | Some hdc -> + fun db -> + if Hint_db.use_dn db then (* Using dnet *) + Hint_db.map_eauto secvars hdc concl db + else Hint_db.map_existential secvars hdc concl db (** Hack to properly solve dependent evars that are typeclasses *) - -let rec e_trivial_fail_db db_list local_db goal = +let rec e_trivial_fail_db only_classes db_list local_db secvars = + let open Tacticals.New in + let open Tacmach.New in + let trivial_fail = + Proofview.Goal.nf_enter { enter = + begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let d = pf_last_hyp gl in + let hintl = make_resolve_hyp env sigma d in + let hints = Hint_db.add_list env sigma hintl local_db in + e_trivial_fail_db only_classes db_list hints secvars + end } + in + let trivial_resolve = + Proofview.Goal.nf_enter { enter = + begin fun gl -> + let tacs = e_trivial_resolve db_list local_db secvars only_classes + (project gl) (pf_concl gl) in + tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs) + end} + in let tacl = - Proofview.V82.of_tactic Eauto.registered_e_assumption :: - (tclTHEN (Proofview.V82.of_tactic Tactics.intro) - (function g'-> - let d = pf_last_hyp g' in - let hintl = make_resolve_hyp (pf_env g') (project g') d in - (e_trivial_fail_db db_list - (Hint_db.add_list (pf_env g') (project g') hintl local_db) g'))) :: - (List.map (fun (x,_,_,_,_) -> x) - (e_trivial_resolve db_list local_db (project goal) (pf_concl goal))) + Eauto.registered_e_assumption :: + (tclTHEN Tactics.intro trivial_fail :: [trivial_resolve]) in - tclFIRST (List.map tclCOMPLETE tacl) goal + tclFIRST (List.map tclCOMPLETE tacl) -and e_my_find_search db_list local_db hdc complete sigma concl = +and e_my_find_search db_list local_db secvars hdc complete only_classes sigma concl = + let open Proofview.Notations in let prods, concl = decompose_prod_assum concl in let nprods = List.length prods in - let freeze = + let freeze = try - let cl = Typeclasses.class_info (fst hdc) in - if cl.cl_strict then - Evd.evars_of_term concl - else Evar.Set.empty - with e when Errors.noncritical e -> Evar.Set.empty + match hdc with + | Some (hd,_) when only_classes -> + let cl = Typeclasses.class_info hd in + if cl.cl_strict then + Evd.evars_of_term concl + else Evar.Set.empty + | _ -> Evar.Set.empty + with e when CErrors.noncritical e -> Evar.Set.empty in + let hint_of_db = hintmap_of hdc secvars concl in let hintl = List.map_append (fun db -> - let tacs = - if Hint_db.use_dn db then (* Using dnet *) - Hint_db.map_eauto hdc concl db - else Hint_db.map_existential hdc concl db - in - let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in - List.map (fun x -> (flags, x)) tacs) + let tacs = hint_of_db db in + let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in + List.map (fun x -> (flags, x)) tacs) (local_db::db_list) in let tac_of_hint = - fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> + fun (flags, {pri = b; pat = p; poly = poly; code = t; secvars; name = name}) -> let tac = function - | Res_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_resolve poly flags) - | ERes_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_e_resolve poly flags) - | Give_exact c -> Proofview.V82.tactic (e_give_exact flags poly c) + | Res_pf (term,cl) -> + if get_typeclasses_filtered_unification () then + let tac = + with_prods nprods poly (term,cl) + ({ enter = fun gl clenv -> + matches_pattern concl p <*> + unify_resolve_refine poly flags gl clenv}) + in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable + else + let tac = + with_prods nprods poly (term,cl) (unify_resolve poly flags) in + if get_typeclasses_legacy_resolution () then + Tacticals.New.tclTHEN tac Proofview.shelve_unifiable + else + Proofview.tclBIND (Proofview.with_shelf tac) + (fun (gls, ()) -> shelve_dependencies gls) + | ERes_pf (term,cl) -> + if get_typeclasses_filtered_unification () then + let tac = (with_prods nprods poly (term,cl) + ({ enter = fun gl clenv -> + matches_pattern concl p <*> + unify_resolve_refine poly flags gl clenv})) in + Tacticals.New.tclTHEN tac Proofview.shelve_unifiable + else + let tac = + with_prods nprods poly (term,cl) (unify_e_resolve poly flags) in + if get_typeclasses_legacy_resolution () then + Tacticals.New.tclTHEN tac Proofview.shelve_unifiable + else + Proofview.tclBIND (Proofview.with_shelf tac) + (fun (gls, ()) -> shelve_dependencies gls) + | Give_exact (c,clenv) -> + if get_typeclasses_filtered_unification () then + let tac = + matches_pattern concl p <*> + Proofview.Goal.nf_enter + { enter = fun gl -> unify_resolve_refine poly flags gl (c,None,clenv) } in + Tacticals.New.tclTHEN tac Proofview.shelve_unifiable + else + Proofview.V82.tactic (e_give_exact flags poly (c,clenv)) | Res_pf_THEN_trivial_fail (term,cl) -> - Proofview.V82.tactic (tclTHEN - (Proofview.V82.of_tactic ((with_prods nprods poly (term,cl) (unify_e_resolve poly flags)))) - (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)) - | Unfold_nth c -> Proofview.V82.tactic (tclWEAK_PROGRESS (Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]))) + let fst = with_prods nprods poly (term,cl) (unify_e_resolve poly flags) in + let snd = if complete then Tacticals.New.tclIDTAC + else e_trivial_fail_db only_classes db_list local_db secvars in + Tacticals.New.tclTHEN fst snd + | Unfold_nth c -> + let tac = Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]) in + Proofview.V82.tactic (tclWEAK_PROGRESS tac) | Extern tacast -> conclPattern concl p tacast in - let tac = Proofview.V82.of_tactic (run_hint t tac) in - let tac = if complete then tclCOMPLETE tac else tac in - match repr_hint t with - | Extern _ -> (tac,b,true, name, lazy (pr_hint t)) - | _ -> -(* let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *) - (tac,b,false, name, lazy (pr_hint t)) + let tac = run_hint t tac in + let tac = if complete then Tacticals.New.tclCOMPLETE tac else tac in + let pp = + match p with + | Some pat when get_typeclasses_filtered_unification () -> + str " with pattern " ++ Printer.pr_constr_pattern pat + | _ -> mt () + in + match repr_hint t with + | Extern _ -> (tac, b, true, name, lazy (pr_hint t ++ pp)) + | _ -> (tac, b, false, name, lazy (pr_hint t ++ pp)) in List.map tac_of_hint hintl -and e_trivial_resolve db_list local_db sigma concl = +and e_trivial_resolve db_list local_db secvars only_classes sigma concl = + let hd = try Some (decompose_app_bound concl) with Bound -> None in try - e_my_find_search db_list local_db - (decompose_app_bound concl) true sigma concl - with Bound | Not_found -> [] + e_my_find_search db_list local_db secvars hd true only_classes sigma concl + with Not_found -> [] -let e_possible_resolve db_list local_db sigma concl = +let e_possible_resolve db_list local_db secvars only_classes sigma concl = + let hd = try Some (decompose_app_bound concl) with Bound -> None in try - e_my_find_search db_list local_db - (decompose_app_bound concl) false sigma concl - with Bound | Not_found -> [] + e_my_find_search db_list local_db secvars hd false only_classes sigma concl + with Not_found -> [] + +let cut_of_hints h = + List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h let catchable = function | Refiner.FailError _ -> true | e -> Logic.catchable_exception e -let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) evs (Evarutil.nf_evar evs (Goal.V82.concl evs ev)) - (* alternate separators in debug search path output *) let debug_seps = [| "." ; "-" |] let next_sep seps = @@ -286,45 +509,66 @@ let next_sep seps = str sep let pr_depth l = prlist_with_sep (next_sep debug_seps) int (List.rev l) -type autoinfo = { hints : hint_db; is_evar: existential_key option; - only_classes: bool; unique : bool; - auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t; - auto_path : global_reference option list; - auto_cut : hints_path } -type autogoal = goal * autoinfo -type failure = NotApplicable | ReachedLimit -type 'ans fk = failure -> 'ans -type ('a,'ans) sk = 'a -> 'ans fk -> 'ans -type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans } - -type auto_result = autogoal list sigma +let is_Prop env sigma concl = + let ty = Retyping.get_type_of env sigma concl in + match kind_of_term ty with + | Sort (Prop Null) -> true + | _ -> false -type atac = auto_result tac +let is_unique env concl = + try + let (cl,u), args = dest_class_app env concl in + cl.cl_unique + with e when CErrors.noncritical e -> false -(* Some utility types to avoid the need of -rectypes *) +(** Sort the undefined variables from the least-dependent to most dependent. *) +let top_sort evm undefs = + let l' = ref [] in + let tosee = ref undefs in + let rec visit ev evi = + let evs = Evarutil.undefined_evars_of_evar_info evm evi in + Evar.Set.iter (fun ev -> + if Evar.Map.mem ev !tosee then + visit ev (Evar.Map.find ev !tosee)) evs; + tosee := Evar.Map.remove ev !tosee; + l' := ev :: !l'; + in + while not (Evar.Map.is_empty !tosee) do + let ev, evi = Evar.Map.min_binding !tosee in + visit ev evi + done; + List.rev !l' -type 'a optionk = - | Nonek - | Somek of 'a * 'a optionk fk +(** We transform the evars that are concerned by this resolution + (according to predicate p) into goals. + Invariant: function p only manipulates and returns undefined evars +*) -type ('a,'b) optionk2 = - | Nonek2 of failure - | Somek2 of 'a * 'b * ('a,'b) optionk2 fk +let evars_to_goals p evm = + let goals = ref Evar.Map.empty in + let map ev evi = + let evi, goal = p evm ev evi in + let () = if goal then goals := Evar.Map.add ev evi !goals in + evi + in + let evm = Evd.raw_map_undefined map evm in + if Evar.Map.is_empty !goals then None + else Some (!goals, evm) +(** Making local hints *) let make_resolve_hyp env sigma st flags only_classes pri decl = - let open Context.Named.Declaration in - let id = get_id decl in - let cty = Evarutil.nf_evar sigma (get_type decl) in + let id = NamedDecl.get_id decl in + let cty = Evarutil.nf_evar sigma (NamedDecl.get_type decl) in let rec iscl env ty = let ctx, ar = decompose_prod_assum ty in match kind_of_term (fst (decompose_app ar)) with | Const (c,_) -> is_class (ConstRef c) | Ind (i,_) -> is_class (IndRef i) | _ -> - let env' = Environ.push_rel_context ctx env in - let ty' = whd_betadeltaiota env' ar in - if not (Term.eq_constr ty' ar) then iscl env' ty' - else false + let env' = Environ.push_rel_context ctx env in + let ty' = whd_all env' ar in + if not (Term.eq_constr ty' ar) then iscl env' ty' + else false in let is_class = iscl env cty in let keep = not only_classes || is_class in @@ -332,344 +576,831 @@ let make_resolve_hyp env sigma st flags only_classes pri decl = let c = mkVar id in let name = PathHints [VarRef id] in let hints = - if is_class then - let hints = build_subclasses ~check:false env sigma (VarRef id) None in - (List.map_append - (fun (path,pri, c) -> make_resolves env sigma ~name:(PathHints path) - (true,false,Flags.is_verbose()) pri false - (IsConstr (c,Univ.ContextSet.empty))) - hints) - else [] + if is_class then + let hints = build_subclasses ~check:false env sigma (VarRef id) empty_hint_info in + (List.map_append + (fun (path,info,c) -> + let info = + { info with Vernacexpr.hint_pattern = + Option.map (Constrintern.intern_constr_pattern env) + info.Vernacexpr.hint_pattern } + in + make_resolves env sigma ~name:(PathHints path) + (true,false,Flags.is_verbose()) info false + (IsConstr (c,Univ.ContextSet.empty))) + hints) + else [] in (hints @ List.map_filter - (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) - with Failure _ | UserError _ -> None) - [make_exact_entry ~name env sigma pri false; - make_apply_entry ~name env sigma flags pri false]) + (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) + with Failure _ | UserError _ -> None) + [make_exact_entry ~name env sigma pri false; + make_apply_entry ~name env sigma flags pri false]) else [] -let pf_filtered_hyps gls = - Goal.V82.hyps gls.Evd.sigma (sig_it gls) - let make_hints g st only_classes sign = - let paths, hintlist = + let hintlist = List.fold_left - (fun (paths, hints) hyp -> - let consider = - let open Context.Named.Declaration in - try let t = Global.lookup_named (get_id hyp) |> get_type in - (* Section variable, reindex only if the type changed *) - not (Term.eq_constr t (get_type hyp)) - with Not_found -> true - in - if consider then - let path, hint = - PathEmpty, pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp - in - (PathOr (paths, path), hint @ hints) - else (paths, hints)) - (PathEmpty, []) sign + (fun hints hyp -> + let consider = + try let t = hyp |> NamedDecl.get_id |> Global.lookup_named |> NamedDecl.get_type in + (* Section variable, reindex only if the type changed *) + not (Term.eq_constr t (NamedDecl.get_type hyp)) + with Not_found -> true + in + if consider then + let hint = + pf_apply make_resolve_hyp g st (true,false,false) only_classes empty_hint_info hyp + in hint @ hints + else hints) + ([]) sign in Hint_db.add_list (pf_env g) (project g) hintlist (Hint_db.empty st true) -let make_autogoal_hints = - let cache = ref (true, Environ.empty_named_context_val, - Hint_db.empty full_transparent_state true) - in - fun only_classes ?(st=full_transparent_state) g -> - let sign = pf_filtered_hyps g in - let (onlyc, sign', cached_hints) = !cache in - if onlyc == only_classes && - (sign == sign' || Environ.eq_named_context_val sign sign') - && Hint_db.transparent_state cached_hints == st - then - cached_hints - else - let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in - cache := (only_classes, sign, hints); hints - -let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac = - { skft = fun sk fk {it = gl,hints; sigma=s;} -> - let res = try Some (tac {it=gl; sigma=s;}) - with e when catchable e -> None in - match res with - | Some gls -> sk (f gls hints) fk - | None -> fk NotApplicable } - -let intro_tac : atac = - lift_tactic (Proofview.V82.of_tactic Tactics.intro) - (fun {it = gls; sigma = s} info -> - let gls' = - List.map (fun g' -> - let env = Goal.V82.env s g' in - let context = Environ.named_context_of_val (Goal.V82.hyps s g') in - let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) - (true,false,false) info.only_classes None (List.hd context) in - let ldb = Hint_db.add_list env s hint info.hints in - (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls - in {it = gls'; sigma = s;}) - -let normevars_tac : atac = - { skft = fun sk fk {it = (gl, info); sigma = s;} -> - let gl', sigma' = Goal.V82.nf_evar s gl in - let info' = { info with auto_last_tac = lazy (str"normevars") } in - sk {it = [gl', info']; sigma = sigma';} fk } - -let merge_failures x y = - match x, y with - | _, ReachedLimit - | ReachedLimit, _ -> ReachedLimit - | NotApplicable, NotApplicable -> NotApplicable - -let or_tac (x : 'a tac) (y : 'a tac) : 'a tac = - { skft = fun sk fk gls -> x.skft sk - (fun f -> y.skft sk (fun f' -> fk (merge_failures f f')) gls) gls } - -let or_else_tac (x : 'a tac) (y : failure -> 'a tac) : 'a tac = - { skft = fun sk fk gls -> x.skft sk - (fun f -> (y f).skft sk fk gls) gls } +(** <= 8.5 resolution *) +module V85 = struct -let is_Prop env sigma concl = - let ty = Retyping.get_type_of env sigma concl in - match kind_of_term ty with - | Sort (Prop Null) -> true - | _ -> false + type autoinfo = { hints : hint_db; is_evar: existential_key option; + only_classes: bool; unique : bool; + auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t; + auto_path : global_reference option list; + auto_cut : hints_path } + type autogoal = goal * autoinfo + type failure = NotApplicable | ReachedLimit + type 'ans fk = failure -> 'ans + type ('a,'ans) sk = 'a -> 'ans fk -> 'ans + type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans } -let is_unique env concl = - try - let (cl,u), args = dest_class_app env concl in - cl.cl_unique - with e when Errors.noncritical e -> false - -let needs_backtrack env evd oev concl = - if Option.is_empty oev || is_Prop env evd concl then - occur_existential concl - else true - -let hints_tac hints = - { skft = fun sk fk {it = gl,info; sigma = s;} -> - let env = Goal.V82.env s gl in - let concl = Goal.V82.concl s gl in - let tacgl = {it = gl; sigma = s;} in - let poss = e_possible_resolve hints info.hints s concl in - let unique = is_unique env concl in - let rec aux i foundone = function - | (tac, _, b, name, pp) :: tl -> - let derivs = path_derivate info.auto_cut name in - let res = - try - if path_matches derivs [] then None else Some (tac tacgl) - with e when catchable e -> None - in - (match res with - | None -> aux i foundone tl - | Some {it = gls; sigma = s';} -> - if !typeclasses_debug then - msg_debug (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp - ++ str" on" ++ spc () ++ pr_ev s gl); - let sgls = - evars_to_goals - (fun evm ev evi -> - if Typeclasses.is_resolvable evi && not (Evd.is_undefined s ev) && - (not info.only_classes || Typeclasses.is_class_evar evm evi) - then Typeclasses.mark_unresolvable evi, true - else evi, false) s' - in - let newgls, s' = - let gls' = List.map (fun g -> (None, g)) gls in - match sgls with - | None -> gls', s' - | Some (evgls, s') -> - if not !typeclasses_dependency_order then - (gls' @ List.map (fun (ev,_) -> (Some ev, ev)) (Evar.Map.bindings evgls), s') - else - (* Reorder with dependent subgoals. *) - let evm = List.fold_left - (fun acc g -> Evar.Map.add g (Evd.find_undefined s' g) acc) evgls gls in - let gls = top_sort s' evm in - (List.map (fun ev -> Some ev, ev) gls, s') - in - let gls' = List.map_i - (fun j (evar, g) -> - let info = - { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp; - is_evar = evar; - hints = - if b && not (Environ.eq_named_context_val (Goal.V82.hyps s' g) - (Goal.V82.hyps s' gl)) - then make_autogoal_hints info.only_classes - ~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s';} - else info.hints; - auto_cut = derivs } - in g, info) 1 newgls in - let glsv = {it = gls'; sigma = s';} in - let fk' = - (fun e -> - let do_backtrack = - if unique then occur_existential concl - else if info.unique then true - else if List.is_empty gls' then - needs_backtrack env s' info.is_evar concl - else true - in - let e' = match foundone with None -> e | Some e' -> merge_failures e e' in - if !typeclasses_debug then - msg_debug - ((if do_backtrack then str"Backtracking after " - else str "Not backtracking after ") - ++ Lazy.force pp); - if do_backtrack then aux (succ i) (Some e') tl - else fk e') - in - sk glsv fk') - | [] -> - if foundone == None && !typeclasses_debug then - msg_debug (pr_depth info.auto_depth ++ str": no match for " ++ - Printer.pr_constr_env (Goal.V82.env s gl) s concl ++ - spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); - match foundone with - | Some e -> fk e - | None -> fk NotApplicable - in aux 1 None poss } - -let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = - let rec aux s (acc : autogoal list list) fk = function - | (gl,info) :: gls -> - Control.check_for_interrupt (); - (match info.is_evar with - | Some ev when Evd.is_defined s ev -> aux s acc fk gls - | _ -> - second.skft - (fun {it=gls';sigma=s'} fk' -> - let fk'' = - if not info.unique && List.is_empty gls' && - not (needs_backtrack (Goal.V82.env s gl) s - info.is_evar (Goal.V82.concl s gl)) - then fk - else fk' - in - aux s' (gls'::acc) fk'' gls) - fk {it = (gl,info); sigma = s; }) - | [] -> Somek2 (List.rev acc, s, fk) - in fun {it = gls; sigma = s; } fk -> - let rec aux' = function - | Nonek2 e -> fk e - | Somek2 (res, s', fk') -> - let goals' = List.concat res in - sk {it = goals'; sigma = s'; } (fun e -> aux' (fk' e)) - in aux' (aux s [] (fun e -> Nonek2 e) gls) - -let then_tac (first : atac) (second : atac) : atac = - { skft = fun sk fk -> first.skft (then_list second sk) fk } - -let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option = - t.skft (fun x _ -> Some x) (fun _ -> None) gl - -type run_list_res = auto_result optionk - -let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res = - (then_list t (fun x fk -> Somek (x, fk))) - gl - (fun _ -> Nonek) - -let fail_tac reason : atac = - { skft = fun sk fk _ -> fk reason } - -let rec fix (t : 'a tac) : 'a tac = - then_tac t { skft = fun sk fk -> (fix t).skft sk fk } - -let rec fix_limit limit (t : 'a tac) : 'a tac = - if Int.equal limit 0 then fail_tac ReachedLimit - else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk } - -let fix_iterative t = - let rec aux depth = - or_else_tac (fix_limit depth t) - (function - | NotApplicable as e -> fail_tac e - | ReachedLimit -> aux (succ depth)) - in aux 1 - -let fix_iterative_limit limit (t : 'a tac) : 'a tac = - let rec aux depth = - if Int.equal depth limit then fail_tac ReachedLimit - else or_tac (fix_limit depth t) { skft = fun sk fk -> (aux (succ depth)).skft sk fk } - in aux 1 - -let make_autogoal ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) cut ev g = - let hints = make_autogoal_hints only_classes ~st g in - (g.it, { hints = hints ; is_evar = ev; unique = unique; - only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none"); - auto_path = []; auto_cut = cut }) + type auto_result = autogoal list sigma + type atac = auto_result tac -let cut_of_hints h = - List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h + (* Some utility types to avoid the need of -rectypes *) + + type 'a optionk = + | Nonek + | Somek of 'a * 'a optionk fk + + type ('a,'b) optionk2 = + | Nonek2 of failure + | Somek2 of 'a * 'b * ('a,'b) optionk2 fk + + let pf_filtered_hyps gls = + Goal.V82.hyps gls.Evd.sigma (sig_it gls) -let make_autogoals ?(only_classes=true) ?(unique=false) - ?(st=full_transparent_state) hints gs evm' = - let cut = cut_of_hints hints in - { it = List.map_i (fun i g -> - let (gl, auto) = make_autogoal ~only_classes ~unique - ~st cut (Some g) {it = g; sigma = evm'; } in - (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm'; } - -let get_result r = - match r with - | Nonek -> None - | Somek (gls, fk) -> Some (gls.sigma,fk) - -let run_on_evars ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) p evm hints tac = - match evars_to_goals p evm with - | None -> None (* This happens only because there's no evar having p *) - | Some (goals, evm') -> - let goals = - if !typeclasses_dependency_order then - top_sort evm' goals - else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals) + let make_autogoal_hints = + let cache = ref (true, Environ.empty_named_context_val, + Hint_db.empty full_transparent_state true) in - let res = run_list_tac tac p goals - (make_autogoals ~only_classes ~unique ~st hints goals evm') in - match get_result res with - | None -> raise Not_found - | Some (evm', fk) -> - Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk) - -let eauto_tac hints = - then_tac normevars_tac (or_tac (hints_tac hints) intro_tac) - -let eauto_tac ?limit hints = - if get_typeclasses_iterative_deepening () then - match limit with - | None -> fix_iterative (eauto_tac hints) - | Some limit -> fix_iterative_limit limit (eauto_tac hints) - else - match limit with - | None -> fix (eauto_tac hints) - | Some limit -> fix_limit limit (eauto_tac hints) + fun only_classes ?(st=full_transparent_state) g -> + let sign = pf_filtered_hyps g in + let (onlyc, sign', cached_hints) = !cache in + if onlyc == only_classes && + (sign == sign' || Environ.eq_named_context_val sign sign') + && Hint_db.transparent_state cached_hints == st + then + cached_hints + else + let hints = make_hints g st only_classes (Environ.named_context_of_val sign) + in + cache := (only_classes, sign, hints); hints + + let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac = + { skft = fun sk fk {it = gl,hints; sigma=s;} -> + let res = try Some (tac {it=gl; sigma=s;}) + with e when catchable e -> None in + match res with + | Some gls -> sk (f gls hints) fk + | None -> fk NotApplicable } + + let intro_tac : atac = + let tac {it = gls; sigma = s} info = + let gls' = + List.map (fun g' -> + let env = Goal.V82.env s g' in + let context = Environ.named_context_of_val (Goal.V82.hyps s g') in + let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) + (true,false,false) info.only_classes empty_hint_info (List.hd context) in + let ldb = Hint_db.add_list env s hint info.hints in + (g', { info with is_evar = None; hints = ldb; + auto_last_tac = lazy (str"intro") })) gls + in {it = gls'; sigma = s;} + in + lift_tactic (Proofview.V82.of_tactic Tactics.intro) tac + + let normevars_tac : atac = + { skft = fun sk fk {it = (gl, info); sigma = s;} -> + let gl', sigma' = Goal.V82.nf_evar s gl in + let info' = { info with auto_last_tac = lazy (str"normevars") } in + sk {it = [gl', info']; sigma = sigma';} fk } + + let merge_failures x y = + match x, y with + | _, ReachedLimit + | ReachedLimit, _ -> ReachedLimit + | NotApplicable, NotApplicable -> NotApplicable + + let or_tac (x : 'a tac) (y : 'a tac) : 'a tac = + { skft = fun sk fk gls -> x.skft sk + (fun f -> y.skft sk (fun f' -> fk (merge_failures f f')) gls) gls } + + let or_else_tac (x : 'a tac) (y : failure -> 'a tac) : 'a tac = + { skft = fun sk fk gls -> x.skft sk + (fun f -> (y f).skft sk fk gls) gls } + + let needs_backtrack env evd oev concl = + if Option.is_empty oev || is_Prop env evd concl then + occur_existential concl + else true -let real_eauto ?limit unique st hints p evd = - let res = - run_on_evars ~st ~unique p evd hints (eauto_tac ?limit hints) - in + let hints_tac hints sk fk {it = gl,info; sigma = s} = + let env = Goal.V82.env s gl in + let concl = Goal.V82.concl s gl in + let tacgl = {it = gl; sigma = s;} in + let secvars = secvars_of_hyps (Environ.named_context_of_val (Goal.V82.hyps s gl)) in + let poss = e_possible_resolve hints info.hints secvars info.only_classes s concl in + let unique = is_unique env concl in + let rec aux i foundone = function + | (tac, _, extern, name, pp) :: tl -> + let derivs = path_derivate info.auto_cut name in + let res = + try + if path_matches derivs [] then None + else Some (Proofview.V82.of_tactic tac tacgl) + with e when catchable e -> None + in + (match res with + | None -> aux i foundone tl + | Some {it = gls; sigma = s';} -> + if !typeclasses_debug > 0 then + Feedback.msg_debug + (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp + ++ str" on" ++ spc () ++ pr_ev s gl); + let sgls = + evars_to_goals + (fun evm ev evi -> + if Typeclasses.is_resolvable evi && not (Evd.is_undefined s ev) && + (not info.only_classes || Typeclasses.is_class_evar evm evi) + then Typeclasses.mark_unresolvable evi, true + else evi, false) s' + in + let newgls, s' = + let gls' = List.map (fun g -> (None, g)) gls in + match sgls with + | None -> gls', s' + | Some (evgls, s') -> + if not !typeclasses_dependency_order then + (gls' @ List.map (fun (ev,_) -> (Some ev, ev)) (Evar.Map.bindings evgls), s') + else + (* Reorder with dependent subgoals. *) + let evm = List.fold_left + (fun acc g -> Evar.Map.add g (Evd.find_undefined s' g) acc) evgls gls in + let gls = top_sort s' evm in + (List.map (fun ev -> Some ev, ev) gls, s') + in + let reindex g = + let open Goal.V82 in + extern && not (Environ.eq_named_context_val + (hyps s' g) (hyps s' gl)) + in + let gl' j (evar, g) = + let hints' = + if reindex g then + make_autogoal_hints + info.only_classes + ~st:(Hint_db.transparent_state info.hints) + {it = g; sigma = s';} + else info.hints + in + { info with + auto_depth = j :: i :: info.auto_depth; + auto_last_tac = pp; + is_evar = evar; + hints = hints'; + auto_cut = derivs } + in + let gls' = List.map_i (fun i g -> snd g, gl' i g) 1 newgls in + let glsv = {it = gls'; sigma = s';} in + let fk' = + (fun e -> + let do_backtrack = + if unique then occur_existential concl + else if info.unique then true + else if List.is_empty gls' then + needs_backtrack env s' info.is_evar concl + else true + in + let e' = match foundone with None -> e + | Some e' -> merge_failures e e' in + if !typeclasses_debug > 0 then + Feedback.msg_debug + ((if do_backtrack then str"Backtracking after " + else str "Not backtracking after ") + ++ Lazy.force pp); + if do_backtrack then aux (succ i) (Some e') tl + else fk e') + in + sk glsv fk') + | [] -> + if foundone == None && !typeclasses_debug > 0 then + Feedback.msg_debug + (pr_depth info.auto_depth ++ str": no match for " ++ + Printer.pr_constr_env (Goal.V82.env s gl) s concl ++ + spc () ++ str ", " ++ int (List.length poss) ++ + str" possibilities"); + match foundone with + | Some e -> fk e + | None -> fk NotApplicable + in aux 1 None poss + + let hints_tac hints = + { skft = fun sk fk gls -> hints_tac hints sk fk gls } + + let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = + let rec aux s (acc : autogoal list list) fk = function + | (gl,info) :: gls -> + Control.check_for_interrupt (); + (match info.is_evar with + | Some ev when Evd.is_defined s ev -> aux s acc fk gls + | _ -> + second.skft + (fun {it=gls';sigma=s'} fk' -> + let fk'' = + if not info.unique && List.is_empty gls' && + not (needs_backtrack (Goal.V82.env s gl) s + info.is_evar (Goal.V82.concl s gl)) + then fk + else fk' + in + aux s' (gls'::acc) fk'' gls) + fk {it = (gl,info); sigma = s; }) + | [] -> Somek2 (List.rev acc, s, fk) + in fun {it = gls; sigma = s; } fk -> + let rec aux' = function + | Nonek2 e -> fk e + | Somek2 (res, s', fk') -> + let goals' = List.concat res in + sk {it = goals'; sigma = s'; } (fun e -> aux' (fk' e)) + in aux' (aux s [] (fun e -> Nonek2 e) gls) + + let then_tac (first : atac) (second : atac) : atac = + { skft = fun sk fk -> first.skft (then_list second sk) fk } + + let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option = + t.skft (fun x _ -> Some x) (fun _ -> None) gl + + type run_list_res = auto_result optionk + + let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res = + (then_list t (fun x fk -> Somek (x, fk))) + gl + (fun _ -> Nonek) + + let fail_tac reason : atac = + { skft = fun sk fk _ -> fk reason } + + let rec fix (t : 'a tac) : 'a tac = + then_tac t { skft = fun sk fk -> (fix t).skft sk fk } + + let rec fix_limit limit (t : 'a tac) : 'a tac = + if Int.equal limit 0 then fail_tac ReachedLimit + else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk } + + let fix_iterative t = + let rec aux depth = + or_else_tac (fix_limit depth t) + (function + | NotApplicable as e -> fail_tac e + | ReachedLimit -> aux (succ depth)) + in aux 1 + + let fix_iterative_limit limit (t : 'a tac) : 'a tac = + let rec aux depth = + if Int.equal limit depth then fail_tac ReachedLimit + else or_tac (fix_limit depth t) + { skft = fun sk fk -> (aux (succ depth)).skft sk fk } + in aux 1 + + let make_autogoal ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) + cut ev g = + let hints = make_autogoal_hints only_classes ~st g in + (g.it, { hints = hints ; is_evar = ev; unique = unique; + only_classes = only_classes; auto_depth = []; + auto_last_tac = lazy (str"none"); + auto_path = []; auto_cut = cut }) + + + let make_autogoals ?(only_classes=true) ?(unique=false) + ?(st=full_transparent_state) hints gs evm' = + let cut = cut_of_hints hints in + let gl i g = + let (gl, auto) = make_autogoal ~only_classes ~unique + ~st cut (Some g) {it = g; sigma = evm'; } in + (gl, { auto with auto_depth = [i]}) + in { it = List.map_i gl 1 gs; sigma = evm' } + + let get_result r = + match r with + | Nonek -> None + | Somek (gls, fk) -> Some (gls.sigma,fk) + + let run_on_evars ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) + p evm hints tac = + match evars_to_goals p evm with + | None -> None (* This happens only because there's no evar having p *) + | Some (goals, evm') -> + let goals = + if !typeclasses_dependency_order then + top_sort evm' goals + else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals) + in + let res = run_list_tac tac p goals + (make_autogoals ~only_classes ~unique ~st hints goals evm') in + match get_result res with + | None -> raise Not_found + | Some (evm', fk) -> + Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk) + + let eauto_tac hints = + then_tac normevars_tac (or_tac (hints_tac hints) intro_tac) + + let eauto_tac strategy depth hints = + match strategy with + | Bfs -> + begin match depth with + | None -> fix_iterative (eauto_tac hints) + | Some depth -> fix_iterative_limit depth (eauto_tac hints) end + | Dfs -> + match depth with + | None -> fix (eauto_tac hints) + | Some depth -> fix_limit depth (eauto_tac hints) + + let real_eauto ?depth strategy unique st hints p evd = + let res = + run_on_evars ~st ~unique p evd hints (eauto_tac strategy depth hints) + in match res with | None -> evd - | Some (evd', fk) -> - if unique then - (match get_result (fk NotApplicable) with - | Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions" - | None -> evd') - else evd' - -let resolve_all_evars_once debug limit unique p evd = - let db = searchtable_map typeclasses_db in - real_eauto ?limit unique (Hint_db.transparent_state db) [db] p evd - -let eauto ?(only_classes=true) ?st ?limit hints g = - let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g; } in - match run_tac (eauto_tac ?limit hints) gl with + | Some (evd', fk) -> + if unique then + (match get_result (fk NotApplicable) with + | Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions" + | None -> evd') + else evd' + + let resolve_all_evars_once debug depth unique p evd = + let db = searchtable_map typeclasses_db in + let strategy = if get_typeclasses_iterative_deepening () then Bfs else Dfs in + real_eauto ?depth strategy unique (Hint_db.transparent_state db) [db] p evd + + let eauto85 ?(only_classes=true) ?st ?strategy depth hints g = + let strategy = + match strategy with + | None -> if get_typeclasses_iterative_deepening () then Bfs else Dfs + | Some s -> s + in + let gl = { it = make_autogoal ~only_classes ?st + (cut_of_hints hints) None g; sigma = project g; } in + match run_tac (eauto_tac strategy depth hints) gl with | None -> raise Not_found | Some {it = goals; sigma = s; } -> - {it = List.map fst goals; sigma = s;} + {it = List.map fst goals; sigma = s;} + +end + +(** 8.6 resolution *) +module Search = struct + type autoinfo = + { search_depth : int list; + last_tac : Pp.std_ppcmds Lazy.t; + search_dep : bool; + search_only_classes : bool; + search_cut : hints_path; + search_hints : hint_db; } + + (** Local hints *) + let autogoal_cache = ref (DirPath.empty, true, Context.Named.empty, + Hint_db.empty full_transparent_state true) + + let make_autogoal_hints only_classes ?(st=full_transparent_state) g = + let open Proofview in + let open Tacmach.New in + let sign = Goal.hyps g in + let (dir, onlyc, sign', cached_hints) = !autogoal_cache in + let cwd = Lib.cwd () in + if DirPath.equal cwd dir && + (onlyc == only_classes) && + Context.Named.equal sign sign' && + Hint_db.transparent_state cached_hints == st + then cached_hints + else + let hints = make_hints {it = Goal.goal g; sigma = project g} + st only_classes sign + in + autogoal_cache := (cwd, only_classes, sign, hints); hints + + let make_autogoal ?(st=full_transparent_state) only_classes dep cut i g = + let hints = make_autogoal_hints only_classes ~st g in + { search_hints = hints; + search_depth = [i]; last_tac = lazy (str"none"); + search_dep = dep; + search_only_classes = only_classes; + search_cut = cut } + + (** In the proof engine failures are represented as exceptions *) + exception ReachedLimitEx + exception NotApplicableEx + + (** ReachedLimitEx has priority over NotApplicableEx to handle + iterative deepening: it should fail when no hints are applicable, + but go to a deeper depth otherwise. *) + let merge_exceptions e e' = + match fst e, fst e' with + | ReachedLimitEx, _ -> e + | _, ReachedLimitEx -> e' + | _, _ -> e + + (** Determine if backtracking is needed for this goal. + If the type class is unique or in Prop + and there are no evars in the goal then we do + NOT backtrack. *) + let needs_backtrack env evd unique concl = + if unique || is_Prop env evd concl then + occur_existential concl + else true + + let mark_unresolvables sigma goals = + List.fold_left + (fun sigma gl -> + let evi = Evd.find_undefined sigma gl in + let evi' = Typeclasses.mark_unresolvable evi in + Evd.add sigma gl evi') + sigma goals + + let fail_if_nonclass info = + Proofview.Goal.enter { enter = fun gl -> + let gl = Proofview.Goal.assume gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + if is_class_type sigma (Proofview.Goal.concl gl) then + Proofview.tclUNIT () + else (if !typeclasses_debug > 1 then + Feedback.msg_debug (pr_depth info.search_depth ++ + str": failure due to non-class subgoal " ++ + pr_ev sigma (Proofview.Goal.goal gl)); + Proofview.tclZERO NotApplicableEx) } + + (** The general hint application tactic. + tac1 + tac2 .... The choice of OR or ORELSE is determined + depending on the dependencies of the goal and the unique/Prop + status *) + let hints_tac_gl hints info kont gl : unit Proofview.tactic = + let open Proofview in + let open Proofview.Notations in + let env = Goal.env gl in + let concl = Goal.concl gl in + let sigma = Goal.sigma gl in + let s = Sigma.to_evar_map sigma in + let unique = not info.search_dep || is_unique env concl in + let backtrack = needs_backtrack env s unique concl in + if !typeclasses_debug > 0 then + Feedback.msg_debug + (pr_depth info.search_depth ++ str": looking for " ++ + Printer.pr_constr_env (Goal.env gl) s concl ++ + (if backtrack then str" with backtracking" + else str" without backtracking")); + let secvars = compute_secvars gl in + let poss = + e_possible_resolve hints info.search_hints secvars info.search_only_classes s concl in + (* If no goal depends on the solution of this one or the + instances are irrelevant/assumed to be unique, then + we don't need to backtrack, as long as no evar appears in the goal + This is an overapproximation. Evars could appear in this goal only + and not any other *) + let ortac = if backtrack then Proofview.tclOR else Proofview.tclORELSE in + let idx = ref 1 in + let foundone = ref false in + let rec onetac e (tac, pat, b, name, pp) tl = + let derivs = path_derivate info.search_cut name in + let pr_error ie = + if !typeclasses_debug > 1 then + let msg = + pr_depth (!idx :: info.search_depth) ++ str": " ++ + Lazy.force pp ++ + (if !foundone != true then + str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal gl) + else mt ()) + in + Feedback.msg_debug (msg ++ str " failed with " ++ CErrors.iprint ie) + else () + in + let tac_of gls i j = Goal.nf_enter { enter = fun gl' -> + let sigma' = Goal.sigma gl' in + let s' = Sigma.to_evar_map sigma' in + let _concl = Goal.concl gl' in + if !typeclasses_debug > 0 then + Feedback.msg_debug + (pr_depth (succ j :: i :: info.search_depth) ++ str" : " ++ + pr_ev s' (Proofview.Goal.goal gl')); + let hints' = + if b && not (Context.Named.equal (Goal.hyps gl') (Goal.hyps gl)) + then + let st = Hint_db.transparent_state info.search_hints in + make_autogoal_hints info.search_only_classes ~st gl' + else info.search_hints + in + let dep' = info.search_dep || Proofview.unifiable s' (Goal.goal gl') gls in + let info' = + { search_depth = succ j :: i :: info.search_depth; + last_tac = pp; + search_dep = dep'; + search_only_classes = info.search_only_classes; + search_hints = hints'; + search_cut = derivs } + in kont info' } + in + let rec result (shelf, ()) i k = + foundone := true; + Proofview.Unsafe.tclGETGOALS >>= fun gls -> + let j = List.length gls in + (if !typeclasses_debug > 0 then + Feedback.msg_debug + (pr_depth (i :: info.search_depth) ++ str": " ++ Lazy.force pp + ++ str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal gl) + ++ str", " ++ int j ++ str" subgoal(s)" ++ + (Option.cata (fun k -> str " in addition to the first " ++ int k) + (mt()) k))); + let res = + if j = 0 then tclUNIT () + else tclDISPATCH + (List.init j (fun j' -> (tac_of gls i (Option.default 0 k + j)))) + in + let finish nestedshelf sigma = + let filter ev = + try + let evi = Evd.find_undefined sigma ev in + if info.search_only_classes then + Some (ev, not (is_class_type sigma (Evd.evar_concl evi))) + else Some (ev, true) + with Not_found -> None + in + let remaining = CList.map_filter filter shelf in + (if !typeclasses_debug > 1 then + let prunsolved (ev, _) = + int (Evar.repr ev) ++ spc () ++ pr_ev sigma ev in + let unsolved = prlist_with_sep spc prunsolved remaining in + Feedback.msg_debug + (pr_depth (i :: info.search_depth) ++ + str": after " ++ Lazy.force pp ++ str" finished, " ++ + int (List.length remaining) ++ + str " goals are shelved and unsolved ( " ++ + unsolved ++ str")")); + begin + (* Some existentials produced by the original tactic were not solved + in the subgoals, turn them into subgoals now. *) + let shelved, goals = List.partition (fun (ev, s) -> s) remaining in + let shelved = List.map fst shelved @ nestedshelf and goals = List.map fst goals in + if !typeclasses_debug > 1 && not (List.is_empty shelved && List.is_empty goals) then + Feedback.msg_debug + (str"Adding shelved subgoals to the search: " ++ + prlist_with_sep spc (pr_ev sigma) goals ++ + str" while shelving " ++ + prlist_with_sep spc (pr_ev sigma) shelved); + shelve_goals shelved <*> + (if List.is_empty goals then tclUNIT () + else + let sigma' = mark_unresolvables sigma goals in + with_shelf (Unsafe.tclEVARS sigma' <*> Unsafe.tclNEWGOALS goals) >>= + fun s -> result s i (Some (Option.default 0 k + j))) + end + in with_shelf res >>= fun (sh, ()) -> + tclEVARMAP >>= finish sh + in + if path_matches derivs [] then aux e tl + else + let filter = + if false (* in 8.6, still allow non-class subgoals + info.search_only_classes *) then fail_if_nonclass info + else Proofview.tclUNIT () + in + ortac + (with_shelf (tac <*> filter) >>= fun s -> + let i = !idx in incr idx; result s i None) + (fun e' -> + if CErrors.noncritical (fst e') then + (pr_error e'; aux (merge_exceptions e e') tl) + else iraise e') + and aux e = function + | x :: xs -> onetac e x xs + | [] -> + if !foundone == false && !typeclasses_debug > 0 then + Feedback.msg_debug + (pr_depth info.search_depth ++ str": no match for " ++ + Printer.pr_constr_env (Goal.env gl) s concl ++ + spc () ++ str ", " ++ int (List.length poss) ++ + str" possibilities"); + match e with + | (ReachedLimitEx,ie) -> Proofview.tclZERO ~info:ie ReachedLimitEx + | (_,ie) -> Proofview.tclZERO ~info:ie NotApplicableEx + in + if backtrack then aux (NotApplicableEx,Exninfo.null) poss + else tclONCE (aux (NotApplicableEx,Exninfo.null) poss) + + let hints_tac hints info kont : unit Proofview.tactic = + Proofview.Goal.nf_enter + { enter = fun gl -> hints_tac_gl hints info kont gl } + + let intro_tac info kont gl = + let open Proofview in + let open Proofview.Notations in + let env = Goal.env gl in + let sigma = Goal.sigma gl in + let s = Sigma.to_evar_map sigma in + let decl = Tacmach.New.pf_last_hyp gl in + let hint = + make_resolve_hyp env s (Hint_db.transparent_state info.search_hints) + (true,false,false) info.search_only_classes empty_hint_info decl in + let ldb = Hint_db.add_list env s hint info.search_hints in + let info' = + { info with search_hints = ldb; last_tac = lazy (str"intro"); + search_depth = 1 :: 1 :: info.search_depth } + in kont info' + + let intro info kont = + Proofview.tclBIND Tactics.intro + (fun _ -> Proofview.Goal.nf_enter { enter = fun gl -> intro_tac info kont gl }) + + let rec search_tac hints limit depth = + let kont info = + Proofview.numgoals >>= fun i -> + if !typeclasses_debug > 1 then + Feedback.msg_debug + (str"calling eauto recursively at depth " ++ int (succ depth) + ++ str" on " ++ int i ++ str" subgoals"); + search_tac hints limit (succ depth) info + in + fun info -> + if Int.equal depth (succ limit) then Proofview.tclZERO ReachedLimitEx + else + Proofview.tclOR (hints_tac hints info kont) + (fun e -> Proofview.tclOR (intro info kont) + (fun e' -> let (e, info) = merge_exceptions e e' in + Proofview.tclZERO ~info e)) + + let search_tac_gl ?st only_classes dep hints depth i sigma gls gl : + unit Proofview.tactic = + let open Proofview in + let open Proofview.Notations in + if false (* In 8.6, still allow non-class goals only_classes && not (is_class_type sigma (Goal.concl gl)) *) then + Tacticals.New.tclZEROMSG (str"Not a subgoal for a class") + else + let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in + let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in + search_tac hints depth 1 info + + let search_tac ?(st=full_transparent_state) only_classes dep hints depth = + let open Proofview in + let tac sigma gls i = + Goal.nf_enter + { enter = fun gl -> + search_tac_gl ~st only_classes dep hints depth (succ i) sigma gls gl } + in + Proofview.Unsafe.tclGETGOALS >>= fun gls -> + Proofview.tclEVARMAP >>= fun sigma -> + let j = List.length gls in + (tclDISPATCH (List.init j (fun i -> tac sigma gls i))) + + let fix_iterative t = + let rec aux depth = + Proofview.tclOR + (t depth) + (function + | (ReachedLimitEx,_) -> aux (succ depth) + | (e,ie) -> Proofview.tclZERO ~info:ie e) + in aux 1 + + let fix_iterative_limit limit t = + let open Proofview in + let rec aux depth = + if Int.equal depth (succ limit) then tclZERO ReachedLimitEx + else tclOR (t depth) (function (ReachedLimitEx, _) -> aux (succ depth) + | (e,ie) -> Proofview.tclZERO ~info:ie e) + in aux 1 + + let eauto_tac ?(st=full_transparent_state) ?(unique=false) + ~only_classes ?strategy ~depth ~dep hints = + let open Proofview in + let tac = + let search = search_tac ~st only_classes dep hints in + let dfs = + match strategy with + | None -> not (get_typeclasses_iterative_deepening ()) + | Some Dfs -> true + | Some Bfs -> false + in + if dfs then + let depth = match depth with None -> -1 | Some d -> d in + search depth + else + match depth with + | None -> fix_iterative search + | Some l -> fix_iterative_limit l search + in + let error (e, ie) = + match e with + | ReachedLimitEx -> + Tacticals.New.tclFAIL 0 (str"Proof search reached its limit") + | NotApplicableEx -> + Tacticals.New.tclFAIL 0 (str"Proof search failed" ++ + (if Option.is_empty depth then mt() + else str" without reaching its limit")) + | Proofview.MoreThanOneSuccess -> + Tacticals.New.tclFAIL 0 (str"Proof search failed: " ++ + str"more than one success found") + | e -> Proofview.tclZERO ~info:ie e + in + let tac = Proofview.tclOR tac error in + let tac = + if unique then + Proofview.tclEXACTLY_ONCE Proofview.MoreThanOneSuccess tac + else tac + in + with_shelf numgoals >>= fun (initshelf, i) -> + (if !typeclasses_debug > 1 then + Feedback.msg_debug (str"Starting resolution with " ++ int i ++ + str" goal(s) under focus and " ++ + int (List.length initshelf) ++ str " shelved goal(s)" ++ + (if only_classes then str " in only_classes mode" else str " in regular mode") ++ + match depth with None -> str ", unbounded" + | Some i -> str ", with depth limit " ++ int i)); + tac + + let run_on_evars p evm tac = + match evars_to_goals p evm with + | None -> None (* This happens only because there's no evar having p *) + | Some (goals, evm') -> + let goals = + if !typeclasses_dependency_order then + top_sort evm' goals + else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals) + in + let fgoals = Evd.future_goals evm in + let pgoal = Evd.principal_future_goal evm in + let _, pv = Proofview.init evm' [] in + let pv = Proofview.unshelve goals pv in + try + let (), pv', (unsafe, shelved, gaveup), _ = + Proofview.apply (Global.env ()) tac pv + in + if Proofview.finished pv' then + let evm' = Proofview.return pv' in + assert(Evd.fold_undefined (fun ev _ acc -> + let okev = Evd.mem evm ev || List.mem ev shelved in + if not okev then + Feedback.msg_debug + (str "leaking evar " ++ int (Evar.repr ev) ++ + spc () ++ pr_ev evm' ev); + acc && okev) evm' true); + let evm' = Evd.restore_future_goals evm' (shelved @ fgoals) pgoal in + let evm' = evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm in + Some evm' + else raise Not_found + with Logic_monad.TacticFailure _ -> raise Not_found + + let evars_eauto depth only_classes unique dep st hints p evd = + let eauto_tac = eauto_tac ~st ~unique ~only_classes ~depth ~dep:(unique || dep) hints in + let res = run_on_evars p evd eauto_tac in + match res with + | None -> evd + | Some evd' -> evd' + + let typeclasses_eauto ?depth unique st hints p evd = + evars_eauto depth true unique false st hints p evd + (** Typeclasses eauto is an eauto which tries to resolve only + goals of typeclass type, and assumes that the initially selected + evars in evd are independent of the rest of the evars *) + + let typeclasses_resolve debug depth unique p evd = + let db = searchtable_map typeclasses_db in + typeclasses_eauto ?depth unique (Hint_db.transparent_state db) [db] p evd +end + +(** Binding to either V85 or Search implementations. *) + +let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) + ?strategy ~depth dbs = + let dbs = List.map_filter + (fun db -> try Some (searchtable_map db) + with e when CErrors.noncritical e -> None) + dbs + in + let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in + let depth = match depth with None -> get_typeclasses_depth () | Some l -> Some l in + if get_typeclasses_legacy_resolution () then + Proofview.V82.tactic + (fun gl -> + try V85.eauto85 depth ~only_classes ~st ?strategy dbs gl + with Not_found -> + Refiner.tclFAIL 0 (str"Proof search failed") gl) + else Search.eauto_tac ~st ~only_classes ?strategy ~depth ~dep:true dbs (** We compute dependencies via a union-find algorithm. Beware of the imperative effects on the partition structure, @@ -691,24 +1422,6 @@ let evar_dependencies evm p = in Intpart.union_set evars p) evm () -let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = - let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env gl in - let (gl,t,sigma) = - Goal.V82.mk_goal sigma nc gl Store.empty in - let gls = { it = gl ; sigma = sigma; } in - let hints = searchtable_map typeclasses_db in - let gls' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in - let evd = sig_sig gls' in - let t' = let (ev, inst) = destEvar t in - mkEvar (ev, Array.of_list subst) - in - let term = Evarutil.nf_evar evd t' in - evd, term - -let _ = - Typeclasses.solve_instantiation_problem := - (fun x y z w -> resolve_one_typeclass x ~sigma:y z w) - (** [split_evars] returns groups of undefined evars according to dependencies *) let split_evars evm = @@ -724,9 +1437,9 @@ let is_inference_forced p evd ev = then let (loc, k) = evar_source ev evd in match k with - | Evar_kinds.ImplicitArg (_, _, b) -> b - | Evar_kinds.QuestionMark _ -> false - | _ -> true + | Evar_kinds.ImplicitArg (_, _, b) -> b + | Evar_kinds.QuestionMark _ -> false + | _ -> true else true with Not_found -> assert false @@ -793,12 +1506,11 @@ let revert_resolvability oevd evd = in Evd.raw_map_undefined map evd -(** If [do_split] is [true], we try to separate the problem in - several components and then solve them separately *) - exception Unresolved -let resolve_all_evars debug m unique env p oevd do_split fail = +(** If [do_split] is [true], we try to separate the problem in + several components and then solve them separately *) +let resolve_all_evars debug depth unique env p oevd do_split fail = let split = if do_split then split_evars oevd else [Evar.Set.empty] in let in_comp comp ev = if do_split then Evar.Set.mem ev comp else true in @@ -807,16 +1519,21 @@ let resolve_all_evars debug m unique env p oevd do_split fail = | comp :: comps -> let p = select_and_update_evars p oevd (in_comp comp) in try - let evd' = resolve_all_evars_once debug m unique p evd in - if has_undefined p oevd evd' then raise Unresolved; - docomp evd' comps + let evd' = + if get_typeclasses_legacy_resolution () then + V85.resolve_all_evars_once debug depth unique p evd + else + Search.typeclasses_resolve debug depth unique p evd + in + if has_undefined p oevd evd' then raise Unresolved; + docomp evd' comps with Unresolved | Not_found -> - if fail && (not do_split || is_mandatory (p evd) comp evd) - then (* Unable to satisfy the constraints. *) + if fail && (not do_split || is_mandatory (p evd) comp evd) + then (* Unable to satisfy the constraints. *) let comp = if do_split then Some comp else None in - error_unresolvable env comp evd - else (* Best effort: do nothing on this component *) - docomp evd comps + error_unresolvable env comp evd + else (* Best effort: do nothing on this component *) + docomp evd comps in docomp oevd split let initial_select_evars filter = @@ -824,61 +1541,51 @@ let initial_select_evars filter = filter ev (snd evi.Evd.evar_source) && Typeclasses.is_class_evar evd evi -let resolve_typeclass_evars debug m unique env evd filter split fail = +let resolve_typeclass_evars debug depth unique env evd filter split fail = let evd = - try Evarconv.consider_remaining_unif_problems + try Evarconv.solve_unif_constraints_with_heuristics ~ts:(Typeclasses.classes_transparent_state ()) env evd - with e when Errors.noncritical e -> evd + with e when CErrors.noncritical e -> evd in - resolve_all_evars debug m unique env (initial_select_evars filter) evd split fail + resolve_all_evars debug depth unique env + (initial_select_evars filter) evd split fail -let solve_inst debug depth env evd filter unique split fail = - resolve_typeclass_evars debug depth unique env evd filter split fail +let solve_inst env evd filter unique split fail = + resolve_typeclass_evars + (get_typeclasses_debug ()) + (get_typeclasses_depth ()) + unique env evd filter split fail let _ = - Typeclasses.solve_instantiations_problem := - solve_inst false !typeclasses_depth - -let set_typeclasses_debug d = (:=) typeclasses_debug d; - Typeclasses.solve_instantiations_problem := solve_inst d !typeclasses_depth - -let get_typeclasses_debug () = !typeclasses_debug + Hook.set Typeclasses.solve_all_instances_hook solve_inst -let set_typeclasses_depth d = (:=) typeclasses_depth d; - Typeclasses.solve_instantiations_problem := solve_inst !typeclasses_debug !typeclasses_depth - -let get_typeclasses_depth () = !typeclasses_depth - -open Goptions - -let set_typeclasses_debug = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "debug output for typeclasses proof search"; - optkey = ["Typeclasses";"Debug"]; - optread = get_typeclasses_debug; - optwrite = set_typeclasses_debug; } - -let set_typeclasses_depth = - declare_int_option - { optsync = true; - optdepr = false; - optname = "depth for typeclasses proof search"; - optkey = ["Typeclasses";"Depth"]; - optread = get_typeclasses_depth; - optwrite = set_typeclasses_depth; } +let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = + let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env gl in + let (gl,t,sigma) = + Goal.V82.mk_goal sigma nc gl Store.empty in + let gls = { it = gl ; sigma = sigma; } in + let hints = searchtable_map typeclasses_db in + let st = Hint_db.transparent_state hints in + let depth = get_typeclasses_depth () in + let gls' = + if get_typeclasses_legacy_resolution () then + V85.eauto85 depth ~st [hints] gls + else + try + Proofview.V82.of_tactic + (Search.eauto_tac ~st ~only_classes:true ~depth [hints] ~dep:true) gls + with Refiner.FailError _ -> raise Not_found + in + let evd = sig_sig gls' in + let t' = let (ev, inst) = destEvar t in + mkEvar (ev, Array.of_list subst) + in + let term = Evarutil.nf_evar evd t' in + evd, term -let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl = - try - let dbs = List.map_filter - (fun db -> try Some (searchtable_map db) - with e when Errors.noncritical e -> None) - dbs - in - let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in - eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl - with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl +let _ = + Hook.set Typeclasses.solve_one_instance_hook + (fun x y z w -> resolve_one_typeclass x ~sigma:y z w) (** Take the head of the arity of a constr. Used in the partial application tactic. *) @@ -895,18 +1602,21 @@ let head_of_constr h c = let c = head_of_constr c in letin_tac None (Name h) c None Locusops.allHyps -let not_evar c = match kind_of_term c with -| Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar") -| _ -> Proofview.tclUNIT () +let not_evar c = + Proofview.tclEVARMAP >>= fun sigma -> + match Evarutil.kind_of_term_upto sigma c with + | Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar") + | _ -> Proofview.tclUNIT () let is_ground c gl = if Evarutil.is_ground_term (project gl) c then tclIDTAC gl else tclFAIL 0 (str"Not ground") gl let autoapply c i gl = - let flags = auto_unif_flags Evar.Set.empty + let flags = auto_unif_flags Evar.Set.empty (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in let cty = pf_unsafe_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl ((c,cty,Univ.ContextSet.empty),ce) } in + let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl + ((c,cty,Univ.ContextSet.empty),0,ce) } in Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index f1bcfa7dd4..76760db025 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** This files implements typeclasses eauto *) + open Names open Constr open Tacmach @@ -18,10 +20,13 @@ val get_typeclasses_debug : unit -> bool val set_typeclasses_depth : int option -> unit val get_typeclasses_depth : unit -> int option -val progress_evars : unit Proofview.tactic -> unit Proofview.tactic +type search_strategy = Dfs | Bfs + +val set_typeclasses_strategy : search_strategy -> unit -val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> - Hints.hint_db_name list -> tactic +val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> ?strategy:search_strategy -> + depth:(Int.t option) -> + Hints.hint_db_name list -> unit Proofview.tactic val head_of_constr : Id.t -> Term.constr -> unit Proofview.tactic @@ -30,3 +35,23 @@ val not_evar : constr -> unit Proofview.tactic val is_ground : constr -> tactic val autoapply : constr -> Hints.hint_db_name -> tactic + +module Search : sig + val eauto_tac : + ?st:Names.transparent_state -> + (** The transparent_state used when working with local hypotheses *) + ?unique:bool -> + (** Should we force a unique solution *) + only_classes:bool -> + (** Should non-class goals be shelved and resolved at the end *) + ?strategy:search_strategy -> + (** Is a traversing-strategy specified? *) + depth:Int.t option -> + (** Bounded or unbounded search *) + dep:bool -> + (** Should the tactic be made backtracking on the initial goals, + whatever their internal dependencies are. *) + Hints.hint_db list -> + (** The list of hint databases to use *) + unit Proofview.tactic +end diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index ab6fb37fd1..6b29f574cc 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -6,16 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors open Term open Hipattern open Tactics open Coqlib open Reductionops open Misctypes -open Sigma.Notations open Proofview.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (* Absurd *) @@ -44,11 +43,13 @@ let absurd c = absurd c (* Contradiction *) +let use_negated_unit_or_eq_type () = Flags.version_strictly_greater Flags.V8_5 + (** [f] does not assume its argument to be [nf_evar]-ed. *) let filter_hyp f tac = let rec seek = function | [] -> Proofview.tclZERO Not_found - | d::rest when f (get_type d) -> tac (get_id d) + | d::rest when f (NamedDecl.get_type d) -> tac (NamedDecl.get_id d) | _::rest -> seek rest in Proofview.Goal.enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in @@ -62,13 +63,28 @@ let contradiction_context = let rec seek_neg l = match l with | [] -> Tacticals.New.tclZEROMSG (Pp.str"No such contradiction") | d :: rest -> - let id = get_id d in - let typ = nf_evar sigma (get_type d) in - let typ = whd_betadeltaiota env sigma typ in + let id = NamedDecl.get_id d in + let typ = nf_evar sigma (NamedDecl.get_type d) in + let typ = whd_all env sigma typ in if is_empty_type typ then simplest_elim (mkVar id) else match kind_of_term typ with | Prod (na,t,u) when is_empty_type u -> + let is_unit_or_eq = + if use_negated_unit_or_eq_type () then match_with_unit_or_eq_type t + else None in + Tacticals.New.tclORELSE + (match is_unit_or_eq with + | Some _ -> + let hd,args = decompose_app t in + let (ind,_ as indu) = destInd hd in + let nparams = Inductiveops.inductive_nparams_env env ind in + let params = Util.List.firstn nparams args in + let p = applist ((mkConstructUi (indu,1)), params) in + (* Checking on the fly that it type-checks *) + simplest_elim (mkApp (mkVar id,[|p|])) + | None -> + Tacticals.New.tclZEROMSG (Pp.str"Not a negated unit type.")) (Proofview.tclORELSE (Proofview.Goal.enter { enter = begin fun gl -> let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in @@ -86,7 +102,7 @@ let contradiction_context = end } let is_negation_of env sigma typ t = - match kind_of_term (whd_betadeltaiota env sigma t) with + match kind_of_term (whd_all env sigma t) with | Prod (na,t,u) -> let u = nf_evar sigma u in is_empty_type u && is_conv_leq env sigma typ t diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 9cfb805d4c..885183174b 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -7,7 +7,7 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util open Names open Nameops @@ -17,12 +17,10 @@ open Proof_type open Tacticals open Tacmach open Tactics -open Patternops open Clenv open Auto open Genredexpr -open Tacexpr -open Misctypes +open Tactypes open Locus open Locusops open Hints @@ -31,11 +29,11 @@ open Proofview.Notations let eauto_unif_flags = auto_flags_of_state full_transparent_state let e_give_exact ?(flags=eauto_unif_flags) c = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let t1 = Tacmach.New.pf_unsafe_type_of gl c in - let t2 = Tacmach.New.pf_concl gl in + let t2 = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in if occur_existential t1 || occur_existential t2 then - Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (Proofview.V82.tactic (exact_no_check c)) + Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) else exact_check c end } @@ -52,16 +50,6 @@ let registered_e_assumption = (Tacmach.New.pf_ids_of_hyps gl)) end } -let eval_uconstrs ist cs = - let flags = { - Pretyping.use_typeclasses = false; - use_unif_heuristics = true; - use_hook = Some Pfedit.solve_by_implicit_tactic; - fail_evar = false; - expand_evars = true - } in - List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs - (************************************************************************) (* PROLOG tactic *) (************************************************************************) @@ -109,19 +97,18 @@ let prolog_tac l n = in let l = List.map map l in try (prolog l n gl) - with UserError ("Refiner.tclFIRST",_) -> - errorlabstrm "Prolog.prolog" (str "Prolog failed.") + with UserError (Some "Refiner.tclFIRST",_) -> + user_err ~hdr:"Prolog.prolog" (str "Prolog failed.") end open Auto -open Unification (***************************************************************************) (* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) (***************************************************************************) let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) - + let unify_e_resolve poly flags (c,clenv) = Proofview.Goal.nf_enter { enter = begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in @@ -132,20 +119,22 @@ let unify_e_resolve poly flags (c,clenv) = (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) end } -let hintmap_of hdc concl = +let hintmap_of secvars hdc concl = match hdc with - | None -> fun db -> Hint_db.map_none db + | None -> fun db -> Hint_db.map_none ~secvars db | Some hdc -> - if occur_existential concl then (fun db -> Hint_db.map_existential hdc concl db) - else (fun db -> Hint_db.map_auto hdc concl db) + if occur_existential concl then + (fun db -> Hint_db.map_existential ~secvars hdc concl db) + else (fun db -> Hint_db.map_auto ~secvars hdc concl db) (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) let e_exact poly flags (c,clenv) = - let (c, _, _) = c in - let clenv', subst = - if poly then Clenv.refresh_undefined_univs clenv - else clenv, Univ.empty_level_subst - in e_give_exact (* ~flags *) (Vars.subst_univs_level_constr subst c) + Proofview.Goal.enter { enter = begin fun gl -> + let clenv', c = connect_hint_clenv poly c clenv gl in + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) + (e_give_exact c) + end } let rec e_trivial_fail_db db_list local_db = let next = Proofview.Goal.nf_enter { enter = begin fun gl -> @@ -154,16 +143,17 @@ let rec e_trivial_fail_db db_list local_db = e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) end } in Proofview.Goal.enter { enter = begin fun gl -> + let secvars = compute_secvars gl in let tacl = registered_e_assumption :: (Tacticals.New.tclTHEN Tactics.intro next) :: - (List.map fst (e_trivial_resolve db_list local_db (Tacmach.New.pf_nf_concl gl))) + (List.map fst (e_trivial_resolve db_list local_db secvars (Tacmach.New.pf_nf_concl gl))) in Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) end } -and e_my_find_search db_list local_db hdc concl = - let hint_of_db = hintmap_of hdc concl in +and e_my_find_search db_list local_db secvars hdc concl = + let hint_of_db = hintmap_of secvars hdc concl in let hintl = List.map_append (fun db -> let flags = auto_flags_of_state (Hint_db.transparent_state db) in @@ -191,14 +181,15 @@ and e_my_find_search db_list local_db hdc concl = in List.map tac_of_hint hintl -and e_trivial_resolve db_list local_db gl = +and e_trivial_resolve db_list local_db secvars gl = let hd = try Some (decompose_app_bound gl) with Bound -> None in - try priority (e_my_find_search db_list local_db hd gl) + try priority (e_my_find_search db_list local_db secvars hd gl) with Not_found -> [] -let e_possible_resolve db_list local_db gl = +let e_possible_resolve db_list local_db secvars gl = let hd = try Some (decompose_app_bound gl) with Bound -> None in - try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) (e_my_find_search db_list local_db hd gl) + try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) + (e_my_find_search db_list local_db secvars hd gl) with Not_found -> [] let find_first_goal gls = @@ -215,7 +206,7 @@ type search_state = { dblist : hint_db list; localdb : hint_db list; prev : prev_search_state; - local_lemmas : Tacexpr.delayed_open_constr list; + local_lemmas : delayed_open_constr list; } and prev_search_state = (* for info eauto *) @@ -243,8 +234,8 @@ module SearchProblem = struct (* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) (lgls, cost, pptac) :: aux tacl - with e when Errors.noncritical e -> - let e = Errors.push e in + with e when CErrors.noncritical e -> + let e = CErrors.push e in Refiner.catch_failerror e; aux tacl in aux l @@ -267,9 +258,11 @@ module SearchProblem = struct let nbgl = List.length (sig_it lg) in assert (nbgl > 0); let g = find_first_goal lg in + let hyps = pf_ids_of_hyps g in + let secvars = secvars_of_hyps (pf_hyps g) in let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in let assumption_tacs = - let tacs = List.map map_assum (pf_ids_of_hyps g) in + let tacs = List.map map_assum hyps in let l = filter_tactics s.tacres tacs in List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; last_tactic = pp; dblist = s.dblist; @@ -294,7 +287,9 @@ module SearchProblem = struct in let rec_tacs = let l = - filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) + let concl = Reductionops.nf_evar (project g)(pf_concl g) in + filter_tactics s.tacres + (e_possible_resolve s.dblist (List.hd s.localdb) secvars concl) in List.map (fun (lgls, cost, pp) -> @@ -357,13 +352,13 @@ let mk_eauto_dbg d = else Off let pr_info_nop = function - | Info -> msg_debug (str "idtac.") + | Info -> Feedback.msg_info (str "idtac.") | _ -> () let pr_dbg_header = function | Off -> () - | Debug -> msg_debug (str "(* debug eauto : *)") - | Info -> msg_debug (str "(* info eauto : *)") + | Debug -> Feedback.msg_debug (str "(* debug eauto: *)") + | Info -> Feedback.msg_info (str "(* info eauto: *)") let pr_info dbg s = if dbg != Info then () @@ -374,7 +369,7 @@ let pr_info dbg s = | State sp -> let mindepth = loop sp in let indent = String.make (mindepth - sp.depth) ' ' in - msg_debug (str indent ++ Lazy.force s.last_tactic ++ str "."); + Feedback.msg_info (str indent ++ Lazy.force s.last_tactic ++ str "."); mindepth in ignore (loop s) @@ -421,9 +416,7 @@ let eauto ?(debug=Off) np lems dbnames = tclTRY (e_search_auto debug np lems db_list) let full_eauto ?(debug=Off) n lems gl = - let dbnames = current_db_names () in - let dbnames = String.Set.remove "v62" dbnames in - let db_list = List.map searchtable_map (String.Set.elements dbnames) in + let db_list = current_pure_db () in tclTRY (e_search_auto debug n lems db_list) gl let gen_eauto ?(debug=Off) np lems = function @@ -443,7 +436,7 @@ let cons a l = a :: l let autounfolds db occs cls gl = let unfolds = List.concat (List.map (fun dbname -> let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in let hyps = pf_ids_of_hyps gl in @@ -510,7 +503,7 @@ let autounfold_one db cl = let st = List.fold_left (fun (i,c) dbname -> let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 8812093d5f..1f69e4ab3c 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -9,6 +9,7 @@ open Term open Proof_type open Hints +open Tactypes val e_assumption : unit Proofview.tactic @@ -16,15 +17,15 @@ val registered_e_assumption : unit Proofview.tactic val e_give_exact : ?flags:Unification.unify_flags -> constr -> unit Proofview.tactic -val prolog_tac : Tacexpr.delayed_open_constr list -> int -> unit Proofview.tactic +val prolog_tac : delayed_open_constr list -> int -> unit Proofview.tactic -val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list -> +val gen_eauto : ?debug:debug -> bool * int -> delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic val eauto_with_bases : - ?debug:Tacexpr.debug -> + ?debug:debug -> bool * int -> - Tacexpr.delayed_open_constr list -> hint_db list -> Proof_type.tactic + delayed_open_constr list -> hint_db list -> Proof_type.tactic val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic diff --git a/tactics/elim.ml b/tactics/elim.ml index d441074f6a..3f0c01a29c 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -16,7 +16,8 @@ open Tacmach.New open Tacticals.New open Tactics open Proofview.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (* Supposed to be called without as clause *) let introElimAssumsThen tac ba = @@ -25,14 +26,14 @@ let introElimAssumsThen tac ba = (tclTHEN introElimAssums (elim_on_ba tac ba)) (* Supposed to be called with a non-recursive scheme *) -let introCaseAssumsThen tac ba = +let introCaseAssumsThen with_evars tac ba = let n1 = List.length ba.Tacticals.branchsign in let n2 = List.length ba.Tacticals.branchnames in let (l1,l2),l3 = if n1 < n2 then List.chop n1 ba.Tacticals.branchnames, [] else (ba.Tacticals.branchnames, []), List.make (n1-n2) false in let introCaseAssums = - tclTHEN (intro_patterns l1) (intros_clearing l3) in + tclTHEN (intro_patterns with_evars l1) (intros_clearing l3) in (tclTHEN introCaseAssums (case_on_ba (tac l2) ba)) (* The following tactic Decompose repeatedly applies the @@ -63,7 +64,7 @@ and general_decompose_aux recognizer id = elimHypThen (introElimAssumsThen (fun bas -> - tclTHEN (Proofview.V82.tactic (clear [id])) + tclTHEN (clear [id]) (tclMAP (general_decompose_on_hyp recognizer) (ids_of_named_context bas.Tacticals.assums)))) id @@ -83,8 +84,8 @@ let general_decompose recognizer c = [ tclTHEN (intro_using tmphyp_name) (onLastHypId (ifOnHyp recognizer (general_decompose_aux recognizer) - (fun id -> Proofview.V82.tactic (clear [id])))); - Proofview.V82.tactic (exact_no_check c) ] + (fun id -> clear [id]))); + exact_no_check c ] end } let head_in indl t gl = @@ -139,7 +140,7 @@ let induction_trailer abs_i abs_j bargs = let (hyps,_) = List.fold_left (fun (bring_ids,leave_ids) d -> - let cid = get_id d in + let cid = NamedDecl.get_id d in if not (List.mem cid leave_ids) then (d::bring_ids,leave_ids) else (bring_ids,cid::leave_ids)) diff --git a/tactics/elim.mli b/tactics/elim.mli index a94f642a07..29c4414636 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -10,11 +10,12 @@ open Names open Term open Tacticals open Misctypes +open Tactypes (** Eliminations tactics. *) -val introCaseAssumsThen : - (Tacexpr.intro_patterns -> branch_assumptions -> unit Proofview.tactic) -> +val introCaseAssumsThen : evars_flag -> + (intro_patterns -> branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic val h_decompose : inductive list -> constr -> unit Proofview.tactic diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index de28189023..93073fdc7e 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -52,19 +52,21 @@ let optimize_non_type_induction_scheme kind dep sort _ ind = let u = Univ.UContext.instance ctx in let ctxset = Univ.ContextSet.of_context ctx in let ectx = Evd.evar_universe_context_of ctxset in - let sigma, c = build_induction_scheme env (Evd.from_ctx ectx) (ind,u) dep sort in + let sigma = Evd.merge_universe_context sigma ectx in + let sigma, c = build_induction_scheme env sigma (ind,u) dep sort in (c, Evd.evar_universe_context sigma), Safe_typing.empty_private_constants let build_induction_scheme_in_type dep sort ind = let env = Global.env () in + let sigma = Evd.from_env env in let ctx = let mib,mip = Inductive.lookup_mind_specif env ind in Declareops.inductive_context mib in let u = Univ.UContext.instance ctx in let ctxset = Univ.ContextSet.of_context ctx in - let ectx = Evd.evar_universe_context_of ctxset in - let sigma, c = build_induction_scheme env (Evd.from_ctx ectx) (ind,u) dep sort in + let sigma = Evd.merge_universe_context sigma (Evd.evar_universe_context_of ctxset) in + let sigma, c = build_induction_scheme env sigma (ind,u) dep sort in c, Evd.evar_universe_context sigma let rect_scheme_kind_from_type = @@ -95,6 +97,10 @@ let rec_scheme_kind_from_prop = declare_individual_scheme_object "_rec" ~aux:"_rec_from_prop" (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InSet) +let rec_scheme_kind_from_type = + declare_individual_scheme_object "_rec_nodep" ~aux:"_rec_nodep_from_type" + (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InSet) + let rec_dep_scheme_kind_from_type = declare_individual_scheme_object "_rec" ~aux:"_rec_from_type" (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InSet) diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli index c36797059e..77f927f2df 100644 --- a/tactics/elimschemes.mli +++ b/tactics/elimschemes.mli @@ -13,9 +13,11 @@ open Ind_tables val rect_scheme_kind_from_prop : individual scheme_kind val ind_scheme_kind_from_prop : individual scheme_kind val rec_scheme_kind_from_prop : individual scheme_kind +val rect_scheme_kind_from_type : individual scheme_kind val rect_dep_scheme_kind_from_type : individual scheme_kind val ind_scheme_kind_from_type : individual scheme_kind val ind_dep_scheme_kind_from_type : individual scheme_kind +val rec_scheme_kind_from_type : individual scheme_kind val rec_dep_scheme_kind_from_type : individual scheme_kind diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 011296a8d0..1a67bedc28 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -12,7 +12,6 @@ (* by Eduardo Gimenez *) (************************************************************************) -open Errors open Util open Names open Namegen @@ -23,11 +22,11 @@ open Tacticals.New open Auto open Constr_matching open Misctypes +open Tactypes open Hipattern open Pretyping open Tacmach.New open Coqlib -open Proofview.Notations (* This file containts the implementation of the tactics ``Decide Equality'' and ``Compare''. They can be used to decide the @@ -51,7 +50,6 @@ open Proofview.Notations Eduardo Gimenez (30/3/98). *) -let clear ids = Proofview.V82.tactic (clear ids) let clear_last = (onLastHyp (fun c -> (clear [destVar c]))) let choose_eq eqonleft = @@ -67,7 +65,7 @@ let choose_noteq eqonleft = let mkBranches c1 c2 = tclTHENLIST - [Proofview.V82.tactic (generalize [c2]); + [generalize [c2]; Simple.elim c1; intros; onLastHyp Simple.case; @@ -76,7 +74,7 @@ let mkBranches c1 c2 = let discrHyp id = let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in - let tac c = Equality.discr_tac false (Some (None, Tacexpr.ElimOnConstr c)) in + let tac c = Equality.discr_tac false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac let solveNoteqBranch side = @@ -124,7 +122,7 @@ let eqCase tac = let injHyp id = let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in - let tac c = Equality.injClause None false (Some (None, Tacexpr.ElimOnConstr c)) in + let tac c = Equality.injClause None false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac let diseqCase hyps eqonleft = diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index a03489c805..c94dcfa9df 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -44,7 +44,7 @@ natural expectation of the user. *) -open Errors +open CErrors open Util open Names open Term @@ -60,6 +60,8 @@ open Indrec open Sigma.Notations open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + let hid = Id.of_string "H" let xid = Id.of_string "X" let default_id_of_sort = function InProp | InSet -> hid | InType -> xid @@ -600,9 +602,9 @@ let fix_r2l_forward_rew_scheme (c, ctx') = | hp :: p :: ind :: indargs -> let c' = my_it_mkLambda_or_LetIn indargs - (mkLambda_or_LetIn (map_constr (liftn (-1) 1) p) - (mkLambda_or_LetIn (map_constr (liftn (-1) 2) hp) - (mkLambda_or_LetIn (map_constr (lift 2) ind) + (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 1) p) + (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 2) hp) + (mkLambda_or_LetIn (RelDecl.map_constr (lift 2) ind) (Reductionops.whd_beta Evd.empty (applist (c, Context.Rel.to_extended_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) @@ -741,7 +743,7 @@ let build_congr env (eq,refl,ctx) ind = if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported."; let env_with_arity = push_rel_context arityctxt env in - let ty = get_type (lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity) in + let ty = RelDecl.get_type (lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity) in let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in if Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt) then diff --git a/tactics/equality.ml b/tactics/equality.ml index cb1d82ae6b..a0d2da863d 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -7,7 +7,7 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util open Names open Nameops @@ -26,7 +26,6 @@ open Retyping open Tacmach.New open Logic open Hipattern -open Tacexpr open Tacticals.New open Tactics open Tacred @@ -45,6 +44,8 @@ open Proofview.Notations open Unification open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + (* Options *) let discriminate_introduction = ref true @@ -72,14 +73,27 @@ let _ = declare_bool_option { optsync = true; optdepr = false; - optname = "injection left-to-right pattern order"; + optname = "injection left-to-right pattern order and clear by default when with introduction pattern"; optkey = ["Injection";"L2R";"Pattern";"Order"]; optread = (fun () -> !injection_pattern_l2r_order) ; optwrite = (fun b -> injection_pattern_l2r_order := b) } -(* Rewriting tactics *) +let injection_in_context = ref false + +let use_injection_in_context () = + !injection_in_context + && Flags.version_strictly_greater Flags.V8_5 + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "injection in context"; + optkey = ["Structural";"Injection"]; + optread = (fun () -> !injection_in_context) ; + optwrite = (fun b -> injection_in_context := b) } -let clear ids = Proofview.V82.tactic (clear ids) +(* Rewriting tactics *) let tclNOTSAMEGOAL tac = Proofview.V82.tactic (Tacticals.tclNOTSAMEGOAL (Proofview.V82.of_tactic tac)) @@ -346,7 +360,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = let _ = Global.lookup_constant c1' in c1' with Not_found -> - errorlabstrm "Equality.find_elim" + user_err ~hdr:"Equality.find_elim" (str "Cannot find rewrite principle " ++ pr_label l' ++ str ".") end | _ -> destConstRef pr1 @@ -387,7 +401,8 @@ let type_of_clause cls gl = match cls with let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let isatomic = isProd (whd_zeta hdcncl) in + let evd = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let isatomic = isProd (whd_zeta evd hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun c type_of_cls in @@ -615,7 +630,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = in match evd with | None -> - tclFAIL 0 (str"Terms do not have convertible types.") + tclFAIL 0 (str"Terms do not have convertible types") | Some evd -> let e = build_coq_eq () in let sym = build_coq_eq_sym () in @@ -687,16 +702,16 @@ let replace_in_clause_maybe_by c1 c2 cl tac_opt = exception DiscrFound of (constructor * int) list * constructor * constructor -let injection_on_proofs = ref false +let keep_proof_equalities_for_injection = ref false let _ = declare_bool_option { optsync = true; optdepr = false; optname = "injection on prop arguments"; - optkey = ["Injection";"On";"Proofs"]; - optread = (fun () -> !injection_on_proofs) ; - optwrite = (fun b -> injection_on_proofs := b) } + optkey = ["Keep";"Proof";"Equalities"]; + optread = (fun () -> !keep_proof_equalities_for_injection) ; + optwrite = (fun b -> keep_proof_equalities_for_injection := b) } let find_positions env sigma t1 t2 = @@ -707,8 +722,8 @@ let find_positions env sigma t1 t2 = then [(List.rev posn,t1,t2)] else [] in let rec findrec sorts posn t1 t2 = - let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in - let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in + let hd1,args1 = whd_all_stack env sigma t1 in + let hd2,args2 = whd_all_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with | Construct (sp1,_), Construct (sp2,_) when Int.equal (List.length args1) (constructor_nallargs_env env sp1) @@ -741,7 +756,7 @@ let find_positions env sigma t1 t2 = project env sorts posn t1_0 t2_0 in try - let sorts = if !injection_on_proofs then [InSet;InType;InProp] + let sorts = if !keep_proof_equalities_for_injection then [InSet;InType;InProp] else [InSet;InType] in Inr (findrec sorts [] t1 t2) @@ -846,7 +861,7 @@ let descend_then env sigma head dirn = List.map build_branch (List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in - mkCase (ci, p, head, Array.of_list brl))) + Inductiveops.make_case_or_project env indf ci p head (Array.of_list brl))) (* Now we need to construct the discriminator, given a discriminable position. This boils down to: @@ -874,7 +889,7 @@ let build_selector env sigma dirn c ind special default = on (c bool true) = (c bool false) CP : changed assert false in a more informative error *) - errorlabstrm "Equality.construct_discriminator" + user_err ~hdr:"Equality.construct_discriminator" (str "Cannot discriminate on inductive constructors with \ dependent types.") in let (indp,_) = dest_ind_family indf in @@ -960,7 +975,7 @@ let apply_on_clause (f,t) clause = let argmv = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv - | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in + | _ -> user_err (str "Ill-formed clause applicator.")) in clenv_fchain ~with_univs:false argmv f_clause clause let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = @@ -976,7 +991,7 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS eff <*> tclTHENS (assert_after Anonymous absurd_term) - [onLastHypId gen_absurdity; (Proofview.V82.tactic (refine pf))] + [onLastHypId gen_absurdity; (Proofview.V82.tactic (Tacmach.refine pf))] let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in @@ -1038,7 +1053,7 @@ let discrEverywhere with_evars = else (* <= 8.2 compat *) tryAllHypsAndConcl (discrSimpleClause with_evars)) (* (fun gls -> - errorlabstrm "DiscrEverywhere" (str"No discriminable equalities.")) + user_err ~hdr:"DiscrEverywhere" (str"No discriminable equalities.")) *) let discr_tac with_evars = function | None -> discrEverywhere with_evars @@ -1149,7 +1164,8 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let dflt_typ = unsafe_type_of env sigma dflt in try let () = evdref := Evarconv.the_conv_x_leq env dflt_typ p_i !evdref in - let () = evdref := Evarconv.consider_remaining_unif_problems env !evdref in + let () = + evdref := Evarconv.solve_unif_constraints_with_heuristics env !evdref in dflt with Evarconv.UnableToUnify _ -> error "Cannot solve a unification problem." @@ -1270,7 +1286,7 @@ let build_injector env sigma dflt c cpath = (* let try_delta_expand env sigma t = - let whdt = whd_betadeltaiota env sigma t in + let whdt = whd_all env sigma t in let rec hd_rec c = match kind_of_term c with | Construct _ -> whdt @@ -1318,7 +1334,7 @@ let inject_if_homogenous_dependent_pair ty = onLastHyp (fun hyp -> tclTHENS (cut (mkApp (ceq,new_eq_args))) [clear [destVar hyp]; - Proofview.V82.tactic (refine + Proofview.V82.tactic (Tacmach.refine (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|]))) ])] with Exit -> @@ -1364,7 +1380,7 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = (Proofview.tclIGNORE (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) [inject_if_homogenous_dependent_pair ty; - Proofview.V82.tactic (refine pf)]) + Proofview.V82.tactic (Tacmach.refine pf)]) (if l2r then List.rev injectors else injectors))) (tac (List.length injectors))) @@ -1375,7 +1391,10 @@ let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = | Inl _ -> tclZEROMSG (strbrk"This equality is discriminable. You should use the discriminate tactic to solve the goal.") | Inr [] -> - let suggestion = if !injection_on_proofs then "" else " You can try to use option Set Injection On Proofs." in + let suggestion = + if !keep_proof_equalities_for_injection then + "" else + " You can try to use option Set Keep Proof Equalities." in tclZEROMSG (strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)) | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 -> tclZEROMSG (str"Nothing to inject.") @@ -1383,34 +1402,52 @@ let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = inject_at_positions env sigma l2r u eq_clause posns (tac (clenv_value eq_clause)) -let use_clear_hyp_by_default () = false - -let postInjEqTac clear_flag ipats c n = - match ipats with - | Some ipats -> - let clear_tac = - let dft = - use_injection_pattern_l2r_order () || use_clear_hyp_by_default () in - tclTRY (apply_clear_request clear_flag dft c) in - let intro_tac = - if use_injection_pattern_l2r_order () - then intro_patterns_bound_to n MoveLast ipats - else intro_patterns_to MoveLast ipats in - tclTHEN clear_tac intro_tac - | None -> apply_clear_request clear_flag false c - -let injEq clear_flag ipats = - let l2r = - if use_injection_pattern_l2r_order () && not (Option.is_empty ipats) then true else false +let get_previous_hyp_position id gl = + let rec aux dest = function + | [] -> raise (RefinerError (NoSuchHyp id)) + | d :: right -> + let hyp = Context.Named.Declaration.get_id d in + if Id.equal hyp id then dest else aux (MoveAfter hyp) right in - injEqThen (fun c i -> postInjEqTac clear_flag ipats c i) l2r - -let inj ipats with_evars clear_flag = onEquality with_evars (injEq clear_flag ipats) + aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) + +let injEq ?(old=false) with_evars clear_flag ipats = + (* Decide which compatibility mode to use *) + let ipats_style, l2r, dft_clear_flag, bounded_intro = match ipats with + | None when not old && use_injection_in_context () -> + Some [], true, true, true + | None -> None, false, false, false + | _ -> let b = use_injection_pattern_l2r_order () in ipats, b, b, b in + (* Built the post tactic depending on compatibility mode *) + let post_tac c n = + match ipats_style with + | Some ipats -> + Proofview.Goal.enter { enter = begin fun gl -> + let destopt = match kind_of_term c with + | Var id -> get_previous_hyp_position id gl + | _ -> MoveLast in + let clear_tac = + tclTRY (apply_clear_request clear_flag dft_clear_flag c) in + (* Try should be removal if dependency were treated *) + let intro_tac = + if bounded_intro + then intro_patterns_bound_to with_evars n destopt ipats + else intro_patterns_to with_evars destopt ipats in + tclTHEN clear_tac intro_tac + end } + | None -> tclIDTAC in + injEqThen post_tac l2r + +let inj ipats with_evars clear_flag = onEquality with_evars (injEq with_evars clear_flag ipats) let injClause ipats with_evars = function - | None -> onNegatedEquality with_evars (injEq None ipats) + | None -> onNegatedEquality with_evars (injEq with_evars None ipats) | Some c -> onInductionArg (inj ipats with_evars) c +let simpleInjClause with_evars = function + | None -> onNegatedEquality with_evars (injEq ~old:true with_evars None None) + | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (injEq ~old:true with_evars clear_flag None)) c + let injConcl = injClause None false None let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.ghost,id))) @@ -1436,13 +1473,13 @@ let dEq with_evars = dEqThen with_evars (fun clear_flag c x -> (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) -let intro_decompe_eq tac data cl = +let intro_decomp_eq tac data cl = Proofview.Goal.enter { enter = begin fun gl -> let cl = pf_apply make_clenv_binding gl cl NoBindings in decompEqThen (fun _ -> tac) data cl end } -let _ = declare_intro_decomp_eq intro_decompe_eq +let _ = declare_intro_decomp_eq intro_decomp_eq (* [subst_tuple_term dep_pair B] @@ -1584,7 +1621,7 @@ let substClause l2r c cls = Proofview.Goal.enter { enter = begin fun gl -> let eq = pf_apply get_type_of gl c in tclTHENS (cutSubstClause l2r eq cls) - [Proofview.tclUNIT (); Proofview.V82.tactic (exact_no_check c)] + [Proofview.tclUNIT (); exact_no_check c] end } let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls) @@ -1630,12 +1667,16 @@ exception FoundHyp of (Id.t * constr * bool) (* tests whether hyp [c] is [x = t] or [t = x], [x] not occurring in [t] *) let is_eq_x gl x d = - let id = get_id d in + let id = NamedDecl.get_id d in try - let c = pf_nf_evar gl (get_type d) in + let is_var id c = match kind_of_term c with + | Var id' -> Id.equal id id' + | _ -> false + in + let c = pf_nf_evar gl (NamedDecl.get_type d) in let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in - if (Term.eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true)); - if (Term.eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false)) + if (is_var x lhs) && not (local_occur_var x rhs) then raise (FoundHyp (id,rhs,true)); + if (is_var x rhs) && not (local_occur_var x lhs) then raise (FoundHyp (id,lhs,false)) with Constr_matching.PatternMatchingFailure -> () @@ -1650,12 +1691,12 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = (* The set of hypotheses using x *) let dephyps = List.rev (pi3 (List.fold_right (fun dcl (dest,deps,allhyps) -> - let id = get_id dcl in + let id = NamedDecl.get_id dcl in if not (Id.equal id hyp) && List.exists (fun y -> occur_var_in_decl env y dcl) deps then let id_dest = if !regular_subst_tactic then dest else MoveLast in - (dest,(if is_local_assum dcl then deps else id::deps), (id_dest,id)::allhyps) + (dest,id::deps,(id_dest,id)::allhyps) else (MoveBefore id,deps,allhyps)) hyps @@ -1679,19 +1720,17 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = let subst_one_var dep_proof_ok x = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in - let xval = pf_get_hyp x gl |> get_value in + let decl = pf_get_hyp x gl in (* If x has a body, simply replace x with body and clear x *) - if not (Option.is_empty xval) then tclTHEN (unfold_body x) (clear [x]) else - (* x is a variable: *) - let varx = mkVar x in + if is_local_def decl then tclTHEN (unfold_body x) (clear [x]) else (* Find a non-recursive definition for x *) let res = try (** [is_eq_x] ensures nf_evar on its side *) let hyps = Proofview.Goal.hyps gl in - let test hyp _ = is_eq_x gl varx hyp in + let test hyp _ = is_eq_x gl x hyp in Context.Named.fold_outside test ~init:() hyps; - errorlabstrm "Subst" + user_err ~hdr:"Subst" (str "Cannot find any non-recursive equality over " ++ pr_id x ++ str".") with FoundHyp res -> res in @@ -1699,7 +1738,7 @@ let subst_one_var dep_proof_ok x = end } let subst_gen dep_proof_ok ids = - tclTHEN Proofview.V82.nf_evar_goals (tclMAP (subst_one_var dep_proof_ok) ids) + tclMAP (subst_one_var dep_proof_ok) ids (* For every x, look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite it everywhere, and erase hyp and x; proceed by generalizing @@ -1727,35 +1766,38 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in - let test decl = + let select_equation_name decl = try - let lbeq,u,(_,x,y) = find_eq_data_decompose (get_type decl) in + let lbeq,u,(_,x,y) = find_eq_data_decompose (NamedDecl.get_type decl) in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match kind_of_term x, kind_of_term y with - | Var z, _ | _, Var z when not (is_evaluable env (EvalVarRef z)) -> - Some (get_id decl) + | Var z, _ when not (is_evaluable env (EvalVarRef z)) -> + Some (NamedDecl.get_id decl) + | _, Var z when not (is_evaluable env (EvalVarRef z)) -> + Some (NamedDecl.get_id decl) | _ -> None with Constr_matching.PatternMatchingFailure -> None in let hyps = Proofview.Goal.hyps gl in - List.rev (List.map_filter test hyps) + List.rev (List.map_filter select_equation_name hyps) in (* Second step: treat equations *) let process hyp = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in + let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in - let c = pf_get_hyp hyp gl |> get_type in + let c = pf_get_hyp hyp gl |> NamedDecl.get_type in let _,_,(_,x,y) = find_eq_data_decompose c in (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then Proofview.tclUNIT () else match kind_of_term x, kind_of_term y with - | Var x', _ when not (occur_term x y) -> + | Var x', _ when not (occur_term x y) && not (is_evaluable env (EvalVarRef x')) -> subst_one flags.rewrite_dependent_proof x' (hyp,y,true) - | _, Var y' when not (occur_term y x) -> + | _, Var y' when not (occur_term y x) && not (is_evaluable env (EvalVarRef y')) -> subst_one flags.rewrite_dependent_proof y' (hyp,x,false) | _ -> Proofview.tclUNIT () @@ -1817,10 +1859,10 @@ let rewrite_assumption_cond cond_eq_term cl = let rec arec hyps gl = match hyps with | [] -> error "No such assumption." | hyp ::rest -> - let id = get_id hyp in + let id = NamedDecl.get_id hyp in begin try - let dir = cond_eq_term (get_type hyp) gl in + let dir = cond_eq_term (NamedDecl.get_type hyp) gl in general_rewrite_clause dir false (mkVar id,NoBindings) cl with | Failure _ | UserError _ -> arec rest gl end diff --git a/tactics/equality.mli b/tactics/equality.mli index 458d8f3722..6a4a8126e1 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -11,10 +11,10 @@ open Names open Term open Evd open Environ -open Tacexpr open Ind_tables open Locus open Misctypes +open Tactypes (*i*) type dep_proof_flag = bool (* true = support rewriting dependent proofs *) @@ -72,16 +72,18 @@ val discrConcl : unit Proofview.tactic val discrHyp : Id.t -> unit Proofview.tactic val discrEverywhere : evars_flag -> unit Proofview.tactic val discr_tac : evars_flag -> - constr with_bindings induction_arg option -> unit Proofview.tactic + constr with_bindings destruction_arg option -> unit Proofview.tactic val inj : intro_patterns option -> evars_flag -> clear_flag -> constr with_bindings -> unit Proofview.tactic val injClause : intro_patterns option -> evars_flag -> - constr with_bindings induction_arg option -> unit Proofview.tactic + constr with_bindings destruction_arg option -> unit Proofview.tactic val injHyp : clear_flag -> Id.t -> unit Proofview.tactic val injConcl : unit Proofview.tactic +val simpleInjClause : evars_flag -> + constr with_bindings destruction_arg option -> unit Proofview.tactic -val dEq : evars_flag -> constr with_bindings induction_arg option -> unit Proofview.tactic -val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings induction_arg option -> unit Proofview.tactic +val dEq : evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic +val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings destruction_arg option -> unit Proofview.tactic val make_iterated_tuple : env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) diff --git a/tactics/ftactic.ml b/tactics/ftactic.ml deleted file mode 100644 index 588709873e..0000000000 --- a/tactics/ftactic.ml +++ /dev/null @@ -1,106 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Proofview.Notations - -(** Focussing tactics *) - -type 'a focus = -| Uniform of 'a -| Depends of 'a list - -(** Type of tactics potentially goal-dependent. If it contains a [Depends], - then the length of the inner list is guaranteed to be the number of - currently focussed goals. Otherwise it means the tactic does not depend - on the current set of focussed goals. *) -type 'a t = 'a focus Proofview.tactic - -let return (x : 'a) : 'a t = Proofview.tclUNIT (Uniform x) - -let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function -| Uniform x -> f x -| Depends l -> - let f arg = f arg >>= function - | Uniform x -> - (** We dispatch the uniform result on each goal under focus, as we know - that the [m] argument was actually dependent. *) - Proofview.Goal.goals >>= fun l -> - let ans = List.map (fun _ -> x) l in - Proofview.tclUNIT ans - | Depends l -> Proofview.tclUNIT l - in - Proofview.tclDISPATCHL (List.map f l) >>= fun l -> - Proofview.tclUNIT (Depends (List.concat l)) - -let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l) -let set_sigma r = - let Sigma.Sigma (ans, sigma, _) = r in - Proofview.Unsafe.tclEVARS (Sigma.to_evar_map sigma) >>= fun () -> ans - -let nf_enter f = - bind goals - (fun gl -> - gl >>= fun gl -> - Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> f.enter nfgl)) - -let nf_s_enter f = - bind goals - (fun gl -> - gl >>= fun gl -> - Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter nfgl))) - -let enter f = - bind goals - (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f.enter gl)) - -let s_enter f = - bind goals - (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter gl))) - -let with_env t = - t >>= function - | Uniform a -> - Proofview.tclENV >>= fun env -> Proofview.tclUNIT (Uniform (env,a)) - | Depends l -> - Proofview.Goal.goals >>= fun gs -> - Proofview.Monad.(List.map (map Proofview.Goal.env) gs) >>= fun envs -> - Proofview.tclUNIT (Depends (List.combine envs l)) - -let lift (type a) (t:a Proofview.tactic) : a t = - Proofview.tclBIND t (fun x -> Proofview.tclUNIT (Uniform x)) - -(** If the tactic returns unit, we can focus on the goals if necessary. *) -let run m k = m >>= function -| Uniform v -> k v -| Depends l -> - let tacs = List.map k l in - Proofview.tclDISPATCH tacs - -let (>>=) = bind - -let (<*>) = fun m n -> bind m (fun () -> n) - -module Self = -struct - type 'a t = 'a focus Proofview.tactic - let return = return - let (>>=) = bind - let (>>) = (<*>) - let map f x = x >>= fun a -> return (f a) -end - -module Ftac = Monad.Make(Self) -module List = Ftac.List - -module Notations = -struct - let (>>=) = bind - let (<*>) = fun m n -> bind m (fun () -> n) -end diff --git a/tactics/ftactic.mli b/tactics/ftactic.mli deleted file mode 100644 index 19041f1698..0000000000 --- a/tactics/ftactic.mli +++ /dev/null @@ -1,79 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Proofview.Notations - -(** Potentially focussing tactics *) - -type +'a focus - -type +'a t = 'a focus Proofview.tactic -(** The type of focussing tactics. A focussing tactic is like a normal tactic, - except that it is able to remember it have entered a goal. Whenever this is - the case, each subsequent effect of the tactic is dispatched on the - focussed goals. This is a monad. *) - -(** {5 Monadic interface} *) - -val return : 'a -> 'a t -(** The unit of the monad. *) - -val bind : 'a t -> ('a -> 'b t) -> 'b t -(** The bind of the monad. *) - -(** {5 Operations} *) - -val lift : 'a Proofview.tactic -> 'a t -(** Transform a tactic into a focussing tactic. The resulting tactic is not - focussed. *) - -val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic -(** Given a continuation producing a tactic, evaluates the focussing tactic. If - the tactic has not focussed, then the continuation is evaluated once. - Otherwise it is called in each of the currently focussed goals. *) - -(** {5 Focussing} *) - -val nf_enter : ([ `NF ], 'a t) enter -> 'a t -(** Enter a goal. The resulting tactic is focussed. *) - -val enter : ([ `LZ ], 'a t) enter -> 'a t -(** Enter a goal, without evar normalization. The resulting tactic is - focussed. *) - -val s_enter : ([ `LZ ], 'a t) s_enter -> 'a t -(** Enter a goal and put back an evarmap. The resulting tactic is focussed. *) - -val nf_s_enter : ([ `NF ], 'a t) s_enter -> 'a t -(** Enter a goal, without evar normalization and put back an evarmap. The - resulting tactic is focussed. *) - -val with_env : 'a t -> (Environ.env*'a) t -(** [with_env t] returns, in addition to the return type of [t], an - environment, which is the global environment if [t] does not focus on - goals, or the local goal environment if [t] focuses on goals. *) - -(** {5 Notations} *) - -val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -(** Notation for {!bind}. *) - -val (<*>) : unit t -> 'a t -> 'a t -(** Sequence. *) - -(** {5 List operations} *) - -module List : Monad.ListS with type 'a t := 'a t - -(** {5 Notations} *) - -module Notations : -sig - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val (<*>) : unit t -> 'a t -> 'a t -end diff --git a/tactics/geninterp.ml b/tactics/geninterp.ml deleted file mode 100644 index 0080758000..0000000000 --- a/tactics/geninterp.ml +++ /dev/null @@ -1,35 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Names -open Genarg - -module TacStore = Store.Make(struct end) - -type interp_sign = { - lfun : Val.t Id.Map.t; - extra : TacStore.t } - -type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t - -module InterpObj = -struct - type ('raw, 'glb, 'top) obj = ('glb, 'top) interp_fun - let name = "interp" - let default _ = None -end - -module Interp = Register(InterpObj) - -let interp = Interp.obj -let register_interp0 = Interp.register0 - -let generic_interp ist (GenArg (Glbwit wit, v)) = - let open Ftactic.Notations in - interp wit ist v >>= fun ans -> - Ftactic.return (Val.Dyn (val_tag (topwit wit), ans)) diff --git a/tactics/geninterp.mli b/tactics/geninterp.mli deleted file mode 100644 index 0992db7a29..0000000000 --- a/tactics/geninterp.mli +++ /dev/null @@ -1,27 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** Interpretation functions for generic arguments. *) - -open Names -open Genarg - -module TacStore : Store.S - -type interp_sign = { - lfun : Val.t Id.Map.t; - extra : TacStore.t } - -type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t - -val interp : ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun - -val generic_interp : (glob_generic_argument, Val.t) interp_fun - -val register_interp0 : - ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun -> unit diff --git a/tactics/hints.ml b/tactics/hints.ml index b2104ba433..59d015fa2d 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -8,7 +8,7 @@ open Pp open Util -open Errors +open CErrors open Names open Vars open Term @@ -20,11 +20,11 @@ open Namegen open Libnames open Smartlocate open Misctypes +open Tactypes open Evd open Termops open Inductiveops open Typing -open Tacexpr open Decl_kinds open Pattern open Patternops @@ -34,12 +34,15 @@ open Tacred open Printer open Vernacexpr open Sigma.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (****************************************) (* General functions *) (****************************************) +type debug = Debug | Info | Off + exception Bound let head_constr_bound t = @@ -66,6 +69,29 @@ let decompose_app_bound t = | Proj (p, c) -> ConstRef (Projection.constant p), Array.cons c args | _ -> raise Bound +(** Compute the set of section variables that remain in the named context. + Starts from the top to the bottom of the context, stops at the first + different declaration between the named hyps and the section context. *) +let secvars_of_hyps hyps = + let secctx = Global.named_context () in + let open Context.Named.Declaration in + let pred, all = + List.fold_left (fun (pred,all) decl -> + try let _ = Context.Named.lookup (get_id decl) hyps in + (* Approximation, it might be an hypothesis reintroduced with same name and unconvertible types, + we must allow it currently, as comparing the declarations for syntactic equality is too + strong a check (e.g. an unfold in a section variable would make it unusable). *) + (Id.Pred.add (get_id decl) pred, all) + with Not_found -> (pred, false)) + (Id.Pred.empty,true) secctx + in + if all then Id.Pred.full (* If the whole section context is available *) + else pred + +let empty_hint_info = + let open Vernacexpr in + { hint_priority = None; hint_pattern = None } + (************************************************************************) (* The Type of Constructions Autotactic Hints *) (************************************************************************) @@ -78,18 +104,25 @@ type 'a hint_ast = | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of Genarg.glob_generic_argument (* Hint Extern *) -type hints_path_atom = - | PathHints of global_reference list + +type 'a hints_path_atom_gen = + | PathHints of 'a list + (* For forward hints, their names is the list of projections *) | PathAny -type hints_path = - | PathAtom of hints_path_atom - | PathStar of hints_path - | PathSeq of hints_path * hints_path - | PathOr of hints_path * hints_path +type hints_path_atom = global_reference hints_path_atom_gen + +type 'a hints_path_gen = + | PathAtom of 'a hints_path_atom_gen + | PathStar of 'a hints_path_gen + | PathSeq of 'a hints_path_gen * 'a hints_path_gen + | PathOr of 'a hints_path_gen * 'a hints_path_gen | PathEmpty | PathEpsilon +type pre_hints_path = Libnames.reference hints_path_gen +type hints_path = global_reference hints_path_gen + type hint_term = | IsGlobRef of global_reference | IsConstr of constr * Univ.universe_context_set @@ -104,11 +137,13 @@ type raw_hint = constr * types * Univ.universe_context_set type hint = (raw_hint * clausenv) hint_ast with_uid type 'a with_metadata = { - pri : int; (* A number lower is higher priority *) - poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) - pat : constr_pattern option; (* A pattern for the concl of the Goal *) - name : hints_path_atom; (* A potential name to refer to the hint *) - code : 'a; (* the tactic to apply when the concl matches pat *) + pri : int; (* A number lower is higher priority *) + poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) + pat : constr_pattern option; (* A pattern for the concl of the Goal *) + name : hints_path_atom; (* A potential name to refer to the hint *) + db : string option; (** The database from which the hint comes *) + secvars : Id.Pred.t; (* The set of section variables the hint depends on *) + code : 'a; (* the tactic to apply when the concl matches pat *) } type full_hint = hint with_metadata @@ -189,7 +224,7 @@ type search_entry = { sentry_nopat : stored_data list; sentry_pat : stored_data list; sentry_bnet : Bounded_net.t; - sentry_mode : bool array list; + sentry_mode : hint_mode array list; } let empty_se = { @@ -317,6 +352,12 @@ let rec is_empty = function | PathEmpty -> true | PathEpsilon -> false +let path_seq p p' = + match p, p' with + | PathEpsilon, p' -> p' + | p, PathEpsilon -> p + | p, p' -> PathSeq (p, p') + let rec path_derivate hp hint = let rec derivate_atoms hints hints' = match hints, hints' with @@ -324,26 +365,26 @@ let rec path_derivate hp hint = | [], [] -> PathEpsilon | [], hints -> PathEmpty | grs, [] -> PathAtom (PathHints grs) - | _, _ -> PathEmpty + | _, _ -> PathEmpty in - match hp with - | PathAtom PathAny -> PathEpsilon - | PathAtom (PathHints grs) -> - (match grs, hint with - | h :: hints, PathAny -> PathEmpty - | hints, PathHints hints' -> derivate_atoms hints hints' - | _, _ -> assert false) - | PathStar p -> if path_matches p [hint] then hp else PathEpsilon - | PathSeq (hp, hp') -> - let hpder = path_derivate hp hint in - if matches_epsilon hp then - PathOr (PathSeq (hpder, hp'), path_derivate hp' hint) - else if is_empty hpder then PathEmpty - else PathSeq (hpder, hp') - | PathOr (hp, hp') -> - PathOr (path_derivate hp hint, path_derivate hp' hint) - | PathEmpty -> PathEmpty - | PathEpsilon -> PathEmpty + match hp with + | PathAtom PathAny -> PathEpsilon + | PathAtom (PathHints grs) -> + (match grs, hint with + | h :: _, PathAny -> PathEmpty + | hints, PathHints hints' -> derivate_atoms hints hints' + | _, _ -> assert false) + | PathStar p -> if path_matches p [hint] then hp else PathEpsilon + | PathSeq (hp, hp') -> + let hpder = path_derivate hp hint in + if matches_epsilon hp then + PathOr (path_seq hpder hp', path_derivate hp' hint) + else if is_empty hpder then PathEmpty + else path_seq hpder hp' + | PathOr (hp, hp') -> + PathOr (path_derivate hp hint, path_derivate hp' hint) + | PathEmpty -> PathEmpty + | PathEpsilon -> PathEmpty let rec normalize_path h = match h with @@ -363,19 +404,40 @@ let rec normalize_path h = let path_derivate hp hint = normalize_path (path_derivate hp hint) -let pp_hints_path_atom a = +let pp_hints_path_atom prg a = match a with - | PathAny -> str"*" - | PathHints grs -> pr_sequence pr_global grs - -let rec pp_hints_path = function - | PathAtom pa -> pp_hints_path_atom pa - | PathStar p -> str "!(" ++ pp_hints_path p ++ str")" - | PathSeq (p, p') -> pp_hints_path p ++ str" ; " ++ pp_hints_path p' - | PathOr (p, p') -> - str "(" ++ pp_hints_path p ++ spc () ++ str"|" ++ spc () ++ pp_hints_path p' ++ str ")" + | PathAny -> str"_" + | PathHints grs -> pr_sequence prg grs + +let pp_hints_path_gen prg = + let rec aux = function + | PathAtom pa -> pp_hints_path_atom prg pa + | PathStar (PathAtom PathAny) -> str"_*" + | PathStar p -> str "(" ++ aux p ++ str")*" + | PathSeq (p, p') -> aux p ++ spc () ++ aux p' + | PathOr (p, p') -> + str "(" ++ aux p ++ spc () ++ str"|" ++ cut () ++ spc () ++ + aux p' ++ str ")" | PathEmpty -> str"emp" | PathEpsilon -> str"eps" + in aux + +let pp_hints_path = pp_hints_path_gen pr_global + +let glob_hints_path_atom p = + match p with + | PathHints g -> PathHints (List.map Nametab.global g) + | PathAny -> PathAny + +let glob_hints_path = + let rec aux = function + | PathAtom pa -> PathAtom (glob_hints_path_atom pa) + | PathStar p -> PathStar (aux p) + | PathSeq (p, p') -> PathSeq (aux p, aux p') + | PathOr (p, p') -> PathOr (aux p, aux p') + | PathEmpty -> PathEmpty + | PathEpsilon -> PathEpsilon + in aux let subst_path_atom subst p = match p with @@ -402,7 +464,38 @@ let rec subst_hints_path subst hp = if p' == p && q' == q then hp else PathOr (p', q') | _ -> hp -module Hint_db = struct +type hint_db_name = string + +module Hint_db : +sig +type t +val empty : ?name:hint_db_name -> transparent_state -> bool -> t +val find : global_reference -> t -> search_entry +val map_none : secvars:Id.Pred.t -> t -> full_hint list +val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint list +val map_existential : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list +val map_eauto : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list +val map_auto : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list +val add_one : env -> evar_map -> hint_entry -> t -> t +val add_list : env -> evar_map -> hint_entry list -> t -> t +val remove_one : global_reference -> t -> t +val remove_list : global_reference list -> t -> t +val iter : (global_reference option -> hint_mode array list -> full_hint list -> unit) -> t -> unit +val use_dn : t -> bool +val transparent_state : t -> transparent_state +val set_transparent_state : t -> transparent_state -> t +val add_cut : hints_path -> t -> t +val add_mode : global_reference -> hint_mode array -> t -> t +val cut : t -> hints_path +val unfolds : t -> Id.Set.t * Cset.t +val fold : (global_reference option -> hint_mode array list -> full_hint list -> 'a -> 'a) -> + t -> 'a -> 'a + +end = +struct type t = { hintdb_state : Names.transparent_state; @@ -413,69 +506,83 @@ module Hint_db = struct hintdb_map : search_entry Constr_map.t; (* A list of unindexed entries starting with an unfoldable constant or with no associated pattern. *) - hintdb_nopat : (global_reference option * stored_data) list + hintdb_nopat : (global_reference option * stored_data) list; + hintdb_name : string option; } let next_hint_id db = let h = db.hintdb_max_id in { db with hintdb_max_id = succ db.hintdb_max_id }, h - let empty st use_dn = { hintdb_state = st; + let empty ?name st use_dn = { hintdb_state = st; hintdb_cut = PathEmpty; hintdb_unfolds = (Id.Set.empty, Cset.empty); hintdb_max_id = 0; use_dn = use_dn; hintdb_map = Constr_map.empty; - hintdb_nopat = [] } + hintdb_nopat = []; + hintdb_name = name; } let find key db = try Constr_map.find key db.hintdb_map with Not_found -> empty_se - let realize_tac (id,tac) = tac - + let realize_tac secvars (id,tac) = + if Id.Pred.subset tac.secvars secvars then Some tac + else + (** Warn about no longer typable hint? *) + None + + let match_mode m arg = + match m with + | ModeInput -> not (occur_existential arg) + | ModeNoHeadEvar -> + Evarutil.(try ignore(head_evar arg); false + with NoHeadEvar -> true) + | ModeOutput -> true + let matches_mode args mode = - Array.length args == Array.length mode && - Array.for_all2 (fun arg m -> not (m && occur_existential arg)) args mode + Array.length mode == Array.length args && + Array.for_all2 match_mode mode args let matches_modes args modes = if List.is_empty modes then true else List.exists (matches_mode args) modes - let merge_entry db nopat pat = + let merge_entry secvars db nopat pat = let h = List.sort pri_order_int (List.map snd db.hintdb_nopat) in let h = List.merge pri_order_int h nopat in let h = List.merge pri_order_int h pat in - List.map realize_tac h + List.map_filter (realize_tac secvars) h - let map_none db = - merge_entry db [] [] + let map_none ~secvars db = + merge_entry secvars db [] [] - let map_all k db = + let map_all ~secvars k db = let se = find k db in - merge_entry db se.sentry_nopat se.sentry_pat + merge_entry secvars db se.sentry_nopat se.sentry_pat (** Precondition: concl has no existentials *) - let map_auto (k,args) concl db = + let map_auto ~secvars (k,args) concl db = let se = find k db in let st = if db.use_dn then (Some db.hintdb_state) else None in let pat = lookup_tacs concl st se in - merge_entry db [] pat + merge_entry secvars db [] pat - let map_existential (k,args) concl db = + let map_existential ~secvars (k,args) concl db = let se = find k db in if matches_modes args se.sentry_mode then - merge_entry db se.sentry_nopat se.sentry_pat - else merge_entry db [] [] + merge_entry secvars db se.sentry_nopat se.sentry_pat + else merge_entry secvars db [] [] (* [c] contains an existential *) - let map_eauto (k,args) concl db = + let map_eauto ~secvars (k,args) concl db = let se = find k db in if matches_modes args se.sentry_mode then let st = if db.use_dn then Some db.hintdb_state else None in let pat = lookup_tacs concl st se in - merge_entry db [] pat - else merge_entry db [] [] + merge_entry secvars db [] pat + else merge_entry secvars db [] [] let is_exact = function | Give_exact _ -> true @@ -486,7 +593,7 @@ module Hint_db = struct | _ -> false let addkv gr id v db = - let idv = id, v in + let idv = id, { v with db = db.hintdb_name } in let k = match gr with | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr && is_unfold v.code.obj then None else Some gr @@ -551,11 +658,11 @@ module Hint_db = struct let get_entry se = let h = List.merge pri_order_int se.sentry_nopat se.sentry_pat in - List.map realize_tac h + List.map snd h let iter f db = let iter_se k se = f (Some k) se.sentry_mode (get_entry se) in - f None [] (List.map (fun x -> realize_tac (snd x)) db.hintdb_nopat); + f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat); Constr_map.iter iter_se db.hintdb_map let fold f db accu = @@ -590,8 +697,6 @@ type hint_db = Hint_db.t type hint_db_table = hint_db Hintdbmap.t ref -type hint_db_name = string - (** Initially created hint databases, for typeclasses and rewrite *) let typeclasses_db = "typeclass_instances" @@ -612,11 +717,10 @@ let searchtable_add (name,db) = let current_db_names () = Hintdbmap.domain !searchtable let current_db () = Hintdbmap.bindings !searchtable -let current_pure_db () = - List.map snd (Hintdbmap.bindings (Hintdbmap.remove "v62" !searchtable)) +let current_pure_db () = List.map snd (current_db ()) let error_no_such_hint_database x = - errorlabstrm "Hints" (str "No such Hint database: " ++ str x ++ str ".") + user_err ~hdr:"Hints" (str "No such Hint database: " ++ str x ++ str ".") (**************************************************************************) (* Definition of the summary *) @@ -653,7 +757,20 @@ let try_head_pattern c = let with_uid c = { obj = c; uid = fresh_key () } -let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = +let secvars_of_idset s = + Id.Set.fold (fun id p -> + if is_section_variable id then + Id.Pred.add id p + else p) s Id.Pred.empty + +let secvars_of_constr env c = + secvars_of_idset (global_vars_set env c) + +let secvars_of_global env gr = + secvars_of_idset (vars_of_global_reference env gr) + +let make_exact_entry env sigma info poly ?(name=PathAny) (c, cty, ctx) = + let secvars = secvars_of_constr env c in let cty = strip_outer_cast cty in match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" @@ -663,14 +780,17 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = try head_pattern_bound pat with BoundPattern -> failwith "make_exact_entry" in - (Some hd, - { pri = (match pri with None -> 0 | Some p -> p); - poly = poly; - pat = Some pat; - name = name; - code = with_uid (Give_exact (c, cty, ctx)); }) + let pri = match info.hint_priority with None -> 0 | Some p -> p in + let pat = match info.hint_pattern with + | Some pat -> snd pat + | None -> pat + in + (Some hd, + { pri; poly; pat = Some pat; name; + db = None; secvars; + code = with_uid (Give_exact (c, cty, ctx)); }) -let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) = +let make_apply_entry env sigma (eapply,hnf,verbose) info poly ?(name=PathAny) (c, cty, ctx) = let cty = if hnf then hnf_constr env sigma cty else cty in match kind_of_term cty with | Prod _ -> @@ -682,23 +802,25 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry" in let nmiss = List.length (clenv_missing ce) in + let secvars = secvars_of_constr env c in + let pri = match info.hint_priority with None -> nb_hyp cty + nmiss | Some p -> p in + let pat = match info.hint_pattern with + | Some p -> snd p | None -> pat + in if Int.equal nmiss 0 then (Some hd, - { pri = (match pri with None -> nb_hyp cty | Some p -> p); - poly = poly; - pat = Some pat; - name = name; + { pri; poly; pat = Some pat; name; + db = None; + secvars; code = with_uid (Res_pf(c,cty,ctx)); }) else begin if not eapply then failwith "make_apply_entry"; if verbose then - msg_warning (str "the hint: eapply " ++ pr_lconstr c ++ + Feedback.msg_info (str "the hint: eapply " ++ pr_lconstr c ++ str " will only be used by eauto"); (Some hd, - { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p); - poly = poly; - pat = Some pat; - name = name; + { pri; poly; pat = Some pat; name; + db = None; secvars; code = with_uid (ERes_pf(c,cty,ctx)); }) end | _ -> failwith "make_apply_entry" @@ -707,21 +829,59 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, c is a constr cty is the type of constr *) -let fresh_global_or_constr env sigma poly cr = - match cr with - | IsGlobRef gr -> Universes.fresh_global_instance env gr - | IsConstr (c, ctx) -> (c, ctx) +let pr_hint_term env sigma ctx = function + | IsGlobRef gr -> pr_global gr + | IsConstr (c, ctx) -> + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + pr_constr_env env sigma c + +(** We need an object to record the side-effect of registering + global universes associated with a hint. *) +let cache_context_set (_,c) = + Global.push_context_set false c + +let input_context_set : Univ.ContextSet.t -> Libobject.obj = + let open Libobject in + declare_object + { (default_object "Global universe context") with + cache_function = cache_context_set; + load_function = (fun _ -> cache_context_set); + discharge_function = (fun (_,a) -> Some a); + classify_function = (fun a -> Keep a) } + +let warn_polymorphic_hint = + CWarnings.create ~name:"polymorphic-hint" ~category:"automation" + (fun hint -> strbrk"Using polymorphic hint " ++ hint ++ + str" monomorphically" ++ + strbrk" use Polymorphic Hint to use it polymorphically.") -let make_resolves env sigma flags pri poly ?name cr = +let fresh_global_or_constr env sigma poly cr = + let isgr, (c, ctx) = + match cr with + | IsGlobRef gr -> + true, Universes.fresh_global_instance env gr + | IsConstr (c, ctx) -> false, (c, ctx) + in + if poly then (c, ctx) + else if Univ.ContextSet.is_empty ctx then (c, ctx) + else begin + if isgr then + warn_polymorphic_hint (pr_hint_term env sigma ctx cr); + Lib.add_anonymous_leaf (input_context_set ctx); + (c, Univ.ContextSet.empty) + end + +let make_resolves env sigma flags info poly ?name cr = let c, ctx = fresh_global_or_constr env sigma poly cr in let cty = Retyping.get_type_of env sigma c in let try_apply f = try Some (f (c, cty, ctx)) with Failure _ -> None in let ents = List.map_filter try_apply - [make_exact_entry env sigma pri poly ?name; make_apply_entry env sigma flags pri poly ?name] + [make_exact_entry env sigma info poly ?name; + make_apply_entry env sigma flags info poly ?name] in if List.is_empty ents then - errorlabstrm "Hint" + user_err ~hdr:"Hint" (pr_lconstr c ++ spc() ++ (if pi1 flags then str"cannot be used as a hint." else str "can be used as a hint only for eauto.")); @@ -729,16 +889,18 @@ let make_resolves env sigma flags pri poly ?name cr = (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma decl = - let hname = get_id decl in + let hname = NamedDecl.get_id decl in + let c = mkVar hname in try - [make_apply_entry env sigma (true, true, false) None false + [make_apply_entry env sigma (true, true, false) empty_hint_info false ~name:(PathHints [VarRef hname]) - (mkVar hname, get_type decl, Univ.ContextSet.empty)] + (c, NamedDecl.get_type decl, Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") (* REM : in most cases hintname = id *) + let make_unfold eref = let g = global_of_evaluable_reference eref in (Some g, @@ -746,16 +908,19 @@ let make_unfold eref = poly = false; pat = None; name = PathHints [g]; + db = None; + secvars = secvars_of_global (Global.env ()) g; code = with_uid (Unfold_nth eref) }) let make_extern pri pat tacast = - let tacast = Genarg.in_gen (Genarg.glbwit Constrarg.wit_ltac) tacast in let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri = pri; poly = false; pat = pat; name = PathAny; + db = None; + secvars = Id.Pred.empty; (* Approximation *) code = with_uid (Extern tacast) }) let make_mode ref m = @@ -764,7 +929,7 @@ let make_mode ref m = let n = List.length ctx in let m' = Array.of_list m in if not (n == Array.length m') then - errorlabstrm "Hint" + user_err ~hdr:"Hint" (pr_global ref ++ str" has " ++ int n ++ str" arguments while the mode declares " ++ int (Array.length m')) else m' @@ -779,6 +944,8 @@ let make_trivial env sigma poly ?(name=PathAny) r = poly = poly; pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce)); name = name; + db = None; + secvars = secvars_of_constr env c; code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) @@ -792,7 +959,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = let get_db dbname = try searchtable_map dbname - with Not_found -> Hint_db.empty empty_transparent_state false + with Not_found -> Hint_db.empty ~name:dbname empty_transparent_state false let add_hint dbname hintlist = let check (_, h) = @@ -831,7 +998,7 @@ type hint_action = | AddHints of hint_entry list | RemoveHints of global_reference list | AddCut of hints_path - | AddMode of global_reference * bool array + | AddMode of global_reference * hint_mode array let add_cut dbname path = let db = get_db dbname in @@ -852,7 +1019,7 @@ type hint_obj = { let load_autohint _ (kn, h) = let name = h.hint_name in match h.hint_action with - | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b) + | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty ~name st b) | AddTransparency (grs, b) -> add_transparency name grs b | AddHints hints -> add_hint name hints | RemoveHints grs -> remove_hint name grs @@ -1008,16 +1175,17 @@ let add_transparency l b local dbnames = Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let add_extern pri pat tacast local dbname = - let pat = match pat with +let add_extern info tacast local dbname = + let pat = match info.hint_pattern with | None -> None | Some (_, pat) -> Some pat in - let hint = make_hint ~local dbname (AddHints [make_extern pri pat tacast]) in + let hint = make_hint ~local dbname + (AddHints [make_extern (Option.get info.hint_priority) pat tacast]) in Lib.add_anonymous_leaf (inAutoHint hint) -let add_externs pri pat tacast local dbnames = - List.iter (add_extern pri pat tacast local) dbnames +let add_externs info tacast local dbnames = + List.iter (add_extern info tacast local) dbnames let add_trivials env sigma l local dbnames = List.iter @@ -1027,19 +1195,18 @@ let add_trivials env sigma l local dbnames = Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let (forward_intern_tac, extern_intern_tac) = Hook.make () - type hnf = bool +type hint_info = (patvar list * constr_pattern) hint_info_gen + type hints_entry = - | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * hint_term) list + | HintsResolveEntry of (hint_info * polymorphic * hnf * hints_path_atom * hint_term) list | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool - | HintsModeEntry of global_reference * bool list - | HintsExternEntry of - int * (patvar list * constr_pattern) option * glob_tactic_expr + | HintsModeEntry of global_reference * hint_mode list + | HintsExternEntry of hint_info * Genarg.glob_generic_argument let default_prepare_hint_ident = Id.of_string "H" @@ -1047,10 +1214,12 @@ exception Found of constr * types let prepare_hint check (poly,local) env init (sigma,c) = let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in - (* We re-abstract over uninstantiated evars. + (* We re-abstract over uninstantiated evars and universes. It is actually a bit stupid to generalize over evars since the first thing make_resolves will do is to re-instantiate the products *) - let c = drop_extra_implicit_args (Evarutil.nf_evar sigma c) in + let sigma, subst = Evd.nf_univ_variables sigma in + let c = Vars.subst_univs_constr subst (Evarutil.nf_evar sigma c) in + let c = drop_extra_implicit_args c in let vars = ref (collect_vars c) in let subst = ref [] in let rec find_next_evar c = match kind_of_term c with @@ -1077,7 +1246,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in if poly then IsConstr (c', diff) else if local then IsConstr (c', diff) - else (Global.push_context_set false diff; + else (Lib.add_anonymous_leaf (input_context_set diff); IsConstr (c', Univ.ContextSet.empty)) let interp_hints poly = @@ -1101,11 +1270,12 @@ let interp_hints poly = (PathHints [gr], poly, IsGlobRef gr) | HintsConstr c -> (PathAny, poly, f poly c) in - let fres (pri, b, r) = + let fp = Constrintern.intern_constr_pattern (Global.env()) in + let fres (info, b, r) = let path, poly, gr = fi r in - (pri, poly, b, path, gr) + let info = { info with hint_pattern = Option.map fp info.hint_pattern } in + (info, poly, b, path, gr) in - let fp = Constrintern.intern_constr_pattern (Global.env()) in match h with | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) @@ -1121,14 +1291,16 @@ let interp_hints poly = List.init (nconstructors ind) (fun i -> let c = (ind,i+1) in let gr = ConstructRef c in - None, mib.Declarations.mind_polymorphic, true, + empty_hint_info, mib.Declarations.mind_polymorphic, true, PathHints [gr], IsGlobRef gr) in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> let pat = Option.map fp patcom in let l = match pat with None -> [] | Some (l, _) -> l in - let tacexp = Hook.get forward_intern_tac l tacexp in - HintsExternEntry (pri, pat, tacexp) + let ltacvars = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in + let env = Genintern.({ genv = env; ltacvars }) in + let _, tacexp = Genintern.generic_intern env tacexp in + HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp) let add_hints local dbnames0 h = if String.List.mem "nocore" dbnames0 then @@ -1144,26 +1316,32 @@ let add_hints local dbnames0 h = | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames | HintsTransparencyEntry (lhints, b) -> add_transparency lhints b local dbnames - | HintsExternEntry (pri, pat, tacexp) -> - add_externs pri pat tacexp local dbnames + | HintsExternEntry (info, tacexp) -> + add_externs info tacexp local dbnames let expand_constructor_hints env sigma lems = List.map_append (fun (evd,lem) -> match kind_of_term lem with | Ind (ind,u) -> List.init (nconstructors ind) - (fun i -> IsConstr (mkConstructU ((ind,i+1),u), - Univ.ContextSet.empty)) + (fun i -> + let ctx = Univ.ContextSet.diff (Evd.universe_context_set evd) + (Evd.universe_context_set sigma) in + not (Univ.ContextSet.is_empty ctx), + IsConstr (mkConstructU ((ind,i+1),u),ctx)) | _ -> - [prepare_hint false (false,true) env sigma (evd,lem)]) lems - + [match prepare_hint false (false,true) env sigma (evd,lem) with + | IsConstr (c, ctx) -> + not (Univ.ContextSet.is_empty ctx), IsConstr (c, ctx) + | IsGlobRef _ -> assert false (* Impossible return value *) ]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *) let add_hint_lemmas env sigma eapply lems hint_db = let lems = expand_constructor_hints env sigma lems in let hintlist' = - List.map_append (make_resolves env sigma (eapply,true,false) None false) lems in + List.map_append (fun (poly, lem) -> + make_resolves env sigma (eapply,true,false) empty_hint_info poly lem) lems in Hint_db.add_list env sigma hintlist' hint_db let make_local_hint_db env sigma ts eapply lems = @@ -1182,12 +1360,6 @@ let make_local_hint_db env sigma ts eapply lems = add_hint_lemmas env sigma eapply lems (Hint_db.add_list env sigma hintlist (Hint_db.empty ts false)) -let make_local_hint_db = - if Flags.profile then - let key = Profile.declare_profile "make_local_hint_db" in - Profile.profile4 key make_local_hint_db - else make_local_hint_db - let make_local_hint_db env sigma ?ts eapply lems = make_local_hint_db env sigma ts eapply lems @@ -1207,23 +1379,25 @@ let make_db_list dbnames = let pr_hint_elt (c, _, _) = pr_constr c let pr_hint h = match h.obj with - | Res_pf (c, _) -> (str"apply " ++ pr_hint_elt c) - | ERes_pf (c, _) -> (str"eapply " ++ pr_hint_elt c) + | Res_pf (c, _) -> (str"simple apply " ++ pr_hint_elt c) + | ERes_pf (c, _) -> (str"simple eapply " ++ pr_hint_elt c) | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt c) | Res_pf_THEN_trivial_fail (c, _) -> - (str"apply " ++ pr_hint_elt c ++ str" ; trivial") + (str"simple apply " ++ pr_hint_elt c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) | Extern tac -> let env = try let (_, env) = Pfedit.get_current_goal_context () in env - with e when Errors.noncritical e -> Global.env () + with e when CErrors.noncritical e -> Global.env () in - (str "(*external*) " ++ Pptactic.pr_glb_generic env tac) + (str "(*external*) " ++ Pputils.pr_glb_generic env tac) let pr_id_hint (id, v) = - (pr_hint v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ()) + let pr_pat p = str", pattern " ++ pr_lconstr_pattern p in + (pr_hint v.code ++ str"(level " ++ int v.pri ++ pr_opt_no_spc pr_pat v.pat + ++ str", id " ++ int id ++ str ")" ++ spc ()) let pr_hint_list hintlist = (str " " ++ hov 0 (prlist pr_id_hint hintlist) ++ fnl ()) @@ -1237,7 +1411,7 @@ let pr_hints_db (name,db,hintlist) = let pr_hint_list_for_head c = let dbs = current_db () in let validate (name, db) = - let hints = List.map (fun v -> 0, v) (Hint_db.map_all c db) in + let hints = List.map (fun v -> 0, v) (Hint_db.map_all Id.Pred.full c db) in (name, db, hints) in let valid_dbs = List.map validate dbs in @@ -1259,9 +1433,9 @@ let pr_hint_term cl = let fn = try let hdc = decompose_app_bound cl in if occur_existential cl then - Hint_db.map_existential hdc cl - else Hint_db.map_auto hdc cl - with Bound -> Hint_db.map_none + Hint_db.map_existential ~secvars:Id.Pred.full hdc cl + else Hint_db.map_auto ~secvars:Id.Pred.full hdc cl + with Bound -> Hint_db.map_none ~secvars:Id.Pred.full in let fn db = List.map (fun x -> 0, x) (fn db) in List.map (fun (name, db) -> (name, db, fn db)) dbs @@ -1279,13 +1453,18 @@ let pr_applicable_hint () = let pts = get_pftreestate () in let glss = Proof.V82.subgoals pts in match glss.Evd.it with - | [] -> Errors.error "No focused goal." + | [] -> CErrors.error "No focused goal." | g::_ -> pr_hint_term (Goal.V82.concl glss.Evd.sigma g) +let pp_hint_mode = function + | ModeInput -> str"+" + | ModeNoHeadEvar -> str"!" + | ModeOutput -> str"-" + (* displays the whole hint database db *) let pr_hint_db db = - let pr_mode = prvect_with_sep spc (fun x -> if x then str"+" else str"-") in + let pr_mode = prvect_with_sep spc pp_hint_mode in let pr_modes l = if List.is_empty l then mt () else str" (modes " ++ prlist_with_sep pr_comma pr_mode l ++ str")" @@ -1333,10 +1512,15 @@ let print_mp mp = let is_imported h = try KNmap.find h.uid !statustable with Not_found -> true +let warn_non_imported_hint = + CWarnings.create ~name:"non-imported-hint" ~category:"automation" + (fun (hint,mp) -> + strbrk "Hint used but not imported: " ++ hint ++ print_mp mp) + let warn h x = let hint = pr_hint h in let (mp, _, _) = KerName.repr h.uid in - let () = msg_warning (str "Hint used but not imported: " ++ hint ++ print_mp mp) in + warn_non_imported_hint (hint,mp); Proofview.tclUNIT x let run_hint tac k = match !warn_hint with @@ -1346,6 +1530,6 @@ let run_hint tac k = match !warn_hint with else Proofview.tclBIND (k tac.obj) (fun x -> warn tac x) | `STRICT -> if is_imported tac then k tac.obj - else Proofview.tclZERO (UserError ("", (str "Tactic failure."))) + else Proofview.tclZERO (UserError (None, (str "Tactic failure."))) let repr_hint h = h.obj diff --git a/tactics/hints.mli b/tactics/hints.mli index df9d792121..05d41adfe1 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -15,6 +15,7 @@ open Globnames open Decl_kinds open Evd open Misctypes +open Tactypes open Clenv open Pattern open Vernacexpr @@ -25,6 +26,12 @@ exception Bound val decompose_app_bound : constr -> global_reference * constr array +type debug = Debug | Info | Off + +val secvars_of_hyps : Context.Named.t -> Id.Pred.t + +val empty_hint_info : 'a hint_info_gen + (** Pre-created hint databases *) type 'a hint_ast = @@ -38,16 +45,22 @@ type 'a hint_ast = type hint type raw_hint = constr * types * Univ.universe_context_set -type hints_path_atom = - | PathHints of global_reference list +type 'a hints_path_atom_gen = + | PathHints of 'a list + (* For forward hints, their names is the list of projections *) | PathAny +type hints_path_atom = global_reference hints_path_atom_gen +type hint_db_name = string + type 'a with_metadata = private { pri : int; (** A number between 0 and 4, 4 = lower priority *) poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (** A pattern for the concl of the Goal *) name : hints_path_atom; (** A potential name to refer to the hint *) - code : 'a; (** the tactic to apply when the concl matches pat *) + db : hint_db_name option; + secvars : Id.Pred.t; (** The section variables this hint depends on, as a predicate *) + code : 'a; (** the tactic to apply when the concl matches pat *) } type full_hint = hint with_metadata @@ -58,47 +71,63 @@ type search_entry type hint_entry -type hints_path = - | PathAtom of hints_path_atom - | PathStar of hints_path - | PathSeq of hints_path * hints_path - | PathOr of hints_path * hints_path +type 'a hints_path_gen = + | PathAtom of 'a hints_path_atom_gen + | PathStar of 'a hints_path_gen + | PathSeq of 'a hints_path_gen * 'a hints_path_gen + | PathOr of 'a hints_path_gen * 'a hints_path_gen | PathEmpty | PathEpsilon +type pre_hints_path = Libnames.reference hints_path_gen +type hints_path = global_reference hints_path_gen + val normalize_path : hints_path -> hints_path val path_matches : hints_path -> hints_path_atom list -> bool val path_derivate : hints_path -> hints_path_atom -> hints_path -val pp_hints_path_atom : hints_path_atom -> Pp.std_ppcmds +val pp_hints_path_gen : ('a -> Pp.std_ppcmds) -> 'a hints_path_gen -> Pp.std_ppcmds +val pp_hints_path_atom : ('a -> Pp.std_ppcmds) -> 'a hints_path_atom_gen -> Pp.std_ppcmds val pp_hints_path : hints_path -> Pp.std_ppcmds +val pp_hint_mode : hint_mode -> Pp.std_ppcmds +val glob_hints_path_atom : + Libnames.reference hints_path_atom_gen -> Globnames.global_reference hints_path_atom_gen +val glob_hints_path : + Libnames.reference hints_path_gen -> Globnames.global_reference hints_path_gen module Hint_db : sig type t - val empty : transparent_state -> bool -> t + val empty : ?name:hint_db_name -> transparent_state -> bool -> t val find : global_reference -> t -> search_entry - val map_none : t -> full_hint list + + (** All hints which have no pattern. + * [secvars] represent the set of section variables that + * can be used in the hint. *) + val map_none : secvars:Id.Pred.t -> t -> full_hint list (** All hints associated to the reference *) - val map_all : global_reference -> t -> full_hint list + val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments, _not_ using the discrimination net. *) - val map_existential : (global_reference * constr array) -> constr -> t -> full_hint list + val map_existential : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments and using the discrimination net. *) - val map_eauto : (global_reference * constr array) -> constr -> t -> full_hint list + val map_eauto : secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments. *) - val map_auto : (global_reference * constr array) -> constr -> t -> full_hint list + val map_auto : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list val add_one : env -> evar_map -> hint_entry -> t -> t val add_list : env -> evar_map -> hint_entry list -> t -> t val remove_one : global_reference -> t -> t val remove_list : global_reference list -> t -> t - val iter : (global_reference option -> bool array list -> full_hint list -> unit) -> t -> unit + val iter : (global_reference option -> + hint_mode array list -> full_hint list -> unit) -> t -> unit val use_dn : t -> bool val transparent_state : t -> transparent_state @@ -110,26 +139,25 @@ module Hint_db : val unfolds : t -> Id.Set.t * Cset.t end -type hint_db_name = string - type hint_db = Hint_db.t type hnf = bool +type hint_info = (patvar list * constr_pattern) hint_info_gen + type hint_term = | IsGlobRef of global_reference | IsConstr of constr * Univ.universe_context_set type hints_entry = - | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * - hint_term) list + | HintsResolveEntry of + (hint_info * polymorphic * hnf * hints_path_atom * hint_term) list | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool - | HintsModeEntry of global_reference * bool list - | HintsExternEntry of - int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr + | HintsModeEntry of global_reference * hint_mode list + | HintsExternEntry of hint_info * Genarg.glob_generic_argument val searchtable_map : hint_db_name -> hint_db @@ -156,22 +184,34 @@ val prepare_hint : bool (* Check no remaining evars *) -> (bool * bool) (* polymorphic or monomorphic, local or global *) -> env -> evar_map -> open_constr -> hint_term -(** [make_exact_entry pri (c, ctyp)]. +(** [make_exact_entry info (c, ctyp, ctx)]. [c] is the term given as an exact proof to solve the goal; - [ctyp] is the type of [c]. *) - -val make_exact_entry : env -> evar_map -> int option -> polymorphic -> ?name:hints_path_atom -> + [ctyp] is the type of [c]. + [ctx] is its (refreshable) universe context. + In info: + [hint_priority] is the hint's desired priority, it is 0 if unspecified + [hint_pattern] is the hint's desired pattern, it is inferred if not specified +*) + +val make_exact_entry : env -> evar_map -> hint_info -> polymorphic -> ?name:hints_path_atom -> (constr * types * Univ.universe_context_set) -> hint_entry -(** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)]. +(** [make_apply_entry (eapply,hnf,verbose) info (c,cty,ctx))]. [eapply] is true if this hint will be used only with EApply; [hnf] should be true if we should expand the head of cty before searching for products; [c] is the term given as an exact proof to solve the goal; - [cty] is the type of [c]. *) + [cty] is the type of [c]. + [ctx] is its (refreshable) universe context. + In info: + [hint_priority] is the hint's desired priority, it is computed as the number of products in [cty] + if unspecified + [hint_pattern] is the hint's desired pattern, it is inferred from the conclusion of [cty] + if not specified +*) val make_apply_entry : - env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> + env -> evar_map -> bool * bool * bool -> hint_info -> polymorphic -> ?name:hints_path_atom -> (constr * types * Univ.universe_context_set) -> hint_entry (** A constr which is Hint'ed will be: @@ -182,7 +222,7 @@ val make_apply_entry : has missing arguments. *) val make_resolves : - env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> + env -> evar_map -> bool * bool * bool -> hint_info -> polymorphic -> ?name:hints_path_atom -> hint_term -> hint_entry list (** [make_resolve_hyp hname htyp]. @@ -196,7 +236,7 @@ val make_resolve_hyp : (** [make_extern pri pattern tactic_expr] *) val make_extern : - int -> constr_pattern option -> Tacexpr.glob_tactic_expr + int -> constr_pattern option -> Genarg.glob_generic_argument -> hint_entry val run_hint : hint -> @@ -206,14 +246,11 @@ val run_hint : hint -> written code. *) val repr_hint : hint -> (raw_hint * clausenv) hint_ast -val extern_intern_tac : - (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr) Hook.t - (** Create a Hint database from the pairs (name, constr). Useful to take the current goal hypotheses as hints; Boolean tells if lemmas with evars are allowed *) -val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> Tacexpr.delayed_open_constr list -> hint_db +val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> delayed_open_constr list -> hint_db val make_db_list : hint_db_name list -> hint_db list diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml index bcec90f803..27af7200bd 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml @@ -6,10 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma grammar/q_constr.cmo" i*) - open Pp -open Errors +open CErrors open Util open Names open Term @@ -21,6 +19,8 @@ open Declarations open Tacmach.New open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (* I implemented the following functions which test whether a term t is an inductive but non-recursive type, a general conjuction, a general disjunction, or a type with no constructors. @@ -102,7 +102,7 @@ let match_with_one_constructor style onlybinary allow_rec t = (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in if List.for_all - (fun decl -> let c = get_type decl in + (fun decl -> let c = RelDecl.get_type decl in is_local_assum decl && isRel c && Int.equal (destRel c) mib.mind_nparams) ctx @@ -111,7 +111,7 @@ let match_with_one_constructor style onlybinary allow_rec t = else None else let ctyp = prod_applist mip.mind_nf_lc.(0) args in - let cargs = List.map get_type (prod_assum ctyp) in + let cargs = List.map RelDecl.get_type (prod_assum ctyp) in if not (is_lax_conjunction style) || has_nodep_prod ctyp then (* Record or non strict conjunction *) Some (hdapp,List.rev cargs) @@ -243,9 +243,36 @@ type equation_kind = exception NoEquationFound -let coq_refl_leibniz1_pattern = PATTERN [ forall x:_, _ x x ] -let coq_refl_leibniz2_pattern = PATTERN [ forall A:_, forall x:A, _ A x x ] -let coq_refl_jm_pattern = PATTERN [ forall A:_, forall x:A, _ A x A x ] +open Glob_term +open Decl_kinds +open Evar_kinds + +let mkPattern c = snd (Patternops.pattern_of_glob_constr c) +let mkGApp f args = GApp (Loc.ghost, f, args) +let mkGHole = + GHole (Loc.ghost, QuestionMark (Define false), Misctypes.IntroAnonymous, None) +let mkGProd id c1 c2 = + GProd (Loc.ghost, Name (Id.of_string id), Explicit, c1, c2) +let mkGArrow c1 c2 = + GProd (Loc.ghost, Anonymous, Explicit, c1, c2) +let mkGVar id = GVar (Loc.ghost, Id.of_string id) +let mkGPatVar id = GPatVar(Loc.ghost, (false, Id.of_string id)) +let mkGRef r = GRef (Loc.ghost, Lazy.force r, None) +let mkGAppRef r args = mkGApp (mkGRef r) args + +(** forall x : _, _ x x *) +let coq_refl_leibniz1_pattern = + mkPattern (mkGProd "x" mkGHole (mkGApp mkGHole [mkGVar "x"; mkGVar "x";])) + +(** forall A:_, forall x:A, _ A x x *) +let coq_refl_leibniz2_pattern = + mkPattern (mkGProd "A" mkGHole (mkGProd "x" (mkGVar "A") + (mkGApp mkGHole [mkGVar "A"; mkGVar "x"; mkGVar "x";]))) + +(** forall A:_, forall x:A, _ A x A x *) +let coq_refl_jm_pattern = + mkPattern (mkGProd "A" mkGHole (mkGProd "x" (mkGVar "A") + (mkGApp mkGHole [mkGVar "A"; mkGVar "x"; mkGVar "A"; mkGVar "x";]))) open Globnames @@ -301,7 +328,8 @@ let is_equality_type t = op2bool (match_with_equality_type t) (* Arrows/Implication/Negation *) -let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ] +(** X1 -> X2 **) +let coq_arrow_pattern = mkPattern (mkGArrow (mkGPatVar "X1") (mkGPatVar "X2")) let match_arrow_pattern t = let result = matches coq_arrow_pattern t in @@ -380,33 +408,27 @@ let rec first_match matcher = function (*** Equality *) -(* Patterns "(eq ?1 ?2 ?3)" and "(identity ?1 ?2 ?3)" *) -let coq_eq_pattern_gen eq = lazy PATTERN [ %eq ?X1 ?X2 ?X3 ] -let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref -let coq_identity_pattern = coq_eq_pattern_gen coq_identity_ref -let coq_jmeq_pattern = lazy PATTERN [ %coq_jmeq_ref ?X1 ?X2 ?X3 ?X4 ] - -let match_eq eqn eq_pat = - let pat = - try Lazy.force eq_pat - with e when Errors.noncritical e -> raise PatternMatchingFailure +let match_eq eqn (ref, hetero) = + let ref = + try Lazy.force ref + with e when CErrors.noncritical e -> raise PatternMatchingFailure in - match Id.Map.bindings (matches pat eqn) with - | [(m1,t);(m2,x);(m3,y)] -> - assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); - PolymorphicLeibnizEq (t,x,y) - | [(m1,t);(m2,x);(m3,t');(m4,x')] -> - assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4); - HeterogenousEq (t,x,t',x') - | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 or 4 terms") + match kind_of_term eqn with + | App (c, [|t; x; y|]) -> + if not hetero && is_global ref c then PolymorphicLeibnizEq (t, x, y) + else raise PatternMatchingFailure + | App (c, [|t; x; t'; x'|]) -> + if hetero && is_global ref c then HeterogenousEq (t, x, t', x') + else raise PatternMatchingFailure + | _ -> raise PatternMatchingFailure let no_check () = true let check_jmeq_loaded () = Library.library_is_loaded Coqlib.jmeq_module let equalities = - [coq_eq_pattern, no_check, build_coq_eq_data; - coq_jmeq_pattern, check_jmeq_loaded, build_coq_jmeq_data; - coq_identity_pattern, no_check, build_coq_identity_data] + [(coq_eq_ref, false), no_check, build_coq_eq_data; + (coq_jmeq_ref, true), check_jmeq_loaded, build_coq_jmeq_data; + (coq_identity_ref, false), no_check, build_coq_identity_data] let find_eq_data eqn = (* fails with PatternMatchingFailure *) let d,k = first_match (match_eq eqn) equalities in @@ -430,18 +452,21 @@ let find_this_eq_data_decompose gl eqn = try (*first_match (match_eq eqn) inversible_equalities*) find_eq_data eqn with PatternMatchingFailure -> - errorlabstrm "" (str "No primitive equality found.") in + user_err (str "No primitive equality found.") in let eq_args = try extract_eq_args gl eq_args with PatternMatchingFailure -> error "Don't know what to do with JMeq on arguments not of same type." in (lbeq,u,eq_args) -let match_eq_nf gls eqn eq_pat = - match Id.Map.bindings (pf_matches gls (Lazy.force eq_pat) eqn) with +let match_eq_nf gls eqn (ref, hetero) = + let n = if hetero then 4 else 3 in + let args = List.init n (fun i -> mkGPatVar ("X" ^ string_of_int (i + 1))) in + let pat = mkPattern (mkGAppRef ref args) in + match Id.Map.bindings (pf_matches gls pat eqn) with | [(m1,t);(m2,x);(m3,y)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); - (t,pf_whd_betadeltaiota gls x,pf_whd_betadeltaiota gls y) + (t,pf_whd_all gls x,pf_whd_all gls y) | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms") let dest_nf_eq gls eqn = @@ -464,7 +489,8 @@ let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) match_sigma ex (* Pattern "(sig ?1 ?2)" *) -let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ] +let coq_sig_pattern = + lazy (mkPattern (mkGAppRef coq_sig_ref [mkGPatVar "X1"; mkGPatVar "X2"])) let match_sigma t = match Id.Map.bindings (matches (Lazy.force coq_sig_pattern) t) with @@ -480,17 +506,25 @@ let is_matching_sigma t = is_matching (Lazy.force coq_sig_pattern) t (* Pattern "{<?1>x=y}+{~(<?1>x=y)}" *) (* i.e. "(sumbool (eq ?1 x y) ~(eq ?1 x y))" *) -let coq_eqdec_inf_pattern = - lazy PATTERN [ { ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 } ] +let coq_eqdec ~sum ~rev = + lazy ( + let eqn = mkGAppRef coq_eq_ref (List.map mkGPatVar ["X1"; "X2"; "X3"]) in + let args = [eqn; mkGAppRef coq_not_ref [eqn]] in + let args = if rev then List.rev args else args in + mkPattern (mkGAppRef sum args) + ) + +(** { ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 } *) +let coq_eqdec_inf_pattern = coq_eqdec ~sum:coq_sumbool_ref ~rev:false -let coq_eqdec_inf_rev_pattern = - lazy PATTERN [ { ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 } ] +(** { ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 } *) +let coq_eqdec_inf_rev_pattern = coq_eqdec ~sum:coq_sumbool_ref ~rev:true -let coq_eqdec_pattern = - lazy PATTERN [ %coq_or_ref (?X2 = ?X3 :> ?X1) (~ ?X2 = ?X3 :> ?X1) ] +(** %coq_or_ref (?X2 = ?X3 :> ?X1) (~ ?X2 = ?X3 :> ?X1) *) +let coq_eqdec_pattern = coq_eqdec ~sum:coq_or_ref ~rev:false -let coq_eqdec_rev_pattern = - lazy PATTERN [ %coq_or_ref (~ ?X2 = ?X3 :> ?X1) (?X2 = ?X3 :> ?X1) ] +(** %coq_or_ref (~ ?X2 = ?X3 :> ?X1) (?X2 = ?X3 :> ?X1) *) +let coq_eqdec_rev_pattern = coq_eqdec ~sum:coq_or_ref ~rev:true let op_or = coq_or_ref let op_sum = coq_sumbool_ref @@ -510,8 +544,8 @@ let match_eqdec t = | _ -> anomaly (Pp.str "Unexpected pattern") (* Patterns "~ ?" and "? -> False" *) -let coq_not_pattern = lazy PATTERN [ ~ _ ] -let coq_imp_False_pattern = lazy PATTERN [ _ -> %coq_False_ref ] +let coq_not_pattern = lazy (mkPattern (mkGAppRef coq_not_ref [mkGHole])) +let coq_imp_False_pattern = lazy (mkPattern (mkGArrow mkGHole (mkGRef coq_False_ref))) let is_matching_not t = is_matching (Lazy.force coq_not_pattern) t let is_matching_imp_False t = is_matching (Lazy.force coq_imp_False_pattern) t diff --git a/tactics/inv.ml b/tactics/inv.ml index 89c6beb321..e7d8249e43 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -7,7 +7,7 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util open Names open Nameops @@ -25,12 +25,10 @@ open Tactics open Elim open Equality open Misctypes -open Tacexpr open Sigma.Notations open Proofview.Notations -open Context.Named.Declaration -let clear hyps = Proofview.V82.tactic (clear hyps) +module NamedDecl = Context.Named.Declaration let var_occurs_in_pf gl id = let env = Proofview.Goal.env gl in @@ -78,7 +76,7 @@ let make_inv_predicate env evd indf realargs id status concl = (hyps_arity,concl) | Dep dflt_concl -> if not (occur_var env id concl) then - errorlabstrm "make_inv_predicate" + user_err ~hdr:"make_inv_predicate" (str "Current goal does not depend on " ++ pr_id id ++ str"."); (* We abstract the conclusion of goal with respect to realargs and c to * be concl in order to rewrite and have @@ -184,7 +182,7 @@ let dependent_hyps env id idlist gl = | [] -> [] | d::l -> (* Update the type of id1: it may have been subject to rewriting *) - let d = pf_get_hyp (get_id d) gl in + let d = pf_get_hyp (NamedDecl.get_id d) gl in if occur_var_in_decl env id d then d :: dep_rec l else dep_rec l @@ -194,7 +192,7 @@ let dependent_hyps env id idlist gl = let split_dep_and_nodep hyps gl = List.fold_right (fun d (l1,l2) -> - if var_occurs_in_pf gl (get_id d) then (d::l1,l2) else (l1,d::l2)) + if var_occurs_in_pf gl (NamedDecl.get_id d) then (d::l1,l2) else (l1,d::l2)) hyps ([],[]) (* Computation of dids is late; must have been done in rewrite_equations*) @@ -385,7 +383,7 @@ let rewrite_equations as_mode othin neqns names ba = Proofview.Goal.nf_enter { enter = begin fun gl -> let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in let first_eq = ref MoveLast in - let avoid = if as_mode then List.map get_id nodepids else [] in + let avoid = if as_mode then List.map NamedDecl.get_id nodepids else [] in match othin with | Some thin -> tclTHENLIST @@ -401,10 +399,10 @@ let rewrite_equations as_mode othin neqns names ba = tclTRY (projectAndApply as_mode thin avoid id first_eq names depids))))) names; tclMAP (fun d -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *) - let idopt = if as_mode then Some (get_id d) else None in + let idopt = if as_mode then Some (NamedDecl.get_id d) else None in intro_move idopt (if thin then MoveLast else !first_eq)) nodepids; - (tclMAP (fun d -> tclTRY (clear [get_id d])) depids)] + (tclMAP (fun d -> tclTRY (clear [NamedDecl.get_id d])) depids)] | None -> (* simple inversion *) if as_mode then @@ -442,7 +440,7 @@ let raw_inversion inv_kind id status names = try pf_apply Tacred.reduce_to_atomic_ind gl (pf_unsafe_type_of gl c) with UserError _ -> let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in - Errors.errorlabstrm "" msg + CErrors.user_err msg in let IndType (indf,realargs) = find_rectype env sigma t in let evdref = ref sigma in @@ -467,7 +465,7 @@ let raw_inversion inv_kind id status names = (tclTHENS (assert_before Anonymous cut_concl) [case_tac names - (introCaseAssumsThen + (introCaseAssumsThen false (* ApplyOn not supported by inversion *) (rewrite_equations_tac as_mode inv_kind id neqns)) (Some elim_predicate) ind (c, t); onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]) @@ -498,8 +496,6 @@ let inversion inv_kind status names id = let inv_gen thin status names = try_intros_until (inversion thin status names) -open Tacexpr - let inv k = inv_gen k NoDep let inv_tac id = inv FullInversion None (NamedHyp id) diff --git a/tactics/inv.mli b/tactics/inv.mli index af1cb996a5..df629e7c9f 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -9,7 +9,7 @@ open Names open Term open Misctypes -open Tacexpr +open Tactypes type inversion_status = Dep of constr option | NoDep diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 70782ec648..10fc5076c2 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -7,7 +7,7 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util open Names open Term @@ -29,6 +29,8 @@ open Decl_kinds open Proofview.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + let no_inductive_inconstr env sigma constr = (str "Cannot recognize an inductive predicate in " ++ pr_lconstr_env env sigma constr ++ @@ -114,7 +116,7 @@ let max_prefix_sign lid sign = | id::l -> snd (max_rec (id, sign_prefix id sign) l) *) let rec add_prods_sign env sigma t = - match kind_of_term (whd_betadeltaiota env sigma t) with + match kind_of_term (whd_all env sigma t) with | Prod (na,c1,b) -> let id = id_of_name_using_hdchar env t na in let b'= subst1 (mkVar id) b in @@ -156,7 +158,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let revargs,ownsign = fold_named_context (fun env d (revargs,hyps) -> - let id = get_id d in + let id = NamedDecl.get_id d in if Id.List.mem id ivars then ((mkVar id)::revargs, Context.Named.add d hyps) else @@ -167,7 +169,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in (pty,goal) in - let npty = nf_betadeltaiota env sigma pty in + let npty = nf_all env sigma pty in let extenv = push_named (LocalAssum (p,npty)) env in extenv, goal @@ -183,7 +185,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = let ind = try find_rectype env sigma i with Not_found -> - errorlabstrm "inversion_scheme" (no_inductive_inconstr env sigma i) + user_err ~hdr:"inversion_scheme" (no_inductive_inconstr env sigma i) in let (invEnv,invGoal) = compute_first_inversion_scheme env sigma ind sort dep_option @@ -193,7 +195,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = (global_vars env invGoal) (ids_of_named_context (named_context invEnv))); (* - errorlabstrm "lemma_inversion" + user_err ~hdr:"lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) let pf = Proof.start (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in @@ -202,11 +204,11 @@ let inversion_scheme env sigma t sort dep_option inv_op = tclTHEN intro (onLastHypId inv_op)) pf) in let pfterm = List.hd (Proof.partial_proof pf) in - let global_named_context = Global.named_context () in + let global_named_context = Global.named_context_val () in let ownSign = ref begin fold_named_context (fun env d sign -> - if mem_named_context (get_id d) global_named_context then sign + if mem_named_context_val (NamedDecl.get_id d) global_named_context then sign else Context.Named.add d sign) invEnv ~init:Context.Named.empty end in @@ -247,8 +249,8 @@ let add_inversion_lemma_exn na com comsort bool tac = try add_inversion_lemma na env sigma c sort bool tac with - | UserError ("Case analysis",s) -> (* Reference to Indrec *) - errorlabstrm "Inv needs Nodep Prop Set" s + | UserError (Some "Case analysis",s) -> (* Reference to Indrec *) + user_err ~hdr:"Inv needs Nodep Prop Set" s (* ================================= *) (* Applying a given inversion lemma *) @@ -261,10 +263,10 @@ let lemInv id c gls = Proofview.V82.of_tactic (Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false) gls with | NoSuchBinding -> - errorlabstrm "" + user_err (hov 0 (pr_constr c ++ spc () ++ str "does not refer to an inversion lemma.")) | UserError (a,b) -> - errorlabstrm "LemInv" + user_err ~hdr:"LemInv" (str "Cannot refine current goal with the lemma " ++ pr_lconstr_env (Refiner.pf_env gls) (Refiner.project gls) c) diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml deleted file mode 100644 index 358f6d6468..0000000000 --- a/tactics/taccoerce.ml +++ /dev/null @@ -1,300 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Util -open Names -open Term -open Pattern -open Misctypes -open Genarg -open Stdarg -open Constrarg - -exception CannotCoerceTo of string - -let (wit_constr_context : (Empty.t, Empty.t, constr) Genarg.genarg_type) = - Genarg.create_arg "constr_context" - -(* includes idents known to be bound and references *) -let (wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) Genarg.genarg_type) = - Genarg.create_arg "constr_under_binders" - -let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> - let Val.Dyn (t, _) = v in - match Val.eq t (val_tag wit) with - | None -> false - | Some Refl -> true - -let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> - let Val.Dyn (t', x) = v in - match Val.eq t t' with - | None -> None - | Some Refl -> Some x - -let in_gen wit v = Val.Dyn (val_tag wit, v) -let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x - -module Value = -struct - -type t = Val.t - -let normalize v = v - -let of_constr c = in_gen (topwit wit_constr) c - -let to_constr v = - let v = normalize v in - if has_type v (topwit wit_constr) then - let c = out_gen (topwit wit_constr) v in - Some c - else if has_type v (topwit wit_constr_under_binders) then - let vars, c = out_gen (topwit wit_constr_under_binders) v in - match vars with [] -> Some c | _ -> None - else None - -let of_uconstr c = in_gen (topwit wit_uconstr) c - -let to_uconstr v = - let v = normalize v in - if has_type v (topwit wit_uconstr) then - Some (out_gen (topwit wit_uconstr) v) - else None - -let of_int i = in_gen (topwit wit_int) i - -let to_int v = - let v = normalize v in - if has_type v (topwit wit_int) then - Some (out_gen (topwit wit_int) v) - else None - -let to_list v = - let v = normalize v in - let Val.Dyn (tag, v) = v in - match tag with - | Val.List t -> Some (List.map (fun x -> Val.Dyn (t, x)) v) - | _ -> None - -let of_list t v = Val.Dyn (Val.List t, v) - -let to_option v = - let v = normalize v in - let Val.Dyn (tag, v) = v in - match tag with - | Val.Opt t -> Some (Option.map (fun x -> Val.Dyn (t, x)) v) - | _ -> None - -let of_option t v = Val.Dyn (Val.Opt t, v) - -end - -let is_variable env id = - Id.List.mem id (Termops.ids_of_named_context (Environ.named_context env)) - -(* Transforms an id into a constr if possible, or fails with Not_found *) -let constr_of_id env id = - Term.mkVar (let _ = Environ.lookup_named id env in id) - -(* Gives the constr corresponding to a Constr_context tactic_arg *) -let coerce_to_constr_context v = - let v = Value.normalize v in - if has_type v (topwit wit_constr_context) then - out_gen (topwit wit_constr_context) v - else raise (CannotCoerceTo "a term context") - -(* Interprets an identifier which must be fresh *) -let coerce_to_ident fresh env v = - let v = Value.normalize v in - let fail () = raise (CannotCoerceTo "a fresh identifier") in - if has_type v (topwit wit_intro_pattern) then - match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) -> id - | _ -> fail () - else if has_type v (topwit wit_var) then - out_gen (topwit wit_var) v - else match Value.to_constr v with - | None -> fail () - | Some c -> - (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *) - if isVar c && not (fresh && is_variable env (destVar c)) then - destVar c - else fail () - -let coerce_to_intro_pattern env v = - let v = Value.normalize v in - if has_type v (topwit wit_intro_pattern) then - snd (out_gen (topwit wit_intro_pattern) v) - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - IntroNaming (IntroIdentifier id) - else match Value.to_constr v with - | Some c when isVar c -> - (* This happens e.g. in definitions like "Tac H = clear H; intro H" *) - (* but also in "destruct H as (H,H')" *) - IntroNaming (IntroIdentifier (destVar c)) - | _ -> raise (CannotCoerceTo "an introduction pattern") - -let coerce_to_intro_pattern_naming env v = - match coerce_to_intro_pattern env v with - | IntroNaming pat -> pat - | _ -> raise (CannotCoerceTo "a naming introduction pattern") - -let coerce_to_hint_base v = - let v = Value.normalize v in - if has_type v (topwit wit_intro_pattern) then - match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) -> Id.to_string id - | _ -> raise (CannotCoerceTo "a hint base name") - else raise (CannotCoerceTo "a hint base name") - -let coerce_to_int v = - let v = Value.normalize v in - if has_type v (topwit wit_int) then - out_gen (topwit wit_int) v - else raise (CannotCoerceTo "an integer") - -let coerce_to_constr env v = - let v = Value.normalize v in - let fail () = raise (CannotCoerceTo "a term") in - if has_type v (topwit wit_intro_pattern) then - match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) -> - (try ([], constr_of_id env id) with Not_found -> fail ()) - | _ -> fail () - else if has_type v (topwit wit_constr) then - let c = out_gen (topwit wit_constr) v in - ([], c) - else if has_type v (topwit wit_constr_under_binders) then - out_gen (topwit wit_constr_under_binders) v - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - (try [], constr_of_id env id with Not_found -> fail ()) - else fail () - -let coerce_to_uconstr env v = - let v = Value.normalize v in - if has_type v (topwit wit_uconstr) then - out_gen (topwit wit_uconstr) v - else - raise (CannotCoerceTo "an untyped term") - -let coerce_to_closed_constr env v = - let ids,c = coerce_to_constr env v in - let () = if not (List.is_empty ids) then raise (CannotCoerceTo "a term") in - c - -let coerce_to_evaluable_ref env v = - let fail () = raise (CannotCoerceTo "an evaluable reference") in - let v = Value.normalize v in - if has_type v (topwit wit_intro_pattern) then - match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) when is_variable env id -> EvalVarRef id - | _ -> fail () - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - if Id.List.mem id (Termops.ids_of_context env) then EvalVarRef id - else fail () - else if has_type v (topwit wit_ref) then - let open Globnames in - let r = out_gen (topwit wit_ref) v in - match r with - | VarRef var -> EvalVarRef var - | ConstRef c -> EvalConstRef c - | IndRef _ | ConstructRef _ -> fail () - else - let ev = match Value.to_constr v with - | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c)) - | Some c when isVar c -> EvalVarRef (destVar c) - | _ -> fail () - in - if Tacred.is_evaluable env ev then ev else fail () - -let coerce_to_constr_list env v = - let v = Value.to_list v in - match v with - | Some l -> - let map v = coerce_to_closed_constr env v in - List.map map l - | None -> raise (CannotCoerceTo "a term list") - -let coerce_to_intro_pattern_list loc env v = - match Value.to_list v with - | None -> raise (CannotCoerceTo "an intro pattern list") - | Some l -> - let map v = (loc, coerce_to_intro_pattern env v) in - List.map map l - -let coerce_to_hyp env v = - let fail () = raise (CannotCoerceTo "a variable") in - let v = Value.normalize v in - if has_type v (topwit wit_intro_pattern) then - match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) when is_variable env id -> id - | _ -> fail () - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - if is_variable env id then id else fail () - else match Value.to_constr v with - | Some c when isVar c -> destVar c - | _ -> fail () - -let coerce_to_hyp_list env v = - let v = Value.to_list v in - match v with - | Some l -> - let map n = coerce_to_hyp env n in - List.map map l - | None -> raise (CannotCoerceTo "a variable list") - -(* Interprets a qualified name *) -let coerce_to_reference env v = - let v = Value.normalize v in - match Value.to_constr v with - | Some c -> - begin - try Globnames.global_of_constr c - with Not_found -> raise (CannotCoerceTo "a reference") - end - | None -> raise (CannotCoerceTo "a reference") - -(* Quantified named or numbered hypothesis or hypothesis in context *) -(* (as in Inversion) *) -let coerce_to_quantified_hypothesis v = - let v = Value.normalize v in - if has_type v (topwit wit_intro_pattern) then - let v = out_gen (topwit wit_intro_pattern) v in - match v with - | _, IntroNaming (IntroIdentifier id) -> NamedHyp id - | _ -> raise (CannotCoerceTo "a quantified hypothesis") - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - NamedHyp id - else if has_type v (topwit wit_int) then - AnonHyp (out_gen (topwit wit_int) v) - else match Value.to_constr v with - | Some c when isVar c -> NamedHyp (destVar c) - | _ -> raise (CannotCoerceTo "a quantified hypothesis") - -(* Quantified named or numbered hypothesis or hypothesis in context *) -(* (as in Inversion) *) -let coerce_to_decl_or_quant_hyp env v = - let v = Value.normalize v in - if has_type v (topwit wit_int) then - AnonHyp (out_gen (topwit wit_int) v) - else - try coerce_to_quantified_hypothesis v - with CannotCoerceTo _ -> - raise (CannotCoerceTo "a declared or quantified hypothesis") - -let coerce_to_int_or_var_list v = - match Value.to_list v with - | None -> raise (CannotCoerceTo "an int list") - | Some l -> - let map n = ArgArg (coerce_to_int n) in - List.map map l diff --git a/tactics/taccoerce.mli b/tactics/taccoerce.mli deleted file mode 100644 index 87137fd2e7..0000000000 --- a/tactics/taccoerce.mli +++ /dev/null @@ -1,94 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Util -open Names -open Term -open Misctypes -open Pattern -open Genarg - -(** Coercions from highest level generic arguments to actual data used by Ltac - interpretation. Those functions examinate dynamic types and try to return - something sensible according to the object content. *) - -exception CannotCoerceTo of string -(** Exception raised whenever a coercion failed. *) - -(** {5 High-level access to values} - - The [of_*] functions cast a given argument into a value. The [to_*] do the - converse, and return [None] if there is a type mismatch. - -*) - -module Value : -sig - type t = Val.t - - val normalize : t -> t - (** Eliminated the leading dynamic type casts. *) - - val of_constr : constr -> t - val to_constr : t -> constr option - val of_uconstr : Glob_term.closed_glob_constr -> t - val to_uconstr : t -> Glob_term.closed_glob_constr option - val of_int : int -> t - val to_int : t -> int option - val to_list : t -> t list option - val of_list : 'a Val.tag -> 'a list -> t - val to_option : t -> t option option - val of_option : 'a Val.tag -> 'a option -> t -end - -(** {5 Coercion functions} *) - -val coerce_to_constr_context : Value.t -> constr - -val coerce_to_ident : bool -> Environ.env -> Value.t -> Id.t - -val coerce_to_intro_pattern : Environ.env -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr - -val coerce_to_intro_pattern_naming : - Environ.env -> Value.t -> intro_pattern_naming_expr - -val coerce_to_hint_base : Value.t -> string - -val coerce_to_int : Value.t -> int - -val coerce_to_constr : Environ.env -> Value.t -> constr_under_binders - -val coerce_to_uconstr : Environ.env -> Value.t -> Glob_term.closed_glob_constr - -val coerce_to_closed_constr : Environ.env -> Value.t -> constr - -val coerce_to_evaluable_ref : - Environ.env -> Value.t -> evaluable_global_reference - -val coerce_to_constr_list : Environ.env -> Value.t -> constr list - -val coerce_to_intro_pattern_list : - Loc.t -> Environ.env -> Value.t -> Tacexpr.intro_patterns - -val coerce_to_hyp : Environ.env -> Value.t -> Id.t - -val coerce_to_hyp_list : Environ.env -> Value.t -> Id.t list - -val coerce_to_reference : Environ.env -> Value.t -> Globnames.global_reference - -val coerce_to_quantified_hypothesis : Value.t -> quantified_hypothesis - -val coerce_to_decl_or_quant_hyp : Environ.env -> Value.t -> quantified_hypothesis - -val coerce_to_int_or_var_list : Value.t -> int or_var list - -(** {5 Missing generic arguments} *) - -val wit_constr_context : (Empty.t, Empty.t, constr) genarg_type - -val wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) genarg_type diff --git a/tactics/tactic_matching.ml b/tactics/tactic_matching.ml deleted file mode 100644 index 2144b75e74..0000000000 --- a/tactics/tactic_matching.ml +++ /dev/null @@ -1,375 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** This file extends Matching with the main logic for Ltac's - (lazy)match and (lazy)match goal. *) - -open Names -open Tacexpr -open Context.Named.Declaration - -(** [t] is the type of matching successes. It ultimately contains a - {!Tacexpr.glob_tactic_expr} representing the left-hand side of the - corresponding matching rule, a matching substitution to be - applied, a context substitution mapping identifier to context like - those of {!Matching.matching_result}), and a {!Term.constr} - substitution mapping corresponding to matched hypotheses. *) -type 'a t = { - subst : Constr_matching.bound_ident_map * Pattern.extended_patvar_map ; - context : Term.constr Id.Map.t; - terms : Term.constr Id.Map.t; - lhs : 'a; -} - - - -(** {6 Utilities} *) - - -(** Some of the functions of {!Matching} return the substitution with a - [patvar_map] instead of an [extended_patvar_map]. [adjust] coerces - substitution of the former type to the latter. *) -let adjust : Constr_matching.bound_ident_map * Pattern.patvar_map -> - Constr_matching.bound_ident_map * Pattern.extended_patvar_map = - fun (l, lc) -> (l, Id.Map.map (fun c -> [], c) lc) - - -(** Adds a binding to a {!Id.Map.t} if the identifier is [Some id] *) -let id_map_try_add id x m = - match id with - | Some id -> Id.Map.add id x m - | None -> m - -(** Adds a binding to a {!Id.Map.t} if the name is [Name id] *) -let id_map_try_add_name id x m = - match id with - | Name id -> Id.Map.add id x m - | Anonymous -> m - -(** Takes the union of two {!Id.Map.t}. If there is conflict, - the binding of the right-hand argument shadows that of the left-hand - argument. *) -let id_map_right_biased_union m1 m2 = - if Id.Map.is_empty m1 then m2 (** Don't reconstruct the whole map *) - else Id.Map.fold Id.Map.add m2 m1 - -(** Tests whether the substitution [s] is empty. *) -let is_empty_subst (ln,lm) = - Id.Map.(is_empty ln && is_empty lm) - -(** {6 Non-linear patterns} *) - - -(** The patterns of Ltac are not necessarily linear. Non-linear - pattern are partially handled by the {!Matching} module, however - goal patterns are not primitive to {!Matching}, hence we must deal - with non-linearity between hypotheses and conclusion. Subterms are - considered equal up to the equality implemented in - [equal_instances]. *) -(* spiwack: it doesn't seem to be quite the same rule for non-linear - term patterns and non-linearity between hypotheses and/or - conclusion. Indeed, in [Matching], matching is made modulo - syntactic equality, and here we merge modulo conversion. It may be - a good idea to have an entry point of [Matching] with a partial - substitution as argument instead of merging substitution here. That - would ensure consistency. *) -let equal_instances env sigma (ctx',c') (ctx,c) = - (* How to compare instances? Do we want the terms to be convertible? - unifiable? Do we want the universe levels to be relevant? - (historically, conv_x is used) *) - CList.equal Id.equal ctx ctx' && Reductionops.is_conv env sigma c' c - - -(** Merges two substitutions. Raises [Not_coherent_metas] when - encountering two instances of the same metavariable which are not - equal according to {!equal_instances}. *) -exception Not_coherent_metas -let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) = - let merge id oc1 oc2 = match oc1, oc2 with - | None, None -> None - | None, Some c | Some c, None -> Some c - | Some c1, Some c2 -> - if equal_instances env sigma c1 c2 then Some c1 - else raise Not_coherent_metas - in - let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 in - (** ppedrot: Is that even correct? *) - let merged = ln +++ ln1 in - (merged, Id.Map.merge merge lcm lm) - -let matching_error = - Errors.UserError ("tactic matching" , Pp.str "No matching clauses for match.") - -let imatching_error = (matching_error, Exninfo.null) - -(** A functor is introduced to share the environment and the - evar_map. They do not change and it would be a pity to introduce - closures everywhere just for the occasional calls to - {!equal_instances}. *) -module type StaticEnvironment = sig - val env : Environ.env - val sigma : Evd.evar_map -end -module PatternMatching (E:StaticEnvironment) = struct - - - (** {6 The pattern-matching monad } *) - - - (** To focus on the algorithmic portion of pattern-matching, the - bookkeeping is relegated to a monad: the composition of the - bactracking monad of {!IStream.t} with a "writer" effect. *) - (* spiwack: as we don't benefit from the various stream optimisations - of Haskell, it may be costly to give the monad in direct style such as - here. We may want to use some continuation passing style. *) - type 'a tac = 'a Proofview.tactic - type 'a m = { stream : 'r. ('a -> unit t -> 'r tac) -> unit t -> 'r tac } - - (** The empty substitution. *) - let empty_subst = Id.Map.empty , Id.Map.empty - - (** Composes two substitutions using {!verify_metas_coherence}. It - must be a monoid with neutral element {!empty_subst}. Raises - [Not_coherent_metas] when composition cannot be achieved. *) - let subst_prod s1 s2 = - if is_empty_subst s1 then s2 - else if is_empty_subst s2 then s1 - else verify_metas_coherence E.env E.sigma s1 s2 - - (** The empty context substitution. *) - let empty_context_subst = Id.Map.empty - - (** Compose two context substitutions, in case of conflict the - right hand substitution shadows the left hand one. *) - let context_subst_prod = id_map_right_biased_union - - (** The empty term substitution. *) - let empty_term_subst = Id.Map.empty - - (** Compose two terms substitutions, in case of conflict the - right hand substitution shadows the left hand one. *) - let term_subst_prod = id_map_right_biased_union - - (** Merge two writers (and ignore the first value component). *) - let merge m1 m2 = - try Some { - subst = subst_prod m1.subst m2.subst; - context = context_subst_prod m1.context m2.context; - terms = term_subst_prod m1.terms m2.terms; - lhs = m2.lhs; - } - with Not_coherent_metas -> None - - (** Monadic [return]: returns a single success with empty substitutions. *) - let return (type a) (lhs:a) : a m = - { stream = fun k ctx -> k lhs ctx } - - (** Monadic bind: each success of [x] is replaced by the successes - of [f x]. The substitutions of [x] and [f x] are composed, - dropping the apparent successes when the substitutions are not - coherent. *) - let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m = - { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx } - - (** A variant of [(>>=)] when the first argument returns [unit]. *) - let (<*>) (type a) (m:unit m) (y:a m) : a m = - { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } - - (** Failure of the pattern-matching monad: no success. *) - let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } - - let run (m : 'a m) = - let ctx = { - subst = empty_subst ; - context = empty_context_subst ; - terms = empty_term_subst ; - lhs = (); - } in - let eval lhs ctx = Proofview.tclUNIT { ctx with lhs } in - m.stream eval ctx - - (** Chooses in a list, in the same order as the list *) - let rec pick (l:'a list) (e, info) : 'a m = match l with - | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } - | x :: l -> - { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) } - - let pick l = pick l imatching_error - - (** Declares a subsitution, a context substitution and a term substitution. *) - let put subst context terms : unit m = - let s = { subst ; context ; terms ; lhs = () } in - { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } - - (** Declares a substitution. *) - let put_subst subst : unit m = put subst empty_context_subst empty_term_subst - - (** Declares a term substitution. *) - let put_terms terms : unit m = put empty_subst empty_context_subst terms - - - - (** {6 Pattern-matching} *) - - - (** [wildcard_match_term lhs] matches a term against a wildcard - pattern ([_ => lhs]). It has a single success with an empty - substitution. *) - let wildcard_match_term = return - - (** [pattern_match_term refresh pat term lhs] returns the possible - matchings of [term] with the pattern [pat => lhs]. If refresh is - true, refreshes the universes of [term]. *) - let pattern_match_term refresh pat term lhs = -(* let term = if refresh then Termops.refresh_universes_strict term else term in *) - match pat with - | Term p -> - begin - try - put_subst (Constr_matching.extended_matches E.env E.sigma p term) <*> - return lhs - with Constr_matching.PatternMatchingFailure -> fail - end - | Subterm (with_app_context,id_ctxt,p) -> - - let rec map s (e, info) = - { stream = fun k ctx -> match IStream.peek s with - | IStream.Nil -> Proofview.tclZERO ~info e - | IStream.Cons ({ Constr_matching.m_sub ; m_ctx }, s) -> - let subst = adjust m_sub in - let context = id_map_try_add id_ctxt m_ctx Id.Map.empty in - let terms = empty_term_subst in - let nctx = { subst ; context ; terms ; lhs = () } in - match merge ctx nctx with - | None -> (map s (e, info)).stream k ctx - | Some nctx -> Proofview.tclOR (k lhs nctx) (fun e -> (map s e).stream k ctx) - } - in - map (Constr_matching.match_subterm_gen E.env E.sigma with_app_context p term) imatching_error - - - (** [rule_match_term term rule] matches the term [term] with the - matching rule [rule]. *) - let rule_match_term term = function - | All lhs -> wildcard_match_term lhs - | Pat ([],pat,lhs) -> pattern_match_term false pat term lhs - | Pat _ -> - (** Rules with hypotheses, only work in match goal. *) - fail - - (** [match_term term rules] matches the term [term] with the set of - matching rules [rules].*) - let rec match_term (e, info) term rules = match rules with - | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } - | r :: rules -> - { stream = fun k ctx -> - let head = rule_match_term term r in - let tail e = match_term e term rules in - Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx) - } - - - (** [hyp_match_type hypname pat hyps] matches a single - hypothesis pattern [hypname:pat] against the hypotheses in - [hyps]. Tries the hypotheses in order. For each success returns - the name of the matched hypothesis. *) - let hyp_match_type hypname pat hyps = - pick hyps >>= fun decl -> - let id = get_id decl in - let refresh = is_local_def decl in - pattern_match_term refresh pat (get_type decl) () <*> - put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> - return id - - (** [hyp_match_type hypname bodypat typepat hyps] matches a single - hypothesis pattern [hypname := bodypat : typepat] against the - hypotheses in [hyps].Tries the hypotheses in order. For each - success returns the name of the matched hypothesis. *) - let hyp_match_body_and_type hypname bodypat typepat hyps = - pick hyps >>= function - | LocalDef (id,body,hyp) -> - pattern_match_term false bodypat body () <*> - pattern_match_term true typepat hyp () <*> - put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> - return id - | LocalAssum (id,hyp) -> fail - - (** [hyp_match pat hyps] dispatches to - {!hyp_match_type} or {!hyp_match_body_and_type} depending on whether - [pat] is [Hyp _] or [Def _]. *) - let hyp_match pat hyps = - match pat with - | Hyp ((_,hypname),typepat) -> - hyp_match_type hypname typepat hyps - | Def ((_,hypname),bodypat,typepat) -> - hyp_match_body_and_type hypname bodypat typepat hyps - - (** [hyp_pattern_list_match pats hyps lhs], matches the list of - patterns [pats] against the hypotheses in [hyps], and eventually - returns [lhs]. *) - let rec hyp_pattern_list_match pats hyps lhs = - match pats with - | pat::pats -> - hyp_match pat hyps >>= fun matched_hyp -> - (* spiwack: alternatively it is possible to return the list - with the matched hypothesis removed directly in - [hyp_match]. *) - let select_matched_hyp decl = Id.equal (get_id decl) matched_hyp in - let hyps = CList.remove_first select_matched_hyp hyps in - hyp_pattern_list_match pats hyps lhs - | [] -> return lhs - - (** [rule_match_goal hyps concl rule] matches the rule [rule] - against the goal [hyps|-concl]. *) - let rule_match_goal hyps concl = function - | All lhs -> wildcard_match_term lhs - | Pat (hyppats,conclpat,lhs) -> - (* the rules are applied from the topmost one (in the concrete - syntax) to the bottommost. *) - let hyppats = List.rev hyppats in - pattern_match_term false conclpat concl () <*> - hyp_pattern_list_match hyppats hyps lhs - - (** [match_goal hyps concl rules] matches the goal [hyps|-concl] - with the set of matching rules [rules]. *) - let rec match_goal (e, info) hyps concl rules = match rules with - | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } - | r :: rules -> - { stream = fun k ctx -> - let head = rule_match_goal hyps concl r in - let tail e = match_goal e hyps concl rules in - Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx) - } - -end - -(** [match_term env sigma term rules] matches the term [term] with the - set of matching rules [rules]. The environment [env] and the - evar_map [sigma] are not currently used, but avoid code - duplication. *) -let match_term env sigma term rules = - let module E = struct - let env = env - let sigma = sigma - end in - let module M = PatternMatching(E) in - M.run (M.match_term imatching_error term rules) - - -(** [match_goal env sigma hyps concl rules] matches the goal - [hyps|-concl] with the set of matching rules [rules]. The - environment [env] and the evar_map [sigma] are used to check - convertibility for pattern variables shared between hypothesis - patterns or the conclusion pattern. *) -let match_goal env sigma hyps concl rules = - let module E = struct - let env = env - let sigma = sigma - end in - let module M = PatternMatching(E) in - M.run (M.match_goal imatching_error hyps concl rules) diff --git a/tactics/tactic_matching.mli b/tactics/tactic_matching.mli deleted file mode 100644 index 090207bcc3..0000000000 --- a/tactics/tactic_matching.mli +++ /dev/null @@ -1,49 +0,0 @@ - (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** This file extends Matching with the main logic for Ltac's - (lazy)match and (lazy)match goal. *) - - -(** [t] is the type of matching successes. It ultimately contains a - {!Tacexpr.glob_tactic_expr} representing the left-hand side of the - corresponding matching rule, a matching substitution to be - applied, a context substitution mapping identifier to context like - those of {!Matching.matching_result}), and a {!Term.constr} - substitution mapping corresponding to matched hypotheses. *) -type 'a t = { - subst : Constr_matching.bound_ident_map * Pattern.extended_patvar_map ; - context : Term.constr Names.Id.Map.t; - terms : Term.constr Names.Id.Map.t; - lhs : 'a; -} - - -(** [match_term env sigma term rules] matches the term [term] with the - set of matching rules [rules]. The environment [env] and the - evar_map [sigma] are not currently used, but avoid code - duplication. *) -val match_term : - Environ.env -> - Evd.evar_map -> - Term.constr -> - (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> - Tacexpr.glob_tactic_expr t Proofview.tactic - -(** [match_goal env sigma hyps concl rules] matches the goal - [hyps|-concl] with the set of matching rules [rules]. The - environment [env] and the evar_map [sigma] are used to check - convertibility for pattern variables shared between hypothesis - patterns or the conclusion pattern. *) -val match_goal: - Environ.env -> - Evd.evar_map -> - Context.Named.t -> - Term.constr -> - (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> - Tacexpr.glob_tactic_expr t Proofview.tactic diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 7f904a561d..93c04e373c 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -7,7 +7,7 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util open Names open Term @@ -15,8 +15,10 @@ open Termops open Declarations open Tacmach open Clenv +open Tactypes open Sigma.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (************************************************************************) (* Tacticals re-exported from the Refiner module *) @@ -70,7 +72,7 @@ let nthDecl m gl = try List.nth (pf_hyps gl) (m-1) with Failure _ -> error "No such assumption." -let nthHypId m gl = nthDecl m gl |> get_id +let nthHypId m gl = nthDecl m gl |> NamedDecl.get_id let nthHyp m gl = mkVar (nthHypId m gl) let lastDecl gl = nthDecl 1 gl @@ -81,7 +83,7 @@ let nLastDecls n gl = try List.firstn n (pf_hyps gl) with Failure _ -> error "Not enough hypotheses in the goal." -let nLastHypsId n gl = List.map get_id (nLastDecls n gl) +let nLastHypsId n gl = List.map NamedDecl.get_id (nLastDecls n gl) let nLastHyps n gl = List.map mkVar (nLastHypsId n gl) let onNthDecl m tac gl = tac (nthDecl m gl) gl @@ -99,7 +101,7 @@ let onNLastHypsId n tac = onHyps (nLastHypsId n) tac let onNLastHyps n tac = onHyps (nLastHyps n) tac let afterHyp id gl = - fst (List.split_when (Id.equal id % get_id) (pf_hyps gl)) + fst (List.split_when (NamedDecl.get_id %> Id.equal id) (pf_hyps gl)) (***************************************) (* Clause Tacticals *) @@ -151,7 +153,7 @@ type branch_args = { nassums : int; (* number of assumptions/letin to be introduced *) branchsign : bool list; (* the signature of the branch. true=assumption, false=let-in *) - branchnames : Tacexpr.intro_patterns} + branchnames : intro_patterns} type branch_assumptions = { ba : branch_args; (* the branch args *) @@ -172,14 +174,14 @@ let check_or_and_pattern_size check_and loc names branchsigns = let n = Array.length branchsigns in let msg p1 p2 = strbrk "a conjunctive pattern made of " ++ int p1 ++ (if p1 == p2 then mt () else str " or " ++ int p2) ++ str " patterns" in let err1 p1 p2 = - user_err_loc (loc,"",str "Expects " ++ msg p1 p2 ++ str ".") in + user_err ~loc (str "Expects " ++ msg p1 p2 ++ str ".") in let errn n = - user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n + user_err ~loc (str "Expects a disjunctive pattern with " ++ int n ++ str " branches.") in let err1' p1 p2 = - user_err_loc (loc,"",strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in + user_err ~loc (strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in let errforthcoming loc = - user_err_loc (loc,"",strbrk "Unexpected non atomic pattern.") in + user_err ~loc (strbrk "Unexpected non atomic pattern.") in match names with | IntroAndPattern l -> if not (Int.equal n 1) then errn n; @@ -311,7 +313,7 @@ module New = struct tclZERO (Refiner.FailError (lvl,lazy msg)) let tclZEROMSG ?loc msg = - let err = UserError ("", msg) in + let err = UserError (None, msg) in let info = match loc with | None -> Exninfo.null | Some loc -> Loc.add_loc Exninfo.null loc @@ -322,7 +324,7 @@ module New = struct try Refiner.catch_failerror e; tclUNIT () - with e -> tclZERO e + with e when CErrors.noncritical e -> tclZERO e (* spiwack: I chose to give the Ltac + the same semantics as [Proofview.tclOR], however, for consistency with the or-else @@ -476,6 +478,13 @@ module New = struct let tclPROGRESS t = Proofview.tclINDEPENDENT (Proofview.tclPROGRESS t) + (* Select a subset of the goals *) + let tclSELECT = function + | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i + | Vernacexpr.SelectList l -> Proofview.tclFOCUSLIST l + | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id + | Vernacexpr.SelectAll -> fun tac -> tac + (* Check that holes in arguments have been resolved *) let check_evars env sigma extsigma origsigma = @@ -501,7 +510,7 @@ module New = struct | [] -> () | (evk,evi) :: _ -> let (loc,_) = evi.Evd.evar_source in - Pretype_errors.error_unsolvable_implicit loc env sigma evk None + Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None let tclWITHHOLES accept_unresolved_holes tac sigma = tclEVARMAP >>= fun sigma_initial -> @@ -514,7 +523,7 @@ module New = struct try let () = check_evars env sigma_final sigma sigma_initial in tclUNIT x - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> tclZERO e else tclUNIT x @@ -525,7 +534,7 @@ module New = struct Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let Sigma (x, sigma, _) = x.Tacexpr.delayed env sigma in + let Sigma (x, sigma, _) = x.delayed env sigma in tclWITHHOLES check (tac x) (Sigma.to_evar_map sigma) end } @@ -533,7 +542,7 @@ module New = struct Proofview.tclOR (Proofview.tclTIMEOUT n t) begin function (e, info) -> match e with - | Proofview.Timeout as e -> Proofview.tclZERO (Refiner.FailError (0,lazy (Errors.print e))) + | Proofview.Timeout as e -> Proofview.tclZERO (Refiner.FailError (0,lazy (CErrors.print e))) | e -> Proofview.tclZERO ~info e end @@ -544,7 +553,7 @@ module New = struct let hyps = Proofview.Goal.hyps gl in try List.nth hyps (m-1) - with Failure _ -> Errors.error "No such assumption." + with Failure _ -> CErrors.error "No such assumption." let nLastDecls gl n = try List.firstn n (Proofview.Goal.hyps gl) @@ -553,7 +562,7 @@ module New = struct let nthHypId m gl = (** We only use [id] *) let gl = Proofview.Goal.assume gl in - nthDecl m gl |> get_id + nthDecl m gl |> NamedDecl.get_id let nthHyp m gl = mkVar (nthHypId m gl) @@ -583,9 +592,9 @@ module New = struct let onHyps find tac = Proofview.Goal.nf_enter { enter = begin fun gl -> tac (find.enter gl) end } let afterHyp id tac = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let hyps = Proofview.Goal.hyps gl in - let rem, _ = List.split_when (Id.equal id % get_id) hyps in + Proofview.Goal.enter { enter = begin fun gl -> + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + let rem, _ = List.split_when (NamedDecl.get_id %> Id.equal id) hyps in tac rem end } @@ -636,7 +645,7 @@ module New = struct | Var id -> string_of_id id | _ -> "\b" in - errorlabstrm "Tacticals.general_elim_then_using" + user_err ~hdr:"Tacticals.general_elim_then_using" (str "The elimination combinator " ++ str name_elim ++ str " is unknown.") in let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 0f926468b9..18cf03c51d 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -11,9 +11,9 @@ open Names open Term open Tacmach open Proof_type -open Tacexpr open Locus open Misctypes +open Tactypes (** Tacticals i.e. functions from tactics to tactics. *) @@ -221,6 +221,7 @@ module New : sig val tclCOMPLETE : 'a tactic -> 'a tactic val tclSOLVE : unit tactic list -> unit tactic val tclPROGRESS : unit tactic -> unit tactic + val tclSELECT : Vernacexpr.goal_selector -> 'a tactic -> 'a tactic val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic val tclDELAYEDWITHHOLES : bool -> 'a delayed_open -> ('a -> unit tactic) -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 0bb8426011..6205bd1092 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -7,7 +7,7 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util open Names open Nameops @@ -32,7 +32,6 @@ open Refiner open Tacticals open Hipattern open Coqlib -open Tacexpr open Decl_kinds open Evarutil open Indrec @@ -41,14 +40,23 @@ open Unification open Locus open Locusops open Misctypes +open Tactypes open Proofview.Notations open Sigma.Notations +open Context.Named.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration let inj_with_occurrences e = (AllOccurrences,e) let dloc = Loc.ghost -let typ_of env sigma c = Retyping.get_type_of env (Sigma.to_evar_map sigma) c +let typ_of env sigma c = + let open Retyping in + try get_type_of ~lax:true env (Sigma.to_evar_map sigma) c + with RetypeError e -> + user_err (print_retype_error e) open Goptions @@ -79,7 +87,7 @@ let _ = let apply_solve_class_goals = ref (false) let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optsync = true; Goptions.optdepr = true; Goptions.optname = "Perform typeclass resolution on apply-generated subgoals."; Goptions.optkey = ["Typeclass";"Resolution";"After";"Apply"]; @@ -119,12 +127,12 @@ let _ = (* Shrinking of abstract proofs. *) -let shrink_abstract = ref false +let shrink_abstract = ref true let _ = declare_bool_option { optsync = true; - optdepr = false; + optdepr = true; optname = "shrinking of abstracted proofs"; optkey = ["Shrink"; "Abstract"]; optread = (fun () -> !shrink_abstract) ; @@ -162,30 +170,29 @@ let _ = (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) let unsafe_intro env store decl b = - let open Context.Named.Declaration in Refine.refine ~unsafe:true { run = begin fun sigma -> let ctx = named_context_val env in let nctx = push_named_context_val decl ctx in - let inst = List.map (mkVar % get_id) (named_context env) in + let inst = List.map (NamedDecl.get_id %> mkVar) (named_context env) in let ninst = mkRel 1 :: inst in - let nb = subst1 (mkVar (get_id decl)) b in + let nb = subst1 (mkVar (NamedDecl.get_id decl)) b in let Sigma (ev, sigma, p) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in Sigma (mkNamedLambda_or_LetIn decl ev, sigma, p) end } let introduction ?(check=true) id = - let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in - let hyps = Proofview.Goal.hyps gl in + let hyps = named_context_val (Proofview.Goal.env gl) in let store = Proofview.Goal.extra gl in let env = Proofview.Goal.env gl in - let () = if check && mem_named_context id hyps then - errorlabstrm "Tactics.introduction" + let () = if check && mem_named_context_val id hyps then + user_err ~hdr:"Tactics.introduction" (str "Variable " ++ pr_id id ++ str " is already declared.") in + let open Context.Named.Declaration in match kind_of_term (whd_evar sigma concl) with | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b @@ -255,7 +262,7 @@ let clear_dependency_msg env sigma id = function Printer.pr_existential env sigma ev ++ str"." let error_clear_dependency env sigma id err = - errorlabstrm "" (clear_dependency_msg env sigma id err) + user_err (clear_dependency_msg env sigma id err) let replacing_dependency_msg env sigma id = function | Evarutil.OccurHypInSimpleClause None -> @@ -269,35 +276,65 @@ let replacing_dependency_msg env sigma id = function Printer.pr_existential env sigma ev ++ str"." let error_replacing_dependency env sigma id err = - errorlabstrm "" (replacing_dependency_msg env sigma id err) + user_err (replacing_dependency_msg env sigma id err) + +(* This tactic enables the user to remove hypotheses from the signature. + * Some care is taken to prevent him from removing variables that are + * subsequently used in other hypotheses or in the conclusion of the + * goal. *) -let thin l gl = - try Tacmach.thin l gl - with Evarutil.ClearDependencyError (id,err) -> - error_clear_dependency (pf_env gl) (project gl) id err +let clear_gen fail = function +| [] -> Proofview.tclUNIT () +| ids -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let ids = List.fold_right Id.Set.add ids Id.Set.empty in + (** clear_hyps_in_evi does not require nf terms *) + let gl = Proofview.Goal.assume gl in + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let concl = Proofview.Goal.concl gl in + let evdref = ref sigma in + let (hyps, concl) = + try clear_hyps_in_evi env evdref (named_context_val env) concl ids + with Evarutil.ClearDependencyError (id,err) -> fail env sigma id err + in + let env = reset_with_named_context hyps env in + let tac = Refine.refine ~unsafe:true { run = fun sigma -> + Evarutil.new_evar env sigma ~principal:true concl + } in + Sigma.Unsafe.of_pair (tac, !evdref) + end } -let thin_for_replacing l gl = - try Tacmach.thin l gl - with Evarutil.ClearDependencyError (id,err) -> - error_replacing_dependency (pf_env gl) (project gl) id err +let clear ids = clear_gen error_clear_dependency ids +let clear_for_replacing ids = clear_gen error_replacing_dependency ids let apply_clear_request clear_flag dft c = let check_isvar c = if not (isVar c) then error "keep/clear modifiers apply only to hypothesis names." in - let clear = match clear_flag with + let doclear = match clear_flag with | None -> dft && isVar c | Some true -> check_isvar c; true | Some false -> false in - if clear then Proofview.V82.tactic (thin [destVar c]) + if doclear then clear [destVar c] else Tacticals.New.tclIDTAC (* Moving hypotheses *) -let move_hyp id dest gl = Tacmach.move_hyp id dest gl +let move_hyp id dest = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let ty = Proofview.Goal.raw_concl gl in + let store = Proofview.Goal.extra gl in + let sign = named_context_val env in + let sign' = move_hyp_in_named_context id dest sign in + let env = reset_with_named_context sign' env in + Refine.refine ~unsafe:true { run = begin fun sigma -> + Evarutil.new_evar env sigma ~principal:true ~store ty + end } + end } (* Renaming hypotheses *) let rename_hyp repl = - let open Context.Named.Declaration in let fold accu (src, dst) = match accu with | None -> None | Some (srcs, dsts) -> @@ -319,7 +356,7 @@ let rename_hyp repl = let concl = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in (** Check that we do not mess variables *) - let fold accu decl = Id.Set.add (get_id decl) accu in + let fold accu decl = Id.Set.add (NamedDecl.get_id decl) accu in let vars = List.fold_left fold Id.Set.empty hyps in let () = if not (Id.Set.subset src vars) then @@ -330,7 +367,7 @@ let rename_hyp repl = let () = try let elt = Id.Set.choose (Id.Set.inter dst mods) in - Errors.errorlabstrm "" (pr_id elt ++ str " is already used") + CErrors.user_err (pr_id elt ++ str " is already used") with Not_found -> () in (** All is well *) @@ -338,15 +375,15 @@ let rename_hyp repl = let subst = List.map make_subst repl in let subst c = Vars.replace_vars subst c in let map decl = - decl |> map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id) - |> map_constr subst + decl |> NamedDecl.map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id) + |> NamedDecl.map_constr subst in let nhyps = List.map map hyps in let nconcl = subst concl in let nctx = Environ.val_of_named_context nhyps in - let instance = List.map (mkVar % get_id) hyps in + let instance = List.map (NamedDecl.get_id %> mkVar) hyps in Refine.refine ~unsafe:true { run = begin fun sigma -> - Evarutil.new_evar_instance nctx sigma nconcl ~store instance + Evarutil.new_evar_instance nctx sigma nconcl ~principal:true ~store instance end } end } @@ -403,7 +440,7 @@ let find_name mayrepl decl naming gl = match naming with let ids_of_hyps = Tacmach.New.pf_ids_of_hyps gl in let id' = next_ident_away id ids_of_hyps in if not mayrepl && not (Id.equal id' id) then - user_err_loc (loc,"",pr_id id ++ str" is already used."); + user_err ~loc (pr_id id ++ str" is already used."); id (**************************************************************) @@ -452,23 +489,120 @@ let assert_after_replacing id = assert_after_gen true (NamingMustBe (dloc,id)) (* Fixpoints and CoFixpoints *) (**************************************************************) +let rec mk_holes : type r s. _ -> r Sigma.t -> (s, r) Sigma.le -> _ -> (_, s) Sigma.sigma = +fun env sigma p -> function +| [] -> Sigma ([], sigma, p) +| arg :: rem -> + let Sigma (arg, sigma, q) = Evarutil.new_evar env sigma arg in + let Sigma (rem, sigma, r) = mk_holes env sigma (p +> q) rem in + Sigma (arg :: rem, sigma, r) + +let rec check_mutind env sigma k cl = match kind_of_term (strip_outer_cast cl) with +| Prod (na, c1, b) -> + if Int.equal k 1 then + try + let ((sp, _), u), _ = find_inductive env sigma c1 in + (sp, u) + with Not_found -> error "Cannot do a fixpoint on a non inductive type." + else + let open Context.Rel.Declaration in + check_mutind (push_rel (LocalAssum (na, c1)) env) sigma (pred k) b +| _ -> error "Not enough products." + (* Refine as a fixpoint *) -let mutual_fix = Tacmach.mutual_fix +let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let concl = Proofview.Goal.concl gl in + let (sp, u) = check_mutind env sigma n concl in + let firsts, lasts = List.chop j rest in + let all = firsts @ (f, n, concl) :: lasts in + let rec mk_sign sign = function + | [] -> sign + | (f, n, ar) :: oth -> + let open Context.Named.Declaration in + let (sp', u') = check_mutind env sigma n ar in + if not (eq_mind sp sp') then + error "Fixpoints should be on the same mutual inductive declaration."; + if mem_named_context_val f sign then + user_err ~hdr:"Logic.prim_refiner" + (str "Name " ++ pr_id f ++ str " already used in the environment"); + mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth + in + let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in + Refine.refine { run = begin fun sigma -> + let Sigma (evs, sigma, p) = mk_holes nenv sigma Sigma.refl (List.map pi3 all) in + let ids = List.map pi1 all in + let evs = List.map (Vars.subst_vars (List.rev ids)) evs in + let indxs = Array.of_list (List.map (fun n -> n-1) (List.map pi2 all)) in + let funnames = Array.of_list (List.map (fun i -> Name i) ids) in + let typarray = Array.of_list (List.map pi3 all) in + let bodies = Array.of_list evs in + let oterm = Term.mkFix ((indxs,0),(funnames,typarray,bodies)) in + Sigma (oterm, sigma, p) + end } +end } -let fix ido n gl = match ido with +let fix ido n = match ido with | None -> - mutual_fix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) n [] 0 gl + Proofview.Goal.enter { enter = begin fun gl -> + let name = Pfedit.get_current_proof_name () in + let id = new_fresh_id [] name gl in + mutual_fix id n [] 0 + end } | Some id -> - mutual_fix id n [] 0 gl + mutual_fix id n [] 0 + +let rec check_is_mutcoind env sigma cl = + let b = whd_all env sigma cl in + match kind_of_term b with + | Prod (na, c1, b) -> + let open Context.Rel.Declaration in + check_is_mutcoind (push_rel (LocalAssum (na,c1)) env) sigma b + | _ -> + try + let _ = find_coinductive env sigma b in () + with Not_found -> + error "All methods must construct elements in coinductive types." (* Refine as a cofixpoint *) -let mutual_cofix = Tacmach.mutual_cofix +let mutual_cofix f others j = Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let concl = Proofview.Goal.concl gl in + let firsts,lasts = List.chop j others in + let all = firsts @ (f, concl) :: lasts in + List.iter (fun (_, c) -> check_is_mutcoind env sigma c) all; + let rec mk_sign sign = function + | [] -> sign + | (f, ar) :: oth -> + let open Context.Named.Declaration in + if mem_named_context_val f sign then + error "Name already used in the environment."; + mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth + in + let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in + Refine.refine { run = begin fun sigma -> + let (ids, types) = List.split all in + let Sigma (evs, sigma, p) = mk_holes nenv sigma Sigma.refl types in + let evs = List.map (Vars.subst_vars (List.rev ids)) evs in + let funnames = Array.of_list (List.map (fun i -> Name i) ids) in + let typarray = Array.of_list types in + let bodies = Array.of_list evs in + let oterm = Term.mkCoFix (0, (funnames, typarray, bodies)) in + Sigma (oterm, sigma, p) + end } +end } -let cofix ido gl = match ido with +let cofix ido = match ido with | None -> - mutual_cofix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) [] 0 gl + Proofview.Goal.enter { enter = begin fun gl -> + let name = Pfedit.get_current_proof_name () in + let id = new_fresh_id [] name gl in + mutual_cofix id [] 0 + end } | Some id -> - mutual_cofix id [] 0 gl + mutual_cofix id [] 0 (**************************************************************) (* Reduction and conversion tactics *) @@ -482,7 +616,7 @@ let pf_reduce_decl redfun where decl gl = match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str " has no value."); + user_err (pr_id id ++ str " has no value."); LocalAssum (id,redfun' ty) | LocalDef (id,b,ty) -> let b' = if where != InHypTypeOnly then redfun' b else b in @@ -583,7 +717,7 @@ let pf_e_reduce_decl redfun where decl gl = match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str " has no value."); + user_err (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = redfun sigma ty in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> @@ -591,11 +725,11 @@ let pf_e_reduce_decl redfun where decl gl = let Sigma (ty', sigma, q) = if where != InHypValueOnly then redfun sigma ty else Sigma.here ty sigma in Sigma (LocalDef (id, b', ty'), sigma, p +> q) -let e_reduct_in_concl (redfun, sty) = +let e_reduct_in_concl ~check (redfun, sty) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in - Sigma (convert_concl_no_check c' sty, sigma, p) + Sigma (convert_concl ~check c' sty, sigma, p) end } let e_reduct_in_hyp ?(check=false) redfun (id, where) = @@ -606,7 +740,7 @@ let e_reduct_in_hyp ?(check=false) redfun (id, where) = let e_reduct_option ?(check=false) redfun = function | Some id -> e_reduct_in_hyp ~check (fst redfun) id - | None -> e_reduct_in_concl (revert_cast redfun) + | None -> e_reduct_in_concl ~check (revert_cast redfun) (** Versions with evars to maintain the unification of universes resulting from conversions. *) @@ -623,7 +757,7 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigm match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str " has no value."); + user_err (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> @@ -657,16 +791,16 @@ let check_types env sigma mayneedglobalcheck deep newc origc = let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in if not b then if - isSort (whd_betadeltaiota env sigma t1) && - isSort (whd_betadeltaiota env sigma t2) + isSort (whd_all env sigma t1) && + isSort (whd_all env sigma t2) then (mayneedglobalcheck := true; sigma) else - errorlabstrm "convert-check-hyp" (str "Types are incompatible.") + user_err ~hdr:"convert-check-hyp" (str "Types are incompatible.") else sigma end else - if not (isSort (whd_betadeltaiota env sigma t1)) then - errorlabstrm "convert-check-hyp" (str "Not a type.") + if not (isSort (whd_all env sigma t1)) then + user_err ~hdr:"convert-check-hyp" (str "Not a type.") else sigma (* Now we introduce different instances of the previous tacticals *) @@ -675,7 +809,7 @@ let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun en let sigma = Sigma.to_evar_map sigma in let sigma = check_types env sigma mayneedglobalcheck deep t' c in let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in - if not b then errorlabstrm "convert-check-hyp" (str "Not convertible."); + if not b then user_err ~hdr:"convert-check-hyp" (str "Not convertible."); Sigma.Unsafe.of_pair (t', sigma) end } @@ -708,14 +842,16 @@ let change_option occl t = function | Some id -> change_in_hyp occl t id | None -> change_in_concl occl t -let change chg c cls gl = - let cls = concrete_clause_of (fun () -> Tacmach.pf_ids_of_hyps gl) cls in - Proofview.V82.of_tactic (Tacticals.New.tclMAP (function +let change chg c cls = + Proofview.Goal.enter { enter = begin fun gl -> + let cls = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in + Tacticals.New.tclMAP (function | OnHyp (id,occs,where) -> change_option (bind_change_occurrences occs chg) c (Some (id,where)) | OnConcl occs -> change_option (bind_change_occurrences occs chg) c None) - cls) gl + cls + end } let change_concl t = change_in_concl None (make_change_arg t) @@ -750,22 +886,28 @@ let reduction_clause redexp cl = (None, bind_red_expr_occurrences occs nbcl redexp)) cl let reduce redexp cl = + let trace () = + let open Printer in + let pr = (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern) in + Pp.(hov 2 (Pputils.pr_red_expr pr str redexp)) + in + Proofview.Trace.name_tactic trace begin Proofview.Goal.enter { enter = begin fun gl -> - let cl = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in - let redexps = reduction_clause redexp cl in + let cl' = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in + let redexps = reduction_clause redexp cl' in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in - let tac = Tacticals.New.tclMAP (fun (where,redexp) -> + Tacticals.New.tclMAP (fun (where,redexp) -> e_reduct_option ~check - (Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp) where) redexps in - if check then Proofview.V82.tactic (fun gl -> with_check (Proofview.V82.of_tactic tac) gl) else tac (** FIXME *) + (Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp) where) redexps end } + end (* Unfolding occurrences of a constant *) let unfold_constr = function | ConstRef sp -> unfold_in_concl [AllOccurrences,EvalConstRef sp] | VarRef id -> unfold_in_concl [AllOccurrences,EvalVarRef id] - | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.") + | _ -> user_err ~hdr:"unfold_constr" (str "Cannot unfold a non-constant.") (*******************************************) (* Introduction tactics *) @@ -789,9 +931,8 @@ let find_intro_names ctxt gl = let build_intro_tac id dest tac = match dest with | MoveLast -> Tacticals.New.tclTHEN (introduction id) (tac id) | dest -> Tacticals.New.tclTHENLIST - [introduction id; - Proofview.V82.tactic (move_hyp id dest); tac id] - + [introduction id; move_hyp id dest; tac id] + let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> @@ -865,23 +1006,21 @@ let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = aux n [] let get_next_hyp_position id gl = - let open Context.Named.Declaration in let rec aux = function | [] -> raise (RefinerError (NoSuchHyp id)) | decl :: right -> - if Id.equal (get_id decl) id then - match right with decl::_ -> MoveBefore (get_id decl) | [] -> MoveLast + if Id.equal (NamedDecl.get_id decl) id then + match right with decl::_ -> MoveBefore (NamedDecl.get_id decl) | [] -> MoveLast else aux right in aux (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let get_previous_hyp_position id gl = - let open Context.Named.Declaration in let rec aux dest = function | [] -> raise (RefinerError (NoSuchHyp id)) | decl :: right -> - let hyp = get_id decl in + let hyp = NamedDecl.get_id decl in if Id.equal hyp id then dest else aux (MoveAfter hyp) right in aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) @@ -890,9 +1029,9 @@ let intro_replacing id = Proofview.Goal.enter { enter = begin fun gl -> let next_hyp = get_next_hyp_position id gl in Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (thin_for_replacing [id]); + clear_for_replacing [id]; introduction id; - Proofview.V82.tactic (move_hyp id next_hyp); + move_hyp id next_hyp; ] end } @@ -910,7 +1049,7 @@ let intros_possibly_replacing ids = let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in Tacticals.New.tclTHEN (Tacticals.New.tclMAP (fun id -> - Tacticals.New.tclTRY (Proofview.V82.tactic (thin_for_replacing [id]))) + Tacticals.New.tclTRY (clear_for_replacing [id])) (if suboptimal then ids else List.rev ids)) (Tacticals.New.tclMAP (fun (id,pos) -> Tacticals.New.tclORELSE (intro_move (Some id) pos) (intro_using id)) @@ -922,7 +1061,7 @@ let intros_replacing ids = Proofview.Goal.enter { enter = begin fun gl -> let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in Tacticals.New.tclTHEN - (Proofview.V82.tactic (thin_for_replacing ids)) + (clear_for_replacing ids) (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl) end } @@ -961,7 +1100,7 @@ let depth_of_quantified_hypothesis red h gl = match lookup_hypothesis_as_renamed_gen red h gl with | Some depth -> depth | None -> - errorlabstrm "lookup_quantified_hypothesis" + user_err ~hdr:"lookup_quantified_hypothesis" (str "No " ++ msg_quantified_hypothesis h ++ strbrk " in current goal" ++ (if red then strbrk " even after head-reduction" else mt ()) ++ @@ -979,10 +1118,14 @@ let intros_until_n_gen red n = intros_until_gen red (AnonHyp n) let intros_until = intros_until_gen true let intros_until_n = intros_until_n_gen true -let tclCHECKVAR id gl = ignore (Tacmach.pf_get_hyp gl id); tclIDTAC gl +let tclCHECKVAR id = + Proofview.Goal.enter { enter = begin fun gl -> + let _ = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in + Proofview.tclUNIT () + end } let try_intros_until_id_check id = - Tacticals.New.tclORELSE (intros_until_id id) (Proofview.V82.tactic (tclCHECKVAR id)) + Tacticals.New.tclORELSE (intros_until_id id) (tclCHECKVAR id) let try_intros_until tac = function | NamedHyp id -> Tacticals.New.tclTHEN (try_intros_until_id_check id) (tac id) @@ -1000,6 +1143,14 @@ let run_delayed env sigma c = (* Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) +let tactic_infer_flags with_evar = { + Pretyping.use_typeclasses = true; + Pretyping.solve_unification_constraints = true; + Pretyping.use_hook = Some solve_by_implicit_tactic; + Pretyping.fail_evar = not with_evar; + Pretyping.expand_evars = true } + + let onOpenInductionArg env sigma tac = function | clear_flag,ElimOnConstr f -> let (cbl, sigma') = run_delayed env sigma f in @@ -1040,10 +1191,25 @@ let onInductionArg tac = function (try_intros_until_id_check id) (tac clear_flag (mkVar id,NoBindings)) -let map_induction_arg f = function - | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (f g) - | clear_flag,ElimOnAnonHyp n as x -> x - | clear_flag,ElimOnIdent id as x -> x +let map_destruction_arg f sigma = function + | clear_flag,ElimOnConstr g -> let sigma,x = f sigma g in (sigma, (clear_flag,ElimOnConstr x)) + | clear_flag,ElimOnAnonHyp n as x -> (sigma,x) + | clear_flag,ElimOnIdent id as x -> (sigma,x) + +let finish_delayed_evar_resolution with_evars env sigma f = + let ((c, lbind), sigma') = run_delayed env sigma f in + let pending = (sigma,sigma') in + let sigma' = Sigma.Unsafe.of_evar_map sigma' in + let flags = tactic_infer_flags with_evars in + let Sigma (c, sigma', _) = finish_evar_resolution ~flags env sigma' (pending,c) in + (Sigma.to_evar_map sigma', (c, lbind)) + +let with_no_bindings (c, lbind) = + if lbind != NoBindings then error "'with' clause not supported here."; + c + +let force_destruction_arg with_evars env sigma c = + map_destruction_arg (finish_delayed_evar_resolution with_evars env) sigma c (****************************************) (* tactic "cut" (actually modus ponens) *) @@ -1060,7 +1226,7 @@ let cut c = try (** Backward compat: ensure that [c] is well-typed. *) let typ = Typing.unsafe_type_of env sigma c in - let typ = whd_betadeltaiota env sigma typ in + let typ = whd_all env sigma typ in match kind_of_term typ with | Sort _ -> true | _ -> false @@ -1083,7 +1249,7 @@ let cut c = let error_uninstantiated_metas t clenv = let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in let id = match na with Name id -> id | _ -> anomaly (Pp.str "unnamed dependent meta") - in errorlabstrm "" (str "Cannot find an instance for " ++ pr_id id ++ str".") + in user_err (str "Cannot find an instance for " ++ pr_id id ++ str".") let check_unresolved_evars_of_metas sigma clenv = (* This checks that Metas turned into Evars by *) @@ -1126,7 +1292,7 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) let naming = NamingMustBe (dloc,targetid) in let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS clenv.evd) + (Proofview.Unsafe.tclEVARS (clear_metas clenv.evd)) (if sidecond_first then Tacticals.New.tclTHENFIRST (assert_before_then_gen with_clear naming new_hyp_typ tac) exact_tac @@ -1186,7 +1352,7 @@ let enforce_prop_bound_names rename tac = mkProd (Anonymous,t,aux (push_rel (LocalAssum (Anonymous,t)) env) sigma (i-1) t') | LetIn (na,c,t,t') -> mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t') - | _ -> print_int i; Pp.msg (print_constr t); assert false in + | _ -> print_int i; Feedback.msg_notice (print_constr t); assert false in let rename_branch i = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in @@ -1216,7 +1382,7 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags let indmv = (match kind_of_term (nth_arg i elimclause.templval.rebus) with | Meta mv -> mv - | _ -> errorlabstrm "elimination_clause" + | _ -> user_err ~hdr:"elimination_clause" (str "The type of elimination clause is not well-formed.")) in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in @@ -1256,6 +1422,8 @@ let general_elim with_evars clear_flag (c, lbindc) elim = let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in let elimtac = elimination_clause_scheme with_evars in let indclause = make_clenv_binding env sigma (c, t) lbindc in + let sigma = meta_merge sigma (clear_metas indclause.evd) in + Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.tclTHEN (general_elim_clause_gen elimtac indclause elim) (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c) @@ -1293,6 +1461,7 @@ let general_case_analysis with_evars clear_flag (c,lbindc as cx) = general_case_analysis_in_context with_evars clear_flag cx let simplest_case c = general_case_analysis false None (c,NoBindings) +let simplest_ecase c = general_case_analysis true None (c,NoBindings) (* Elimination tactic with bindings but using the default elimination * constant associated with the type. *) @@ -1325,7 +1494,7 @@ let default_elim with_evars clear_flag (c,_ as cx) = begin function (e, info) -> match e with | IsNonrec -> (* For records, induction principles aren't there by default - anymore. Instead, we do a case analysis instead. *) + anymore. Instead, we do a case analysis. *) general_case_analysis with_evars clear_flag cx | e -> Proofview.tclZERO ~info e end @@ -1378,7 +1547,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) try match List.remove Int.equal indmv (clenv_independent elimclause) with | [a] -> a | _ -> failwith "" - with Failure _ -> errorlabstrm "elimination_clause" + with Failure _ -> user_err ~hdr:"elimination_clause" (str "The type of elimination clause is not well-formed.") in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in let hyp = mkVar id in @@ -1387,7 +1556,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in if Term.eq_constr hyp_typ new_hyp_typ then - errorlabstrm "general_rewrite_in" + user_err ~hdr:"general_rewrite_in" (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id id sigma elimclause'' (fun id -> Proofview.tclUNIT ()) @@ -1412,7 +1581,7 @@ let make_projection env sigma params cstr sign elim i n c u = | NotADefinedRecordUseScheme elim -> (* bugs: goes from right to left when i increases! *) let decl = List.nth cstr.cs_args i in - let t = get_type decl in + let t = RelDecl.get_type decl in let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> b in let branch = it_mkLambda_or_LetIn b cstr.cs_args in if @@ -1502,9 +1671,7 @@ let solve_remaining_apply_goals = let concl = Proofview.Goal.concl gl in if Typeclasses.is_class_type evd concl then let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in - let tac = - (Proofview.V82.tactic (Tacmach.refine_no_check c')) - in + let tac = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c' h } in Sigma.Unsafe.of_pair (tac, evd') else Sigma.here (Proofview.tclUNIT ()) sigma with Not_found -> Sigma.here (Proofview.tclUNIT ()) sigma @@ -1540,7 +1707,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) if n<0 then error "Applied theorem has not enough premisses."; let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in Clenvtac.res_pf clause ~with_evars ~flags - with UserError _ as exn -> + with exn when catchable_exception exn -> Proofview.tclZERO exn in let rec try_red_apply thm_ty (exn0, info) = @@ -1563,7 +1730,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) (fun b id -> Tacticals.New.tclTHEN (try_main_apply b (mkVar id)) - (Proofview.V82.tactic (thin [id]))) + (clear [id])) (exn0, info) c else Proofview.tclZERO ~info exn0 in @@ -1662,8 +1829,8 @@ let apply_in_once_main flags innerclause env sigma (d,lbind) = let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in let rec aux clause = try progress_with_clause flags innerclause clause - with e when Errors.noncritical e -> - let e = Errors.push e in + with e when CErrors.noncritical e -> + let e = CErrors.push e in try aux (clenv_push_prod clause) with NotExtensibleClause -> iraise e in @@ -1690,11 +1857,11 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming (fun id -> Tacticals.New.tclTHENLIST [ apply_clear_request clear_flag false c; - Proofview.V82.tactic (thin idstoclear); + clear idstoclear; tac id ]) - with e when with_destruct && Errors.noncritical e -> - let (e, info) = Errors.push e in + with e when with_destruct && CErrors.noncritical e -> + let (e, info) = CErrors.push e in (descend_in_conjunctions [targetid] (fun b id -> aux (id::idstoclear) b (mkVar id)) (e, info) c) @@ -1758,7 +1925,7 @@ let cut_and_apply c = (* let refine_no_checkkey = Profile.declare_profile "refine_no_check";; *) (* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) -let new_exact_no_check c = +let exact_no_check c = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } let exact_check c = @@ -1770,28 +1937,32 @@ let exact_check c = let sigma = Sigma.to_evar_map sigma in let sigma, ct = Typing.type_of env sigma c in let tac = - Tacticals.New.tclTHEN (convert_leq ct concl) (new_exact_no_check c) + Tacticals.New.tclTHEN (convert_leq ct concl) (exact_no_check c) in Sigma.Unsafe.of_pair (tac, sigma) end } -let exact_no_check = Tacmach.refine_no_check - -let vm_cast_no_check c gl = - let concl = Tacmach.pf_concl gl in - Tacmach.refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl - -let native_cast_no_check c gl = - let concl = Tacmach.pf_concl gl in - Tacmach.refine_no_check (Term.mkCast(c,Term.NATIVEcast,concl)) gl +let cast_no_check cast c = + Proofview.Goal.enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in + exact_no_check (Term.mkCast (c, cast, concl)) + end } +let vm_cast_no_check c = cast_no_check Term.VMcast c +let native_cast_no_check c = cast_no_check Term.NATIVEcast c -let exact_proof c gl = - let c,ctx = Constrintern.interp_casted_constr (Tacmach.pf_env gl) (Tacmach.project gl) c (Tacmach.pf_concl gl) - in tclTHEN (tclEVARUNIVCONTEXT ctx) (Tacmach.refine_no_check c) gl +let exact_proof c = + let open Tacmach.New in + Proofview.Goal.nf_enter { enter = begin fun gl -> + Refine.refine { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in + let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (pf_concl gl) in + let sigma = Evd.merge_universe_context sigma ctx in + Sigma.Unsafe.of_pair (c, sigma) + end } + end } let assumption = - let open Context.Named.Declaration in let rec arec gl only_eq = function | [] -> if only_eq then @@ -1799,7 +1970,7 @@ let assumption = arec gl false hyps else Tacticals.New.tclZEROMSG (str "No such assumption.") | decl::rest -> - let t = get_type decl in + let t = NamedDecl.get_type decl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let (sigma, is_same_type) = @@ -1810,7 +1981,7 @@ let assumption = in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> - Refine.refine ~unsafe:true { run = fun h -> Sigma.here (mkVar (get_id decl)) h } + exact_no_check (mkVar (NamedDecl.get_id decl)) else arec gl only_eq rest in let assumption_tac = { enter = begin fun gl -> @@ -1823,14 +1994,6 @@ let assumption = (* Modification of a local context *) (*****************************************************************) -(* This tactic enables the user to remove hypotheses from the signature. - * Some care is taken to prevent him from removing variables that are - * subsequently used in other hypotheses or in the conclusion of the - * goal. *) - -let clear ids = (* avant seul dyn_clear n'echouait pas en [] *) - if List.is_empty ids then tclIDTAC else thin ids - let on_the_bodies = function | [] -> assert false | [id] -> str " depends on the body of " ++ pr_id id @@ -1843,12 +2006,12 @@ let check_is_type env sigma ty = try let _ = Typing.e_sort_of env evdref ty in !evdref - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> raise (DependsOnBody None) let check_decl env sigma decl = let open Context.Named.Declaration in - let ty = get_type decl in + let ty = NamedDecl.get_type decl in let evdref = ref sigma in try let _ = Typing.e_sort_of env evdref ty in @@ -1857,8 +2020,8 @@ let check_decl env sigma decl = | LocalDef (_,c,_) -> Typing.e_check env evdref c ty in !evdref - with e when Errors.noncritical e -> - let id = get_id decl in + with e when CErrors.noncritical e -> + let id = NamedDecl.get_id decl in raise (DependsOnBody (Some id)) let clear_body ids = @@ -1871,7 +2034,7 @@ let clear_body ids = let map = function | LocalAssum (id,t) as decl -> let () = if List.mem_f Id.equal id ids then - errorlabstrm "" (str "Hypothesis " ++ pr_id id ++ str " is not a local definition") + user_err (str "Hypothesis " ++ pr_id id ++ str " is not a local definition") in decl | LocalDef (id,_,t) as decl -> @@ -1882,16 +2045,18 @@ let clear_body ids = let env = push_named_context ctx base_env in let check = try - let check (env, sigma) decl = + let check (env, sigma, seen) decl = (** Do no recheck hypotheses that do not depend *) let sigma = - if List.exists (fun id -> occur_var_in_decl env id decl) ids then + if not seen then sigma + else if List.exists (fun id -> occur_var_in_decl env id decl) ids then check_decl env sigma decl else sigma in - (push_named decl env, sigma) + let seen = seen || List.mem_f Id.equal (NamedDecl.get_id decl) ids in + (push_named decl env, sigma, seen) in - let (env, sigma) = List.fold_left check (base_env, sigma) (List.rev ctx) in + let (env, sigma, _) = List.fold_left check (base_env, sigma, false) (List.rev ctx) in let sigma = if List.exists (fun id -> occur_var env id concl) ids then check_is_type env sigma concl @@ -1912,13 +2077,7 @@ let clear_body ids = end } let clear_wildcards ids = - Proofview.V82.tactic (tclMAP (fun (loc,id) gl -> - try with_check (Tacmach.thin_no_check [id]) gl - with ClearDependencyError (id,err) -> - (* Intercept standard [thin] error message *) - Loc.raise loc - (error_clear_dependency (pf_env gl) (project gl) (Id.of_string "_") err)) - ids) + Tacticals.New.tclMAP (fun (loc, id) -> clear [id]) ids (* Takes a list of booleans, and introduces all the variables * quantified in the goal which are associated with a value @@ -1929,18 +2088,17 @@ let rec intros_clearing = function | (false::tl) -> Tacticals.New.tclTHEN intro (intros_clearing tl) | (true::tl) -> Tacticals.New.tclTHENLIST - [ intro; Tacticals.New.onLastHypId (fun id -> Proofview.V82.tactic (clear [id])); intros_clearing tl] + [ intro; Tacticals.New.onLastHypId (fun id -> clear [id]); intros_clearing tl] (* Keeping only a few hypotheses *) let keep hyps = - let open Context.Named.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> Proofview.tclENV >>= fun env -> let ccl = Proofview.Goal.concl gl in let cl,_ = fold_named_context_reverse (fun (clear,keep) decl -> - let hyp = get_id decl in + let hyp = NamedDecl.get_id decl in if Id.List.mem hyp hyps || List.exists (occur_var_in_decl env hyp) keep || occur_var env hyp ccl @@ -1948,7 +2106,7 @@ let keep hyps = else (hyp::clear,keep)) ~init:([],[]) (Proofview.Goal.env gl) in - Proofview.V82.tactic (fun gl -> thin cl gl) + clear cl end } (*********************************) @@ -1995,7 +2153,7 @@ let revert hyps = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in - (bring_hyps ctx) <*> (Proofview.V82.tactic (clear hyps)) + (bring_hyps ctx) <*> (clear hyps) end } (************************) @@ -2006,7 +2164,7 @@ let check_number_of_constructors expctdnumopt i nconstr = if Int.equal i 0 then error "The constructors are numbered starting from 1."; begin match expctdnumopt with | Some n when not (Int.equal n nconstr) -> - errorlabstrm "Tactics.check_number_of_constructors" + user_err ~hdr:"Tactics.check_number_of_constructors" (str "Not an inductive goal with " ++ int n ++ str (String.plural n " constructor") ++ str ".") | _ -> () end; @@ -2095,7 +2253,7 @@ let error_unexpected_extra_pattern loc bound pat = | IntroNaming (IntroIdentifier _) -> "name", (String.plural nb " introduction pattern"), "no" | _ -> "introduction pattern", "", "none" in - user_err_loc (loc,"",str "Unexpected " ++ str s1 ++ str " (" ++ + user_err ~loc (str "Unexpected " ++ str s1 ++ str " (" ++ (if Int.equal nb 0 then (str s3 ++ str s2) else (str "at most " ++ int nb ++ str s2)) ++ spc () ++ str (if Int.equal nb 1 then "was" else "were") ++ @@ -2127,7 +2285,7 @@ let intro_decomp_eq loc l thin tac id = Tacticals.New.tclZEROMSG (str "Not a primitive equality here.") end } -let intro_or_and_pattern loc bracketed ll thin tac id = +let intro_or_and_pattern loc with_evars bracketed ll thin tac id = Proofview.Goal.enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in @@ -2137,14 +2295,14 @@ let intro_or_and_pattern loc bracketed ll thin tac id = let ll = fix_empty_or_and_pattern (Array.length branchsigns) ll in let ll = get_and_check_or_and_pattern loc ll branchsigns in Tacticals.New.tclTHENLASTn - (Tacticals.New.tclTHEN (simplest_case c) (Proofview.V82.tactic (clear [id]))) + (Tacticals.New.tclTHEN (simplest_ecase c) (clear [id])) (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l) nv_with_let ll) end } -let rewrite_hyp_then assert_style thin l2r id tac = +let rewrite_hyp_then assert_style with_evars thin l2r id tac = let rew_on l2r = - Hook.get forward_general_rewrite_clause l2r false (mkVar id,NoBindings) in + Hook.get forward_general_rewrite_clause l2r with_evars (mkVar id,NoBindings) in let subst_on l2r x rhs = Hook.get forward_subst_one true x (id,rhs,l2r) in let clear_var_and_eq id' = clear [id';id] in @@ -2153,8 +2311,8 @@ let rewrite_hyp_then assert_style thin l2r id tac = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in - let whd_betadeltaiota = Tacmach.New.pf_apply whd_betadeltaiota gl in - let t = whd_betadeltaiota (type_of (mkVar id)) in + let whd_all = Tacmach.New.pf_apply whd_all gl in + let t = whd_all (type_of (mkVar id)) in let eqtac, thin = match match_with_equality_type t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r && isVar lhs && not (occur_var env (destVar lhs) rhs) then @@ -2164,20 +2322,20 @@ let rewrite_hyp_then assert_style thin l2r id tac = let id' = destVar rhs in subst_on l2r id' lhs, early_clear id' thin else - Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])), + Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), thin | Some (hdcncl,[c]) -> let l2r = not l2r in (* equality of the form eq_true *) if isVar c then let id' = destVar c in Tacticals.New.tclTHEN (rew_on l2r allHypsAndConcl) - (Proofview.V82.tactic (clear_var_and_eq id')), + (clear_var_and_eq id'), early_clear id' thin else - Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])), + Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), thin | _ -> - Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])), + Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), thin in (* Skip the side conditions of the rewriting step *) Tacticals.New.tclTHENFIRST eqtac (tac thin) @@ -2255,12 +2413,13 @@ let exceed_bound n = function [patl]: introduction patterns to interpret *) -let rec intro_patterns_core b avoid ids thin destopt bound n tac = function +let rec intro_patterns_core with_evars b avoid ids thin destopt bound n tac = + function | [] when fit_bound n bound -> tac ids thin | [] -> (* Behave as IntroAnonymous *) - intro_patterns_core b avoid ids thin destopt bound n tac + intro_patterns_core with_evars b avoid ids thin destopt bound n tac [dloc,IntroNaming IntroAnonymous] | (loc,pat) :: l -> if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else @@ -2268,98 +2427,100 @@ let rec intro_patterns_core b avoid ids thin destopt bound n tac = function | IntroForthcoming onlydeps -> intro_forthcoming_then_gen (NamingAvoid (avoid@explicit_intro_names l)) destopt onlydeps n bound - (fun ids -> intro_patterns_core b avoid ids thin destopt bound + (fun ids -> intro_patterns_core with_evars b avoid ids thin destopt bound (n+List.length ids) tac l) | IntroAction pat -> intro_then_gen (make_tmp_naming avoid l pat) destopt true false - (intro_pattern_action loc (b || not (List.is_empty l)) false pat thin - destopt - (fun thin bound' -> intro_patterns_core b avoid ids thin destopt bound' 0 + (intro_pattern_action loc with_evars (b || not (List.is_empty l)) false + pat thin destopt + (fun thin bound' -> intro_patterns_core with_evars b avoid ids thin destopt bound' 0 (fun ids thin -> - intro_patterns_core b avoid ids thin destopt bound (n+1) tac l))) + intro_patterns_core with_evars b avoid ids thin destopt bound (n+1) tac l))) | IntroNaming pat -> - intro_pattern_naming loc b avoid ids pat thin destopt bound (n+1) tac l + intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound (n+1) tac l (* Pi-introduction rule, used backwards *) -and intro_pattern_naming loc b avoid ids pat thin destopt bound n tac l = +and intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound n tac l = match pat with | IntroIdentifier id -> check_thin_clash_then id thin avoid (fun thin -> intro_then_gen (NamingMustBe (loc,id)) destopt true false - (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound n tac l)) + (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l)) | IntroAnonymous -> intro_then_gen (NamingAvoid (avoid@explicit_intro_names l)) destopt true false - (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound n tac l) + (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) | IntroFresh id -> (* todo: avoid thinned names to interfere with generation of fresh name *) intro_then_gen (NamingBasedOn (id, avoid@explicit_intro_names l)) destopt true false - (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound n tac l) + (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) -and intro_pattern_action loc b style pat thin destopt tac id = match pat with +and intro_pattern_action loc with_evars b style pat thin destopt tac id = + match pat with | IntroWildcard -> tac ((loc,id)::thin) None [] | IntroOrAndPattern ll -> - intro_or_and_pattern loc b ll thin tac id + intro_or_and_pattern loc with_evars b ll thin tac id | IntroInjection l' -> intro_decomp_eq loc l' thin tac id | IntroRewrite l2r -> - rewrite_hyp_then style thin l2r id (fun thin -> tac thin None []) + rewrite_hyp_then style with_evars thin l2r id (fun thin -> tac thin None []) | IntroApplyOn (f,(loc,pat)) -> let naming,tac_ipat = - prepare_intros_loc loc (IntroIdentifier id) destopt pat in + prepare_intros_loc loc with_evars (IntroIdentifier id) destopt pat in let doclear = if naming = NamingMustBe (loc,id) then Proofview.tclUNIT () (* apply_in_once do a replacement *) else - Proofview.V82.tactic (clear [id]) in + clear [id] in let f = { delayed = fun env sigma -> let Sigma (c, sigma, p) = f.delayed env sigma in Sigma ((c, NoBindings), sigma, p) } in - apply_in_delayed_once false true true true naming id (None,(loc,f)) + apply_in_delayed_once false true true with_evars naming id (None,(loc,f)) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) -and prepare_intros_loc loc dft destopt = function +and prepare_intros_loc loc with_evars dft destopt = function | IntroNaming ipat -> prepare_naming loc ipat, - (fun id -> Proofview.V82.tactic (move_hyp id destopt)) + (fun id -> move_hyp id destopt) | IntroAction ipat -> prepare_naming loc dft, (let tac thin bound = - intro_patterns_core true [] [] thin destopt bound 0 + intro_patterns_core with_evars true [] [] thin destopt bound 0 (fun _ l -> clear_wildcards l) in - fun id -> intro_pattern_action loc true true ipat [] destopt tac id) - | IntroForthcoming _ -> user_err_loc - (loc,"",str "Introduction pattern for one hypothesis expected.") + fun id -> + intro_pattern_action loc with_evars true true ipat [] destopt tac id) + | IntroForthcoming _ -> user_err ~loc + (str "Introduction pattern for one hypothesis expected.") -let intro_patterns_bound_to n destopt = - intro_patterns_core true [] [] [] destopt +let intro_patterns_bound_to with_evars n destopt = + intro_patterns_core with_evars true [] [] [] destopt (Some (true,n)) 0 (fun _ l -> clear_wildcards l) -let intro_patterns_to destopt = - intro_patterns_core (use_bracketing_last_or_and_intro_pattern ()) +let intro_patterns_to with_evars destopt = + intro_patterns_core with_evars (use_bracketing_last_or_and_intro_pattern ()) [] [] [] destopt None 0 (fun _ l -> clear_wildcards l) -let intro_pattern_to destopt pat = - intro_patterns_to destopt [dloc,pat] +let intro_pattern_to with_evars destopt pat = + intro_patterns_to with_evars destopt [dloc,pat] -let intro_patterns = intro_patterns_to MoveLast +let intro_patterns with_evars = intro_patterns_to with_evars MoveLast (* Implements "intros" *) -let intros_patterns = function +let intros_patterns with_evars = function | [] -> intros - | l -> intro_patterns_to MoveLast l + | l -> intro_patterns_to with_evars MoveLast l (**************************) (* Forward reasoning *) (**************************) -let prepare_intros dft destopt = function +let prepare_intros with_evars dft destopt = function | None -> prepare_naming dloc dft, (fun _id -> Proofview.tclUNIT ()) - | Some (loc,ipat) -> prepare_intros_loc loc dft destopt ipat + | Some (loc,ipat) -> prepare_intros_loc loc with_evars dft destopt ipat let ipat_of_name = function | Anonymous -> None @@ -2370,7 +2531,7 @@ let head_ident c = if isVar c then Some (destVar c) else None let assert_as first hd ipat t = - let naming,tac = prepare_intros IntroAnonymous MoveLast ipat in + let naming,tac = prepare_intros false IntroAnonymous MoveLast ipat in let repl = do_replace hd naming in let tac = if repl then (fun id -> Proofview.tclUNIT ()) else tac in if first then assert_before_then_gen repl naming t tac @@ -2387,7 +2548,8 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars let destopt = if with_evars then MoveLast (* evars would depend on the whole context *) else get_previous_hyp_position id gl in - let naming,ipat_tac = prepare_intros (IntroIdentifier id) destopt ipat in + let naming,ipat_tac = + prepare_intros with_evars (IntroIdentifier id) destopt ipat in let lemmas_target, last_lemma_target = let last,first = List.sep_last lemmas in List.map (fun lem -> (NamingMustBe (dloc,id),lem)) first, (naming,last) @@ -2418,13 +2580,6 @@ let apply_delayed_in simple with_evars id lemmas ipat = (* Implementation without generalisation: abbrev will be lost in hyps in *) (* in the extracted proof *) -let tactic_infer_flags with_evar = { - Pretyping.use_typeclasses = true; - Pretyping.use_unif_heuristics = true; - Pretyping.use_hook = Some solve_by_implicit_tactic; - Pretyping.fail_evar = not with_evar; - Pretyping.expand_evars = true } - let decode_hyp = function | None -> MoveLast | Some id -> MoveAfter id @@ -2481,13 +2636,12 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = end } let insert_before decls lasthyp env = - let open Context.Named.Declaration in match lasthyp with | None -> push_named_context decls env | Some id -> Environ.fold_named_context (fun _ d env -> - let env = if Id.equal id (get_id d) then push_named_context decls env else env in + let env = if Id.equal id (NamedDecl.get_id d) then push_named_context decls env else env in push_named d env) ~init:(reset_context env) env @@ -2506,7 +2660,7 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = | IntroFresh heq_base -> fresh_id_in_env [id] heq_base env | IntroIdentifier id -> if List.mem id (ids_of_named_context (named_context env)) then - user_err_loc (loc,"",pr_id id ++ str" is already used."); + user_err ~loc (pr_id id ++ str" is already used."); id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in @@ -2528,10 +2682,15 @@ let letin_tac with_eq id c ty occs = let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let abs = AbstractExact (id,c,ty,occs,true) in - let (id,_,depdecls,lastlhyp,ccl,_) = make_abstraction env sigma ccl abs in - (* We keep the original term to match *) + let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in + (* We keep the original term to match but record the potential side-effects + of unifying universes. *) + let Sigma (c, sigma, p) = match res with + | None -> Sigma.here c sigma + | Some (Sigma (_, sigma, p)) -> Sigma (c, sigma, p) + in let tac = letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty in - Sigma.here tac sigma + Sigma (tac, sigma, p) end } let letin_pat_tac with_eq id c occs = @@ -2556,12 +2715,14 @@ let forward b usetac ipat c = match usetac with | None -> Proofview.Goal.enter { enter = begin fun gl -> - let t = Tacmach.New.pf_unsafe_type_of gl c in + let t = Tacmach.New.pf_get_type_of gl c in let hd = head_ident c in - Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) - (Proofview.V82.tactic (exact_no_check c)) + Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) (exact_no_check c) end } | Some tac -> + let tac = match tac with + | None -> Tacticals.New.tclIDTAC + | Some tac -> Tacticals.New.tclCOMPLETE tac in if b then Tacticals.New.tclTHENFIRST (assert_as b None ipat c) tac else @@ -2569,8 +2730,8 @@ let forward b usetac ipat c = (assert_as b None ipat c) [||] tac [|Tacticals.New.tclIDTAC|] let pose_proof na c = forward true None (ipat_of_name na) c -let assert_by na t tac = forward true (Some tac) (ipat_of_name na) t -let enough_by na t tac = forward false (Some tac) (ipat_of_name na) t +let assert_by na t tac = forward true (Some (Some tac)) (ipat_of_name na) t +let enough_by na t tac = forward false (Some (Some tac)) (ipat_of_name na) t (***************************) (* Generalization tactics *) @@ -2581,7 +2742,7 @@ let enough_by na t tac = forward false (Some tac) (ipat_of_name na) t let generalized_name c t ids cl = function | Name id as na -> if Id.List.mem id ids then - errorlabstrm "" (pr_id id ++ str " is already used."); + user_err (pr_id id ++ str " is already used."); na | Anonymous -> match kind_of_term c with @@ -2618,24 +2779,23 @@ let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = let sigma, t = Typing.type_of env sigma c in generalize_goal_gen env sigma ids i o t cl -let generalize_dep ?(with_let=false) c gl = - let open Context.Named.Declaration in +let old_generalize_dep ?(with_let=false) c gl = let env = pf_env gl in let sign = pf_hyps gl in let init_ids = ids_of_named_context (Global.named_context()) in let seek (d:Context.Named.Declaration.t) (toquant:Context.Named.t) = - if List.exists (fun d' -> occur_var_in_decl env (get_id d') d) toquant + if List.exists (fun d' -> occur_var_in_decl env (NamedDecl.get_id d') d) toquant || dependent_in_decl c d then d::toquant else toquant in let to_quantify = Context.Named.fold_outside seek sign ~init:[] in let to_quantify_rev = List.rev to_quantify in - let qhyps = List.map get_id to_quantify_rev in + let qhyps = List.map NamedDecl.get_id to_quantify_rev in let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in let tothin' = match kind_of_term c with - | Var id when mem_named_context id sign && not (Id.List.mem id init_ids) + | Var id when mem_named_context_val id (val_of_named_context sign) && not (Id.List.mem id init_ids) -> id::tothin | _ -> tothin in @@ -2643,28 +2803,36 @@ let generalize_dep ?(with_let=false) c gl = let body = if with_let then match kind_of_term c with - | Var id -> Tacmach.pf_get_hyp gl id |> get_value + | Var id -> id |> Tacmach.pf_get_hyp gl |> NamedDecl.get_value | _ -> None else None in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in + (** Check that the generalization is indeed well-typed *) + let (evd, _) = Typing.type_of env evd cl'' in let args = Context.Named.to_instance to_quantify_rev in tclTHENLIST [tclEVARS evd; Proofview.V82.of_tactic (apply_type cl'' (if Option.is_empty body then c::args else args)); - thin (List.rev tothin')] + Proofview.V82.of_tactic (clear (List.rev tothin'))] gl +let generalize_dep ?(with_let = false) c = + Proofview.V82.tactic (old_generalize_dep ~with_let c) + (** *) -let generalize_gen_let lconstr gl = +let generalize_gen_let lconstr = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in let newcl, evd = - List.fold_right_i (generalize_goal gl) 0 lconstr - (Tacmach.pf_concl gl,Tacmach.project gl) + List.fold_right_i (Tacmach.New.of_old generalize_goal gl) 0 lconstr + (Tacmach.New.pf_concl gl,Tacmach.New.project gl) in - Proofview.V82.of_tactic (Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) - (apply_type newcl (List.map_filter (fun ((_,c,b),_) -> - if Option.is_empty b then Some c else None) lconstr))) gl + let (evd, _) = Typing.type_of env evd newcl in + let map ((_, c, b),_) = if Option.is_empty b then Some c else None in + let tac = apply_type newcl (List.map_filter map lconstr) in + Sigma.Unsafe.of_pair (tac, evd) +end } let new_generalize_gen_let lconstr = Proofview.Goal.s_enter { s_enter = begin fun gl -> @@ -2700,11 +2868,8 @@ let generalize_gen lconstr = let new_generalize_gen lconstr = new_generalize_gen_let (List.map (fun ((occs,c),na) -> (occs,c,None),na) lconstr) - -let generalize l = - generalize_gen_let (List.map (fun c -> ((AllOccurrences,c,None),Anonymous)) l) -let new_generalize l = +let generalize l = new_generalize_gen_let (List.map (fun c -> ((AllOccurrences,c,None),Anonymous)) l) (* Faudra-t-il une version avec plusieurs args de generalize_dep ? @@ -2721,7 +2886,7 @@ let quantify lconstr = (* Modifying/Adding an hypothesis *) -let specialize (c,lbind) = +let specialize (c,lbind) ipat = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in @@ -2741,25 +2906,37 @@ let specialize (c,lbind) = let tstack = chk tstack in let term = applist(thd,List.map (nf_evar clause.evd) tstack) in if occur_meta term then - errorlabstrm "" (str "Cannot infer an instance for " ++ + user_err (str "Cannot infer an instance for " ++ + pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ str "."); clause.evd, term in let typ = Retyping.get_type_of env sigma term in - match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with - | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> - Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS sigma) - (Tacticals.New.tclTHENFIRST - (assert_before_replacing id typ) - (new_exact_no_check term)) - | _ -> - (* To deprecate in favor of generalize? *) - Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS sigma) - (Tacticals.New.tclTHENLAST - (cut typ) - (new_exact_no_check term)) + let tac = + match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with + | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> + (* Like assert (id:=id args) but with the concept of specialization *) + let naming,tac = + prepare_intros false (IntroIdentifier id) MoveLast ipat in + let repl = do_replace (Some id) naming in + Tacticals.New.tclTHENFIRST + (assert_before_then_gen repl naming typ tac) + (exact_no_check term) + | _ -> + match ipat with + | None -> + (* Like generalize with extra support for "with" bindings *) + (* even though the "with" bindings forces full application *) + Tacticals.New.tclTHENLAST (cut typ) (exact_no_check term) + | Some (loc,ipat) -> + (* Like pose proof with extra support for "with" bindings *) + (* even though the "with" bindings forces full application *) + let naming,tac = prepare_intros_loc loc false IntroAnonymous MoveLast ipat in + Tacticals.New.tclTHENFIRST + (assert_before_then_gen false naming typ tac) + (exact_no_check term) + in + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac end } (*****************************) @@ -2772,16 +2949,15 @@ let unfold_body x = let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> (** We normalize the given hypothesis immediately. *) - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let xval = match Context.Named.lookup x hyps with - | LocalAssum _ -> errorlabstrm "unfold_body" + let env = Proofview.Goal.env (Proofview.Goal.assume gl) in + let xval = match Environ.lookup_named x env with + | LocalAssum _ -> user_err ~hdr:"unfold_body" (pr_id x ++ str" is not a defined hypothesis.") - | LocalDef (_,xval,_) -> pf_nf_evar gl xval + | LocalDef (_,xval,_) -> xval in Tacticals.New.afterHyp x begin fun aft -> - let hl = List.fold_right (fun decl cl -> (get_id decl, InHyp) :: cl) aft [] in - let xvar = mkVar x in - let rfun _ _ c = replace_term xvar xval c in + let hl = List.fold_right (fun decl cl -> (NamedDecl.get_id decl, InHyp) :: cl) aft [] in + let rfun _ _ c = replace_vars [x, xval] c in let reducth h = reduct_in_hyp rfun h in let reductc = reduct_in_concl (rfun, DEFAULTcast) in Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] @@ -2789,7 +2965,7 @@ let unfold_body x = end } (* Either unfold and clear if defined or simply clear if not a definition *) -let expand_hyp id = Tacticals.New.tclTHEN (Tacticals.New.tclTRY (unfold_body id)) (Proofview.V82.tactic (clear [id])) +let expand_hyp id = Tacticals.New.tclTRY (unfold_body id) <*> clear [id] (*****************************) (* High-level induction *) @@ -2825,13 +3001,17 @@ let expand_hyp id = Tacticals.New.tclTHEN (Tacticals.New.tclTRY (unfold_body id) *) +let warn_unused_intro_pattern = + CWarnings.create ~name:"unused-intro-pattern" ~category:"tactics" + (fun names -> + strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern") + ++ str": " ++ prlist_with_sep spc + (Miscprint.pr_intro_pattern + (fun c -> Printer.pr_constr (fst (run_delayed (Global.env()) Evd.empty c)))) names) + let check_unused_names names = if not (List.is_empty names) && Flags.is_verbose () then - msg_warning - (str"Unused introduction " ++ str (String.plural (List.length names) "pattern") - ++ str": " ++ prlist_with_sep spc - (Miscprint.pr_intro_pattern - (fun c -> Printer.pr_constr (fst (run_delayed (Global.env()) Evd.empty c)))) names) + warn_unused_intro_pattern names let intropattern_of_name gl avoid = function | Anonymous -> IntroNaming IntroAnonymous @@ -2861,19 +3041,19 @@ let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) = (intros_move rstatus) (intros_move newlstatus) -let dest_intro_patterns avoid thin dest pat tac = - intro_patterns_core true avoid [] thin dest None 0 tac pat +let dest_intro_patterns with_evars avoid thin dest pat tac = + intro_patterns_core with_evars true avoid [] thin dest None 0 tac pat -let safe_dest_intro_patterns avoid thin dest pat tac = +let safe_dest_intro_patterns with_evars avoid thin dest pat tac = Proofview.tclORELSE - (dest_intro_patterns avoid thin dest pat tac) + (dest_intro_patterns with_evars avoid thin dest pat tac) begin function (e, info) -> match e with - | UserError ("move_hyp",_) -> + | UserError (Some "move_hyp",_) -> (* May happen e.g. with "destruct x using s" with an hypothesis which is morally an induction hypothesis to be "MoveLast" if known as such but which is considered instead as a subterm of a constructor to be move at the place of x. *) - dest_intro_patterns avoid thin MoveLast pat tac + dest_intro_patterns with_evars avoid thin MoveLast pat tac | e -> Proofview.tclZERO ~info e end @@ -2905,7 +3085,7 @@ let get_recarg_dest (recargdests,tophyp) = had to be introduced at the top of the context). *) -let induct_discharge dests avoid' tac (avoid,ra) names = +let induct_discharge with_evars dests avoid' tac (avoid,ra) names = let avoid = avoid @ avoid' in let rec peel_tac ra dests names thin = match ra with @@ -2918,12 +3098,12 @@ let induct_discharge dests avoid' tac (avoid,ra) names = (pat, [dloc, IntroNaming (IntroIdentifier id')]) | _ -> consume_pattern avoid (Name recvarname) deprec gl names in let dest = get_recarg_dest dests in - dest_intro_patterns avoid thin dest [recpat] (fun ids thin -> + dest_intro_patterns with_evars avoid thin dest [recpat] (fun ids thin -> Proofview.Goal.enter { enter = begin fun gl -> let (hyprec,names) = consume_pattern avoid (Name hyprecname) depind gl names in - dest_intro_patterns avoid thin MoveLast [hyprec] (fun ids' thin -> + dest_intro_patterns with_evars avoid thin MoveLast [hyprec] (fun ids' thin -> peel_tac ra' (update_dest dests ids') names thin) end }) end } @@ -2932,7 +3112,7 @@ let induct_discharge dests avoid' tac (avoid,ra) names = (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = consume_pattern avoid (Name hyprecname) dep gl names in - dest_intro_patterns avoid thin MoveLast [pat] (fun ids thin -> + dest_intro_patterns with_evars avoid thin MoveLast [pat] (fun ids thin -> peel_tac ra' (update_dest dests ids) names thin) end } | (RecArg,_,dep,recvarname) :: ra' -> @@ -2940,14 +3120,14 @@ let induct_discharge dests avoid' tac (avoid,ra) names = let (pat,names) = consume_pattern avoid (Name recvarname) dep gl names in let dest = get_recarg_dest dests in - dest_intro_patterns avoid thin dest [pat] (fun ids thin -> + dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) end } | (OtherArg,_,dep,_) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (pat,names) = consume_pattern avoid Anonymous dep gl names in let dest = get_recarg_dest dests in - safe_dest_intro_patterns avoid thin dest [pat] (fun ids thin -> + safe_dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) end } | [] -> @@ -3095,7 +3275,6 @@ exception Shunt of Id.t move_location let cook_sign hyp0_opt inhyps indvars env = (* First phase from L to R: get [toclear], [decldep] and [statuslist] for the hypotheses before (= more ancient than) hyp0 (see above) *) - let open Context.Named.Declaration in let toclear = ref [] in let avoid = ref [] in let decldeps = ref [] in @@ -3105,7 +3284,7 @@ let cook_sign hyp0_opt inhyps indvars env = let before = ref true in let maindep = ref false in let seek_deps env decl rhyp = - let hyp = get_id decl in + let hyp = NamedDecl.get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then begin before:=false; @@ -3124,7 +3303,7 @@ let cook_sign hyp0_opt inhyps indvars env = in let depother = List.is_empty inhyps && (List.exists (fun id -> occur_var_in_decl env id decl) indvars || - List.exists (fun decl' -> occur_var_in_decl env (get_id decl') decl) !decldeps) + List.exists (fun decl' -> occur_var_in_decl env (NamedDecl.get_id decl') decl) !decldeps) in if not (List.is_empty inhyps) && Id.List.mem hyp inhyps || dephyp0 || depother @@ -3147,7 +3326,7 @@ let cook_sign hyp0_opt inhyps indvars env = let _ = fold_named_context seek_deps env ~init:MoveFirst in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) let compute_lstatus lhyp decl = - let hyp = get_id decl in + let hyp = NamedDecl.get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then raise (Shunt lhyp); if Id.List.mem hyp !ldeps then begin @@ -3268,7 +3447,7 @@ let make_up_names n ind_opt cname = let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in - errorlabstrm "Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") + user_err ~hdr:"Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") let glob = Universes.constr_of_global @@ -3315,8 +3494,8 @@ let ids_of_constr ?(all=false) vars c = Array.fold_left_from (if all then 0 else mib.Declarations.mind_nparams) aux vars args - | _ -> fold_constr aux vars c) - | _ -> fold_constr aux vars c + | _ -> Term.fold_constr aux vars c) + | _ -> Term.fold_constr aux vars c in aux vars c let decompose_indapp f args = @@ -3371,13 +3550,12 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = end } let hyps_of_vars env sign nogen hyps = - let open Context.Named.Declaration in if Id.Set.is_empty hyps then [] else let (_,lh) = Context.Named.fold_inside (fun (hs,hl) d -> - let x = get_id d in + let x = NamedDecl.get_id d in if Id.Set.mem x nogen then (hs,hl) else if Id.Set.mem x hs then (hs,x::hl) else @@ -3407,8 +3585,7 @@ let linear vars args = with Seen -> false let is_defined_variable env id = - let open Context.Named.Declaration in - lookup_named id env |> is_local_def + env |> lookup_named id |> is_local_def let abstract_args gl generalize_vars dep id defined f args = let open Context.Rel.Declaration in @@ -3431,7 +3608,7 @@ let abstract_args gl generalize_vars dep id defined f args = let name, ty, arity = let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in let decl = List.hd rel in - get_name decl, get_type decl, c + RelDecl.get_name decl, RelDecl.get_type decl, c in let argty = Tacmach.pf_unsafe_type_of gl arg in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in @@ -3520,18 +3697,18 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = Tacticals.New.tclTHENLIST [ tac; rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro; - Proofview.V82.tactic (generalize_dep ~with_let:true (mkVar oldid))] + generalize_dep ~with_let:true (mkVar oldid)] else Tacticals.New.tclTHENLIST [ tac; - Proofview.V82.tactic (clear [id]); + clear [id]; Tacticals.New.tclDO n intro] in if List.is_empty vars then tac else Tacticals.New.tclTHEN tac (Tacticals.New.tclFIRST [revert vars ; - Proofview.V82.tactic (fun gl -> tclMAP (fun id -> - tclTRY (generalize_dep ~with_let:true (mkVar id))) vars gl)]) + Tacticals.New.tclMAP (fun id -> + Tacticals.New.tclTRY (generalize_dep ~with_let:true (mkVar id))) vars]) end } let rec compare_upto_variables x y = @@ -3584,17 +3761,16 @@ let specialize_eqs id gl = let ty' = Evarutil.nf_evar !evars ty' in if worked then tclTHENFIRST (Tacmach.internal_cut true id ty') - (exact_no_check ((* refresh_universes_strict *) acc')) gl + (Proofview.V82.of_tactic (exact_no_check ((* refresh_universes_strict *) acc'))) gl else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl -let specialize_eqs id gl = - if - (try ignore(clear [id] gl); false - with e when Errors.noncritical e -> true) - then - tclFAIL 0 (str "Specialization not allowed on dependent hypotheses") gl - else specialize_eqs id gl +let specialize_eqs id = Proofview.Goal.nf_enter { enter = begin fun gl -> + let msg = str "Specialization not allowed on dependent hypotheses" in + Proofview.tclOR (clear [id]) + (fun _ -> Tacticals.New.tclZEROMSG msg) >>= fun () -> + Proofview.V82.tactic (specialize_eqs id) +end } let occur_rel n c = let res = not (noccurn n c) in @@ -3726,7 +3902,7 @@ let compute_elim_sig ?elimc elimt = | Some (LocalAssum (_,ind)) -> let indhd,indargs = decompose_app ind in try {!res with indref = Some (global_of_constr indhd) } - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> error "Cannot find the inductive type of the inductive scheme." let compute_scheme_signature scheme names_info ind_type_guess = @@ -3867,14 +4043,15 @@ let is_functional_induction elimc gl = need a dependent one or not *) let get_eliminator elim dep s gl = - let open Context.Rel.Declaration in match elim with | ElimUsing (elim,indsign) -> Tacmach.New.project gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in - let branchlengthes = List.map (fun d -> assert (is_local_assum d); pi1 (decompose_prod_letin (get_type d))) (List.rev s.branches) in + let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (RelDecl.get_type d))) + (List.rev s.branches) + in evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l (* Instantiate all meta variables of elimclause using lid, some elts @@ -3887,16 +4064,16 @@ let recolle_clenv i params args elimclause gl = (fun x -> match kind_of_term x with | Meta mv -> mv - | _ -> errorlabstrm "elimination_clause" + | _ -> user_err ~hdr:"elimination_clause" (str "The type of the elimination clause is not well-formed.")) arr in let k = match i with -1 -> Array.length lindmv - List.length args | _ -> i in (* parameters correspond to first elts of lid. *) let clauses_params = - List.map_i (fun i id -> mkVar id , Tacmach.pf_get_hyp_typ gl id , lindmv.(i)) + List.map_i (fun i id -> mkVar id , pf_get_hyp_typ id gl, lindmv.(i)) 0 params in let clauses_args = - List.map_i (fun i id -> mkVar id , Tacmach.pf_get_hyp_typ gl id , lindmv.(k+i)) + List.map_i (fun i id -> mkVar id , pf_get_hyp_typ id gl, lindmv.(k+i)) 0 args in let clauses = clauses_params@clauses_args in (* iteration of clenv_fchain with all infos we have. *) @@ -3906,7 +4083,7 @@ let recolle_clenv i params args elimclause gl = (* from_n (Some 0) means that x should be taken "as is" without trying to unify (which would lead to trying to apply it to evars if y is a product). *) - let indclause = mk_clenv_from_n gl (Some 0) (x,y) in + let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from_n gl (Some 0) (x,y)) gl in let elimclause' = clenv_fchain ~with_univs:false i acc indclause in elimclause') (List.rev clauses) @@ -3916,26 +4093,26 @@ let recolle_clenv i params args elimclause gl = (elimc ?i ?j ?k...?l). This solves partly meta variables (and may produce new ones). Then refine with the resulting term with holes. *) -let induction_tac with_evars params indvars elim gl = +let induction_tac with_evars params indvars elim = + Proofview.Goal.nf_enter { enter = begin fun gl -> let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in let i = match i with None -> index_of_ind_arg elimt | Some i -> i in (* elimclause contains this: (elimc ?i ?j ?k...?l) *) let elimc = contract_letin_in_lam_header elimc in let elimc = mkCast (elimc, DEFAULTcast, elimt) in - let elimclause = - Tacmach.pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in + let elimclause = pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in (* elimclause' is built from elimclause by instanciating all args and params. *) let elimclause' = recolle_clenv i params indvars elimclause gl in (* one last resolution (useless?) *) - let resolved = clenv_unique_resolver ~flags:(elim_flags ()) elimclause' gl in - Proofview.V82.of_tactic (enforce_prop_bound_names rename (Clenvtac.clenv_refine with_evars resolved)) gl + let resolved = Tacmach.New.of_old (clenv_unique_resolver ~flags:(elim_flags ()) elimclause') gl in + enforce_prop_bound_names rename (Clenvtac.clenv_refine with_evars resolved) + end } (* Apply induction "in place" taking into account dependent hypotheses from the context, replacing the main hypothesis on which induction applies with the induction hypotheses *) -let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = - let open Context.Named.Declaration in +let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_tac = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in @@ -3948,7 +4125,7 @@ let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = let s = Retyping.get_sort_family_of env sigma tmpcl in let deps_cstr = List.fold_left - (fun a decl -> if is_local_assum decl then (mkVar (get_id decl))::a else a) [] deps in + (fun a decl -> if NamedDecl.is_local_assum decl then (mkVar (NamedDecl.get_id decl))::a else a) [] deps in let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in let branchletsigns = let f (_,is_not_let,_,_) = is_not_let in @@ -3964,7 +4141,8 @@ let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = Tacticals.New.tclMAP expand_hyp toclear; ]) (Array.map2 - (induct_discharge lhyp0 avoid (re_intro_dependent_hypotheses statuslists)) + (induct_discharge with_evars lhyp0 avoid + (re_intro_dependent_hypotheses statuslists)) indsign names) in Sigma.Unsafe.of_pair (tac, sigma) @@ -3974,8 +4152,8 @@ let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyp Proofview.Goal.enter { enter = begin fun gl -> let elim_info = find_induction_type isrec elim hyp0 (Proofview.Goal.assume gl) in atomize_param_of_ind_then elim_info hyp0 (fun indvars -> - apply_induction_in_context (Some hyp0) inhyps (pi3 elim_info) indvars names - (fun elim -> Proofview.V82.tactic (induction_tac with_evars [] [hyp0] elim))) + apply_induction_in_context with_evars (Some hyp0) inhyps (pi3 elim_info) indvars names + (fun elim -> induction_tac with_evars [] [hyp0] elim)) end } let msg_not_right_number_induction_arguments scheme = @@ -4013,39 +4191,40 @@ let induction_without_atomization isrec with_evars elim names lid = but by chance, because of the addition of at least hyp0 for cook_sign, it behaved as if there was a real induction arg. *) if indvars = [] then [List.hd lid_params] else indvars in - let induct_tac elim = Proofview.V82.tactic (tclTHENLIST [ + let induct_tac elim = Tacticals.New.tclTHENLIST [ (* pattern to make the predicate appear. *) - Proofview.V82.of_tactic (reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl); + reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl; (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all possible holes using arguments given by the user (but the functional one). *) (* FIXME: Tester ca avec un principe dependant et non-dependant *) - induction_tac with_evars params realindvars elim - ]) in + induction_tac with_evars params realindvars elim; + ] in let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in - apply_induction_in_context None [] elim indvars names induct_tac + apply_induction_in_context with_evars None [] elim indvars names induct_tac end } (* assume that no occurrences are selected *) -let clear_unselected_context id inhyps cls gl = - let open Context.Named.Declaration in - if occur_var (Tacmach.pf_env gl) id (Tacmach.pf_concl gl) && +let clear_unselected_context id inhyps cls = + Proofview.Goal.nf_enter { enter = begin fun gl -> + if occur_var (Tacmach.New.pf_env gl) id (Tacmach.New.pf_concl gl) && cls.concl_occs == NoOccurrences - then errorlabstrm "" + then user_err (str "Conclusion must be mentioned: it depends on " ++ pr_id id ++ str "."); match cls.onhyps with | Some hyps -> let to_erase d = - let id' = get_id d in + let id' = NamedDecl.get_id d in if Id.List.mem id' inhyps then (* if selected, do not erase *) None else (* erase if not selected and dependent on id or selected hyps *) - let test id = occur_var_in_decl (pf_env gl) id d in + let test id = occur_var_in_decl (Tacmach.New.pf_env gl) id d in if List.exists test (id::inhyps) then Some id' else None in - let ids = List.map_filter to_erase (pf_hyps gl) in - thin ids gl - | None -> tclIDTAC gl + let ids = List.map_filter to_erase (Proofview.Goal.hyps gl) in + clear ids + | None -> Proofview.tclUNIT () + end } let use_bindings env sigma elim must_be_closed (c,lbind) typ = let sigma = Sigma.to_evar_map sigma in @@ -4095,7 +4274,7 @@ let check_enough_applied env sigma elim = | None -> (* No eliminator given *) fun u -> - let t,_ = decompose_app (whd_betadeltaiota env sigma u) in isInd t + let t,_ = decompose_app (whd_all env sigma u) in isInd t | Some elimc -> let elimt = Retyping.get_type_of env sigma (fst elimc) in let scheme = compute_elim_sig ~elimc elimt in @@ -4148,7 +4327,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim end }; if with_evars then Proofview.shelve_unifiable else guard_no_unifiable; if is_arg_pure_hyp - then Tacticals.New.tclTRY (Proofview.V82.tactic (thin [destVar c0])) + then Tacticals.New.tclTRY (clear [destVar c0]) else Proofview.tclUNIT (); if isrec then Proofview.cycle (-1) else Proofview.tclUNIT () ]) @@ -4189,7 +4368,7 @@ let induction_gen clear_flag isrec with_evars elim let cls = Option.default allHypsAndConcl cls in let t = typ_of env sigma c in let is_arg_pure_hyp = - isVar c && not (mem_named_context (destVar c) (Global.named_context())) + isVar c && not (mem_named_context_val (destVar c) (Global.named_context_val ())) && lbind == NoBindings && not with_evars && Option.is_empty eqname && clear_flag == None && has_generic_occurrences_but_goal cls (destVar c) env ccl in @@ -4202,7 +4381,7 @@ let induction_gen clear_flag isrec with_evars elim and w/o equality kept: no need to generalize *) let id = destVar c in Tacticals.New.tclTHEN - (Proofview.V82.tactic (clear_unselected_context id inhyps cls)) + (clear_unselected_context id inhyps cls) (induction_with_atomization_of_ind_arg isrec with_evars elim names id inhyps) else @@ -4229,14 +4408,14 @@ let induction_gen_l isrec with_evars elim names lc = let lc = List.map (function | (c,None) -> c | (c,Some(loc,eqname)) -> - user_err_loc (loc,"",str "Do not know what to do with " ++ + user_err ~loc (str "Do not know what to do with " ++ Miscprint.pr_intro_pattern_naming eqname)) lc in let rec atomize_list l = match l with | [] -> Proofview.tclUNIT () | c::l' -> match kind_of_term c with - | Var id when not (mem_named_context id (Global.named_context())) + | Var id when not (mem_named_context_val id (Global.named_context_val ())) && not with_evars -> let _ = newlc:= id::!newlc in atomize_list l' @@ -4278,19 +4457,11 @@ let induction_destruct isrec with_evars (lc,elim) = (* Standard induction on non-standard induction schemes *) (* will be removable when is_functional_induction will be more clever *) if not (Option.is_empty cls) then error "'in' clause not supported here."; - let finish_evar_resolution f = - let ((c, lbind), sigma') = run_delayed env sigma f in - let pending = (sigma,sigma') in - let sigma' = Sigma.Unsafe.of_evar_map sigma' in - let Sigma (c, _, _) = finish_evar_resolution env sigma' (pending,c) in - (c, lbind) - in - let c = map_induction_arg finish_evar_resolution c in + let _,c = force_destruction_arg false env sigma c in onInductionArg - (fun _clear_flag (c,lbind) -> - if lbind != NoBindings then - error "'with' clause not supported here."; - induction_gen_l isrec with_evars elim names [c,eqname]) c + (fun _clear_flag c -> + induction_gen_l isrec with_evars elim names + [with_no_bindings c,eqname]) c | _ -> (* standard induction *) onOpenInductionArg env sigma @@ -4321,23 +4492,14 @@ let induction_destruct isrec with_evars (lc,elim) = end }) l) | Some elim -> (* Several induction hyps with induction scheme *) - let finish_evar_resolution f = - let ((c, lbind), sigma') = run_delayed env sigma f in - let pending = (sigma,sigma') in - if lbind != NoBindings then - error "'with' clause not supported here."; - let sigma' = Sigma.Unsafe.of_evar_map sigma' in - let Sigma (c, _, _) = finish_evar_resolution env sigma' (pending,c) in - c - in - let lc = List.map (on_pi1 (map_induction_arg finish_evar_resolution)) lc in + let lc = List.map (on_pi1 (fun c -> snd (force_destruction_arg false env sigma c))) lc in let newlc = List.map (fun (x,(eqn,names),cls) -> if cls != None then error "'in' clause not yet supported here."; match x with (* FIXME: should we deal with ElimOnIdent? *) | _clear_flag,ElimOnConstr x -> if eqn <> None then error "'eqn' clause not supported here."; - (x,names) + (with_no_bindings x,names) | _ -> error "Don't know where to find some argument.") lc in (* Check that "as", if any, is given only on the last argument *) @@ -4432,7 +4594,7 @@ let maybe_betadeltaiota_concl allowred gl = if not allowred then concl else let env = Proofview.Goal.env gl in - whd_betadeltaiota env sigma concl + whd_all env sigma concl let reflexivity_red allowred = Proofview.Goal.enter { enter = begin fun gl -> @@ -4620,7 +4782,7 @@ let interpretable_as_section_decl evd d1 d2 = | LocalDef _, LocalAssum _ -> false | LocalDef (_,b1,t1), LocalDef (_,b2,t2) -> e_eq_constr_univs evd b1 b2 && e_eq_constr_univs evd t1 t2 - | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (get_type d2) + | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (NamedDecl.get_type d2) let rec decompose len c t accu = let open Context.Rel.Declaration in @@ -4633,26 +4795,24 @@ let rec decompose len c t accu = | _ -> assert false let rec shrink ctx sign c t accu = - let open Context.Rel.Declaration in match ctx, sign with | [], [] -> (c, t, accu) | p :: ctx, decl :: sign -> - if noccurn 1 c then + if noccurn 1 c && noccurn 1 t then let c = subst1 mkProp c in let t = subst1 mkProp t in shrink ctx sign c t accu else let c = mkLambda_or_LetIn p c in let t = mkProd_or_LetIn p t in - let accu = if is_local_assum p then let open Context.Named.Declaration in - mkVar (get_id decl) :: accu - else accu + let accu = if RelDecl.is_local_assum p + then mkVar (NamedDecl.get_id decl) :: accu + else accu in shrink ctx sign c t accu | _ -> assert false let shrink_entry sign const = - let open Context.Named.Declaration in let open Entries in let typ = match const.const_entry_type with | None -> assert false @@ -4673,19 +4833,18 @@ let abstract_subproof id gk tac = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in - let open Context.Named.Declaration in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let current_sign = Global.named_context() + let current_sign = Global.named_context_val () and global_sign = Proofview.Goal.hyps gl in let sigma = Sigma.to_evar_map sigma in let evdref = ref sigma in let sign,secsign = List.fold_right (fun d (s1,s2) -> - let id = get_id d in - if mem_named_context id current_sign && - interpretable_as_section_decl evdref (Context.Named.lookup id current_sign) d + let id = NamedDecl.get_id d in + if mem_named_context_val id current_sign && + interpretable_as_section_decl evdref (lookup_named_val id current_sign) d then (s1,push_named_context_val d s2) else (Context.Named.add d s1,s2)) global_sign (Context.Named.empty, empty_named_context_val) in @@ -4711,7 +4870,7 @@ let abstract_subproof id gk tac = which is an error irrelevant to the proof system (in fact it means that [e] comes from [tac] failing to yield enough success). Hence it reraises [e]. *) - let (_, info) = Errors.push src in + let (_, info) = CErrors.push src in iraise (e, info) in let const, args = @@ -4720,8 +4879,13 @@ let abstract_subproof id gk tac = in let cd = Entries.DefinitionEntry const in let decl = (cd, IsProof Lemma) in - (** ppedrot: seems legit to have abstracted subproofs as local*) - let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl in + let cst () = + (** do not compute the implicit arguments, it may be costly *) + let () = Impargs.make_implicit_args false in + (** ppedrot: seems legit to have abstracted subproofs as local*) + Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl + in + let cst = Impargs.with_implicit_protection cst () in (* let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in *) let lem, ctx = Universes.unsafe_constr_of_global (ConstRef cst) in let evd = Evd.set_universe_context evd ectx in @@ -4731,7 +4895,7 @@ let abstract_subproof id gk tac = Entries.(snd (Future.force const.const_entry_body)) in let solve = Proofview.tclEFFECTS effs <*> - new_exact_no_check (applist (lem, args)) + exact_no_check (applist (lem, args)) in let tac = if not safe then Proofview.mark_as_unsafe <*> solve else solve in Sigma.Unsafe.of_pair (tac, evd) @@ -4771,7 +4935,7 @@ let unify ?(state=full_transparent_state) x y = let sigma = Sigma.to_evar_map sigma in let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in Sigma.Unsafe.of_pair (Proofview.tclUNIT (), sigma) - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> Sigma.here (Tacticals.New.tclFAIL 0 (str"Not unifiable")) sigma end } @@ -4797,15 +4961,22 @@ end module New = struct open Proofview.Notations - let exact_proof c = Proofview.V82.tactic (exact_proof c) + let exact_proof c = exact_proof c open Genredexpr open Locus let reduce_after_refine = + let onhyps = + (** We reduced everywhere in the hyps before 8.6 *) + if Flags.version_compare !Flags.compat_version Flags.V8_5 == 0 + then None + else Some [] + in reduce - (Lazy {rBeta=true;rIota=true;rZeta=false;rDelta=false;rConst=[]}) - {onhyps=None; concl_occs=AllOccurrences } + (Lazy {rBeta=true;rMatch=true;rFix=true;rCofix=true; + rZeta=false;rDelta=false;rConst=[]}) + {onhyps; concl_occs=AllOccurrences } let refine ?unsafe c = Refine.refine ?unsafe c <*> diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 4c4a96ec07..7acfb62864 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -15,13 +15,16 @@ open Evd open Clenv open Redexpr open Globnames -open Tacexpr open Pattern open Unification open Misctypes +open Tactypes open Locus -(** Main tactics. *) +(** Main tactics defined in ML. This file is huge and should probably be split + in more reasonable units at some point. Because of its size and age, the + implementation features various styles and stages of the proof engine. + This has to be uniformized someday. *) (** {6 General functions. } *) @@ -30,17 +33,15 @@ val is_quantified_hypothesis : Id.t -> ([`NF],'b) Proofview.Goal.t -> bool (** {6 Primitive tactics. } *) val introduction : ?check:bool -> Id.t -> unit Proofview.tactic -val refine : constr -> tactic val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic val convert_hyp : ?check:bool -> Context.Named.Declaration.t -> unit Proofview.tactic val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic val convert_hyp_no_check : Context.Named.Declaration.t -> unit Proofview.tactic -val thin : Id.t list -> tactic val mutual_fix : - Id.t -> int -> (Id.t * int * constr) list -> int -> tactic -val fix : Id.t option -> int -> tactic -val mutual_cofix : Id.t -> (Id.t * constr) list -> int -> tactic -val cofix : Id.t option -> tactic + Id.t -> int -> (Id.t * int * constr) list -> int -> unit Proofview.tactic +val fix : Id.t option -> int -> unit Proofview.tactic +val mutual_cofix : Id.t -> (Id.t * constr) list -> int -> unit Proofview.tactic +val cofix : Id.t option -> unit Proofview.tactic val convert : constr -> constr -> unit Proofview.tactic val convert_leq : constr -> constr -> unit Proofview.tactic @@ -93,7 +94,11 @@ val try_intros_until : val onInductionArg : (clear_flag -> constr with_bindings -> unit Proofview.tactic) -> - constr with_bindings induction_arg -> unit Proofview.tactic + constr with_bindings destruction_arg -> unit Proofview.tactic + +val force_destruction_arg : evars_flag -> env -> evar_map -> + delayed_open_constr_with_bindings destruction_arg -> + evar_map * constr with_bindings destruction_arg (** Tell if a used hypothesis should be cleared by default or not *) @@ -101,25 +106,25 @@ val use_clear_hyp_by_default : unit -> bool (** {6 Introduction tactics with eliminations. } *) -val intro_patterns : intro_patterns -> unit Proofview.tactic -val intro_patterns_to : Id.t move_location -> intro_patterns -> +val intro_patterns : evars_flag -> intro_patterns -> unit Proofview.tactic +val intro_patterns_to : evars_flag -> Id.t move_location -> intro_patterns -> unit Proofview.tactic -val intro_patterns_bound_to : int -> Id.t move_location -> intro_patterns -> +val intro_patterns_bound_to : evars_flag -> int -> Id.t move_location -> intro_patterns -> unit Proofview.tactic -val intro_pattern_to : Id.t move_location -> delayed_open_constr intro_pattern_expr -> +val intro_pattern_to : evars_flag -> Id.t move_location -> delayed_open_constr intro_pattern_expr -> unit Proofview.tactic (** Implements user-level "intros", with [] standing for "**" *) -val intros_patterns : intro_patterns -> unit Proofview.tactic +val intros_patterns : evars_flag -> intro_patterns -> unit Proofview.tactic (** {6 Exact tactics. } *) val assumption : unit Proofview.tactic -val exact_no_check : constr -> tactic -val vm_cast_no_check : constr -> tactic -val native_cast_no_check : constr -> tactic +val exact_no_check : constr -> unit Proofview.tactic +val vm_cast_no_check : constr -> unit Proofview.tactic +val native_cast_no_check : constr -> unit Proofview.tactic val exact_check : constr -> unit Proofview.tactic -val exact_proof : Constrexpr.constr_expr -> tactic +val exact_proof : Constrexpr.constr_expr -> unit Proofview.tactic (** {6 Reduction tactics. } *) @@ -155,7 +160,7 @@ val unfold_in_hyp : val unfold_option : (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic val change : - constr_pattern option -> change_arg -> clause -> tactic + constr_pattern option -> change_arg -> clause -> unit Proofview.tactic val pattern_option : (occurrences * constr) list -> goal_location -> unit Proofview.tactic val reduce : red_expr -> clause -> unit Proofview.tactic @@ -163,15 +168,15 @@ val unfold_constr : global_reference -> unit Proofview.tactic (** {6 Modification of the local context. } *) -val clear : Id.t list -> tactic +val clear : Id.t list -> unit Proofview.tactic val clear_body : Id.t list -> unit Proofview.tactic val unfold_body : Id.t -> unit Proofview.tactic val keep : Id.t list -> unit Proofview.tactic val apply_clear_request : clear_flag -> bool -> constr -> unit Proofview.tactic -val specialize : constr with_bindings -> unit Proofview.tactic +val specialize : constr with_bindings -> intro_pattern option -> unit Proofview.tactic -val move_hyp : Id.t -> Id.t move_location -> tactic +val move_hyp : Id.t -> Id.t move_location -> unit Proofview.tactic val rename_hyp : (Id.t * Id.t) list -> unit Proofview.tactic val revert : Id.t list -> unit Proofview.tactic @@ -294,7 +299,7 @@ val destruct : evars_flag -> clear_flag -> constr -> or_and_intro_pattern option (** Implements user-level "destruct" and "induction" *) val induction_destruct : rec_flag -> evars_flag -> - (delayed_open_constr_with_bindings induction_arg + (delayed_open_constr_with_bindings destruction_arg * (intro_pattern_naming option * or_and_intro_pattern option) * clause option) list * constr with_bindings option -> unit Proofview.tactic @@ -365,7 +370,7 @@ val pose_proof : Name.t -> constr -> (** Common entry point for user-level "assert", "enough" and "pose proof" *) -val forward : bool -> unit Proofview.tactic option -> +val forward : bool -> unit Proofview.tactic option option -> intro_pattern option -> constr -> unit Proofview.tactic (** Implements the tactic cut, actually a modus ponens rule *) @@ -384,13 +389,12 @@ val letin_pat_tac : (bool * intro_pattern_naming) option -> (** {6 Generalize tactics. } *) -val generalize : constr list -> tactic -val generalize_gen : (constr Locus.with_occurrences * Name.t) list -> tactic +val generalize : constr list -> unit Proofview.tactic +val generalize_gen : (constr Locus.with_occurrences * Name.t) list -> unit Proofview.tactic -val new_generalize : constr list -> unit Proofview.tactic val new_generalize_gen : ((occurrences * constr) * Name.t) list -> unit Proofview.tactic -val generalize_dep : ?with_let:bool (** Don't lose let bindings *) -> constr -> tactic +val generalize_dep : ?with_let:bool (** Don't lose let bindings *) -> constr -> unit Proofview.tactic (** {6 Other tactics. } *) @@ -399,7 +403,7 @@ val unify : ?state:Names.transparent_state -> constr -> constr -> unit val tclABSTRACT : Id.t option -> unit Proofview.tactic -> unit Proofview.tactic val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> Id.t -> unit Proofview.tactic -val specialize_eqs : Id.t -> tactic +val specialize_eqs : Id.t -> unit Proofview.tactic val general_rewrite_clause : (bool -> evars_flag -> constr with_bindings -> clause -> unit Proofview.tactic) Hook.t @@ -437,6 +441,4 @@ module New : sig val reduce_after_refine : unit Proofview.tactic (** The reducing tactic called after {!refine}. *) - open Proofview - val exact_proof : Constrexpr.constr_expr -> unit tactic end diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index ab8069225d..f54ad86a3f 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -1,5 +1,3 @@ -Ftactic -Geninterp Dnet Dn Btermdn @@ -14,12 +12,10 @@ Equality Contradiction Inv Leminv -Taccoerce Hints Auto Eauto Class_tactics -Tactic_matching Term_dnet Eqdecide Autorewrite |