diff options
Diffstat (limited to 'tactics')
54 files changed, 19018 insertions, 0 deletions
diff --git a/tactics/abstract.ml b/tactics/abstract.ml new file mode 100644 index 0000000000..3a687a6b41 --- /dev/null +++ b/tactics/abstract.ml @@ -0,0 +1,195 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +module CVars = Vars + +open Util +open Names +open Termops +open EConstr +open Decl_kinds +open Evarutil + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +(* tactical to save as name a subproof such that the generalisation of + the current goal, abstracted with respect to the local signature, + is solved by tac *) + +(** d1 is the section variable in the global context, d2 in the goal context *) +let interpretable_as_section_decl env evd d1 d2 = + let open Context.Named.Declaration in + let e_eq_constr_univs sigma c1 c2 = match eq_constr_universes env !sigma c1 c2 with + | None -> false + | Some cstr -> + try ignore (Evd.add_universe_constraints !sigma cstr); true + with UState.UniversesDiffer -> false + in + match d2, d1 with + | 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 (NamedDecl.get_type d2) + +let rec decompose len c t accu = + let open Constr in + let open Context.Rel.Declaration in + if len = 0 then (c, t, accu) + else match kind c, kind t with + | Lambda (na, u, c), Prod (_, _, t) -> + decompose (pred len) c t (LocalAssum (na, u) :: accu) + | LetIn (na, b, u, c), LetIn (_, _, _, t) -> + decompose (pred len) c t (LocalDef (na, b, u) :: accu) + | _ -> assert false + +let rec shrink ctx sign c t accu = + let open Constr in + let open CVars in + match ctx, sign with + | [], [] -> (c, t, accu) + | p :: ctx, decl :: sign -> + 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 = Term.mkLambda_or_LetIn p c in + let t = Term.mkProd_or_LetIn p t in + 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 Entries in + let typ = match const.const_entry_type with + | None -> assert false + | Some t -> t + in + (* The body has been forced by the call to [build_constant_by_tactic] *) + let () = assert (Future.is_over const.const_entry_body) in + let ((body, uctx), eff) = Future.force const.const_entry_body in + let (body, typ, ctx) = decompose (List.length sign) body typ [] in + let (body, typ, args) = shrink ctx sign body typ [] in + let const = { const with + const_entry_body = Future.from_val ((body, uctx), eff); + const_entry_type = Some typ; + } in + (const, args) + +let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = + let open Tacticals.New in + let open Tacmach.New in + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let current_sign = Global.named_context_val () + and global_sign = Proofview.Goal.hyps gl in + let evdref = ref sigma in + let sign,secsign = + List.fold_right + (fun d (s1,s2) -> + let id = NamedDecl.get_id d in + if mem_named_context_val id current_sign && + interpretable_as_section_decl env 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, Environ.empty_named_context_val) in + let id = Namegen.next_global_ident_away id (pf_ids_set_of_hyps gl) in + let concl = match goal_type with + | None -> Proofview.Goal.concl gl + | Some ty -> ty in + let concl = it_mkNamedProd_or_LetIn concl sign in + let concl = + try flush_and_check_evars !evdref concl + with Uninstantiated_evar _ -> + CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials.") in + + let evd, ctx, concl = + (* FIXME: should be done only if the tactic succeeds *) + let evd = Evd.minimize_universes !evdref in + let ctx = Evd.universe_context_set evd in + evd, ctx, Evarutil.nf_evars_universes evd concl + in + let concl = EConstr.of_constr concl in + let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) Tactics.intro) tac) in + let ectx = Evd.evar_universe_context evd in + let (const, safe, ectx) = + try Pfedit.build_constant_by_tactic ~goal_kind:gk id ectx secsign concl solve_tac + with Logic_monad.TacticFailure e as src -> + (* if the tactic [tac] fails, it reports a [TacticFailure e], + 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) = CErrors.push src in + iraise (e, info) + in + let const, args = shrink_entry sign const in + let args = List.map EConstr.of_constr args in + let cd = Entries.DefinitionEntry { const with Entries.const_entry_opaque = opaque } in + let decl = (cd, if opaque then IsProof Lemma else IsDefinition Definition) 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 inst = match const.Entries.const_entry_universes with + | Entries.Monomorphic_const_entry _ -> EInstance.empty + | Entries.Polymorphic_const_entry (_, ctx) -> + (* We mimick what the kernel does, that is ensuring that no additional + constraints appear in the body of polymorphic constants. Ideally this + should be enforced statically. *) + let (_, body_uctx), _ = Future.force const.Entries.const_entry_body in + let () = assert (Univ.ContextSet.is_empty body_uctx) in + EInstance.make (Univ.UContext.instance ctx) + in + let lem = mkConstU (cst, inst) in + let evd = Evd.set_universe_context evd ectx in + let open Safe_typing in + let eff = private_con_of_con (Global.safe_env ()) cst in + let effs = concat_private eff + Entries.(snd (Future.force const.const_entry_body)) in + let solve = + Proofview.tclEFFECTS effs <*> + tacK lem args + in + let tac = if not safe then Proofview.mark_as_unsafe <*> solve else solve in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) tac + end + +let abstract_subproof ~opaque id gk tac = + cache_term_by_tactic_then ~opaque id gk tac (fun lem args -> Tactics.exact_no_check (applist (lem, args))) + +let anon_id = Id.of_string "anonymous" + +let name_op_to_name name_op object_kind suffix = + let open Proof_global in + let default_gk = (Global, false, object_kind) in + let name, gk = match Proof_global.V82.get_current_initial_conclusions () with + | (id, (_, gk)) -> Some id, gk + | exception NoCurrentProof -> None, default_gk + in + match name_op with + | Some s -> s, gk + | None -> + let name = Option.default anon_id name in + Nameops.add_suffix name suffix, gk + +let tclABSTRACT ?(opaque=true) name_op tac = + let s, gk = if opaque + then name_op_to_name name_op (Proof Theorem) "_subproof" + else name_op_to_name name_op (DefinitionBody Definition) "_subterm" in + abstract_subproof ~opaque s gk tac diff --git a/tactics/abstract.mli b/tactics/abstract.mli new file mode 100644 index 0000000000..7fb671fbf8 --- /dev/null +++ b/tactics/abstract.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open EConstr + +val cache_term_by_tactic_then : opaque:bool -> ?goal_type:(constr option) -> Id.t -> Decl_kinds.goal_kind -> unit Proofview.tactic -> (constr -> constr list -> unit Proofview.tactic) -> unit Proofview.tactic + +val tclABSTRACT : ?opaque:bool -> Id.t option -> unit Proofview.tactic -> unit Proofview.tactic diff --git a/tactics/auto.ml b/tactics/auto.ml new file mode 100644 index 0000000000..2619620eb8 --- /dev/null +++ b/tactics/auto.ml @@ -0,0 +1,554 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open Util +open Names +open Termops +open EConstr +open Environ +open Genredexpr +open Tactics +open Clenv +open Locus +open Proofview.Notations +open Hints + +(**************************************************************************) +(* Automatic tactics *) +(**************************************************************************) + +(**************************************************************************) +(* tactics with a trace mechanism for automatic search *) +(**************************************************************************) + +let priority l = List.filter (fun (_, hint) -> Int.equal hint.pri 0) l + +let compute_secvars gl = + let hyps = Proofview.Goal.hyps gl in + secvars_of_hyps hyps + +(* tell auto not to reuse already instantiated metas in unification (for + compatibility, since otherwise, apply succeeds oftener) *) + +open Unification + +let auto_core_unif_flags_of st1 st2 = { + modulo_conv_on_closed_terms = Some st1; + use_metas_eagerly_in_conv_on_closed_terms = false; + use_evars_eagerly_in_conv_on_closed_terms = false; + modulo_delta = st2; + modulo_delta_types = TransparentState.full; + check_applied_meta_types = false; + use_pattern_unification = false; + use_meta_bound_pattern_unification = true; + frozen_evars = Evar.Set.empty; + restrict_conv_on_strict_subterms = false; (* Compat *) + modulo_betaiota = false; + modulo_eta = true; +} + +let auto_unif_flags_of st1 st2 = + let flags = auto_core_unif_flags_of st1 st2 in { + core_unify_flags = flags; + merge_unify_flags = flags; + subterm_unify_flags = { flags with modulo_delta = TransparentState.empty }; + allow_K_in_toplevel_higher_order_unification = false; + resolve_evars = true +} + +let auto_unif_flags = + auto_unif_flags_of TransparentState.full TransparentState.empty + +(* Try unification with the precompiled clause, then use registered Apply *) + +let connect_hint_clenv poly (c, _, ctx) clenv gl = + (* [clenv] has been generated by a hint-making function, so the only relevant + data in its evarmap is the set of metas. The [evar_reset_evd] function + below just replaces the metas of sigma by those coming from the clenv. *) + let sigma = Tacmach.New.project gl in + let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in + (* Still, we need to update the universes *) + let clenv, c = + if poly then + (* Refresh the instance of the hint *) + let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in + let emap c = Vars.subst_univs_level_constr subst c in + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in + (* Only metas are mentioning the old universes. *) + let clenv = { + templval = Evd.map_fl emap clenv.templval; + templtyp = Evd.map_fl emap clenv.templtyp; + evd = Evd.map_metas emap evd; + env = Proofview.Goal.env gl; + } in + clenv, emap c + else + 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.enter begin fun gl -> + let clenv, c = connect_hint_clenv poly c clenv gl in + let clenv = clenv_unique_resolver ~flags clenv gl in + Clenvtac.clenv_refine clenv + end + +let unify_resolve_nodelta poly h = unify_resolve poly auto_unif_flags h + +let unify_resolve_gen poly = function + | None -> unify_resolve_nodelta poly + | Some flags -> unify_resolve poly flags + +let exact poly (c,clenv) = + Proofview.Goal.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 *) + +(* Serait-ce possible de compiler d'abord la tactique puis de faire la + substitution sans passer par bdize dont l'objectif est de préparer un + terme pour l'affichage ? (HH) *) + +(* Si on enlève le dernier argument (gl) conclPattern est calculé une +fois pour toutes : en particulier si Pattern.somatch produit une UserError +Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même +si après Intros la conclusion matche le pattern. +*) + +(* conclPattern doit échouer avec error car il est rattraper par tclFIRST *) + +let conclPattern concl pat tac = + let constr_bindings env sigma = + match pat with + | None -> Proofview.tclUNIT Id.Map.empty + | Some pat -> + try + Proofview.tclUNIT (Constr_matching.matches env sigma pat concl) + with Constr_matching.PatternMatchingFailure -> + Tacticals.New.tclZEROMSG (str "pattern-matching failed") + in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + constr_bindings env sigma >>= fun constr_bindings -> + let open Genarg in + let open Geninterp 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 + match tac with + | GenArg (Glbwit wit, tac) -> + Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) + end + +(***********************************************************) +(** A debugging / verbosity framework for trivial and auto *) +(***********************************************************) + +(** The following options allow to trigger debugging/verbosity + without having to adapt the scripts. + Note: if Debug and Info are both activated, Debug take precedence. *) + +let global_debug_trivial = ref false +let global_debug_auto = ref false +let global_info_trivial = ref false +let global_info_auto = ref false + +let add_option ls refe = + Goptions.(declare_bool_option + { optdepr = false; + optname = String.concat " " ls; + optkey = ls; + optread = (fun () -> !refe); + optwrite = (:=) refe }) + +let () = + add_option ["Debug";"Trivial"] global_debug_trivial; + add_option ["Debug";"Auto"] global_debug_auto; + add_option ["Info";"Trivial"] global_info_trivial; + add_option ["Info";"Auto"] global_info_auto + +type debug_kind = ReportForTrivial | ReportForAuto + +let no_dbg (_,whatfor,_,_) = (Off,whatfor,0,ref []) + +let mk_trivial_dbg debug = + let d = + if debug == Debug || !global_debug_trivial then Debug + else if debug == Info || !global_info_trivial then Info + else Off + in (d,ReportForTrivial,0,ref []) + +let mk_auto_dbg debug = + let d = + if debug == Debug || !global_debug_auto then Debug + else if debug == Info || !global_info_auto then Info + else Off + in (d,ReportForAuto,0,ref []) + +let incr_dbg = function (dbg,whatfor,depth,trace) -> (dbg,whatfor,depth+1,trace) + +(** A tracing tactic for debug/info trivial/auto *) + +let tclLOG (dbg,_,depth,trace) pp tac = + match dbg with + | Off -> tac + | Debug -> + (* For "debug (trivial/auto)", we directly output messages *) + let s = String.make (depth+1) '*' in + Proofview.(tclIFCATCH ( + tac >>= fun v -> + tclENV >>= fun env -> + tclEVARMAP >>= fun sigma -> + Feedback.msg_debug (str s ++ spc () ++ pp env sigma ++ str ". (*success*)"); + tclUNIT v + ) tclUNIT + (fun (exn, info) -> + tclENV >>= fun env -> + tclEVARMAP >>= fun sigma -> + Feedback.msg_debug (str s ++ spc () ++ pp env sigma ++ str ". (*fail*)"); + tclZERO ~info exn)) + | Info -> + (* For "info (trivial/auto)", we store a log trace *) + Proofview.(tclIFCATCH ( + tac >>= fun v -> + trace := (depth, Some pp) :: !trace; + tclUNIT v + ) Proofview.tclUNIT + (fun (exn, info) -> + trace := (depth, None) :: !trace; + tclZERO ~info exn)) + +(** For info, from the linear trace information, we reconstitute the part + of the proof tree we're interested in. The last executed tactic + comes first in the trace (and it should be a successful one). + [depth] is the root depth of the tree fragment we're visiting. + [keep] means we're in a successful tree fragment (the very last + tactic has been successful). *) + +let rec cleanup_info_trace depth acc = function + | [] -> acc + | (d,Some pp) :: l -> cleanup_info_trace d ((d,pp)::acc) l + | l -> cleanup_info_trace depth acc (erase_subtree depth l) + +and erase_subtree depth = function + | [] -> [] + | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l + +let pr_info_atom env sigma (d,pp) = + str (String.make d ' ') ++ pp env sigma ++ str "." + +let pr_info_trace env sigma = function + | (Info,_,_,{contents=(d,Some pp)::l}) -> + Feedback.msg_info (prlist_with_sep fnl (pr_info_atom env sigma) (cleanup_info_trace d [(d,pp)] l)) + | _ -> () + +let pr_info_nop = function + | (Info,_,_,_) -> Feedback.msg_info (str "idtac.") + | _ -> () + +let pr_dbg_header = function + | (Off,_,_,_) -> () + | (Debug,ReportForTrivial,_,_) -> Feedback.msg_debug (str "(* debug trivial: *)") + | (Debug,ReportForAuto,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") + | (Info,ReportForTrivial,_,_) -> Feedback.msg_info (str "(* info trivial: *)") + | (Info,ReportForAuto,_,_) -> Feedback.msg_info (str "(* info auto: *)") + +let tclTRY_dbg d tac = + let delay f = Proofview.tclUNIT () >>= fun () -> f () in + let tac = + delay (fun () -> pr_dbg_header d; tac) >>= fun () -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + pr_info_trace env sigma d; + Proofview.tclUNIT () in + let after = delay (fun () -> pr_info_nop d; Proofview.tclUNIT ()) in + Tacticals.New.tclORELSE0 tac after + +(**************************************************************************) +(* The Trivial tactic *) +(**************************************************************************) + +(* local_db is a Hint database containing the hypotheses of current goal *) +(* Papageno : cette fonction a été pas mal simplifiée depuis que la base + de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) + +let flags_of_state st = + auto_unif_flags_of st st + +let auto_flags_of_state st = + auto_unif_flags_of TransparentState.full st + +let hintmap_of sigma secvars hdc concl = + match hdc with + | None -> Hint_db.map_none ~secvars + | Some hdc -> + if occur_existential sigma concl then + Hint_db.map_existential sigma ~secvars hdc concl + else Hint_db.map_auto sigma ~secvars hdc concl + +let exists_evaluable_reference env = function + | EvalConstRef _ -> true + | EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false + +let dbg_intro dbg = tclLOG dbg (fun _ _ -> str "intro") intro +let dbg_assumption dbg = tclLOG dbg (fun _ _ -> str "assumption") assumption + +let rec trivial_fail_db dbg mod_delta db_list local_db = + let intro_tac = + Tacticals.New.tclTHEN (dbg_intro dbg) + ( Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in + let nf c = Evarutil.nf_evar sigma c in + let decl = Tacmach.New.pf_last_hyp gl in + let hyp = Context.Named.Declaration.map_constr nf decl in + let hintl = make_resolve_hyp env sigma hyp + in trivial_fail_db dbg mod_delta db_list + (Hint_db.add_list env sigma hintl local_db) + end) + in + Proofview.Goal.enter begin fun gl -> + let concl = Tacmach.New.pf_concl gl in + let sigma = Tacmach.New.project gl in + let secvars = compute_secvars gl in + Tacticals.New.tclFIRST + ((dbg_assumption dbg)::intro_tac:: + (List.map Tacticals.New.tclCOMPLETE + (trivial_resolve sigma dbg mod_delta db_list local_db secvars concl))) + end + +and my_find_search_nodelta sigma db_list local_db secvars hdc concl = + List.map (fun hint -> (None,hint)) + (List.map_append (hintmap_of sigma 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 sigma db_list local_db secvars hdc concl = + let f = hintmap_of sigma secvars hdc concl in + if occur_existential sigma concl then + List.map_append + (fun db -> + if Hint_db.use_dn db then + let flags = flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (Some flags,x)) (f db) + else + let flags = auto_flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (Some flags,x)) (f db)) + (local_db::db_list) + else + List.map_append (fun db -> + if Hint_db.use_dn db then + let flags = flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (Some flags, x)) (f db) + else + let st = Hint_db.transparent_state db in + let flags, l = + let l = + match hdc with None -> Hint_db.map_none ~secvars db + | Some hdc -> + if TransparentState.is_empty st + then Hint_db.map_auto sigma ~secvars hdc concl db + else Hint_db.map_existential sigma ~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;db=dbname})) = + let tactic = function + | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl) + | ERes_pf _ -> Proofview.Goal.enter (fun gl -> Tacticals.New.tclZEROMSG (str "eres_pf")) + | Give_exact (c, cl) -> exact poly (c, cl) + | Res_pf_THEN_trivial_fail (c,cl) -> + Tacticals.New.tclTHEN + (unify_resolve_gen poly flags (c,cl)) + (* With "(debug) trivial", we shouldn't end here, and + with "debug auto" we don't display the details of inner trivial *) + (trivial_fail_db (no_dbg dbg) (not (Option.is_empty flags)) db_list local_db) + | Unfold_nth c -> + Proofview.Goal.enter begin fun gl -> + if exists_evaluable_reference (Tacmach.New.pf_env gl) c then + Tacticals.New.tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) + else Tacticals.New.tclFAIL 0 (str"Unbound reference") + end + | Extern tacast -> + conclPattern concl p tacast + in + let pr_hint env sigma = + let origin = match dbname with + | None -> mt () + | Some n -> str " (in " ++ str n ++ str ")" + in + pr_hint env sigma t ++ origin + in + tclLOG dbg pr_hint (run_hint t tactic) + +and trivial_resolve sigma dbg mod_delta db_list local_db secvars cl = + try + let head = + try let hdconstr = decompose_app_bound sigma cl in + Some hdconstr + with Bound -> None + in + List.map (tac_of_hint dbg db_list local_db cl) + (priority + (my_find_search mod_delta sigma db_list local_db secvars head cl)) + with Not_found -> [] + +(** The use of the "core" database can be de-activated by passing + "nocore" amongst the databases. *) + +let trivial ?(debug=Off) lems dbnames = + Hints.wrap_hint_warning @@ + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let db_list = make_db_list dbnames in + let d = mk_trivial_dbg debug in + let hints = make_local_hint_db env sigma false lems in + tclTRY_dbg d + (trivial_fail_db d false db_list hints) + end + +let full_trivial ?(debug=Off) lems = + Hints.wrap_hint_warning @@ + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let db_list = current_pure_db () in + let d = mk_trivial_dbg debug in + let hints = make_local_hint_db env sigma false lems in + tclTRY_dbg d + (trivial_fail_db d false db_list hints) + end + +let gen_trivial ?(debug=Off) lems = function + | None -> full_trivial ~debug lems + | Some l -> trivial ~debug lems l + +let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l + +(**************************************************************************) +(* The classical Auto tactic *) +(**************************************************************************) + +let possible_resolve sigma dbg mod_delta db_list local_db secvars cl = + try + let head = + try let hdconstr = decompose_app_bound sigma cl in + Some hdconstr + with Bound -> None + in + List.map (tac_of_hint dbg db_list local_db cl) + (my_find_search mod_delta sigma db_list local_db secvars head cl) + with Not_found -> [] + +let extend_local_db decl db gl = + let env = Tacmach.New.pf_env gl in + let sigma = Tacmach.New.project gl in + Hint_db.add_list env sigma (make_resolve_hyp env sigma decl) db + +(* Introduce an hypothesis, then call the continuation tactic [kont] + with the hint db extended with the so-obtained hypothesis *) + +let intro_register dbg kont db = + Tacticals.New.tclTHEN (dbg_intro dbg) + (Proofview.Goal.enter begin fun gl -> + let extend_local_db decl db = extend_local_db decl db gl in + Tacticals.New.onLastDecl (fun decl -> kont (extend_local_db decl db)) + end) + +(* n is the max depth of search *) +(* local_db contains the local Hypotheses *) + +let search d n mod_delta db_list local_db = + let rec search d n local_db = + (* spiwack: the test of [n] to 0 must be done independently in + each goal. Hence the [tclEXTEND] *) + Proofview.tclEXTEND [] begin + if Int.equal n 0 then Tacticals.New.tclZEROMSG (str"BOUND 2") else + Tacticals.New.tclORELSE0 (dbg_assumption d) + (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) + ( Proofview.Goal.enter begin fun gl -> + let concl = Tacmach.New.pf_concl gl in + let sigma = Tacmach.New.project 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 sigma d mod_delta db_list local_db secvars concl)) + end)) + end [] + in + search d n local_db + +let default_search_depth = ref 5 + +let delta_auto debug mod_delta n lems dbnames = + Hints.wrap_hint_warning @@ + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let db_list = make_db_list dbnames in + let d = mk_auto_dbg debug in + let hints = make_local_hint_db env sigma false lems in + tclTRY_dbg d + (search d n mod_delta db_list hints) + end + +let delta_auto = + if Flags.profile then + let key = CProfile.declare_profile "delta_auto" in + CProfile.profile5 key delta_auto + else delta_auto + +let auto ?(debug=Off) n = delta_auto debug false n + +let new_auto ?(debug=Off) n = delta_auto debug true n + +let default_auto = auto !default_search_depth [] [] + +let delta_full_auto ?(debug=Off) mod_delta n lems = + Hints.wrap_hint_warning @@ + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let db_list = current_pure_db () in + let d = mk_auto_dbg debug in + let hints = make_local_hint_db env sigma false lems in + tclTRY_dbg d + (search d n mod_delta db_list hints) + end + +let full_auto ?(debug=Off) n = delta_full_auto ~debug false n +let new_full_auto ?(debug=Off) n = delta_full_auto ~debug true n + +let default_full_auto = full_auto !default_search_depth [] + +let gen_auto ?(debug=Off) n lems dbnames = + let n = match n with None -> !default_search_depth | Some n -> n in + match dbnames with + | None -> full_auto ~debug n lems + | Some l -> auto ~debug n lems l + +let h_auto ?(debug=Off) n lems l = gen_auto ~debug n lems l diff --git a/tactics/auto.mli b/tactics/auto.mli new file mode 100644 index 0000000000..72d2292ffb --- /dev/null +++ b/tactics/auto.mli @@ -0,0 +1,84 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** This files implements auto and related automation tactics *) + +open Names +open EConstr +open Clenv +open Pattern +open Decl_kinds +open Hints +open Tactypes + +val compute_secvars : Proofview.Goal.t -> Id.Pred.t + +val default_search_depth : int ref + +val auto_flags_of_state : TransparentState.t -> Unification.unify_flags + +val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> + 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 + +(** [ConclPattern concl pat tacast]: + if the term concl matches the pattern pat, (in sense of + [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the + right values to build a tactic *) + +val conclPattern : constr -> constr_pattern option -> Genarg.glob_generic_argument -> unit Proofview.tactic + +(** The Auto tactic *) + +(** The use of the "core" database can be de-activated by passing + "nocore" amongst the databases. *) + +val auto : ?debug:debug -> + int -> delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic + +(** Auto with more delta. *) + +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 *) +val full_auto : ?debug:debug -> + int -> 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 *) +val default_full_auto : unit Proofview.tactic + +(** The generic form of auto (second arg [None] means all bases) *) +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:debug -> + int option -> delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic + +(** Trivial *) + +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 new file mode 100644 index 0000000000..f824552705 --- /dev/null +++ b/tactics/autorewrite.ml @@ -0,0 +1,285 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Equality +open Names +open Pp +open Constr +open Termops +open CErrors +open Util +open Mod_subst +open Locus + +(* Rewriting rules *) +type rew_rule = { rew_lemma: constr; + rew_type: types; + rew_pat: constr; + rew_ctx: Univ.ContextSet.t; + rew_l2r: bool; + rew_tac: Genarg.glob_generic_argument option } + +let subst_hint subst hint = + let cst' = subst_mps subst hint.rew_lemma in + let typ' = subst_mps subst hint.rew_type in + let pat' = subst_mps subst hint.rew_pat in + let t' = Option.Smart.map (Genintern.generic_substitute subst) hint.rew_tac in + if hint.rew_lemma == cst' && hint.rew_type == typ' && hint.rew_tac == t' then hint else + { hint with + rew_lemma = cst'; rew_type = typ'; + rew_pat = pat'; rew_tac = t' } + +module HintIdent = +struct + type t = int * rew_rule + + let compare (i, t) (j, t') = i - j + + let subst s (i,t) = (i,subst_hint s t) + + let constr_of (i,t) = t.rew_pat +end + +module HintOpt = +struct + let reduce c = c + let direction = true +end + +module HintDN = Term_dnet.Make(HintIdent)(HintOpt) + +(* Summary and Object declaration *) +let rewtab = + Summary.ref (String.Map.empty : HintDN.t String.Map.t) ~name:"autorewrite" + +let raw_find_base bas = String.Map.find bas !rewtab + +let find_base bas = + try raw_find_base bas + with Not_found -> + user_err ~hdr:"AutoRewrite" + (str "Rewriting base " ++ str bas ++ str " does not exist.") + +let find_rewrites bas = + List.rev_map snd (HintDN.find_all (find_base bas)) + +let find_matches bas pat = + let base = find_base bas in + let res = HintDN.search_pattern base pat in + List.map snd res + +let print_rewrite_hintdb env sigma bas = + (str "Database " ++ str bas ++ fnl () ++ + prlist_with_sep fnl + (fun h -> + str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ + Printer.pr_lconstr_env env sigma h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr_env env sigma h.rew_type ++ + Option.cata (fun tac -> str " then use tactic " ++ + Pputils.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) + (find_rewrites bas)) + +type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) CAst.t + +(* Applies all the rules of one base *) +let one_base general_rewrite_maybe_in tac_main bas = + let lrul = find_rewrites bas in + let try_rewrite dir ctx c tc = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let subst, ctx' = UnivGen.fresh_universe_context_set_instance ctx in + let c' = Vars.subst_univs_level_constr subst c in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (general_rewrite_maybe_in dir c' tc) + end in + let lrul = List.map (fun h -> + let tac = match h.rew_tac with + | None -> Proofview.tclUNIT () + | Some (Genarg.GenArg (Genarg.Glbwit wit, tac)) -> + let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + 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) -> + Tacticals.New.tclTHEN tac + (Tacticals.New.tclREPEAT_MAIN + (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) + (Proofview.tclUNIT()) lrul)) + +(* The AutoRewrite tactic *) +let autorewrite ?(conds=Naive) tac_main lbas = + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS + (List.fold_left (fun tac bas -> + Tacticals.New.tclTHEN tac + (one_base (fun dir c tac -> + let tac = (tac, conds) in + general_rewrite dir AllOccurrences true false ~tac (EConstr.of_constr c)) + tac_main bas)) + (Proofview.tclUNIT()) lbas)) + +let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = + Proofview.Goal.enter begin fun gl -> + (* let's check at once if id exists (to raise the appropriate error) *) + let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in + let general_rewrite_in id dir cstr tac = + let cstr = EConstr.of_constr cstr in + general_rewrite_in dir AllOccurrences true ~tac:(tac, conds) false id cstr false + in + Tacticals.New.tclMAP (fun id -> + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS + (List.fold_left (fun tac bas -> + Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas))) + idl + end + +let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] + +let gen_auto_multi_rewrite conds tac_main lbas cl = + let try_do_hyps treat_id l = + autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas + in + if cl.concl_occs != AllOccurrences && + cl.concl_occs != NoOccurrences + then + Tacticals.New.tclZEROMSG (str"The \"at\" syntax isn't available yet for the autorewrite tactic.") + else + let compose_tac t1 t2 = + match cl.onhyps with + | Some [] -> t1 + | _ -> Tacticals.New.tclTHENFIRST t1 t2 + in + compose_tac + (if cl.concl_occs != NoOccurrences then autorewrite ~conds tac_main lbas else Proofview.tclUNIT ()) + (match cl.onhyps with + | Some l -> try_do_hyps (fun ((_,id),_) -> id) l + | None -> + (* try to rewrite in all hypothesis + (except maybe the rewritten one) *) + Proofview.Goal.enter begin fun gl -> + let ids = Tacmach.New.pf_ids_of_hyps gl in + try_do_hyps (fun id -> id) ids + end) + +let auto_multi_rewrite ?(conds=Naive) lems cl = + Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl) + +let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = + let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in + match onconcl,cl.Locus.onhyps with + | false,Some [_] | true,Some [] | false,Some [] -> + (* autorewrite with .... in clause using tac n'est sur que + si clause represente soit le but soit UNE hypothese + *) + Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl) + | _ -> + Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") + +(* Functions necessary to the library object declaration *) +let cache_hintrewrite (_,(rbase,lrl)) = + let base = try raw_find_base rbase with Not_found -> HintDN.empty in + let max = try fst (Util.List.last (HintDN.find_all base)) with Failure _ -> 0 + in + let lrl = HintDN.refresh_metas lrl in + let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in + rewtab:=String.Map.add rbase (HintDN.union lrl base) !rewtab + + +let subst_hintrewrite (subst,(rbase,list as node)) = + let list' = HintDN.subst subst list in + if list' == list then node else + (rbase,list') + +(* Declaration of the Hint Rewrite library object *) +let inHintRewrite : string * HintDN.t -> Libobject.obj = + let open Libobject in + declare_object @@ superglobal_object_nodischarge "HINT_REWRITE" + ~cache:cache_hintrewrite + ~subst:(Some subst_hintrewrite) + +open Clenv + +type hypinfo = { + hyp_cl : clausenv; + hyp_prf : constr; + hyp_ty : types; + hyp_car : constr; + hyp_rel : constr; + hyp_l2r : bool; + hyp_left : constr; + hyp_right : constr; +} + +let decompose_applied_relation metas env sigma c ctype left2right = + let find_rel ty = + let eqclause = Clenv.mk_clenv_from_env env sigma None (EConstr.of_constr c,ty) in + let eqclause = + if metas then eqclause + else fst (clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd)) + in + let (equiv, args) = EConstr.decompose_app sigma (Clenv.clenv_type eqclause) in + let rec split_last_two = function + | [c1;c2] -> [],(c1, c2) + | x::y::z -> + let l,res = split_last_two (y::z) in x::l, res + | _ -> raise Not_found + in + try + let others,(c1,c2) = split_last_two args in + let ty1, ty2 = Typing.unsafe_type_of env eqclause.evd c1, Typing.unsafe_type_of env eqclause.evd c2 in + (* XXX: It looks like mk_clenv_from_env should be fixed instead? *) + let open EConstr in + let hyp_ty = Unsafe.to_constr ty in + let hyp_car = Unsafe.to_constr ty1 in + let hyp_prf = Unsafe.to_constr @@ Clenv.clenv_value eqclause in + let hyp_rel = Unsafe.to_constr @@ mkApp (equiv, Array.of_list others) in + let hyp_left = Unsafe.to_constr @@ c1 in + let hyp_right = Unsafe.to_constr @@ c2 in +(* if not (evd_convertible env eqclause.evd ty1 ty2) then None *) +(* else *) + Some { hyp_cl=eqclause; hyp_prf; hyp_ty; hyp_car; hyp_rel; hyp_l2r=left2right; hyp_left; hyp_right; } + with Not_found -> None + in + match find_rel ctype with + | Some c -> Some c + | None -> + let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' ctx) with + | Some c -> Some c + | None -> None + +let find_applied_relation ?loc metas env sigma c left2right = + let ctype = Typing.unsafe_type_of env sigma (EConstr.of_constr c) in + match decompose_applied_relation metas env sigma c ctype left2right with + | Some c -> c + | None -> + user_err ?loc ~hdr:"decompose_applied_relation" + (str"The type" ++ spc () ++ Printer.pr_econstr_env env sigma ctype ++ + spc () ++ str"of this term does not end with an applied relation.") + +(* To add rewriting rules to a base *) +let add_rew_rules base lrul = + let counter = ref 0 in + let env = Global.env () in + let sigma = Evd.from_env env in + let ist = Genintern.empty_glob_sign (Global.env ()) in + let intern tac = snd (Genintern.generic_intern ist tac) in + let lrul = + List.fold_left + (fun dn {CAst.loc;v=((c,ctx),b,t)} -> + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in + let info = find_applied_relation ?loc false env sigma c b in + let pat = if b then info.hyp_left else info.hyp_right in + let rul = { rew_lemma = c; rew_type = info.hyp_ty; + rew_pat = pat; rew_ctx = ctx; rew_l2r = b; + rew_tac = Option.map intern t} + in incr counter; + HintDN.add pat (!counter, rul) dn) HintDN.empty lrul + in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) + diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli new file mode 100644 index 0000000000..03e9414e0f --- /dev/null +++ b/tactics/autorewrite.mli @@ -0,0 +1,64 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** This files implements the autorewrite tactic. *) + +open Constr +open Equality + +(** Rewriting rules before tactic interpretation *) +type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) CAst.t + +(** To add rewriting rules to a base *) +val add_rew_rules : string -> raw_rew_rule list -> unit + +(** The AutoRewrite tactic. + The optional conditions tell rewrite how to handle matching and side-condition solving. + Default is Naive: first match in the clause, don't look at the side-conditions to + tell if the rewrite succeeded. *) +val autorewrite : ?conds:conditions -> unit Proofview.tactic -> string list -> unit Proofview.tactic +val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> string list -> unit Proofview.tactic + +(** Rewriting rules *) +type rew_rule = { rew_lemma: constr; + rew_type: types; + rew_pat: constr; + rew_ctx: Univ.ContextSet.t; + rew_l2r: bool; + rew_tac: Genarg.glob_generic_argument option } + +val find_rewrites : string -> rew_rule list + +val find_matches : string -> constr -> rew_rule list + +val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> unit Proofview.tactic + +val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic + +val print_rewrite_hintdb : Environ.env -> Evd.evar_map -> string -> Pp.t + +open Clenv + + +type hypinfo = { + hyp_cl : clausenv; + hyp_prf : constr; + hyp_ty : types; + hyp_car : constr; + hyp_rel : constr; + hyp_l2r : bool; + hyp_left : constr; + hyp_right : constr; +} + +val find_applied_relation : + ?loc:Loc.t -> bool -> + Environ.env -> Evd.evar_map -> constr -> bool -> hypinfo + diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml new file mode 100644 index 0000000000..2f2bd8d2bc --- /dev/null +++ b/tactics/btermdn.ml @@ -0,0 +1,179 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Constr +open EConstr +open Names +open Pattern +open Globnames + +(* Discrimination nets with bounded depth. + See the module dn.ml for further explanations. + Eduardo (5/8/97). *) + +let dnet_depth = ref 8 + +type term_label = +| GRLabel of GlobRef.t +| ProdLabel +| LambdaLabel +| SortLabel + +let compare_term_label t1 t2 = match t1, t2 with +| GRLabel gr1, GRLabel gr2 -> GlobRef.Ordered.compare gr1 gr2 +| _ -> Pervasives.compare t1 t2 (** OK *) + +type 'res lookup_res = 'res Dn.lookup_res = Label of 'res | Nothing | Everything + +let decomp_pat = + let rec decrec acc = function + | PApp (f,args) -> decrec (Array.to_list args @ acc) f + | PProj (p, c) -> (PRef (ConstRef (Projection.constant p)), c :: acc) + | c -> (c,acc) + in + decrec [] + +let decomp sigma t = + let rec decrec acc c = match EConstr.kind sigma c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Proj (p, c) -> (mkConst (Projection.constant p), c :: acc) + | Cast (c1,_,_) -> decrec acc c1 + | _ -> (c,acc) + in + decrec [] t + +let constr_val_discr sigma t = + let c, l = decomp sigma t in + match EConstr.kind sigma c with + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) + | Var id -> Label(GRLabel (VarRef id),l) + | Const _ -> Everything + | _ -> Nothing + +let constr_pat_discr t = + if not (Patternops.occur_meta_pattern t) then + None + else + match decomp_pat t with + | PRef ((IndRef _) as ref), args + | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) + | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args) + | _ -> None + +let constr_val_discr_st sigma ts t = + let c, l = decomp sigma t in + match EConstr.kind sigma c with + | Const (c,u) -> if TransparentState.is_transparent_constant ts c then Everything else Label(GRLabel (ConstRef c),l) + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) + | Var id when not (TransparentState.is_transparent_variable ts id) -> Label(GRLabel (VarRef id),l) + | Prod (n, d, c) -> Label(ProdLabel, [d; c]) + | Lambda (n, d, c) -> + if List.is_empty l then + Label(LambdaLabel, [d; c] @ l) + else Everything + | Sort _ -> Label(SortLabel, []) + | Evar _ -> Everything + | _ -> Nothing + +let constr_pat_discr_st ts t = + match decomp_pat t with + | PRef ((IndRef _) as ref), args + | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) + | PRef ((VarRef v) as ref), args when not (TransparentState.is_transparent_variable ts v) -> + Some(GRLabel ref,args) + | PVar v, args when not (TransparentState.is_transparent_variable ts v) -> + Some(GRLabel (VarRef v),args) + | PRef ((ConstRef c) as ref), args when not (TransparentState.is_transparent_constant ts c) -> + Some (GRLabel ref, args) + | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c]) + | PLambda (_, d, c), [] -> Some (LambdaLabel, [d ; c]) + | PSort s, [] -> Some (SortLabel, []) + | _ -> None + +let bounded_constr_pat_discr_st st (t,depth) = + if Int.equal depth 0 then + None + else + match constr_pat_discr_st st t with + | None -> None + | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + +let bounded_constr_val_discr_st sigma st (t,depth) = + if Int.equal depth 0 then + Nothing + else + match constr_val_discr_st sigma st t with + | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l) + | Nothing -> Nothing + | Everything -> Everything + +let bounded_constr_pat_discr (t,depth) = + if Int.equal depth 0 then + None + else + match constr_pat_discr t with + | None -> None + | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + +let bounded_constr_val_discr sigma (t,depth) = + if Int.equal depth 0 then + Nothing + else + match constr_val_discr sigma t with + | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l) + | Nothing -> Nothing + | Everything -> Everything + +module Make = + functor (Z : Map.OrderedType) -> +struct + + module Y = struct + type t = term_label + let compare = compare_term_label + end + + module Dn = Dn.Make(Y)(Z) + + type t = Dn.t + + let empty = Dn.empty + + let add = function + | None -> + (fun dn (c,v) -> + Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)) + | Some st -> + (fun dn (c,v) -> + Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + + let rmv = function + | None -> + (fun dn (c,v) -> + Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) + | Some st -> + (fun dn (c,v) -> + Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + + let lookup sigma = function + | None -> + (fun dn t -> + Dn.lookup dn (bounded_constr_val_discr sigma) (t,!dnet_depth)) + | Some st -> + (fun dn t -> + Dn.lookup dn (bounded_constr_val_discr_st sigma st) (t,!dnet_depth)) + + let app f dn = Dn.app f dn + +end + diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli new file mode 100644 index 0000000000..cc31fb0599 --- /dev/null +++ b/tactics/btermdn.mli @@ -0,0 +1,40 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pattern + +(** Discrimination nets with bounded depth. *) + +(** This module registers actions (typically tactics) mapped to patterns *) + +(** Patterns are stocked linearly as the list of its node in prefix +order in such a way patterns having the same prefix have this common +prefix shared and the seek for the action associated to the patterns +that a term matches are found in time proportional to the maximal +number of nodes of the patterns matching the term. The [TransparentState.t] +indicates which constants and variables can be considered as rigid. +These dnets are able to cope with existential variables as well, which match +[Everything]. *) + +module Make : + functor (Z : Map.OrderedType) -> +sig + type t + + val empty : t + + val add : TransparentState.t option -> t -> (constr_pattern * Z.t) -> t + val rmv : TransparentState.t option -> t -> (constr_pattern * Z.t) -> t + + val lookup : Evd.evar_map -> TransparentState.t option -> t -> EConstr.constr -> Z.t list + val app : (Z.t -> unit) -> t -> unit +end + +val dnet_depth : int ref diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml new file mode 100644 index 0000000000..ba7645446d --- /dev/null +++ b/tactics/class_tactics.ml @@ -0,0 +1,1194 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* TODO: + - Find an interface allowing eauto to backtrack when shelved goals remain, + e.g. to force instantiations. + *) + +open Pp +open CErrors +open Util +open Names +open Term +open Constr +open Termops +open EConstr +open Tacmach +open Tactics +open Clenv +open Typeclasses +open Globnames +open Evd +open Locus +open Proofview.Notations +open Hints + +module NamedDecl = Context.Named.Declaration + +(** Hint database named "typeclass_instances", now created directly in Auto *) + +(** Options handling *) + +let typeclasses_debug = ref 0 +let typeclasses_depth = ref None + +(** 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 + +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 + +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 + { 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 + { optdepr = false; + optname = "during typeclass resolution, solve instances according to their dependency order"; + optkey = ["Typeclasses";"Dependency";"Order"]; + optread = get_typeclasses_dependency_order; + optwrite = set_typeclasses_dependency_order; } + +let () = + declare_bool_option + { optdepr = false; + optname = "use iterative deepening strategy"; + optkey = ["Typeclasses";"Iterative";"Deepening"]; + optread = get_typeclasses_iterative_deepening; + optwrite = set_typeclasses_iterative_deepening; } + +let () = + declare_bool_option + { optdepr = false; + optname = "compat"; + optkey = ["Typeclasses";"Filtered";"Unification"]; + optread = get_typeclasses_filtered_unification; + optwrite = set_typeclasses_filtered_unification; } + +let () = + declare_bool_option + { optdepr = false; + optname = "debug output for typeclasses proof search"; + optkey = ["Typeclasses";"Debug"]; + optread = get_typeclasses_debug; + optwrite = set_typeclasses_debug; } + +let _ = + declare_int_option + { optdepr = false; + optname = "verbosity of debug output for typeclasses proof search"; + optkey = ["Typeclasses";"Debug";"Verbosity"]; + optread = get_typeclasses_verbose; + optwrite = set_typeclasses_verbose; } + +let () = + declare_int_option + { 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_econstr_env (Goal.V82.env evs ev) evs (Goal.V82.concl evs ev) + +(** Typeclasses instance search tactic / eauto *) + +open Auto +open Unification + +let auto_core_unif_flags st freeze = { + modulo_conv_on_closed_terms = Some st; + use_metas_eagerly_in_conv_on_closed_terms = true; + use_evars_eagerly_in_conv_on_closed_terms = false; + modulo_delta = st; + modulo_delta_types = st; + check_applied_meta_types = false; + use_pattern_unification = true; + use_meta_bound_pattern_unification = true; + frozen_evars = freeze; + restrict_conv_on_strict_subterms = false; (* ? *) + modulo_betaiota = true; + modulo_eta = false; +} + +let auto_unif_flags freeze st = + let fl = auto_core_unif_flags st freeze in + { core_unify_flags = fl; + merge_unify_flags = fl; + subterm_unify_flags = fl; + allow_K_in_toplevel_higher_order_unification = false; + resolve_evars = false +} + +let e_give_exact flags poly (c,clenv) = + let open Tacmach.New in + Proofview.Goal.enter begin fun gl -> + let sigma = project gl in + let (c, _, _) = c in + let c, sigma = + if poly then + let clenv', subst = Clenv.refresh_undefined_univs clenv in + let evd = evars_reset_evd ~with_conv_pbs:true sigma clenv'.evd in + let c = Vars.subst_univs_level_constr subst c in + c, evd + else c, sigma + in + let (sigma, t1) = Typing.type_of (pf_env gl) sigma c in + Proofview.Unsafe.tclEVARS sigma <*> + Clenvtac.unify ~flags t1 <*> exact_no_check c + end + +let clenv_unique_resolver_tac with_evars ~flags clenv' = + Proofview.Goal.enter begin fun gls -> + let resolve = + try Proofview.tclUNIT (clenv_unique_resolver ~flags clenv' gls) + with e -> Proofview.tclZERO e + in resolve >>= fun clenv' -> + Clenvtac.clenv_refine ~with_evars ~with_classes:false clenv' + end + +let unify_e_resolve poly flags = begin fun gls (c,_,clenv) -> + let clenv', c = connect_hint_clenv poly c clenv gls in + clenv_unique_resolver_tac true ~flags clenv' end + +let unify_resolve poly flags = begin fun gls (c,_,clenv) -> + let clenv', _ = connect_hint_clenv poly c clenv gls in + clenv_unique_resolver_tac false ~flags 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 ~typecheck:false begin fun sigma -> + let sigma, term, ty = + if poly then + let (subst, ctx) = UnivGen.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 = applist (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', term) end + +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 (None, clenv) + else + let sigma = Tacmach.New.project gl in + let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma c in + let diff = nb_prod sigma ty - nprods in + if Pervasives.(>=) diff 0 then + (* Was Some clenv... *) + Some (Some diff, + mk_clenv_from_n gl (Some diff) (c,ty)) + else None + +let with_prods nprods poly (c, clenv) f = + if get_typeclasses_limit_intros () then + Proofview.Goal.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 gl (c, diff, clenv') + with e when CErrors.noncritical e -> + Tacticals.New.tclZEROMSG (CErrors.print e) end + else Proofview.Goal.enter + begin fun gl -> + if Int.equal nprods 0 then f 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 -> + 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 begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + matches env sigma end + +(** 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 sigma 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 sigma ~secvars hdc concl db + else Hint_db.map_existential sigma ~secvars hdc concl db + +(** Hack to properly solve dependent evars that are typeclasses *) +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.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.enter + begin fun gl -> + let tacs = e_trivial_resolve db_list local_db secvars only_classes + (pf_env gl) (project gl) (pf_concl gl) in + tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs) + end + in + let tacl = + Eauto.registered_e_assumption :: + (tclTHEN Tactics.intro trivial_fail :: [trivial_resolve]) + in + tclSOLVE tacl + +and e_my_find_search db_list local_db secvars hdc complete only_classes env sigma concl = + let open Proofview.Notations in + let prods, concl = EConstr.decompose_prod_assum sigma concl in + let nprods = List.length prods in + let freeze = + try + match hdc with + | Some (hd,_) when only_classes -> + let cl = Typeclasses.class_info hd in + if cl.cl_strict then + Evarutil.undefined_evars_of_term sigma concl + else Evar.Set.empty + | _ -> Evar.Set.empty + with e when CErrors.noncritical e -> Evar.Set.empty + in + let hint_of_db = hintmap_of sigma hdc secvars concl in + let hintl = + List.map_append + (fun db -> + 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; secvars; name = name}) -> + let tac = function + | Res_pf (term,cl) -> + if get_typeclasses_filtered_unification () then + let tac = + with_prods nprods poly (term,cl) + (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 + 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) + (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 + 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.enter + (fun gl -> unify_resolve_refine poly flags gl (c,None,clenv)) in + Tacticals.New.tclTHEN tac Proofview.shelve_unifiable + else + e_give_exact flags poly (c,clenv) + | Res_pf_THEN_trivial_fail (term,cl) -> + 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 -> + Proofview.tclPROGRESS (unfold_in_concl [AllOccurrences,c]) + | Extern tacast -> conclPattern concl p tacast + in + 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_env env sigma pat + | _ -> mt () + in + match repr_hint t with + | Extern _ -> (tac, b, true, name, lazy (pr_hint env sigma t ++ pp)) + | _ -> (tac, b, false, name, lazy (pr_hint env sigma t ++ pp)) + in List.map tac_of_hint hintl + +and e_trivial_resolve db_list local_db secvars only_classes env sigma concl = + let hd = try Some (decompose_app_bound sigma concl) with Bound -> None in + try + e_my_find_search db_list local_db secvars hd true only_classes env sigma concl + with Not_found -> [] + +let e_possible_resolve db_list local_db secvars only_classes env sigma concl = + let hd = try Some (decompose_app_bound sigma concl) with Bound -> None in + try + e_my_find_search db_list local_db secvars hd false only_classes env 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_depth l = + let rec fmt elts = + match elts with + | [] -> [] + | [n] -> [string_of_int n] + | n1::n2::rest -> + (string_of_int n1 ^ "." ^ string_of_int n2) :: fmt rest + in + prlist_with_sep (fun () -> str "-") str (fmt (List.rev l)) + +let is_Prop env sigma concl = + let ty = Retyping.get_type_of env sigma concl in + match EConstr.kind sigma ty with + | Sort s -> + begin match ESorts.kind sigma s with + | Prop -> true + | _ -> false + end + | _ -> false + +let is_unique env sigma concl = + try + let (cl,u), args = dest_class_app env sigma concl in + cl.cl_unique + with e when CErrors.noncritical e -> false + +(** 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 + tosee := Evar.Set.remove ev !tosee; + Evar.Set.iter (fun ev -> + if Evar.Set.mem ev !tosee then + visit ev (Evd.find evm ev)) evs; + l' := ev :: !l'; + in + while not (Evar.Set.is_empty !tosee) do + let ev = Evar.Set.choose !tosee in + visit ev (Evd.find evm ev) + done; + List.rev !l' + +(** 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 evars_to_goals p evm = + let goals, nongoals = Evar.Set.partition (p evm) (Evd.get_typeclass_evars evm) in + if Evar.Set.is_empty goals then None + else Some (goals, nongoals) + +(** Making local hints *) +let make_resolve_hyp env sigma st flags only_classes pri decl = + 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 sigma ty in + match EConstr.kind sigma (fst (decompose_app sigma ar)) with + | Const (c,_) -> is_class (ConstRef c) + | Ind (i,_) -> is_class (IndRef i) + | _ -> + let env' = push_rel_context ctx env in + let ty' = Reductionops.whd_all env' sigma ar in + if not (EConstr.eq_constr sigma ty' ar) then iscl env' ty' + else false + in + let is_class = iscl env cty in + let keep = not only_classes || is_class in + if keep then + 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) empty_hint_info in + (List.map_append + (fun (path,info,c) -> + make_resolves env sigma ~name:(PathHints path) + (true,false,not !Flags.quiet) info false + (IsConstr (EConstr.of_constr 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]) + else [] + +let make_hints g st only_classes sign = + let hintlist = + List.fold_left + (fun hints hyp -> + let consider = + not only_classes || + try let t = hyp |> NamedDecl.get_id |> Global.lookup_named |> NamedDecl.get_type in + (* Section variable, reindex only if the type changed *) + not (EConstr.eq_constr (project g) (EConstr.of_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) + +module Search = struct + type autoinfo = + { search_depth : int list; + last_tac : Pp.t Lazy.t; + search_dep : bool; + search_only_classes : bool; + search_cut : hints_path; + search_hints : hint_db; } + + (** Local hints *) + let autogoal_cache = Summary.ref ~name:"autogoal_cache" + (DirPath.empty, true, Context.Named.empty, + Hint_db.empty TransparentState.full true) + + let make_autogoal_hints only_classes ?(st=TransparentState.full) 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 + let eq c1 c2 = EConstr.eq_constr (project g) c1 c2 in + if DirPath.equal cwd dir && + (onlyc == only_classes) && + Context.Named.equal eq 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=TransparentState.full) 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 NoApplicableEx + + (** ReachedLimitEx has priority over NoApplicableEx 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 evd concl + else true + + (** 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 unique = not info.search_dep || is_unique env sigma concl in + let backtrack = needs_backtrack env sigma unique concl in + if !typeclasses_debug > 0 then + Feedback.msg_debug + (pr_depth info.search_depth ++ str": looking for " ++ + Printer.pr_econstr_env (Goal.env gl) sigma 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 env sigma 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 idx = if fst ie == NoApplicableEx then pred !idx else !idx in + let header = + pr_depth (idx :: info.search_depth) ++ str": " ++ + Lazy.force pp ++ + (if !foundone != true then + str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal gl) + else mt ()) + in + let msg = + match fst ie with + | Pretype_errors.PretypeError (env, evd, Pretype_errors.CannotUnify (x,y,_)) -> + str"Cannot unify " ++ + Printer.pr_econstr_env env evd x ++ str" and " ++ + Printer.pr_econstr_env env evd y + | ReachedLimitEx -> str "Proof-search reached its limit." + | NoApplicableEx -> str "Proof-search failed." + | e -> CErrors.iprint ie + in + Feedback.msg_debug (header ++ str " failed with: " ++ msg) + else () + in + let tac_of gls i j = Goal.enter begin fun gl' -> + let sigma' = Goal.sigma gl' 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 sigma' (Proofview.Goal.goal gl')); + let eq c1 c2 = EConstr.eq_constr sigma' c1 c2 in + let hints' = + if b && not (Context.Named.equal eq (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 sigma' (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' end + in + let rec result (shelf, ()) i k = + foundone := true; + Proofview.Unsafe.tclGETGOALS >>= fun gls -> + let gls = CList.map Proofview.drop_state gls in + 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 sigma (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_evar sigma 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' = make_unresolvables (fun x -> List.mem_f Evar.equal x goals) sigma in + with_shelf (Unsafe.tclEVARS sigma' <*> Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state 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 + ortac + (with_shelf tac >>= 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_econstr_env (Goal.env gl) sigma concl ++ + str ", " ++ int (List.length poss) ++ + str" possibilities"); + match e with + | (ReachedLimitEx,ie) -> Proofview.tclZERO ~info:ie ReachedLimitEx + | (_,ie) -> Proofview.tclZERO ~info:ie NoApplicableEx + in + if backtrack then aux (NoApplicableEx,Exninfo.null) poss + else tclONCE (aux (NoApplicableEx,Exninfo.null) poss) + + let hints_tac hints info kont : unit Proofview.tactic = + Proofview.Goal.enter + (fun gl -> hints_tac_gl hints info kont gl) + + let intro_tac info kont gl = + let open Proofview in + let env = Goal.env gl in + let sigma = Goal.sigma gl in + let decl = Tacmach.New.pf_last_hyp gl in + let hint = + make_resolve_hyp env sigma (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 sigma 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.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 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=TransparentState.full) only_classes dep hints depth = + let open Proofview in + let tac sigma gls i = + Goal.enter + begin fun gl -> + search_tac_gl ~st only_classes dep hints depth (succ i) sigma gls gl end + in + Proofview.Unsafe.tclGETGOALS >>= fun gls -> + let gls = CList.map Proofview.drop_state gls in + 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=TransparentState.full) ?(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") + | NoApplicableEx -> + 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 eauto_tac ?st ?unique ~only_classes ?strategy ~depth ~dep hints = + Hints.wrap_hint_warning @@ eauto_tac ?st ?unique ~only_classes ?strategy ~depth ~dep hints + + let run_on_evars env evm p tac = + match evars_to_goals p evm with + | None -> None (* This happens only because there's no evar having p *) + | Some (goals, nongoals) -> + let goals = + if !typeclasses_dependency_order then + top_sort evm goals + else Evar.Set.elements goals + in + let evm = Evd.set_typeclass_evars evm Evar.Set.empty in + let fgoals = Evd.save_future_goals evm in + let _, pv = Proofview.init evm [] in + let pv = Proofview.unshelve goals pv in + try + let (), pv', (unsafe, shelved, gaveup), _ = + Proofview.apply env tac pv + in + if not (List.is_empty gaveup) then + CErrors.anomaly (Pp.str "run_on_evars not assumed to apply tactics generating given up goals."); + 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 fgoals = Evd.shelve_on_future_goals shelved fgoals in + let evm' = Evd.restore_future_goals evm' fgoals in + let nongoals' = + Evar.Set.fold (fun ev acc -> match Evarutil.advance evm' ev with + | Some ev' -> Evar.Set.add ev acc + | None -> acc) nongoals (Evd.get_typeclass_evars evm') + in + let evm' = evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm in + let evm' = Evd.set_typeclass_evars evm' nongoals' in + Some evm' + else raise Not_found + with Logic_monad.TacticFailure _ -> raise Not_found + + let evars_eauto env evd depth only_classes unique dep st hints p = + let eauto_tac = eauto_tac ~st ~unique ~only_classes ~depth ~dep:(unique || dep) hints in + let res = run_on_evars env evd p eauto_tac in + match res with + | None -> evd + | Some evd' -> evd' + + let typeclasses_eauto env evd ?depth unique st hints p = + evars_eauto env evd depth true unique false st hints p + (** 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 env evd debug depth unique p = + let db = searchtable_map typeclasses_db in + typeclasses_eauto env evd ?depth unique (Hint_db.transparent_state db) [db] p +end + +(** Binding to either V85 or Search implementations. *) + +let typeclasses_eauto ?(only_classes=false) ?(st=TransparentState.full) + ?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 + 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, + it should not be shared, but only used locally. *) + +module Intpart = Unionfind.Make(Evar.Set)(Evar.Map) + +let deps_of_constraints cstrs evm p = + List.iter (fun (_, _, x, y) -> + let evx = Evarutil.undefined_evars_of_term evm x in + let evy = Evarutil.undefined_evars_of_term evm y in + Intpart.union_set (Evar.Set.union evx evy) p) + cstrs + +let evar_dependencies pred evm p = + Evd.fold_undefined + (fun ev evi _ -> + if Evd.is_typeclass_evar evm ev && pred evm ev evi then + let evars = Evar.Set.add ev (Evarutil.undefined_evars_of_evar_info evm evi) + in Intpart.union_set evars p + else ()) + evm () + +(** [split_evars] returns groups of undefined evars according to dependencies *) + +let split_evars pred evm = + let p = Intpart.create () in + evar_dependencies pred evm p; + deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p; + Intpart.partition p + +let is_inference_forced p evd ev = + try + if Evar.Set.mem ev (Evd.get_typeclass_evars evd) && p ev + then + let (loc, k) = evar_source ev evd in + match k with + | Evar_kinds.ImplicitArg (_, _, b) -> b + | Evar_kinds.QuestionMark _ -> false + | _ -> true + else true + with Not_found -> assert false + +let is_mandatory p comp evd = + Evar.Set.exists (is_inference_forced p evd) comp + +(** In case of unsatisfiable constraints, build a nice error message *) + +let error_unresolvable env comp evd = + let is_part ev = match comp with + | None -> true + | Some s -> Evar.Set.mem ev s + in + let fold ev evi (found, accu) = + let ev_class = class_of_constr evd evi.evar_concl in + if not (Option.is_empty ev_class) && is_part ev then + (* focus on one instance if only one was searched for *) + if not found then (true, Some ev) + else (found, None) + else (found, accu) + in + let (_, ev) = Evd.fold_undefined fold evd (true, None) in + Pretype_errors.unsatisfiable_constraints env evd ev comp + +(** Check if an evar is concerned by the current resolution attempt, + (and in particular is in the current component). + Invariant : this should only be applied to undefined evars. *) + +let select_and_update_evars p oevd in_comp evd ev = + try + if Evd.is_typeclass_evar oevd ev then + (in_comp ev && p evd ev (Evd.find evd ev)) + else false + with Not_found -> false + +(** Do we still have unresolved evars that should be resolved ? *) + +let has_undefined p oevd evd = + let check ev evi = p oevd ev in + Evar.Map.exists check (Evd.undefined_map evd) + +exception Unresolved + +(** 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 tcs = Evd.get_typeclass_evars oevd in + let split = if do_split then split_evars p oevd else [tcs] in + let in_comp comp ev = if do_split then Evar.Set.mem ev comp else true in + let rec docomp evd = function + | [] -> evd + | comp :: comps -> + let p = select_and_update_evars p oevd (in_comp comp) in + try + let evd' = Search.typeclasses_resolve env evd debug depth unique p 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. *) + 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 + in docomp oevd split + +let initial_select_evars filter = + fun evd ev evi -> + filter ev (Lazy.from_val (snd evi.Evd.evar_source)) && + (* Typeclass evars can contain evars whose conclusion is not + yet determined to be a class or not. *) + Typeclasses.is_class_evar evd evi + +let resolve_typeclass_evars debug depth unique env evd filter split fail = + let evd = + try Evarconv.solve_unif_constraints_with_heuristics + ~ts:(Typeclasses.classes_transparent_state ()) env evd + with e when CErrors.noncritical e -> evd + in + resolve_all_evars debug depth unique env + (initial_select_evars filter) evd split fail + +let solve_inst env evd filter unique split fail = + let ((), sigma) = Hints.wrap_hint_warning_fun env evd begin fun evd -> + (), resolve_typeclass_evars + (get_typeclasses_debug ()) + (get_typeclasses_depth ()) + unique env evd filter split fail + end in + sigma + +let () = + Hook.set Typeclasses.solve_all_instances_hook solve_inst + +let resolve_one_typeclass env ?(sigma=Evd.from_env env) gl unique = + let (term, sigma) = Hints.wrap_hint_warning_fun env sigma begin fun sigma -> + let nc, gl, subst, _ = Evarutil.push_rel_context_to_named_context env sigma gl in + let (gl,t,sigma) = Goal.V82.mk_goal sigma nc gl in + let (ev, _) = destEvar sigma t 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' = + 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' = mkEvar (ev, Array.of_list subst) in + let term = Evarutil.nf_evar evd t' in + term, evd + end in + (sigma, term) + +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. *) + +let rec head_of_constr sigma t = + let t = strip_outer_cast sigma (collapse_appl sigma t) in + match EConstr.kind sigma t with + | Prod (_,_,c2) -> head_of_constr sigma c2 + | LetIn (_,_,_,c2) -> head_of_constr sigma c2 + | App (f,args) -> head_of_constr sigma f + | _ -> t + +let head_of_constr h c = + Proofview.tclEVARMAP >>= fun sigma -> + let c = head_of_constr sigma c in + letin_tac None (Name h) c None Locusops.allHyps + +let not_evar c = + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma c with + | Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar") + | _ -> Proofview.tclUNIT () + +let is_ground c = + let open Tacticals.New in + Proofview.tclEVARMAP >>= fun sigma -> + if Evarutil.is_ground_term sigma c then tclIDTAC + else tclFAIL 0 (str"Not ground") + +let autoapply c i = + let open Proofview.Notations in + Hints.wrap_hint_warning @@ + Proofview.Goal.enter begin fun gl -> + let hintdb = try Hints.searchtable_map i with Not_found -> + CErrors.user_err (Pp.str ("Unknown hint database " ^ i ^ ".")) + in + let flags = auto_unif_flags Evar.Set.empty + (Hints.Hint_db.transparent_state hintdb) in + let cty = Tacmach.New.pf_unsafe_type_of gl c in + let ce = mk_clenv_from gl (c,cty) in + unify_e_resolve false flags gl + ((c,cty,Univ.ContextSet.empty),0,ce) <*> + Proofview.tclEVARMAP >>= (fun sigma -> + let sigma = Typeclasses.make_unresolvables + (fun ev -> Typeclasses.all_goals ev (Lazy.from_val (snd (Evd.find sigma ev).evar_source))) sigma in + Proofview.Unsafe.tclEVARS sigma) end diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli new file mode 100644 index 0000000000..a6922213d0 --- /dev/null +++ b/tactics/class_tactics.mli @@ -0,0 +1,58 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** This files implements typeclasses eauto *) + +open Names +open EConstr + +val catchable : exn -> bool + +val set_typeclasses_debug : bool -> unit +val get_typeclasses_debug : unit -> bool + +val set_typeclasses_depth : int option -> unit +val get_typeclasses_depth : unit -> int option + +type search_strategy = Dfs | Bfs + +val set_typeclasses_strategy : search_strategy -> unit + +val typeclasses_eauto : ?only_classes:bool -> ?st:TransparentState.t -> ?strategy:search_strategy -> + depth:(Int.t option) -> + Hints.hint_db_name list -> unit Proofview.tactic + +val head_of_constr : Id.t -> constr -> unit Proofview.tactic + +val not_evar : constr -> unit Proofview.tactic + +val is_ground : constr -> unit Proofview.tactic + +val autoapply : constr -> Hints.hint_db_name -> unit Proofview.tactic + +module Search : sig + val eauto_tac : + ?st:TransparentState.t + (** 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 new file mode 100644 index 0000000000..bd95a62532 --- /dev/null +++ b/tactics/contradiction.ml @@ -0,0 +1,135 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Constr +open EConstr +open Hipattern +open Tactics +open Reductionops +open Proofview.Notations + +module NamedDecl = Context.Named.Declaration + +(* Absurd *) + +let mk_absurd_proof coq_not t = + let id = Namegen.default_dependent_ident in + mkLambda (Names.Name id,mkApp(coq_not,[|t|]), + mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|]))) + +let absurd c = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let j = Retyping.get_judgment_of env sigma c in + let sigma, j = Coercion.inh_coerce_to_sort env sigma j in + let t = j.Environ.utj_val in + Proofview.Unsafe.tclEVARS sigma <*> + Tacticals.New.pf_constr_of_global (Coqlib.(lib_ref "core.not.type")) >>= fun coqnot -> + Tacticals.New.pf_constr_of_global (Coqlib.(lib_ref "core.False.type")) >>= fun coqfalse -> + Tacticals.New.tclTHENLIST [ + elim_type coqfalse; + Simple.apply (mk_absurd_proof coqnot t) + ] + end + +let absurd c = absurd c + +(* Contradiction *) + +(** [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 (NamedDecl.get_type d) -> tac (NamedDecl.get_id d) + | _::rest -> seek rest in + Proofview.Goal.enter begin fun gl -> + let hyps = Proofview.Goal.hyps gl in + seek hyps + end + +let contradiction_context = + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in + let rec seek_neg l = match l with + | [] -> Tacticals.New.tclZEROMSG (Pp.str"No such contradiction") + | d :: rest -> + 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 sigma typ then + simplest_elim (mkVar id) + else match EConstr.kind sigma typ with + | Prod (na,t,u) when is_empty_type sigma u -> + let is_unit_or_eq = match_with_unit_or_eq_type sigma t in + Tacticals.New.tclORELSE + (match is_unit_or_eq with + | Some _ -> + let hd,args = decompose_app sigma t in + let (ind,_ as indu) = destInd sigma 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 begin fun gl -> + let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in + filter_hyp (fun typ -> is_conv_leq typ t) + (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) + end) + begin function (e, info) -> match e with + | Not_found -> seek_neg rest + | e -> Proofview.tclZERO ~info e + end) + | _ -> seek_neg rest + in + let hyps = Proofview.Goal.hyps gl in + seek_neg hyps + end + +let is_negation_of env sigma typ t = + match EConstr.kind sigma (whd_all env sigma t) with + | Prod (na,t,u) -> + is_empty_type sigma u && is_conv_leq env sigma typ t + | _ -> false + +let contradiction_term (c,lbind as cl) = + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in + let type_of = Tacmach.New.pf_unsafe_type_of gl in + let typ = type_of c in + let _, ccl = splay_prod env sigma typ in + if is_empty_type sigma ccl then + Tacticals.New.tclTHEN + (elim false None cl None) + (Tacticals.New.tclTRY assumption) + else + Proofview.tclORELSE + begin + if lbind = Tactypes.NoBindings then + filter_hyp (fun c -> is_negation_of env sigma typ c) + (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) + else + Proofview.tclZERO Not_found + end + begin function (e, info) -> match e with + | Not_found -> Tacticals.New.tclZEROMSG (Pp.str"Not a contradiction.") + | e -> Proofview.tclZERO ~info e + end + end + +let contradiction = function + | None -> Tacticals.New.tclTHEN intros contradiction_context + | Some c -> contradiction_term c diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli new file mode 100644 index 0000000000..4bb3263fb4 --- /dev/null +++ b/tactics/contradiction.mli @@ -0,0 +1,15 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open EConstr +open Tactypes + +val absurd : constr -> unit Proofview.tactic +val contradiction : constr with_bindings option -> unit Proofview.tactic diff --git a/tactics/dn.ml b/tactics/dn.ml new file mode 100644 index 0000000000..aed2c28323 --- /dev/null +++ b/tactics/dn.ml @@ -0,0 +1,101 @@ +open Util + +type 'res lookup_res = Label of 'res | Nothing | Everything + +module Make = + functor (Y : Map.OrderedType) -> + functor (Z : Map.OrderedType) -> +struct + + module Y_tries = struct + type t = (Y.t * int) option + let compare x y = + match x,y with + None,None -> 0 + | Some (l,n),Some (l',n') -> + let m = Y.compare l l' in + if Int.equal m 0 then + n-n' + else m + | Some(l,n),None -> 1 + | None, Some(l,n) -> -1 + end + module ZSet = Set.Make(Z) + module X_tries = + struct + type t = ZSet.t + let nil = ZSet.empty + let is_nil = ZSet.is_empty + let add = ZSet.union + let sub = ZSet.diff + end + + module Trie = Trie.Make(Y_tries)(X_tries) + + type 'a decompose_fun = 'a -> (Y.t * 'a list) option + + type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res + + type t = Trie.t + + let empty = Trie.empty + +(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in +prefix ordering, [dna] is the function returning the main node of a pattern *) + + let path_of dna = + let rec path_of_deferred = function + | [] -> [] + | h::tl -> pathrec tl h + + and pathrec deferred t = + match dna t with + | None -> + None :: (path_of_deferred deferred) + | Some (lbl,[]) -> + (Some (lbl,0))::(path_of_deferred deferred) + | Some (lbl,(h::def_subl as v)) -> + (Some (lbl,List.length v))::(pathrec (def_subl@deferred) h) + in + pathrec [] + + let tm_of tm lbl = + try [Trie.next tm lbl, true] with Not_found -> [] + + let rec skip_arg n tm = + if Int.equal n 0 then [tm, true] + else + let labels = Trie.labels tm in + let map lbl = match lbl with + | None -> skip_arg (pred n) (Trie.next tm lbl) + | Some (_, m) -> + skip_arg (pred n + m) (Trie.next tm lbl) + in + List.flatten (List.map map labels) + + let lookup tm dna t = + let rec lookrec t tm = + match dna t with + | Nothing -> tm_of tm None + | Label(lbl,v) -> + tm_of tm None@ + (List.fold_left + (fun l c -> + List.flatten(List.map (fun (tm, b) -> + if b then lookrec c tm + else [tm,b]) l)) + (tm_of tm (Some(lbl,List.length v))) v) + | Everything -> skip_arg 1 tm + in + List.flatten (List.map (fun (tm,b) -> ZSet.elements (Trie.get tm)) (lookrec t tm)) + + let add tm dna (pat,inf) = + let p = path_of dna pat in Trie.add p (ZSet.singleton inf) tm + + let rmv tm dna (pat,inf) = + let p = path_of dna pat in Trie.remove p (ZSet.singleton inf) tm + + let app f tm = Trie.iter (fun _ p -> ZSet.iter f p) tm + +end + diff --git a/tactics/dn.mli b/tactics/dn.mli new file mode 100644 index 0000000000..2a60c3eb82 --- /dev/null +++ b/tactics/dn.mli @@ -0,0 +1,39 @@ +type 'res lookup_res = Label of 'res | Nothing | Everything + + +module Make : + functor (Y : Map.OrderedType) -> + functor (Z : Map.OrderedType) -> +sig + + type 'a decompose_fun = 'a -> (Y.t * 'a list) option + + type t + + val empty : t + + (** [add t f (tree,inf)] adds a structured object [tree] together with + the associated information [inf] to the table [t]; the function + [f] is used to translated [tree] into its prefix decomposition: [f] + must decompose any tree into a label characterizing its root node and + the list of its subtree *) + + val add : t -> 'a decompose_fun -> 'a * Z.t -> t + + val rmv : t -> 'a decompose_fun -> 'a * Z.t -> t + + type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res + + +(** [lookup t f tree] looks for trees (and their associated + information) in table [t] such that the structured object [tree] + matches against them; [f] is used to translated [tree] into its + prefix decomposition: [f] must decompose any tree into a label + characterizing its root node and the list of its subtree *) + + val lookup : t -> 'term lookup_fun -> 'term + -> Z.t list + + val app : (Z.t -> unit) -> t -> unit + +end diff --git a/tactics/dnet.ml b/tactics/dnet.ml new file mode 100644 index 0000000000..17ff94ec9c --- /dev/null +++ b/tactics/dnet.ml @@ -0,0 +1,303 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Generic dnet implementation over non-recursive types *) + +module type Datatype = +sig + type 'a t + val map : ('a -> 'b) -> 'a t -> 'b t + val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t + val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a + val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a + val compare : unit t -> unit t -> int + val terminal : 'a t -> bool + val choose : ('a -> 'b) -> 'a t -> 'b +end + +module type S = +sig + type t + type ident + type meta + type 'a structure + module Idset : Set.S with type elt=ident + type term_pattern = + | Term of term_pattern structure + | Meta of meta + val empty : t + val add : t -> term_pattern -> ident -> t + val find_all : t -> Idset.t + val fold_pattern : + ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a + val find_match : term_pattern -> t -> Idset.t + val inter : t -> t -> t + val union : t -> t -> t + val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t + val map_metas : (meta -> meta) -> t -> t +end + +module Make = + functor (T:Datatype) -> + functor (Ident:Set.OrderedType) -> + functor (Meta:Set.OrderedType) -> +struct + + type ident = Ident.t + type meta = Meta.t + + type 'a structure = 'a T.t + + type term_pattern = + | Term of term_pattern structure + | Meta of meta + + module Idset = Set.Make(Ident) + module Mmap = Map.Make(Meta) + module Tmap = Map.Make(struct type t = unit structure + let compare = T.compare end) + + type idset = Idset.t + + + + (* we store identifiers at the leaf of the dnet *) + type node = + | Node of t structure + | Terminal of t structure * idset + + (* at each node, we have a bunch of nodes (actually a map between + the bare node and a subnet) and a bunch of metavariables *) + and t = Nodes of node Tmap.t * idset Mmap.t + + let empty : t = Nodes (Tmap.empty, Mmap.empty) + + (* the head of a data is of type unit structure *) + let head w = T.map (fun c -> ()) w + + (* given a node of the net and a word, returns the subnet with the + same head as the word (with the rest of the nodes) *) + let split l (w:'a structure) : node * node Tmap.t = + let elt : node = Tmap.find (head w) l in + (elt, Tmap.remove (head w) l) + + let select l w = Tmap.find (head w) l + + let rec add (Nodes (t,m):t) (w:term_pattern) (id:ident) : t = + match w with Term w -> + ( try + let (n,tl) = split t w in + let new_node = match n with + | Terminal (e,is) -> Terminal (e,Idset.add id is) + | Node e -> Node (T.map2 (fun t p -> add t p id) e w) in + Nodes ((Tmap.add (head w) new_node tl), m) + with Not_found -> + let new_content = T.map (fun p -> add empty p id) w in + let new_node = + if T.terminal w then + Terminal (new_content, Idset.singleton id) + else Node new_content in + Nodes ((Tmap.add (head w) new_node t), m) ) + | Meta i -> + let m = + try Mmap.add i (Idset.add id (Mmap.find i m)) m + with Not_found -> Mmap.add i (Idset.singleton id) m in + Nodes (t, m) + + let add t w id = add t w id + + let rec find_all (Nodes (t,m)) : idset = + Idset.union + (Mmap.fold (fun _ -> Idset.union) m Idset.empty) + (Tmap.fold + ( fun _ n acc -> + let s2 = match n with + | Terminal (_,is) -> is + | Node e -> T.choose find_all e in + Idset.union acc s2 + ) t Idset.empty) + +(* (\* optimization hack: Not_found is caught in fold_pattern *\) *) +(* let fast_inter s1 s2 = *) +(* if Idset.is_empty s1 || Idset.is_empty s2 then raise Not_found *) +(* else Idset.inter s1 s2 *) + +(* let option_any2 f s1 s2 = match s1,s2 with *) +(* | Some s1, Some s2 -> f s1 s2 *) +(* | (Some s, _ | _, Some s) -> s *) +(* | _ -> raise Not_found *) + +(* let fold_pattern ?(complete=true) f acc pat dn = *) +(* let deferred = ref [] in *) +(* let leafs,metas = ref None, ref None in *) +(* let leaf s = leafs := match !leafs with *) +(* | None -> Some s *) +(* | Some s' -> Some (fast_inter s s') in *) +(* let meta s = metas := match !metas with *) +(* | None -> Some s *) +(* | Some s' -> Some (Idset.union s s') in *) +(* let defer c = deferred := c::!deferred in *) +(* let rec fp_rec (p:term_pattern) (Nodes(t,m) as dn:t) = *) +(* Mmap.iter (fun _ -> meta) m; (\* TODO: gérer patterns nonlin ici *\) *) +(* match p with *) +(* | Meta m -> defer (m,dn) *) +(* | Term w -> *) +(* try match select t w with *) +(* | Terminal (_,is) -> leaf is *) +(* | Node e -> *) +(* if complete then T.fold2 (fun _ -> fp_rec) () w e else *) +(* if T.fold2 *) +(* (fun b p dn -> match p with *) +(* | Term _ -> fp_rec p dn; false *) +(* | Meta _ -> b *) +(* ) true w e *) +(* then T.choose (T.choose fp_rec w) e *) +(* with Not_found -> *) +(* if Mmap.is_empty m then raise Not_found else () *) +(* in try *) +(* fp_rec pat dn; *) +(* (try Some (option_any2 Idset.union !leafs !metas) with Not_found -> None), *) +(* List.fold_left (fun acc (m,dn) -> f m dn acc) acc !deferred *) +(* with Not_found -> None,acc *) + + (* Sets with a neutral element for inter *) + module OSet (S:Set.S) = struct + type t = S.t option + let union s1 s2 : t = match s1,s2 with + | (None, _ | _, None) -> None + | Some a, Some b -> Some (S.union a b) + let inter s1 s2 : t = match s1,s2 with + | (None, a | a, None) -> a + | Some a, Some b -> Some (S.inter a b) + let is_empty : t -> bool = function + | None -> false + | Some s -> S.is_empty s + (* optimization hack: Not_found is caught in fold_pattern *) + let fast_inter s1 s2 = + if is_empty s1 || is_empty s2 then raise Not_found + else let r = inter s1 s2 in + if is_empty r then raise Not_found else r + let full = None + let empty = Some S.empty + end + + module OIdset = OSet(Idset) + + let fold_pattern ?(complete=true) f acc pat dn = + let deferred = ref [] in + let defer c = deferred := c::!deferred in + + let rec fp_rec metas p (Nodes(t,m) as dn:t) = + (* TODO gérer les dnets non-linéaires *) + let metas = Mmap.fold (fun _ -> Idset.union) m metas in + match p with + | Meta m -> defer (metas,m,dn); OIdset.full + | Term w -> + let curm = Mmap.fold (fun _ -> Idset.union) m Idset.empty in + try match select t w with + | Terminal (_,is) -> Some (Idset.union curm is) + | Node e -> + let ids = if complete then T.fold2 + (fun acc w e -> + OIdset.fast_inter acc (fp_rec metas w e) + ) OIdset.full w e + else + let (all_metas, res) = T.fold2 + (fun (b,acc) w e -> match w with + | Term _ -> false, OIdset.fast_inter acc (fp_rec metas w e) + | Meta _ -> b, acc + ) (true,OIdset.full) w e in + if all_metas then T.choose (T.choose (fp_rec metas) w) e + else res in + OIdset.union ids (Some curm) + with Not_found -> + if Idset.is_empty metas then raise Not_found else Some curm in + let cand = + try fp_rec Idset.empty pat dn + with Not_found -> OIdset.empty in + let res = List.fold_left f acc !deferred in + cand, res + + (* intersection of two dnets. keep only the common pairs *) + let rec inter (t1:t) (t2:t) : t = + let inter_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = + Nodes + (Tmap.fold + ( fun k e acc -> + try Tmap.add k (f e (Tmap.find k t2)) acc + with Not_found -> acc + ) t1 Tmap.empty, + Mmap.fold + ( fun m s acc -> + try Mmap.add m (Idset.inter s (Mmap.find m m2)) acc + with Not_found -> acc + ) m1 Mmap.empty + ) in + inter_map + (fun n1 n2 -> match n1,n2 with + | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.inter s1 s2) + | Node e1, Node e2 -> Node (T.map2 inter e1 e2) + | _ -> assert false + ) t1 t2 + + let rec union (t1:t) (t2:t) : t = + let union_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = + Nodes + (Tmap.fold + ( fun k e acc -> + try Tmap.add k (f e (Tmap.find k acc)) acc + with Not_found -> Tmap.add k e acc + ) t1 t2, + Mmap.fold + ( fun m s acc -> + try Mmap.add m (Idset.inter s (Mmap.find m acc)) acc + with Not_found -> Mmap.add m s acc + ) m1 m2 + ) in + union_map + (fun n1 n2 -> match n1,n2 with + | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.union s1 s2) + | Node e1, Node e2 -> Node (T.map2 union e1 e2) + | _ -> assert false + ) t1 t2 + + let find_match (p:term_pattern) (t:t) : idset = + let metas = ref Mmap.empty in + let (mset,lset) = fold_pattern ~complete:false + (fun acc (mset,m,t) -> + let all = OIdset.fast_inter acc + (Some(let t = try inter t (Mmap.find m !metas) with Not_found -> t in + metas := Mmap.add m t !metas; + find_all t)) in + OIdset.union (Some mset) all + ) None p t in + Option.get (OIdset.inter mset lset) + + let fold_pattern f acc p dn = fold_pattern ~complete:true f acc p dn + + let idset_map f is = Idset.fold (fun e acc -> Idset.add (f e) acc) is Idset.empty + let tmap_map f g m = Tmap.fold (fun k e acc -> Tmap.add (f k) (g e) acc) m Tmap.empty + + let rec map sidset sterm (Nodes (t,m)) : t = + let snode = function + | Terminal (e,is) -> Terminal (e,idset_map sidset is) + | Node e -> Node (T.map (map sidset sterm) e) in + Nodes (tmap_map sterm snode t, Mmap.map (idset_map sidset) m) + + let rec map_metas f (Nodes (t, m)) : t = + let f_node = function + | Terminal (e, is) -> Terminal (T.map (map_metas f) e, is) + | Node e -> Node (T.map (map_metas f) e) + in + let m' = Mmap.fold (fun m s acc -> Mmap.add (f m) s acc) m Mmap.empty in + let t' = Tmap.fold (fun k n acc -> Tmap.add k (f_node n) acc) t Tmap.empty in + Nodes (t', m') + +end diff --git a/tactics/dnet.mli b/tactics/dnet.mli new file mode 100644 index 0000000000..647bbd6bcb --- /dev/null +++ b/tactics/dnet.mli @@ -0,0 +1,128 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Generic discrimination net implementation over recursive + types. This module implements a association data structure similar + to tries but working on any types (not just lists). It is a term + indexing datastructure, a generalization of the discrimination nets + described for example in W.W.McCune, 1992, related also to + generalized tries [Hinze, 2000]. + + You can add pairs of (term,identifier) into a dnet, where the + identifier is *unique*, and search terms in a dnet filtering a + given pattern (retrievial of instances). It returns all identifiers + associated with terms matching the pattern. It also works the other + way around : You provide a set of patterns and a term, and it + returns all patterns which the term matches (retrievial of + generalizations). That's why you provide *patterns* everywhere. + + Warning 1: Full unification doesn't work as for now. Make sure the + set of metavariables in the structure and in the queries are + distincts, or you'll get unexpected behaviours. + + Warning 2: This structure is perfect, i.e. the set of candidates + returned is equal to the set of solutions. Beware of de Bruijn + shifts and sorts subtyping though (which makes the comparison not + symmetric, see term_dnet.ml). + + The complexity of the search is (almost) the depth of the term. + + To use it, you have to provide a module (Datatype) with the datatype + parametrized on the recursive argument. example: + + type btree = type 'a btree0 = + | Leaf ===> | Leaf + | Node of btree * btree | Node of 'a * 'a + +*) + +(** datatype you want to build a dnet on *) +module type Datatype = +sig + (** parametric datatype. ['a] is morally the recursive argument *) + type 'a t + + (** non-recursive mapping of subterms *) + val map : ('a -> 'b) -> 'a t -> 'b t + val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t + + (** non-recursive folding of subterms *) + val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a + val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a + + (** comparison of constructors *) + val compare : unit t -> unit t -> int + + (** for each constructor, is it not-parametric on 'a? *) + val terminal : 'a t -> bool + + (** [choose f w] applies f on ONE of the subterms of w *) + val choose : ('a -> 'b) -> 'a t -> 'b +end + +module type S = +sig + type t + + (** provided identifier type *) + type ident + + (** provided metavariable type *) + type meta + + (** provided parametrized datastructure *) + type 'a structure + + (** returned sets of solutions *) + module Idset : Set.S with type elt=ident + + (** a pattern is a term where each node can be a unification + variable *) + type term_pattern = + | Term of term_pattern structure + | Meta of meta + + val empty : t + + (** [add t w i] adds a new association (w,i) in t. *) + val add : t -> term_pattern -> ident -> t + + (** [find_all t] returns all identifiers contained in t. *) + val find_all : t -> Idset.t + + (** [fold_pattern f acc p dn] folds f on each meta of p, passing the + meta and the sub-dnet under it. The result includes: + - Some set if identifiers were gathered on the leafs of the term + - None if the pattern contains no leaf (only Metas at the leafs). + *) + val fold_pattern : + ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a + + (** [find_match p t] returns identifiers of all terms matching p in + t. *) + val find_match : term_pattern -> t -> Idset.t + + (** set operations on dnets *) + val inter : t -> t -> t + val union : t -> t -> t + + (** apply a function on each identifier and node of terms in a dnet *) + val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t + + val map_metas : (meta -> meta) -> t -> t +end + +module Make : + functor (T:Datatype) -> + functor (Ident:Set.OrderedType) -> + functor (Meta:Set.OrderedType) -> + S with type ident = Ident.t + and type meta = Meta.t + and type 'a structure = 'a T.t diff --git a/tactics/doc.tex b/tactics/doc.tex new file mode 100644 index 0000000000..d44cc14a5f --- /dev/null +++ b/tactics/doc.tex @@ -0,0 +1,11 @@ + +\newpage +\section*{The Tactics} + +\ocwsection \label{tactics} +This chapter describes the \Coq\ main tactics. +The modules of that chapter are organized as follows. + +\bigskip +\begin{center}\epsfig{file=tactics.dep.ps,width=\linewidth}\end{center} + diff --git a/tactics/dune b/tactics/dune new file mode 100644 index 0000000000..908dde5253 --- /dev/null +++ b/tactics/dune @@ -0,0 +1,6 @@ +(library + (name tactics) + (synopsis "Coq's Core Tactics [ML implementation]") + (public_name coq.tactics) + (wrapped false) + (libraries printing)) diff --git a/tactics/eauto.ml b/tactics/eauto.ml new file mode 100644 index 0000000000..3019fc0231 --- /dev/null +++ b/tactics/eauto.ml @@ -0,0 +1,520 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Names +open Constr +open Termops +open EConstr +open Tacticals +open Tacmach +open Evd +open Tactics +open Clenv +open Auto +open Genredexpr +open Tactypes +open Locus +open Locusops +open Hints +open Proofview.Notations + +let eauto_unif_flags = auto_flags_of_state TransparentState.full + +let e_give_exact ?(flags=eauto_unif_flags) c = + Proofview.Goal.enter begin fun gl -> + let t1 = Tacmach.New.pf_unsafe_type_of gl c in + let t2 = Tacmach.New.pf_concl gl in + let sigma = Tacmach.New.project gl in + if occur_existential sigma t1 || occur_existential sigma t2 then + Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) + else exact_check c + end + +let assumption id = e_give_exact (mkVar id) + +let e_assumption = + Proofview.Goal.enter begin fun gl -> + Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl)) + end + +let registered_e_assumption = + Proofview.Goal.enter begin fun gl -> + Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) + (Tacmach.New.pf_ids_of_hyps gl)) + end + +(************************************************************************) +(* PROLOG tactic *) +(************************************************************************) + +(*s Tactics handling a list of goals. *) + +(* first_goal : goal list sigma -> goal sigma *) + +let first_goal gls = + let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in + if List.is_empty gl then user_err Pp.(str "first_goal"); + { Evd.it = List.hd gl; Evd.sigma = sig_0; } + +(* tactic -> tactic_list : Apply a tactic to the first goal in the list *) + +let apply_tac_list tac glls = + match glls.it with + | (g1::rest) -> + let pack = tac (re_sig g1 glls.sigma) in + re_sig (pack.it @ rest) pack.sigma + | _ -> user_err Pp.(str "apply_tac_list") + +let one_step l gl = + [Proofview.V82.of_tactic Tactics.intro] + @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl))) + @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l) + @ (List.map (fun c -> Proofview.V82.of_tactic (assumption c)) (pf_ids_of_hyps gl)) + +let rec prolog l n gl = + if n <= 0 then user_err Pp.(str "prolog - failure"); + let prol = (prolog l (n-1)) in + (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl + +let out_term env = function + | IsConstr (c, _) -> c + | IsGlobRef gr -> EConstr.of_constr (fst (UnivGen.fresh_global_instance env gr)) + +let prolog_tac l n = + Proofview.V82.tactic begin fun gl -> + let map c = + let (sigma, c) = c (pf_env gl) (project gl) in + let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in + out_term (pf_env gl) c + in + let l = List.map map l in + try (prolog l n gl) + with UserError (Some "Refiner.tclFIRST",_) -> + user_err ~hdr:"Prolog.prolog" (str "Prolog failed.") + end + +open Auto + +(***************************************************************************) +(* 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.enter begin fun gl -> + let clenv', c = connect_hint_clenv poly c clenv gl in + let clenv' = clenv_unique_resolver ~flags clenv' gl in + Proofview.tclTHEN + (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) + (Tactics.Simple.eapply c) + end + +let hintmap_of sigma secvars hdc concl = + match hdc with + | None -> fun db -> Hint_db.map_none ~secvars db + | Some hdc -> + if occur_existential sigma concl then + (fun db -> Hint_db.map_existential sigma ~secvars hdc concl db) + else (fun db -> Hint_db.map_auto sigma ~secvars hdc concl db) + (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) + +let e_exact poly flags (c,clenv) = + Proofview.Goal.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.enter begin fun gl -> + let d = Tacmach.New.pf_last_hyp gl in + let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in + 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 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 (Tacmach.New.pf_env gl) (Tacmach.New.project gl) db_list local_db secvars (Tacmach.New.pf_concl gl))) + in + Tacticals.New.tclSOLVE tacl + end + +and e_my_find_search env sigma db_list local_db secvars hdc concl = + let hint_of_db = hintmap_of sigma secvars hdc concl in + let hintl = + List.map_append (fun db -> + let flags = auto_flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> flags, x) (hint_of_db db)) (local_db::db_list) + in + let tac_of_hint = + fun (st, {pri = b; pat = p; code = t; poly = poly}) -> + let b = match Hints.repr_hint t with + | Unfold_nth _ -> 1 + | _ -> b + in + (b, + let tac = function + | Res_pf (term,cl) -> unify_resolve poly st (term,cl) + | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) + | Give_exact (c,cl) -> e_exact poly st (c,cl) + | Res_pf_THEN_trivial_fail (term,cl) -> + Tacticals.New.tclTHEN (unify_e_resolve poly st (term,cl)) + (e_trivial_fail_db db_list local_db) + | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl + | Extern tacast -> conclPattern concl p tacast + in + let tac = run_hint t tac in + (tac, lazy (pr_hint env sigma t))) + in + List.map tac_of_hint hintl + +and e_trivial_resolve env sigma db_list local_db secvars gl = + let hd = try Some (decompose_app_bound sigma gl) with Bound -> None in + try priority (e_my_find_search env sigma db_list local_db secvars hd gl) + with Not_found -> [] + +let e_possible_resolve env sigma db_list local_db secvars gl = + let hd = try Some (decompose_app_bound sigma gl) with Bound -> None in + try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) + (e_my_find_search env sigma db_list local_db secvars hd gl) + with Not_found -> [] + +let find_first_goal gls = + try first_goal gls with UserError _ -> assert false + +(*s The following module [SearchProblem] is used to instantiate the generic + exploration functor [Explore.Make]. *) + +type search_state = { + priority : int; + depth : int; (*r depth of search before failing *) + tacres : Goal.goal list sigma; + last_tactic : Pp.t Lazy.t; + dblist : hint_db list; + localdb : hint_db list; + prev : prev_search_state; + local_lemmas : delayed_open_constr list; +} + +and prev_search_state = (* for info eauto *) + | Unknown + | Init + | State of search_state + +module SearchProblem = struct + + type state = search_state + + let success s = List.is_empty (sig_it s.tacres) + +(* let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) *) + + let filter_tactics glls l = +(* let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) +(* let evars = Evarutil.nf_evars (Refiner.project glls) in *) +(* msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *) + let rec aux = function + | [] -> [] + | (tac, cost, pptac) :: tacl -> + try + let lgls = apply_tac_list (Proofview.V82.of_tactic tac) glls in +(* 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 CErrors.noncritical e -> + let e = CErrors.push e in + Refiner.catch_failerror e; aux tacl + in aux l + + (* Ordering of states is lexicographic on depth (greatest first) then + number of remaining goals. *) + let compare s s' = + let d = s'.depth - s.depth in + let d' = Int.compare s.priority s'.priority in + let nbgoals s = List.length (sig_it s.tacres) in + if not (Int.equal d 0) then d + else if not (Int.equal d' 0) then d' + else Int.compare (nbgoals s) (nbgoals s') + + let branching s = + if Int.equal s.depth 0 then + [] + else + let ps = if s.prev == Unknown then Unknown else State s in + let lg = s.tacres in + 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 () ++ Id.print id)) in + let assumption_tacs = + 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; + localdb = List.tl s.localdb; + prev = ps; local_lemmas = s.local_lemmas}) l + in + let intro_tac = + let l = filter_tactics s.tacres [Tactics.intro, (-1), lazy (str "intro")] in + List.map + (fun (lgls, cost, pp) -> + let g' = first_goal lgls in + let hintl = + make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') + in + let ldb = Hint_db.add_list (pf_env g') (project g') + hintl (List.hd s.localdb) in + { depth = s.depth; priority = cost; tacres = lgls; + last_tactic = pp; dblist = s.dblist; + localdb = ldb :: List.tl s.localdb; prev = ps; + local_lemmas = s.local_lemmas}) + l + in + let rec_tacs = + let l = + let concl = Reductionops.nf_evar (project g) (pf_concl g) in + filter_tactics s.tacres + (e_possible_resolve (pf_env g) (project g) s.dblist (List.hd s.localdb) secvars concl) + in + List.map + (fun (lgls, cost, pp) -> + let nbgl' = List.length (sig_it lgls) in + if nbgl' < nbgl then + { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; + prev = ps; dblist = s.dblist; localdb = List.tl s.localdb; + local_lemmas = s.local_lemmas } + else + let newlocal = + let hyps = pf_hyps g in + List.map (fun gl -> + let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in + let hyps' = pf_hyps gls in + if hyps' == hyps then List.hd s.localdb + else make_local_hint_db (pf_env gls) (project gls) ~ts:TransparentState.full true s.local_lemmas) + (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) + in + { depth = pred s.depth; priority = cost; tacres = lgls; + dblist = s.dblist; last_tactic = pp; prev = ps; + localdb = newlocal @ List.tl s.localdb; + local_lemmas = s.local_lemmas }) + l + in + List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) + + let pp s = hov 0 (str " depth=" ++ int s.depth ++ spc () ++ + (Lazy.force s.last_tactic)) + +end + +module Search = Explore.Make(SearchProblem) + +(** Utilities for debug eauto / info eauto *) + +let global_debug_eauto = ref false +let global_info_eauto = ref false + +let () = + Goptions.(declare_bool_option + { optdepr = false; + optname = "Debug Eauto"; + optkey = ["Debug";"Eauto"]; + optread = (fun () -> !global_debug_eauto); + optwrite = (:=) global_debug_eauto }) + +let () = + Goptions.(declare_bool_option + { optdepr = false; + optname = "Info Eauto"; + optkey = ["Info";"Eauto"]; + optread = (fun () -> !global_info_eauto); + optwrite = (:=) global_info_eauto }) + +let mk_eauto_dbg d = + if d == Debug || !global_debug_eauto then Debug + else if d == Info || !global_info_eauto then Info + else Off + +let pr_info_nop = function + | Info -> Feedback.msg_info (str "idtac.") + | _ -> () + +let pr_dbg_header = function + | Off -> () + | Debug -> Feedback.msg_debug (str "(* debug eauto: *)") + | Info -> Feedback.msg_info (str "(* info eauto: *)") + +let pr_info dbg s = + if dbg != Info then () + else + let rec loop s = + match s.prev with + | Unknown | Init -> s.depth + | State sp -> + let mindepth = loop sp in + let indent = String.make (mindepth - sp.depth) ' ' in + Feedback.msg_info (str indent ++ Lazy.force s.last_tactic ++ str "."); + mindepth + in + ignore (loop s) + +(** Eauto main code *) + +let make_initial_state dbg n gl dblist localdb lems = + { depth = n; + priority = 0; + tacres = tclIDTAC gl; + last_tactic = lazy (mt()); + dblist = dblist; + localdb = [localdb]; + prev = if dbg == Info then Init else Unknown; + local_lemmas = lems; + } + +let e_search_auto debug (in_depth,p) lems db_list gl = + let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:TransparentState.full true lems in + let d = mk_eauto_dbg debug in + let tac = match in_depth,d with + | (true,Debug) -> Search.debug_depth_first + | (true,_) -> Search.depth_first + | (false,Debug) -> Search.debug_breadth_first + | (false,_) -> Search.breadth_first + in + try + pr_dbg_header d; + let s = tac (make_initial_state d p gl db_list local_db lems) in + pr_info d s; + s.tacres + with Not_found -> + pr_info_nop d; + user_err Pp.(str "eauto: search failed") + +(* let e_search_auto_key = CProfile.declare_profile "e_search_auto" *) +(* let e_search_auto = CProfile.profile5 e_search_auto_key e_search_auto *) + +let eauto_with_bases ?(debug=Off) np lems db_list = + Proofview.V82.of_tactic (Hints.wrap_hint_warning (Proofview.V82.tactic (tclTRY (e_search_auto debug np lems db_list)))) + +let eauto ?(debug=Off) np lems dbnames = + let db_list = make_db_list dbnames in + tclTRY (e_search_auto debug np lems db_list) + +let full_eauto ?(debug=Off) n lems gl = + 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 + | None -> Hints.wrap_hint_warning (Proofview.V82.tactic (full_eauto ~debug np lems)) + | Some l -> Hints.wrap_hint_warning (Proofview.V82.tactic (eauto ~debug np lems l)) + +let make_depth = function + | None -> !default_search_depth + | Some d -> d + +let make_dimension n = function + | None -> (true,make_depth n) + | Some d -> (false,d) + +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 -> 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 + let ids = Id.Set.filter (fun id -> List.mem id hyps) ids in + Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts + (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) + in Proofview.V82.of_tactic (unfold_option unfolds cls) gl + +let autounfold db cls = + Proofview.V82.tactic begin fun gl -> + let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in + let tac = autounfolds db in + tclMAP (function + | OnHyp (id,occs,where) -> tac occs (Some (id,where)) + | OnConcl occs -> tac occs None) + cls gl + end + +let autounfold_tac db cls = + Proofview.tclUNIT () >>= fun () -> + let dbs = match db with + | None -> String.Set.elements (current_db_names ()) + | Some [] -> ["core"] + | Some l -> l + in + autounfold dbs cls + +let unfold_head env sigma (ids, csts) c = + let rec aux c = + match EConstr.kind sigma c with + | Var id when Id.Set.mem id ids -> + (match Environ.named_body id env with + | Some b -> true, EConstr.of_constr b + | None -> false, c) + | Const (cst, u) when Cset.mem cst csts -> + let u = EInstance.kind sigma u in + true, EConstr.of_constr (Environ.constant_value_in env (cst, u)) + | App (f, args) -> + (match aux f with + | true, f' -> true, Reductionops.whd_betaiota sigma (mkApp (f', args)) + | false, _ -> + let done_, args' = + Array.fold_left_i (fun i (done_, acc) arg -> + if done_ then done_, arg :: acc + else match aux arg with + | true, arg' -> true, arg' :: acc + | false, arg' -> false, arg :: acc) + (false, []) args + in + if done_ then true, mkApp (f, Array.of_list (List.rev args')) + else false, c) + | _ -> + let done_ = ref false in + let c' = EConstr.map sigma (fun c -> + if !done_ then c else + let x, c' = aux c in + done_ := x; c') c + in !done_, c' + in aux c + +let autounfold_one db cl = + Proofview.Goal.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 st = + List.fold_left (fun (i,c) dbname -> + let db = try searchtable_map 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 + in + let did, c' = unfold_head env sigma st + (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) + in + if did then + match cl with + | Some hyp -> change_in_hyp None (make_change_arg c') hyp + | None -> convert_concl_no_check c' DEFAULTcast + else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") + end diff --git a/tactics/eauto.mli b/tactics/eauto.mli new file mode 100644 index 0000000000..5aa2f42de1 --- /dev/null +++ b/tactics/eauto.mli @@ -0,0 +1,35 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open EConstr +open Hints +open Tactypes + +val e_assumption : unit Proofview.tactic + +val registered_e_assumption : unit Proofview.tactic + +val e_give_exact : ?flags:Unification.unify_flags -> constr -> unit Proofview.tactic + +val prolog_tac : delayed_open_constr list -> int -> unit Proofview.tactic + +val gen_eauto : ?debug:debug -> bool * int -> delayed_open_constr list -> + hint_db_name list option -> unit Proofview.tactic + +val eauto_with_bases : + ?debug:debug -> + bool * int -> + delayed_open_constr list -> hint_db list -> Proofview.V82.tac + +val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic +val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic +val autounfold_one : hint_db_name list -> Locus.hyp_location option -> unit Proofview.tactic + +val make_dimension : int option -> int option -> bool * int diff --git a/tactics/elim.ml b/tactics/elim.ml new file mode 100644 index 0000000000..003b069b6e --- /dev/null +++ b/tactics/elim.ml @@ -0,0 +1,176 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Names +open Termops +open EConstr +open Inductiveops +open Hipattern +open Tacmach.New +open Tacticals.New +open Tactics +open Proofview.Notations + +module NamedDecl = Context.Named.Declaration + +(* Supposed to be called without as clause *) +let introElimAssumsThen tac ba = + assert (ba.Tacticals.branchnames == []); + let introElimAssums = tclDO ba.Tacticals.nassums intro in + (tclTHEN introElimAssums (elim_on_ba tac ba)) + +(* Supposed to be called with a non-recursive scheme *) +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 with_evars l1) (intros_clearing l3) in + (tclTHEN introCaseAssums (case_on_ba (tac l2) ba)) + +(* The following tactic Decompose repeatedly applies the + elimination(s) rule(s) of the types satisfying the predicate + ``recognizer'' onto a certain hypothesis. For example : + +Require Elim. +Require Le. + Goal (y:nat){x:nat | (le O x)/\(le x y)}->{x:nat | (le O x)}. + Intros y H. + Decompose [sig and] H;EAuto. + Qed. + +Another example : + + Goal (A,B,C:Prop)(A/\B/\C \/ B/\C \/ C/\A) -> C. + Intros A B C H; Decompose [and or] H; Assumption. + Qed. +*) + +let elimHypThen tac id = + elimination_then tac (mkVar id) + +let rec general_decompose_on_hyp recognizer = + ifOnHyp recognizer (general_decompose_aux recognizer) (fun _ -> Proofview.tclUNIT()) + +and general_decompose_aux recognizer id = + elimHypThen + (introElimAssumsThen + (fun bas -> + tclTHEN (clear [id]) + (tclMAP (general_decompose_on_hyp recognizer) + (ids_of_named_context bas.Tacticals.assums)))) + id + +(* We should add a COMPLETE to be sure that the created hypothesis + doesn't stay if no elimination is possible *) + +(* Best strategies but loss of compatibility *) +let tmphyp_name = Id.of_string "_TmpHyp" +let up_to_delta = ref false (* true *) + +let general_decompose recognizer c = + Proofview.Goal.enter begin fun gl -> + let type_of = pf_unsafe_type_of gl in + let sigma = project gl in + let typc = type_of c in + tclTHENS (cut typc) + [ tclTHEN (intro_using tmphyp_name) + (onLastHypId + (ifOnHyp (recognizer sigma) (general_decompose_aux (recognizer sigma)) + (fun id -> clear [id]))); + exact_no_check c ] + end + +let head_in indl t gl = + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + try + let ity,_ = + if !up_to_delta + then find_mrectype env sigma t + else extract_mrectype sigma t + in List.exists (fun i -> eq_ind (fst i) (fst ity)) indl + with Not_found -> false + +let decompose_these c l = + Proofview.Goal.enter begin fun gl -> + let indl = List.map (fun x -> x, Univ.Instance.empty) l in + general_decompose (fun sigma (_,t) -> head_in indl t gl) c + end + +let decompose_and c = + general_decompose + (fun sigma (_,t) -> is_record sigma t) + c + +let decompose_or c = + general_decompose + (fun sigma (_,t) -> is_disjunction sigma t) + c + +let h_decompose l c = decompose_these c l + +let h_decompose_or = decompose_or + +let h_decompose_and = decompose_and + +(* The tactic Double performs a double induction *) + +let simple_elimination c = + elimination_then (fun _ -> tclIDTAC) c + +let induction_trailer abs_i abs_j bargs = + tclTHEN + (tclDO (abs_j - abs_i) intro) + (onLastHypId + (fun id -> + Proofview.Goal.enter begin fun gl -> + let idty = pf_unsafe_type_of gl (mkVar id) in + let fvty = global_vars (pf_env gl) (project gl) idty in + let possible_bring_hyps = + (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums + in + let (hyps,_) = + List.fold_left + (fun (bring_ids,leave_ids) d -> + 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)) + ([],fvty) possible_bring_hyps + in + let ids = List.rev (ids_of_named_context hyps) in + (tclTHENLIST + [revert ids; simple_elimination (mkVar id)]) + end + )) + +let double_ind h1 h2 = + Proofview.Goal.enter begin fun gl -> + let abs_i = depth_of_quantified_hypothesis true h1 gl in + let abs_j = depth_of_quantified_hypothesis true h2 gl in + let abs = + if abs_i < abs_j then Proofview.tclUNIT (abs_i,abs_j) else + if abs_i > abs_j then Proofview.tclUNIT (abs_j,abs_i) else + tclZEROMSG (Pp.str "Both hypotheses are the same.") in + abs >>= fun (abs_i,abs_j) -> + (tclTHEN (tclDO abs_i intro) + (onLastHypId + (fun id -> + elimination_then + (introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id)))) + end + +let h_double_induction = double_ind + + diff --git a/tactics/elim.mli b/tactics/elim.mli new file mode 100644 index 0000000000..ddfac3f2cd --- /dev/null +++ b/tactics/elim.mli @@ -0,0 +1,25 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open EConstr +open Tacticals +open Tactypes + +(** Eliminations tactics. *) + +val introCaseAssumsThen : Tactics.evars_flag -> + (intro_patterns -> branch_assumptions -> unit Proofview.tactic) -> + branch_args -> unit Proofview.tactic + +val h_decompose : inductive list -> constr -> unit Proofview.tactic +val h_decompose_or : constr -> unit Proofview.tactic +val h_decompose_and : constr -> unit Proofview.tactic +val h_double_induction : quantified_hypothesis -> quantified_hypothesis-> unit Proofview.tactic diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml new file mode 100644 index 0000000000..3b69d9922d --- /dev/null +++ b/tactics/elimschemes.ml @@ -0,0 +1,130 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Created by Hugo Herbelin from contents related to inductive schemes + initially developed by Christine Paulin (induction schemes), Vincent + Siles (decidable equality and boolean equality) and Matthieu Sozeau + (combined scheme) in file command.ml, Sep 2009 *) + +(* This file builds schemes related to case analysis and recursion schemes *) + +open Sorts +open Constr +open Indrec +open Declarations +open Typeops +open Ind_tables + +(* Induction/recursion schemes *) + +let optimize_non_type_induction_scheme kind dep sort _ ind = + let env = Global.env () in + let sigma = Evd.from_env env in + if check_scheme kind ind then + (* in case the inductive has a type elimination, generates only one + induction scheme, the other ones share the same code with the + apropriate type *) + let cte, eff = find_scheme kind ind in + let sigma, cte = Evd.fresh_constant_instance env sigma cte in + let c = mkConstU cte in + let t = type_of_constant_in (Global.env()) cte in + let (mib,mip) = Global.lookup_inductive ind in + let npars = + (* if a constructor of [ind] contains a recursive call, the scheme + is generalized only wrt recursively uniform parameters *) + if (Inductiveops.mis_is_recursive_subset [snd ind] mip.mind_recargs) + then + mib.mind_nparams_rec + else + mib.mind_nparams in + let sigma, sort = Evd.fresh_sort_in_family sigma sort in + let sigma, t', c' = weaken_sort_scheme env sigma false sort npars c t in + let sigma = Evd.minimize_universes sigma in + (Evarutil.nf_evars_universes sigma c', Evd.evar_universe_context sigma), eff + else + let sigma, pind = Evd.fresh_inductive_instance env sigma ind in + let sigma, c = build_induction_scheme env sigma pind 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 sigma, pind = Evd.fresh_inductive_instance env sigma ind in + let sigma, c = build_induction_scheme env sigma pind dep sort in + c, Evd.evar_universe_context sigma + +let rect_scheme_kind_from_type = + declare_individual_scheme_object "_rect_nodep" + (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) + +let rect_scheme_kind_from_prop = + declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop" + (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) + +let rect_dep_scheme_kind_from_type = + declare_individual_scheme_object "_rect" ~aux:"_rect_from_type" + (fun _ x -> build_induction_scheme_in_type true InType x, Safe_typing.empty_private_constants) + +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_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_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) + +let ind_scheme_kind_from_type = + declare_individual_scheme_object "_ind_nodep" + (optimize_non_type_induction_scheme rec_scheme_kind_from_type false InProp) + +let ind_dep_scheme_kind_from_type = + declare_individual_scheme_object "_ind" ~aux:"_ind_from_type" + (optimize_non_type_induction_scheme rec_dep_scheme_kind_from_type true InProp) + +let ind_scheme_kind_from_prop = + declare_individual_scheme_object "_ind" ~aux:"_ind_from_prop" + (optimize_non_type_induction_scheme rec_scheme_kind_from_prop false InProp) + +(* Case analysis *) + +let build_case_analysis_scheme_in_type dep sort ind = + let env = Global.env () in + let sigma = Evd.from_env env in + let (sigma, indu) = Evd.fresh_inductive_instance env sigma ind in + let (sigma, c) = build_case_analysis_scheme env sigma indu dep sort in + c, Evd.evar_universe_context sigma + +let case_scheme_kind_from_type = + declare_individual_scheme_object "_case_nodep" + (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) + +let case_scheme_kind_from_prop = + declare_individual_scheme_object "_case" ~aux:"_case_from_prop" + (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) + +let case_dep_scheme_kind_from_type = + declare_individual_scheme_object "_case" ~aux:"_case_from_type" + (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) + +let case_dep_scheme_kind_from_type_in_prop = + declare_individual_scheme_object "_casep_dep" + (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) + +let case_dep_scheme_kind_from_prop = + declare_individual_scheme_object "_case_dep" + (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) + +let case_dep_scheme_kind_from_prop_in_prop = + declare_individual_scheme_object "_casep" + (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli new file mode 100644 index 0000000000..ece4124b8b --- /dev/null +++ b/tactics/elimschemes.mli @@ -0,0 +1,41 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Ind_tables + +(** Induction/recursion schemes *) + +val optimize_non_type_induction_scheme : + 'a Ind_tables.scheme_kind -> + Indrec.dep_flag -> + Sorts.family -> + 'b -> + Names.inductive -> + (Constr.constr * UState.t) * Safe_typing.private_constants + +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 + + +(** Case analysis schemes *) + +val case_scheme_kind_from_type : individual scheme_kind +val case_scheme_kind_from_prop : individual scheme_kind +val case_dep_scheme_kind_from_type : individual scheme_kind +val case_dep_scheme_kind_from_type_in_prop : individual scheme_kind +val case_dep_scheme_kind_from_prop : individual scheme_kind +val case_dep_scheme_kind_from_prop_in_prop : individual scheme_kind diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml new file mode 100644 index 0000000000..6388aa2c33 --- /dev/null +++ b/tactics/eqdecide.ml @@ -0,0 +1,282 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(************************************************************************) +(* EqDecide *) +(* A tactic for deciding propositional equality on inductive types *) +(* by Eduardo Gimenez *) +(************************************************************************) + +open Util +open Names +open Namegen +open Constr +open EConstr +open Declarations +open Tactics +open Tacticals.New +open Auto +open Constr_matching +open Hipattern +open Proofview.Notations +open Tacmach.New +open Tactypes + +(* This file containts the implementation of the tactics ``Decide + Equality'' and ``Compare''. They can be used to decide the + propositional equality of two objects that belongs to a small + inductive datatype --i.e., an inductive set such that all the + arguments of its constructors are non-functional sets. + + The procedure for proving (x,y:R){x=y}+{~x=y} can be scketched as + follows: + 1. Eliminate x and then y. + 2. Try discrimination to solve those goals where x and y has + been introduced by different constructors. + 3. If x and y have been introduced by the same constructor, + then analyse one by one the corresponding pairs of arguments. + If they are equal, rewrite one into the other. If they are + not, derive a contradiction from the injectiveness of the + constructor. + 4. Once all the arguments have been rewritten, solve the remaining half + of the disjunction by reflexivity. + + Eduardo Gimenez (30/3/98). +*) + +let clear_last = + Proofview.tclEVARMAP >>= fun sigma -> + (onLastHyp (fun c -> (clear [destVar sigma c]))) + +let choose_eq eqonleft = + if eqonleft then + left_with_bindings false NoBindings + else + right_with_bindings false NoBindings +let choose_noteq eqonleft = + if eqonleft then + right_with_bindings false NoBindings + else + left_with_bindings false NoBindings + +(* A surgical generalize which selects the right occurrences by hand *) +(* This prevents issues where c2 is also a subterm of c1 (see e.g. #5449) *) + +let generalize_right mk typ c1 c2 = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + Refine.refine ~typecheck:false begin fun sigma -> + let na = Name (next_name_away_with_default "x" Anonymous (Termops.vars_of_env env)) in + let newconcl = mkProd (na, typ, mk typ c1 (mkRel 1)) in + let (sigma, x) = Evarutil.new_evar env sigma ~principal:true newconcl in + (sigma, mkApp (x, [|c2|])) + end + end + +let mkBranches (eqonleft,mk,c1,c2,typ) = + tclTHENLIST + [generalize_right mk typ c1 c2; + Simple.elim c1; + intros; + onLastHyp Simple.case; + clear_last; + intros] + +let inj_flags = Some { + Equality.keep_proof_equalities = true; (* necessary *) + Equality.injection_in_context = true; (* does not matter here *) + Equality.injection_pattern_l2r_order = true; (* does not matter here *) + } + +let discrHyp id = + let c env sigma = (sigma, (mkVar id, NoBindings)) in + let tac c = Equality.discr_tac false (Some (None, ElimOnConstr c)) in + Tacticals.New.tclDELAYEDWITHHOLES false c tac + +let solveNoteqBranch side = + tclTHEN (choose_noteq side) + (tclTHEN introf + (onLastHypId (fun id -> discrHyp id))) + +(* Constructs the type {c1=c2}+{~c1=c2} *) + +let mkDecideEqGoal eqonleft (op,eq,neg) rectype c1 c2 = + let equality = mkApp(eq, [|rectype; c1; c2|]) in + let disequality = mkApp(neg, [|equality|]) in + if eqonleft then mkApp(op, [|equality; disequality |]) + else mkApp(op, [|disequality; equality |]) + + +(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *) + +let idx = Id.of_string "x" +let idy = Id.of_string "y" + +let mkGenDecideEqGoal rectype ops g = + let hypnames = pf_ids_set_of_hyps g in + let xname = next_ident_away idx hypnames + and yname = next_ident_away idy hypnames in + (mkNamedProd xname rectype + (mkNamedProd yname rectype + (mkDecideEqGoal true ops + rectype (mkVar xname) (mkVar yname)))) + +let rec rewrite_and_clear hyps = match hyps with +| [] -> Proofview.tclUNIT () +| id :: hyps -> + tclTHENLIST [ + Equality.rewriteLR (mkVar id); + clear [id]; + rewrite_and_clear hyps; + ] + +let eqCase tac = + tclTHEN intro (onLastHypId tac) + +let injHyp id = + let c env sigma = (sigma, (mkVar id, NoBindings)) in + let tac c = Equality.injClause inj_flags None false (Some (None, ElimOnConstr c)) in + Tacticals.New.tclDELAYEDWITHHOLES false c tac + +let diseqCase hyps eqonleft = + let diseq = Id.of_string "diseq" in + let absurd = Id.of_string "absurd" in + (tclTHEN (intro_using diseq) + (tclTHEN (choose_noteq eqonleft) + (tclTHEN (rewrite_and_clear (List.rev hyps)) + (tclTHEN (red_in_concl) + (tclTHEN (intro_using absurd) + (tclTHEN (Simple.apply (mkVar diseq)) + (tclTHEN (injHyp absurd) + (full_trivial [])))))))) + +open Proofview.Notations + +(* spiwack: a PatternMatchingFailure wrapper around [Hipattern]. *) + +let match_eqdec env sigma c = + try + let (eqonleft,_,c1,c2,ty) = match_eqdec env sigma c in + let (op,eq1,noteq,eq2) = + match EConstr.kind sigma c with + | App (op,[|ty1;ty2|]) -> + let ty1, ty2 = if eqonleft then ty1, ty2 else ty2, ty1 in + (match EConstr.kind sigma ty1, EConstr.kind sigma ty2 with + | App (eq1,_), App (noteq,[|neq|]) -> + (match EConstr.kind sigma neq with + | App (eq2,_) -> op,eq1,noteq,eq2 + | _ -> assert false) + | _ -> assert false) + | _ -> assert false in + let mk t x y = + let eq = mkApp (eq1,[|t;x;y|]) in + let neq = mkApp (noteq,[|mkApp (eq2,[|t;x;y|])|]) in + if eqonleft then mkApp (op,[|eq;neq|]) else mkApp (op,[|neq;eq|]) in + Proofview.tclUNIT (eqonleft,mk,c1,c2,ty) + with PatternMatchingFailure -> Proofview.tclZERO PatternMatchingFailure + +(* /spiwack *) + +let rec solveArg hyps eqonleft mk largs rargs = match largs, rargs with +| [], [] -> + tclTHENLIST [ + choose_eq eqonleft; + rewrite_and_clear (List.rev hyps); + intros_reflexivity; + ] +| a1 :: largs, a2 :: rargs -> + Proofview.Goal.enter begin fun gl -> + let rectype = pf_unsafe_type_of gl a1 in + let decide = mk rectype a1 a2 in + let tac hyp = solveArg (hyp :: hyps) eqonleft mk largs rargs in + let subtacs = + if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto] + else [diseqCase hyps eqonleft;eqCase tac;default_auto] in + (tclTHENS (elim_type decide) subtacs) + end +| _ -> invalid_arg "List.fold_right2" + +let solveEqBranch rectype = + Proofview.tclORELSE + begin + Proofview.Goal.enter begin fun gl -> + let concl = pf_concl gl in + let env = Proofview.Goal.env gl in + let sigma = project gl in + match_eqdec env sigma concl >>= fun (eqonleft,mk,lhs,rhs,_) -> + let (mib,mip) = Global.lookup_inductive rectype in + let nparams = mib.mind_nparams in + let getargs l = List.skipn nparams (snd (decompose_app sigma l)) in + let rargs = getargs rhs + and largs = getargs lhs in + + solveArg [] eqonleft mk largs rargs + end + end + begin function (e, info) -> match e with + | PatternMatchingFailure -> Tacticals.New.tclZEROMSG (Pp.str"Unexpected conclusion!") + | e -> Proofview.tclZERO ~info e + end + +(* The tactic Decide Equality *) + +let hd_app sigma c = match EConstr.kind sigma c with + | App (h,_) -> h + | _ -> c + +let decideGralEquality = + Proofview.tclORELSE + begin + Proofview.Goal.enter begin fun gl -> + let concl = pf_concl gl in + let env = Proofview.Goal.env gl in + let sigma = project gl in + match_eqdec env sigma concl >>= fun (eqonleft,mk,c1,c2,typ as data) -> + let headtyp = hd_app sigma (pf_compute gl typ) in + begin match EConstr.kind sigma headtyp with + | Ind (mi,_) -> Proofview.tclUNIT mi + | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.") + end >>= fun rectype -> + (tclTHEN + (mkBranches data) + (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype))) + end + end + begin function (e, info) -> match e with + | PatternMatchingFailure -> + Tacticals.New.tclZEROMSG (Pp.str"The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}.") + | e -> Proofview.tclZERO ~info e + end + +let decideEqualityGoal = tclTHEN intros decideGralEquality + +let decideEquality rectype ops = + Proofview.Goal.enter begin fun gl -> + let decide = mkGenDecideEqGoal rectype ops gl in + (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) + end + + +(* The tactic Compare *) + +let compare c1 c2 = + let open Coqlib in + pf_constr_of_global (lib_ref "core.sumbool.type") >>= fun opc -> + pf_constr_of_global (lib_ref "core.eq.type") >>= fun eqc -> + pf_constr_of_global (lib_ref "core.not.type") >>= fun notc -> + Proofview.Goal.enter begin fun gl -> + let rectype = pf_unsafe_type_of gl c1 in + let ops = (opc,eqc,notc) in + let decide = mkDecideEqGoal true ops rectype c1 c2 in + (tclTHENS (cut decide) + [(tclTHEN intro + (tclTHEN (onLastHyp simplest_case) clear_last)); + decideEquality rectype ops]) + end diff --git a/tactics/eqdecide.mli b/tactics/eqdecide.mli new file mode 100644 index 0000000000..1e898d427b --- /dev/null +++ b/tactics/eqdecide.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(************************************************************************) +(* EqDecide *) +(* A tactic for deciding propositional equality on inductive types *) +(* by Eduardo Gimenez *) +(************************************************************************) + +val decideEqualityGoal : unit Proofview.tactic + +val compare : EConstr.t -> EConstr.t -> unit Proofview.tactic diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml new file mode 100644 index 0000000000..b12018cd66 --- /dev/null +++ b/tactics/eqschemes.ml @@ -0,0 +1,824 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* File created by Hugo Herbelin, Nov 2009 *) + +(* This file builds schemes related to equality inductive types, + especially for dependent rewrite, rewriting on arbitrary equality + types and congruence on arbitrary equality types *) + +(* However, the choices made lack uniformity, as we have to make a + compromise between several constraints and ideal requirements: + + - Having the extended schemes working conservatively over the + existing non-dependent schemes eq_rect and eq_rect_r. There is in + particular a problem with the dependent rewriting schemes in + hypotheses for which the inductive types cannot be in last + position of the scheme as it is the general rule in Coq. This has + an effect on the order of generated goals (side-conditions of the + lemma after or before the main goal). The non-dependent case can be + fixed but to the price of a lost of uniformity wrt side-conditions + in the dependent and non-dependent cases. + + - Having schemes general enough to support non-symmetric equality + type like eq_true. + + - Having schemes that avoid introducing beta-expansions blocked by + "match" so as to please the guard condition, but this introduces + some tricky things involving involutivity of symmetry that I + don't how to avoid. The result below is a compromise with + dependent left-to-right rewriting in conclusion (l2r_dep) using + the tricky involutivity of symmetry and dependent left-to-right + rewriting in hypotheses (r2l_forward_dep), that one wants to be + used for non-symmetric equality and that introduces blocked + beta-expansions. + + One may wonder whether these extensions are worth to be done + regarding the price we have to pay and regarding the rare + situations where they are needed. However, I believe it meets a + natural expectation of the user. +*) + +open CErrors +open Util +open Names +open Term +open Constr +open Vars +open Declarations +open Environ +open Inductive +open Termops +open Namegen +open Inductiveops +open Ind_tables +open Indrec +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 +let fresh env id = next_global_ident_away id Id.Set.empty +let with_context_set ctx (b, ctx') = + (b, Univ.ContextSet.union ctx ctx') + +let build_dependent_inductive ind (mib,mip) = + let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in + applist + (mkIndU ind, + Context.Rel.to_extended_list mkRel mip.mind_nrealdecls mib.mind_params_ctxt + @ Context.Rel.to_extended_list mkRel 0 realargs) + +let named_hd env t na = named_hd env (Evd.from_env env) (EConstr.of_constr t) na +let name_assumption env = function +| LocalAssum (na,t) -> LocalAssum (named_hd env t na, t) +| LocalDef (na,c,t) -> LocalDef (named_hd env c na, c, t) + +let name_context env hyps = + snd + (List.fold_left + (fun (env,hyps) d -> + let d' = name_assumption env d in (push_rel d' env, d' :: hyps)) + (env,[]) (List.rev hyps)) + +let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn c s +let my_it_mkProd_or_LetIn s c = Term.it_mkProd_or_LetIn c s +let my_it_mkLambda_or_LetIn_name s c = + let env = Global.env () in + let mkLambda_or_LetIn_name d b = mkLambda_or_LetIn (name_assumption env d) b in + List.fold_left (fun c d -> mkLambda_or_LetIn_name d c) c s + +let get_coq_eq ctx = + try + let eq = Globnames.destIndRef (Coqlib.lib_ref "core.eq.type") in + (* Do not force the lazy if they are not defined *) + let eq, ctx = with_context_set ctx + (UnivGen.fresh_inductive_instance (Global.env ()) eq) in + mkIndU eq, mkConstructUi (eq,1), ctx + with Not_found -> + user_err Pp.(str "eq not found.") + +let univ_of_eq env eq = + let open EConstr in + let eq = of_constr eq in + let sigma = Evd.from_env env in + match kind sigma (Retyping.get_type_of env sigma eq) with + | Prod (_,t,_) -> (match kind sigma t with + Sort k -> + (match ESorts.kind sigma k with Type u -> u | _ -> assert false) + | _ -> assert false) + | _ -> assert false + +(**********************************************************************) +(* Check if an inductive type [ind] has the form *) +(* *) +(* I q1..qm,p1..pn a1..an with one constructor *) +(* C : I q1..qm,p1..pn p1..pn *) +(* *) +(* in which case, a symmetry lemma is definable *) +(**********************************************************************) + +let error msg = user_err Pp.(str msg) + +let get_sym_eq_data env (ind,u) = + let (mib,mip as specif) = lookup_mind_specif env ind in + if not (Int.equal (Array.length mib.mind_packets) 1) || + not (Int.equal (Array.length mip.mind_nf_lc) 1) then + error "Not an inductive type with a single constructor."; + let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in + let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in + if List.exists is_local_def realsign then + error "Inductive equalities with local definitions in arity not supported."; + let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in + let _,constrargs = decompose_app ccl in + if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then + error "Constructor must have no arguments"; (* This can be relaxed... *) + let params,constrargs = List.chop mib.mind_nparams constrargs in + if mip.mind_nrealargs > mib.mind_nparams then + error "Constructors arguments must repeat the parameters."; + let _,params2 = List.chop (mib.mind_nparams-mip.mind_nrealargs) params in + let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsctxt1,_ = + List.chop (mib.mind_nparams-mip.mind_nrealargs) paramsctxt in + if not (List.equal Constr.equal params2 constrargs) then + error "Constructors arguments must repeat the parameters."; + (* nrealargs_ctxt and nrealargs are the same here *) + (specif,mip.mind_nrealargs,realsign,paramsctxt,paramsctxt1) + +(**********************************************************************) +(* Check if an inductive type [ind] has the form *) +(* *) +(* I q1..qm a1..an with one constructor *) +(* C : I q1..qm b1..bn *) +(* *) +(* in which case it expresses the equalities ai=bi, but not in a way *) +(* such that symmetry is a priori definable *) +(**********************************************************************) + +let get_non_sym_eq_data env (ind,u) = + let (mib,mip as specif) = lookup_mind_specif env ind in + if not (Int.equal (Array.length mib.mind_packets) 1) || + not (Int.equal (Array.length mip.mind_nf_lc) 1) then + error "Not an inductive type with a single constructor."; + let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in + let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in + if List.exists is_local_def realsign then + error "Inductive equalities with local definitions in arity not supported"; + let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in + let _,constrargs = decompose_app ccl in + if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then + error "Constructor must have no arguments"; + let _,constrargs = List.chop mib.mind_nparams constrargs in + let constrargs = List.map (Vars.subst_instance_constr u) constrargs in + let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in + (specif,constrargs,realsign,paramsctxt,mip.mind_nrealargs) + +(**********************************************************************) +(* Build the symmetry lemma associated to an inductive type *) +(* I q1..qm,p1..pn a1..an with one constructor *) +(* C : I q1..qm,p1..pn p1..pn *) +(* *) +(* sym := fun q1..qn p1..pn a1..an (H:I q1..qm p1..pn a1..an) => *) +(* match H in I _.._ a1..an return I q1..qm a1..an p1..pn with *) +(* C => C *) +(* end *) +(* : forall q1..qm p1..pn a1..an I q1..qm p1..pn a1..an -> *) +(* I q1..qm a1..an p1..pn *) +(* *) +(**********************************************************************) + +let build_sym_scheme env ind = + let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in + let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = + get_sym_eq_data env indu in + let cstr n = + mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect mkRel n mib.mind_params_ctxt) in + let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let applied_ind = build_dependent_inductive indu specif in + let realsign_ind = + name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in + let ci = make_case_info (Global.env()) ind RegularStyle in + let c = + (my_it_mkLambda_or_LetIn paramsctxt + (my_it_mkLambda_or_LetIn_name realsign_ind + (mkCase (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+1) realsign_ind) + (mkApp (mkIndU indu,Array.concat + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; + rel_vect 1 nrealargs; + rel_vect (2*nrealargs+2) nrealargs])), + mkRel 1 (* varH *), + [|cstr (nrealargs+1)|])))) + in c, UState.of_context_set ctx + +let sym_scheme_kind = + declare_individual_scheme_object "_sym_internal" + (fun _ ind -> + let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in + (c, ctx), Safe_typing.empty_private_constants) + +(**********************************************************************) +(* Build the involutivity of symmetry for an inductive type *) +(* I q1..qm,p1..pn a1..an with one constructor *) +(* C : I q1..qm,p1..pn p1..pn *) +(* *) +(* inv := fun q1..qn p1..pn a1..an (H:I q1..qm p1..pn a1..an) => *) +(* match H in I _.._ a1..an return *) +(* sym q1..qm p1..pn a1..an (sym q1..qm a1..an p1..pn H) = H *) +(* with *) +(* C => refl_equal C *) +(* end *) +(* : forall q1..qm p1..pn a1..an (H:I q1..qm a1..an p1..pn), *) +(* sym q1..qm p1..pn a1..an (sym q1..qm a1..an p1..pn H) = H *) +(* *) +(**********************************************************************) + +let const_of_scheme kind env ind ctx = + let sym_scheme, eff = (find_scheme kind ind) in + let sym, ctx = with_context_set ctx + (UnivGen.fresh_constant_instance (Global.env()) sym_scheme) in + mkConstU sym, ctx, eff + +let build_sym_involutive_scheme env ind = + let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in + let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = + get_sym_eq_data env indu in + let eq,eqrefl,ctx = get_coq_eq ctx in + let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in + let cstr n = mkApp (mkConstructUi (indu,1),Context.Rel.to_extended_vect mkRel n paramsctxt) in + let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let applied_ind = build_dependent_inductive indu specif in + let applied_ind_C = + mkApp + (mkIndU indu, Array.append + (Context.Rel.to_extended_vect mkRel (nrealargs+1) mib.mind_params_ctxt) + (rel_vect (nrealargs+1) nrealargs)) in + let realsign_ind = + name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in + let ci = make_case_info (Global.env()) ind RegularStyle in + let c = + (my_it_mkLambda_or_LetIn paramsctxt + (my_it_mkLambda_or_LetIn_name realsign_ind + (mkCase (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+1) realsign_ind) + (mkApp (eq,[| + mkApp + (mkIndU indu, Array.concat + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; + rel_vect (2*nrealargs+2) nrealargs; + rel_vect 1 nrealargs]); + mkApp (sym,Array.concat + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; + rel_vect 1 nrealargs; + rel_vect (2*nrealargs+2) nrealargs; + [|mkApp (sym,Array.concat + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; + rel_vect (2*nrealargs+2) nrealargs; + rel_vect 1 nrealargs; + [|mkRel 1|]])|]]); + mkRel 1|])), + mkRel 1 (* varH *), + [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) + in (c, UState.of_context_set ctx), eff + +let sym_involutive_scheme_kind = + declare_individual_scheme_object "_sym_involutive" + (fun _ ind -> + build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) + +(**********************************************************************) +(* Build the left-to-right rewriting lemma for conclusion associated *) +(* to an inductive type I q1..qm,p1..pn a1..an with one constructor *) +(* C : I q1..qm,p1..pn p1..pn *) +(* (symmetric equality in non-dependent and dependent cases) *) +(* *) +(* We could have defined the scheme in one match over a generalized *) +(* type but this behaves badly wrt the guard condition, so we use *) +(* symmetry instead; with commutative-cuts-aware guard condition a *) +(* proof in the style of l2r_forward is also possible (see below) *) +(* *) +(* rew := fun q1..qm p1..pn a1..an *) +(* (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind) *) +(* (HC:P a1..an C) *) +(* (H:I q1..qm p1..pn a1..an) => *) +(* match sym_involutive q1..qm p1..pn a1..an H as Heq *) +(* in _ = H return P p1..pn H *) +(* with *) +(* refl => *) +(* match sym q1..qm p1..pn a1..an H as H *) +(* in I _.._ p1..pn *) +(* return P p1..pn (sym q1..qm a1..an p1..pn H) *) +(* with *) +(* C => HC *) +(* end *) +(* end *) +(* : forall q1..qn p1..pn a1..an *) +(* (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind), *) +(* P a1..an C -> *) +(* forall (H:I q1..qm p1..pn a1..an), P p1..pn H *) +(* *) +(* where A1..An are the common types of p1..pn and a1..an *) +(* *) +(* Note: the symmetry is needed in the dependent case since the *) +(* dependency is on the inner arguments (the indices in C) and these *) +(* inner arguments need to be visible as parameters to be able to *) +(* abstract over them in P. *) +(**********************************************************************) + +(**********************************************************************) +(* For information, the alternative proof of dependent l2r_rew scheme *) +(* that would use commutative cuts is the following *) +(* *) +(* rew := fun q1..qm p1..pn a1..an *) +(* (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind) *) +(* (HC:P a1..an C) *) +(* (H:I q1..qm p1..pn a1..an) => *) +(* match H in I .._.. a1..an return *) +(* forall p1..pn, I q1..qm p1..pn a1..an -> kind), *) +(* P a1..an C -> P p1..pn H *) +(* with *) +(* C => fun P HC => HC *) +(* end P HC *) +(* : forall q1..qn p1..pn a1..an *) +(* (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind), *) +(* P a1..an C -> *) +(* forall (H:I q1..qm p1..pn a1..an), P p1..pn H *) +(* *) +(**********************************************************************) + +let build_l2r_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in + let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = + get_sym_eq_data env indu in + let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in + let sym_involutive, ctx, eff' = const_of_scheme sym_involutive_scheme_kind env ind ctx in + let eq,eqrefl,ctx = get_coq_eq ctx in + let cstr n p = + mkApp (mkConstructUi(indu,1), + Array.concat [Context.Rel.to_extended_vect mkRel n paramsctxt1; + rel_vect p nrealargs]) in + let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let varHC = fresh env (Id.of_string "HC") in + let varP = fresh env (Id.of_string "P") in + let applied_ind = build_dependent_inductive indu specif in + let applied_ind_P = + mkApp (mkIndU indu, Array.concat + [Context.Rel.to_extended_vect mkRel (3*nrealargs) paramsctxt1; + rel_vect 0 nrealargs; + rel_vect nrealargs nrealargs]) in + let applied_ind_G = + mkApp (mkIndU indu, Array.concat + [Context.Rel.to_extended_vect mkRel (3*nrealargs+3) paramsctxt1; + rel_vect (nrealargs+3) nrealargs; + rel_vect 0 nrealargs]) in + let realsign_P = lift_rel_context nrealargs realsign in + let realsign_ind_P = + name_context env ((LocalAssum (Name varH,applied_ind_P))::realsign_P) in + let realsign_ind_G = + name_context env ((LocalAssum (Name varH,applied_ind_G)):: + lift_rel_context (nrealargs+3) realsign) in + let applied_sym_C n = + mkApp(sym, + Array.append (Context.Rel.to_extended_vect mkRel n mip.mind_arity_ctxt) [|mkVar varH|]) in + let applied_sym_G = + mkApp(sym, + Array.concat [Context.Rel.to_extended_vect mkRel (nrealargs*3+4) paramsctxt1; + rel_vect (nrealargs+4) nrealargs; + rel_vect 1 nrealargs; + [|mkRel 1|]]) in + let s, ctx' = UnivGen.fresh_sort_in_family kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in + let ci = make_case_info (Global.env()) ind RegularStyle in + let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in + let applied_PC = + mkApp (mkVar varP,Array.append (Context.Rel.to_extended_vect mkRel 1 realsign) + (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in + let applied_PG = + mkApp (mkVar varP,Array.append (rel_vect 1 nrealargs) + (if dep then [|applied_sym_G|] else [||])) in + let applied_PR = + mkApp (mkVar varP,Array.append (rel_vect (nrealargs+5) nrealargs) + (if dep then [|mkRel 2|] else [||])) in + let applied_sym_sym = + mkApp (sym,Array.concat + [Context.Rel.to_extended_vect mkRel (2*nrealargs+4) paramsctxt1; + rel_vect 4 nrealargs; + rel_vect (nrealargs+4) nrealargs; + [|mkApp (sym,Array.concat + [Context.Rel.to_extended_vect mkRel (2*nrealargs+4) paramsctxt1; + rel_vect (nrealargs+4) nrealargs; + rel_vect 4 nrealargs; + [|mkRel 2|]])|]]) in + let main_body = + mkCase (ci, + my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG, + applied_sym_C 3, + [|mkVar varHC|]) in + let c = + (my_it_mkLambda_or_LetIn paramsctxt + (my_it_mkLambda_or_LetIn_name realsign + (mkNamedLambda varP + (my_it_mkProd_or_LetIn (if dep then realsign_ind_P else realsign_P) s) + (mkNamedLambda varHC applied_PC + (mkNamedLambda varH (lift 2 applied_ind) + (if dep then (* we need a coercion *) + mkCase (cieq, + mkLambda (Name varH,lift 3 applied_ind, + mkLambda (Anonymous, + mkApp (eq,[|lift 4 applied_ind;applied_sym_sym;mkRel 1|]), + applied_PR)), + mkApp (sym_involutive, + Array.append (Context.Rel.to_extended_vect mkRel 3 mip.mind_arity_ctxt) [|mkVar varH|]), + [|main_body|]) + else + main_body)))))) + in (c, UState.of_context_set ctx), + Safe_typing.concat_private eff' eff + +(**********************************************************************) +(* Build the left-to-right rewriting lemma for hypotheses associated *) +(* to an inductive type I q1..qm,p1..pn a1..an with one constructor *) +(* C : I q1..qm,p1..pn p1..pn *) +(* (symmetric equality in non dependent and dependent cases) *) +(* *) +(* rew := fun q1..qm p1..pn a1..an (H:I q1..qm p1..pn a1..an) *) +(* match H in I _.._ a1..an *) +(* return forall *) +(* (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind) *) +(* (HC:P p1..pn H) => *) +(* P a1..an C *) +(* with *) +(* C => fun P HC => HC *) +(* end *) +(* : forall q1..qm p1..pn a1..an *) +(* (H:I q1..qm p1..pn a1..an) *) +(* (P:forall p1..pn, I q1..qm p1..pn a1..an ->kind), *) +(* P p1..pn H -> P a1..an C *) +(* *) +(* Note: the symmetry is needed in the dependent case since the *) +(* dependency is on the inner arguments (the indices in C) and these *) +(* inner arguments need to be visible as parameters to be able to *) +(* abstract over them in P. *) +(**********************************************************************) + +let build_l2r_forward_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in + let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = + get_sym_eq_data env indu in + let cstr n p = + mkApp (mkConstructUi(indu,1), + Array.concat [Context.Rel.to_extended_vect mkRel n paramsctxt1; + rel_vect p nrealargs]) in + let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let varHC = fresh env (Id.of_string "HC") in + let varP = fresh env (Id.of_string "P") in + let applied_ind = build_dependent_inductive indu specif in + let applied_ind_P = + mkApp (mkIndU indu, Array.concat + [Context.Rel.to_extended_vect mkRel (4*nrealargs+2) paramsctxt1; + rel_vect 0 nrealargs; + rel_vect (nrealargs+1) nrealargs]) in + let applied_ind_P' = + mkApp (mkIndU indu, Array.concat + [Context.Rel.to_extended_vect mkRel (3*nrealargs+1) paramsctxt1; + rel_vect 0 nrealargs; + rel_vect (2*nrealargs+1) nrealargs]) in + let realsign_P n = lift_rel_context (nrealargs*n+n) realsign in + let realsign_ind = + name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in + let realsign_ind_P n aP = + name_context env ((LocalAssum (Name varH,aP))::realsign_P n) in + let s, ctx' = UnivGen.fresh_sort_in_family kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in + let ci = make_case_info (Global.env()) ind RegularStyle in + let applied_PC = + mkApp (mkVar varP,Array.append + (rel_vect (nrealargs*2+3) nrealargs) + (if dep then [|mkRel 2|] else [||])) in + let applied_PC' = + mkApp (mkVar varP,Array.append + (rel_vect (nrealargs+2) nrealargs) + (if dep then [|cstr (2*nrealargs+2) (nrealargs+2)|] + else [||])) in + let applied_PG = + mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs) + (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in + let c = + (my_it_mkLambda_or_LetIn paramsctxt + (my_it_mkLambda_or_LetIn_name realsign + (mkNamedLambda varH applied_ind + (mkCase (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+1) realsign_ind) + (mkNamedProd varP + (my_it_mkProd_or_LetIn + (if dep then realsign_ind_P 2 applied_ind_P else realsign_P 2) s) + (mkNamedProd varHC applied_PC applied_PG)), + (mkVar varH), + [|mkNamedLambda varP + (my_it_mkProd_or_LetIn + (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) + (mkNamedLambda varHC applied_PC' + (mkVar varHC))|]))))) + in c, UState.of_context_set ctx + +(**********************************************************************) +(* Build the right-to-left rewriting lemma for hypotheses associated *) +(* to an inductive type I q1..qm a1..an with one constructor *) +(* C : I q1..qm b1..bn *) +(* (arbitrary equality in non-dependent and dependent cases) *) +(* *) +(* rew := fun q1..qm a1..an (H:I q1..qm a1..an) *) +(* (P:forall a1..an, I q1..qm a1..an -> kind) *) +(* (HC:P a1..an H) => *) +(* match H in I _.._ a1..an return P a1..an H -> P b1..bn C *) +(* with *) +(* C => fun x => x *) +(* end HC *) +(* : forall q1..pm a1..an (H:I q1..qm a1..an) *) +(* (P:forall a1..an, I q1..qm a1..an -> kind), *) +(* P a1..an H -> P b1..bn C *) +(* *) +(* Note that the dependent elimination here is not a dependency *) +(* in the conclusion of the scheme but a dependency in the premise of *) +(* the scheme. This is unfortunately incompatible with the standard *) +(* pattern for schemes in Coq which expects that the eliminated *) +(* object is the last premise of the scheme. We then have no choice *) +(* than following the more liberal pattern of having the eliminated *) +(* object coming before the premises. *) +(* *) +(* Note that in the non-dependent case, this scheme (up to the order *) +(* of premises) generalizes the (backward) l2r scheme above: same *) +(* statement but no need for symmetry of the equality. *) +(**********************************************************************) + +let build_r2l_forward_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in + let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) = + get_non_sym_eq_data env indu in + let cstr n = + mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect mkRel n mib.mind_params_ctxt) in + let constrargs_cstr = constrargs@[cstr 0] in + let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let varHC = fresh env (Id.of_string "HC") in + let varP = fresh env (Id.of_string "P") in + let applied_ind = build_dependent_inductive indu specif in + let realsign_ind = + name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in + let s, ctx' = UnivGen.fresh_sort_in_family kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in + let ci = make_case_info (Global.env()) ind RegularStyle in + let applied_PC = + applist (mkVar varP,if dep then constrargs_cstr else constrargs) in + let applied_PG = + mkApp (mkVar varP, + if dep then Context.Rel.to_extended_vect mkRel 0 realsign_ind + else Context.Rel.to_extended_vect mkRel 1 realsign) in + let c = + (my_it_mkLambda_or_LetIn paramsctxt + (my_it_mkLambda_or_LetIn_name realsign_ind + (mkNamedLambda varP + (my_it_mkProd_or_LetIn (lift_rel_context (nrealargs+1) + (if dep then realsign_ind else realsign)) s) + (mkNamedLambda varHC (lift 1 applied_PG) + (mkApp + (mkCase (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+3) realsign_ind) + (mkArrow applied_PG (lift (2*nrealargs+5) applied_PC)), + mkRel 3 (* varH *), + [|mkLambda + (Name varHC, + lift (nrealargs+3) applied_PC, + mkRel 1)|]), + [|mkVar varHC|])))))) + in c, UState.of_context_set ctx + +(**********************************************************************) +(* This function "repairs" the non-dependent r2l forward rewriting *) +(* scheme by making it comply with the standard pattern of schemes *) +(* in Coq. Otherwise said, it turns a scheme of type *) +(* *) +(* forall q1..pm a1..an, I q1..qm a1..an -> *) +(* forall (P: forall a1..an, kind), *) +(* P a1..an -> P b1..bn *) +(* *) +(* into a scheme of type *) +(* *) +(* forall q1..pm (P:forall a1..an, kind), *) +(* P a1..an -> forall a1..an, I q1..qm a1..an -> P b1..bn *) +(* *) +(**********************************************************************) + +let fix_r2l_forward_rew_scheme (c, ctx') = + let env = Global.env () in + let sigma = Evd.from_env env in + let t = Retyping.get_type_of env sigma (EConstr.of_constr c) in + let t = EConstr.Unsafe.to_constr t in + let ctx,_ = decompose_prod_assum t in + match ctx with + | hp :: p :: ind :: indargs -> + let c' = + my_it_mkLambda_or_LetIn indargs + (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) + (EConstr.Unsafe.to_constr (Reductionops.whd_beta sigma + (EConstr.of_constr (applist (c, + Context.Rel.to_extended_list mkRel 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))))) + in c', ctx' + | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme.") + +(**********************************************************************) +(* Build the right-to-left rewriting lemma for conclusion associated *) +(* to an inductive type I q1..qm a1..an with one constructor *) +(* C : I q1..qm b1..bn *) +(* (arbitrary equality in non-dependent and dependent case) *) +(* *) +(* This is actually the standard case analysis scheme *) +(* *) +(* rew := fun q1..qm a1..an *) +(* (P:forall a1..an, I q1..qm a1..an -> kind) *) +(* (H:I q1..qm a1..an) *) +(* (HC:P b1..bn C) => *) +(* match H in I _.._ a1..an return P a1..an H with *) +(* C => HC *) +(* end *) +(* : forall q1..pm a1..an *) +(* (P:forall a1..an, I q1..qm a1..an -> kind) *) +(* (H:I q1..qm a1..an), *) +(* P b1..bn C -> P a1..an H *) +(**********************************************************************) + +let build_r2l_rew_scheme dep env ind k = + let sigma = Evd.from_env env in + let (sigma, indu) = Evd.fresh_inductive_instance env sigma ind in + let (sigma, c) = build_case_analysis_scheme env sigma indu dep k in + c, Evd.evar_universe_context sigma + +let build_l2r_rew_scheme = build_l2r_rew_scheme +let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme +let build_r2l_rew_scheme = build_r2l_rew_scheme +let build_r2l_forward_rew_scheme = build_r2l_forward_rew_scheme + +(**********************************************************************) +(* Register the rewriting schemes *) +(**********************************************************************) + +(**********************************************************************) +(* Dependent rewrite from left-to-right in conclusion *) +(* (symmetrical equality type only) *) +(* Gamma |- P p1..pn H ==> Gamma |- P a1..an C *) +(* with H:I p1..pn a1..an in Gamma *) +(**********************************************************************) +let rew_l2r_dep_scheme_kind = + declare_individual_scheme_object "_rew_r_dep" + (fun _ ind -> build_l2r_rew_scheme true (Global.env()) ind InType) + +(**********************************************************************) +(* Dependent rewrite from right-to-left in conclusion *) +(* Gamma |- P a1..an H ==> Gamma |- P b1..bn C *) +(* with H:I a1..an in Gamma (non symmetric case) *) +(* or H:I b1..bn a1..an in Gamma (symmetric case) *) +(**********************************************************************) +let rew_r2l_dep_scheme_kind = + declare_individual_scheme_object "_rew_dep" + (fun _ ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) + +(**********************************************************************) +(* Dependent rewrite from right-to-left in hypotheses *) +(* Gamma, P a1..an H |- D ==> Gamma, P b1..bn C |- D *) +(* with H:I a1..an in Gamma (non symmetric case) *) +(* or H:I b1..bn a1..an in Gamma (symmetric case) *) +(**********************************************************************) +let rew_r2l_forward_dep_scheme_kind = + declare_individual_scheme_object "_rew_fwd_dep" + (fun _ ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) + +(**********************************************************************) +(* Dependent rewrite from left-to-right in hypotheses *) +(* (symmetrical equality type only) *) +(* Gamma, P p1..pn H |- D ==> Gamma, P a1..an C |- D *) +(* with H:I p1..pn a1..an in Gamma *) +(**********************************************************************) +let rew_l2r_forward_dep_scheme_kind = + declare_individual_scheme_object "_rew_fwd_r_dep" + (fun _ ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) + +(**********************************************************************) +(* Non-dependent rewrite from either left-to-right in conclusion or *) +(* right-to-left in hypotheses: both l2r_rew and r2l_forward_rew are *) +(* potential candidates. Since l2r_rew needs a symmetrical equality, *) +(* we adopt r2l_forward_rew (this one introduces a blocked beta- *) +(* expansion but since the guard condition supports commutative cuts *) +(* this is not a problem; we need though a fix to adjust it to the *) +(* standard form of schemes in Coq) *) +(**********************************************************************) +let rew_l2r_scheme_kind = + declare_individual_scheme_object "_rew_r" + (fun _ ind -> fix_r2l_forward_rew_scheme + (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Safe_typing.empty_private_constants) + +(**********************************************************************) +(* Non-dependent rewrite from either right-to-left in conclusion or *) +(* left-to-right in hypotheses: both r2l_rew and l2r_forward_rew but *) +(* since r2l_rew works in the non-symmetric case as well as without *) +(* introducing commutative cuts, we adopt it *) +(**********************************************************************) +let rew_r2l_scheme_kind = + declare_individual_scheme_object "_rew" + (fun _ ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Safe_typing.empty_private_constants) + +(* End of rewriting schemes *) + +(**********************************************************************) +(* Build the congruence lemma associated to an inductive type *) +(* I p1..pn a with one constructor C : I q1..qn b *) +(* *) +(* congr := fun p1..pn (B:Type) (f:A->B) a (H:I p1..pn a) => *) +(* match H in I _.._ a' return f b = f a' with *) +(* C => eq_refl (f b) *) +(* end *) +(* : forall p1..pn (B:Type) (f:A->B) a, I p1..pn a -> f b = f a *) +(* *) +(* where A is the common type of a and b *) +(**********************************************************************) + +(* TODO: extend it to types with more than one index *) + +let build_congr env (eq,refl,ctx) ind = + let (ind,u as indu), ctx = with_context_set ctx + (UnivGen.fresh_inductive_instance env ind) in + let (mib,mip) = lookup_mind_specif env ind in + if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then + error "Not an inductive type with a single constructor."; + if not (Int.equal mip.mind_nrealargs 1) then + error "Expect an inductive type with one predicate parameter."; + let i = 1 in + let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in + let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in + let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in + 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 = 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 not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then + error "Constructor must have no arguments"; + let b = List.nth constrargs (i + mib.mind_nparams - 1) in + let varB = fresh env (Id.of_string "B") in + let varH = fresh env (Id.of_string "H") in + let varf = fresh env (Id.of_string "f") in + let ci = make_case_info (Global.env()) ind RegularStyle in + let uni, ctx = Univ.extend_in_context_set (UnivGen.new_global_univ ()) ctx in + let ctx = (fst ctx, Univ.enforce_leq uni (univ_of_eq env eq) (snd ctx)) in + let c = + my_it_mkLambda_or_LetIn paramsctxt + (mkNamedLambda varB (mkSort (Type uni)) + (mkNamedLambda varf (mkArrow (lift 1 ty) (mkVar varB)) + (my_it_mkLambda_or_LetIn_name (lift_rel_context 2 realsign) + (mkNamedLambda varH + (applist + (mkIndU indu, + Context.Rel.to_extended_list mkRel (mip.mind_nrealargs+2) paramsctxt @ + Context.Rel.to_extended_list mkRel 0 realsign)) + (mkCase (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (mip.mind_nrealargs+3) realsign) + (mkLambda + (Anonymous, + applist + (mkIndU indu, + Context.Rel.to_extended_list mkRel (2*mip.mind_nrealdecls+3) + paramsctxt + @ Context.Rel.to_extended_list mkRel 0 realsign), + mkApp (eq, + [|mkVar varB; + mkApp (mkVar varf, [|lift (2*mip.mind_nrealdecls+4) b|]); + mkApp (mkVar varf, [|mkRel (mip.mind_nrealargs - i + 2)|])|]))), + mkVar varH, + [|mkApp (refl, + [|mkVar varB; + mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|])))))) + in c, UState.of_context_set ctx + +let congr_scheme_kind = declare_individual_scheme_object "_congr" + (fun _ ind -> + (* May fail if equality is not defined *) + build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, + Safe_typing.empty_private_constants) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli new file mode 100644 index 0000000000..4749aebd96 --- /dev/null +++ b/tactics/eqschemes.mli @@ -0,0 +1,49 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** This file builds schemes relative to equality inductive types *) + +open Names +open Constr +open Environ +open Ind_tables + +(** Builds a left-to-right rewriting scheme for an equality type *) + +val rew_l2r_dep_scheme_kind : individual scheme_kind +val rew_l2r_scheme_kind : individual scheme_kind +val rew_r2l_forward_dep_scheme_kind : individual scheme_kind +val rew_l2r_forward_dep_scheme_kind : individual scheme_kind +val rew_r2l_dep_scheme_kind : individual scheme_kind +val rew_r2l_scheme_kind : individual scheme_kind + +val build_r2l_rew_scheme : bool -> env -> inductive -> Sorts.family -> + constr Evd.in_evar_universe_context +val build_l2r_rew_scheme : bool -> env -> inductive -> Sorts.family -> + constr Evd.in_evar_universe_context * Safe_typing.private_constants +val build_r2l_forward_rew_scheme : + bool -> env -> inductive -> Sorts.family -> constr Evd.in_evar_universe_context +val build_l2r_forward_rew_scheme : + bool -> env -> inductive -> Sorts.family -> constr Evd.in_evar_universe_context + +(** Builds a symmetry scheme for a symmetrical equality type *) + +val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context +val sym_scheme_kind : individual scheme_kind + +val build_sym_involutive_scheme : env -> inductive -> + constr Evd.in_evar_universe_context * Safe_typing.private_constants +val sym_involutive_scheme_kind : individual scheme_kind + +(** Builds a congruence scheme for an equality type *) + +val congr_scheme_kind : individual scheme_kind +val build_congr : env -> constr * constr * Univ.ContextSet.t -> inductive -> + constr Evd.in_evar_universe_context diff --git a/tactics/equality.ml b/tactics/equality.ml new file mode 100644 index 0000000000..769e702da1 --- /dev/null +++ b/tactics/equality.ml @@ -0,0 +1,1918 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +module CVars = Vars +open Pp +open CErrors +open Util +open Names +open Nameops +open Term +open Constr +open Termops +open EConstr +open Vars +open Namegen +open Inductive +open Inductiveops +open Libnames +open Globnames +open Reductionops +open Typing +open Retyping +open Tacmach.New +open Logic +open Hipattern +open Tacticals.New +open Tactics +open Tacred +open Coqlib +open Declarations +open Indrec +open Clenv +open Evd +open Ind_tables +open Eqschemes +open Locus +open Locusops +open Tactypes +open Proofview.Notations +open Unification +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration + +(* Options *) + +type inj_flags = { + keep_proof_equalities : bool; + injection_in_context : bool; + injection_pattern_l2r_order : bool; + } + +open Goptions + +let use_injection_pattern_l2r_order = function + | None -> true + | Some flags -> flags.injection_pattern_l2r_order + +let injection_in_context = ref false + +let use_injection_in_context = function + | None -> !injection_in_context + | Some flags -> flags.injection_in_context + +let () = + declare_bool_option + { optdepr = false; + optname = "injection in context"; + optkey = ["Structural";"Injection"]; + optread = (fun () -> !injection_in_context) ; + optwrite = (fun b -> injection_in_context := b) } + +(* Rewriting tactics *) + +type dep_proof_flag = bool (* true = support rewriting dependent proofs *) +type freeze_evars_flag = bool (* true = don't instantiate existing evars *) + +type orientation = bool + +type conditions = + | Naive (* Only try the first occurrence of the lemma (default) *) + | FirstSolved (* Use the first match whose side-conditions are solved *) + | AllMatches (* Rewrite all matches whose side-conditions are solved *) + +(* Warning : rewriting from left to right only works + if there exists in the context a theorem named <eqname>_<suffsort>_r + with type (A:<sort>)(x:A)(P:A->Prop)(P x)->(y:A)(eqname A y x)->(P y). + If another equality myeq is introduced, then corresponding theorems + myeq_ind_r, myeq_rec_r and myeq_rect_r have to be proven. See below. + -- Eduardo (19/8/97) +*) + +let rewrite_core_unif_flags = { + modulo_conv_on_closed_terms = None; + use_metas_eagerly_in_conv_on_closed_terms = true; + use_evars_eagerly_in_conv_on_closed_terms = false; + modulo_delta = TransparentState.empty; + modulo_delta_types = TransparentState.empty; + check_applied_meta_types = true; + use_pattern_unification = true; + use_meta_bound_pattern_unification = true; + frozen_evars = Evar.Set.empty; + restrict_conv_on_strict_subterms = false; + modulo_betaiota = false; + modulo_eta = true; +} + +let rewrite_unif_flags = { + core_unify_flags = rewrite_core_unif_flags; + merge_unify_flags = rewrite_core_unif_flags; + subterm_unify_flags = rewrite_core_unif_flags; + allow_K_in_toplevel_higher_order_unification = false; + (* allow_K does not matter in practice because calls w_typed_unify *) + resolve_evars = true +} + +let freeze_initial_evars sigma flags clause = + (* We take evars of the type: this may include old evars! For excluding *) + (* all old evars, including the ones occurring in the rewriting lemma, *) + (* we would have to take the clenv_value *) + let newevars = Evarutil.undefined_evars_of_term sigma (clenv_type clause) in + let evars = + fold_undefined (fun evk _ evars -> + if Evar.Set.mem evk newevars then evars + else Evar.Set.add evk evars) + sigma Evar.Set.empty in + {flags with + core_unify_flags = {flags.core_unify_flags with frozen_evars = evars}; + merge_unify_flags = {flags.merge_unify_flags with frozen_evars = evars}; + subterm_unify_flags = {flags.subterm_unify_flags with frozen_evars = evars}} + +let make_flags frzevars sigma flags clause = + if frzevars then freeze_initial_evars sigma flags clause else flags + +let side_tac tac sidetac = + match sidetac with + | None -> tac + | Some sidetac -> tclTHENSFIRSTn tac [|Proofview.tclUNIT ()|] sidetac + +let instantiate_lemma_all frzevars gl c ty l l2r concl = + let env = Proofview.Goal.env gl in + let sigma = project gl in + let eqclause = pf_apply Clenv.make_clenv_binding gl (c,ty) l in + let (equiv, args) = decompose_app_vect sigma (Clenv.clenv_type eqclause) in + let arglen = Array.length args in + let () = if arglen < 2 then user_err Pp.(str "The term provided is not an applied relation.") in + let c1 = args.(arglen - 2) in + let c2 = args.(arglen - 1) in + let try_occ (evd', c') = + Clenvtac.clenv_pose_dependent_evars ~with_evars:true {eqclause with evd = evd'} + in + let flags = make_flags frzevars (Tacmach.New.project gl) rewrite_unif_flags eqclause in + let occs = + w_unify_to_subterm_all ~flags env eqclause.evd + ((if l2r then c1 else c2),concl) + in List.map try_occ occs + +let instantiate_lemma gl c ty l l2r concl = + let sigma, ct = pf_type_of gl c in + let t = try snd (reduce_to_quantified_ind (pf_env gl) sigma ct) with UserError _ -> ct in + let eqclause = Clenv.make_clenv_binding (pf_env gl) sigma (c,t) l in + [eqclause] + +let rewrite_conv_closed_core_unif_flags = { + modulo_conv_on_closed_terms = Some TransparentState.full; + (* We have this flag for historical reasons, it has e.g. the consequence *) + (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) + + use_metas_eagerly_in_conv_on_closed_terms = true; + use_evars_eagerly_in_conv_on_closed_terms = false; + (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) + (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) + + modulo_delta = TransparentState.empty; + modulo_delta_types = TransparentState.full; + check_applied_meta_types = true; + use_pattern_unification = true; + (* To rewrite "?n x y" in "y+x=0" when ?n is *) + (* a preexisting evar of the goal*) + + use_meta_bound_pattern_unification = true; + + frozen_evars = Evar.Set.empty; + (* This is set dynamically *) + + restrict_conv_on_strict_subterms = false; + modulo_betaiota = false; + modulo_eta = true; +} + +let rewrite_conv_closed_unif_flags = { + core_unify_flags = rewrite_conv_closed_core_unif_flags; + merge_unify_flags = rewrite_conv_closed_core_unif_flags; + subterm_unify_flags = rewrite_conv_closed_core_unif_flags; + allow_K_in_toplevel_higher_order_unification = false; + resolve_evars = false +} + +let rewrite_keyed_core_unif_flags = { + modulo_conv_on_closed_terms = Some TransparentState.full; + (* We have this flag for historical reasons, it has e.g. the consequence *) + (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) + + use_metas_eagerly_in_conv_on_closed_terms = true; + use_evars_eagerly_in_conv_on_closed_terms = false; + (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) + (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) + + modulo_delta = TransparentState.full; + modulo_delta_types = TransparentState.full; + check_applied_meta_types = true; + use_pattern_unification = true; + (* To rewrite "?n x y" in "y+x=0" when ?n is *) + (* a preexisting evar of the goal*) + + use_meta_bound_pattern_unification = true; + + frozen_evars = Evar.Set.empty; + (* This is set dynamically *) + + restrict_conv_on_strict_subterms = false; + modulo_betaiota = true; + + modulo_eta = true; +} + +let rewrite_keyed_unif_flags = { + core_unify_flags = rewrite_keyed_core_unif_flags; + merge_unify_flags = rewrite_keyed_core_unif_flags; + subterm_unify_flags = rewrite_keyed_core_unif_flags; + allow_K_in_toplevel_higher_order_unification = false; + resolve_evars = false +} + +let rewrite_elim with_evars frzevars cls c e = + Proofview.Goal.enter begin fun gl -> + let flags = if Unification.is_keyed_unification () + then rewrite_keyed_unif_flags else rewrite_conv_closed_unif_flags in + let flags = make_flags frzevars (Tacmach.New.project gl) flags c in + general_elim_clause with_evars flags cls c e + end + +let tclNOTSAMEGOAL tac = + let goal gl = Proofview.Goal.goal gl in + Proofview.Goal.enter begin fun gl -> + let sigma = project gl in + let ev = goal gl in + tac >>= fun () -> + Proofview.Goal.goals >>= fun gls -> + let check accu gl' = + gl' >>= fun gl' -> + let accu = accu || Goal.V82.same_goal sigma ev (project gl') (goal gl') in + Proofview.tclUNIT accu + in + Proofview.Monad.List.fold_left check false gls >>= fun has_same -> + if has_same then + tclZEROMSG (str"Tactic generated a subgoal identical to the original goal.") + else + Proofview.tclUNIT () + end + +(* Ad hoc asymmetric general_elim_clause *) +let general_elim_clause with_evars frzevars cls rew elim = + let open Pretype_errors in + Proofview.tclORELSE + begin match cls with + | None -> + (* was tclWEAK_PROGRESS which only fails for tactics generating one + subgoal and did not fail for useless conditional rewritings generating + an extra condition *) + tclNOTSAMEGOAL (rewrite_elim with_evars frzevars cls rew elim) + | Some _ -> rewrite_elim with_evars frzevars cls rew elim + end + begin function (e, info) -> match e with + | PretypeError (env, evd, NoOccurrenceFound (c', _)) -> + Proofview.tclZERO (PretypeError (env, evd, NoOccurrenceFound (c', cls))) + | e -> Proofview.tclZERO ~info e + end + +let general_elim_clause with_evars frzevars tac cls c t l l2r elim = + let all, firstonly, tac = + match tac with + | None -> false, false, None + | Some (tac, Naive) -> false, false, Some tac + | Some (tac, FirstSolved) -> true, true, Some (tclCOMPLETE tac) + | Some (tac, AllMatches) -> true, false, Some (tclCOMPLETE tac) + in + let try_clause c = + side_tac + (tclTHEN + (Proofview.Unsafe.tclEVARS c.evd) + (general_elim_clause with_evars frzevars cls c elim)) + tac + in + Proofview.Goal.enter begin fun gl -> + let instantiate_lemma concl = + if not all then instantiate_lemma gl c t l l2r concl + else instantiate_lemma_all frzevars gl c t l l2r concl + in + let typ = match cls with + | None -> pf_concl gl + | Some id -> pf_get_hyp_typ id gl + in + let cs = instantiate_lemma typ in + if firstonly then tclFIRST (List.map try_clause cs) + else tclMAP try_clause cs + end + +(* The next function decides in particular whether to try a regular + rewrite or a generalized rewrite. + Approach is to break everything, if [eq] appears in head position + then regular rewrite else try general rewrite. + If occurrences are set, use general rewrite. +*) + +let (forward_general_setoid_rewrite_clause, general_setoid_rewrite_clause) = Hook.make () + +(* Do we have a JMeq instance on twice the same domains ? *) + +let jmeq_same_dom env sigma = function + | None -> true (* already checked in Hipattern.find_eq_data_decompose *) + | Some t -> + let rels, t = decompose_prod_assum sigma t in + let env = push_rel_context rels env in + match decompose_app sigma t with + | _, [dom1; _; dom2;_] -> is_conv env sigma dom1 dom2 + | _ -> false + +(* find_elim determines which elimination principle is necessary to + eliminate lbeq on sort_of_gl. *) + +let find_elim hdcncl lft2rgt dep cls ot = + Proofview.Goal.enter_one begin fun gl -> + let sigma = project gl in + let is_global_exists gr c = + Coqlib.has_ref gr && Termops.is_global sigma (Coqlib.lib_ref gr) c + in + let inccl = Option.is_empty cls in + let env = Proofview.Goal.env gl in + (* if (is_global Coqlib.glob_eq hdcncl || *) + (* (is_global Coqlib.glob_jmeq hdcncl && *) + (* jmeq_same_dom env sigma ot)) && not dep *) + if (is_global_exists "core.eq.type" hdcncl || + (is_global_exists "core.JMeq.type" hdcncl + && jmeq_same_dom env sigma ot)) && not dep + then + let c = + match EConstr.kind sigma hdcncl with + | Ind (ind_sp,u) -> + let pr1 = + lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) + in + begin match lft2rgt, cls with + | Some true, None + | Some false, Some _ -> + let c1 = destConstRef pr1 in + let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical c1)) in + let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in + let c1' = Global.constant_of_delta_kn (KerName.make mp l') in + begin + try + let _ = Global.lookup_constant c1' in + c1' + with Not_found -> + user_err ~hdr:"Equality.find_elim" + (str "Cannot find rewrite principle " ++ Label.print l' ++ str ".") + end + | _ -> destConstRef pr1 + end + | _ -> + (* cannot occur since we checked that we are in presence of + Logic.eq or Jmeq just before *) + assert false + in + pf_constr_of_global (ConstRef c) + else + let scheme_name = match dep, lft2rgt, inccl with + (* Non dependent case *) + | false, Some true, true -> rew_l2r_scheme_kind + | false, Some true, false -> rew_r2l_scheme_kind + | false, _, false -> rew_l2r_scheme_kind + | false, _, true -> rew_r2l_scheme_kind + (* Dependent case *) + | true, Some true, true -> rew_l2r_dep_scheme_kind + | true, Some true, false -> rew_l2r_forward_dep_scheme_kind + | true, _, true -> rew_r2l_dep_scheme_kind + | true, _, false -> rew_r2l_forward_dep_scheme_kind + in + match EConstr.kind sigma hdcncl with + | Ind (ind,u) -> + + let c, eff = find_scheme scheme_name ind in + Proofview.tclEFFECTS eff <*> + pf_constr_of_global (ConstRef c) + | _ -> assert false + end + +let type_of_clause cls gl = match cls with + | None -> Proofview.Goal.concl gl + | Some id -> pf_get_hyp_typ id gl + +let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = + Proofview.Goal.enter begin fun gl -> + let evd = Proofview.Goal.sigma gl in + let isatomic = isProd evd (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 evd c type_of_cls in + find_elim hdcncl lft2rgt dep cls (Some t) >>= fun elim -> + general_elim_clause with_evars frzevars tac cls c t l + (match lft2rgt with None -> false | Some b -> b) + {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} + end + +let adjust_rewriting_direction args lft2rgt = + match args with + | [_] -> + (* equality to a constant, like in eq_true *) + (* more natural to see -> as the rewriting to the constant *) + if not lft2rgt then + user_err Pp.(str "Rewriting non-symmetric equality not allowed from right-to-left."); + None + | _ -> + (* other equality *) + Some lft2rgt + +let rewrite_side_tac tac sidetac = side_tac tac (Option.map fst sidetac) + +(* Main function for dispatching which kind of rewriting it is about *) + +let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac + ((c,l) : constr with_bindings) with_evars = + if occs != AllOccurrences then ( + rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac) + else + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in + let ctype = get_type_of env sigma c in + let rels, t = decompose_prod_assum sigma (whd_betaiotazeta sigma ctype) in + match match_with_equality_type sigma t with + | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) + let lft2rgt = adjust_rewriting_direction args lft2rgt in + leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t rels) + l with_evars frzevars dep_proof_ok hdcncl + | None -> + Proofview.tclORELSE + begin + rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls + lft2rgt occs (c,l) ~new_goals:[]) tac + end + begin function + | (e, info) -> + Proofview.tclEVARMAP >>= fun sigma -> + let env' = push_rel_context rels env in + let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) + match match_with_equality_type sigma t' with + | Some (hdcncl,args) -> + let lft2rgt = adjust_rewriting_direction args lft2rgt in + leibniz_rewrite_ebindings_clause cls lft2rgt tac c + (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok hdcncl + | None -> Proofview.tclZERO ~info e + (* error "The provided term does not end with an equality or a declared rewrite relation." *) + end + end + +let general_rewrite_ebindings = + general_rewrite_ebindings_clause None + +let general_rewrite_bindings l2r occs frzevars dep_proof_ok ?tac (c,bl) = + general_rewrite_ebindings_clause None l2r occs + frzevars dep_proof_ok ?tac (c,bl) + +let general_rewrite l2r occs frzevars dep_proof_ok ?tac c = + general_rewrite_bindings l2r occs + frzevars dep_proof_ok ?tac (c,NoBindings) false + +let general_rewrite_ebindings_in l2r occs frzevars dep_proof_ok ?tac id = + general_rewrite_ebindings_clause (Some id) l2r occs frzevars dep_proof_ok ?tac + +let general_rewrite_bindings_in l2r occs frzevars dep_proof_ok ?tac id (c,bl) = + general_rewrite_ebindings_clause (Some id) l2r occs + frzevars dep_proof_ok ?tac (c,bl) + +let general_rewrite_in l2r occs frzevars dep_proof_ok ?tac id c = + general_rewrite_ebindings_clause (Some id) l2r occs + frzevars dep_proof_ok ?tac (c,NoBindings) + +let general_rewrite_clause l2r with_evars ?tac c cl = + let occs_of = occurrences_map (List.fold_left + (fun acc -> + function ArgArg x -> x :: acc | ArgVar _ -> acc) + []) + in + match cl.onhyps with + | Some l -> + (* If a precise list of locations is given, success is mandatory for + each of these locations. *) + let rec do_hyps = function + | [] -> Proofview.tclUNIT () + | ((occs,id),_) :: l -> + tclTHENFIRST + (general_rewrite_ebindings_in l2r (occs_of occs) false true ?tac id c with_evars) + (do_hyps l) + in + if cl.concl_occs == NoOccurrences then do_hyps l else + tclTHENFIRST + (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) + (do_hyps l) + | None -> + (* Otherwise, if we are told to rewrite in all hypothesis via the + syntax "* |-", we fail iff all the different rewrites fail *) + let rec do_hyps_atleastonce = function + | [] -> tclZEROMSG (Pp.str"Nothing to rewrite.") + | id :: l -> + tclIFTHENFIRSTTRYELSEMUST + (general_rewrite_ebindings_in l2r AllOccurrences false true ?tac id c with_evars) + (do_hyps_atleastonce l) + in + let do_hyps = + (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) + let ids gl = + let ids_in_c = Termops.global_vars_set (Proofview.Goal.env gl) (project gl) (fst c) in + let ids_of_hyps = pf_ids_of_hyps gl in + Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps + in + Proofview.Goal.enter begin fun gl -> + do_hyps_atleastonce (ids gl) + end + in + if cl.concl_occs == NoOccurrences then do_hyps else + tclIFTHENFIRSTTRYELSEMUST + (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) + do_hyps + +let apply_special_clear_request clear_flag f = + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in + try + let (sigma, (c, bl)) = f env sigma in + apply_clear_request clear_flag (use_clear_hyp_by_default ()) c + with + e when catchable_exception e -> tclIDTAC + end + +type multi = + | Precisely of int + | UpTo of int + | RepeatStar + | RepeatPlus + +let general_multi_rewrite with_evars l cl tac = + let do1 l2r f = + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in + let (sigma, c) = f env sigma in + tclWITHHOLES with_evars + (general_rewrite_clause l2r with_evars ?tac c cl) sigma + end + in + let rec doN l2r c = function + | Precisely n when n <= 0 -> Proofview.tclUNIT () + | Precisely 1 -> do1 l2r c + | Precisely n -> tclTHENFIRST (do1 l2r c) (doN l2r c (Precisely (n-1))) + | RepeatStar -> tclREPEAT_MAIN (do1 l2r c) + | RepeatPlus -> tclTHENFIRST (do1 l2r c) (doN l2r c RepeatStar) + | UpTo n when n<=0 -> Proofview.tclUNIT () + | UpTo n -> tclTHENFIRST (tclTRY (do1 l2r c)) (doN l2r c (UpTo (n-1))) + in + let rec loop = function + | [] -> Proofview.tclUNIT () + | (l2r,m,clear_flag,c)::l -> + tclTHENFIRST + (tclTHEN (doN l2r c m) (apply_special_clear_request clear_flag c)) (loop l) + in loop l + +let rewriteLR = general_rewrite true AllOccurrences true true +let rewriteRL = general_rewrite false AllOccurrences true true + +(* Replacing tactics *) + +let classes_dirpath = + DirPath.make (List.map Id.of_string ["Classes";"Coq"]) + +let init_setoid () = + if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () + else check_required_library ["Coq";"Setoids";"Setoid"] + +let check_setoid cl = + Option.fold_left + ( List.fold_left + (fun b ((occ,_),_) -> + b||(Locusops.occurrences_map (fun x -> x) occ <> AllOccurrences) + ) + ) + ((Locusops.occurrences_map (fun x -> x) cl.concl_occs <> AllOccurrences) && + (Locusops.occurrences_map (fun x -> x) cl.concl_occs <> NoOccurrences)) + cl.onhyps + +let replace_core clause l2r eq = + if check_setoid clause + then init_setoid (); + tclTHENFIRST + (assert_as false None None eq) + (onLastHypId (fun id -> + tclTHEN + (tclTRY (general_rewrite_clause l2r false (mkVar id,NoBindings) clause)) + (clear [id]))) + +(* eq,sym_eq : equality on Type and its symmetry theorem + c1 c2 : c1 is to be replaced by c2 + unsafe : If true, do not check that c1 and c2 are convertible + tac : Used to prove the equality c1 = c2 + gl : goal *) + +let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = + let try_prove_eq = + match try_prove_eq_opt with + | None -> Proofview.tclUNIT () + | Some tac -> tclCOMPLETE tac + in + Proofview.Goal.enter begin fun gl -> + let get_type_of = pf_apply get_type_of gl in + let t1 = get_type_of c1 + and t2 = get_type_of c2 in + let evd = + if unsafe then Some (Tacmach.New.project gl) + else + try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Tacmach.New.project gl)) + with Evarconv.UnableToUnify _ -> None + in + match evd with + | None -> + tclFAIL 0 (str"Terms do not have convertible types") + | Some evd -> + let e = lib_ref "core.eq.type" in + let sym = lib_ref "core.eq.sym" in + Tacticals.New.pf_constr_of_global sym >>= fun sym -> + Tacticals.New.pf_constr_of_global e >>= fun e -> + let eq = applist (e, [t1;c1;c2]) in + tclTHENLAST + (replace_core clause l2r eq) + (tclFIRST + [assumption; + tclTHEN (apply sym) assumption; + try_prove_eq + ]) + end + +let replace c1 c2 = + replace_using_leibniz onConcl c2 c1 false false None + +let replace_by c1 c2 tac = + replace_using_leibniz onConcl c2 c1 false false (Some tac) + +let replace_in_clause_maybe_by c1 c2 cl tac_opt = + replace_using_leibniz cl c2 c1 false false tac_opt + +(* End of Eduardo's code. The rest of this file could be improved + using the functions match_with_equation, etc that I defined + in Pattern.ml. + -- Eduardo (19/8/97) +*) + +(* Tactics for equality reasoning with the "eq" relation. This code + will work with any equivalence relation which is substitutive *) + +(* [find_positions t1 t2] + + will find the positions in the two terms which are suitable for + discrimination, or for injection. Obviously, if there is a + position which is suitable for discrimination, then we want to + exploit it, and not bother with injection. So when we find a + position which is suitable for discrimination, we will just raise + an exception with that position. + + So the algorithm goes like this: + + if [t1] and [t2] start with the same constructor, then we can + continue to try to find positions in the arguments of [t1] and + [t2]. + + if [t1] and [t2] do not start with the same constructor, then we + have found a discrimination position + + if one [t1] or [t2] do not start with a constructor and the two + terms are not already convertible, then we have found an injection + position. + + A discriminating position consists of a constructor-path and a pair + of operators. The constructor-path tells us how to get down to the + place where the two operators, which must differ, can be found. + + An injecting position has two terms instead of the two operators, + since these terms are different, but not manifestly so. + + A constructor-path is a list of pairs of (operator * int), where + the int (based at 0) tells us which argument of the operator we + descended into. + + *) + +exception DiscrFound of + (constructor * int) list * constructor * constructor + +let keep_proof_equalities_for_injection = ref false + +let () = + declare_bool_option + { optdepr = false; + optname = "injection on prop arguments"; + optkey = ["Keep";"Proof";"Equalities"]; + optread = (fun () -> !keep_proof_equalities_for_injection) ; + optwrite = (fun b -> keep_proof_equalities_for_injection := b) } + +let keep_proof_equalities = function + | None -> !keep_proof_equalities_for_injection + | Some flags -> flags.keep_proof_equalities + +(* [keep_proofs] is relevant for types in Prop with elimination in Type *) +(* In particular, it is relevant for injection but not for discriminate *) + +let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = + let project env sorts posn t1 t2 = + let ty1 = get_type_of env sigma t1 in + let s = get_sort_family_of ~truncation_style:true env sigma ty1 in + if Sorts.List.mem s sorts + then [(List.rev posn,t1,t2)] else [] + in + let rec findrec sorts posn t1 t2 = + let hd1,args1 = whd_all_stack env sigma t1 in + let hd2,args2 = whd_all_stack env sigma t2 in + match (EConstr.kind sigma hd1, EConstr.kind sigma hd2) with + | Construct ((ind1,i1 as sp1),u1), Construct (sp2,_) + when Int.equal (List.length args1) (constructor_nallargs_env env sp1) + -> + let sorts' = + Sorts.List.intersect sorts (allowed_sorts env (fst sp1)) + in + (* both sides are fully applied constructors, so either we descend, + or we can discriminate here. *) + if eq_constructor sp1 sp2 then + let nparams = inductive_nparams_env env ind1 in + let params1,rargs1 = List.chop nparams args1 in + let _,rargs2 = List.chop nparams args2 in + let (mib,mip) = lookup_mind_specif env ind1 in + let params1 = List.map EConstr.Unsafe.to_constr params1 in + let u1 = EInstance.kind sigma u1 in + let ctxt = (get_constructor ((ind1,u1),mib,mip,params1) i1).cs_args in + let adjust i = CVars.adjust_rel_to_rel_context ctxt (i+1) - 1 in + List.flatten + (List.map2_i (fun i -> findrec sorts' ((sp1,adjust i)::posn)) + 0 rargs1 rargs2) + else if Sorts.List.mem InType sorts' && not no_discr + then (* see build_discriminator *) + raise (DiscrFound (List.rev posn,sp1,sp2)) + else + (* if we cannot eliminate to Type, we cannot discriminate but we + may still try to project *) + project env sorts posn (applist (hd1,args1)) (applist (hd2,args2)) + | _ -> + let t1_0 = applist (hd1,args1) + and t2_0 = applist (hd2,args2) in + if is_conv env sigma t1_0 t2_0 then + [] + else + project env sorts posn t1_0 t2_0 + in + try + let sorts = if keep_proofs then [InSet;InType;InProp] else [InSet;InType] in + Inr (findrec sorts [] t1 t2) + with DiscrFound (path,c1,c2) -> + Inl (path,c1,c2) + +let use_keep_proofs = function + | None -> !keep_proof_equalities_for_injection + | Some b -> b + +let discriminable env sigma t1 t2 = + match find_positions env sigma ~keep_proofs:false ~no_discr:false t1 t2 with + | Inl _ -> true + | _ -> false + +let injectable env sigma ~keep_proofs t1 t2 = + match find_positions env sigma ~keep_proofs:(use_keep_proofs keep_proofs) ~no_discr:true t1 t2 with + | Inl _ -> assert false + | Inr [] | Inr [([],_,_)] -> false + | Inr _ -> true + + +(* Once we have found a position, we need to project down to it. If + we are discriminating, then we need to produce False on one of the + branches of the discriminator, and True on the other one. So the + result type of the case-expressions is always Prop. + + If we are injecting, then we need to discover the result-type. + This can be difficult, since the type of the two terms at the + injection-position can be different, and we need to find a + dependent sigma-type which generalizes them both. + + We can get an approximation to the right type to choose by: + + (0) Before beginning, we reserve a patvar for the default + value of the match, to be used in all the bogus branches. + + (1) perform the case-splits, down to the site of the injection. At + each step, we have a term which is the "head" of the next + case-split. At the point when we actually reach the end of our + path, the "head" is the term to return. We compute its type, and + then, backwards, make a sigma-type with every free debruijn + reference in that type. We can be finer, and first do a S(TRONG)NF + on the type, so that we get the fewest number of references + possible. + + (2) This gives us a closed type for the head, which we use for the + types of all the case-splits. + + (3) Now, we can compute the type of one of T1, T2, and then unify + it with the type of the last component of the result-type, and this + will give us the bindings for the other arguments of the tuple. + + *) + +(* The algorithm, then is to perform successive case-splits. We have + the result-type of the case-split, and also the type of that + result-type. We have a "direction" we want to follow, i.e. a + constructor-number, and in all other "directions", we want to juse + use the default-value. + + After doing the case-split, we call the afterfun, with the updated + environment, to produce the term for the desired "direction". + + The assumption is made here that the result-type is not manifestly + functional, so we can just use the length of the branch-type to + know how many lambda's to stick in. + + *) + +(* [descend_then env sigma head dirn] + + returns the number of products introduced, and the environment + which is active, in the body of the case-branch given by [dirn], + along with a continuation, which expects to be fed: + + (1) the value of the body of the branch given by [dirn] + (2) the default-value + + (3) the type of the default-value, which must also be the type of + the body of the [dirn] branch + + the continuation then constructs the case-split. + *) + +let descend_then env sigma head dirn = + let IndType (indf,_) = + try find_rectype env sigma (get_type_of env sigma head) + with Not_found -> + user_err Pp.(str "Cannot project on an inductive type derived from a dependency.") + in + let indp,_ = (dest_ind_family indf) in + let ind, _ = check_privacy env indp in + let (mib,mip) = lookup_mind_specif env ind in + let cstr = get_constructors env indf in + let dirn_nlams = cstr.(dirn-1).cs_nargs in + let dirn_env = Environ.push_rel_context cstr.(dirn-1).cs_args env in + (dirn_nlams, + dirn_env, + (fun sigma dirnval (dfltval,resty) -> + let deparsign = make_arity_signature env sigma true indf in + let p = + it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in + let build_branch i = + let result = if Int.equal i dirn then dirnval else dfltval in + let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cstr.(i-1).cs_args in + let args = name_context env sigma cs_args in + it_mkLambda_or_LetIn result args in + let brl = + List.map build_branch + (List.interval 1 (Array.length mip.mind_consnames)) in + let ci = make_case_info env ind RegularStyle in + Inductiveops.make_case_or_project env sigma indf ci p head (Array.of_list brl))) + +(* Now we need to construct the discriminator, given a discriminable + position. This boils down to: + + (1) If the position is directly beneath us, then we need to do a + case-split, with result-type Prop, and stick True and False into + the branches, as is convenient. + + (2) If the position is not directly beneath us, then we need to + call descend_then, to descend one step, and then recursively + construct the discriminator. + + *) + +(* [construct_discriminator env sigma dirn c ind special default]] + constructs a case-split on [c] of type [ind], with the [dirn]-th + branch giving [special], and all the rest giving [default]. *) + +let build_selector env sigma dirn c ind special default = + let IndType(indf,_) = + try find_rectype env sigma ind + with Not_found -> + (* one can find Rel(k) in case of dependent constructors + like T := c : (A:Set)A->T and a discrimination + on (c bool true) = (c bool false) + CP : changed assert false in a more informative error + *) + user_err ~hdr:"Equality.construct_discriminator" + (str "Cannot discriminate on inductive constructors with \ + dependent types.") in + let (indp,_) = dest_ind_family indf in + let ind, _ = check_privacy env indp in + let typ = Retyping.get_type_of env sigma default in + let (mib,mip) = lookup_mind_specif env ind in + let deparsign = make_arity_signature env sigma true indf in + let p = it_mkLambda_or_LetIn typ deparsign in + let cstrs = get_constructors env indf in + let build_branch i = + let endpt = if Int.equal i dirn then special else default in + let args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cstrs.(i-1).cs_args in + it_mkLambda_or_LetIn endpt args in + let brl = + List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in + let ci = make_case_info env ind RegularStyle in + let ans = Inductiveops.make_case_or_project env sigma indf ci p c (Array.of_list brl) in + ans + +let build_coq_False () = pf_constr_of_global (lib_ref "core.False.type") +let build_coq_True () = pf_constr_of_global (lib_ref "core.True.type") +let build_coq_I () = pf_constr_of_global (lib_ref "core.True.I") + +let rec build_discriminator env sigma true_0 false_0 dirn c = function + | [] -> + let ind = get_type_of env sigma c in + build_selector env sigma dirn c ind true_0 false_0 + | ((sp,cnum),argnum)::l -> + let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in + let newc = mkRel(cnum_nlams-argnum) in + let subval = build_discriminator cnum_env sigma true_0 false_0 dirn newc l in + kont sigma subval (false_0,mkProp) + +(* Note: discrimination could be more clever: if some elimination is + not allowed because of a large impredicative constructor in the + path (see allowed_sorts in find_positions), the positions could + still be discrimated by projecting first instead of putting the + discrimination combinator inside the projecting combinator. Example + of relevant situation: + + Inductive t:Set := c : forall A:Set, A -> nat -> t. + Goal ~ c _ 0 0 = c _ 0 1. intro. discriminate H. +*) + +let gen_absurdity id = + Proofview.Goal.enter begin fun gl -> + let sigma = project gl in + let hyp_typ = pf_get_hyp_typ id gl in + if is_empty_type sigma hyp_typ + then + simplest_elim (mkVar id) + else + tclZEROMSG (str "Not the negation of an equality.") + end + +(* Precondition: eq is leibniz equality + + returns ((eq_elim t t1 P i t2), absurd_term) + where P=[e:t]discriminator + absurd_term=False +*) + +let ind_scheme_of_eq lbeq = + let (mib,mip) = Global.lookup_inductive (destIndRef lbeq.eq) in + let kind = inductive_sort_family mip in + (* use ind rather than case by compatibility *) + let kind = + if kind == InProp then Elimschemes.ind_scheme_kind_from_prop + else Elimschemes.ind_scheme_kind_from_type in + let c, eff = find_scheme kind (destIndRef lbeq.eq) in + ConstRef c, eff + + +let discrimination_pf e (t,t1,t2) discriminator lbeq = + build_coq_I () >>= fun i -> + build_coq_False () >>= fun absurd_term -> + let eq_elim, eff = ind_scheme_of_eq lbeq in + Proofview.tclEFFECTS eff <*> + pf_constr_of_global eq_elim >>= fun eq_elim -> + Proofview.tclUNIT + (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term) + + +let eq_baseid = Id.of_string "e" + +let apply_on_clause (f,t) clause = + let sigma = clause.evd in + let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in + let argmv = + (match EConstr.kind sigma (last_arg f_clause.evd f_clause.templval.Evd.rebus) with + | Meta mv -> mv + | _ -> 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 = + build_coq_True () >>= fun true_0 -> + build_coq_False () >>= fun false_0 -> + let e = next_ident_away eq_baseid (vars_of_env env) in + let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in + let discriminator = + try + Proofview.tclUNIT + (build_discriminator e_env sigma true_0 false_0 dirn (mkVar e) cpath) + with + UserError _ as ex -> Proofview.tclZERO ex + in + discriminator >>= fun discriminator -> + discrimination_pf e (t,t1,t2) discriminator lbeq >>= fun (pf, absurd_term) -> + let pf_ty = mkArrow eqn absurd_term in + let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in + let pf = Clenvtac.clenv_value_cast_meta absurd_clause in + tclTHENS (assert_after Anonymous absurd_term) + [onLastHypId gen_absurdity; (Proofview.V82.tactic (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr pf)))] + +let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = + let sigma = eq_clause.evd in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + match find_positions env sigma ~keep_proofs:false ~no_discr:false t1 t2 with + | Inr _ -> + tclZEROMSG (str"Not a discriminable equality.") + | Inl (cpath, (_,dirn), _) -> + discr_positions env sigma u eq_clause cpath dirn + end + +let onEquality with_evars tac (c,lbindc) = + Proofview.Goal.enter begin fun gl -> + let type_of = pf_unsafe_type_of gl in + let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in + let t = type_of c in + let t' = try snd (reduce_to_quantified_ind t) with UserError _ -> t in + let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in + let eq_clause' = Clenvtac.clenv_pose_dependent_evars ~with_evars eq_clause in + let eqn = clenv_type eq_clause' in + let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in + tclTHEN + (Proofview.Unsafe.tclEVARS eq_clause'.evd) + (tac (eq,eqn,eq_args) eq_clause') + end + +let onNegatedEquality with_evars tac = + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let ccl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + match EConstr.kind sigma (hnf_constr env sigma ccl) with + | Prod (_,t,u) when is_empty_type sigma u -> + tclTHEN introf + (onLastHypId (fun id -> + onEquality with_evars tac (mkVar id,NoBindings))) + | _ -> + tclZEROMSG (str "Not a negated primitive equality.") + end + +let discrSimpleClause with_evars = function + | None -> onNegatedEquality with_evars discrEq + | Some id -> onEquality with_evars discrEq (mkVar id,NoBindings) + +let discr with_evars = onEquality with_evars discrEq + +let discrClause with_evars = onClause (discrSimpleClause with_evars) + +let discrEverywhere with_evars = + tclTHEN (Proofview.tclUNIT ()) + (* Delay the interpretation of side-effect *) + (tclTHEN + (tclREPEAT introf) + (tryAllHyps + (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings))))) + +let discr_tac with_evars = function + | None -> discrEverywhere with_evars + | Some c -> onInductionArg (fun clear_flag -> discr with_evars) c + +let discrConcl = discrClause false onConcl +let discrHyp id = discrClause false (onHyp id) + +(* returns the sigma type (sigS, sigT) with the respective + constructor depending on the sort *) +(* J.F.: correction du bug #1167 en accord avec Hugo. *) + +let find_sigma_data env s = build_sigma_type () + +(* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser + index bound in [rty] + + Then we build the term + + [(existT A P (mkRel lind) rterm)] of type [(sigS A P)] + + where [A] is the type of [mkRel lind] and [P] is [\na:A.rty{1/lind}] + *) + +let make_tuple env sigma (rterm,rty) lind = + assert (not (noccurn sigma lind rty)); + let sigdata = find_sigma_data env (get_sort_of env sigma rty) in + let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in + let na = Context.Rel.Declaration.get_name (lookup_rel lind env) in + (* We move [lind] to [1] and lift other rels > [lind] by 1 *) + let rty = lift (1-lind) (liftn lind (lind+1) rty) in + (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) + let p = mkLambda (na, a, rty) in + let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in + let sigma, sig_term = Evd.fresh_global env sigma sigdata.typ in + sigma, + (applist(exist_term,[a;p;(mkRel lind);rterm]), + applist(sig_term,[a;p])) + +(* check that the free-references of the type of [c] are contained in + the free-references of the normal-form of that type. Strictly + computing the exact set of free rels would require full + normalization but this is not reasonable (e.g. in presence of + records that contains proofs). We restrict ourself to a "simpl" + normalization *) + +let minimal_free_rels env sigma (c,cty) = + let cty_rels = free_rels sigma cty in + let cty' = simpl env sigma cty in + let rels' = free_rels sigma cty' in + if Int.Set.subset cty_rels rels' then + (cty,cty_rels) + else + (cty',rels') + +(* Like the above, but recurse over all the rels found until there are + no more rels to be found *) +let minimal_free_rels_rec env sigma = + let rec minimalrec_free_rels_rec prev_rels (c,cty) = + let (cty,direct_rels) = minimal_free_rels env sigma (c,cty) in + let combined_rels = Int.Set.union prev_rels direct_rels in + let folder rels i = snd (minimalrec_free_rels_rec rels (c, unsafe_type_of env sigma (mkRel i))) + in (cty, List.fold_left folder combined_rels (Int.Set.elements (Int.Set.diff direct_rels prev_rels))) + in minimalrec_free_rels_rec Int.Set.empty + +(* [sig_clausal_form siglen ty] + + Will explode [siglen] [sigS,sigT ]'s on [ty] (depending on the + type of ty), and return: + + (1) a pattern, with meta-variables in it for various arguments, + which, when the metavariables are replaced with appropriate + terms, will have type [ty] + + (2) an integer, which is the last argument - the one which we just + returned. + + (3) a pattern, for the type of that last meta + + (4) a typing for each patvar + + WARNING: No checking is done to make sure that the + sigS(or sigT)'s are actually there. + - Only homogeneous pairs are built i.e. pairs where all the + dependencies are of the same sort + + [sig_clausal_form] proceed as follows: the default tuple is + constructed by taking the tuple-type, exploding the first [tuplen] + [sigS]'s, and replacing at each step the binder in the + right-hand-type by a fresh metavariable. In addition, on the way + back out, we will construct the pattern for the tuple which uses + these meta-vars. + + This gives us a pattern, which we use to match against the type of + [dflt]; if that fails, then against the S(TRONG)NF of that type. If + both fail, then we just cannot construct our tuple. If one of + those succeed, then we can construct our value easily - we just use + the tuple-pattern. + + *) + +let sig_clausal_form env sigma sort_of_ty siglen ty dflt = + let sigdata = find_sigma_data env sort_of_ty in + let rec sigrec_clausal_form sigma siglen p_i = + if Int.equal siglen 0 then + (* is the default value typable with the expected type *) + let dflt_typ = unsafe_type_of env sigma dflt in + try + let sigma = Evarconv.the_conv_x_leq env dflt_typ p_i sigma in + let sigma = + Evarconv.solve_unif_constraints_with_heuristics env sigma in + sigma, dflt + with Evarconv.UnableToUnify _ -> + user_err Pp.(str "Cannot solve a unification problem.") + else + let (a,p_i_minus_1) = match whd_beta_stack sigma p_i with + | (_sigS,[a;p]) -> (a, p) + | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type.") in + let sigma, ev = Evarutil.new_evar env sigma a in + let rty = beta_applist sigma (p_i_minus_1,[ev]) in + let sigma, tuple_tail = sigrec_clausal_form sigma (siglen-1) rty in + let evopt = match EConstr.kind sigma ev with Evar _ -> None | _ -> Some ev in + match evopt with + | Some w -> + let w_type = unsafe_type_of env sigma w in + begin match Evarconv.cumul env sigma w_type a with + | Some sigma -> + let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in + sigma, applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) + | None -> + user_err Pp.(str "Cannot solve a unification problem.") + end + | None -> + (* This at least happens if what has been detected as a + dependency is not one; use an evasive error message; + even if the problem is upwards: unification should be + tried in the first place in make_iterated_tuple instead + of approximatively computing the free rels; then + unsolved evars would mean not binding rel *) + user_err Pp.(str "Cannot solve a unification problem.") + in + let sigma = Evd.clear_metas sigma in + let sigma, scf = sigrec_clausal_form sigma siglen ty in + sigma, Evarutil.nf_evar sigma scf + +(* The problem is to build a destructor (a generalization of the + predecessor) which, when applied to a term made of constructors + (say [Ci(e1,Cj(e2,Ck(...,term,...),...),...)]), returns a given + subterm of the term (say [term]). + + Let [typ] be the type of [term]. If [term] has no dependencies in + the [e1], [e2], etc, then all is simple. If not, then we need to + encapsulated the dependencies into a dependent tuple in such a way + that the destructor has not a dependent type and rewriting can then + be applied. The destructor has the form + + [e]Cases e of + | ... + | Ci (x1,x2,...) => + Cases x2 of + | ... + | Cj (y1,y2,...) => + Cases y2 of + | ... + | Ck (...,z,...) => z + | ... end + | ... end + | ... end + + and the dependencies is expressed by the fact that [z] has a type + dependent in the x1, y1, ... + + Assume [z] is typed as follows: env |- z:zty + + If [zty] has no dependencies, this is simple. Otherwise, assume + [zty] has free (de Bruijn) variables in,...i1 then the role of + [make_iterated_tuple env sigma (term,typ) (z,zty)] is to build the + tuple + + [existT [xn]Pn Rel(in) .. (existT [x2]P2 Rel(i2) (existT [x1]P1 Rel(i1) z))] + + where P1 is zty[i1/x1], P2 is {x1 | P1[i2/x2]} etc. + + To do this, we find the free (relative) references of the strong NF + of [z]'s type, gather them together in left-to-right order + (i.e. highest-numbered is farthest-left), and construct a big + iterated pair out of it. This only works when the references are + all themselves to members of [Set]s, because we use [sigS] to + construct the tuple. + + Suppose now that our constructed tuple is of length [tuplen]. We + need also to construct a default value for the other branches of + the destructor. As default value, we take a tuple of the form + + [existT [xn]Pn ?n (... existT [x2]P2 ?2 (existT [x1]P1 ?1 term))] + + but for this we have to solve the following unification problem: + + typ = zty[i1/?1;...;in/?n] + + This is done by [sig_clausal_form]. + *) + +let make_iterated_tuple env sigma dflt (z,zty) = + let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in + let sort_of_zty = get_sort_of env sigma zty in + let sorted_rels = Int.Set.elements rels in + let sigma, (tuple,tuplety) = + List.fold_left (fun (sigma, t) -> make_tuple env sigma t) (sigma, (z,zty)) sorted_rels + in + assert (closed0 sigma tuplety); + let n = List.length sorted_rels in + let sigma, dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in + sigma, (tuple,tuplety,dfltval) + +let rec build_injrec env sigma dflt c = function + | [] -> make_iterated_tuple env sigma dflt (c,unsafe_type_of env sigma c) + | ((sp,cnum),argnum)::l -> + try + let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in + let newc = mkRel(cnum_nlams-argnum) in + let sigma, (subval,tuplety,dfltval) = build_injrec cnum_env sigma dflt newc l in + let res = kont sigma subval (dfltval,tuplety) in + sigma, (res, tuplety,dfltval) + with + UserError _ -> failwith "caught" + +let build_injector env sigma dflt c cpath = + let sigma, (injcode,resty,_) = build_injrec env sigma dflt c cpath in + sigma, (injcode,resty) + +let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined") +let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) + +let inject_if_homogenous_dependent_pair ty = + Proofview.Goal.enter begin fun gl -> + try + let sigma = Tacmach.New.project gl in + let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in + (* fetch the informations of the pair *) + let sigTconstr = Coqlib.(lib_ref "core.sigT.type") in + let existTconstr = Coqlib.lib_ref "core.sigT.intro" in + (* check whether the equality deals with dep pairs or not *) + let eqTypeDest = fst (decompose_app sigma t) in + if not (Termops.is_global sigma sigTconstr eqTypeDest) then raise Exit; + let hd1,ar1 = decompose_app_vect sigma t1 and + hd2,ar2 = decompose_app_vect sigma t2 in + if not (Termops.is_global sigma existTconstr hd1) then raise Exit; + if not (Termops.is_global sigma existTconstr hd2) then raise Exit; + let (ind, _), _ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in + (* check if the user has declared the dec principle *) + (* and compare the fst arguments of the dep pair *) + (* Note: should work even if not an inductive type, but the table only *) + (* knows inductive types *) + if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind && + pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; + check_required_library ["Coq";"Logic";"Eqdep_dec"]; + let new_eq_args = [|pf_unsafe_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in + let inj2 = lib_ref "core.eqdep_dec.inj_pair2" in + let c, eff = find_scheme (!eq_dec_scheme_kind_name()) ind in + (* cut with the good equality and prove the requested goal *) + tclTHENLIST + [Proofview.tclEFFECTS eff; + intro; + onLastHyp (fun hyp -> + Tacticals.New.pf_constr_of_global Coqlib.(lib_ref "core.eq.type") >>= fun ceq -> + tclTHENS (cut (mkApp (ceq,new_eq_args))) + [clear [destVar sigma hyp]; + Tacticals.New.pf_constr_of_global inj2 >>= fun inj2 -> + Proofview.V82.tactic (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr + (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|])))) + ])] + with Exit -> + Proofview.tclUNIT () + end + +(* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it + expands then only when the whdnf has a constructor of an inductive type + in hd position, otherwise delta expansion is not done *) + +let simplify_args env sigma t = + (* Quick hack to reduce in arguments of eq only *) + match decompose_app sigma t with + | eq, [t;c1;c2] -> applist (eq,[t;simpl env sigma c1;simpl env sigma c2]) + | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma c1;t2;simpl env sigma c2]) + | _ -> t + +let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = + let e = next_ident_away eq_baseid (vars_of_env env) in + let e_env = push_named (LocalAssum (e,t)) env in + let evdref = ref sigma in + let filter (cpath, t1', t2') = + try + (* arbitrarily take t1' as the injector default value *) + let sigma, (injbody,resty) = build_injector e_env !evdref t1' (mkVar e) cpath in + let injfun = mkNamedLambda e t injbody in + let sigma,congr = Evd.fresh_global env sigma eq.congr in + let pf = applist(congr,[t;resty;injfun;t1;t2]) in + let sigma, pf_typ = Typing.type_of env sigma pf in + let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in + let pf = Clenvtac.clenv_value_cast_meta inj_clause in + let ty = simplify_args env sigma (clenv_type inj_clause) in + evdref := sigma; + Some (pf, ty) + with Failure _ -> None + in + let injectors = List.map_filter filter posns in + if List.is_empty injectors then + tclZEROMSG (str "Failed to decompose the equality.") + else + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) + (Tacticals.New.tclTHENFIRST + (Proofview.tclIGNORE (Proofview.Monad.List.map + (fun (pf,ty) -> tclTHENS (cut ty) + [inject_if_homogenous_dependent_pair ty; + Proofview.V82.tactic (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr pf))]) + (if l2r then List.rev injectors else injectors))) + (tac (List.length injectors))) + +let injEqThen keep_proofs tac l2r (eq,_,(t,t1,t2) as u) eq_clause = + let sigma = eq_clause.evd in + let env = eq_clause.env in + match find_positions env sigma ~keep_proofs ~no_discr:true t1 t2 with + | Inl _ -> + assert false + | Inr [] -> + let suggestion = + if keep_proofs 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 [([],_,_)] -> + tclZEROMSG (str"Nothing to inject.") + | Inr posns -> + inject_at_positions env sigma l2r u eq_clause posns + (tac (clenv_value eq_clause)) + +let get_previous_hyp_position id gl = + let env, sigma = Proofview.Goal.(env gl, sigma gl) in + let rec aux dest = function + | [] -> raise (RefinerError (env, sigma, 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 + aux MoveLast (Proofview.Goal.hyps gl) + +let injEq flags ?(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 flags -> + Some [], true, true, true + | None -> None, false, false, false + | _ -> let b = use_injection_pattern_l2r_order flags 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 begin fun gl -> + let sigma = project gl in + let destopt = match EConstr.kind sigma 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 (keep_proof_equalities flags) post_tac l2r + +let inj flags ipats with_evars clear_flag = onEquality with_evars (injEq flags with_evars clear_flag ipats) + +let injClause flags ipats with_evars = function + | None -> onNegatedEquality with_evars (injEq flags with_evars None ipats) + | Some c -> onInductionArg (inj flags ipats with_evars) c + +let simpleInjClause flags with_evars = function + | None -> onNegatedEquality with_evars (injEq flags ~old:true with_evars None None) + | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (injEq flags ~old:true with_evars clear_flag None)) c + +let injConcl flags = injClause flags None false None +let injHyp flags clear_flag id = injClause flags None false (Some (clear_flag,ElimOnIdent CAst.(make id))) + +let decompEqThen keep_proofs ntac (lbeq,_,(t,t1,t2) as u) clause = + Proofview.Goal.enter begin fun gl -> + let sigma = clause.evd in + let env = Proofview.Goal.env gl in + match find_positions env sigma ~keep_proofs ~no_discr:false t1 t2 with + | Inl (cpath, (_,dirn), _) -> + discr_positions env sigma u clause cpath dirn + | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) + ntac (clenv_value clause) 0 + | Inr posns -> + inject_at_positions env sigma true u clause posns + (ntac (clenv_value clause)) + end + +let dEqThen ~keep_proofs with_evars ntac = function + | None -> onNegatedEquality with_evars (decompEqThen (use_keep_proofs keep_proofs) (ntac None)) + | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (decompEqThen (use_keep_proofs keep_proofs) (ntac clear_flag))) c + +let dEq ~keep_proofs with_evars = + dEqThen ~keep_proofs with_evars (fun clear_flag c x -> + (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) + +let intro_decomp_eq tac data (c, t) = + Proofview.Goal.enter begin fun gl -> + let cl = pf_apply make_clenv_binding gl (c, t) NoBindings in + decompEqThen !keep_proof_equalities_for_injection (fun _ -> tac) data cl + end + +let () = declare_intro_decomp_eq intro_decomp_eq + +(* [subst_tuple_term dep_pair B] + + Given that dep_pair looks like: + + (existT e1 (existT e2 ... (existT en en+1) ... )) + + of type {x1:T1 & {x2:T2(x1) & ... {xn:Tn(x1..xn-1) & en+1 } } } + + and B might contain instances of the ei, we will return the term: + + ([x1:ty1]...[xn+1:tyn+1]B + (projT1 (mkRel 1)) + (projT1 (projT2 (mkRel 1))) + ... + (projT1 (projT2^n (mkRel 1))) + (projT2 (projT2^n (mkRel 1))) + + That is, we will abstract out the terms e1...en+1 of types + t1 (=_beta T1), ..., tn+1 (=_beta Tn+1(e1..en)) as usual, but + will then produce a term in which the abstraction is on a single + term - the debruijn index [mkRel 1], which will be of the same type + as dep_pair (note that the abstracted body may not be typable!). + + ALGORITHM for abstraction: + + We have a list of terms, [e1]...[en+1], which we want to abstract + out of [B]. For each term [ei], going backwards from [n+1], we + just do a [subst_term], and then do a lambda-abstraction to the + type of the [ei]. + + *) + +let decomp_tuple_term env sigma c t = + let rec decomprec inner_code ex exty = + let iterated_decomp = + try + let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose env sigma ex in + let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code]) + and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in + let cdrtyp = beta_applist sigma (p,[car]) in + List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp) + with Constr_matching.PatternMatchingFailure -> + [] + in [((ex,exty),inner_code)]::iterated_decomp + in decomprec (mkRel 1) c t + +let subst_tuple_term env sigma dep_pair1 dep_pair2 b = + let typ = get_type_of env sigma dep_pair1 in + (* We find all possible decompositions *) + let decomps1 = decomp_tuple_term env sigma dep_pair1 typ in + let decomps2 = decomp_tuple_term env sigma dep_pair2 typ in + (* We adjust to the shortest decomposition *) + let n = min (List.length decomps1) (List.length decomps2) in + let decomp1 = List.nth decomps1 (n-1) in + let decomp2 = List.nth decomps2 (n-1) in + (* We rewrite dep_pair1 ... *) + let e1_list,proj_list = List.split decomp1 in + (* ... and use dep_pair2 to compute the expected goal *) + let e2_list,_ = List.split decomp2 in + (* We build the expected goal *) + let abst_B = + List.fold_right + (fun (e,t) body -> lambda_create env sigma (t,subst_term sigma e body)) e1_list b in + let pred_body = beta_applist sigma (abst_B,proj_list) in + let body = mkApp (lambda_create env sigma (typ,pred_body),[|dep_pair1|]) in + let expected_goal = beta_applist sigma (abst_B,List.map fst e2_list) in + (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) + let expected_goal = nf_betaiota env sigma expected_goal in + (* Retype to get universes right *) + let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in + let sigma, _ = Typing.type_of env sigma body in + (sigma, (body, expected_goal)) + +(* Like "replace" but decompose dependent equalities *) +(* i.e. if equality is "exists t v = exists u w", and goal is "phi(t,u)", *) +(* then it uses the predicate "\x.phi(proj1_sig x,proj2_sig x)", and so *) +(* on for further iterated sigma-tuples *) + +let cutSubstInConcl l2r eqn = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in + let typ = pf_concl gl in + let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in + let (sigma, (typ, expected)) = subst_tuple_term env sigma e1 e2 typ in + tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (tclTHENFIRST + (tclTHENLIST [ + (change_concl typ); (* Put in pattern form *) + (replace_core onConcl l2r eqn) + ]) + (change_concl expected)) (* Put in normalized form *) + end + +let cutSubstInHyp l2r eqn id = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in + let typ = pf_get_hyp_typ id gl in + let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in + let (sigma, (typ, expected)) = subst_tuple_term env sigma e1 e2 typ in + tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (tclTHENFIRST + (tclTHENLIST [ + (change_in_hyp None (make_change_arg typ) (id,InHypTypeOnly)); + (replace_core (onHyp id) l2r eqn) + ]) + (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly))) + end + +let try_rewrite tac = + Proofview.tclORELSE tac begin function (e, info) -> match e with + | Constr_matching.PatternMatchingFailure -> + tclZEROMSG (str "Not a primitive equality here.") + | e when catchable_exception e -> + tclZEROMSG + (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") + | e -> Proofview.tclZERO ~info e + end + +let cutSubstClause l2r eqn cls = + match cls with + | None -> cutSubstInConcl l2r eqn + | Some id -> cutSubstInHyp l2r eqn id + +let cutRewriteClause l2r eqn cls = try_rewrite (cutSubstClause l2r eqn cls) +let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) +let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None + +let substClause l2r c cls = + Proofview.Goal.enter begin fun gl -> + let eq = pf_apply get_type_of gl c in + tclTHENS (cutSubstClause l2r eq cls) + [Proofview.tclUNIT (); exact_no_check c] + end + +let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls) +let rewriteInHyp l2r c id = rewriteClause l2r c (Some id) +let rewriteInConcl l2r c = rewriteClause l2r c None + +(* Naming scheme for rewrite and cutrewrite tactics + + give equality give proof of equality + + / cutSubstClause substClause +raw | cutSubstInHyp substInHyp + \ cutSubstInConcl substInConcl + + / cutRewriteClause rewriteClause +user| cutRewriteInHyp rewriteInHyp + \ cutRewriteInConcl rewriteInConcl + +raw = raise typing error or PatternMatchingFailure +user = raise user error specific to rewrite +*) + +(**********************************************************************) +(* Substitutions tactics (JCF) *) + +let regular_subst_tactic = ref true + +let () = + declare_bool_option + { optdepr = false; + optname = "more regular behavior of tactic subst"; + optkey = ["Regular";"Subst";"Tactic"]; + optread = (fun () -> !regular_subst_tactic); + optwrite = (:=) regular_subst_tactic } + +let restrict_to_eq_and_identity eq = (* compatibility *) + if not (is_global (lib_ref "core.eq.type") eq) && + not (is_global (lib_ref "core.identity.type") eq) + then raise Constr_matching.PatternMatchingFailure + +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 = NamedDecl.get_id d in + try + let is_var id c = match EConstr.kind (project gl) 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 (is_var x lhs) && not (local_occur_var (project gl) x rhs) then raise (FoundHyp (id,rhs,true)); + if (is_var x rhs) && not (local_occur_var (project gl) x lhs) then raise (FoundHyp (id,lhs,false)) + with Constr_matching.PatternMatchingFailure -> + () + +(* Rewrite "hyp:x=rhs" or "hyp:rhs=x" (if dir=false) everywhere and + erase hyp and x; proceed by generalizing all dep hyps *) + +let subst_one dep_proof_ok x (hyp,rhs,dir) = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let hyps = Proofview.Goal.hyps gl in + let concl = Proofview.Goal.concl gl in + (* The set of hypotheses using x *) + let dephyps = + List.rev (pi3 (List.fold_right (fun dcl (dest,deps,allhyps) -> + let id = NamedDecl.get_id dcl in + if not (Id.equal id hyp) + && List.exists (fun y -> occur_var_in_decl env sigma y dcl) deps + then + let id_dest = if !regular_subst_tactic then dest else MoveLast in + (dest,id::deps,(id_dest,id)::allhyps) + else + (MoveBefore id,deps,allhyps)) + hyps + (MoveBefore x,[x],[]))) in (* In practice, no dep hyps before x, so MoveBefore x is good enough *) + (* Decides if x appears in conclusion *) + let depconcl = occur_var env sigma x concl in + let need_rewrite = not (List.is_empty dephyps) || depconcl in + tclTHENLIST + ((if need_rewrite then + [revert (List.map snd dephyps); + general_rewrite dir AllOccurrences true dep_proof_ok (mkVar hyp); + (tclMAP (fun (dest,id) -> intro_move (Some id) dest) dephyps)] + else + [Proofview.tclUNIT ()]) @ + [tclTRY (clear [x; hyp])]) + end + +(* Look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite + it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *) + +let subst_one_var dep_proof_ok x = + Proofview.Goal.enter begin fun gl -> + let decl = pf_get_hyp x gl in + (* If x has a body, simply replace x with body and clear x *) + 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 x hyp in + Context.Named.fold_outside test ~init:() hyps; + user_err ~hdr:"Subst" + (str "Cannot find any non-recursive equality over " ++ Id.print x ++ + str".") + with FoundHyp res -> res in + subst_one dep_proof_ok x res + end + +let subst_gen 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 + all dep hyps *) + +let subst = subst_gen true + +type subst_tactic_flags = { + only_leibniz : bool; + rewrite_dependent_proof : bool +} + +let default_subst_tactic_flags = + { only_leibniz = false; rewrite_dependent_proof = true } + +let warn_deprecated_simple_subst = + CWarnings.create ~name:"deprecated-simple-subst" ~category:"deprecated" + (fun () -> strbrk"\"simple subst\" is deprecated") + +let subst_all ?(flags=default_subst_tactic_flags) () = + + let () = + if flags.only_leibniz || not flags.rewrite_dependent_proof then + warn_deprecated_simple_subst () + in + + if !regular_subst_tactic then + + (* First step: find hypotheses to treat in linear time *) + let find_equations gl = + let env = Proofview.Goal.env gl in + let sigma = project gl in + let find_eq_data_decompose = find_eq_data_decompose gl in + let select_equation_name decl = + try + let lbeq,u,(_,x,y) = find_eq_data_decompose (NamedDecl.get_type decl) in + let u = EInstance.kind sigma u in + let eq = Constr.mkRef (lbeq.eq,u) in + if flags.only_leibniz then restrict_to_eq_and_identity eq; + match EConstr.kind sigma x, EConstr.kind sigma y with + | 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 select_equation_name hyps) + in + + (* Second step: treat equations *) + let process hyp = + Proofview.Goal.enter begin fun gl -> + let sigma = project 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 |> 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 EConstr.eq_constr sigma x y then Proofview.tclUNIT () else + match EConstr.kind sigma x, EConstr.kind sigma y with + | Var x', _ when not (Termops.local_occur_var sigma x' y) && not (is_evaluable env (EvalVarRef x')) -> + subst_one flags.rewrite_dependent_proof x' (hyp,y,true) + | _, Var y' when not (Termops.local_occur_var sigma y' x) && not (is_evaluable env (EvalVarRef y')) -> + subst_one flags.rewrite_dependent_proof y' (hyp,x,false) + | _ -> + Proofview.tclUNIT () + end + in + Proofview.Goal.enter begin fun gl -> + let ids = find_equations gl in + tclMAP process ids + end + + else + +(* Old implementation, not able to manage configurations like a=b, a=t, + or situations like "a = S b, b = S a", or also accidentally unfolding + let-ins *) + Proofview.Goal.enter begin fun gl -> + let sigma = project gl in + let find_eq_data_decompose = find_eq_data_decompose gl in + let test (_,c) = + try + let lbeq,u,(_,x,y) = find_eq_data_decompose c in + let u = EInstance.kind sigma u in + let eq = Constr.mkRef (lbeq.eq,u) in + if flags.only_leibniz then restrict_to_eq_and_identity eq; + (* J.F.: added to prevent failure on goal containing x=x as an hyp *) + if EConstr.eq_constr sigma x y then failwith "caught"; + match EConstr.kind sigma x with Var x -> x | _ -> + match EConstr.kind sigma y with Var y -> y | _ -> failwith "caught" + with Constr_matching.PatternMatchingFailure -> failwith "caught" in + let test p = try Some (test p) with Failure _ -> None in + let hyps = pf_hyps_types gl in + let ids = List.map_filter test hyps in + let ids = List.uniquize ids in + subst_gen flags.rewrite_dependent_proof ids + end + +(* Rewrite the first assumption for which a condition holds + and gives the direction of the rewrite *) + +let cond_eq_term_left c t gl = + try + let (_,x,_) = pi3 (find_eq_data_decompose gl t) in + if pf_conv_x gl c x then true else failwith "not convertible" + with Constr_matching.PatternMatchingFailure -> failwith "not an equality" + +let cond_eq_term_right c t gl = + try + let (_,_,x) = pi3 (find_eq_data_decompose gl t) in + if pf_conv_x gl c x then false else failwith "not convertible" + with Constr_matching.PatternMatchingFailure -> failwith "not an equality" + +let cond_eq_term c t gl = + try + let (_,x,y) = pi3 (find_eq_data_decompose gl t) in + if pf_conv_x gl c x then true + else if pf_conv_x gl c y then false + else failwith "not convertible" + with Constr_matching.PatternMatchingFailure -> failwith "not an equality" + +let rewrite_assumption_cond cond_eq_term cl = + let rec arec hyps gl = match hyps with + | [] -> user_err Pp.(str "No such assumption.") + | hyp ::rest -> + let id = NamedDecl.get_id hyp in + begin + try + 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 + in + Proofview.Goal.enter begin fun gl -> + let hyps = Proofview.Goal.hyps gl in + arec hyps gl + end + +(* Generalize "subst x" to substitution of subterm appearing as an + equation in the context, but not clearing the hypothesis *) + +let replace_term dir_opt c = + let cond_eq_fun = + match dir_opt with + | None -> cond_eq_term c + | Some true -> cond_eq_term_left c + | Some false -> cond_eq_term_right c + in + rewrite_assumption_cond cond_eq_fun + +(* Declare rewriting tactic for intro patterns "<-" and "->" *) + +let () = + let gmr l2r with_evars tac c = general_rewrite_clause l2r with_evars tac c in + Hook.set Tactics.general_rewrite_clause gmr + +let () = Hook.set Tactics.subst_one subst_one diff --git a/tactics/equality.mli b/tactics/equality.mli new file mode 100644 index 0000000000..6f3e08ea02 --- /dev/null +++ b/tactics/equality.mli @@ -0,0 +1,145 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(*i*) +open Names +open Evd +open EConstr +open Environ +open Ind_tables +open Locus +open Tactypes +open Tactics +(*i*) + +type dep_proof_flag = bool (* true = support rewriting dependent proofs *) +type freeze_evars_flag = bool (* true = don't instantiate existing evars *) + +type orientation = bool + +type conditions = + | Naive (* Only try the first occurrence of the lemma (default) *) + | FirstSolved (* Use the first match whose side-conditions are solved *) + | AllMatches (* Rewrite all matches whose side-conditions are solved *) + +val general_rewrite_bindings : + orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> + ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> evars_flag -> unit Proofview.tactic +val general_rewrite : + orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> + ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic + +(* Equivalent to [general_rewrite l2r] *) +val rewriteLR : ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic +val rewriteRL : ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic + +(* Warning: old [general_rewrite_in] is now [general_rewrite_bindings_in] *) + +val general_setoid_rewrite_clause : + (Id.t option -> orientation -> occurrences -> constr with_bindings -> + new_goals:constr list -> unit Proofview.tactic) Hook.t + +val general_rewrite_ebindings_clause : Id.t option -> + orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> + ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> evars_flag -> unit Proofview.tactic + +val general_rewrite_bindings_in : + orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> + ?tac:(unit Proofview.tactic * conditions) -> + Id.t -> constr with_bindings -> evars_flag -> unit Proofview.tactic +val general_rewrite_in : + orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> + ?tac:(unit Proofview.tactic * conditions) -> Id.t -> constr -> evars_flag -> unit Proofview.tactic + +val general_rewrite_clause : + orientation -> evars_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> clause -> unit Proofview.tactic + +type multi = + | Precisely of int + | UpTo of int + | RepeatStar + | RepeatPlus + +val general_multi_rewrite : + evars_flag -> (bool * multi * clear_flag * delayed_open_constr_with_bindings) list -> + clause -> (unit Proofview.tactic * conditions) option -> unit Proofview.tactic + +val replace_in_clause_maybe_by : constr -> constr -> clause -> unit Proofview.tactic option -> unit Proofview.tactic +val replace : constr -> constr -> unit Proofview.tactic +val replace_by : constr -> constr -> unit Proofview.tactic -> unit Proofview.tactic + +type inj_flags = { + keep_proof_equalities : bool; (* One may want it or not *) + injection_in_context : bool; (* For regularity; one may want it from ML code but not interactively *) + injection_pattern_l2r_order : bool; (* Compatibility option: no reason not to want it *) + } + +val discr : evars_flag -> constr with_bindings -> unit Proofview.tactic +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 Tactics.destruction_arg option -> unit Proofview.tactic + +(* Below, if flag is [None], it takes the value from the dynamic value of the option *) +val inj : inj_flags option -> intro_patterns option -> evars_flag -> + clear_flag -> constr with_bindings -> unit Proofview.tactic +val injClause : inj_flags option -> intro_patterns option -> evars_flag -> + constr with_bindings Tactics.destruction_arg option -> unit Proofview.tactic +val injHyp : inj_flags option -> clear_flag -> Id.t -> unit Proofview.tactic +val injConcl : inj_flags option -> unit Proofview.tactic +val simpleInjClause : inj_flags option -> evars_flag -> + constr with_bindings Tactics.destruction_arg option -> unit Proofview.tactic + +val dEq : keep_proofs:(bool option) -> evars_flag -> constr with_bindings Tactics.destruction_arg option -> unit Proofview.tactic +val dEqThen : keep_proofs:(bool option) -> evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings Tactics.destruction_arg option -> unit Proofview.tactic + +val make_iterated_tuple : + env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) + +(* The family cutRewriteIn expect an equality statement *) +val cutRewriteInHyp : bool -> types -> Id.t -> unit Proofview.tactic +val cutRewriteInConcl : bool -> constr -> unit Proofview.tactic + +(* The family rewriteIn expect the proof of an equality *) +val rewriteInHyp : bool -> constr -> Id.t -> unit Proofview.tactic +val rewriteInConcl : bool -> constr -> unit Proofview.tactic + +(* Tells if tactic "discriminate" is applicable *) +val discriminable : env -> evar_map -> constr -> constr -> bool + +(* Tells if tactic "injection" is applicable *) +val injectable : env -> evar_map -> keep_proofs:(bool option) -> constr -> constr -> bool + +(* Subst *) + +(* val unfold_body : Id.t -> tactic *) + +type subst_tactic_flags = { + only_leibniz : bool; + rewrite_dependent_proof : bool +} +val subst_gen : bool -> Id.t list -> unit Proofview.tactic +val subst : Id.t list -> unit Proofview.tactic +val subst_all : ?flags:subst_tactic_flags -> unit -> unit Proofview.tactic + +(* Replace term *) +(* [replace_term dir_opt c cl] + perfoms replacement of [c] by the first value found in context + (according to [dir] if given to get the rewrite direction) in the clause [cl] +*) +val replace_term : bool option -> constr -> clause -> unit Proofview.tactic + +val set_eq_dec_scheme_kind : mutual scheme_kind -> unit + +(* [build_selector env sigma i c t u v] matches on [c] of + type [t] and returns [u] in branch [i] and [v] on other branches *) +val build_selector : env -> evar_map -> int -> constr -> types -> + constr -> constr -> constr diff --git a/tactics/genredexpr.ml b/tactics/genredexpr.ml new file mode 100644 index 0000000000..8209684c37 --- /dev/null +++ b/tactics/genredexpr.ml @@ -0,0 +1,79 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Reduction expressions *) + +(** The parsing produces initially a list of [red_atom] *) + +type 'a red_atom = + | FBeta + | FMatch + | FFix + | FCofix + | FZeta + | FConst of 'a list + | FDeltaBut of 'a list + +(** This list of atoms is immediately converted to a [glob_red_flag] *) + +type 'a glob_red_flag = { + rBeta : bool; + rMatch : bool; + rFix : bool; + rCofix : bool; + rZeta : bool; + rDelta : bool; (** true = delta all but rConst; false = delta only on rConst*) + rConst : 'a list +} + +(** Generic kinds of reductions *) + +type ('a,'b,'c) red_expr_gen = + | Red of bool + | Hnf + | Simpl of 'b glob_red_flag*('b,'c) Util.union Locus.with_occurrences option + | Cbv of 'b glob_red_flag + | Cbn of 'b glob_red_flag + | Lazy of 'b glob_red_flag + | Unfold of 'b Locus.with_occurrences list + | Fold of 'a list + | Pattern of 'a Locus.with_occurrences list + | ExtraRedExpr of string + | CbvVm of ('b,'c) Util.union Locus.with_occurrences option + | CbvNative of ('b,'c) Util.union Locus.with_occurrences option + +type ('a,'b,'c) may_eval = + | ConstrTerm of 'a + | ConstrEval of ('a,'b,'c) red_expr_gen * 'a + | ConstrContext of Names.lident * 'a + | ConstrTypeOf of 'a + +open Libnames +open Constrexpr + +type r_trm = constr_expr +type r_pat = constr_pattern_expr +type r_cst = qualid or_by_notation + +type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen + +let make0 ?dyn name = + let wit = Genarg.make0 name in + let () = Geninterp.register_val0 wit dyn in + wit + +type 'a and_short_name = 'a * Names.lident option + +let wit_red_expr : + ((constr_expr,qualid or_by_notation,constr_expr) red_expr_gen, + (Genintern.glob_constr_and_expr,Names.evaluable_global_reference and_short_name Locus.or_var,Genintern.glob_constr_pattern_and_expr) red_expr_gen, + (EConstr.t,Names.evaluable_global_reference,Pattern.constr_pattern) red_expr_gen) + Genarg.genarg_type = + make0 "redexpr" diff --git a/tactics/hints.ml b/tactics/hints.ml new file mode 100644 index 0000000000..571ad9d160 --- /dev/null +++ b/tactics/hints.ml @@ -0,0 +1,1654 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open Util +open CErrors +open Names +open Constr +open Evd +open EConstr +open Vars +open Environ +open Mod_subst +open Globnames +open Libobject +open Namegen +open Libnames +open Smartlocate +open Termops +open Inductiveops +open Typing +open Decl_kinds +open Typeclasses +open Pattern +open Patternops +open Clenv +open Tacred +open Printer + +module NamedDecl = Context.Named.Declaration + +(****************************************) +(* General functions *) +(****************************************) + +type debug = Debug | Info | Off + +exception Bound + +let head_constr_bound sigma t = + let t = strip_outer_cast sigma t in + let _,ccl = decompose_prod_assum sigma t in + let hd,args = decompose_app sigma ccl in + match EConstr.kind sigma hd with + | Const (c, _) -> ConstRef c + | Ind (i, _) -> IndRef i + | Construct (c, _) -> ConstructRef c + | Var id -> VarRef id + | Proj (p, _) -> ConstRef (Projection.constant p) + | _ -> raise Bound + +let head_constr sigma c = + try head_constr_bound sigma c + with Bound -> user_err (Pp.str "Head identifier must be a constant, section variable, \ + (co)inductive type, (co)inductive type constructor, or projection.") + +let decompose_app_bound sigma t = + let t = strip_outer_cast sigma t in + let _,ccl = decompose_prod_assum sigma t in + let hd,args = decompose_app_vect sigma ccl in + match EConstr.kind sigma hd with + | Const (c,u) -> ConstRef c, args + | Ind (i,u) -> IndRef i, args + | Construct (c,u) -> ConstructRef c, args + | Var id -> VarRef id, args + | 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 = + { hint_priority = None; hint_pattern = None } + +(************************************************************************) +(* The Type of Constructions Autotactic Hints *) +(************************************************************************) + +type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen + +type 'a hint_ast = + | Res_pf of 'a (* Hint Apply *) + | ERes_pf of 'a (* Hint EApply *) + | Give_exact of 'a + | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) + | Unfold_nth of evaluable_global_reference (* Hint Unfold *) + | Extern of Genarg.glob_generic_argument (* Hint Extern *) + + +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 = GlobRef.t 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.qualid hints_path_gen +type hints_path = GlobRef.t hints_path_gen + +type hint_term = + | IsGlobRef of GlobRef.t + | IsConstr of constr * Univ.ContextSet.t + +type 'a with_uid = { + obj : 'a; + uid : KerName.t; +} + +type raw_hint = constr * types * Univ.ContextSet.t + +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 *) + 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 + +type hint_entry = GlobRef.t option * + raw_hint hint_ast with_uid with_metadata + +type reference_or_constr = + | HintsReference of qualid + | HintsConstr of Constrexpr.constr_expr + +type hint_mode = + | ModeInput (* No evars *) + | ModeNoHeadEvar (* No evar at the head *) + | ModeOutput (* Anything *) + +type 'a hints_transparency_target = + | HintsVariables + | HintsConstants + | HintsReferences of 'a list + +type hints_expr = + | HintsResolve of (hint_info_expr * bool * reference_or_constr) list + | HintsResolveIFF of bool * qualid list * int option + | HintsImmediate of reference_or_constr list + | HintsUnfold of qualid list + | HintsTransparency of qualid hints_transparency_target * bool + | HintsMode of qualid * hint_mode list + | HintsConstructors of qualid list + | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument + +type import_level = [ `LAX | `WARN | `STRICT ] + +let warn_hint : import_level ref = ref `LAX +let read_warn_hint () = match !warn_hint with +| `LAX -> "Lax" +| `WARN -> "Warn" +| `STRICT -> "Strict" + +let write_warn_hint = function +| "Lax" -> warn_hint := `LAX +| "Warn" -> warn_hint := `WARN +| "Strict" -> warn_hint := `STRICT +| _ -> user_err Pp.(str "Only the following flags are accepted: Lax, Warn, Strict.") + +let () = + Goptions.(declare_string_option + { optdepr = false; + optname = "behavior of non-imported hints"; + optkey = ["Loose"; "Hint"; "Behavior"]; + optread = read_warn_hint; + optwrite = write_warn_hint; + }) + +let fresh_key = + let id = Summary.ref ~name:"HINT-COUNTER" 0 in + fun () -> + let cur = incr id; !id in + let lbl = Id.of_string ("_" ^ string_of_int cur) in + let kn = Lib.make_kn lbl in + let (mp, _) = KerName.repr kn in + (* We embed the full path of the kernel name in the label so that + the identifier should be unique. This ensures that including + two modules together won't confuse the corresponding labels. *) + let lbl = Id.of_string_soft (Printf.sprintf "%s#%i" + (ModPath.to_string mp) cur) + in + KerName.make mp (Label.of_id lbl) + +let pri_order_int (id1, {pri=pri1}) (id2, {pri=pri2}) = + let d = pri1 - pri2 in + if Int.equal d 0 then id2 - id1 + else d + +let pri_order t1 t2 = pri_order_int t1 t2 <= 0 + +(* Nov 98 -- Papageno *) +(* Les Hints sont ré-organisés en plusieurs databases. + + La table impérative "searchtable", de type "hint_db_table", + associe une database (hint_db) à chaque nom. + + Une hint_db est une table d'association fonctionelle constr -> search_entry + Le constr correspond à la constante de tête de la conclusion. + + Une search_entry est un triplet comprenant : + - la liste des tactiques qui n'ont pas de pattern associé + - la liste des tactiques qui ont un pattern + - un discrimination net borné (Btermdn.t) constitué de tous les + patterns de la seconde liste de tactiques *) + +type stored_data = int * full_hint + (* First component is the index of insertion in the table, to keep most recent first semantics. *) + +module Bounded_net = Btermdn.Make(struct + type t = stored_data + let compare = pri_order_int + end) + +type search_entry = { + sentry_nopat : stored_data list; + sentry_pat : stored_data list; + sentry_bnet : Bounded_net.t; + sentry_mode : hint_mode array list; +} + +let empty_se = { + sentry_nopat = []; + sentry_pat = []; + sentry_bnet = Bounded_net.empty; + sentry_mode = []; +} + +let eq_pri_auto_tactic (_, x) (_, y) = KerName.equal x.code.uid y.code.uid + +let add_tac pat t st se = + match pat with + | None -> + if List.exists (eq_pri_auto_tactic t) se.sentry_nopat then se + else { se with sentry_nopat = List.insert pri_order t se.sentry_nopat } + | Some pat -> + if List.exists (eq_pri_auto_tactic t) se.sentry_pat then se + else { se with + sentry_pat = List.insert pri_order t se.sentry_pat; + sentry_bnet = Bounded_net.add st se.sentry_bnet (pat, t); } + +let rebuild_dn st se = + let dn' = + List.fold_left + (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t))) + Bounded_net.empty se.sentry_pat + in + { se with sentry_bnet = dn' } + +let lookup_tacs sigma concl st se = + let l' = Bounded_net.lookup sigma st se.sentry_bnet concl in + let sl' = List.stable_sort pri_order_int l' in + List.merge pri_order_int se.sentry_nopat sl' + +module Constr_map = Map.Make(GlobRef.Ordered) + +let is_transparent_gr ts = function + | VarRef id -> TransparentState.is_transparent_variable ts id + | ConstRef cst -> TransparentState.is_transparent_constant ts cst + | IndRef _ | ConstructRef _ -> false + +let strip_params env sigma c = + match EConstr.kind sigma c with + | App (f, args) -> + (match EConstr.kind sigma f with + | Const (cst,_) -> + (match Recordops.find_primitive_projection cst with + | Some p -> + let p = Projection.make p false in + let npars = Projection.npars p in + if Array.length args > npars then + mkApp (mkProj (p, args.(npars)), + Array.sub args (npars+1) (Array.length args - (npars + 1))) + else c + | None -> c) + | _ -> c) + | _ -> c + +let instantiate_hint env sigma p = + let mk_clenv (c, cty, ctx) = + let sigma = Evd.merge_context_set univ_flexible sigma ctx in + let cl = mk_clenv_from_env env sigma None (c,cty) in + {cl with templval = + { cl.templval with rebus = strip_params env sigma cl.templval.rebus }; + env = empty_env} + in + let code = match p.code.obj with + | Res_pf c -> Res_pf (c, mk_clenv c) + | ERes_pf c -> ERes_pf (c, mk_clenv c) + | Res_pf_THEN_trivial_fail c -> + Res_pf_THEN_trivial_fail (c, mk_clenv c) + | Give_exact c -> Give_exact (c, mk_clenv c) + | Unfold_nth e -> Unfold_nth e + | Extern t -> Extern t + in + { p with code = { p.code with obj = code } } + +let hints_path_atom_eq h1 h2 = match h1, h2 with +| PathHints l1, PathHints l2 -> List.equal GlobRef.equal l1 l2 +| PathAny, PathAny -> true +| _ -> false + +let rec hints_path_eq h1 h2 = match h1, h2 with +| PathAtom h1, PathAtom h2 -> hints_path_atom_eq h1 h2 +| PathStar h1, PathStar h2 -> hints_path_eq h1 h2 +| PathSeq (l1, r1), PathSeq (l2, r2) -> + hints_path_eq l1 l2 && hints_path_eq r1 r2 +| PathOr (l1, r1), PathOr (l2, r2) -> + hints_path_eq l1 l2 && hints_path_eq r1 r2 +| PathEmpty, PathEmpty -> true +| PathEpsilon, PathEpsilon -> true +| _ -> false + +let path_matches hp hints = + let rec aux hp hints k = + match hp, hints with + | PathAtom _, [] -> false + | PathAtom PathAny, (_ :: hints') -> k hints' + | PathAtom p, (h :: hints') -> + if hints_path_atom_eq p h then k hints' else false + | PathStar hp', hints -> + k hints || aux hp' hints (fun hints' -> aux hp hints' k) + | PathSeq (hp, hp'), hints -> + aux hp hints (fun hints' -> aux hp' hints' k) + | PathOr (hp, hp'), hints -> + aux hp hints k || aux hp' hints k + | PathEmpty, _ -> false + | PathEpsilon, hints -> k hints + in aux hp hints (fun hints' -> true) + +let rec matches_epsilon = function + | PathAtom _ -> false + | PathStar _ -> true + | PathSeq (p, p') -> matches_epsilon p && matches_epsilon p' + | PathOr (p, p') -> matches_epsilon p || matches_epsilon p' + | PathEmpty -> false + | PathEpsilon -> true + +let rec is_empty = function + | PathAtom _ -> false + | PathStar _ -> false + | PathSeq (p, p') -> is_empty p || is_empty p' + | PathOr (p, p') -> matches_epsilon p && matches_epsilon p' + | 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 + | gr :: grs, gr' :: grs' when GlobRef.equal gr gr' -> derivate_atoms grs grs' + | [], [] -> PathEpsilon + | [], hints -> PathEmpty + | grs, [] -> PathAtom (PathHints grs) + | _, _ -> PathEmpty + in + 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 + | PathStar PathEpsilon -> PathEpsilon + | PathSeq (PathEmpty, _) | PathSeq (_, PathEmpty) -> PathEmpty + | PathSeq (PathEpsilon, p) | PathSeq (p, PathEpsilon) -> normalize_path p + | PathOr (PathEmpty, p) | PathOr (p, PathEmpty) -> normalize_path p + | PathOr (p, q) -> + let p', q' = normalize_path p, normalize_path q in + if hints_path_eq p p' && hints_path_eq q q' then h + else normalize_path (PathOr (p', q')) + | PathSeq (p, q) -> + let p', q' = normalize_path p, normalize_path q in + if hints_path_eq p p' && hints_path_eq q q' then h + else normalize_path (PathSeq (p', q')) + | _ -> h + +let path_derivate hp hint = normalize_path (path_derivate hp hint) + +let pp_hints_path_atom prg a = + match a with + | 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 + | PathAny -> p + | PathHints grs -> + let gr' gr = fst (subst_global subst gr) in + let grs' = List.Smart.map gr' grs in + if grs' == grs then p else PathHints grs' + +let rec subst_hints_path subst hp = + match hp with + | PathAtom p -> + let p' = subst_path_atom subst p in + if p' == p then hp else PathAtom p' + | PathStar p -> let p' = subst_hints_path subst p in + if p' == p then hp else PathStar p' + | PathSeq (p, q) -> + let p' = subst_hints_path subst p in + let q' = subst_hints_path subst q in + if p' == p && q' == q then hp else PathSeq (p', q') + | PathOr (p, q) -> + let p' = subst_hints_path subst p in + let q' = subst_hints_path subst q in + if p' == p && q' == q then hp else PathOr (p', q') + | _ -> hp + +type hint_db_name = string + +module Hint_db : +sig +type t +val empty : ?name:hint_db_name -> TransparentState.t -> bool -> t +val find : GlobRef.t -> t -> search_entry +val map_none : secvars:Id.Pred.t -> t -> full_hint list +val map_all : secvars:Id.Pred.t -> GlobRef.t -> t -> full_hint list +val map_existential : evar_map -> secvars:Id.Pred.t -> + (GlobRef.t * constr array) -> constr -> t -> full_hint list +val map_eauto : evar_map -> secvars:Id.Pred.t -> + (GlobRef.t * constr array) -> constr -> t -> full_hint list +val map_auto : evar_map -> secvars:Id.Pred.t -> + (GlobRef.t * 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 : GlobRef.t -> t -> t +val remove_list : GlobRef.t list -> t -> t +val iter : (GlobRef.t option -> hint_mode array list -> full_hint list -> unit) -> t -> unit +val use_dn : t -> bool +val transparent_state : t -> TransparentState.t +val set_transparent_state : t -> TransparentState.t -> t +val add_cut : hints_path -> t -> t +val add_mode : GlobRef.t -> hint_mode array -> t -> t +val cut : t -> hints_path +val unfolds : t -> Id.Set.t * Cset.t +val fold : (GlobRef.t option -> hint_mode array list -> full_hint list -> 'a -> 'a) -> + t -> 'a -> 'a + +end = +struct + + type t = { + hintdb_state : TransparentState.t; + hintdb_cut : hints_path; + hintdb_unfolds : Id.Set.t * Cset.t; + hintdb_max_id : int; + use_dn : bool; + hintdb_map : search_entry Constr_map.t; + (* A list of unindexed entries starting with an unfoldable constant + or with no associated pattern. *) + hintdb_nopat : (GlobRef.t 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 ?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_name = name; } + + let find key db = + try Constr_map.find key db.hintdb_map + with Not_found -> empty_se + + 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 head_evar sigma c = + let rec hrec c = match EConstr.kind sigma c with + | Evar (evk,_) -> evk + | Case (_,_,c,_) -> hrec c + | App (c,_) -> hrec c + | Cast (c,_,_) -> hrec c + | Proj (p, c) -> hrec c + | _ -> raise Evarutil.NoHeadEvar + in + hrec c + + let match_mode sigma m arg = + match m with + | ModeInput -> not (occur_existential sigma arg) + | ModeNoHeadEvar -> + (try ignore(head_evar sigma arg); false + with Evarutil.NoHeadEvar -> true) + | ModeOutput -> true + + let matches_mode sigma args mode = + Array.length mode == Array.length args && + Array.for_all2 (match_mode sigma) mode args + + let matches_modes sigma args modes = + if List.is_empty modes then true + else List.exists (matches_mode sigma args) modes + + 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_filter (realize_tac secvars) h + + let map_none ~secvars db = + merge_entry secvars db [] [] + + let map_all ~secvars k db = + let se = find k db in + merge_entry secvars db se.sentry_nopat se.sentry_pat + + (* Precondition: concl has no existentials *) + let map_auto sigma ~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 sigma concl st se in + merge_entry secvars db [] pat + + let map_existential sigma ~secvars (k,args) concl db = + let se = find k db in + if matches_modes sigma args se.sentry_mode then + merge_entry secvars db se.sentry_nopat se.sentry_pat + else merge_entry secvars db [] [] + + (* [c] contains an existential *) + let map_eauto sigma ~secvars (k,args) concl db = + let se = find k db in + if matches_modes sigma args se.sentry_mode then + let st = if db.use_dn then Some db.hintdb_state else None in + let pat = lookup_tacs sigma concl st se in + merge_entry secvars db [] pat + else merge_entry secvars db [] [] + + let is_exact = function + | Give_exact _ -> true + | _ -> false + + let is_unfold = function + | Unfold_nth _ -> true + | _ -> false + + let addkv gr id v db = + 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 + | None -> None + in + let dnst = if db.use_dn then Some db.hintdb_state else None in + let pat = if not db.use_dn && is_exact v.code.obj then None else v.pat in + match k with + | None -> + let is_present (_, (_, v')) = KerName.equal v.code.uid v'.code.uid in + if not (List.exists is_present db.hintdb_nopat) then + (* FIXME *) + { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } + else db + | Some gr -> + let oval = find gr db in + { db with hintdb_map = Constr_map.add gr (add_tac pat idv dnst oval) db.hintdb_map } + + let rebuild_db st' db = + let db' = + { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map; + hintdb_state = st'; hintdb_nopat = [] } + in + List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat + + let add_one env sigma (k, v) db = + let v = instantiate_hint env sigma v in + let st',db,rebuild = + match v.code.obj with + | Unfold_nth egr -> + let addunf ts (ids, csts) = + let open TransparentState in + match egr with + | EvalVarRef id -> + { ts with tr_var = Id.Pred.add id ts.tr_var }, (Id.Set.add id ids, csts) + | EvalConstRef cst -> + { ts with tr_cst = Cpred.add cst ts.tr_cst }, (ids, Cset.add cst csts) + in + let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in + state, { db with hintdb_unfolds = unfs }, true + | _ -> db.hintdb_state, db, false + in + let db = if db.use_dn && rebuild then rebuild_db st' db else db in + let db, id = next_hint_id db in + addkv k id v db + + let add_list env sigma l db = List.fold_left (fun db k -> add_one env sigma k db) db l + + let remove_sdl p sdl = List.filter p sdl + + let remove_he st p se = + let sl1' = remove_sdl p se.sentry_nopat in + let sl2' = remove_sdl p se.sentry_pat in + if sl1' == se.sentry_nopat && sl2' == se.sentry_pat then se + else rebuild_dn st { se with sentry_nopat = sl1'; sentry_pat = sl2' } + + let remove_list grs db = + let filter (_, h) = + match h.name with PathHints [gr] -> not (List.mem_f GlobRef.equal gr grs) | _ -> true in + let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in + let hintnopat = List.filter (fun (ge, sd) -> filter sd) db.hintdb_nopat in + { db with hintdb_map = hintmap; hintdb_nopat = hintnopat } + + let remove_one gr db = remove_list [gr] db + + let get_entry se = + let h = List.merge pri_order_int se.sentry_nopat se.sentry_pat in + 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 -> snd (snd x)) db.hintdb_nopat); + Constr_map.iter iter_se db.hintdb_map + + let fold f db accu = + let accu = f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in + Constr_map.fold (fun k se -> f (Some k) se.sentry_mode (get_entry se)) db.hintdb_map accu + + let transparent_state db = db.hintdb_state + + let set_transparent_state db st = + if db.use_dn then rebuild_db st db + else { db with hintdb_state = st } + + let add_cut path db = + { db with hintdb_cut = normalize_path (PathOr (db.hintdb_cut, path)) } + + let add_mode gr m db = + let se = find gr db in + let se = { se with sentry_mode = m :: se.sentry_mode } in + { db with hintdb_map = Constr_map.add gr se db.hintdb_map } + + let cut db = db.hintdb_cut + + let unfolds db = db.hintdb_unfolds + + let use_dn db = db.use_dn + +end + +module Hintdbmap = String.Map + +type hint_db = Hint_db.t + +(** Initially created hint databases, for typeclasses and rewrite *) +let typeclasses_db = "typeclass_instances" +let rewrite_db = "rewrite" + +let auto_init_db = + Hintdbmap.add typeclasses_db (Hint_db.empty TransparentState.full true) + (Hintdbmap.add rewrite_db (Hint_db.empty TransparentState.cst_full true) + Hintdbmap.empty) + +let searchtable = Summary.ref ~name:"searchtable" auto_init_db +let statustable = Summary.ref ~name:"statustable" KNmap.empty + +let searchtable_map name = + Hintdbmap.find name !searchtable +let searchtable_add (name,db) = + searchtable := Hintdbmap.add name db !searchtable +let current_db_names () = Hintdbmap.domain !searchtable +let current_db () = Hintdbmap.bindings !searchtable + +let current_pure_db () = List.map snd (current_db ()) + +let error_no_such_hint_database x = + user_err ~hdr:"Hints" (str "No such Hint database: " ++ str x ++ str ".") + +(**************************************************************************) +(* Auxiliary functions to prepare AUTOHINT objects *) +(**************************************************************************) + +let rec nb_hyp sigma c = match EConstr.kind sigma c with + | Prod(_,_,c2) -> if noccurn sigma 1 c2 then 1+(nb_hyp sigma c2) else nb_hyp sigma c2 + | _ -> 0 + +(* adding and removing tactics in the search table *) + +let try_head_pattern c = + try head_pattern_bound c + with BoundPattern -> + user_err (Pp.str "Head pattern or sub-pattern must be a global constant, a section variable, \ + an if, case, or let expression, an application, or a projection.") + +let with_uid c = { obj = c; uid = fresh_key () } + +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 sigma c = + secvars_of_idset (Termops.global_vars_set env sigma c) + +let secvars_of_global env gr = + secvars_of_idset (vars_of_global env gr) + +let make_exact_entry env sigma info poly ?(name=PathAny) (c, cty, ctx) = + let secvars = secvars_of_constr env sigma c in + let cty = strip_outer_cast sigma cty in + match EConstr.kind sigma cty with + | Prod _ -> failwith "make_exact_entry" + | _ -> + let pat = Patternops.pattern_of_constr env sigma (EConstr.to_constr ~abort_on_undefined_evars:false sigma cty) in + let hd = + try head_pattern_bound pat + with BoundPattern -> failwith "make_exact_entry" + in + 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) info poly ?(name=PathAny) (c, cty, ctx) = + let cty = if hnf then hnf_constr env sigma cty else cty in + match EConstr.kind sigma cty with + | Prod _ -> + let sigma' = Evd.merge_context_set univ_flexible sigma ctx in + let ce = mk_clenv_from_env env sigma' None (c,cty) in + let c' = clenv_type (* ~reduce:false *) ce in + let pat = Patternops.pattern_of_constr env ce.evd (EConstr.to_constr ~abort_on_undefined_evars:false sigma c') in + let hd = + try head_pattern_bound pat + with BoundPattern -> failwith "make_apply_entry" in + let miss = clenv_missing ce in + let nmiss = List.length miss in + let secvars = secvars_of_constr env sigma c in + let pri = match info.hint_priority with None -> nb_hyp sigma' 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; 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 begin + let variables = str (CString.plural nmiss "variable") in + Feedback.msg_info ( + strbrk "The hint " ++ + pr_leconstr_env env sigma' c ++ + strbrk " will only be used by eauto, because applying " ++ + pr_leconstr_env env sigma' c ++ + strbrk " would leave " ++ variables ++ Pp.spc () ++ + Pp.prlist_with_sep Pp.pr_comma Name.print (List.map (Evd.meta_name ce.evd) miss) ++ + strbrk " as unresolved existential " ++ variables ++ str "." + ) + end; + (Some hd, + { pri; poly; pat = Some pat; name; + db = None; secvars; + code = with_uid (ERes_pf(c,cty,ctx)); }) + end + | _ -> failwith "make_apply_entry" + +(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose + c is a constr + cty is the type of constr *) + +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_econstr_env env sigma c + +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 fresh_global_or_constr env sigma poly cr = + let isgr, (c, ctx) = + match cr with + | IsGlobRef gr -> + let (c, ctx) = UnivGen.fresh_global_instance env gr in + true, (EConstr.of_constr c, ctx) + | 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); + Declare.declare_universe_context false 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 info poly ?name; + make_apply_entry env sigma flags info poly ?name] + in + if List.is_empty ents then + user_err ~hdr:"Hint" + (pr_leconstr_env env sigma c ++ spc() ++ + (if pi1 flags then str"cannot be used as a hint." + else str "can be used as a hint only for eauto.")); + ents + +(* used to add an hypothesis to the local hint database *) +let make_resolve_hyp env sigma decl = + let hname = NamedDecl.get_id decl in + let c = mkVar hname in + try + [make_apply_entry env sigma (true, true, false) empty_hint_info false + ~name:(PathHints [VarRef hname]) + (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, + { pri = 4; + 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 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 = + let open Term in + let ty, _ = Typeops.type_of_global_in_context (Global.env ()) ref in + let ctx, t = decompose_prod ty in + let n = List.length ctx in + let m' = Array.of_list m in + if not (n == Array.length m') then + user_err ~hdr:"Hint" + (pr_global ref ++ str" has " ++ int n ++ + str" arguments while the mode declares " ++ int (Array.length m')) + else m' + +let make_trivial env sigma poly ?(name=PathAny) r = + let c,ctx = fresh_global_or_constr env sigma poly r in + let sigma = Evd.merge_context_set univ_flexible sigma ctx in + let t = hnf_constr env sigma (unsafe_type_of env sigma c) in + let hd = head_constr sigma t in + let ce = mk_clenv_from_env env sigma None (c,t) in + (Some hd, { pri=1; + poly = poly; + pat = Some (Patternops.pattern_of_constr env ce.evd (EConstr.to_constr sigma (clenv_type ce))); + name = name; + db = None; + secvars = secvars_of_constr env sigma c; + code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) + + + +(**************************************************************************) +(* declaration of the AUTOHINT library object *) +(**************************************************************************) + +(* If the database does not exist, it is created *) +(* TODO: should a warning be printed in this case ?? *) + +let get_db dbname = + try searchtable_map dbname + with Not_found -> Hint_db.empty ~name:dbname TransparentState.empty false + +let add_hint dbname hintlist = + let check (_, h) = + let () = if KNmap.mem h.code.uid !statustable then + user_err Pp.(str "Conflicting hint keys. This can happen when including \ + twice the same module.") + in + statustable := KNmap.add h.code.uid false !statustable + in + let () = List.iter check hintlist in + let db = get_db dbname in + let env = Global.env () in + let sigma = Evd.from_env env in + let db' = Hint_db.add_list env sigma hintlist db in + searchtable_add (dbname,db') + +let add_transparency dbname target b = + let open TransparentState in + let db = get_db dbname in + let st = Hint_db.transparent_state db in + let st' = + match target with + | HintsVariables -> { st with tr_var = (if b then Id.Pred.full else Id.Pred.empty) } + | HintsConstants -> { st with tr_cst = (if b then Cpred.full else Cpred.empty) } + | HintsReferences grs -> + List.fold_left (fun st gr -> + match gr with + | EvalConstRef c -> { st with tr_cst = (if b then Cpred.add else Cpred.remove) c st.tr_cst } + | EvalVarRef v -> { st with tr_var = (if b then Id.Pred.add else Id.Pred.remove) v st.tr_var }) + st grs + in searchtable_add (dbname, Hint_db.set_transparent_state db st') + +let remove_hint dbname grs = + let db = get_db dbname in + let db' = Hint_db.remove_list grs db in + searchtable_add (dbname, db') + +type hint_action = + | CreateDB of bool * TransparentState.t + | AddTransparency of evaluable_global_reference hints_transparency_target * bool + | AddHints of hint_entry list + | RemoveHints of GlobRef.t list + | AddCut of hints_path + | AddMode of GlobRef.t * hint_mode array + +let add_cut dbname path = + let db = get_db dbname in + let db' = Hint_db.add_cut path db in + searchtable_add (dbname, db') + +let add_mode dbname l m = + let db = get_db dbname in + let db' = Hint_db.add_mode l m db in + searchtable_add (dbname, db') + +type hint_obj = { + hint_local : bool; + hint_name : string; + hint_action : hint_action; +} + +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 ~name st b) + | AddTransparency (grs, b) -> add_transparency name grs b + | AddHints hints -> add_hint name hints + | RemoveHints grs -> remove_hint name grs + | AddCut path -> add_cut name path + | AddMode (l, m) -> add_mode name l m + +let open_autohint i (kn, h) = + if Int.equal i 1 then match h.hint_action with + | AddHints hints -> + let add (_, hint) = statustable := KNmap.add hint.code.uid true !statustable in + List.iter add hints + | _ -> () + +let cache_autohint (kn, obj) = + load_autohint 1 (kn, obj); open_autohint 1 (kn, obj) + +let subst_autohint (subst, obj) = + let subst_key gr = + let (gr', t) = subst_global subst gr in + match t with + | None -> gr' + | Some t -> + (try head_constr_bound Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value) + with Bound -> gr') + in + let subst_hint (k,data as hint) = + let k' = Option.Smart.map subst_key k in + let pat' = Option.Smart.map (subst_pattern subst) data.pat in + let subst_mps subst c = EConstr.of_constr (subst_mps subst (EConstr.Unsafe.to_constr c)) in + let code' = match data.code.obj with + | Res_pf (c,t,ctx) -> + let c' = subst_mps subst c in + let t' = subst_mps subst t in + if c==c' && t'==t then data.code.obj else Res_pf (c', t',ctx) + | ERes_pf (c,t,ctx) -> + let c' = subst_mps subst c in + let t' = subst_mps subst t in + if c==c' && t'==t then data.code.obj else ERes_pf (c',t',ctx) + | Give_exact (c,t,ctx) -> + let c' = subst_mps subst c in + let t' = subst_mps subst t in + if c==c' && t'== t then data.code.obj else Give_exact (c',t',ctx) + | Res_pf_THEN_trivial_fail (c,t,ctx) -> + let c' = subst_mps subst c in + let t' = subst_mps subst t in + if c==c' && t==t' then data.code.obj else Res_pf_THEN_trivial_fail (c',t',ctx) + | Unfold_nth ref -> + let ref' = subst_evaluable_reference subst ref in + if ref==ref' then data.code.obj else Unfold_nth ref' + | Extern tac -> + let tac' = Genintern.generic_substitute subst tac in + if tac==tac' then data.code.obj else Extern tac' + in + let name' = subst_path_atom subst data.name in + let uid' = subst_kn subst data.code.uid in + let data' = + if data.code.uid == uid' && data.pat == pat' && + data.name == name' && data.code.obj == code' then data + else { data with pat = pat'; name = name'; code = { obj = code'; uid = uid' } } + in + if k' == k && data' == data then hint else (k',data') + in + let action = match obj.hint_action with + | CreateDB _ -> obj.hint_action + | AddTransparency (target, b) -> + let target' = + match target with + | HintsVariables -> target + | HintsConstants -> target + | HintsReferences grs -> + let grs' = List.Smart.map (subst_evaluable_reference subst) grs in + if grs == grs' then target + else HintsReferences grs' + in + if target' == target then obj.hint_action else AddTransparency (target', b) + | AddHints hintlist -> + let hintlist' = List.Smart.map subst_hint hintlist in + if hintlist' == hintlist then obj.hint_action else AddHints hintlist' + | RemoveHints grs -> + let grs' = List.Smart.map (subst_global_reference subst) grs in + if grs == grs' then obj.hint_action else RemoveHints grs' + | AddCut path -> + let path' = subst_hints_path subst path in + if path' == path then obj.hint_action else AddCut path' + | AddMode (l,m) -> + let l' = subst_global_reference subst l in + if l' == l then obj.hint_action else AddMode (l', m) + in + if action == obj.hint_action then obj else { obj with hint_action = action } + +let classify_autohint obj = + match obj.hint_action with + | AddHints [] -> Dispose + | _ -> if obj.hint_local then Dispose else Substitute obj + +let inAutoHint : hint_obj -> obj = + declare_object {(default_object "AUTOHINT") with + cache_function = cache_autohint; + load_function = load_autohint; + open_function = open_autohint; + subst_function = subst_autohint; + classify_function = classify_autohint; } + +let make_hint ?(local = false) name action = { + hint_local = local; + hint_name = name; + hint_action = action; +} + +let create_hint_db l n st b = + let hint = make_hint ~local:l n (CreateDB (b, st)) in + Lib.add_anonymous_leaf (inAutoHint hint) + +let remove_hints local dbnames grs = + let dbnames = if List.is_empty dbnames then ["core"] else dbnames in + List.iter + (fun dbname -> + let hint = make_hint ~local dbname (RemoveHints grs) in + Lib.add_anonymous_leaf (inAutoHint hint)) + dbnames + +(**************************************************************************) +(* The "Hint" vernacular command *) +(**************************************************************************) +let add_resolves env sigma clist local dbnames = + List.iter + (fun dbname -> + let r = + List.flatten (List.map (fun (pri, poly, hnf, path, gr) -> + make_resolves env sigma (true,hnf,not !Flags.quiet) + pri poly ~name:path gr) clist) + in + let hint = make_hint ~local dbname (AddHints r) in + Lib.add_anonymous_leaf (inAutoHint hint)) + dbnames + +let add_unfolds l local dbnames = + List.iter + (fun dbname -> + let hint = make_hint ~local dbname (AddHints (List.map make_unfold l)) in + Lib.add_anonymous_leaf (inAutoHint hint)) + dbnames + +let add_cuts l local dbnames = + List.iter + (fun dbname -> + let hint = make_hint ~local dbname (AddCut l) in + Lib.add_anonymous_leaf (inAutoHint hint)) + dbnames + +let add_mode l m local dbnames = + List.iter + (fun dbname -> + let m' = make_mode l m in + let hint = make_hint ~local dbname (AddMode (l, m')) in + Lib.add_anonymous_leaf (inAutoHint hint)) + dbnames + +let add_transparency l b local dbnames = + List.iter + (fun dbname -> + let hint = make_hint ~local dbname (AddTransparency (l, b)) in + Lib.add_anonymous_leaf (inAutoHint hint)) + dbnames + +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 (Option.get info.hint_priority) pat tacast]) in + Lib.add_anonymous_leaf (inAutoHint hint) + +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 + (fun dbname -> + let l = List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l in + let hint = make_hint ~local dbname (AddHints l) in + Lib.add_anonymous_leaf (inAutoHint hint)) + dbnames + +type hnf = bool + +type nonrec hint_info = hint_info + +type hints_entry = + | 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 hints_transparency_target * bool + | HintsModeEntry of GlobRef.t * hint_mode list + | HintsExternEntry of hint_info * Genarg.glob_generic_argument + +let default_prepare_hint_ident = Id.of_string "H" + +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 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 sigma, _ = Evd.nf_univ_variables sigma in + let c = Evarutil.nf_evar sigma c in + let c = drop_extra_implicit_args sigma c in + let vars = ref (collect_vars sigma c) in + let subst = ref [] in + let rec find_next_evar c = match EConstr.kind sigma c with + | Evar (evk,args as ev) -> + (* We skip the test whether args is the identity or not *) + let t = Evarutil.nf_evar sigma (existential_type sigma ev) in + let t = List.fold_right (fun (e,id) c -> replace_term sigma e id c) !subst t in + if not (closed0 sigma c) then + user_err Pp.(str "Hints with holes dependent on a bound variable not supported."); + if occur_existential sigma t then + (* Not clever enough to construct dependency graph of evars *) + user_err Pp.(str "Not clever enough to deal with evars dependent in other evars."); + raise (Found (c,t)) + | _ -> EConstr.iter sigma find_next_evar c in + let rec iter c = + try find_next_evar c; c + with Found (evar,t) -> + let id = next_ident_away_from default_prepare_hint_ident (fun id -> Id.Set.mem id !vars) in + vars := Id.Set.add id !vars; + subst := (evar,mkVar id)::!subst; + mkNamedLambda id t (iter (replace_term sigma evar (mkVar id) c)) in + let c' = iter c in + let env = Global.env () in + let empty_sigma = Evd.from_env env in + if check then Pretyping.check_evars env empty_sigma 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 (Declare.declare_universe_context false diff; + IsConstr (c', Univ.ContextSet.empty)) + +let project_hint ~poly pri l2r r = + let open EConstr in + let open Coqlib in + let gr = Smartlocate.global_with_alias r in + let env = Global.env() in + let sigma = Evd.from_env env in + let sigma, c = Evd.fresh_global env sigma gr in + let t = Retyping.get_type_of env sigma c in + let t = + Tacred.reduce_to_quantified_ref env sigma (lib_ref "core.iff.type") t in + let sign,ccl = decompose_prod_assum sigma t in + let (a,b) = match snd (decompose_app sigma ccl) with + | [a;b] -> (a,b) + | _ -> assert false in + let p = + if l2r then lib_ref "core.iff.proj1" else lib_ref "core.iff.proj2" in + let sigma, p = Evd.fresh_global env sigma p in + let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in + let c = it_mkLambda_or_LetIn + (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in + let id = + Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) + in + let ctx = Evd.const_univ_entry ~poly sigma in + let c = EConstr.to_constr sigma c in + let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in + let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in + (info,false,true,PathAny, IsGlobRef (Globnames.ConstRef c)) + +let interp_hints poly = + fun h -> + let env = Global.env () in + let sigma = Evd.from_env env in + let f poly c = + let evd,c = Constrintern.interp_open_constr env sigma c in + let env = Global.env () in + let sigma = Evd.from_env env in + prepare_hint true (poly,false) env sigma (evd,c) in + let fref r = + let gr = global_with_alias r in + Dumpglob.add_glob ?loc:r.CAst.loc gr; + gr in + let fr r = evaluable_of_global_reference env (fref r) in + let fi c = + match c with + | HintsReference c -> + let gr = global_with_alias c in + (PathHints [gr], poly, IsGlobRef gr) + | HintsConstr c -> (PathAny, poly, f poly c) + in + let fp = Constrintern.intern_constr_pattern env sigma in + let fres (info, b, r) = + let path, poly, gr = fi r in + let info = { info with hint_pattern = Option.map fp info.hint_pattern } in + (info, poly, b, path, gr) + in + let ft = function + | HintsVariables -> HintsVariables + | HintsConstants -> HintsConstants + | HintsReferences lhints -> HintsReferences (List.map fr lhints) + in + let fp = Constrintern.intern_constr_pattern (Global.env()) in + match h with + | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) + | HintsResolveIFF (l2r, lc, n) -> + HintsResolveEntry (List.map (project_hint ~poly n l2r) lc) + | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) + | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints) + | HintsTransparency (t, b) -> HintsTransparencyEntry (ft t, b) + | HintsMode (r, l) -> HintsModeEntry (fref r, l) + | HintsConstructors lqid -> + let constr_hints_of_ind qid = + let ind = global_inductive_with_alias qid in + let mib,_ = Global.lookup_inductive ind in + Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" (string_of_qualid qid) "ind"; + List.init (nconstructors ind) + (fun i -> let c = (ind,i+1) in + let gr = ConstructRef c in + empty_hint_info, + (Declareops.inductive_is_polymorphic mib), 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 sigma) patcom in + let l = match pat with None -> [] | Some (l, _) -> l in + let ltacvars = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in + let env = Genintern.({ (empty_glob_sign env) with ltacvars }) in + let _, tacexp = Genintern.generic_intern env tacexp in + HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp) + +let add_hints ~local dbnames h = + if String.List.mem "nocore" dbnames then + user_err Pp.(str "The hint database \"nocore\" is meant to stay empty."); + assert (not (List.is_empty dbnames)); + let env = Global.env() in + let sigma = Evd.from_env env in + match h with + | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames + | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames + | HintsCutEntry lhints -> add_cuts lhints local dbnames + | HintsModeEntry (l,m) -> add_mode l m local dbnames + | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames + | HintsTransparencyEntry (lhints, b) -> + add_transparency lhints b 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 EConstr.kind sigma lem with + | Ind (ind,u) -> + List.init (nconstructors ind) + (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)) + | _ -> + [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 constructor_hints env sigma eapply lems = + let lems = expand_constructor_hints env sigma lems in + List.map_append (fun (poly, lem) -> + make_resolves env sigma (eapply,true,false) empty_hint_info poly lem) lems + +let make_local_hint_db env sigma ts eapply lems = + let map c = c env sigma in + let lems = List.map map lems in + let sign = EConstr.named_context env in + let ts = match ts with + | None -> Hint_db.transparent_state (searchtable_map "core") + | Some ts -> ts + in + let hintlist = List.map_append (make_resolve_hyp env sigma) sign in + Hint_db.empty ts false + |> Hint_db.add_list env sigma hintlist + |> Hint_db.add_list env sigma (constructor_hints env sigma eapply lems) + +let make_local_hint_db env sigma ?ts eapply lems = + make_local_hint_db env sigma ts eapply lems + +let make_db_list dbnames = + let use_core = not (List.mem "nocore" dbnames) in + let dbnames = List.remove String.equal "nocore" dbnames in + let dbnames = if use_core then "core"::dbnames else dbnames in + let lookup db = + try searchtable_map db with Not_found -> error_no_such_hint_database db + in + List.map lookup dbnames + +(**************************************************************************) +(* Functions for printing the hints *) +(**************************************************************************) + +let pr_hint_elt env sigma (c, _, _) = pr_econstr_env env sigma c + +let pr_hint env sigma h = match h.obj with + | Res_pf (c, _) -> (str"simple apply " ++ pr_hint_elt env sigma c) + | ERes_pf (c, _) -> (str"simple eapply " ++ pr_hint_elt env sigma c) + | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt env sigma c) + | Res_pf_THEN_trivial_fail (c, _) -> + (str"simple apply " ++ pr_hint_elt env sigma c ++ str" ; trivial") + | Unfold_nth c -> + str"unfold " ++ pr_evaluable_reference c + | Extern tac -> + str "(*external*) " ++ Pputils.pr_glb_generic env tac + +let pr_id_hint env sigma (id, v) = + let pr_pat p = str", pattern " ++ pr_lconstr_pattern_env env sigma p in + (pr_hint env sigma 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 env sigma hintlist = + (str " " ++ hov 0 (prlist (pr_id_hint env sigma) hintlist) ++ fnl ()) + +let pr_hints_db env sigma (name,db,hintlist) = + (str "In the database " ++ str name ++ str ":" ++ + if List.is_empty hintlist then (str " nothing" ++ fnl ()) + else (fnl () ++ pr_hint_list env sigma hintlist)) + +(* Print all hints associated to head c in any database *) +let pr_hint_list_for_head env sigma c = + let dbs = current_db () in + let validate (name, db) = + let hints = List.map (fun v -> 0, v) (Hint_db.map_all ~secvars:Id.Pred.full c db) in + (name, db, hints) + in + let valid_dbs = List.map validate dbs in + if List.is_empty valid_dbs then + (str "No hint declared for :" ++ pr_global c) + else + hov 0 + (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++ + hov 0 (prlist (pr_hints_db env sigma) valid_dbs)) + +let pr_hint_ref ref = pr_hint_list_for_head ref + +(* Print all hints associated to head id in any database *) + +let pr_hint_term env sigma cl = + try + let dbs = current_db () in + let valid_dbs = + let fn = try + let hdc = decompose_app_bound sigma cl in + if occur_existential sigma cl then + Hint_db.map_existential sigma ~secvars:Id.Pred.full hdc cl + else Hint_db.map_auto sigma ~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 + in + if List.is_empty valid_dbs then + (str "No hint applicable for current goal") + else + (str "Applicable Hints :" ++ fnl () ++ + hov 0 (prlist (pr_hints_db env sigma) valid_dbs)) + with Match_failure _ | Failure _ -> + (str "No hint applicable for current goal") + +(* print all hints that apply to the concl of the current goal *) +let pr_applicable_hint () = + let env = Global.env () in + let pts = Proof_global.give_me_the_proof () in + let Proof.{goals;sigma} = Proof.data pts in + match goals with + | [] -> CErrors.user_err Pp.(str "No focused goal.") + | g::_ -> + pr_hint_term env sigma (Goal.V82.concl sigma g) + +let pp_hint_mode = function + | ModeInput -> str"+" + | ModeNoHeadEvar -> str"!" + | ModeOutput -> str"-" + +(* displays the whole hint database db *) +let pr_hint_db_env env sigma db = + 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")" + in + let content = + let fold head modes hintlist accu = + let goal_descr = match head with + | None -> str "For any goal" + | Some head -> str "For " ++ pr_global head ++ pr_modes modes + in + let hints = pr_hint_list env sigma (List.map (fun x -> (0, x)) hintlist) in + let hint_descr = hov 0 (goal_descr ++ str " -> " ++ hints) in + accu ++ hint_descr + in + Hint_db.fold fold db (mt ()) + in + let { TransparentState.tr_var = ids; tr_cst = csts } = Hint_db.transparent_state db in + hov 0 + ((if Hint_db.use_dn db then str"Discriminated database" + else str"Non-discriminated database")) ++ fnl () ++ + hov 2 (str"Unfoldable variable definitions: " ++ pr_idpred ids) ++ fnl () ++ + hov 2 (str"Unfoldable constant definitions: " ++ pr_cpred csts) ++ fnl () ++ + hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db)) ++ fnl () ++ + content + +let pr_hint_db_by_name env sigma dbname = + try + let db = searchtable_map dbname in pr_hint_db_env env sigma db + with Not_found -> + error_no_such_hint_database dbname + +(* displays all the hints of all databases *) +let pr_searchtable env sigma = + let fold name db accu = + accu ++ str "In the database " ++ str name ++ str ":" ++ fnl () ++ + pr_hint_db_env env sigma db ++ fnl () + in + Hintdbmap.fold fold !searchtable (mt ()) + +let print_mp mp = + try + let qid = Nametab.shortest_qualid_of_module mp in + str " from " ++ pr_qualid qid + with Not_found -> mt () + +let is_imported h = try KNmap.find h.uid !statustable with Not_found -> true + +let hint_trace = Evd.Store.field () + +let log_hint h = + let open Proofview.Notations in + Proofview.tclEVARMAP >>= fun sigma -> + let store = get_extra_data sigma in + match Store.get store hint_trace with + | None -> + (* All calls to hint logging should be well-scoped *) + assert false + | Some trace -> + let trace = KNmap.add h.uid h trace in + let store = Store.set store hint_trace trace in + Proofview.Unsafe.tclEVARS (set_extra_data store sigma) + +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 env sigma h = + let hint = pr_hint env sigma h in + let mp = KerName.modpath h.uid in + warn_non_imported_hint (hint,mp) + +let wrap_hint_warning t = + let open Proofview.Notations in + Proofview.tclEVARMAP >>= fun sigma -> + let store = get_extra_data sigma in + let old = Store.get store hint_trace in + let store = Store.set store hint_trace KNmap.empty in + Proofview.Unsafe.tclEVARS (set_extra_data store sigma) >>= fun () -> + t >>= fun ans -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + let store = get_extra_data sigma in + let hints = match Store.get store hint_trace with + | None -> assert false + | Some hints -> hints + in + let () = KNmap.iter (fun _ h -> warn env sigma h) hints in + let store = match old with + | None -> Store.remove store hint_trace + | Some v -> Store.set store hint_trace v + in + Proofview.Unsafe.tclEVARS (set_extra_data store sigma) >>= fun () -> + Proofview.tclUNIT ans + +let wrap_hint_warning_fun env sigma t = + let store = get_extra_data sigma in + let old = Store.get store hint_trace in + let store = Store.set store hint_trace KNmap.empty in + let (ans, sigma) = t (set_extra_data store sigma) in + let store = get_extra_data sigma in + let hints = match Store.get store hint_trace with + | None -> assert false + | Some hints -> hints + in + let () = KNmap.iter (fun _ h -> warn env sigma h) hints in + let store = match old with + | None -> Store.remove store hint_trace + | Some v -> Store.set store hint_trace v + in + (ans, set_extra_data store sigma) + +let run_hint tac k = match !warn_hint with +| `LAX -> k tac.obj +| `WARN -> + if is_imported tac then k tac.obj + else Proofview.tclTHEN (log_hint tac) (k tac.obj) +| `STRICT -> + if is_imported tac then k tac.obj + else Proofview.tclZERO (UserError (None, (str "Tactic failure."))) + +let repr_hint h = h.obj diff --git a/tactics/hints.mli b/tactics/hints.mli new file mode 100644 index 0000000000..dd2c63d351 --- /dev/null +++ b/tactics/hints.mli @@ -0,0 +1,301 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Names +open EConstr +open Environ +open Decl_kinds +open Evd +open Tactypes +open Clenv +open Pattern +open Typeclasses + +(** {6 General functions. } *) + +exception Bound + +val decompose_app_bound : evar_map -> constr -> GlobRef.t * constr array + +type debug = Debug | Info | Off + +val secvars_of_hyps : ('c, 't) Context.Named.pt -> Id.Pred.t + +val empty_hint_info : 'a Typeclasses.hint_info_gen + +(** Pre-created hint databases *) + +type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen + +type 'a hint_ast = + | Res_pf of 'a (* Hint Apply *) + | ERes_pf of 'a (* Hint EApply *) + | Give_exact of 'a + | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) + | Unfold_nth of evaluable_global_reference (* Hint Unfold *) + | Extern of Genarg.glob_generic_argument (* Hint Extern *) + +type hint +type raw_hint = constr * types * Univ.ContextSet.t + +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 = GlobRef.t 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 *) + 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 + +type search_entry + +(** The head may not be bound. *) + +type hint_entry + +type reference_or_constr = + | HintsReference of Libnames.qualid + | HintsConstr of Constrexpr.constr_expr + +type hint_mode = + | ModeInput (* No evars *) + | ModeNoHeadEvar (* No evar at the head *) + | ModeOutput (* Anything *) + +type 'a hints_transparency_target = + | HintsVariables + | HintsConstants + | HintsReferences of 'a list + +type hints_expr = + | HintsResolve of (hint_info_expr * bool * reference_or_constr) list + | HintsResolveIFF of bool * Libnames.qualid list * int option + | HintsImmediate of reference_or_constr list + | HintsUnfold of Libnames.qualid list + | HintsTransparency of Libnames.qualid hints_transparency_target * bool + | HintsMode of Libnames.qualid * hint_mode list + | HintsConstructors of Libnames.qualid list + | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument + +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.qualid hints_path_gen +type hints_path = GlobRef.t 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_gen : ('a -> Pp.t) -> 'a hints_path_gen -> Pp.t +val pp_hints_path_atom : ('a -> Pp.t) -> 'a hints_path_atom_gen -> Pp.t +val pp_hints_path : hints_path -> Pp.t +val pp_hint_mode : hint_mode -> Pp.t +val glob_hints_path_atom : + Libnames.qualid hints_path_atom_gen -> GlobRef.t hints_path_atom_gen +val glob_hints_path : + Libnames.qualid hints_path_gen -> GlobRef.t hints_path_gen + +module Hint_db : + sig + type t + val empty : ?name:hint_db_name -> TransparentState.t -> bool -> t + val find : GlobRef.t -> t -> search_entry + + (** 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 : secvars:Id.Pred.t -> GlobRef.t -> 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 : evar_map -> secvars:Id.Pred.t -> + (GlobRef.t * 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 : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list + + (** All hints associated to the reference, respecting modes if evars appear in the + arguments. *) + val map_auto : evar_map -> secvars:Id.Pred.t -> + (GlobRef.t * 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 : GlobRef.t -> t -> t + val remove_list : GlobRef.t list -> t -> t + val iter : (GlobRef.t option -> + hint_mode array list -> full_hint list -> unit) -> t -> unit + + val use_dn : t -> bool + val transparent_state : t -> TransparentState.t + val set_transparent_state : t -> TransparentState.t -> t + + val add_cut : hints_path -> t -> t + val cut : t -> hints_path + + val unfolds : t -> Id.Set.t * Cset.t + end + +type hint_db = Hint_db.t + +type hnf = bool + +type hint_term = + | IsGlobRef of GlobRef.t + | IsConstr of constr * Univ.ContextSet.t + +type hints_entry = + | 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 hints_transparency_target * bool + | HintsModeEntry of GlobRef.t * hint_mode list + | HintsExternEntry of hint_info * Genarg.glob_generic_argument + +val searchtable_map : hint_db_name -> hint_db + +val searchtable_add : (hint_db_name * hint_db) -> unit + +(** [create_hint_db local name st use_dn]. + [st] is a transparency state for unification using this db + [use_dn] switches the use of the discrimination net for all hints + and patterns. *) + +val create_hint_db : bool -> hint_db_name -> TransparentState.t -> bool -> unit + +val remove_hints : bool -> hint_db_name list -> GlobRef.t list -> unit + +val current_db_names : unit -> String.Set.t + +val current_pure_db : unit -> hint_db list + +val interp_hints : polymorphic -> hints_expr -> hints_entry + +val add_hints : local:bool -> hint_db_name list -> hints_entry -> unit + +val prepare_hint : bool (* Check no remaining evars *) -> + (bool * bool) (* polymorphic or monomorphic, local or global *) -> + env -> evar_map -> evar_map * constr -> hint_term + +(** [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]. + [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.ContextSet.t) -> hint_entry + +(** [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]. + [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 -> hint_info -> polymorphic -> ?name:hints_path_atom -> + (constr * types * Univ.ContextSet.t) -> hint_entry + +(** A constr which is Hint'ed will be: + - (1) used as an Exact, if it does not start with a product + - (2) used as an Apply, if its HNF starts with a product, and + has no missing arguments. + - (3) used as an EApply, if its HNF starts with a product, and + has missing arguments. *) + +val make_resolves : + env -> evar_map -> bool * bool * bool -> hint_info -> polymorphic -> ?name:hints_path_atom -> + hint_term -> hint_entry list + +(** [make_resolve_hyp hname htyp]. + used to add an hypothesis to the local hint database; + Never raises a user exception; + If the hyp cannot be used as a Hint, the empty list is returned. *) + +val make_resolve_hyp : + env -> evar_map -> named_declaration -> hint_entry list + +(** [make_extern pri pattern tactic_expr] *) + +val make_extern : + int -> constr_pattern option -> Genarg.glob_generic_argument + -> hint_entry + +val run_hint : hint -> + ((raw_hint * clausenv) hint_ast -> 'r Proofview.tactic) -> 'r Proofview.tactic + +(** This function is for backward compatibility only, not to use in newly + written code. *) +val repr_hint : hint -> (raw_hint * clausenv) hint_ast + +(** 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:TransparentState.t -> bool -> delayed_open_constr list -> hint_db + +val make_db_list : hint_db_name list -> hint_db list + +(** Initially created hint databases, for typeclasses and rewrite *) + +val typeclasses_db : hint_db_name +val rewrite_db : hint_db_name + +val wrap_hint_warning : 'a Proofview.tactic -> 'a Proofview.tactic +(** Use around toplevel calls to hint-using tactics, to enable the tracking of + non-imported hints. Any tactic calling [run_hint] must be wrapped this + way. *) + +val wrap_hint_warning_fun : env -> evar_map -> + (evar_map -> 'a * evar_map) -> 'a * evar_map +(** Variant of the above for non-tactics *) + +(** Printing hints *) + +val pr_searchtable : env -> evar_map -> Pp.t +val pr_applicable_hint : unit -> Pp.t +val pr_hint_ref : env -> evar_map -> GlobRef.t -> Pp.t +val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t +val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t +val pr_hint : env -> evar_map -> hint -> Pp.t diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml new file mode 100644 index 0000000000..708412720a --- /dev/null +++ b/tactics/hipattern.ml @@ -0,0 +1,552 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Names +open Constr +open Termops +open EConstr +open Inductiveops +open Constr_matching +open Coqlib +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. + + They are more general than matching with or_term, and_term, etc, + since they do not depend on the name of the type. Hence, they + also work on ad-hoc disjunctions introduced by the user. + + -- Eduardo (6/8/97). *) + +type 'a matching_function = Evd.evar_map -> EConstr.constr -> 'a option + +type testing_function = Evd.evar_map -> EConstr.constr -> bool + +let mkmeta n = Nameops.make_ident "X" (Some n) +let meta1 = mkmeta 1 +let meta2 = mkmeta 2 + +let op2bool = function Some _ -> true | None -> false + +let match_with_non_recursive_type sigma t = + match EConstr.kind sigma t with + | App _ -> + let (hdapp,args) = decompose_app sigma t in + (match EConstr.kind sigma hdapp with + | Ind (ind,u) -> + if (Global.lookup_mind (fst ind)).mind_finite == CoFinite then + Some (hdapp,args) + else + None + | _ -> None) + | _ -> None + +let is_non_recursive_type sigma t = op2bool (match_with_non_recursive_type sigma t) + +(* Test dependencies *) + +(* NB: we consider also the let-in case in the following function, + since they may appear in types of inductive constructors (see #2629) *) + +let rec has_nodep_prod_after n sigma c = + match EConstr.kind sigma c with + | Prod (_,_,b) | LetIn (_,_,_,b) -> + ( n>0 || Vars.noccurn sigma 1 b) + && (has_nodep_prod_after (n-1) sigma b) + | _ -> true + +let has_nodep_prod sigma c = has_nodep_prod_after 0 sigma c + +(* A general conjunctive type is a non-recursive with-no-indices inductive + type with only one constructor and no dependencies between argument; + it is strict if it has the form + "Inductive I A1 ... An := C (_:A1) ... (_:An)" *) + +(* style: None = record; Some false = conjunction; Some true = strict conj *) + +let is_strict_conjunction = function +| Some true -> true +| _ -> false + +let is_lax_conjunction = function +| Some false -> true +| _ -> false + +let prod_assum sigma t = fst (decompose_prod_assum sigma t) + +(* whd_beta normalize the types of arguments in a product *) +let rec whd_beta_prod sigma c = match EConstr.kind sigma c with + | Prod (n,t,c) -> mkProd (n,Reductionops.whd_beta sigma t,whd_beta_prod sigma c) + | LetIn (n,d,t,c) -> mkLetIn (n,d,t,whd_beta_prod sigma c) + | _ -> c + +let match_with_one_constructor sigma style onlybinary allow_rec t = + let (hdapp,args) = decompose_app sigma t in + let res = match EConstr.kind sigma hdapp with + | Ind ind -> + let (mib,mip) = Global.lookup_inductive (fst ind) in + if Int.equal (Array.length mip.mind_consnames) 1 + && (allow_rec || not (mis_is_recursive (fst ind,mib,mip))) + && (Int.equal mip.mind_nrealargs 0) + then + if is_strict_conjunction style (* strict conjunction *) then + let ctx = + (prod_assum sigma (snd + (decompose_prod_n_assum sigma mib.mind_nparams (EConstr.of_constr mip.mind_nf_lc.(0))))) in + if + List.for_all + (fun decl -> let c = RelDecl.get_type decl in + is_local_assum decl && + isRel sigma c && + Int.equal (destRel sigma c) mib.mind_nparams) ctx + then + Some (hdapp,args) + else None + else + let ctyp = whd_beta_prod sigma + (Termops.prod_applist_assum sigma (Context.Rel.length mib.mind_params_ctxt) + (EConstr.of_constr mip.mind_nf_lc.(0)) args) in + let cargs = List.map RelDecl.get_type (prod_assum sigma ctyp) in + if not (is_lax_conjunction style) || has_nodep_prod sigma ctyp then + (* Record or non strict conjunction *) + Some (hdapp,List.rev cargs) + else + None + else + None + | _ -> None in + match res with + | Some (hdapp, args) when not onlybinary -> res + | Some (hdapp, [_; _]) -> res + | _ -> None + +let match_with_conjunction ?(strict=false) ?(onlybinary=false) sigma t = + match_with_one_constructor sigma (Some strict) onlybinary false t + +let match_with_record sigma t = + match_with_one_constructor sigma None false false t + +let is_conjunction ?(strict=false) ?(onlybinary=false) sigma t = + op2bool (match_with_conjunction sigma ~strict ~onlybinary t) + +let is_record sigma t = + op2bool (match_with_record sigma t) + +let match_with_tuple sigma t = + let t = match_with_one_constructor sigma None false true t in + Option.map (fun (hd,l) -> + let ind = destInd sigma hd in + let ind = on_snd (fun u -> EInstance.kind sigma u) ind in + let (mib,mip) = Global.lookup_pinductive ind in + let isrec = mis_is_recursive (fst ind,mib,mip) in + (hd,l,isrec)) t + +let is_tuple sigma t = + op2bool (match_with_tuple sigma t) + +(* A general disjunction type is a non-recursive with-no-indices inductive + type with of which all constructors have a single argument; + it is strict if it has the form + "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *) + +let test_strict_disjunction n lc = + let open Term in + Array.for_all_i (fun i c -> + match (prod_assum (snd (decompose_prod_n_assum n c))) with + | [LocalAssum (_,c)] -> Constr.isRel c && Int.equal (Constr.destRel c) (n - i) + | _ -> false) 0 lc + +let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = + let (hdapp,args) = decompose_app sigma t in + let res = match EConstr.kind sigma hdapp with + | Ind (ind,u) -> + let car = constructors_nrealargs ind in + let (mib,mip) = Global.lookup_inductive ind in + if Array.for_all (fun ar -> Int.equal ar 1) car + && not (mis_is_recursive (ind,mib,mip)) + && (Int.equal mip.mind_nrealargs 0) + then + if strict then + if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then + Some (hdapp,args) + else + None + else + let cargs = + Array.map (fun ar -> pi2 (destProd sigma (prod_applist sigma (EConstr.of_constr ar) args))) + mip.mind_nf_lc in + Some (hdapp,Array.to_list cargs) + else + None + | _ -> None in + match res with + | Some (hdapp,args) when not onlybinary -> res + | Some (hdapp,[_; _]) -> res + | _ -> None + +let is_disjunction ?(strict=false) ?(onlybinary=false) sigma t = + op2bool (match_with_disjunction ~strict ~onlybinary sigma t) + +(* An empty type is an inductive type, possible with indices, that has no + constructors *) + +let match_with_empty_type sigma t = + let (hdapp,args) = decompose_app sigma t in + match EConstr.kind sigma hdapp with + | Ind (ind, _) -> + let (mib,mip) = Global.lookup_inductive ind in + let nconstr = Array.length mip.mind_consnames in + if Int.equal nconstr 0 then Some hdapp else None + | _ -> None + +let is_empty_type sigma t = op2bool (match_with_empty_type sigma t) + +(* This filters inductive types with one constructor with no arguments; + Parameters and indices are allowed *) + +let match_with_unit_or_eq_type sigma t = + let (hdapp,args) = decompose_app sigma t in + match EConstr.kind sigma hdapp with + | Ind (ind , _) -> + let (mib,mip) = Global.lookup_inductive ind in + let constr_types = mip.mind_nf_lc in + let nconstr = Array.length mip.mind_consnames in + let zero_args c = Int.equal (nb_prod sigma (EConstr.of_constr c)) mib.mind_nparams in + if Int.equal nconstr 1 && zero_args constr_types.(0) then + Some hdapp + else + None + | _ -> None + +let is_unit_or_eq_type sigma t = op2bool (match_with_unit_or_eq_type sigma t) + +(* A unit type is an inductive type with no indices but possibly + (useless) parameters, and that has no arguments in its unique + constructor *) + +let is_unit_type sigma t = + match match_with_conjunction sigma t with + | Some (_,[]) -> true + | _ -> false + +(* Checks if a given term is an application of an + inductive binary relation R, so that R has only one constructor + establishing its reflexivity. *) + +type equation_kind = + | MonomorphicLeibnizEq of constr * constr + | PolymorphicLeibnizEq of constr * constr * constr + | HeterogenousEq of constr * constr * constr * constr + +exception NoEquationFound + +open Glob_term +open Decl_kinds +open Evar_kinds + +let mkPattern c = snd (Patternops.pattern_of_glob_constr c) +let mkGApp f args = DAst.make @@ GApp (f, args) +let mkGHole = DAst.make @@ + GHole (QuestionMark { + Evar_kinds.default_question_mark with Evar_kinds.qm_obligation=Define false; + }, Namegen.IntroAnonymous, None) +let mkGProd id c1 c2 = DAst.make @@ + GProd (Name (Id.of_string id), Explicit, c1, c2) +let mkGArrow c1 c2 = DAst.make @@ + GProd (Anonymous, Explicit, c1, c2) +let mkGVar id = DAst.make @@ GVar (Id.of_string id) +let mkGPatVar id = DAst.make @@ GPatVar(Evar_kinds.FirstOrderPatVar (Id.of_string id)) +let mkGRef r = DAst.make @@ GRef (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";]))) + +let match_with_equation env sigma t = + if not (isApp sigma t) then raise NoEquationFound; + let (hdapp,args) = destApp sigma t in + match EConstr.kind sigma hdapp with + | Ind (ind,u) -> + if Coqlib.check_ind_ref "core.eq.type" ind then + Some (build_coq_eq_data()),hdapp, + PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if Coqlib.check_ind_ref "core.identity.type" ind then + Some (build_coq_identity_data()),hdapp, + PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if Coqlib.check_ind_ref "core.JMeq.type" ind then + Some (build_coq_jmeq_data()),hdapp, + HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) + else + let (mib,mip) = Global.lookup_inductive ind in + let constr_types = mip.mind_nf_lc in + let nconstr = Array.length mip.mind_consnames in + if Int.equal nconstr 1 then + if is_matching env sigma coq_refl_leibniz1_pattern (EConstr.of_constr constr_types.(0)) then + None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) + else if is_matching env sigma coq_refl_leibniz2_pattern (EConstr.of_constr constr_types.(0)) then + None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if is_matching env sigma coq_refl_jm_pattern (EConstr.of_constr constr_types.(0)) then + None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) + else raise NoEquationFound + else raise NoEquationFound + | _ -> raise NoEquationFound + +(* Note: An "equality type" is any type with a single argument-free + constructor: it captures eq, eq_dep, JMeq, eq_true, etc. but also + True/unit which is the degenerate equality type (isomorphic to ()=()); + in particular, True/unit are provable by "reflexivity" *) + +let is_inductive_equality ind = + let (mib,mip) = Global.lookup_inductive ind in + let nconstr = Array.length mip.mind_consnames in + Int.equal nconstr 1 && Int.equal (constructor_nrealargs (ind,1)) 0 + +let match_with_equality_type sigma t = + let (hdapp,args) = decompose_app sigma t in + match EConstr.kind sigma hdapp with + | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args) + | _ -> None + +let is_equality_type sigma t = op2bool (match_with_equality_type sigma t) + +(* Arrows/Implication/Negation *) + +(** X1 -> X2 **) +let coq_arrow_pattern = mkPattern (mkGArrow (mkGPatVar "X1") (mkGPatVar "X2")) + +let match_arrow_pattern env sigma t = + let result = matches env sigma coq_arrow_pattern t in + match Id.Map.bindings result with + | [(m1,arg);(m2,mind)] -> + assert (Id.equal m1 meta1 && Id.equal m2 meta2); (arg, mind) + | _ -> anomaly (Pp.str "Incorrect pattern matching.") + +let match_with_imp_term sigma c = + match EConstr.kind sigma c with + | Prod (_,a,b) when Vars.noccurn sigma 1 b -> Some (a,b) + | _ -> None + +let is_imp_term sigma c = op2bool (match_with_imp_term sigma c) + +let match_with_nottype env sigma t = + try + let (arg,mind) = match_arrow_pattern env sigma t in + if is_empty_type sigma mind then Some (mind,arg) else None + with PatternMatchingFailure -> None + +let is_nottype env sigma t = op2bool (match_with_nottype env sigma t) + +(* Forall *) + +let match_with_forall_term sigma c= + match EConstr.kind sigma c with + | Prod (nam,a,b) -> Some (nam,a,b) + | _ -> None + +let is_forall_term sigma c = op2bool (match_with_forall_term sigma c) + +let match_with_nodep_ind sigma t = + let (hdapp,args) = decompose_app sigma t in + match EConstr.kind sigma hdapp with + | Ind (ind, _) -> + let (mib,mip) = Global.lookup_inductive ind in + if Array.length (mib.mind_packets)>1 then None else + let nodep_constr c = + has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt) sigma (EConstr.of_constr c) in + if Array.for_all nodep_constr mip.mind_nf_lc then + let params= + if Int.equal mip.mind_nrealargs 0 then args else + fst (List.chop mib.mind_nparams args) in + Some (hdapp,params,mip.mind_nrealargs) + else + None + | _ -> None + +let is_nodep_ind sigma t = op2bool (match_with_nodep_ind sigma t) + +let match_with_sigma_type sigma t = + let (hdapp,args) = decompose_app sigma t in + match EConstr.kind sigma hdapp with + | Ind (ind, _) -> + let (mib,mip) = Global.lookup_inductive ind in + if Int.equal (Array.length (mib.mind_packets)) 1 + && (Int.equal mip.mind_nrealargs 0) + && (Int.equal (Array.length mip.mind_consnames)1) + && has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt + 1) sigma + (EConstr.of_constr mip.mind_nf_lc.(0)) + then + (*allowing only 1 existential*) + Some (hdapp,args) + else + None + | _ -> None + +let is_sigma_type sigma t = op2bool (match_with_sigma_type sigma t) + +(***** Destructing patterns bound to some theory *) + +let rec first_match matcher = function + | [] -> raise PatternMatchingFailure + | (pat,check,build_set)::l when check () -> + (try (build_set (),matcher pat) + with PatternMatchingFailure -> first_match matcher l) + | _::l -> first_match matcher l + +(*** Equality *) + +let match_eq sigma eqn (ref, hetero) = + let ref = + try Lazy.force ref + with e when CErrors.noncritical e -> raise PatternMatchingFailure + in + match EConstr.kind sigma eqn with + | App (c, [|t; x; y|]) -> + if not hetero && Termops.is_global sigma ref c then PolymorphicLeibnizEq (t, x, y) + else raise PatternMatchingFailure + | App (c, [|t; x; t'; x'|]) -> + if hetero && Termops.is_global sigma ref c then HeterogenousEq (t, x, t', x') + else raise PatternMatchingFailure + | _ -> raise PatternMatchingFailure + +let no_check () = true +let check_jmeq_loaded () = has_ref "core.JMeq.type" + +let equalities = + [(lazy(lib_ref "core.eq.type"), false), no_check, build_coq_eq_data; + (lazy(lib_ref "core.JMeq.type"), true), check_jmeq_loaded, build_coq_jmeq_data; + (lazy(lib_ref "core.identity.type"), false), no_check, build_coq_identity_data] + +let find_eq_data sigma eqn = (* fails with PatternMatchingFailure *) + let d,k = first_match (match_eq sigma eqn) equalities in + let hd,u = destInd sigma (fst (destApp sigma eqn)) in + d,u,k + +let extract_eq_args gl = function + | MonomorphicLeibnizEq (e1,e2) -> + let t = pf_unsafe_type_of gl e1 in (t,e1,e2) + | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2) + | HeterogenousEq (t1,e1,t2,e2) -> + if pf_conv_x gl t1 t2 then (t1,e1,e2) + else raise PatternMatchingFailure + +let find_eq_data_decompose gl eqn = + let (lbeq,u,eq_args) = find_eq_data (project gl) eqn in + (lbeq,u,extract_eq_args gl eq_args) + +let find_this_eq_data_decompose gl eqn = + let (lbeq,u,eq_args) = + try (*first_match (match_eq eqn) inversible_equalities*) + find_eq_data (project gl) eqn + with PatternMatchingFailure -> + user_err (str "No primitive equality found.") in + let eq_args = + try extract_eq_args gl eq_args + with PatternMatchingFailure -> + user_err Pp.(str "Don't know what to do with JMeq on arguments not of same type.") in + (lbeq,u,eq_args) + +(*** Sigma-types *) + +let match_sigma env sigma ex = + match EConstr.kind sigma ex with + | App (f, [| a; p; car; cdr |]) when Termops.is_global sigma (lib_ref "core.sig.intro") f -> + build_sigma (), (snd (destConstruct sigma f), a, p, car, cdr) + | App (f, [| a; p; car; cdr |]) when Termops.is_global sigma (lib_ref "core.sigT.intro") f -> + build_sigma_type (), (snd (destConstruct sigma f), a, p, car, cdr) + | _ -> raise PatternMatchingFailure + +let find_sigma_data_decompose env ex = (* fails with PatternMatchingFailure *) + match_sigma env ex + +(* Pattern "(sig ?1 ?2)" *) +let coq_sig_pattern = + lazy (mkPattern (mkGAppRef (lazy (lib_ref "core.sig.type")) [mkGPatVar "X1"; mkGPatVar "X2"])) + +let match_sigma env sigma t = + match Id.Map.bindings (matches env sigma (Lazy.force coq_sig_pattern) t) with + | [(_,a); (_,p)] -> (a,p) + | _ -> anomaly (Pp.str "Unexpected pattern.") + +let is_matching_sigma env sigma t = is_matching env sigma (Lazy.force coq_sig_pattern) t + +(*** Decidable equalities *) + +(* The expected form of the goal for the tactic Decide Equality *) + +(* Pattern "{<?1>x=y}+{~(<?1>x=y)}" *) +(* i.e. "(sumbool (eq ?1 x y) ~(eq ?1 x y))" *) + +let coq_eqdec ~sum ~rev = + lazy ( + let eqn = mkGAppRef (lazy (lib_ref "core.eq.type")) (List.map mkGPatVar ["X1"; "X2"; "X3"]) in + let args = [eqn; mkGAppRef (lazy (lib_ref "core.not.type")) [eqn]] in + let args = if rev then List.rev args else args in + mkPattern (mkGAppRef sum args) + ) + +let sumbool_type = lazy (lib_ref "core.sumbool.type") +let or_type = lazy (lib_ref "core.or.type") + +(** [{ ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 }] *) +let coq_eqdec_inf_pattern = coq_eqdec ~sum:sumbool_type ~rev:false + +(** [{ ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 }] *) +let coq_eqdec_inf_rev_pattern = coq_eqdec ~sum:sumbool_type ~rev:true + +(** %coq_or_ref (?X2 = ?X3 :> ?X1) (~ ?X2 = ?X3 :> ?X1) *) +let coq_eqdec_pattern = coq_eqdec ~sum:or_type ~rev:false + +(** %coq_or_ref (~ ?X2 = ?X3 :> ?X1) (?X2 = ?X3 :> ?X1) *) +let coq_eqdec_rev_pattern = coq_eqdec ~sum:or_type ~rev:true + +let match_eqdec env sigma t = + let eqonleft,op,subst = + try true,sumbool_type,matches env sigma (Lazy.force coq_eqdec_inf_pattern) t + with PatternMatchingFailure -> + try false,sumbool_type,matches env sigma (Lazy.force coq_eqdec_inf_rev_pattern) t + with PatternMatchingFailure -> + try true,or_type,matches env sigma (Lazy.force coq_eqdec_pattern) t + with PatternMatchingFailure -> + false,or_type,matches env sigma (Lazy.force coq_eqdec_rev_pattern) t in + match Id.Map.bindings subst with + | [(_,typ);(_,c1);(_,c2)] -> + eqonleft, Lazy.force op, c1, c2, typ + | _ -> anomaly (Pp.str "Unexpected pattern.") + +(* Patterns "~ ?" and "? -> False" *) +let coq_not_pattern = lazy (mkPattern (mkGAppRef (lazy (lib_ref "core.not.type")) [mkGHole])) +let coq_imp_False_pattern = lazy (mkPattern (mkGArrow mkGHole (mkGRef (lazy (lib_ref "core.False.type"))))) + +let is_matching_not env sigma t = is_matching env sigma (Lazy.force coq_not_pattern) t +let is_matching_imp_False env sigma t = is_matching env sigma (Lazy.force coq_imp_False_pattern) t + +(* Remark: patterns that have references to the standard library must + be evaluated lazily (i.e. at the time they are used, not a the time + coqtop starts) *) diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli new file mode 100644 index 0000000000..f04cda1232 --- /dev/null +++ b/tactics/hipattern.mli @@ -0,0 +1,151 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Evd +open EConstr +open Coqlib + +(** High-order patterns *) + +(** Given a term with second-order variables in it, + represented by Meta's, and possibly applied using SoApp + terms, this function will perform second-order, binding-preserving, + matching, in the case where the pattern is a pattern in the sense + of Dale Miller. + + ALGORITHM: + + Given a pattern, we decompose it, flattening casts and apply's, + recursing on all operators, and pushing the name of the binder each + time we descend a binder. + + When we reach a first-order variable, we ask that the corresponding + term's free-rels all be higher than the depth of the current stack. + + When we reach a second-order application, we ask that the + intersection of the free-rels of the term and the current stack be + contained in the arguments of the application *) + +(** 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. + + They are more general than matching with [or_term], [and_term], etc, + since they do not depend on the name of the type. Hence, they + also work on ad-hoc disjunctions introduced by the user. + (Eduardo, 6/8/97). *) + +type 'a matching_function = evar_map -> constr -> 'a option +type testing_function = evar_map -> constr -> bool + +val match_with_non_recursive_type : (constr * constr list) matching_function +val is_non_recursive_type : testing_function + +(** Non recursive type with no indices and exactly one argument for each + constructor; canonical definition of n-ary disjunction if strict *) +val match_with_disjunction : ?strict:bool -> ?onlybinary:bool -> (constr * constr list) matching_function +val is_disjunction : ?strict:bool -> ?onlybinary:bool -> testing_function + +(** Non recursive tuple (one constructor and no indices) with no inner + dependencies; canonical definition of n-ary conjunction if strict *) +val match_with_conjunction : ?strict:bool -> ?onlybinary:bool -> (constr * constr list) matching_function +val is_conjunction : ?strict:bool -> ?onlybinary:bool -> testing_function + +(** Non recursive tuple, possibly with inner dependencies *) +val match_with_record : (constr * constr list) matching_function +val is_record : testing_function + +(** Like record but supports and tells if recursive (e.g. Acc) *) +val match_with_tuple : (constr * constr list * bool) matching_function +val is_tuple : testing_function + +(** No constructor, possibly with indices *) +val match_with_empty_type : constr matching_function +val is_empty_type : testing_function + +(** type with only one constructor and no arguments, possibly with indices *) +val match_with_unit_or_eq_type : constr matching_function +val is_unit_or_eq_type : testing_function + +(** type with only one constructor and no arguments, no indices *) +val is_unit_type : testing_function + +(** type with only one constructor, no arguments and at least one dependency *) +val is_inductive_equality : inductive -> bool +val match_with_equality_type : (constr * constr list) matching_function +val is_equality_type : testing_function + +val match_with_nottype : Environ.env -> (constr * constr) matching_function +val is_nottype : Environ.env -> testing_function + +val match_with_forall_term : (Name.t * constr * constr) matching_function +val is_forall_term : testing_function + +val match_with_imp_term : (constr * constr) matching_function +val is_imp_term : testing_function + +(** I added these functions to test whether a type contains dependent + products or not, and if an inductive has constructors with dependent types + (excluding parameters). this is useful to check whether a conjunction is a + real conjunction and not a dependent tuple. (Pierre Corbineau, 13/5/2002) *) + +val has_nodep_prod_after : int -> testing_function +val has_nodep_prod : testing_function + +val match_with_nodep_ind : (constr * constr list * int) matching_function +val is_nodep_ind : testing_function + +val match_with_sigma_type : (constr * constr list) matching_function +val is_sigma_type : testing_function + +(** Recongnize inductive relation defined by reflexivity *) + +type equation_kind = + | MonomorphicLeibnizEq of constr * constr + | PolymorphicLeibnizEq of constr * constr * constr + | HeterogenousEq of constr * constr * constr * constr + +exception NoEquationFound + +val match_with_equation: + Environ.env -> evar_map -> constr -> coq_eq_data option * constr * equation_kind + +(***** Destructing patterns bound to some theory *) + +(** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] + Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) +val find_eq_data_decompose : Proofview.Goal.t -> constr -> + coq_eq_data * EInstance.t * (types * constr * constr) + +(** Idem but fails with an error message instead of PatternMatchingFailure *) +val find_this_eq_data_decompose : Proofview.Goal.t -> constr -> + coq_eq_data * EInstance.t * (types * constr * constr) + +(** A variant that returns more informative structure on the equality found *) +val find_eq_data : evar_map -> constr -> coq_eq_data * EInstance.t * equation_kind + +(** Match a term of the form [(existT A P t p)] + Returns associated lemmas and [A,P,t,p] *) +val find_sigma_data_decompose : Environ.env -> evar_map -> constr -> + coq_sigma_data * (EInstance.t * constr * constr * constr * constr) + +(** Match a term of the form [{x:A|P}], returns [A] and [P] *) +val match_sigma : Environ.env -> evar_map -> constr -> constr * constr + +val is_matching_sigma : Environ.env -> evar_map -> constr -> bool + +(** Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns + [t,u,T] and a boolean telling if equality is on the left side *) +val match_eqdec : Environ.env -> evar_map -> constr -> bool * GlobRef.t * constr * constr * constr + +(** Match a negation *) +val is_matching_not : Environ.env -> evar_map -> constr -> bool +val is_matching_imp_False : Environ.env -> evar_map -> constr -> bool diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml new file mode 100644 index 0000000000..a67f5f6d6e --- /dev/null +++ b/tactics/ind_tables.ml @@ -0,0 +1,201 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* File created by Vincent Siles, Oct 2007, extended into a generic + support for generation of inductive schemes by Hugo Herbelin, Nov 2009 *) + +(* This file provides support for registering inductive scheme builders, + declaring schemes and generating schemes on demand *) + +open Names +open Mod_subst +open Libobject +open Nameops +open Declarations +open Constr +open CErrors +open Util +open Declare +open Entries +open Decl_kinds +open Pp + +(**********************************************************************) +(* Registering schemes in the environment *) + +type mutual_scheme_object_function = + internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants +type individual_scheme_object_function = + internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants + +type 'a scheme_kind = string + +let scheme_map = Summary.ref Indmap.empty ~name:"Schemes" + +let pr_scheme_kind = Pp.str + +let cache_one_scheme kind (ind,const) = + let map = try Indmap.find ind !scheme_map with Not_found -> String.Map.empty in + scheme_map := Indmap.add ind (String.Map.add kind const map) !scheme_map + +let cache_scheme (_,(kind,l)) = + Array.iter (cache_one_scheme kind) l + +let subst_one_scheme subst (ind,const) = + (* Remark: const is a def: the result of substitution is a constant *) + (subst_ind subst ind,subst_constant subst const) + +let subst_scheme (subst,(kind,l)) = + (kind,Array.Smart.map (subst_one_scheme subst) l) + +let discharge_scheme (_,(kind,l)) = + Some (kind, l) + +let inScheme : string * (inductive * Constant.t) array -> obj = + declare_object @@ superglobal_object "SCHEME" + ~cache:cache_scheme + ~subst:(Some subst_scheme) + ~discharge:discharge_scheme + +(**********************************************************************) +(* The table of scheme building functions *) + +type individual +type mutual + +type scheme_object_function = + | MutualSchemeFunction of mutual_scheme_object_function + | IndividualSchemeFunction of individual_scheme_object_function + +let scheme_object_table = + (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t) + +let declare_scheme_object s aux f = + let () = + if not (Id.is_valid ("ind" ^ s)) then + user_err Pp.(str ("Illegal induction scheme suffix: " ^ s)) + in + let key = if String.is_empty aux then s else aux in + try + let _ = Hashtbl.find scheme_object_table key in +(* let aux_msg = if aux="" then "" else " (with key "^aux^")" in*) + user_err ~hdr:"IndTables.declare_scheme_object" + (str "Scheme object " ++ str key ++ str " already declared.") + with Not_found -> + Hashtbl.add scheme_object_table key (s,f); + key + +let declare_mutual_scheme_object s ?(aux="") f = + declare_scheme_object s aux (MutualSchemeFunction f) + +let declare_individual_scheme_object s ?(aux="") f = + declare_scheme_object s aux (IndividualSchemeFunction f) + +(**********************************************************************) +(* Defining/retrieving schemes *) + +let declare_scheme kind indcl = + Lib.add_anonymous_leaf (inScheme (kind,indcl)) + +let () = Declare.set_declare_scheme declare_scheme + +let is_visible_name id = + try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true + with Not_found -> false + +let compute_name internal id = + match internal with + | UserAutomaticRequest | UserIndividualRequest -> id + | InternalTacticRequest -> + Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name + +let define internal id c poly univs = + let fd = declare_constant ~internal in + let id = compute_name internal id in + let ctx = UState.minimize univs in + let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in + let univs = UState.const_univ_entry ~poly ctx in + let entry = { + const_entry_body = + Future.from_val ((c,Univ.ContextSet.empty), + Safe_typing.empty_private_constants); + const_entry_secctx = None; + const_entry_type = None; + const_entry_universes = univs; + const_entry_opaque = false; + const_entry_inline_code = false; + const_entry_feedback = None; + } in + let kn = fd id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in + let () = match internal with + | InternalTacticRequest -> () + | _-> definition_message id + in + kn + +let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = + let (c, ctx), eff = f mode ind in + let mib = Global.lookup_mind mind in + let id = match idopt with + | Some id -> id + | None -> add_suffix mib.mind_packets.(i).mind_typename suff in + let const = define mode id c (Declareops.inductive_is_polymorphic mib) ctx in + declare_scheme kind [|ind,const|]; + const, Safe_typing.concat_private + (Safe_typing.private_con_of_scheme ~kind (Global.safe_env()) [ind,const]) eff + +let define_individual_scheme kind mode names (mind,i as ind) = + match Hashtbl.find scheme_object_table kind with + | _,MutualSchemeFunction f -> assert false + | s,IndividualSchemeFunction f -> + define_individual_scheme_base kind s f mode names ind + +let define_mutual_scheme_base kind suff f mode names mind = + let (cl, ctx), eff = f mode mind in + let mib = Global.lookup_mind mind in + let ids = Array.init (Array.length mib.mind_packets) (fun i -> + try Int.List.assoc i names + with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in + let consts = Array.map2 (fun id cl -> + define mode id cl (Declareops.inductive_is_polymorphic mib) ctx) ids cl in + let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in + declare_scheme kind schemes; + consts, + Safe_typing.concat_private + (Safe_typing.private_con_of_scheme + ~kind (Global.safe_env()) (Array.to_list schemes)) + eff + +let define_mutual_scheme kind mode names mind = + match Hashtbl.find scheme_object_table kind with + | _,IndividualSchemeFunction _ -> assert false + | s,MutualSchemeFunction f -> + define_mutual_scheme_base kind s f mode names mind + +let find_scheme_on_env_too kind ind = + let s = String.Map.find kind (Indmap.find ind !scheme_map) in + s, Safe_typing.concat_private + (Safe_typing.private_con_of_scheme + ~kind (Global.safe_env()) [ind, s]) + Safe_typing.empty_private_constants + +let find_scheme ?(mode=InternalTacticRequest) kind (mind,i as ind) = + try find_scheme_on_env_too kind ind + with Not_found -> + match Hashtbl.find scheme_object_table kind with + | s,IndividualSchemeFunction f -> + define_individual_scheme_base kind s f mode None ind + | s,MutualSchemeFunction f -> + let ca, eff = define_mutual_scheme_base kind s f mode [] mind in + ca.(i), eff + +let check_scheme kind ind = + try let _ = find_scheme_on_env_too kind ind in true + with Not_found -> false diff --git a/tactics/ind_tables.mli b/tactics/ind_tables.mli new file mode 100644 index 0000000000..0eb4e47aeb --- /dev/null +++ b/tactics/ind_tables.mli @@ -0,0 +1,53 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open Declare + +(** This module provides support for registering inductive scheme builders, + declaring schemes and generating schemes on demand *) + +(** A scheme is either a "mutual scheme_kind" or an "individual scheme_kind" *) + +type mutual +type individual +type 'a scheme_kind + +type mutual_scheme_object_function = + internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants +type individual_scheme_object_function = + internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants + +(** Main functions to register a scheme builder *) + +val declare_mutual_scheme_object : string -> ?aux:string -> + mutual_scheme_object_function -> mutual scheme_kind + +val declare_individual_scheme_object : string -> ?aux:string -> + individual_scheme_object_function -> + individual scheme_kind + +(** Force generation of a (mutually) scheme with possibly user-level names *) + +val define_individual_scheme : individual scheme_kind -> + internal_flag (** internal *) -> + Id.t option -> inductive -> Constant.t * Safe_typing.private_constants + +val define_mutual_scheme : mutual scheme_kind -> internal_flag (** internal *) -> + (int * Id.t) list -> MutInd.t -> Constant.t array * Safe_typing.private_constants + +(** Main function to retrieve a scheme in the cache or to generate it *) +val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> Constant.t * Safe_typing.private_constants + +val check_scheme : 'a scheme_kind -> inductive -> bool + + +val pr_scheme_kind : 'a scheme_kind -> Pp.t diff --git a/tactics/inv.ml b/tactics/inv.ml new file mode 100644 index 0000000000..2ae37ab471 --- /dev/null +++ b/tactics/inv.ml @@ -0,0 +1,569 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Names +open Term +open Termops +open Constr +open EConstr +open Vars +open Namegen +open Inductiveops +open Printer +open Retyping +open Tacmach.New +open Tacticals.New +open Tactics +open Elim +open Equality +open Tactypes +open Proofview.Notations + +module NamedDecl = Context.Named.Declaration + +let var_occurs_in_pf gl id = + let env = Proofview.Goal.env gl in + let sigma = project gl in + occur_var env sigma id (Proofview.Goal.concl gl) || + List.exists (occur_var_in_decl env sigma id) (Proofview.Goal.hyps gl) + +(* [make_inv_predicate (ity,args) C] + + is given the inductive type, its arguments, both the global + parameters and its local arguments, and is expected to produce a + predicate P such that if largs is the "local" part of the + arguments, then (P largs) will be convertible with a conclusion of + the form: + + <A1>a1=a1-><A2>a2=a2 ... -> C + + Algorithm: suppose length(largs)=n + + (1) Push the entire arity, [xbar:Abar], carrying along largs and + the conclusion + + (2) Pair up each ai with its respective Rel version: a1==(Rel n), + a2==(Rel n-1), etc. + + (3) For each pair, ai,Rel j, if the Ai is dependent - that is, the + type of [Rel j] is an open term, then we construct the iterated + tuple, [make_iterated_tuple] does it, and use that for our equation + + Otherwise, we just use <Ai>ai=Rel j + + *) + +type inversion_status = Dep of constr option | NoDep + +type inversion_kind = + | SimpleInversion + | FullInversion + | FullInversionClear + +let evd_comb1 f evdref x = + let (evd',y) = f !evdref x in + evdref := evd'; + y + +let compute_eqn env sigma n i ai = + (mkRel (n-i),get_type_of env sigma (mkRel (n-i))) + +let make_inv_predicate env evd indf realargs id status concl = + let nrealargs = List.length realargs in + let (hyps,concl) = + match status with + | NoDep -> + (* We push the arity and leave concl unchanged *) + let hyps_arity,_ = get_arity env indf in + let hyps_arity = List.map (fun d -> map_rel_decl EConstr.of_constr d) hyps_arity in + (hyps_arity,concl) + | Dep dflt_concl -> + if not (occur_var env !evd id concl) then + user_err ~hdr:"make_inv_predicate" + (str "Current goal does not depend on " ++ Id.print id ++ str"."); + (* We abstract the conclusion of goal with respect to + realargs and c to * be concl in order to rewrite and have + c also rewritten when the case * will be done *) + let pred = + match dflt_concl with + | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) + | None -> + let sort = get_sort_family_of env !evd concl in + let sort = evd_comb1 Evd.fresh_sort_in_family evd sort in + let p = make_arity env !evd true indf sort in + let evd',(p,ptyp) = Unification.abstract_list_all env + !evd p concl (realargs@[mkVar id]) + in evd := evd'; p in + let hyps,bodypred = decompose_lam_n_assum !evd (nrealargs+1) pred in + (* We lift to make room for the equations *) + (hyps,lift nrealargs bodypred) + in + let nhyps = Context.Rel.length hyps in + let env' = push_rel_context hyps env in + (* Now the arity is pushed, and we need to construct the pairs + * ai,mkRel(n-i+1) *) + (* Now, we can recurse down this list, for each ai,(mkRel k) whether to + push <Ai>(mkRel k)=ai (when Ai is closed). + In any case, we carry along the rest of pairs *) + let eqdata = Coqlib.build_coq_eq_data () in + let rec build_concl eqns args n = function + | [] -> it_mkProd concl eqns, Array.rev_of_list args + | ai :: restlist -> + let ai = lift nhyps ai in + let (xi, ti) = compute_eqn env' !evd nhyps n ai in + let (lhs,eqnty,rhs) = + if closed0 !evd ti then + (xi,ti,ai) + else + let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in + evd := sigma; res + in + let eq_term = eqdata.Coqlib.eq in + let eq = evd_comb1 (Evd.fresh_global env) evd eq_term in + let eqn = applist (eq,[eqnty;lhs;rhs]) in + let eqns = (Anonymous, lift n eqn) :: eqns in + let refl_term = eqdata.Coqlib.refl in + let refl_term = evd_comb1 (Evd.fresh_global env) evd refl_term in + let refl = mkApp (refl_term, [|eqnty; rhs|]) in + let _ = evd_comb1 (Typing.type_of env) evd refl in + let args = refl :: args in + build_concl eqns args (succ n) restlist + in + let (newconcl, args) = build_concl [] [] 0 realargs in + let predicate = it_mkLambda_or_LetIn newconcl (name_context env !evd hyps) in + let _ = evd_comb1 (Typing.type_of env) evd predicate in + (* OK - this predicate should now be usable by res_elimination_then to + do elimination on the conclusion. *) + predicate, args + +(* The result of the elimination is a bunch of goals like: + + |- (cibar:Cibar)Equands->C + + where the cibar are either dependent or not. We are fed a + signature, with "true" for every recursive argument, and false for + every non-recursive one. So we need to do the + sign_branch_len(sign) intros, thinning out all recursive + assumptions. This leaves us with exactly length(sign) assumptions. + + We save their names, and then do introductions for all the equands + (there are some number of them, which is the other argument of the + tactic) + + This gives us the #neqns equations, whose names we get also, and + the #length(sign) arguments. + + Suppose that #nodep of these arguments are non-dependent. + Generalize and thin them. + + This gives us #dep = #length(sign)-#nodep arguments which are + dependent. + + Now, we want to take each of the equations, and do all possible + injections to get the left-hand-side to be a variable. At the same + time, if we find a lhs/rhs pair which are different, we can + discriminate them to prove false and finish the branch. + + Then, we thin away the equations, and do the introductions for the + #nodep arguments which we generalized before. + *) + +(* Called after the case-assumptions have been killed off, and all the + intros have been done. Given that the clause in question is an + equality (if it isn't we fail), we are responsible for projecting + the equality, using Injection and Discriminate, and applying it to + the concusion *) + +(* Computes the subset of hypothesis in the local context whose + type depends on t (should be of the form (mkVar id)), then + it generalizes them, applies tac to rewrite all occurrencies of t, + and introduces generalized hypotheis. + Precondition: t=(mkVar id) *) + +let dependent_hyps env id idlist gl = + let rec dep_rec =function + | [] -> [] + | d::l -> + (* Update the type of id1: it may have been subject to rewriting *) + let d = pf_get_hyp (NamedDecl.get_id d) gl in + if occur_var_in_decl env (project gl) id d + then d :: dep_rec l + else dep_rec l + in + dep_rec idlist + +let split_dep_and_nodep hyps gl = + List.fold_right + (fun d (l1,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*) +(* Will keep generalizing and introducing back and forth... *) +(* Moreover, others hyps depending of dids should have been *) +(* generalized; in such a way that [dids] can endly be cleared *) +(* Consider for instance this case extracted from Well_Ordering.v + + A : Set + B : A ->Set + a0 : A + f : (B a0) ->WO + y : WO + H0 : (le_WO y (sup a0 f)) + ============================ + (Acc WO le_WO y) + + Inversion H0 gives + + A : Set + B : A ->Set + a0 : A + f : (B a0) ->WO + y : WO + H0 : (le_WO y (sup a0 f)) + a1 : A + f0 : (B a1) ->WO + v : (B a1) + H1 : (f0 v)=y + H3 : a1=a0 + f1 : (B a0) ->WO + v0 : (B a0) + H4 : (existS A [a:A](B a) ->WO a0 f1)=(existS A [a:A](B a) ->WO a0 f) + ============================ + (Acc WO le_WO (f1 v0)) + +while, ideally, we would have expected + + A : Set + B : A ->Set + a0 : A + f0 : (B a0)->WO + v : (B a0) + ============================ + (Acc WO le_WO (f0 v)) + +obtained from destruction with equalities + + A : Set + B : A ->Set + a0 : A + f : (B a0) ->WO + y : WO + H0 : (le_WO y (sup a0 f)) + a1 : A + f0 : (B a1)->WO + v : (B a1) + H1 : (f0 v)=y + H2 : (sup a1 f0)=(sup a0 f) + ============================ + (Acc WO le_WO (f0 v)) + +by clearing initial hypothesis H0 and its dependency y, clearing H1 +(in fact H1 can be avoided using the same trick as for newdestruct), +decomposing H2 to get a1=a0 and (a1,f0)=(a0,f), replacing a1 by a0 +everywhere and removing a1 and a1=a0 (in fact it would have been more +regular to replace a0 by a1, avoiding f1 and v0 cannot replace f0 and v), +finally removing H4 (here because f is not used, more generally after using +eq_dep and replacing f by f0) [and finally rename a0, f0 into a,f]. +Summary: nine useless hypotheses! +Nota: with Inversion_clear, only four useless hypotheses +*) + +let generalizeRewriteIntros as_mode tac depids id = + Proofview.tclENV >>= fun env -> + Proofview.Goal.enter begin fun gl -> + let dids = dependent_hyps env id depids gl in + let reintros = if as_mode then intros_replacing else intros_possibly_replacing in + (tclTHENLIST + [bring_hyps dids; tac; + (* may actually fail to replace if dependent in a previous eq *) + reintros (ids_of_named_context dids)]) + end + +let error_too_many_names pats = + let loc = Loc.merge_opt (List.hd pats).CAst.loc (List.last pats).CAst.loc in + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + tclZEROMSG ?loc ( + str "Unexpected " ++ + str (String.plural (List.length pats) "introduction pattern") ++ + str ": " ++ pr_enum (Miscprint.pr_intro_pattern + (fun c -> Printer.pr_econstr_env env sigma (snd (c env (Evd.from_env env))))) pats ++ + str ".") + +let get_names (allow_conj,issimple) ({CAst.loc;v=pat} as x) = match pat with + | IntroNaming IntroAnonymous | IntroForthcoming _ -> + user_err Pp.(str "Anonymous pattern not allowed for inversion equations.") + | IntroNaming (IntroFresh _) -> + user_err Pp.(str "Fresh pattern not allowed for inversion equations.") + | IntroAction IntroWildcard -> + user_err Pp.(str "Discarding pattern not allowed for inversion equations.") + | IntroAction (IntroRewrite _) -> + user_err Pp.(str "Rewriting pattern not allowed for inversion equations.") + | IntroAction (IntroOrAndPattern (IntroAndPattern [])) when allow_conj -> (None, []) + | IntroAction (IntroOrAndPattern (IntroAndPattern ({CAst.v=IntroNaming (IntroIdentifier id)} :: _ as l) + | IntroOrPattern [{CAst.v=IntroNaming (IntroIdentifier id)} :: _ as l])) + when allow_conj -> (Some id,l) + | IntroAction (IntroOrAndPattern (IntroAndPattern _)) -> + if issimple then + user_err Pp.(str"Conjunctive patterns not allowed for simple inversion equations.") + else + user_err Pp.(str"Nested conjunctive patterns not allowed for inversion equations.") + | IntroAction (IntroInjection l) -> + user_err Pp.(str "Injection patterns not allowed for inversion equations.") + | IntroAction (IntroOrAndPattern (IntroOrPattern _)) -> + user_err Pp.(str "Disjunctive patterns not allowed for inversion equations.") + | IntroAction (IntroApplyOn (c,pat)) -> + user_err Pp.(str "Apply patterns not allowed for inversion equations.") + | IntroNaming (IntroIdentifier id) -> + (Some id,[x]) + +let rec tclMAP_i allow_conj n tacfun = function + | [] -> tclDO n (tacfun (None,[])) + | a::l as l' -> + if Int.equal n 0 then error_too_many_names l' + else + tclTHEN + (tacfun (get_names allow_conj a)) + (tclMAP_i allow_conj (n-1) tacfun l) + +let remember_first_eq id x = if !x == Logic.MoveLast then x := Logic.MoveAfter id + +(* invariant: ProjectAndApply is responsible for erasing the clause + which it is given as input + It simplifies the clause (an equality) to use it as a rewrite rule and then + erases the result of the simplification. *) +(* invariant: ProjectAndApplyNoThining simplifies the clause (an equality) . + If it can discriminate then the goal is proved, if not tries to use it as + a rewrite rule. It erases the clause which is given as input *) + +let dest_nf_eq env sigma t = match EConstr.kind sigma t with +| App (r, [| t; x; y |]) -> + let open Reductionops in + let eq = Coqlib.lib_ref "core.eq.type" in + if EConstr.is_global sigma eq r then + (t, whd_all env sigma x, whd_all env sigma y) + else user_err Pp.(str "Not an equality.") +| _ -> + user_err Pp.(str "Not an equality.") + +let projectAndApply as_mode thin avoid id eqname names depids = + let subst_hyp l2r id = + tclTHEN (tclTRY(rewriteInConcl l2r (EConstr.mkVar id))) + (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC)) + in + let substHypIfVariable tac id = + Proofview.Goal.enter begin fun gl -> + let sigma = project gl in + (* We only look at the type of hypothesis "id" *) + let hyp = pf_nf_evar gl (pf_get_hyp_typ id gl) in + let (t,t1,t2) = dest_nf_eq (pf_env gl) sigma hyp in + match (EConstr.kind sigma t1, EConstr.kind sigma t2) with + | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1 + | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2 + | _ -> tac id + end + in + let deq_trailer id clear_flag _ neqns = + assert (clear_flag == None); + tclTHENLIST + [if as_mode then clear [id] else tclIDTAC; + (tclMAP_i (false,false) neqns (function (idopt,_) -> + tclTRY (tclTHEN + (intro_move_avoid idopt avoid Logic.MoveLast) + (* try again to substitute and if still not a variable after *) + (* decomposition, arbitrarily try to rewrite RL !? *) + (tclTRY (onLastHypId (substHypIfVariable (fun id -> subst_hyp false id)))))) + names); + (if as_mode then tclIDTAC else clear [id])] + (* Doing the above late breaks the computation of dids in + generalizeRewriteIntros, and hence breaks proper intros_replacing + but it is needed for compatibility *) + in + substHypIfVariable + (* If no immediate variable in the equation, try to decompose it *) + (* and apply a trailer which again try to substitute *) + (fun id -> + dEqThen ~keep_proofs:None false (deq_trailer id) + (Some (None,ElimOnConstr (EConstr.mkVar id,NoBindings)))) + id + +let nLastDecls i tac = + Proofview.Goal.enter begin fun gl -> tac (nLastDecls gl i) end + +(* Introduction of the equations on arguments + othin: discriminates Simple Inversion, Inversion and Inversion_clear + None: the equations are introduced, but not rewritten + Some thin: the equations are rewritten, and cleared if thin is true *) + +let rewrite_equations as_mode othin neqns names ba = + Proofview.Goal.enter begin fun gl -> + let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in + let first_eq = ref Logic.MoveLast in + let avoid = if as_mode then Id.Set.of_list (List.map NamedDecl.get_id nodepids) else Id.Set.empty in + match othin with + | Some thin -> + tclTHENLIST + [tclDO neqns intro; + bring_hyps nodepids; + clear (ids_of_named_context nodepids); + (nLastDecls neqns (fun ctx -> bring_hyps (List.rev ctx))); + (nLastDecls neqns (fun ctx -> clear (ids_of_named_context ctx))); + tclMAP_i (true,false) neqns (fun (idopt,names) -> + (tclTHEN + (intro_move_avoid idopt avoid Logic.MoveLast) + (onLastHypId (fun id -> + 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 (NamedDecl.get_id d) else None in + intro_move idopt (if thin then Logic.MoveLast else !first_eq)) + nodepids; + (tclMAP (fun d -> tclTRY (clear [NamedDecl.get_id d])) depids)] + | None -> + (* simple inversion *) + if as_mode then + tclMAP_i (false,true) neqns (fun (idopt,_) -> + intro_move idopt Logic.MoveLast) names + else + (tclTHENLIST + [tclDO neqns intro; + bring_hyps nodepids; + clear (ids_of_named_context nodepids)]) + end + +let interp_inversion_kind = function + | SimpleInversion -> None + | FullInversion -> Some false + | FullInversionClear -> Some true + +let rewrite_equations_tac as_mode othin id neqns names ba = + let othin = interp_inversion_kind othin in + let tac = rewrite_equations as_mode othin neqns names ba in + match othin with + | Some true (* if Inversion_clear, clear the hypothesis *) -> + tclTHEN tac (tclTRY (clear [id])) + | _ -> + tac + +let raw_inversion inv_kind id status names = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + let c = mkVar id in + let (ind, t) = + try pf_apply Tacred.reduce_to_atomic_ind gl (pf_unsafe_type_of gl c) + with UserError _ -> + let msg = str "The type of " ++ Id.print id ++ str " is not inductive." in + CErrors.user_err msg + in + let IndType (indf,realargs) = find_rectype env sigma t in + let evdref = ref sigma in + let (elim_predicate, args) = + make_inv_predicate env evdref indf realargs id status concl in + let sigma = !evdref in + let (cut_concl,case_tac) = + if status != NoDep && (local_occur_var sigma id concl) then + Reductionops.beta_applist sigma (elim_predicate, realargs@[c]), + case_then_using + else + Reductionops.beta_applist sigma (elim_predicate, realargs), + case_nodep_then_using + in + let refined id = + let prf = mkApp (mkVar id, args) in + Refine.refine ~typecheck:false (fun h -> (h, prf)) + in + let neqns = List.length realargs in + let as_mode = names != None in + tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (tclTHENS + (assert_before Anonymous cut_concl) + [case_tac names + (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)]) + end + +(* Error messages of the inversion tactics *) +let wrap_inv_error id = function (e, info) -> match e with + | Indrec.RecursionSchemeError + (_, Indrec.NotAllowedCaseAnalysis (_,(Type _ | Set as k),i)) -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + tclZEROMSG ( + (strbrk "Inversion would require case analysis on sort " ++ + pr_sort sigma k ++ + strbrk " which is not allowed for inductive definition " ++ + pr_inductive env (fst i) ++ str ".")) + | e -> Proofview.tclZERO ~info e + +(* The most general inversion tactic *) +let inversion inv_kind status names id = + Proofview.tclORELSE + (raw_inversion inv_kind id status names) + (wrap_inv_error id) + +(* Specializing it... *) + +let inv_gen thin status names = + try_intros_until (inversion thin status names) + +let inv k = inv_gen k NoDep + +let inv_tac id = inv FullInversion None (NamedHyp id) +let inv_clear_tac id = inv FullInversionClear None (NamedHyp id) + +let dinv k c = inv_gen k (Dep c) + +let dinv_tac id = dinv FullInversion None None (NamedHyp id) +let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) + +(* InvIn will bring the specified clauses into the conclusion, and then + * perform inversion on the named hypothesis. After, it will intro them + * back to their places in the hyp-list. *) + +let invIn k names ids id = + Proofview.Goal.enter begin fun gl -> + let hyps = List.map (fun id -> pf_get_hyp id gl) ids in + let concl = Proofview.Goal.concl gl in + let sigma = project gl in + let nb_prod_init = nb_prod sigma concl in + let intros_replace_ids = + Proofview.Goal.enter begin fun gl -> + let concl = pf_concl gl in + let sigma = project gl in + let nb_of_new_hyp = + nb_prod sigma concl - (List.length hyps + nb_prod_init) + in + if nb_of_new_hyp < 1 then + intros_replacing ids + else + tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) + end + in + Proofview.tclORELSE + (tclTHENLIST + [bring_hyps hyps; + inversion k NoDep names id; + intros_replace_ids]) + (wrap_inv_error id) + end + +let invIn_gen k names idl = try_intros_until (invIn k names idl) + +let inv_clause k names = function + | [] -> inv k names + | idl -> invIn_gen k names idl diff --git a/tactics/inv.mli b/tactics/inv.mli new file mode 100644 index 0000000000..bbd1f3352a --- /dev/null +++ b/tactics/inv.mli @@ -0,0 +1,35 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open EConstr +open Tactypes + +type inversion_status = Dep of constr option | NoDep + +type inversion_kind = + | SimpleInversion + | FullInversion + | FullInversionClear + +val inv_clause : + inversion_kind -> or_and_intro_pattern option -> Id.t list -> + quantified_hypothesis -> unit Proofview.tactic + +val inv : inversion_kind -> or_and_intro_pattern option -> + quantified_hypothesis -> unit Proofview.tactic + +val dinv : inversion_kind -> constr option -> + or_and_intro_pattern option -> quantified_hypothesis -> unit Proofview.tactic + +val inv_tac : Id.t -> unit Proofview.tactic +val inv_clear_tac : Id.t -> unit Proofview.tactic +val dinv_tac : Id.t -> unit Proofview.tactic +val dinv_clear_tac : Id.t -> unit Proofview.tactic diff --git a/tactics/leminv.ml b/tactics/leminv.ml new file mode 100644 index 0000000000..356b43ec14 --- /dev/null +++ b/tactics/leminv.ml @@ -0,0 +1,303 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Names +open Termops +open Environ +open Constr +open EConstr +open Vars +open Namegen +open Evd +open Printer +open Reductionops +open Entries +open Inductiveops +open Tacmach.New +open Clenv +open Declare +open Tacticals.New +open Tactics +open Decl_kinds +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration + +let no_inductive_inconstr env sigma constr = + (str "Cannot recognize an inductive predicate in " ++ + pr_leconstr_env env sigma constr ++ + str "." ++ spc () ++ str "If there is one, may be the structure of the arity" ++ + spc () ++ str "or of the type of constructors" ++ spc () ++ + str "is hidden by constant definitions.") + +(* Inversion stored in lemmas *) + +(* ALGORITHM: + + An inversion stored in a lemma is computed from a term-pattern, in + a signature, as follows: + + Suppose we have an inductive relation, (I abar), in a signature Gamma: + + Gamma |- (I abar) + + Then we compute the free-variables of abar. Suppose that Gamma is + thinned out to only include these. + + [We need technically to require that all free-variables of the + types of the free variables of abar are themselves free-variables + of abar. This needs to be checked, but it should not pose a + problem - it is hard to imagine cases where it would not hold.] + + Now, we pose the goal: + + (P:(Gamma)Prop)(Gamma)(I abar)->(P vars[Gamma]). + + We execute the tactic: + + REPEAT Intro THEN (OnLastHyp (Inv NONE false o outSOME)) + + This leaves us with some subgoals. All the assumptions after "P" + in these subgoals are new assumptions. I.e. if we have a subgoal, + + P:(Gamma)Prop, Gamma, Hbar:Tbar |- (P ybar) + + then the assumption we needed to have was + + (Hbar:Tbar)(P ybar) + + So we construct all the assumptions we need, and rebuild the goal + with these assumptions. Then, we can re-apply the same tactic as + above, but instead of stopping after the inversion, we just apply + the respective assumption in each subgoal. + + *) + +(* returns the sub_signature of sign corresponding to those identifiers that + * are not global. *) +(* +let get_local_sign sign = + let lid = ids_of_sign sign in + let globsign = Global.named_context() in + let add_local id res_sign = + if not (mem_sign globsign id) then + add_sign (lookup_sign id sign) res_sign + else + res_sign + in + List.fold_right add_local lid nil_sign +*) +(* returs the identifier of lid that was the latest declared in sign. + * (i.e. is the identifier id of lid such that + * sign_length (sign_prefix id sign) > sign_length (sign_prefix id' sign) > + * for any id'<>id in lid). + * it returns both the pair (id,(sign_prefix id sign)) *) +(* +let max_prefix_sign lid sign = + let rec max_rec (resid,prefix) = function + | [] -> (resid,prefix) + | (id::l) -> + let pre = sign_prefix id sign in + if sign_length pre > sign_length prefix then + max_rec (id,pre) l + else + max_rec (resid,prefix) l + in + match lid with + | [] -> nil_sign + | id::l -> snd (max_rec (id, sign_prefix id sign) l) +*) +let rec add_prods_sign env sigma t = + match EConstr.kind sigma (whd_all env sigma t) with + | Prod (na,c1,b) -> + let id = id_of_name_using_hdchar env sigma t na in + let b'= subst1 (mkVar id) b in + add_prods_sign (push_named (LocalAssum (id,c1)) env) sigma b' + | LetIn (na,c1,t1,b) -> + let id = id_of_name_using_hdchar env sigma t na in + let b'= subst1 (mkVar id) b in + add_prods_sign (push_named (LocalDef (id,c1,t1)) env) sigma b' + | _ -> (env,t) + +(* [dep_option] indicates whether the inversion lemma is dependent or not. + If it is dependent and I is of the form (x_bar:T_bar)(I t_bar) then + the stated goal will be (x_bar:T_bar)(H:(I t_bar))(P t_bar H) + where P:(x_bar:T_bar)(H:(I x_bar))[sort]. + The generalisation of such a goal at the moment of the dependent case should + be easy. + + If it is non dependent, then if [I]=(I t_bar) and (x_bar:T_bar) are the + variables occurring in [I], then the stated goal will be: + (x_bar:T_bar)(I t_bar)->(P x_bar) + where P: P:(x_bar:T_bar)[sort]. +*) + +let compute_first_inversion_scheme env sigma ind sort dep_option = + let indf,realargs = dest_ind_type ind in + let allvars = vars_of_env env in + let p = next_ident_away (Id.of_string "P") allvars in + let pty,goal = + if dep_option then + let pty = make_arity env sigma true indf sort in + let goal = + mkProd + (Anonymous, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1])) + in + pty,goal + else + let i = mkAppliedInd ind in + let ivars = global_vars env sigma i in + let revargs,ownsign = + fold_named_context + (fun env d (revargs,hyps) -> + let d = map_named_decl EConstr.of_constr d in + let id = NamedDecl.get_id d in + if Id.List.mem id ivars then + ((mkVar id)::revargs, Context.Named.add d hyps) + else + (revargs,hyps)) + env ~init:([],[]) + in + let pty = it_mkNamedProd_or_LetIn (mkSort sort) ownsign in + let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in + (pty,goal) + in + let npty = nf_all env sigma pty in + let extenv = push_named (LocalAssum (p,npty)) env in + extenv, goal + +(* [inversion_scheme sign I] + + Given a local signature, [sign], and an instance of an inductive + relation, [I], inversion_scheme will prove the associated inversion + scheme on sort [sort]. Depending on the value of [dep_option] it will + build a dependent lemma or a non-dependent one *) + +let inversion_scheme ~name ~poly env sigma t sort dep_option inv_op = + let (env,i) = add_prods_sign env sigma t in + let ind = + try find_rectype env sigma i + with Not_found -> + user_err ~hdr:"inversion_scheme" (no_inductive_inconstr env sigma i) + in + let (invEnv,invGoal) = + compute_first_inversion_scheme env sigma ind sort dep_option + in + assert + (List.subset + (global_vars env sigma invGoal) + (ids_of_named_context (named_context invEnv))); + (* + user_err ~hdr:"lemma_inversion" + (str"Computed inversion goal was not closed in initial signature."); + *) + let pf = Proof.start ~name ~poly (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in + let pf = + fst (Proof.run_tactic env ( + tclTHEN intro (onLastHypId inv_op)) pf) + in + let pfterm = List.hd (Proof.partial_proof pf) in + let global_named_context = Global.named_context_val () in + let ownSign = ref begin + fold_named_context + (fun env d sign -> + let d = map_named_decl EConstr.of_constr d in + if mem_named_context_val (NamedDecl.get_id d) global_named_context then sign + else Context.Named.add d sign) + invEnv ~init:Context.Named.empty + end in + let avoid = ref Id.Set.empty in + let Proof.{sigma} = Proof.data pf in + let sigma = Evd.minimize_universes sigma in + let rec fill_holes c = + match EConstr.kind sigma c with + | Evar (e,args) -> + let h = next_ident_away (Id.of_string "H") !avoid in + let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in + avoid := Id.Set.add h !avoid; + ownSign := Context.Named.add (LocalAssum (h,ty)) !ownSign; + applist (mkVar h, inst) + | _ -> EConstr.map sigma fill_holes c + in + let c = fill_holes pfterm in + (* warning: side-effect on ownSign *) + let invProof = it_mkNamedLambda_or_LetIn c !ownSign in + let p = EConstr.to_constr sigma invProof in + p, sigma + +let add_inversion_lemma ~poly name env sigma t sort dep inv_op = + let invProof, sigma = inversion_scheme ~name ~poly env sigma t sort dep inv_op in + let univs = + Evd.const_univ_entry ~poly sigma + in + let entry = definition_entry ~univs invProof in + let _ = declare_constant name (DefinitionEntry entry, IsProof Lemma) in + () + +(* inv_op = Inv (derives de complete inv. lemma) + * inv_op = InvNoThining (derives de semi inversion lemma) *) + +let add_inversion_lemma_exn ~poly na com comsort bool tac = + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, c = Constrintern.interp_type_evars env sigma com in + let sigma, sort = Evd.fresh_sort_in_family ~rigid:univ_rigid sigma comsort in + try + add_inversion_lemma ~poly na env sigma c sort bool tac + with + | UserError (Some "Case analysis",s) -> (* Reference to Indrec *) + user_err ~hdr:"Inv needs Nodep Prop Set" s + +(* ================================= *) +(* Applying a given inversion lemma *) +(* ================================= *) + +let lemInv id c = + Proofview.Goal.enter begin fun gls -> + try + let clause = mk_clenv_from_env (pf_env gls) (project gls) None (c, pf_unsafe_type_of gls c) in + let clause = clenv_constrain_last_binding (EConstr.mkVar id) clause in + Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false + with + | NoSuchBinding -> + user_err + (hov 0 (pr_econstr_env (pf_env gls) (project gls) c ++ spc () ++ str "does not refer to an inversion lemma.")) + | UserError (a,b) -> + user_err ~hdr:"LemInv" + (str "Cannot refine current goal with the lemma " ++ + pr_leconstr_env (pf_env gls) (project gls) c) + end + +let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id + +let lemInvIn id c ids = + Proofview.Goal.enter begin fun gl -> + let hyps = List.map (fun id -> pf_get_hyp id gl) ids in + let intros_replace_ids = + let concl = Proofview.Goal.concl gl in + let sigma = project gl in + let nb_of_new_hyp = nb_prod sigma concl - List.length ids in + if nb_of_new_hyp < 1 then + intros_replacing ids + else + (tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)) + in + ((tclTHEN (tclTHEN (bring_hyps hyps) (lemInv id c)) + (intros_replace_ids))) + end + +let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id + +let lemInv_clause id c = function + | [] -> lemInv_gen id c + | l -> lemInvIn_gen id c l diff --git a/tactics/leminv.mli b/tactics/leminv.mli new file mode 100644 index 0000000000..f42e5a8b05 --- /dev/null +++ b/tactics/leminv.mli @@ -0,0 +1,21 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open EConstr +open Constrexpr +open Tactypes + +val lemInv_clause : + quantified_hypothesis -> constr -> Id.t list -> unit Proofview.tactic + +val add_inversion_lemma_exn : poly:bool -> + Id.t -> constr_expr -> Sorts.family -> bool -> (Id.t -> unit Proofview.tactic) -> + unit diff --git a/tactics/ppred.ml b/tactics/ppred.ml new file mode 100644 index 0000000000..dd1bcd4699 --- /dev/null +++ b/tactics/ppred.ml @@ -0,0 +1,83 @@ +open Util +open Pp +open Locus +open Genredexpr +open Pputils + +let pr_with_occurrences pr keyword (occs,c) = + match occs with + | AllOccurrences -> + pr c + | NoOccurrences -> + failwith "pr_with_occurrences: no occurrences" + | OnlyOccurrences nl -> + hov 1 (pr c ++ spc () ++ keyword "at" ++ spc () ++ + hov 0 (prlist_with_sep spc (pr_or_var int) nl)) + | AllOccurrencesBut nl -> + hov 1 (pr c ++ spc () ++ keyword "at" ++ str" - " ++ + hov 0 (prlist_with_sep spc (pr_or_var int) nl)) + +exception ComplexRedFlag + +let pr_short_red_flag pr r = + if not r.rBeta || not r.rMatch || not r.rFix || not r.rCofix || not r.rZeta then + raise ComplexRedFlag + else if List.is_empty r.rConst then + if r.rDelta then mt () else raise ComplexRedFlag + else (if r.rDelta then str "-" else mt ()) ++ + hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]") + +let pr_red_flag pr r = + try pr_short_red_flag pr r + with ComplexRedFlag -> + (if r.rBeta then pr_arg str "beta" else mt ()) ++ + (if r.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else + (if r.rMatch then pr_arg str "match" else mt ()) ++ + (if r.rFix then pr_arg str "fix" else mt ()) ++ + (if r.rCofix then pr_arg str "cofix" else mt ())) ++ + (if r.rZeta then pr_arg str "zeta" else mt ()) ++ + (if List.is_empty r.rConst then + if r.rDelta then pr_arg str "delta" + else mt () + else + pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++ + hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")) + +let pr_union pr1 pr2 = function + | Inl a -> pr1 a + | Inr b -> pr2 b + +let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function + | Red false -> keyword "red" + | Hnf -> keyword "hnf" + | Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f) + ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + | Cbv f -> + if f.rBeta && f.rMatch && f.rFix && f.rCofix && + f.rZeta && f.rDelta && List.is_empty f.rConst then + keyword "compute" + else + hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f) + | Lazy f -> + hov 1 (keyword "lazy" ++ pr_red_flag pr_ref f) + | Cbn f -> + hov 1 (keyword "cbn" ++ pr_red_flag pr_ref f) + | Unfold l -> + hov 1 (keyword "unfold" ++ spc() ++ + prlist_with_sep pr_comma (pr_with_occurrences pr_ref keyword) l) + | Fold l -> hov 1 (keyword "fold" ++ prlist (pr_arg pr_constr) l) + | Pattern l -> + hov 1 (keyword "pattern" ++ + pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr keyword)) l) + + | Red true -> + CErrors.user_err Pp.(str "Shouldn't be accessible from user.") + | ExtraRedExpr s -> + str s + | CbvVm o -> + keyword "vm_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + | CbvNative o -> + keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + +let pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_ref,pr_pattern) = + pr_red_expr (pr_constr env sigma, pr_lconstr env sigma, pr_ref, pr_pattern env sigma) diff --git a/tactics/ppred.mli b/tactics/ppred.mli new file mode 100644 index 0000000000..b3a306a36f --- /dev/null +++ b/tactics/ppred.mli @@ -0,0 +1,19 @@ +open Genredexpr + +val pr_with_occurrences : + ('a -> Pp.t) -> (string -> Pp.t) -> 'a Locus.with_occurrences -> Pp.t + +val pr_short_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t +val pr_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t + +val pr_red_expr : + ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> + (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t + +val pr_red_expr_env : Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * + (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * + ('b -> Pp.t) * + (Environ.env -> Evd.evar_map -> 'c -> Pp.t) -> + (string -> Pp.t) -> + ('a,'b,'c) red_expr_gen -> Pp.t diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml new file mode 100644 index 0000000000..aabfae444e --- /dev/null +++ b/tactics/redexpr.ml @@ -0,0 +1,278 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Names +open Constr +open EConstr +open Declarations +open Genredexpr +open Pattern +open Reductionops +open Tacred +open CClosure +open RedFlags +open Libobject + +(* call by value normalisation function using the virtual machine *) +let cbv_vm env sigma c = + if Coq_config.bytecode_compiler then + let ctyp = Retyping.get_type_of env sigma c in + Vnorm.cbv_vm env sigma c ctyp + else + compute env sigma c + +let warn_native_compute_disabled = + CWarnings.create ~name:"native-compute-disabled" ~category:"native-compiler" + (fun () -> + strbrk "native_compute disabled at configure time; falling back to vm_compute.") + +let cbv_native env sigma c = + if Coq_config.native_compiler then + let ctyp = Retyping.get_type_of env sigma c in + Nativenorm.native_norm env sigma c ctyp + else + (warn_native_compute_disabled (); + cbv_vm env sigma c) + +let whd_cbn flags env sigma t = + let (state,_) = + (whd_state_gen ~refold:true ~tactic_mode:true flags env sigma (t,Reductionops.Stack.empty)) + in + Reductionops.Stack.zip ~refold:true sigma state + +let strong_cbn flags = + strong_with_flags whd_cbn flags + +let simplIsCbn = ref (false) +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = + "Plug the simpl tactic to the new cbn mechanism"; + optkey = ["SimplIsCbn"]; + optread = (fun () -> !simplIsCbn); + optwrite = (fun a -> simplIsCbn:=a); +}) + +let set_strategy_one ref l = + let k = + match ref with + | EvalConstRef sp -> ConstKey sp + | EvalVarRef id -> VarKey id in + Global.set_strategy k l; + match k,l with + ConstKey sp, Conv_oracle.Opaque -> + Csymtable.set_opaque_const sp + | ConstKey sp, _ -> + let cb = Global.lookup_constant sp in + (match cb.const_body with + | OpaqueDef _ -> + user_err ~hdr:"set_transparent_const" + (str "Cannot make" ++ spc () ++ + Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef sp) ++ + spc () ++ str "transparent because it was declared opaque."); + | _ -> Csymtable.set_transparent_const sp) + | _ -> () + +let cache_strategy (_,str) = + List.iter + (fun (lev,ql) -> List.iter (fun q -> set_strategy_one q lev) ql) + str + +let subst_strategy (subs,(local,obj)) = + local, + List.Smart.map + (fun (k,ql as entry) -> + let ql' = List.Smart.map (Mod_subst.subst_evaluable_reference subs) ql in + if ql==ql' then entry else (k,ql')) + obj + + +let map_strategy f l = + let l' = List.fold_right + (fun (lev,ql) str -> + let ql' = List.fold_right + (fun q ql -> + match f q with + Some q' -> q' :: ql + | None -> ql) ql [] in + if List.is_empty ql' then str else (lev,ql')::str) l [] in + if List.is_empty l' then None else Some (false,l') + +let classify_strategy (local,_ as obj) = + if local then Dispose else Substitute obj + +let disch_ref ref = + match ref with + EvalConstRef c -> Some ref + | EvalVarRef id -> if Lib.is_in_section (GlobRef.VarRef id) then None else Some ref + +let discharge_strategy (_,(local,obj)) = + if local then None else + map_strategy disch_ref obj + +type strategy_obj = + bool * (Conv_oracle.level * evaluable_global_reference list) list + +let inStrategy : strategy_obj -> obj = + declare_object {(default_object "STRATEGY") with + cache_function = (fun (_,obj) -> cache_strategy obj); + load_function = (fun _ (_,obj) -> cache_strategy obj); + subst_function = subst_strategy; + discharge_function = discharge_strategy; + classify_function = classify_strategy } + + +let set_strategy local str = + Lib.add_anonymous_leaf (inStrategy (local,str)) + +(* Generic reduction: reduction functions used in reduction tactics *) + +type red_expr = + (constr, evaluable_global_reference, constr_pattern) red_expr_gen + +let make_flag_constant = function + | EvalVarRef id -> fVAR id + | EvalConstRef sp -> fCONST sp + +let make_flag env f = + let red = no_red in + let red = if f.rBeta then red_add red fBETA else red in + let red = if f.rMatch then red_add red fMATCH else red in + let red = if f.rFix then red_add red fFIX else red in + let red = if f.rCofix then red_add red fCOFIX else red in + let red = if f.rZeta then red_add red fZETA else red in + let red = + if f.rDelta then (* All but rConst *) + let red = red_add red fDELTA in + let red = red_add_transparent red + (Conv_oracle.get_transp_state (Environ.oracle env)) in + List.fold_right + (fun v red -> red_sub red (make_flag_constant v)) + f.rConst red + else (* Only rConst *) + let red = red_add_transparent (red_add red fDELTA) TransparentState.empty in + List.fold_right + (fun v red -> red_add red (make_flag_constant v)) + f.rConst red + in red + +(* table of custom reductino fonctions, not synchronized, + filled via ML calls to [declare_reduction] *) +let reduction_tab = ref String.Map.empty + +(* table of custom reduction expressions, synchronized, + filled by command Declare Reduction *) +let red_expr_tab = Summary.ref String.Map.empty ~name:"Declare Reduction" + +let declare_reduction s f = + if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab + then user_err ~hdr:"Redexpr.declare_reduction" + (str "There is already a reduction expression of name " ++ str s) + else reduction_tab := String.Map.add s f !reduction_tab + +let check_custom = function + | ExtraRedExpr s -> + if not (String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab) + then user_err ~hdr:"Redexpr.check_custom" (str "Reference to undefined reduction expression " ++ str s) + |_ -> () + +let decl_red_expr s e = + if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab + then user_err ~hdr:"Redexpr.decl_red_expr" + (str "There is already a reduction expression of name " ++ str s) + else begin + check_custom e; + red_expr_tab := String.Map.add s e !red_expr_tab + end + +let out_arg = function + | Locus.ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable.") + | Locus.ArgArg x -> x + +let out_with_occurrences (occs,c) = + (Locusops.occurrences_map (List.map out_arg) occs, c) + +let e_red f env evm c = evm, f env evm c + +let head_style = false (* Turn to true to have a semantics where simpl + only reduce at the head when an evaluable reference is given, e.g. + 2+n would just reduce to S(1+n) instead of S(S(n)) *) + +let contextualize f g = function + | Some (occs,c) -> + let l = Locusops.occurrences_map (List.map out_arg) occs in + let b,c,h = match c with + | Inl r -> true,PRef (global_of_evaluable_reference r),f + | Inr c -> false,c,f in + e_red (contextually b (l,c) (fun _ -> h)) + | None -> e_red g + +let warn_simpl_unfolding_modifiers = + CWarnings.create ~name:"simpl-unfolding-modifiers" ~category:"tactics" + (fun () -> + Pp.strbrk "The legacy simpl ignores constant unfolding modifiers.") + +let reduction_of_red_expr env = + let make_flag = make_flag env in + let rec reduction_of_red_expr = function + | Red internal -> + if internal then (e_red try_red_product,DEFAULTcast) + else (e_red red_product,DEFAULTcast) + | Hnf -> (e_red hnf_constr,DEFAULTcast) + | Simpl (f,o) -> + let whd_am = if !simplIsCbn then whd_cbn (make_flag f) else whd_simpl in + let am = if !simplIsCbn then strong_cbn (make_flag f) else simpl in + let () = + if not (!simplIsCbn || List.is_empty f.rConst) then + warn_simpl_unfolding_modifiers () in + (contextualize (if head_style then whd_am else am) am o,DEFAULTcast) + | Cbv f -> (e_red (cbv_norm_flags (make_flag f)),DEFAULTcast) + | Cbn f -> + (e_red (strong_cbn (make_flag f)), DEFAULTcast) + | Lazy f -> (e_red (clos_norm_flags (make_flag f)),DEFAULTcast) + | Unfold ubinds -> (e_red (unfoldn (List.map out_with_occurrences ubinds)),DEFAULTcast) + | Fold cl -> (e_red (fold_commands cl),DEFAULTcast) + | Pattern lp -> (pattern_occs (List.map out_with_occurrences lp),DEFAULTcast) + | ExtraRedExpr s -> + (try (e_red (String.Map.find s !reduction_tab),DEFAULTcast) + with Not_found -> + (try reduction_of_red_expr (String.Map.find s !red_expr_tab) + with Not_found -> + user_err ~hdr:"Redexpr.reduction_of_red_expr" + (str "unknown user-defined reduction \"" ++ str s ++ str "\""))) + | CbvVm o -> (contextualize cbv_vm cbv_vm o, VMcast) + | CbvNative o -> (contextualize cbv_native cbv_native o, NATIVEcast) + in + reduction_of_red_expr + +let subst_mps subst c = + EConstr.of_constr (Mod_subst.subst_mps subst (EConstr.Unsafe.to_constr c)) + +let subst_red_expr subs = + Redops.map_red_expr_gen + (subst_mps subs) + (Mod_subst.subst_evaluable_reference subs) + (Patternops.subst_pattern subs) + +let inReduction : bool * string * red_expr -> obj = + declare_object + {(default_object "REDUCTION") with + cache_function = (fun (_,(_,s,e)) -> decl_red_expr s e); + load_function = (fun _ (_,(_,s,e)) -> decl_red_expr s e); + subst_function = + (fun (subs,(b,s,e)) -> b,s,subst_red_expr subs e); + classify_function = + (fun ((b,_,_) as obj) -> if b then Dispose else Substitute obj) } + +let declare_red_expr locality s expr = + Lib.add_anonymous_leaf (inReduction (locality,s,expr)) diff --git a/tactics/redexpr.mli b/tactics/redexpr.mli new file mode 100644 index 0000000000..1f65862701 --- /dev/null +++ b/tactics/redexpr.mli @@ -0,0 +1,48 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Interpretation layer of redexprs such as hnf, cbv, etc. *) + +open Names +open Constr +open EConstr +open Pattern +open Genredexpr +open Reductionops +open Locus + +type red_expr = + (constr, evaluable_global_reference, constr_pattern) red_expr_gen + +val out_with_occurrences : 'a with_occurrences -> occurrences * 'a + +val reduction_of_red_expr : + Environ.env -> red_expr -> e_reduction_function * cast_kind + +(** [true] if we should use the vm to verify the reduction *) + +(** Adding a custom reduction (function to be use at the ML level) + NB: the effect is permanent. *) +val declare_reduction : string -> reduction_function -> unit + +(** Adding a custom reduction (function to be called a vernac command). + The boolean flag is the locality. *) +val declare_red_expr : bool -> string -> red_expr -> unit + +(** Opaque and Transparent commands. *) + +(** Sets the expansion strategy of a constant. When the boolean is + true, the effect is non-synchronous (i.e. it does not survive + section and module closure). *) +val set_strategy : + bool -> (Conv_oracle.level * evaluable_global_reference list) list -> unit + +(** call by value normalisation function using the virtual machine *) +val cbv_vm : reduction_function diff --git a/tactics/redops.ml b/tactics/redops.ml new file mode 100644 index 0000000000..6f83ea9a34 --- /dev/null +++ b/tactics/redops.ml @@ -0,0 +1,64 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Genredexpr + +let union_consts l1 l2 = Util.List.union Pervasives.(=) l1 l2 (* FIXME *) + +let make_red_flag l = + let rec add_flag red = function + | [] -> red + | FBeta :: lf -> add_flag { red with rBeta = true } lf + | FMatch :: lf -> add_flag { red with rMatch = true } lf + | FFix :: lf -> add_flag { red with rFix = true } lf + | FCofix :: lf -> add_flag { red with rCofix = true } lf + | FZeta :: lf -> add_flag { red with rZeta = true } lf + | FConst l :: lf -> + if red.rDelta then + CErrors.user_err Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); + add_flag { red with rConst = union_consts red.rConst l } lf + | FDeltaBut l :: lf -> + if red.rConst <> [] && not red.rDelta then + CErrors.user_err Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); + add_flag + { red with rConst = union_consts red.rConst l; rDelta = true } + lf + in + add_flag + {rBeta = false; rMatch = false; rFix = false; rCofix = false; + rZeta = false; rDelta = false; rConst = []} + l + + +let all_flags = + {rBeta = true; rMatch = true; rFix = true; rCofix = true; + rZeta = true; rDelta = true; rConst = []} + +(** Mapping [red_expr_gen] *) + +let map_flags f flags = + { flags with rConst = List.map f flags.rConst } + +let map_occs f (occ,e) = (occ,f e) + +let map_red_expr_gen f g h = function + | Fold l -> Fold (List.map f l) + | Pattern occs_l -> Pattern (List.map (map_occs f) occs_l) + | Simpl (flags,occs_o) -> + Simpl (map_flags g flags, Option.map (map_occs (Util.map_union g h)) occs_o) + | Unfold occs_l -> Unfold (List.map (map_occs g) occs_l) + | Cbv flags -> Cbv (map_flags g flags) + | Lazy flags -> Lazy (map_flags g flags) + | CbvVm occs_o -> CbvVm (Option.map (map_occs (Util.map_union g h)) occs_o) + | CbvNative occs_o -> CbvNative (Option.map (map_occs (Util.map_union g h)) occs_o) + | Cbn flags -> Cbn (map_flags g flags) + | ExtraRedExpr _ | Red _ | Hnf as x -> x diff --git a/tactics/redops.mli b/tactics/redops.mli new file mode 100644 index 0000000000..7254f29b25 --- /dev/null +++ b/tactics/redops.mli @@ -0,0 +1,20 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Genredexpr + +val make_red_flag : 'a red_atom list -> 'a glob_red_flag + +val all_flags : 'a glob_red_flag + +(** Mapping [red_expr_gen] *) + +val map_red_expr_gen : ('a -> 'd) -> ('b -> 'e) -> ('c -> 'f) -> + ('a,'b,'c) red_expr_gen -> ('d,'e,'f) red_expr_gen diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml new file mode 100644 index 0000000000..bfbce8f6eb --- /dev/null +++ b/tactics/tacticals.ml @@ -0,0 +1,771 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Names +open Constr +open EConstr +open Termops +open Declarations +open Tacmach +open Clenv +open Tactypes + +module NamedDecl = Context.Named.Declaration + +(************************************************************************) +(* Tacticals re-exported from the Refiner module *) +(************************************************************************) + +type tactic = Proofview.V82.tac + +let tclIDTAC = Refiner.tclIDTAC +let tclIDTAC_MESSAGE = Refiner.tclIDTAC_MESSAGE +let tclORELSE0 = Refiner.tclORELSE0 +let tclORELSE = Refiner.tclORELSE +let tclTHEN = Refiner.tclTHEN +let tclTHENLIST = Refiner.tclTHENLIST +let tclMAP = Refiner.tclMAP +let tclTHEN_i = Refiner.tclTHEN_i +let tclTHENFIRST = Refiner.tclTHENFIRST +let tclTHENLAST = Refiner.tclTHENLAST +let tclTHENS = Refiner.tclTHENS +let tclTHENSV = Refiner.tclTHENSV +let tclTHENSFIRSTn = Refiner.tclTHENSFIRSTn +let tclTHENSLASTn = Refiner.tclTHENSLASTn +let tclTHENFIRSTn = Refiner.tclTHENFIRSTn +let tclTHENLASTn = Refiner.tclTHENLASTn +let tclREPEAT = Refiner.tclREPEAT +let tclREPEAT_MAIN = Refiner.tclREPEAT_MAIN +let tclFIRST = Refiner.tclFIRST +let tclSOLVE = Refiner.tclSOLVE +let tclTRY = Refiner.tclTRY +let tclCOMPLETE = Refiner.tclCOMPLETE +let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE +let tclFAIL = Refiner.tclFAIL +let tclFAIL_lazy = Refiner.tclFAIL_lazy +let tclDO = Refiner.tclDO +let tclPROGRESS = Refiner.tclPROGRESS +let tclSHOWHYPS = Refiner.tclSHOWHYPS +let tclTHENTRY = Refiner.tclTHENTRY +let tclIFTHENELSE = Refiner.tclIFTHENELSE +let tclIFTHENSELSE = Refiner.tclIFTHENSELSE +let tclIFTHENSVELSE = Refiner.tclIFTHENSVELSE +let tclIFTHENTRYELSEMUST = Refiner.tclIFTHENTRYELSEMUST + +(************************************************************************) +(* Tacticals applying on hypotheses *) +(************************************************************************) + +let nthDecl m gl = + try List.nth (pf_hyps gl) (m-1) + with Failure _ -> user_err Pp.(str "No such assumption.") + +let nthHypId m gl = nthDecl m gl |> NamedDecl.get_id +let nthHyp m gl = mkVar (nthHypId m gl) + +let lastDecl gl = nthDecl 1 gl +let lastHypId gl = nthHypId 1 gl +let lastHyp gl = nthHyp 1 gl + +let nLastDecls n gl = + try List.firstn n (pf_hyps gl) + with Failure _ -> user_err Pp.(str "Not enough hypotheses in the goal.") + +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 +let onNthHypId m tac gl = tac (nthHypId m gl) gl +let onNthHyp m tac gl = tac (nthHyp m gl) gl + +let onLastDecl = onNthDecl 1 +let onLastHypId = onNthHypId 1 +let onLastHyp = onNthHyp 1 + +let onHyps find tac gl = tac (find gl) gl + +let onNLastDecls n tac = onHyps (nLastDecls n) tac +let onNLastHypsId n tac = onHyps (nLastHypsId n) tac +let onNLastHyps n tac = onHyps (nLastHyps n) tac + +let afterHyp id gl = + fst (List.split_when (NamedDecl.get_id %> Id.equal id) (pf_hyps gl)) + +(***************************************) +(* Clause Tacticals *) +(***************************************) + +(* The following functions introduce several tactic combinators and + functions useful for working with clauses. A clause is either None + or (Some id), where id is an identifier. This type is useful for + defining tactics that may be used either to transform the + conclusion (None) or to transform a hypothesis id (Some id). -- + --Eduardo (8/8/97) +*) + +let fullGoal gl = None :: List.map Option.make (pf_ids_of_hyps gl) + +let onAllHyps tac gl = tclMAP tac (pf_ids_of_hyps gl) gl +let onAllHypsAndConcl tac gl = tclMAP tac (fullGoal gl) gl + +let onClause tac cl gls = + let hyps () = pf_ids_of_hyps gls in + tclMAP tac (Locusops.simple_clause_of hyps cl) gls +let onClauseLR tac cl gls = + let hyps () = pf_ids_of_hyps gls in + tclMAP tac (List.rev (Locusops.simple_clause_of hyps cl)) gls + +let ifOnHyp pred tac1 tac2 id gl = + if pred (id,pf_get_hyp_typ gl id) then + tac1 id gl + else + tac2 id gl + +(************************************************************************) +(* Elimination Tacticals *) +(************************************************************************) + +(* The following tacticals allow to apply a tactic to the + branches generated by the application of an elimination + tactic. + + Two auxiliary types --branch_args and branch_assumptions-- are + used to keep track of some information about the ``branches'' of + the elimination. *) + +type branch_args = { + ity : pinductive; (* the type we were eliminating on *) + largs : constr list; (* its arguments *) + branchnum : int; (* the branch number *) + pred : constr; (* the predicate we used *) + nassums : int; (* number of assumptions/letin to be introduced *) + branchsign : bool list; (* the signature of the branch. + true=assumption, false=let-in *) + branchnames : intro_patterns} + +type branch_assumptions = { + ba : branch_args; (* the branch args *) + assums : named_context} (* the list of assumptions introduced *) + +let fix_empty_or_and_pattern nv l = + (* 1- The syntax does not distinguish between "[ ]" for one clause with no + names and "[ ]" for no clause at all *) + (* 2- More generally, we admit "[ ]" for any disjunctive pattern of + arbitrary length *) + match l with + | IntroOrPattern [[]] -> IntroOrPattern (List.make nv []) + | _ -> l + +let check_or_and_pattern_size ?loc check_and 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 (str "Expects " ++ msg p1 p2 ++ str ".") in + let errn n = + user_err ?loc (str "Expects a disjunctive pattern with " ++ int n + ++ str " branches.") in + let err1' p1 p2 = + user_err ?loc (strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in + let errforthcoming ?loc = + user_err ?loc (strbrk "Unexpected non atomic pattern.") in + match names with + | IntroAndPattern l -> + if not (Int.equal n 1) then errn n; + let l' = List.filter CAst.(function {v=IntroForthcoming _} -> true | {v=IntroNaming _} | {v=IntroAction _} -> false) l in + if l' != [] then errforthcoming ?loc:(List.hd l').CAst.loc; + if check_and then + let p1 = List.count (fun x -> x) branchsigns.(0) in + let p2 = List.length branchsigns.(0) in + let p = List.length l in + if not (Int.equal p p1 || Int.equal p p2) then err1 p1 p2; + if Int.equal p p1 then + IntroAndPattern + (List.extend branchsigns.(0) (CAst.make @@ IntroNaming Namegen.IntroAnonymous) l) + else + names + else + names + | IntroOrPattern ll -> + if not (Int.equal n (List.length ll)) then + if Int.equal n 1 then + let p1 = List.count (fun x -> x) branchsigns.(0) in + let p2 = List.length branchsigns.(0) in + err1' p1 p2 else errn n; + names + +let get_and_check_or_and_pattern_gen ?loc check_and names branchsigns = + let names = check_or_and_pattern_size ?loc check_and names branchsigns in + match names with + | IntroAndPattern l -> [|l|] + | IntroOrPattern l -> Array.of_list l + +let get_and_check_or_and_pattern ?loc = get_and_check_or_and_pattern_gen ?loc true + +let compute_induction_names_gen check_and branchletsigns = function + | None -> + Array.make (Array.length branchletsigns) [] + | Some {CAst.loc;v=names} -> + let names = fix_empty_or_and_pattern (Array.length branchletsigns) names in + get_and_check_or_and_pattern_gen check_and ?loc names branchletsigns + +let compute_induction_names = compute_induction_names_gen true + +(* Compute the let-in signature of case analysis or standard induction scheme *) +let compute_constructor_signatures ~rec_flag ((_,k as ity),u) = + let rec analrec c recargs = + match Constr.kind c, recargs with + | Prod (_,_,c), recarg::rest -> + let rest = analrec c rest in + begin match Declareops.dest_recarg recarg with + | Norec | Imbr _ -> true :: rest + | Mrec (_,j) -> + if rec_flag && Int.equal j k then true :: true :: rest + else true :: rest + end + | LetIn (_,_,_,c), rest -> false :: analrec c rest + | _, [] -> [] + | _ -> anomaly (Pp.str "compute_constructor_signatures.") + in + let (mib,mip) = Global.lookup_inductive ity in + let n = mib.mind_nparams in + let lc = + Array.map (fun c -> snd (Term.decompose_prod_n_assum n c)) mip.mind_nf_lc in + let lrecargs = Declareops.dest_subterms mip.mind_recargs in + Array.map2 analrec lc lrecargs + +let elimination_sort_of_goal gl = + pf_apply Retyping.get_sort_family_of gl (pf_concl gl) + +let elimination_sort_of_hyp id gl = + pf_apply Retyping.get_sort_family_of gl (pf_get_hyp_typ gl id) + +let elimination_sort_of_clause = function + | None -> elimination_sort_of_goal + | Some id -> elimination_sort_of_hyp id + + +let pf_with_evars glsev k gls = + let evd, a = glsev gls in + tclTHEN (Refiner.tclEVARS evd) (k a) gls + +let pf_constr_of_global gr k = + pf_with_evars (fun gls -> pf_apply Evd.fresh_global gls gr) k + +(** Tacticals of Ltac defined directly in term of Proofview *) +module New = struct + open Proofview + open Proofview.Notations + open Tacmach.New + + let tclIDTAC = tclUNIT () + + let tclTHEN t1 t2 = + t1 <*> t2 + + let tclFAIL lvl msg = + tclZERO (Refiner.FailError (lvl,lazy msg)) + + let tclZEROMSG ?loc msg = + let err = UserError (None, msg) in + let info = match loc with + | None -> Exninfo.null + | Some loc -> Loc.add_loc Exninfo.null loc + in + tclZERO ~info err + + let catch_failerror e = + try + Refiner.catch_failerror e; + tclUNIT () + 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 + tactical, we may consider wrapping the first argument with + [tclPROGRESS]. It strikes me as a bad idea, but consistency can be + considered valuable. *) + let tclOR t1 t2 = + tclINDEPENDENT begin + Proofview.tclOR + t1 + begin fun e -> + catch_failerror e <*> t2 + end + end + + let tclORD t1 t2 = + tclINDEPENDENT begin + Proofview.tclOR + t1 + begin fun e -> + catch_failerror e <*> t2 () + end + end + + let tclONCE = Proofview.tclONCE + + let tclEXACTLY_ONCE t = Proofview.tclEXACTLY_ONCE (Refiner.FailError(0,lazy (assert false))) t + + let tclIFCATCH t tt te = + tclINDEPENDENT begin + Proofview.tclIFCATCH t + tt + (fun e -> catch_failerror e <*> te ()) + end + + let tclORELSE0 t1 t2 = + tclINDEPENDENT begin + tclORELSE + t1 + begin fun e -> + catch_failerror e <*> t2 + end + end + + let tclORELSE0L t1 t2 = + tclINDEPENDENTL begin + tclORELSE + t1 + begin fun e -> + catch_failerror e <*> t2 + end + end + + let tclORELSE t1 t2 = + tclORELSE0 (tclPROGRESS t1) t2 + + let tclTHENS3PARTS t1 l1 repeat l2 = + tclINDEPENDENT begin + t1 <*> + Proofview.tclORELSE (* converts the [SizeMismatch] error into an ltac error *) + begin tclEXTEND (Array.to_list l1) repeat (Array.to_list l2) end + begin function (e, info) -> match e with + | SizeMismatch (i,_)-> + let errmsg = + str"Incorrect number of goals" ++ spc() ++ + str"(expected "++int i++str(String.plural i " tactic") ++ str")" + in + tclFAIL 0 errmsg + | reraise -> tclZERO ~info reraise + end + end + let tclTHENSFIRSTn t1 l repeat = + tclTHENS3PARTS t1 l repeat [||] + let tclTHENFIRSTn t1 l = + tclTHENSFIRSTn t1 l (tclUNIT()) + let tclTHENFIRST t1 t2 = + tclTHENFIRSTn t1 [|t2|] + + let tclBINDFIRST t1 t2 = + t1 >>= fun ans -> + Proofview.Unsafe.tclGETGOALS >>= fun gls -> + match gls with + | [] -> tclFAIL 0 (str "Expect at least one goal.") + | hd::tl -> + Proofview.Unsafe.tclSETGOALS [hd] <*> t2 ans >>= fun ans -> + Proofview.Unsafe.tclNEWGOALS tl <*> + Proofview.tclUNIT ans + + let tclTHENLASTn t1 l = + tclTHENS3PARTS t1 [||] (tclUNIT()) l + let tclTHENLAST t1 t2 = tclTHENLASTn t1 [|t2|] + + let option_of_failure f x = try Some (f x) with Failure _ -> None + + let tclBINDLAST t1 t2 = + t1 >>= fun ans -> + Proofview.Unsafe.tclGETGOALS >>= fun gls -> + match option_of_failure List.sep_last gls with + | None -> tclFAIL 0 (str "Expect at least one goal.") + | Some (last,firstn) -> + Proofview.Unsafe.tclSETGOALS [last] <*> t2 ans >>= fun ans -> + Proofview.Unsafe.tclGETGOALS >>= fun newgls -> + tclEVARMAP >>= fun sigma -> + let firstn = Proofview.Unsafe.undefined sigma firstn in + Proofview.Unsafe.tclSETGOALS (firstn@newgls) <*> + Proofview.tclUNIT ans + + let tclTHENS t l = + tclINDEPENDENT begin + t <*>Proofview.tclORELSE (* converts the [SizeMismatch] error into an ltac error *) + begin tclDISPATCH l end + begin function (e, info) -> match e with + | SizeMismatch (i,_)-> + let errmsg = + str"Incorrect number of goals" ++ spc() ++ + str"(expected "++int i++str(String.plural i " tactic") ++ str")" + in + tclFAIL 0 errmsg + | reraise -> tclZERO ~info reraise + end + end + let tclTHENLIST l = + List.fold_left tclTHEN (tclUNIT()) l + + + (* [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *) + let tclMAP tacfun l = + List.fold_right (fun x -> (tclTHEN (tacfun x))) l (tclUNIT()) + + let tclTRY t = + tclORELSE0 t (tclUNIT ()) + + let tclTRYb t = + tclORELSE0L (t <*> tclUNIT true) (tclUNIT false) + + let tclIFTHENELSE t1 t2 t3 = + tclINDEPENDENT begin + Proofview.tclIFCATCH t1 + (fun () -> t2) + (fun (e, info) -> Proofview.tclORELSE t3 (fun e' -> tclZERO ~info e)) + end + let tclIFTHENSVELSE t1 a t3 = + Proofview.tclIFCATCH t1 + (fun () -> tclDISPATCH (Array.to_list a)) + (fun _ -> t3) + let tclIFTHENFIRSTELSE t1 t2 t3 = + Proofview.tclIFCATCH t1 + (fun () -> tclEXTEND [t2] (tclUNIT ()) []) + (fun _ -> t3) + let tclIFTHENTRYELSEMUST t1 t2 = + tclIFTHENELSE t1 (tclTRY t2) t2 + let tclIFTHENFIRSTTRYELSEMUST t1 t2 = + tclIFTHENFIRSTELSE t1 (tclTRY t2) t2 + + (* Try the first tactic that does not fail in a list of tactics *) + let rec tclFIRST = function + | [] -> tclZEROMSG (str"No applicable tactic.") + | t::rest -> tclORELSE0 t (tclFIRST rest) + + let rec tclFIRST_PROGRESS_ON tac = function + | [] -> tclFAIL 0 (str "No applicable tactic") + | [a] -> tac a (* so that returned failure is the one from last item *) + | a::tl -> tclORELSE (tac a) (tclFIRST_PROGRESS_ON tac tl) + + let rec tclDO n t = + if n < 0 then + tclZEROMSG (str"Wrong argument : Do needs a positive integer.") + else if n = 0 then tclUNIT () + else if n = 1 then t + else tclTHEN t (tclDO (n-1) t) + + let rec tclREPEAT0 t = + tclINDEPENDENT begin + Proofview.tclIFCATCH t + (fun () -> tclCHECKINTERRUPT <*> tclREPEAT0 t) + (fun e -> catch_failerror e <*> tclUNIT ()) + end + let tclREPEAT t = + tclREPEAT0 (tclPROGRESS t) + let rec tclREPEAT_MAIN0 t = + Proofview.tclIFCATCH t + (fun () -> tclTRYFOCUS 1 1 (tclREPEAT_MAIN0 t)) + (fun e -> catch_failerror e <*> tclUNIT ()) + let tclREPEAT_MAIN t = + tclREPEAT_MAIN0 (tclPROGRESS t) + + let tclCOMPLETE t = + t >>= fun res -> + (tclINDEPENDENT + (tclZEROMSG (str"Proof is not complete.")) + ) <*> + tclUNIT res + + (* Try the first thats solves the current goal *) + let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl) + + let tclPROGRESS t = + Proofview.tclINDEPENDENT (Proofview.tclPROGRESS t) + + (* Select a subset of the goals *) + let tclSELECT = let open Goal_select in function + | SelectNth i -> Proofview.tclFOCUS i i + | SelectList l -> Proofview.tclFOCUSLIST l + | SelectId id -> Proofview.tclFOCUSID id + | SelectAll -> anomaly ~label:"tclSELECT" Pp.(str "SelectAll not allowed here") + | SelectAlreadyFocused -> + anomaly ~label:"tclSELECT" Pp.(str "SelectAlreadyFocused not allowed here") + + (* Check that holes in arguments have been resolved *) + + let check_evars env sigma extsigma origsigma = + let rec is_undefined_up_to_restriction sigma evk = + if Evd.mem origsigma evk then None else + let evi = Evd.find sigma evk in + match Evd.evar_body evi with + | Evd.Evar_empty -> Some (evk,evi) + | Evd.Evar_defined c -> match Constr.kind (EConstr.Unsafe.to_constr c) with + | Evar (evk,l) -> is_undefined_up_to_restriction sigma evk + | _ -> + (* We make the assumption that there is no way to refine an + evar remaining after typing from the initial term given to + apply/elim and co tactics, is it correct? *) + None in + let rest = + Evd.fold_undefined (fun evk evi acc -> + match is_undefined_up_to_restriction sigma evk with + | Some (evk',evi) -> (evk',evi)::acc + | _ -> acc) + extsigma [] + in + match rest with + | [] -> () + | (evk,evi) :: _ -> + let (loc,_) = evi.Evd.evar_source in + Pretype_errors.error_unsolvable_implicit ?loc env sigma evk None + + let tclWITHHOLES accept_unresolved_holes tac sigma = + tclEVARMAP >>= fun sigma_initial -> + if sigma == sigma_initial then tac + else + let check_evars_if x = + if not accept_unresolved_holes then + tclEVARMAP >>= fun sigma_final -> + tclENV >>= fun env -> + try + let () = check_evars env sigma_final sigma sigma_initial in + tclUNIT x + with e when CErrors.noncritical e -> + tclZERO e + else + tclUNIT x + in + Proofview.Unsafe.tclEVARS sigma <*> tac >>= check_evars_if + + let tclDELAYEDWITHHOLES check x tac = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let (sigma, x) = x env sigma in + tclWITHHOLES check (tac x) sigma + end + + let tclTIMEOUT n t = + Proofview.tclOR + (Proofview.tclTIMEOUT n t) + begin function (e, info) -> match e with + | Proofview.Timeout as e -> Proofview.tclZERO (Refiner.FailError (0,lazy (CErrors.print e))) + | e -> Proofview.tclZERO ~info e + end + + let tclTIME s t = + Proofview.tclTIME s t + + let nthDecl m gl = + let hyps = Proofview.Goal.hyps gl in + try + List.nth hyps (m-1) + with Failure _ -> CErrors.user_err Pp.(str "No such assumption.") + + let nLastDecls gl n = + try List.firstn n (Proofview.Goal.hyps gl) + with Failure _ -> CErrors.user_err Pp.(str "Not enough hypotheses in the goal.") + + let nthHypId m gl = + (* We only use [id] *) + nthDecl m gl |> NamedDecl.get_id + let nthHyp m gl = + mkVar (nthHypId m gl) + + let onNthHypId m tac = + Proofview.Goal.enter begin fun gl -> tac (nthHypId m gl) end + let onNthHyp m tac = + Proofview.Goal.enter begin fun gl -> tac (nthHyp m gl) end + + let onLastHypId = onNthHypId 1 + let onLastHyp = onNthHyp 1 + + let onNthDecl m tac = + Proofview.Goal.enter begin fun gl -> + Proofview.tclUNIT (nthDecl m gl) >>= tac + end + let onLastDecl = onNthDecl 1 + + let ifOnHyp pred tac1 tac2 id = + Proofview.Goal.enter begin fun gl -> + let typ = Tacmach.New.pf_get_hyp_typ id gl in + if pred (id,typ) then + tac1 id + else + tac2 id + end + + let onHyps find tac = Proofview.Goal.enter begin fun gl -> tac (find gl) end + + let afterHyp id tac = + Proofview.Goal.enter begin fun gl -> + let hyps = Proofview.Goal.hyps gl in + let rem, _ = List.split_when (NamedDecl.get_id %> Id.equal id) hyps in + tac rem + end + + let fullGoal gl = + let hyps = Tacmach.New.pf_ids_of_hyps gl in + None :: List.map Option.make hyps + + let tryAllHyps tac = + Proofview.Goal.enter begin fun gl -> + let hyps = Tacmach.New.pf_ids_of_hyps gl in + tclFIRST_PROGRESS_ON tac hyps + end + let tryAllHypsAndConcl tac = + Proofview.Goal.enter begin fun gl -> + tclFIRST_PROGRESS_ON tac (fullGoal gl) + end + + let onClause tac cl = + Proofview.Goal.enter begin fun gl -> + let hyps = Tacmach.New.pf_ids_of_hyps gl in + tclMAP tac (Locusops.simple_clause_of (fun () -> hyps) cl) + end + + (* Find the right elimination suffix corresponding to the sort of the goal *) + (* c should be of type A1->.. An->B with B an inductive definition *) + let general_elim_then_using mk_elim + rec_flag allnames tac predicate ind (c, t) = + Proofview.Goal.enter begin fun gl -> + let sigma, elim = mk_elim ind gl in + let ind = on_snd (fun u -> EInstance.kind sigma u) ind in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Proofview.Goal.enter begin fun gl -> + let indclause = mk_clenv_from gl (c, t) in + (* applying elimination_scheme just a little modified *) + let elimclause = mk_clenv_from gl (elim,Tacmach.New.pf_unsafe_type_of gl elim) in + let indmv = + match EConstr.kind elimclause.evd (last_arg elimclause.evd elimclause.templval.Evd.rebus) with + | Meta mv -> mv + | _ -> anomaly (str"elimination.") + in + let pmv = + let p, _ = decompose_app elimclause.evd elimclause.templtyp.Evd.rebus in + match EConstr.kind elimclause.evd p with + | Meta p -> p + | _ -> + let name_elim = + match EConstr.kind sigma elim with + | Const _ | Var _ -> str " " ++ Printer.pr_econstr_env (pf_env gl) sigma elim + | _ -> mt () + in + user_err ~hdr:"Tacticals.general_elim_then_using" + (str "The elimination combinator " ++ name_elim ++ str " is unknown.") + in + let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in + let branchsigns = compute_constructor_signatures ~rec_flag ind in + let brnames = compute_induction_names_gen false branchsigns allnames in + let flags = Unification.elim_flags () in + let elimclause' = + match predicate with + | None -> elimclause' + | Some p -> clenv_unify ~flags Reduction.CONV (mkMeta pmv) p elimclause' + in + let clenv' = clenv_unique_resolver ~flags elimclause' gl in + let after_tac i = + let (hd,largs) = decompose_app clenv'.evd clenv'.templtyp.Evd.rebus in + let ba = { branchsign = branchsigns.(i); + branchnames = brnames.(i); + nassums = List.length branchsigns.(i); + branchnum = i+1; + ity = ind; + largs = List.map (clenv_nf_meta clenv') largs; + pred = clenv_nf_meta clenv' hd } + in + tac ba + in + let branchtacs = List.init (Array.length branchsigns) after_tac in + Proofview.tclTHEN + (Clenvtac.clenv_refine clenv') + (Proofview.tclEXTEND [] tclIDTAC branchtacs) + end) end + + let elimination_sort_of_goal gl = + (* Retyping will expand evars anyway. *) + let c = Proofview.Goal.concl gl in + pf_apply Retyping.get_sort_family_of gl c + + let elimination_sort_of_hyp id gl = + (* Retyping will expand evars anyway. *) + let c = pf_get_hyp_typ id gl in + pf_apply Retyping.get_sort_family_of gl c + + let elimination_sort_of_clause id gl = match id with + | None -> elimination_sort_of_goal gl + | Some id -> elimination_sort_of_hyp id gl + + (* computing the case/elim combinators *) + + let gl_make_elim ind = begin fun gl -> + let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in + let (sigma, c) = pf_apply Evd.fresh_global gl gr in + (sigma, c) + end + + let gl_make_case_dep (ind, u) = begin fun gl -> + let sigma = project gl in + let u = EInstance.kind (project gl) u in + let (sigma, r) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) true + (elimination_sort_of_goal gl) + in + (sigma, EConstr.of_constr r) + end + + let gl_make_case_nodep (ind, u) = begin fun gl -> + let sigma = project gl in + let u = EInstance.kind sigma u in + let (sigma, r) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) false + (elimination_sort_of_goal gl) + in + (sigma, EConstr.of_constr r) + end + + let make_elim_branch_assumptions ba hyps = + let assums = + try List.rev (List.firstn ba.nassums hyps) + with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions.") in + { ba = ba; assums = assums } + + let elim_on_ba tac ba = + Proofview.Goal.enter begin fun gl -> + let branches = make_elim_branch_assumptions ba (Proofview.Goal.hyps gl) in + tac branches + end + + let case_on_ba tac ba = + Proofview.Goal.enter begin fun gl -> + let branches = make_elim_branch_assumptions ba (Proofview.Goal.hyps gl) in + tac branches + end + + let elimination_then tac c = + Proofview.Goal.enter begin fun gl -> + let (ind,t) = pf_reduce_to_quantified_ind gl (pf_unsafe_type_of gl c) in + let isrec,mkelim = + match (Global.lookup_mind (fst (fst ind))).mind_record with + | NotRecord -> true,gl_make_elim + | FakeRecord | PrimRecord _ -> false,gl_make_case_dep + in + general_elim_then_using mkelim isrec None tac None ind (c, t) + end + + let case_then_using = + general_elim_then_using gl_make_case_dep false + + let case_nodep_then_using = + general_elim_then_using gl_make_case_nodep false + + let pf_constr_of_global ref = + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.tclENV >>= fun env -> + let (sigma, c) = Evd.fresh_global env sigma ref in + Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT c + +end diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli new file mode 100644 index 0000000000..201b7801c3 --- /dev/null +++ b/tactics/tacticals.mli @@ -0,0 +1,271 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open EConstr +open Evd +open Locus +open Tactypes + +(** Tacticals i.e. functions from tactics to tactics. *) + +type tactic = Proofview.V82.tac + +val tclIDTAC : tactic +val tclIDTAC_MESSAGE : Pp.t -> tactic +val tclORELSE0 : tactic -> tactic -> tactic +val tclORELSE : tactic -> tactic -> tactic +val tclTHEN : tactic -> tactic -> tactic +val tclTHENLIST : tactic list -> tactic +val tclTHEN_i : tactic -> (int -> tactic) -> tactic +val tclTHENFIRST : tactic -> tactic -> tactic +val tclTHENLAST : tactic -> tactic -> tactic +val tclTHENS : tactic -> tactic list -> tactic +val tclTHENSV : tactic -> tactic array -> tactic +val tclTHENSLASTn : tactic -> tactic -> tactic array -> tactic +val tclTHENLASTn : tactic -> tactic array -> tactic +val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic +val tclTHENFIRSTn : tactic -> tactic array -> tactic +val tclREPEAT : tactic -> tactic +val tclREPEAT_MAIN : tactic -> tactic +val tclFIRST : tactic list -> tactic +val tclSOLVE : tactic list -> tactic +val tclTRY : tactic -> tactic +val tclCOMPLETE : tactic -> tactic +val tclAT_LEAST_ONCE : tactic -> tactic +val tclFAIL : int -> Pp.t -> tactic +val tclFAIL_lazy : int -> Pp.t Lazy.t -> tactic +val tclDO : int -> tactic -> tactic +val tclPROGRESS : tactic -> tactic +val tclSHOWHYPS : tactic -> tactic +val tclTHENTRY : tactic -> tactic -> tactic +val tclMAP : ('a -> tactic) -> 'a list -> tactic + +val tclIFTHENELSE : tactic -> tactic -> tactic -> tactic +val tclIFTHENSELSE : tactic -> tactic list -> tactic -> tactic +val tclIFTHENSVELSE : tactic -> tactic array -> tactic -> tactic +val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic + +(** {6 Tacticals applying to hypotheses } *) + +val onNthHypId : int -> (Id.t -> tactic) -> tactic +val onNthHyp : int -> (constr -> tactic) -> tactic +val onNthDecl : int -> (named_declaration -> tactic) -> tactic +val onLastHypId : (Id.t -> tactic) -> tactic +val onLastHyp : (constr -> tactic) -> tactic +val onLastDecl : (named_declaration -> tactic) -> tactic +val onNLastHypsId : int -> (Id.t list -> tactic) -> tactic +val onNLastHyps : int -> (constr list -> tactic) -> tactic +val onNLastDecls : int -> (named_context -> tactic) -> tactic + +val lastHypId : Goal.goal sigma -> Id.t +val lastHyp : Goal.goal sigma -> constr +val lastDecl : Goal.goal sigma -> named_declaration +val nLastHypsId : int -> Goal.goal sigma -> Id.t list +val nLastHyps : int -> Goal.goal sigma -> constr list +val nLastDecls : int -> Goal.goal sigma -> named_context + +val afterHyp : Id.t -> Goal.goal sigma -> named_context + +val ifOnHyp : (Id.t * types -> bool) -> + (Id.t -> tactic) -> (Id.t -> tactic) -> + Id.t -> tactic + +val onHyps : (Goal.goal sigma -> named_context) -> + (named_context -> tactic) -> tactic + +(** {6 Tacticals applying to goal components } *) + +(** A [clause] denotes occurrences and hypotheses in a + goal; in particular, it can abstractly refer to the set of + hypotheses independently of the effective contents of the current goal *) + +val onAllHyps : (Id.t -> tactic) -> tactic +val onAllHypsAndConcl : (Id.t option -> tactic) -> tactic + +val onClause : (Id.t option -> tactic) -> clause -> tactic +val onClauseLR : (Id.t option -> tactic) -> clause -> tactic + +(** {6 Elimination tacticals. } *) + +type branch_args = private { + ity : pinductive; (** the type we were eliminating on *) + largs : constr list; (** its arguments *) + branchnum : int; (** the branch number *) + pred : constr; (** the predicate we used *) + nassums : int; (** number of assumptions/letin to be introduced *) + branchsign : bool list; (** the signature of the branch. + true=assumption, false=let-in *) + branchnames : intro_patterns} + +type branch_assumptions = private { + ba : branch_args; (** the branch args *) + assums : named_context} (** the list of assumptions introduced *) + +(** [get_and_check_or_and_pattern loc pats branchsign] returns an appropriate + error message if |pats| <> |branchsign|; extends them if no pattern is given + for let-ins in the case of a conjunctive pattern *) +val get_and_check_or_and_pattern : + ?loc:Loc.t -> delayed_open_constr or_and_intro_pattern_expr -> + bool list array -> intro_patterns array + +(** Tolerate "[]" to mean a disjunctive pattern of any length *) +val fix_empty_or_and_pattern : int -> + delayed_open_constr or_and_intro_pattern_expr -> + delayed_open_constr or_and_intro_pattern_expr + +val compute_constructor_signatures : rec_flag:bool -> inductive * 'a -> bool list array + +(** Useful for [as intro_pattern] modifier *) +val compute_induction_names : + bool list array -> or_and_intro_pattern option -> intro_patterns array + +val elimination_sort_of_goal : Goal.goal sigma -> Sorts.family +val elimination_sort_of_hyp : Id.t -> Goal.goal sigma -> Sorts.family +val elimination_sort_of_clause : Id.t option -> Goal.goal sigma -> Sorts.family + +val pf_with_evars : (Goal.goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic +val pf_constr_of_global : GlobRef.t -> (constr -> tactic) -> tactic + +(** Tacticals defined directly in term of Proofview *) + +(** The tacticals in the module [New] are the tactical of Ltac. Their + semantics is an extension of the tacticals in this file for the + multi-goal backtracking tactics. They do not have the same + semantics as the similarly named tacticals in [Proofview]. The + tactical of [Proofview] are used in the definition of the + tacticals of [Tacticals.New], but they are more atomic. In + particular [Tacticals.New.tclORELSE] sees lack of progress as a + failure, whereas [Proofview.tclORELSE] doesn't. Additionally every + tactic which can catch failure ([tclOR], [tclORELSE], [tclTRY], + [tclREPEAt], etc…) are run into each goal independently (failures + and backtracks are localised to a given goal). *) +module New : sig + open Proofview + + (** [catch_failerror e] fails and decreases the level if [e] is an + Ltac error with level more than 0. Otherwise succeeds. *) + val catch_failerror : Util.iexn -> unit tactic + + val tclIDTAC : unit tactic + val tclTHEN : unit tactic -> unit tactic -> unit tactic + (* [tclFAIL n msg] fails with [msg] as an error message at level [n] + (meaning that it will jump over [n] error catching tacticals FROM + THIS MODULE. *) + val tclFAIL : int -> Pp.t -> 'a tactic + + val tclZEROMSG : ?loc:Loc.t -> Pp.t -> 'a tactic + (** Fail with a [User_Error] containing the given message. *) + + val tclOR : unit tactic -> unit tactic -> unit tactic + val tclORD : unit tactic -> (unit -> unit tactic) -> unit tactic + (** Like {!tclOR} but accepts a delayed tactic as a second argument + in the form of a function which will be run only in case of + backtracking. *) + + val tclONCE : unit tactic -> unit tactic + val tclEXACTLY_ONCE : unit tactic -> unit tactic + + val tclIFCATCH : + unit tactic -> + (unit -> unit tactic) -> + (unit -> unit tactic) -> unit tactic + + val tclORELSE0 : unit tactic -> unit tactic -> unit tactic + val tclORELSE : unit tactic -> unit tactic -> unit tactic + + (** [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|] + gls] applies the tactic [tac1] to [gls] then, applies [t1], ..., + [tn] to the first [n] resulting subgoals, [t'1], ..., [t'm] to the + last [m] subgoals and [tac2] to the rest of the subgoals in the + middle. Raises an error if the number of resulting subgoals is + strictly less than [n+m] *) + val tclTHENS3PARTS : unit tactic -> unit tactic array -> unit tactic -> unit tactic array -> unit tactic + val tclTHENSFIRSTn : unit tactic -> unit tactic array -> unit tactic -> unit tactic + val tclTHENFIRSTn : unit tactic -> unit tactic array -> unit tactic + + (** [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls] + and [tac2] to the first resulting subgoal *) + val tclTHENFIRST : unit tactic -> unit tactic -> unit tactic + val tclBINDFIRST : 'a tactic -> ('a -> 'b tactic) -> 'b tactic + val tclTHENLASTn : unit tactic -> unit tactic array -> unit tactic + val tclTHENLAST : unit tactic -> unit tactic -> unit tactic + val tclBINDLAST : 'a tactic -> ('a -> 'b tactic) -> 'b tactic + (* [tclTHENS t l = t <*> tclDISPATCH l] *) + val tclTHENS : unit tactic -> unit tactic list -> unit tactic + (* [tclTHENLIST [t1;…;tn]] is [t1<*>…<*>tn] *) + val tclTHENLIST : unit tactic list -> unit tactic + + (** [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *) + val tclMAP : ('a -> unit tactic) -> 'a list -> unit tactic + + val tclTRY : unit tactic -> unit tactic + val tclTRYb : unit tactic -> bool list tactic + val tclFIRST : unit tactic list -> unit tactic + val tclIFTHENELSE : unit tactic -> unit tactic -> unit tactic -> unit tactic + val tclIFTHENSVELSE : unit tactic -> unit tactic array -> unit tactic -> unit tactic + val tclIFTHENTRYELSEMUST : unit tactic -> unit tactic -> unit tactic + val tclIFTHENFIRSTTRYELSEMUST : unit tactic -> unit tactic -> unit tactic + + val tclDO : int -> unit tactic -> unit tactic + val tclREPEAT : unit tactic -> unit tactic + (* Repeat on the first subgoal (no failure if no more subgoal) *) + val tclREPEAT_MAIN : unit tactic -> unit tactic + val tclCOMPLETE : 'a tactic -> 'a tactic + val tclSOLVE : unit tactic list -> unit tactic + val tclPROGRESS : unit tactic -> unit tactic + val tclSELECT : Goal_select.t -> '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 + + val tclTIMEOUT : int -> unit tactic -> unit tactic + val tclTIME : string option -> 'a tactic -> 'a tactic + + val nLastDecls : Proofview.Goal.t -> int -> named_context + + val ifOnHyp : (Id.t * types -> bool) -> + (Id.t -> unit Proofview.tactic) -> (Id.t -> unit Proofview.tactic) -> + Id.t -> unit Proofview.tactic + + val onNthHypId : int -> (Id.t -> unit tactic) -> unit tactic + val onLastHypId : (Id.t -> unit tactic) -> unit tactic + val onLastHyp : (constr -> unit tactic) -> unit tactic + val onLastDecl : (named_declaration -> unit tactic) -> unit tactic + + val onHyps : (Proofview.Goal.t -> named_context) -> + (named_context -> unit tactic) -> unit tactic + val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic + + val tryAllHyps : (Id.t -> unit tactic) -> unit tactic + val tryAllHypsAndConcl : (Id.t option -> unit tactic) -> unit tactic + val onClause : (Id.t option -> unit tactic) -> clause -> unit tactic + + val elimination_sort_of_goal : Proofview.Goal.t -> Sorts.family + val elimination_sort_of_hyp : Id.t -> Proofview.Goal.t -> Sorts.family + val elimination_sort_of_clause : Id.t option -> Proofview.Goal.t -> Sorts.family + + val elimination_then : + (branch_args -> unit Proofview.tactic) -> + constr -> unit Proofview.tactic + + val case_then_using : + or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) -> + constr option -> inductive * EInstance.t -> constr * types -> unit Proofview.tactic + + val case_nodep_then_using : + or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) -> + constr option -> inductive * EInstance.t -> constr * types -> unit Proofview.tactic + + val elim_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic + val case_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic + + val pf_constr_of_global : GlobRef.t -> constr Proofview.tactic +end diff --git a/tactics/tactics.ml b/tactics/tactics.ml new file mode 100644 index 0000000000..1043c50f00 --- /dev/null +++ b/tactics/tactics.ml @@ -0,0 +1,4967 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Names +open Nameops +open Constr +open Termops +open Environ +open EConstr +open Vars +open Find_subterm +open Namegen +open Declarations +open Inductiveops +open Reductionops +open Globnames +open Evd +open Tacred +open Genredexpr +open Tacmach.New +open Logic +open Clenv +open Refiner +open Tacticals +open Hipattern +open Coqlib +open Evarutil +open Indrec +open Pretype_errors +open Unification +open Locus +open Locusops +open Tactypes +open Proofview.Notations +open Context.Named.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +let inj_with_occurrences e = (AllOccurrences,e) + +let typ_of env sigma c = + let open Retyping in + try get_type_of ~lax:true env sigma c + with RetypeError e -> + user_err (print_retype_error e) + +open Goptions + +let clear_hyp_by_default = ref false + +let use_clear_hyp_by_default () = !clear_hyp_by_default + +let () = + declare_bool_option + { optdepr = false; + optname = "default clearing of hypotheses after use"; + optkey = ["Default";"Clearing";"Used";"Hypotheses"]; + optread = (fun () -> !clear_hyp_by_default) ; + optwrite = (fun b -> clear_hyp_by_default := b) } + +(* Compatibility option useful in developments using apply intensively + in ltac code *) + +let universal_lemma_under_conjunctions = ref false + +let accept_universal_lemma_under_conjunctions () = + !universal_lemma_under_conjunctions + +let () = + declare_bool_option + { optdepr = false; + optname = "trivial unification in tactics applying under conjunctions"; + optkey = ["Universal";"Lemma";"Under";"Conjunction"]; + optread = (fun () -> !universal_lemma_under_conjunctions) ; + optwrite = (fun b -> universal_lemma_under_conjunctions := b) } + +(* The following boolean governs what "intros []" do on examples such + as "forall x:nat*nat, x=x"; if true, it behaves as "intros [? ?]"; + if false, it behaves as "intro H; case H; clear H" for fresh H. + Kept as false for compatibility. + *) + +let bracketing_last_or_and_intro_pattern = ref true + +let use_bracketing_last_or_and_intro_pattern () = + !bracketing_last_or_and_intro_pattern + +let () = + declare_bool_option + { optdepr = false; + optname = "bracketing last or-and introduction pattern"; + optkey = ["Bracketing";"Last";"Introduction";"Pattern"]; + optread = (fun () -> !bracketing_last_or_and_intro_pattern); + optwrite = (fun b -> bracketing_last_or_and_intro_pattern := b) } + +(*********************************************) +(* Tactics *) +(*********************************************) + +(******************************************) +(* Primitive tactics *) +(******************************************) + +(** This tactic creates a partial proof realizing the introduction rule, but + does not check anything. *) +let unsafe_intro env decl b = + Refine.refine ~typecheck:false begin fun sigma -> + let ctx = named_context_val env in + let nctx = push_named_context_val decl ctx in + let inst = List.map (NamedDecl.get_id %> mkVar) (named_context env) in + let ninst = mkRel 1 :: inst in + let nb = subst1 (mkVar (NamedDecl.get_id decl)) b in + let (sigma, ev) = new_evar_instance nctx sigma nb ~principal:true ninst in + (sigma, mkLambda_or_LetIn (NamedDecl.to_rel_decl decl) ev) + end + +let introduction id = + Proofview.Goal.enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + let sigma = Tacmach.New.project gl in + let hyps = named_context_val (Proofview.Goal.env gl) in + let env = Proofview.Goal.env gl in + let () = if mem_named_context_val id hyps then + user_err ~hdr:"Tactics.introduction" + (str "Variable " ++ Id.print id ++ str " is already declared.") + in + let open Context.Named.Declaration in + match EConstr.kind sigma concl with + | Prod (_, t, b) -> unsafe_intro env (LocalAssum (id, t)) b + | LetIn (_, c, t, b) -> unsafe_intro env (LocalDef (id, c, t)) b + | _ -> raise (RefinerError (env, sigma, IntroNeedsProduct)) + end + +let error msg = CErrors.user_err Pp.(str msg) + +let convert_concl ?(check=true) ty k = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let conclty = Proofview.Goal.concl gl in + Refine.refine ~typecheck:false begin fun sigma -> + let sigma = + if check then begin + ignore (Typing.unsafe_type_of env sigma ty); + match Reductionops.infer_conv env sigma ty conclty with + | None -> error "Not convertible." + | Some sigma -> sigma + end else sigma in + let (sigma, x) = Evarutil.new_evar env sigma ~principal:true ty in + let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in + (sigma, ans) + end + end + +let convert_hyp ?(check=true) d = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let ty = Proofview.Goal.concl gl in + let sign = convert_hyp check (named_context_val env) sigma d in + let env = reset_with_named_context sign env in + Refine.refine ~typecheck:false begin fun sigma -> + Evarutil.new_evar env sigma ~principal:true ty + end + end + +let convert_concl_no_check = convert_concl ~check:false +let convert_hyp_no_check = convert_hyp ~check:false + +let convert_gen pb x y = + Proofview.Goal.enter begin fun gl -> + match Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y with + | Some sigma -> Proofview.Unsafe.tclEVARS sigma + | None -> Tacticals.New.tclFAIL 0 (str "Not convertible") + | exception _ -> + (* FIXME: Sometimes an anomaly is raised from conversion *) + Tacticals.New.tclFAIL 0 (str "Not convertible") +end + +let convert x y = convert_gen Reduction.CONV x y +let convert_leq x y = convert_gen Reduction.CUMUL x y + +let clear_in_global_msg = function + | None -> mt () + | Some ref -> str " implicitly in " ++ Printer.pr_global ref + +let clear_dependency_msg env sigma id err inglobal = + let pp = clear_in_global_msg inglobal in + match err with + | Evarutil.OccurHypInSimpleClause None -> + Id.print id ++ str " is used" ++ pp ++ str " in conclusion." + | Evarutil.OccurHypInSimpleClause (Some id') -> + Id.print id ++ strbrk " is used" ++ pp ++ str " in hypothesis " ++ Id.print id' ++ str"." + | Evarutil.EvarTypingBreak ev -> + str "Cannot remove " ++ Id.print id ++ + strbrk " without breaking the typing of " ++ + Printer.pr_existential env sigma ev ++ str"." + | Evarutil.NoCandidatesLeft ev -> + str "Cannot remove " ++ Id.print id ++ str " as it would leave the existential " ++ + Printer.pr_existential_key sigma ev ++ str" without candidates." + +let error_clear_dependency env sigma id err inglobal = + user_err (clear_dependency_msg env sigma id err inglobal) + +let replacing_dependency_msg env sigma id err inglobal = + let pp = clear_in_global_msg inglobal in + match err with + | Evarutil.OccurHypInSimpleClause None -> + str "Cannot change " ++ Id.print id ++ str ", it is used" ++ pp ++ str " in conclusion." + | Evarutil.OccurHypInSimpleClause (Some id') -> + str "Cannot change " ++ Id.print id ++ + strbrk ", it is used" ++ pp ++ str " in hypothesis " ++ Id.print id' ++ str"." + | Evarutil.EvarTypingBreak ev -> + str "Cannot change " ++ Id.print id ++ + strbrk " without breaking the typing of " ++ + Printer.pr_existential env sigma ev ++ str"." + | Evarutil.NoCandidatesLeft ev -> + str "Cannot change " ++ Id.print id ++ str " as it would leave the existential " ++ + Printer.pr_existential_key sigma ev ++ str" without candidates." + +let error_replacing_dependency env sigma id err inglobal = + user_err (replacing_dependency_msg env sigma id err inglobal) + +(* 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_gen fail = function +| [] -> Proofview.tclUNIT () +| ids -> + Proofview.Goal.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 env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let concl = Proofview.Goal.concl gl in + let (sigma, hyps, concl) = + try clear_hyps_in_evi env sigma (named_context_val env) concl ids + with Evarutil.ClearDependencyError (id,err,inglobal) -> fail env sigma id err inglobal + in + let env = reset_with_named_context hyps env in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Refine.refine ~typecheck:false begin fun sigma -> + Evarutil.new_evar env sigma ~principal:true concl + end) + end + +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 = + Proofview.tclEVARMAP >>= fun sigma -> + let check_isvar c = + if not (isVar sigma c) then + error "keep/clear modifiers apply only to hypothesis names." in + let doclear = match clear_flag with + | None -> dft && isVar sigma c + | Some true -> check_isvar c; true + | Some false -> false in + if doclear then clear [destVar sigma c] + else Tacticals.New.tclIDTAC + +(* Moving hypotheses *) +let move_hyp id dest = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let ty = Proofview.Goal.concl gl in + let sign = named_context_val env in + let sign' = move_hyp_in_named_context env sigma id dest sign in + let env = reset_with_named_context sign' env in + Refine.refine ~typecheck:false begin fun sigma -> + Evarutil.new_evar env sigma ~principal:true ty + end + end + +(* Renaming hypotheses *) +let rename_hyp repl = + let fold accu (src, dst) = match accu with + | None -> None + | Some (srcs, dsts) -> + if Id.Set.mem src srcs then None + else if Id.Set.mem dst dsts then None + else + let srcs = Id.Set.add src srcs in + let dsts = Id.Set.add dst dsts in + Some (srcs, dsts) + in + let init = Some (Id.Set.empty, Id.Set.empty) in + let dom = List.fold_left fold init repl in + match dom with + | None -> Tacticals.New.tclZEROMSG (str "Not a one-to-one name mapping") + | Some (src, dst) -> + Proofview.Goal.enter begin fun gl -> + let hyps = Proofview.Goal.hyps gl in + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + (* Check that we do not mess variables *) + 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 + let hyp = Id.Set.choose (Id.Set.diff src vars) in + raise (RefinerError (env, sigma, NoSuchHyp hyp)) + in + let mods = Id.Set.diff vars src in + let () = + try + let elt = Id.Set.choose (Id.Set.inter dst mods) in + CErrors.user_err (Id.print elt ++ str " is already used") + with Not_found -> () + in + (* All is well *) + let make_subst (src, dst) = (src, mkVar dst) in + let subst = List.map make_subst repl in + let subst c = Vars.replace_vars subst c in + let map decl = + 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 = val_of_named_context nhyps in + let instance = List.map (NamedDecl.get_id %> mkVar) hyps in + Refine.refine ~typecheck:false begin fun sigma -> + Evarutil.new_evar_instance nctx sigma nconcl ~principal:true instance + end + end + +(**************************************************************) +(* Fresh names *) +(**************************************************************) + +let fresh_id_in_env avoid id env = + let avoid' = ids_of_named_context_val (named_context_val env) in + let avoid = if Id.Set.is_empty avoid then avoid' else Id.Set.union avoid' avoid in + next_ident_away_in_goal id avoid + +let fresh_id avoid id gl = + fresh_id_in_env avoid id (pf_env gl) + +let new_fresh_id avoid id gl = + fresh_id_in_env avoid id (Proofview.Goal.env gl) + +let id_of_name_with_default id = function + | Anonymous -> id + | Name id -> id + +let default_id_of_sort s = + if Sorts.is_small s then default_small_ident else default_type_ident + +let default_id env sigma decl = + let open Context.Rel.Declaration in + match decl with + | LocalAssum (name,t) -> + let dft = default_id_of_sort (Retyping.get_sort_of env sigma t) in + id_of_name_with_default dft name + | LocalDef (name,b,_) -> id_of_name_using_hdchar env sigma b name + +(* Non primitive introduction tactics are treated by intro_then_gen + There is possibly renaming, with possibly names to avoid and + possibly a move to do after the introduction *) + +type name_flag = + | NamingAvoid of Id.Set.t + | NamingBasedOn of Id.t * Id.Set.t + | NamingMustBe of lident + +let naming_of_name = function + | Anonymous -> NamingAvoid Id.Set.empty + | Name id -> NamingMustBe (CAst.make id) + +let find_name mayrepl decl naming gl = match naming with + | NamingAvoid idl -> + (* this case must be compatible with [find_intro_names] below. *) + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + new_fresh_id idl (default_id env sigma decl) gl + | NamingBasedOn (id,idl) -> new_fresh_id idl id gl + | NamingMustBe {CAst.loc;v=id} -> + (* When name is given, we allow to hide a global name *) + let ids_of_hyps = Tacmach.New.pf_ids_set_of_hyps gl in + if not mayrepl && Id.Set.mem id ids_of_hyps then + user_err ?loc (Id.print id ++ str" is already used."); + id + +(**************************************************************) +(* Computing position of hypotheses for replacing *) +(**************************************************************) + +let get_next_hyp_position env sigma id = + let rec aux = function + | [] -> error_no_such_hypothesis env sigma id + | decl :: right -> + if Id.equal (NamedDecl.get_id decl) id then + match right with decl::_ -> MoveBefore (NamedDecl.get_id decl) | [] -> MoveFirst + else + aux right + in + aux + +let get_previous_hyp_position env sigma id = + let rec aux dest = function + | [] -> error_no_such_hypothesis env sigma id + | decl :: right -> + let hyp = NamedDecl.get_id decl in + if Id.equal hyp id then dest else aux (MoveAfter hyp) right + in + aux MoveLast + +(**************************************************************) +(* Cut rule *) +(**************************************************************) + +let clear_hyps2 env sigma ids sign t cl = + try + let sigma = Evd.clear_metas sigma in + Evarutil.clear_hyps2_in_evi env sigma sign t cl ids + with Evarutil.ClearDependencyError (id,err,inglobal) -> + error_replacing_dependency env sigma id err inglobal + +let internal_cut_gen ?(check=true) dir replace id t = + Proofview.Goal.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 sign = named_context_val env in + let sign',t,concl,sigma = + if replace then + let nexthyp = get_next_hyp_position env sigma id (named_context_of_val sign) in + let sigma,sign',t,concl = clear_hyps2 env sigma (Id.Set.singleton id) sign t concl in + let sign' = insert_decl_in_named_context env sigma (LocalAssum (id,t)) nexthyp sign' in + sign',t,concl,sigma + else + (if check && mem_named_context_val id sign then + user_err (str "Variable " ++ Id.print id ++ str " is already declared."); + push_named_context_val (LocalAssum (id,t)) sign,t,concl,sigma) in + let nf_t = nf_betaiota env sigma t in + Proofview.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (Refine.refine ~typecheck:false begin fun sigma -> + let (sigma,ev,ev') = + if dir then + let (sigma, ev) = Evarutil.new_evar_from_context sign sigma nf_t in + let (sigma, ev') = Evarutil.new_evar_from_context sign' sigma ~principal:true concl in + (sigma,ev,ev') + else + let (sigma, ev') = Evarutil.new_evar_from_context sign' sigma ~principal:true concl in + let (sigma, ev) = Evarutil.new_evar_from_context sign sigma nf_t in + (sigma,ev,ev') in + let term = mkLetIn (Name id, ev, t, EConstr.Vars.subst_var id ev') in + (sigma, term) + end) + end + +let internal_cut ?(check=true) = internal_cut_gen ~check true +let internal_cut_rev ?(check=true) = internal_cut_gen ~check false + +let assert_before_then_gen b naming t tac = + let open Context.Rel.Declaration in + Proofview.Goal.enter begin fun gl -> + let id = find_name b (LocalAssum (Anonymous,t)) naming gl in + Tacticals.New.tclTHENLAST + (internal_cut b id t) + (tac id) + end + +let assert_before_gen b naming t = + assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ()) + +let assert_before na = assert_before_gen false (naming_of_name na) +let assert_before_replacing id = assert_before_gen true (NamingMustBe (CAst.make id)) + +let assert_after_then_gen b naming t tac = + let open Context.Rel.Declaration in + Proofview.Goal.enter begin fun gl -> + let id = find_name b (LocalAssum (Anonymous,t)) naming gl in + Tacticals.New.tclTHENFIRST + (internal_cut_rev b id t) + (tac id) + end + +let assert_after_gen b naming t = + assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ())) + +let assert_after na = assert_after_gen false (naming_of_name na) +let assert_after_replacing id = assert_after_gen true (NamingMustBe (CAst.make id)) + +(**************************************************************) +(* Fixpoints and CoFixpoints *) +(**************************************************************) + +let rec mk_holes env sigma = function +| [] -> (sigma, []) +| arg :: rem -> + let (sigma, arg) = Evarutil.new_evar env sigma arg in + let (sigma, rem) = mk_holes env sigma rem in + (sigma, arg :: rem) + +let rec check_mutind env sigma k cl = match EConstr.kind sigma (strip_outer_cast sigma 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 +| LetIn (na, c1, t, b) -> + let open Context.Rel.Declaration in + check_mutind (push_rel (LocalDef (na, c1, t)) env) sigma k b +| _ -> error "Not enough products." + +(* Refine as a fixpoint *) +let mutual_fix f n rest j = Proofview.Goal.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 (MutInd.equal 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 " ++ Id.print 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 ~typecheck:false begin fun sigma -> + let (sigma, evs) = mk_holes nenv sigma (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 = mkFix ((indxs,0),(funnames,typarray,bodies)) in + (sigma, oterm) + end +end + +let fix id n = mutual_fix id n [] 0 + +let rec check_is_mutcoind env sigma cl = + let b = whd_all env sigma cl in + match EConstr.kind sigma 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 f others j = Proofview.Goal.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 ~typecheck:false begin fun sigma -> + let (ids, types) = List.split all in + let (sigma, evs) = mk_holes nenv sigma 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 = mkCoFix (0, (funnames, typarray, bodies)) in + (sigma, oterm) + end +end + +let cofix id = mutual_cofix id [] 0 + +(**************************************************************) +(* Reduction and conversion tactics *) +(**************************************************************) + +type tactic_reduction = Reductionops.reduction_function +type e_tactic_reduction = Reductionops.e_reduction_function + +let pf_reduce_decl redfun where decl gl = + let open Context.Named.Declaration in + let redfun' c = Tacmach.New.pf_apply redfun gl c in + match decl with + | LocalAssum (id,ty) -> + if where == InHypValueOnly then + user_err (Id.print id ++ str " has no value."); + LocalAssum (id,redfun' ty) + | LocalDef (id,b,ty) -> + let b' = if where != InHypTypeOnly then redfun' b else b in + let ty' = if where != InHypValueOnly then redfun' ty else ty in + LocalDef (id,b',ty') + +(* Possibly equip a reduction with the occurrences mentioned in an + occurrence clause *) + +let error_illegal_clause () = + error "\"at\" clause not supported in presence of an occurrence clause." + +let error_illegal_non_atomic_clause () = + error "\"at\" clause not supported in presence of a non atomic \"in\" clause." + +let error_occurrences_not_unsupported () = + error "Occurrences not supported for this reduction tactic." + +let bind_change_occurrences occs = function + | None -> None + | Some c -> Some (Redexpr.out_with_occurrences (occs,c)) + +let bind_red_expr_occurrences occs nbcl redexp = + let has_at_clause = function + | Unfold l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l + | Pattern l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l + | Simpl (_,Some (occl,_)) -> occl != AllOccurrences + | _ -> false in + if occs == AllOccurrences then + if nbcl > 1 && has_at_clause redexp then + error_illegal_non_atomic_clause () + else + redexp + else + match redexp with + | Unfold (_::_::_) -> + error_illegal_clause () + | Unfold [(occl,c)] -> + if occl != AllOccurrences then + error_illegal_clause () + else + Unfold [(occs,c)] + | Pattern (_::_::_) -> + error_illegal_clause () + | Pattern [(occl,c)] -> + if occl != AllOccurrences then + error_illegal_clause () + else + Pattern [(occs,c)] + | Simpl (f,Some (occl,c)) -> + if occl != AllOccurrences then + error_illegal_clause () + else + Simpl (f,Some (occs,c)) + | CbvVm (Some (occl,c)) -> + if occl != AllOccurrences then + error_illegal_clause () + else + CbvVm (Some (occs,c)) + | CbvNative (Some (occl,c)) -> + if occl != AllOccurrences then + error_illegal_clause () + else + CbvNative (Some (occs,c)) + | Red _ | Hnf | Cbv _ | Lazy _ | Cbn _ + | ExtraRedExpr _ | Fold _ | Simpl (_,None) | CbvVm None | CbvNative None -> + error_occurrences_not_unsupported () + | Unfold [] | Pattern [] -> + assert false + +(* The following two tactics apply an arbitrary + reduction function either to the conclusion or to a + certain hypothesis *) + +let reduct_in_concl (redfun,sty) = + Proofview.Goal.enter begin fun gl -> + convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty + end + +let reduct_in_hyp ?(check=false) redfun (id,where) = + Proofview.Goal.enter begin fun gl -> + convert_hyp ~check (pf_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl) + end + +let revert_cast (redfun,kind as r) = + if kind == DEFAULTcast then (redfun,REVERTcast) else r + +let reduct_option ?(check=false) redfun = function + | Some id -> reduct_in_hyp ~check (fst redfun) id + | None -> reduct_in_concl (revert_cast redfun) + +(** Tactic reduction modulo evars (for universes essentially) *) + +let pf_e_reduce_decl redfun where decl gl = + let open Context.Named.Declaration in + let sigma = Proofview.Goal.sigma gl in + let redfun sigma c = redfun (Tacmach.New.pf_env gl) sigma c in + match decl with + | LocalAssum (id,ty) -> + if where == InHypValueOnly then + user_err (Id.print id ++ str " has no value."); + let (sigma, ty') = redfun sigma ty in + (sigma, LocalAssum (id, ty')) + | LocalDef (id,b,ty) -> + let (sigma, b') = if where != InHypTypeOnly then redfun sigma b else (sigma, b) in + let (sigma, ty') = if where != InHypValueOnly then redfun sigma ty else (sigma, ty) in + (sigma, LocalDef (id, b', ty')) + +let e_reduct_in_concl ~check (redfun, sty) = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let (sigma, c') = redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (convert_concl ~check c' sty) + end + +let e_reduct_in_hyp ?(check=false) redfun (id, where) = + Proofview.Goal.enter begin fun gl -> + let (sigma, decl') = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (convert_hyp ~check decl') + end + +let e_reduct_option ?(check=false) redfun = function + | Some id -> e_reduct_in_hyp ~check (fst redfun) id + | None -> e_reduct_in_concl ~check (revert_cast redfun) + +(** Versions with evars to maintain the unification of universes resulting + from conversions. *) + +let e_change_in_concl (redfun,sty) = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let (sigma, c) = redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.concl gl) in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (convert_concl_no_check c sty) + end + +let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = + let open Context.Named.Declaration in + match decl with + | LocalAssum (id,ty) -> + if where == InHypValueOnly then + user_err (Id.print id ++ str " has no value."); + let (sigma, ty') = redfun false env sigma ty in + (sigma, LocalAssum (id, ty')) + | LocalDef (id,b,ty) -> + let (sigma, b') = + if where != InHypTypeOnly then redfun true env sigma b else (sigma, b) + in + let (sigma, ty') = + if where != InHypValueOnly then redfun false env sigma ty else (sigma, ty) + in + (sigma, LocalDef (id,b',ty')) + +let e_change_in_hyp redfun (id,where) = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let hyp = Tacmach.New.pf_get_hyp id gl in + let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (convert_hyp c) + end + +type change_arg = Ltac_pretype.patvar_map -> env -> evar_map -> evar_map * EConstr.constr + +let make_change_arg c pats env sigma = (sigma, replace_vars (Id.Map.bindings pats) c) + +let check_types env sigma mayneedglobalcheck deep newc origc = + let t1 = Retyping.get_type_of env sigma newc in + if deep then begin + let t2 = Retyping.get_type_of env sigma origc in + let sigma, t2 = Evarsolve.refresh_universes + ~onlyalg:true (Some false) env sigma t2 in + match infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 with + | None -> + if + isSort sigma (whd_all env sigma t1) && + isSort sigma (whd_all env sigma t2) + then (mayneedglobalcheck := true; sigma) + else + user_err ~hdr:"convert-check-hyp" (str "Types are incompatible.") + | Some sigma -> sigma + end + else + if not (isSort sigma (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 *) +let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = + let (sigma, t') = t env sigma in + let sigma = check_types env sigma mayneedglobalcheck deep t' c in + match infer_conv ~pb:cv_pb env sigma t' c with + | None -> user_err ~hdr:"convert-check-hyp" (str "Not convertible."); + | Some sigma -> (sigma, t') + +(* Use cumulativity only if changing the conclusion not a subterm *) +let change_on_subterm cv_pb deep t where env sigma c = + let mayneedglobalcheck = ref false in + let (sigma, c) = match where with + | None -> change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c + | Some occl -> + e_contextually false occl + (fun subst -> + change_and_check Reduction.CONV mayneedglobalcheck true (t subst)) + env sigma c in + if !mayneedglobalcheck then + begin + try ignore (Typing.unsafe_type_of env sigma c) + with e when catchable_exception e -> + error "Replacement would lead to an ill-typed term." + end; + (sigma, c) + +let change_in_concl occl t = + e_change_in_concl ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast) + +let change_in_hyp occl t id = + e_change_in_hyp (fun x -> change_on_subterm Reduction.CONV x t occl) id + +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 = + Proofview.Goal.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 + end + +let change_concl t = + change_in_concl None (make_change_arg t) + +(* Pour usage interne (le niveau User est pris en compte par reduce) *) +let red_in_concl = reduct_in_concl (red_product,REVERTcast) +let red_in_hyp = reduct_in_hyp red_product +let red_option = reduct_option (red_product,REVERTcast) +let hnf_in_concl = reduct_in_concl (hnf_constr,REVERTcast) +let hnf_in_hyp = reduct_in_hyp hnf_constr +let hnf_option = reduct_option (hnf_constr,REVERTcast) +let simpl_in_concl = reduct_in_concl (simpl,REVERTcast) +let simpl_in_hyp = reduct_in_hyp simpl +let simpl_option = reduct_option (simpl,REVERTcast) +let normalise_in_concl = reduct_in_concl (compute,REVERTcast) +let normalise_in_hyp = reduct_in_hyp compute +let normalise_option = reduct_option (compute,REVERTcast) +let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) +let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast) +let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) +let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) +let pattern_option l = e_reduct_option (pattern_occs l,DEFAULTcast) + +(* The main reduction function *) + +let reduction_clause redexp cl = + let nbcl = List.length cl in + List.map (function + | OnHyp (id,occs,where) -> + (Some (id,where), bind_red_expr_occurrences occs nbcl redexp) + | OnConcl occs -> + (None, bind_red_expr_occurrences occs nbcl redexp)) cl + +let reduce redexp cl = + let trace env sigma = + let open Printer in + let pr = (pr_econstr_env, pr_leconstr_env, pr_evaluable_reference, pr_constr_pattern_env) in + Pp.(hov 2 (Ppred.pr_red_expr_env env sigma pr str redexp)) + in + Proofview.Trace.name_tactic trace begin + Proofview.Goal.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 check = match redexp with Fold _ | Pattern _ -> true | _ -> false in + Tacticals.New.tclMAP (fun (where,redexp) -> + e_reduct_option ~check + (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] + | _ -> user_err ~hdr:"unfold_constr" (str "Cannot unfold a non-constant.") + +(*******************************************) +(* Introduction tactics *) +(*******************************************) + +(* Returns the names that would be created by intros, without doing + intros. This function is supposed to be compatible with an + iteration of [find_name] above. As [default_id] checks the sort of + the type to build hyp names, we maintain an environment to be able + to type dependent hyps. *) +let find_intro_names ctxt gl = + let _, res, _ = List.fold_right + (fun decl acc -> + let env,idl,avoid = acc in + let name = fresh_id avoid (default_id env gl.sigma decl) gl in + let newenv = push_rel decl env in + (newenv, name :: idl, Id.Set.add name avoid)) + ctxt (pf_env gl, [], Id.Set.empty) in + List.rev res + +let build_intro_tac id dest tac = match dest with + | MoveLast -> Tacticals.New.tclTHEN (introduction id) (tac id) + | dest -> Tacticals.New.tclTHENLIST + [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 begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in + let concl = Proofview.Goal.concl gl in + match EConstr.kind sigma concl with + | Prod (name,t,u) when not dep_flag || not (noccurn sigma 1 u) -> + let name = find_name false (LocalAssum (name,t)) name_flag gl in + build_intro_tac name move_flag tac + | LetIn (name,b,t,u) when not dep_flag || not (noccurn sigma 1 u) -> + let name = find_name false (LocalDef (name,b,t)) name_flag gl in + build_intro_tac name move_flag tac + | Evar ev when force_flag -> + let sigma, t = Evardefine.define_evar_as_product sigma ev in + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (intro_then_gen name_flag move_flag force_flag dep_flag tac) + | _ -> + begin if not force_flag then Proofview.tclZERO (RefinerError (env, sigma, IntroNeedsProduct)) + (* Note: red_in_concl includes betaiotazeta and this was like *) + (* this since at least V6.3 (a pity *) + (* that intro do betaiotazeta only when reduction is needed; and *) + (* probably also a pity that intro does zeta *) + else Proofview.tclUNIT () + end <*> + Proofview.tclORELSE + (Tacticals.New.tclTHEN hnf_in_concl + (intro_then_gen name_flag move_flag false dep_flag tac)) + begin function (e, info) -> match e with + | RefinerError (env, sigma, IntroNeedsProduct) -> + Tacticals.New.tclZEROMSG (str "No product even after head-reduction.") + | e -> Proofview.tclZERO ~info e + end + end + +let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ()) +let intro_mustbe_force id = intro_gen (NamingMustBe (CAst.make id)) MoveLast true false +let intro_using id = intro_gen (NamingBasedOn (id, Id.Set.empty)) MoveLast false false + +let intro_then = intro_then_gen (NamingAvoid Id.Set.empty) MoveLast false false +let intro = intro_gen (NamingAvoid Id.Set.empty) MoveLast false false +let introf = intro_gen (NamingAvoid Id.Set.empty) MoveLast true false +let intro_avoiding l = intro_gen (NamingAvoid l) MoveLast false false + +let intro_move_avoid idopt avoid hto = match idopt with + | None -> intro_gen (NamingAvoid avoid) hto true false + | Some id -> intro_gen (NamingMustBe (CAst.make id)) hto true false + +let intro_move idopt hto = intro_move_avoid idopt Id.Set.empty hto + +(**** Multiple introduction tactics ****) + +let rec intros_using = function + | [] -> Proofview.tclUNIT() + | str::l -> Tacticals.New.tclTHEN (intro_using str) (intros_using l) + +let intros = Tacticals.New.tclREPEAT intro + +let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = + let rec aux n ids = + (* Note: we always use the bound when there is one for "*" and "**" *) + if (match bound with None -> true | Some (_,p) -> n < p) then + Proofview.tclORELSE + begin + intro_then_gen name_flag move_flag false dep_flag + (fun id -> aux (n+1) (id::ids)) + end + begin function (e, info) -> match e with + | RefinerError (env, sigma, IntroNeedsProduct) -> + tac ids + | e -> Proofview.tclZERO ~info e + end + else + tac ids + in + aux n [] + +let intro_replacing id = + Proofview.Goal.enter begin fun gl -> + let env, sigma = Proofview.Goal.(env gl, sigma gl) in + let hyps = Proofview.Goal.hyps gl in + let next_hyp = get_next_hyp_position env sigma id hyps in + Tacticals.New.tclTHENLIST [ + clear_for_replacing [id]; + introduction id; + move_hyp id next_hyp; + ] + end + +(* We have e.g. [x, y, y', x', y'' |- forall y y' y'', G] and want to + reintroduce y, y,' y''. Note that we have to clear y, y' and y'' + before introducing y because y' or y'' can e.g. depend on old y. *) + +(* This version assumes that replacement is actually possible *) +(* (ids given in the introduction order) *) +(* We keep a sub-optimality in cleaing for compatibility with *) +(* the behavior of inversion *) +let intros_possibly_replacing ids = + let suboptimal = true in + Proofview.Goal.enter begin fun gl -> + let env, sigma = Proofview.Goal.(env gl, sigma gl) in + let hyps = Proofview.Goal.hyps gl in + let posl = List.map (fun id -> (id, get_next_hyp_position env sigma id hyps)) ids in + Tacticals.New.tclTHEN + (Tacticals.New.tclMAP (fun 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)) + posl) + end + +(* This version assumes that replacement is actually possible *) +let intros_replacing ids = + Proofview.Goal.enter begin fun gl -> + let hyps = Proofview.Goal.hyps gl in + let env, sigma = Proofview.Goal.(env gl, sigma gl) in + let posl = List.map (fun id -> (id, get_next_hyp_position env sigma id hyps)) ids in + Tacticals.New.tclTHEN + (clear_for_replacing ids) + (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl) + end + +(* The standard for implementing Automatic Introduction *) +let auto_intros_tac ids = + let fold used = function + | Name id -> Id.Set.add id used + | Anonymous -> used + in + let avoid = NamingAvoid (List.fold_left fold Id.Set.empty ids) in + let naming = function + | Name id -> NamingMustBe CAst.(make id) + | Anonymous -> avoid + in + Tacticals.New.tclMAP (fun name -> intro_gen (naming name) MoveLast true false) (List.rev ids) + +(* User-level introduction tactics *) + +let lookup_hypothesis_as_renamed env sigma ccl = function + | AnonHyp n -> Detyping.lookup_index_as_renamed env sigma ccl n + | NamedHyp id -> Detyping.lookup_name_as_displayed env sigma ccl id + +let lookup_hypothesis_as_renamed_gen red h gl = + let env = Proofview.Goal.env gl in + let rec aux ccl = + match lookup_hypothesis_as_renamed env (Tacmach.New.project gl) ccl h with + | None when red -> + let (redfun, _) = Redexpr.reduction_of_red_expr env (Red true) in + let (_, c) = redfun env (Proofview.Goal.sigma gl) ccl in + aux c + | x -> x + in + try aux (Proofview.Goal.concl gl) + with Redelimination -> None + +let is_quantified_hypothesis id gl = + match lookup_hypothesis_as_renamed_gen false (NamedHyp id) gl with + | Some _ -> true + | None -> false + +let msg_quantified_hypothesis = function + | NamedHyp id -> + str "quantified hypothesis named " ++ Id.print id + | AnonHyp n -> + pr_nth n ++ + str " non dependent hypothesis" + +let warn_deprecated_intros_until_0 = + CWarnings.create ~name:"deprecated-intros-until-0" ~category:"tactics" + (fun () -> + strbrk"\"intros until 0\" is deprecated, use \"intros *\"; instead of \"induction 0\" and \"destruct 0\" use explicitly a name.\"") + +let depth_of_quantified_hypothesis red h gl = + if h = AnonHyp 0 then warn_deprecated_intros_until_0 (); + match lookup_hypothesis_as_renamed_gen red h gl with + | Some depth -> depth + | None -> + 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 ()) ++ + str".") + +let intros_until_gen red h = + Proofview.Goal.enter begin fun gl -> + let n = depth_of_quantified_hypothesis red h gl in + Tacticals.New.tclDO n (if red then introf else intro) + end + +let intros_until_id id = intros_until_gen false (NamedHyp id) +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 = + Proofview.Goal.enter begin fun gl -> + let _ = Tacmach.New.pf_get_hyp id gl in + Proofview.tclUNIT () + end + +let try_intros_until_id_check 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) + | AnonHyp n -> Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHypId tac) + +let rec intros_move = function + | [] -> Proofview.tclUNIT () + | (hyp,destopt) :: rest -> + Tacticals.New.tclTHEN (intro_gen (NamingMustBe (CAst.make hyp)) destopt false false) + (intros_move rest) + +(* 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.fail_evar = not with_evar; + Pretyping.expand_evars = true } + +type evars_flag = bool (* true = pose evars false = fail on evars *) +type rec_flag = bool (* true = recursive false = not recursive *) +type advanced_flag = bool (* true = advanced false = basic *) +type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) + +type 'a core_destruction_arg = + | ElimOnConstr of 'a + | ElimOnIdent of lident + | ElimOnAnonHyp of int + +type 'a destruction_arg = + clear_flag * 'a core_destruction_arg + +let onOpenInductionArg env sigma tac = function + | clear_flag,ElimOnConstr f -> + let (sigma', cbl) = f env sigma in + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARS sigma') + (tac clear_flag (sigma,cbl)) + | clear_flag,ElimOnAnonHyp n -> + Tacticals.New.tclTHEN + (intros_until_n n) + (Tacticals.New.onLastHyp + (fun c -> + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + tac clear_flag (sigma,(c,NoBindings)) + end)) + | clear_flag,ElimOnIdent {CAst.v=id} -> + (* A quantified hypothesis *) + Tacticals.New.tclTHEN + (try_intros_until_id_check id) + (Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + tac clear_flag (sigma,(mkVar id,NoBindings)) + end) + +let onInductionArg tac = function + | clear_flag,ElimOnConstr cbl -> + tac clear_flag cbl + | clear_flag,ElimOnAnonHyp n -> + Tacticals.New.tclTHEN + (intros_until_n n) + (Tacticals.New.onLastHyp (fun c -> tac clear_flag (c,NoBindings))) + | clear_flag,ElimOnIdent {CAst.v=id} -> + (* A quantified hypothesis *) + Tacticals.New.tclTHEN + (try_intros_until_id_check id) + (tac clear_flag (mkVar id,NoBindings)) + +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 (sigma', (c, lbind)) = f env sigma in + let flags = tactic_infer_flags with_evars in + let (sigma', c) = finish_evar_resolution ~flags env sigma' (sigma,c) in + (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) *) +(****************************************) + +let normalize_cut = false + +let cut c = + Proofview.Goal.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 is_sort = + try + (* Backward compat: ensure that [c] is well-typed. *) + let typ = Typing.unsafe_type_of env sigma c in + let typ = whd_all env sigma typ in + match EConstr.kind sigma typ with + | Sort _ -> true + | _ -> false + with e when Pretype_errors.precatchable_exception e -> false + in + if is_sort then + let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_set_of_hyps gl) in + (* Backward compat: normalize [c]. *) + let c = if normalize_cut then local_strong whd_betaiota sigma c else c in + Refine.refine ~typecheck:false begin fun h -> + let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in + let (h, x) = Evarutil.new_evar env h c in + let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in + (h, f) + end + else + Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") + end + +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 user_err (str "Cannot find an instance for " ++ Id.print id ++ str".") + +let check_unresolved_evars_of_metas sigma clenv = + (* This checks that Metas turned into Evars by *) + (* Refiner.pose_all_metas_as_evars are resolved *) + List.iter (fun (mv,b) -> match b with + | Clval (_,(c,_),_) -> + (match Constr.kind (EConstr.Unsafe.to_constr c.rebus) with + | Evar (evk,_) when Evd.is_undefined clenv.evd evk + && not (Evd.mem sigma evk) -> + error_uninstantiated_metas (mkMeta mv) clenv + | _ -> ()) + | _ -> ()) + (meta_list clenv.evd) + +let do_replace id = function + | NamingMustBe {CAst.v=id'} when Option.equal Id.equal id (Some id') -> true + | _ -> false + +(* For a clenv expressing some lemma [C[?1:T1,...,?n:Tn] : P] and some + goal [G], [clenv_refine_in] returns [n+1] subgoals, the [n] last + ones (resp [n] first ones if [sidecond_first] is [true]) being the + [Ti] and the first one (resp last one) being [G] whose hypothesis + [id] is replaced by P using the proof given by [tac] *) + +let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) + targetid id sigma0 clenv tac = + let clenv = Clenvtac.clenv_pose_dependent_evars ~with_evars clenv in + let clenv = + if with_classes then + { clenv with evd = Typeclasses.resolve_typeclasses + ~fail:(not with_evars) clenv.env clenv.evd } + else clenv + in + let new_hyp_typ = clenv_type clenv in + if not with_evars then check_unresolved_evars_of_metas sigma0 clenv; + if not with_evars && occur_meta clenv.evd new_hyp_typ then + error_uninstantiated_metas new_hyp_typ clenv; + let new_hyp_prf = clenv_value clenv in + let exact_tac = Proofview.V82.tactic (Refiner.refiner ~check:false EConstr.Unsafe.(to_constr new_hyp_prf)) in + let naming = NamingMustBe (CAst.make targetid) in + let with_clear = do_replace (Some id) naming in + Tacticals.New.tclTHEN + (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 + else + Tacticals.New.tclTHENLAST + (assert_after_then_gen with_clear naming new_hyp_typ tac) exact_tac) + +(********************************************) +(* Elimination tactics *) +(********************************************) + +let last_arg sigma c = match EConstr.kind sigma c with + | App (f,cl) -> + Array.last cl + | _ -> anomaly (Pp.str "last_arg.") + +let nth_arg sigma i c = + if Int.equal i (-1) then last_arg sigma c else + match EConstr.kind sigma c with + | App (f,cl) -> cl.(i) + | _ -> anomaly (Pp.str "nth_arg.") + +let index_of_ind_arg sigma t = + let rec aux i j t = match EConstr.kind sigma t with + | Prod (_,t,u) -> + (* heuristic *) + if isInd sigma (fst (decompose_app sigma t)) then aux (Some j) (j+1) u + else aux i (j+1) u + | _ -> match i with + | Some i -> i + | None -> error "Could not find inductive argument of elimination scheme." + in aux None 0 t + +let rec contract_letin_in_lam_header sigma c = + match EConstr.kind sigma c with + | Lambda (x,t,c) -> mkLambda (x,t,contract_letin_in_lam_header sigma c) + | LetIn (x,b,t,c) -> contract_letin_in_lam_header sigma (subst1 b c) + | _ -> c + +let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) + rename i (elim, elimty, bindings) indclause = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let elim = contract_letin_in_lam_header sigma elim in + let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in + let indmv = + (match EConstr.kind sigma (nth_arg sigma i elimclause.templval.rebus) with + | Meta mv -> mv + | _ -> 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 + Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags + end + +(* + * Elimination tactic with bindings and using an arbitrary + * elimination constant called elimc. This constant should end + * with a clause (x:I)(P .. ), where P is a bound variable. + * The term c is of type t, which is a product ending with a type + * matching I, lbindc are the expected terms for c arguments + *) + +type eliminator = { + elimindex : int option; (* None = find it automatically *) + elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *) + elimbody : EConstr.constr with_bindings +} + +let general_elim_clause_gen elimtac indclause elim = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let (elimc,lbindelimc) = elim.elimbody in + let elimt = Retyping.get_type_of env sigma elimc in + let i = + match elim.elimindex with None -> index_of_ind_arg sigma elimt | Some i -> i in + elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause + end + +let general_elim with_evars clear_flag (c, lbindc) elim = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let ct = Retyping.get_type_of env sigma c in + 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) + end + +(* Case analysis tactics *) + +let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + let t = Retyping.get_type_of env sigma c in + let (mind,_) = reduce_to_quantified_ind env sigma t in + let sort = Tacticals.New.elimination_sort_of_goal gl in + let mind = on_snd (fun u -> EInstance.kind sigma u) mind in + let (sigma, elim) = + if dependent sigma c concl then + build_case_analysis_scheme env sigma mind true sort + else + build_case_analysis_scheme_default env sigma mind sort in + let elim = EConstr.of_constr elim in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (general_elim with_evars clear_flag (c,lbindc) + {elimindex = None; elimbody = (elim,NoBindings); + elimrename = Some (false, constructors_nrealdecls (fst mind))}) + end + +let general_case_analysis with_evars clear_flag (c,lbindc as cx) = + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma c with + | Var id when lbindc == NoBindings -> + Tacticals.New.tclTHEN (try_intros_until_id_check id) + (general_case_analysis_in_context with_evars clear_flag 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. *) + +exception IsNonrec + +let is_nonrec mind = (Global.lookup_mind (fst mind)).mind_finite == Declarations.BiFinite + +let find_ind_eliminator ind s gl = + let gr = lookup_eliminator ind s in + Tacmach.New.pf_apply Evd.fresh_global gl gr + +let find_eliminator c gl = + let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_unsafe_type_of gl c) in + if is_nonrec ind then raise IsNonrec; + let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in + evd, {elimindex = None; elimbody = (c,NoBindings); + elimrename = Some (true, constructors_nrealdecls ind)} + +let default_elim with_evars clear_flag (c,_ as cx) = + Proofview.tclORELSE + (Proofview.Goal.enter begin fun gl -> + let sigma, elim = find_eliminator c gl in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (general_elim with_evars clear_flag cx elim) + end) + begin function (e, info) -> match e with + | IsNonrec -> + (* For records, induction principles aren't there by default + anymore. Instead, we do a case analysis. *) + general_case_analysis with_evars clear_flag cx + | e -> Proofview.tclZERO ~info e + end + +let elim_in_context with_evars clear_flag c = function + | Some elim -> + general_elim with_evars clear_flag c + {elimindex = Some (-1); elimbody = elim; elimrename = None} + | None -> default_elim with_evars clear_flag c + +let elim with_evars clear_flag (c,lbindc as cx) elim = + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma c with + | Var id when lbindc == NoBindings -> + Tacticals.New.tclTHEN (try_intros_until_id_check id) + (elim_in_context with_evars clear_flag cx elim) + | _ -> + elim_in_context with_evars clear_flag cx elim + +(* The simplest elimination tactic, with no substitutions at all. *) + +let simplest_elim c = default_elim false None (c,NoBindings) + +(* Elimination in hypothesis *) +(* Typically, elimclause := (eq_ind ?x ?P ?H ?y ?Heq : ?P ?y) + indclause : forall ..., hyps -> a=b (to take place of ?Heq) + id : phi(a) (to take place of ?H) + and the result is to overwrite id with the proof of phi(b) + + but this generalizes to any elimination scheme with one constructor + (e.g. it could replace id:A->B->C by id:C, knowing A/\B) +*) + +let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = + (* The evarmap of elimclause is assumed to be an extension of hypclause, so + we do not need to merge the universes coming from hypclause. *) + try clenv_fchain ~with_univs:false ~flags mv elimclause hypclause + with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> + (* Set the hypothesis name in the message *) + raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) + +let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) + id rename i (elim, elimty, bindings) indclause = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let elim = contract_letin_in_lam_header sigma elim in + let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in + let indmv = destMeta sigma (nth_arg sigma i elimclause.templval.rebus) in + let hypmv = + match List.remove Int.equal indmv (clenv_independent elimclause) with + | [a] -> a + | _ -> 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 + let hyp_typ = Retyping.get_type_of env sigma hyp in + let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in + let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in + let new_hyp_typ = clenv_type elimclause'' in + if EConstr.eq_constr sigma hyp_typ new_hyp_typ then + user_err ~hdr:"general_rewrite_in" + (str "Nothing to rewrite in " ++ Id.print id ++ str"."); + clenv_refine_in with_evars id id sigma elimclause'' + (fun id -> Proofview.tclUNIT ()) + end + +let general_elim_clause with_evars flags id c e = + let elim = match id with + | None -> elimination_clause_scheme with_evars ~with_classes:true ~flags + | Some id -> elimination_in_clause_scheme with_evars ~flags id + in + general_elim_clause_gen elim c e + +(* Apply a tactic below the products of the conclusion of a lemma *) + +type conjunction_status = + | DefinedRecord of Constant.t option list + | NotADefinedRecordUseScheme of constr + +let make_projection env sigma params cstr sign elim i n c u = + let open Context.Rel.Declaration in + let elim = match elim with + | NotADefinedRecordUseScheme elim -> + (* bugs: goes from right to left when i increases! *) + let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cstr.cs_args in + let decl = List.nth cs_args i 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 cs_args in + if + (* excludes dependent projection types *) + noccur_between sigma 1 (n-i-1) t + (* to avoid surprising unifications, excludes flexible + projection types or lambda which will be instantiated by Meta/Evar *) + && not (isEvar sigma (fst (whd_betaiota_stack sigma t))) + && (accept_universal_lemma_under_conjunctions () || not (isRel sigma t)) + then + let t = lift (i+1-n) t in + let abselim = beta_applist sigma (elim, params@[t;branch]) in + let args = Context.Rel.to_extended_vect mkRel 0 sign in + let c = beta_applist sigma (abselim, [mkApp (c, args)]) in + Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) + else + None + | DefinedRecord l -> + (* goes from left to right when i increases! *) + match List.nth l i with + | Some proj -> + let args = Context.Rel.to_extended_vect mkRel 0 sign in + let proj = + match Recordops.find_primitive_projection proj with + | Some proj -> + mkProj (Projection.make proj false, mkApp (c, args)) + | None -> + mkApp (mkConstU (proj,u), Array.append (Array.of_list params) + [|mkApp (c, args)|]) + in + let app = it_mkLambda_or_LetIn proj sign in + let t = Retyping.get_type_of env sigma app in + Some (app, t) + | None -> None + in elim + +let descend_in_conjunctions avoid tac (err, info) c = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + try + let t = Retyping.get_type_of env sigma c in + let ((ind,u),t) = reduce_to_quantified_ind env sigma t in + let sign,ccl = EConstr.decompose_prod_assum sigma t in + match match_with_tuple sigma ccl with + | Some (_,_,isrec) -> + let n = (constructors_nrealargs ind).(0) in + let sort = Tacticals.New.elimination_sort_of_goal gl in + let IndType (indf,_) = find_rectype env sigma ccl in + let (_,inst), params = dest_ind_family indf in + let params = List.map EConstr.of_constr params in + let cstr = (get_constructors env indf).(0) in + let elim = + try DefinedRecord (Recordops.lookup_projections ind) + with Not_found -> + let u = EInstance.kind sigma u in + let (_, elim) = build_case_analysis_scheme env sigma (ind,u) false sort in + let elim = EConstr.of_constr elim in + NotADefinedRecordUseScheme elim in + Tacticals.New.tclORELSE0 + (Tacticals.New.tclFIRST + (List.init n (fun i -> + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + match make_projection env sigma params cstr sign elim i n c u with + | None -> Tacticals.New.tclFAIL 0 (mt()) + | Some (p,pt) -> + Tacticals.New.tclTHENS + (assert_before_gen false (NamingAvoid avoid) pt) + [Proofview.V82.tactic (refiner ~check:true EConstr.Unsafe.(to_constr p)); + (* Might be ill-typed due to forbidden elimination. *) + Tacticals.New.onLastHypId (tac (not isrec))] + end))) + (Proofview.tclZERO ~info err) + | None -> Proofview.tclZERO ~info err + with RefinerError _|UserError _ -> Proofview.tclZERO ~info err + end + +(****************************************************) +(* Resolution tactics *) +(****************************************************) + +let tclORELSEOPT t k = + Proofview.tclORELSE t + (fun e -> match k e with + | None -> + let (e, info) = e in + Proofview.tclZERO ~info e + | Some tac -> tac) + +let general_apply ?(respect_opaque=false) with_delta with_destruct with_evars + clear_flag {CAst.loc;v=(c,lbind : EConstr.constr with_bindings)} = + Proofview.Goal.enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + let sigma = Tacmach.New.project gl in + (* The actual type of the theorem. It will be matched against the + goal. If this fails, then the head constant will be unfolded step by + step. *) + let concl_nprod = nb_prod_modulo_zeta sigma concl in + let rec try_main_apply with_destruct c = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let ts = + if respect_opaque then Conv_oracle.get_transp_state (oracle env) + else TransparentState.full + in + let flags = + if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in + let thm_ty0 = nf_betaiota env sigma (Retyping.get_type_of env sigma c) in + let try_apply thm_ty nprod = + try + let n = nb_prod_modulo_zeta sigma thm_ty - nprod in + if n<0 then error "Applied theorem does not have enough premises."; + let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in + Clenvtac.res_pf clause ~with_evars ~flags + with exn when catchable_exception exn -> + Proofview.tclZERO exn + in + let rec try_red_apply thm_ty (exn0, info) = + try + (* Try to head-reduce the conclusion of the theorem *) + let red_thm = try_red_product env sigma thm_ty in + tclORELSEOPT + (try_apply red_thm concl_nprod) + (function (e, info) -> match e with + | PretypeError _|RefinerError _|UserError _|Failure _ -> + Some (try_red_apply red_thm (exn0, info)) + | _ -> None) + with Redelimination -> + (* Last chance: if the head is a variable, apply may try + second order unification *) + let info = Option.cata (fun loc -> Loc.add_loc info loc) info loc in + let tac = + if with_destruct then + descend_in_conjunctions Id.Set.empty + (fun b id -> + Tacticals.New.tclTHEN + (try_main_apply b (mkVar id)) + (clear [id])) + (exn0, info) c + else + Proofview.tclZERO ~info exn0 in + if not (Int.equal concl_nprod 0) then + tclORELSEOPT + (try_apply thm_ty 0) + (function (e, info) -> match e with + | PretypeError _|RefinerError _|UserError _|Failure _-> + Some tac + | _ -> None) + else + tac + in + tclORELSEOPT + (try_apply thm_ty0 concl_nprod) + (function (e, info) -> match e with + | PretypeError _|RefinerError _|UserError _|Failure _ -> + Some (try_red_apply thm_ty0 (e, info)) + | _ -> None) + end + in + Tacticals.New.tclTHEN + (try_main_apply with_destruct c) + (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c) + end + +let rec apply_with_bindings_gen b e = function + | [] -> Proofview.tclUNIT () + | [k,cb] -> general_apply b b e k cb + | (k,cb)::cbl -> + Tacticals.New.tclTHENLAST + (general_apply b b e k cb) + (apply_with_bindings_gen b e cbl) + +let apply_with_delayed_bindings_gen b e l = + let one k {CAst.loc;v=f} = + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in + let (sigma, cb) = f env sigma in + Tacticals.New.tclWITHHOLES e + (general_apply ~respect_opaque:(not b) b b e k CAst.(make ?loc cb)) sigma + end + in + let rec aux = function + | [] -> Proofview.tclUNIT () + | [k,f] -> one k f + | (k,f)::cbl -> + Tacticals.New.tclTHENLAST + (one k f) (aux cbl) + in aux l + +let apply_with_bindings cb = apply_with_bindings_gen false false [None,(CAst.make cb)] + +let eapply_with_bindings cb = apply_with_bindings_gen false true [None,(CAst.make cb)] + +let apply c = apply_with_bindings_gen false false [None,(CAst.make (c,NoBindings))] + +let eapply c = apply_with_bindings_gen false true [None,(CAst.make (c,NoBindings))] + +let apply_list = function + | c::l -> apply_with_bindings (c,ImplicitBindings l) + | _ -> assert false + +(* [apply_in hyp c] replaces + + hyp : forall y1, ti -> t hyp : rho(u) + ======================== with ============ and the ======= + goal goal rho(ti) + + assuming that [c] has type [forall x1..xn -> t' -> u] for some [t] + unifiable with [t'] with unifier [rho] +*) + +let find_matching_clause unifier clause = + let rec find clause = + try unifier clause + with e when catchable_exception e -> + try find (clenv_push_prod clause) + with NotExtensibleClause -> failwith "Cannot apply" + in find clause + +exception UnableToApply + +let progress_with_clause flags innerclause clause = + let ordered_metas = List.rev (clenv_independent clause) in + if List.is_empty ordered_metas then raise UnableToApply; + let f mv = + try Some (find_matching_clause (clenv_fchain ~with_univs:false mv ~flags clause) innerclause) + with Failure _ -> None + in + try List.find_map f ordered_metas + with Not_found -> raise UnableToApply + +let explain_unable_to_apply_lemma ?loc env sigma thm innerclause = + user_err ?loc (hov 0 + (Pp.str "Unable to apply lemma of type" ++ brk(1,1) ++ + Pp.quote (Printer.pr_leconstr_env env sigma thm) ++ spc() ++ + str "on hypothesis of type" ++ brk(1,1) ++ + Pp.quote (Printer.pr_leconstr_env innerclause.env innerclause.evd (clenv_type innerclause)) ++ + str ".")) + +let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = + let thm = nf_betaiota env sigma (Retyping.get_type_of env sigma d) in + let rec aux clause = + try progress_with_clause flags innerclause clause + with e when CErrors.noncritical e -> + let e' = CErrors.push e in + try aux (clenv_push_prod clause) + with NotExtensibleClause -> + match e with + | UnableToApply -> explain_unable_to_apply_lemma ?loc env sigma thm innerclause + | _ -> iraise e' + in + aux (make_clenv_binding env sigma (d,thm) lbind) + +let apply_in_once ?(respect_opaque = false) sidecond_first with_delta + with_destruct with_evars naming id (clear_flag,{ CAst.loc; v= d,lbind}) tac = + let open Context.Rel.Declaration in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let t' = Tacmach.New.pf_get_hyp_typ id gl in + let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in + let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in + let rec aux idstoclear with_destruct c = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let ts = + if respect_opaque then Conv_oracle.get_transp_state (oracle env) + else TransparentState.full + in + let flags = + if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in + try + let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in + clenv_refine_in ~sidecond_first with_evars targetid id sigma clause + (fun id -> + Tacticals.New.tclTHENLIST [ + apply_clear_request clear_flag false c; + clear idstoclear; + tac id + ]) + with e when with_destruct && CErrors.noncritical e -> + let (e, info) = CErrors.push e in + (descend_in_conjunctions (Id.Set.singleton targetid) + (fun b id -> aux (id::idstoclear) b (mkVar id)) + (e, info) c) + end + in + aux [] with_destruct d + end + +let apply_in_delayed_once ?(respect_opaque = false) sidecond_first with_delta + with_destruct with_evars naming id (clear_flag,{CAst.loc;v=f}) tac = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let (sigma, c) = f env sigma in + Tacticals.New.tclWITHHOLES with_evars + (apply_in_once ~respect_opaque sidecond_first with_delta with_destruct with_evars + naming id (clear_flag,CAst.(make ?loc c)) tac) + sigma + end + +(* A useful resolution tactic which, if c:A->B, transforms |- C into + |- B -> C and |- A + + ------------------- + Gamma |- c : A -> B Gamma |- ?2 : A + ---------------------------------------- + Gamma |- B Gamma |- ?1 : B -> C + ----------------------------------------------------- + Gamma |- ? : C + + Ltac lapply c := + let ty := check c in + match eval hnf in ty with + ?A -> ?B => cut B; [ idtac | apply c ] + end. +*) + +let cut_and_apply c = + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + match EConstr.kind sigma (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with + | Prod (_,c1,c2) when Vars.noccurn sigma 1 c2 -> + let concl = Proofview.Goal.concl gl in + let env = Tacmach.New.pf_env gl in + Refine.refine ~typecheck:false begin fun sigma -> + let typ = mkProd (Anonymous, c2, concl) in + let (sigma, f) = Evarutil.new_evar env sigma typ in + let (sigma, x) = Evarutil.new_evar env sigma c1 in + (sigma, mkApp (f, [|mkApp (c, [|x|])|])) + end + | _ -> error "lapply needs a non-dependent product." + end + +(********************************************************************) +(* Exact tactics *) +(********************************************************************) + +(* let convert_leqkey = CProfile.declare_profile "convert_leq";; *) +(* let convert_leq = CProfile.profile3 convert_leqkey convert_leq *) + +(* let refine_no_checkkey = CProfile.declare_profile "refine_no_check";; *) +(* let refine_no_check = CProfile.profile2 refine_no_checkkey refine_no_check *) + +let exact_no_check c = + Refine.refine ~typecheck:false (fun h -> (h,c)) + +let exact_check c = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + (* We do not need to normalize the goal because we just check convertibility *) + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let sigma, ct = Typing.type_of env sigma c in + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHEN (convert_leq ct concl) (exact_no_check c)) + end + +let cast_no_check cast c = + Proofview.Goal.enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + exact_no_check (mkCast (c, cast, concl)) + end + +let vm_cast_no_check c = cast_no_check VMcast c +let native_cast_no_check c = cast_no_check NATIVEcast c + +let exact_proof c = + let open Tacmach.New in + Proofview.Goal.enter begin fun gl -> + Refine.refine ~typecheck:false begin fun sigma -> + 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, c) + end + end + +let assumption = + let rec arec gl only_eq = function + | [] -> + if only_eq then + let hyps = Proofview.Goal.hyps gl in + arec gl false hyps + else Tacticals.New.tclZEROMSG (str "No such assumption.") + | decl::rest -> + let t = NamedDecl.get_type decl in + let concl = Proofview.Goal.concl gl in + let sigma = Tacmach.New.project gl in + let ans = + if only_eq then + if EConstr.eq_constr sigma t concl then Some sigma + else None + else + let env = Proofview.Goal.env gl in + infer_conv env sigma t concl + in + match ans with + | Some sigma -> + (Proofview.Unsafe.tclEVARS sigma) <*> + exact_no_check (mkVar (NamedDecl.get_id decl)) + | None -> arec gl only_eq rest + in + let assumption_tac gl = + let hyps = Proofview.Goal.hyps gl in + arec gl true hyps + in + Proofview.Goal.enter assumption_tac + +(*****************************************************************) +(* Modification of a local context *) +(*****************************************************************) + +let on_the_bodies = function +| [] -> assert false +| [id] -> str " depends on the body of " ++ Id.print id +| l -> str " depends on the bodies of " ++ pr_sequence Id.print l + +exception DependsOnBody of Id.t option + +let check_is_type env sigma ty = + try + let sigma, _ = Typing.sort_of env sigma ty in + sigma + with e when CErrors.noncritical e -> + raise (DependsOnBody None) + +let check_decl env sigma decl = + let open Context.Named.Declaration in + let ty = NamedDecl.get_type decl in + try + let sigma, _ = Typing.sort_of env sigma ty in + let sigma = match decl with + | LocalAssum _ -> sigma + | LocalDef (_,c,_) -> Typing.check env sigma c ty + in + sigma + with e when CErrors.noncritical e -> + let id = NamedDecl.get_id decl in + raise (DependsOnBody (Some id)) + +let clear_body ids = + let open Context.Named.Declaration in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + let sigma = Tacmach.New.project gl in + let ctx = named_context env in + let map = function + | LocalAssum (id,t) as decl -> + let () = if List.mem_f Id.equal id ids then + user_err (str "Hypothesis " ++ Id.print id ++ str " is not a local definition") + in + decl + | LocalDef (id,_,t) as decl -> + if List.mem_f Id.equal id ids then LocalAssum (id, t) else decl + in + let ctx = List.map map ctx in + let base_env = reset_context env in + let env = push_named_context ctx base_env in + let check = + try + let check (env, sigma, seen) decl = + (* Do no recheck hypotheses that do not depend *) + let sigma = + if not seen then sigma + else if List.exists (fun id -> occur_var_in_decl env sigma id decl) ids then + check_decl env sigma decl + else sigma + in + 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, false) (List.rev ctx) in + let sigma = + if List.exists (fun id -> occur_var env sigma id concl) ids then + check_is_type env sigma concl + else sigma + in + Proofview.Unsafe.tclEVARS sigma + with DependsOnBody where -> + let msg = match where with + | None -> str "Conclusion" ++ on_the_bodies ids + | Some id -> str "Hypothesis " ++ Id.print id ++ on_the_bodies ids + in + Tacticals.New.tclZEROMSG msg + in + check <*> + Refine.refine ~typecheck:false begin fun sigma -> + Evarutil.new_evar env sigma ~principal:true concl + end + end + +let clear_wildcards ids = + Tacticals.New.tclMAP (fun {CAst.loc;v=id} -> clear [id]) ids + +(* Takes a list of booleans, and introduces all the variables + * quantified in the goal which are associated with a value + * true in the boolean list. *) + +let rec intros_clearing = function + | [] -> Proofview.tclUNIT () + | (false::tl) -> Tacticals.New.tclTHEN intro (intros_clearing tl) + | (true::tl) -> + Tacticals.New.tclTHENLIST + [ intro; Tacticals.New.onLastHypId (fun id -> clear [id]); intros_clearing tl] + +(* Keeping only a few hypotheses *) + +let keep hyps = + Proofview.Goal.enter begin fun gl -> + Proofview.tclENV >>= fun env -> + let ccl = Proofview.Goal.concl gl in + let sigma = Tacmach.New.project gl in + let cl,_ = + fold_named_context_reverse (fun (clear,keep) decl -> + let decl = map_named_decl EConstr.of_constr decl in + let hyp = NamedDecl.get_id decl in + if Id.List.mem hyp hyps + || List.exists (occur_var_in_decl env sigma hyp) keep + || occur_var env sigma hyp ccl + then (clear,decl::keep) + else (hyp::clear,keep)) + ~init:([],[]) (Proofview.Goal.env gl) + in + clear cl + end + +(*********************************) +(* Basic generalization tactics *) +(*********************************) + +(* Given a type [T] convertible to [forall x1..xn:A1..An(x1..xn-1), G(x1..xn)] + and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)], + this generalizes [hyps |- goal] into [hyps |- T] *) + +let apply_type ~typecheck newcl args = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + Refine.refine ~typecheck begin fun sigma -> + let newcl = nf_betaiota env sigma newcl (* As in former Logic.refine *) in + let (sigma, ev) = + Evarutil.new_evar env sigma ~principal:true newcl in + (sigma, applist (ev, args)) + end + end + +(* Given a context [hyps] with domain [x1..xn], possibly with let-ins, + and well-typed in the current goal, [bring_hyps hyps] generalizes + [ctxt |- G(x1..xn] into [ctxt |- forall hyps, G(x1..xn)] *) + +let bring_hyps hyps = + if List.is_empty hyps then Tacticals.New.tclIDTAC + else + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let concl = Tacmach.New.pf_concl gl in + let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in + let args = Array.of_list (Context.Named.to_instance mkVar hyps) in + Refine.refine ~typecheck:false begin fun sigma -> + let (sigma, ev) = + Evarutil.new_evar env sigma ~principal:true newcl in + (sigma, mkApp (ev, args)) + end + end + +let revert hyps = + Proofview.Goal.enter begin fun gl -> + let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in + (bring_hyps ctx) <*> (clear hyps) + end + +(************************) +(* Introduction tactics *) +(************************) + +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) -> + user_err ~hdr:"Tactics.check_number_of_constructors" + (str "Not an inductive goal with " ++ int n ++ str (String.plural n " constructor") ++ str ".") + | _ -> () + end; + if i > nconstr then error "Not enough constructors." + +let constructor_core with_evars cstr lbind = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let (sigma, (cons, u)) = Evd.fresh_constructor_instance env sigma cstr in + let cons = mkConstructU (cons, EInstance.make u) in + let apply_tac = general_apply true false with_evars None (CAst.make (cons,lbind)) in + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) apply_tac + end + +let constructor_tac with_evars expctdnumopt i lbind = + Proofview.Goal.enter begin fun gl -> + let cl = Tacmach.New.pf_concl gl in + let ((ind,_),redcl) = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl cl in + let nconstr = Array.length (snd (Global.lookup_inductive ind)).mind_consnames in + check_number_of_constructors expctdnumopt i nconstr; + Tacticals.New.tclTHENLIST [ + convert_concl_no_check redcl DEFAULTcast; + intros; + constructor_core with_evars (ind, i) lbind + ] + end + +let one_constructor i lbind = constructor_tac false None i lbind + +(* Try to apply the constructor of the inductive definition followed by + a tactic t given as an argument. + Should be generalize in Constructor (Fun c : I -> tactic) + *) + +let any_constructor with_evars tacopt = + let one_constr = + let tac cstr = constructor_core with_evars cstr NoBindings in + match tacopt with + | None -> tac + | Some t -> fun cstr -> Tacticals.New.tclTHEN (tac cstr) t in + let rec any_constr ind n i () = + if Int.equal i n then one_constr (ind,i) + else Tacticals.New.tclORD (one_constr (ind,i)) (any_constr ind n (i + 1)) in + Proofview.Goal.enter begin fun gl -> + let cl = Tacmach.New.pf_concl gl in + let (ind,_),redcl = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl cl in + let nconstr = + Array.length (snd (Global.lookup_inductive ind)).mind_consnames in + if Int.equal nconstr 0 then error "The type has no constructors."; + Tacticals.New.tclTHENLIST [ + convert_concl_no_check redcl DEFAULTcast; + intros; + any_constr ind nconstr 1 () + ] + end + +let left_with_bindings with_evars = constructor_tac with_evars (Some 2) 1 +let right_with_bindings with_evars = constructor_tac with_evars (Some 2) 2 +let split_with_bindings with_evars l = + Tacticals.New.tclMAP (constructor_tac with_evars (Some 1) 1) l + +let left = left_with_bindings false +let simplest_left = left NoBindings + +let right = right_with_bindings false +let simplest_right = right NoBindings + +let split = constructor_tac false (Some 1) 1 +let simplest_split = split NoBindings + +(*****************************) +(* Decomposing introductions *) +(*****************************) + +(* Rewriting function for rewriting one hypothesis at the time *) +let (forward_general_rewrite_clause, general_rewrite_clause) = Hook.make () + +(* Rewriting function for substitution (x=t) everywhere at the same time *) +let (forward_subst_one, subst_one) = Hook.make () + +let error_unexpected_extra_pattern loc bound pat = + let _,nb = Option.get bound in + let s1,s2,s3 = match pat with + | IntroNaming (IntroIdentifier _) -> + "name", (String.plural nb " introduction pattern"), "no" + | _ -> "introduction pattern", "", "none" in + 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") ++ + strbrk " expected in the branch).") + +let intro_decomp_eq_function = ref (fun _ -> failwith "Not implemented") + +let declare_intro_decomp_eq f = intro_decomp_eq_function := f + +let my_find_eq_data_decompose gl t = + try Some (find_eq_data_decompose gl t) + with e when is_anomaly e + (* Hack in case equality is not yet defined... one day, maybe, + known equalities will be dynamically registered *) + -> None + | Constr_matching.PatternMatchingFailure -> None + +let intro_decomp_eq ?loc l thin tac id = + Proofview.Goal.enter begin fun gl -> + let c = mkVar id in + let t = Tacmach.New.pf_unsafe_type_of gl c in + let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in + match my_find_eq_data_decompose gl t with + | Some (eq,u,eq_args) -> + !intro_decomp_eq_function + (fun n -> tac ((CAst.make id)::thin) (Some (true,n)) l) + (eq,t,eq_args) (c, t) + | None -> + Tacticals.New.tclZEROMSG (str "Not a primitive equality here.") + end + +let intro_or_and_pattern ?loc with_evars bracketed ll thin tac id = + Proofview.Goal.enter begin fun gl -> + let c = mkVar id in + let t = Tacmach.New.pf_unsafe_type_of gl c in + let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in + let branchsigns = compute_constructor_signatures ~rec_flag:false ind in + let nv_with_let = Array.map List.length branchsigns in + 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_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 with_evars thin l2r id tac = + let rew_on l2r = + 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 + let early_clear id' thin = + List.filter (fun {CAst.v=id} -> not (Id.equal id id')) thin in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let type_of = Tacmach.New.pf_unsafe_type_of gl 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 sigma t with + | Some (hdcncl,[_;lhs;rhs]) -> + if l2r && isVar sigma lhs && not (occur_var env sigma (destVar sigma lhs) rhs) then + let id' = destVar sigma lhs in + subst_on l2r id' rhs, early_clear id' thin + else if not l2r && isVar sigma rhs && not (occur_var env sigma (destVar sigma rhs) lhs) then + let id' = destVar sigma rhs in + subst_on l2r id' lhs, early_clear id' thin + else + 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 sigma c then + let id' = destVar sigma c in + Tacticals.New.tclTHEN (rew_on l2r allHypsAndConcl) + (clear_var_and_eq id'), + early_clear id' thin + else + Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), + thin + | _ -> + 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) + end + +let prepare_naming ?loc = function + | IntroIdentifier id -> NamingMustBe (CAst.make ?loc id) + | IntroAnonymous -> NamingAvoid Id.Set.empty + | IntroFresh id -> NamingBasedOn (id, Id.Set.empty) + +let rec explicit_intro_names = let open CAst in function +| {v=IntroForthcoming _} :: l -> explicit_intro_names l +| {v=IntroNaming (IntroIdentifier id)} :: l -> Id.Set.add id (explicit_intro_names l) +| {v=IntroAction (IntroOrAndPattern l)} :: l' -> + let ll = match l with IntroAndPattern l -> [l] | IntroOrPattern ll -> ll in + let fold accu l = Id.Set.union accu (explicit_intro_names (l@l')) in + List.fold_left fold Id.Set.empty ll +| {v=IntroAction (IntroInjection l)} :: l' -> + explicit_intro_names (l@l') +| {v=IntroAction (IntroApplyOn (c,pat))} :: l' -> + explicit_intro_names (pat::l') +| {v=(IntroNaming (IntroAnonymous | IntroFresh _) + | IntroAction (IntroWildcard | IntroRewrite _))} :: l -> + explicit_intro_names l +| [] -> Id.Set.empty + +let rec check_name_unicity env ok seen = let open CAst in function +| {v=IntroForthcoming _} :: l -> check_name_unicity env ok seen l +| {loc;v=IntroNaming (IntroIdentifier id)} :: l -> + (try + ignore (if List.mem_f Id.equal id ok then raise Not_found else lookup_named id env); + user_err ?loc (Id.print id ++ str" is already used.") + with Not_found -> + if List.mem_f Id.equal id seen then + user_err ?loc (Id.print id ++ str" is used twice.") + else + check_name_unicity env ok (id::seen) l) +| {v=IntroAction (IntroOrAndPattern l)} :: l' -> + let ll = match l with IntroAndPattern l -> [l] | IntroOrPattern ll -> ll in + List.iter (fun l -> check_name_unicity env ok seen (l@l')) ll +| {v=IntroAction (IntroInjection l)} :: l' -> + check_name_unicity env ok seen (l@l') +| {v=IntroAction (IntroApplyOn (c,pat))} :: l' -> + check_name_unicity env ok seen (pat::l') +| {v=(IntroNaming (IntroAnonymous | IntroFresh _) + | IntroAction (IntroWildcard | IntroRewrite _))} :: l -> + check_name_unicity env ok seen l +| [] -> () + +let wild_id = Id.of_string "_tmp" + +let rec list_mem_assoc_right id = function + | [] -> false + | {CAst.v=id'}::l -> Id.equal id id' || list_mem_assoc_right id l + +let check_thin_clash_then id thin avoid tac = + if list_mem_assoc_right id thin then + let newid = next_ident_away (add_suffix id "'") avoid in + let thin = + List.map CAst.(map (fun id' -> if Id.equal id id' then newid else id')) thin in + Tacticals.New.tclTHEN (rename_hyp [id,newid]) (tac thin) + else + tac thin + +let make_tmp_naming avoid l = function + (* In theory, we could use a tmp id like "wild_id" for all actions + but we prefer to avoid it to avoid this kind of "ugly" names *) + (* Alternatively, we could have called check_thin_clash_then on + IntroAnonymous, but at the cost of a "renaming"; Note that in the + case of IntroFresh, we should use check_thin_clash_then anyway to + prevent the case of an IntroFresh precisely using the wild_id *) + | IntroWildcard -> NamingBasedOn (wild_id, Id.Set.union avoid (explicit_intro_names l)) + | pat -> NamingAvoid(Id.Set.union avoid (explicit_intro_names ((CAst.make @@ IntroAction pat)::l))) + +let fit_bound n = function + | None -> true + | Some (use_bound,n') -> not use_bound || n = n' + +let exceed_bound n = function + | None -> false + | Some (use_bound,n') -> use_bound && n >= n' + + (* We delay thinning until the completion of the whole intros tactic + to ensure that dependent hypotheses are cleared in the right + dependency order (see BZ#1000); we use fresh names, not used in + the tactic, for the hyps to clear *) + (* In [intro_patterns_core b avoid ids thin destopt bound n tac patl]: + [b]: compatibility flag, if false at toplevel, do not complete incomplete + trailing toplevel or_and patterns (as in "intros []", see + [bracketing_last_or_and_intro_pattern]) + [avoid]: names to avoid when creating an internal name + [ids]: collect introduced names for possible use by the [tac] continuation + [thin]: collect names to erase at the end + [destopt]: position in the context where to introduce the hypotheses + [bound]: number of pending intros to do in the current or-and pattern, + with remembering of [b] flag if at toplevel + [n]: number of introduction done in the current or-and pattern + [tac]: continuation tactic + [patl]: introduction patterns to interpret + *) + +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 with_evars b avoid ids thin destopt bound n tac + [CAst.make @@ IntroNaming IntroAnonymous] + | {CAst.loc;v=pat} :: l -> + if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else + match pat with + | IntroForthcoming onlydeps -> + intro_forthcoming_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) + destopt onlydeps n 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 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 with_evars b avoid ids thin destopt bound (n+1) tac l))) + | IntroNaming pat -> + 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 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 CAst.(make ?loc id)) destopt true false + (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l)) + | IntroAnonymous -> + intro_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) + destopt true false + (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, Id.Set.union avoid (explicit_intro_names l))) + destopt true false + (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) + +and intro_pattern_action ?loc with_evars b style pat thin destopt tac id = + match pat with + | IntroWildcard -> + tac (CAst.(make ?loc id)::thin) None [] + | IntroOrAndPattern ll -> + 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 with_evars thin l2r id (fun thin -> tac thin None []) + | IntroApplyOn ({CAst.loc=loc';v=f},{CAst.loc;v=pat}) -> + let naming,tac_ipat = + prepare_intros ?loc with_evars (IntroIdentifier id) destopt pat in + let doclear = + if naming = NamingMustBe (CAst.make ?loc id) then + Proofview.tclUNIT () (* apply_in_once do a replacement *) + else + clear [id] in + let f env sigma = let (sigma, c) = f env sigma in (sigma,(c, NoBindings)) + in + apply_in_delayed_once false true true with_evars naming id (None,CAst.make ?loc:loc' f) + (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) + +and prepare_intros ?loc with_evars dft destopt = function + | IntroNaming ipat -> + prepare_naming ?loc ipat, + (fun id -> move_hyp id destopt) + | IntroAction ipat -> + prepare_naming ?loc dft, + (let tac thin bound = + intro_patterns_core with_evars true Id.Set.empty [] thin destopt bound 0 + (fun _ l -> clear_wildcards l) in + 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_head_core with_evars b destopt bound pat = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + check_name_unicity env [] [] pat; + intro_patterns_core with_evars b Id.Set.empty [] [] destopt + bound 0 (fun _ l -> clear_wildcards l) pat + end + +let intro_patterns_bound_to with_evars n destopt = + intro_patterns_head_core with_evars true destopt + (Some (true,n)) + +let intro_patterns_to with_evars destopt = + intro_patterns_head_core with_evars (use_bracketing_last_or_and_intro_pattern ()) + destopt None + +let intro_pattern_to with_evars destopt pat = + intro_patterns_to with_evars destopt [CAst.make pat] + +let intro_patterns with_evars = intro_patterns_to with_evars MoveLast + +(* Implements "intros" *) +let intros_patterns with_evars = function + | [] -> intros + | l -> intro_patterns_to with_evars MoveLast l + +(**************************) +(* Forward reasoning *) +(**************************) + +let prepare_intros_opt with_evars dft destopt = function + | None -> prepare_naming dft, (fun _id -> Proofview.tclUNIT ()) + | Some {CAst.loc;v=ipat} -> prepare_intros ?loc with_evars dft destopt ipat + +let ipat_of_name = function + | Anonymous -> None + | Name id -> Some (CAst.make @@ IntroNaming (IntroIdentifier id)) + +let head_ident sigma c = + let c = fst (decompose_app sigma (snd (decompose_lam_assum sigma c))) in + if isVar sigma c then Some (destVar sigma c) else None + +let assert_as first hd ipat t = + let naming,tac = prepare_intros_opt 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 + else assert_after_then_gen repl naming t tac + +(* apply in as *) + +let general_apply_in ?(respect_opaque=false) sidecond_first with_delta + with_destruct with_evars id lemmas ipat = + let tac (naming,lemma) tac id = + apply_in_delayed_once ~respect_opaque sidecond_first with_delta + with_destruct with_evars naming id lemma tac in + Proofview.Goal.enter begin fun gl -> + let destopt = + if with_evars then MoveLast (* evars would depend on the whole context *) + else ( + let env, sigma = Proofview.Goal.(env gl, sigma gl) in + get_previous_hyp_position env sigma id (Proofview.Goal.hyps gl) + ) in + let naming,ipat_tac = + prepare_intros_opt 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 (CAst.make id),lem)) first, (naming,last) + in + (* We chain apply_in_once, ending with an intro pattern *) + List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id + end + +(* + if sidecond_first then + (* Skip the side conditions of the applied lemma *) + Tacticals.New.tclTHENLAST (tclMAPLAST tac lemmas_target) (ipat_tac id) + else + Tacticals.New.tclTHENFIRST (tclMAPFIRST tac lemmas_target) (ipat_tac id) +*) + +let apply_in simple with_evars id lemmas ipat = + let lemmas = List.map (fun (k,{CAst.loc;v=l}) -> k, CAst.make ?loc (fun _ sigma -> (sigma,l))) lemmas in + general_apply_in false simple simple with_evars id lemmas ipat + +let apply_delayed_in simple with_evars id lemmas ipat = + general_apply_in ~respect_opaque:true false simple simple with_evars id lemmas ipat + +(*****************************) +(* Tactics abstracting terms *) +(*****************************) + +(* Implementation without generalisation: abbrev will be lost in hyps in *) +(* in the extracted proof *) + +let decode_hyp = function + | None -> MoveLast + | Some id -> MoveAfter id + +(* [letin_tac b (... abstract over c ...) gl] transforms + [...x1:T1(c),...,x2:T2(c),... |- G(c)] into + [...x:T;Heqx:(x=c);x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is false or + [...x:=c:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is true +*) + +let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let (sigma, t) = match ty with + | Some t -> (sigma, t) + | None -> + let t = typ_of env sigma c in + Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t + in + let (sigma, (newcl, eq_tac)) = match with_eq with + | Some (lr,{CAst.loc;v=ido}) -> + let heq = match ido with + | IntroAnonymous -> new_fresh_id (Id.Set.singleton id) (add_prefix "Heq" id) gl + | IntroFresh heq_base -> new_fresh_id (Id.Set.singleton id) heq_base gl + | IntroIdentifier id -> id in + let eqdata = build_coq_eq_data () in + let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in + let (sigma, eq) = Evd.fresh_global env sigma eqdata.eq in + let (sigma, refl) = Evd.fresh_global env sigma eqdata.refl in + let eq = applist (eq,args) in + let refl = applist (refl, [t;mkVar id]) in + let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in + let sigma, _ = Typing.type_of env sigma term in + let ans = term, + Tacticals.New.tclTHENLIST + [ + intro_gen (NamingMustBe CAst.(make ?loc heq)) (decode_hyp lastlhyp) true false; + clear_body [heq;id]] + in + (sigma, ans) + | None -> + (sigma, (mkNamedLetIn id c t ccl, Proofview.tclUNIT ())) + in + Tacticals.New.tclTHENLIST + [ Proofview.Unsafe.tclEVARS sigma; + convert_concl_no_check newcl DEFAULTcast; + intro_gen (NamingMustBe (CAst.make id)) (decode_hyp lastlhyp) true false; + Tacticals.New.tclMAP convert_hyp_no_check depdecls; + eq_tac ] + end + +let insert_before decls lasthyp env = + match lasthyp with + | None -> push_named_context decls env + | Some id -> + Environ.fold_named_context + (fun _ d env -> + let d = map_named_decl EConstr.of_constr d 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 + +let mk_eq_name env id {CAst.loc;v=ido} = + match ido with + | IntroAnonymous -> fresh_id_in_env (Id.Set.singleton id) (add_prefix "Heq" id) env + | IntroFresh heq_base -> fresh_id_in_env (Id.Set.singleton id) heq_base env + | IntroIdentifier id -> + if List.mem id (ids_of_named_context (named_context env)) then + user_err ?loc (Id.print id ++ str" is already used."); + id + +(* unsafe *) + +let mkletin_goal env sigma with_eq dep (id,lastlhyp,ccl,c) ty = + let open Context.Named.Declaration in + let t = match ty with Some t -> t | _ -> typ_of env sigma c in + let decl = if dep then LocalDef (id,c,t) + else LocalAssum (id,t) + in + match with_eq with + | Some (lr,heq) -> + let eqdata = build_coq_eq_data () in + let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in + let (sigma, eq) = Evd.fresh_global env sigma eqdata.eq in + let (sigma, refl) = Evd.fresh_global env sigma eqdata.refl in + let eq = applist (eq,args) in + let refl = applist (refl, [t;mkVar id]) in + let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in + let (sigma, x) = new_evar newenv sigma ~principal:true ccl in + (sigma, mkNamedLetIn id c t (mkNamedLetIn heq refl eq x)) + | None -> + let newenv = insert_before [decl] lastlhyp env in + let (sigma, x) = new_evar newenv sigma ~principal:true ccl in + (sigma, mkNamedLetIn id c t x) + +let pose_tac na c = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let hyps = named_context_val env in + let concl = Proofview.Goal.concl gl in + let t = typ_of env sigma c in + let (sigma, t) = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t in + let id = match na with + | Name id -> + let () = if mem_named_context_val id hyps then + user_err (str "Variable " ++ Id.print id ++ str " is already declared.") + in + id + | Anonymous -> + let id = id_of_name_using_hdchar env sigma t Anonymous in + next_ident_away_in_goal id (ids_of_named_context_val hyps) + in + Proofview.Unsafe.tclEVARS sigma <*> + Refine.refine ~typecheck:false begin fun sigma -> + let nhyps = EConstr.push_named_context_val (NamedDecl.LocalDef (id, c, t)) hyps in + let (sigma, ev) = Evarutil.new_pure_evar nhyps sigma concl in + let inst = Array.map_of_list (fun d -> mkVar (get_id d)) (named_context env) in + let body = mkEvar (ev, Array.append [|mkRel 1|] inst) in + (sigma, mkLetIn (Name id, c, t, body)) + end + end + +let letin_tac with_eq id c ty occs = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + 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,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) = match res with + | None -> (sigma, c) + | Some (sigma, _) -> (sigma, c) + in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty) + end + +let letin_pat_tac with_evars with_eq id c occs = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let ccl = Proofview.Goal.concl gl in + let check t = true in + let abs = AbstractPattern (false,check,id,c,occs,false) in + let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in + let (sigma, c) = match res with + | None -> finish_evar_resolution ~flags:(tactic_infer_flags with_evars) env sigma c + | Some res -> res in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None) + end + +(* Tactics "pose proof" (usetac=None) and "assert"/"enough" (otherwise) *) +let forward b usetac ipat c = + match usetac with + | None -> + Proofview.Goal.enter begin fun gl -> + let t = Tacmach.New.pf_get_type_of gl c in + let sigma = Tacmach.New.project gl in + let hd = head_ident sigma c in + 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 + Tacticals.New.tclTHENS3PARTS + (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 (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 *) +(***************************) + +(* Compute a name for a generalization *) + +let generalized_name env sigma c t ids cl = function + | Name id as na -> + if Id.List.mem id ids then + user_err (Id.print id ++ str " is already used."); + na + | Anonymous -> + match EConstr.kind sigma c with + | Var id -> + (* Keep the name even if not occurring: may be used by intros later *) + Name id + | _ -> + if noccurn sigma 1 cl then Anonymous else + (* On ne s'etait pas casse la tete : on avait pris pour nom de + variable la premiere lettre du type, meme si "c" avait ete une + constante dont on aurait pu prendre directement le nom *) + named_hd env sigma t Anonymous + +(* Abstract over [c] in [forall x1:A1(c)..xi:Ai(c).T(c)] producing + [forall x, x1:A1(x1), .., xi:Ai(x). T(x)] with all [c] abtracted in [Ai] + but only those at [occs] in [T] *) + +let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = + let open Context.Rel.Declaration in + let decls,cl = decompose_prod_n_assum sigma i cl in + let dummy_prod = it_mkProd_or_LetIn mkProp decls in + let newdecls,_ = decompose_prod_n_assum sigma i (subst_term_gen sigma EConstr.eq_constr_nounivs c dummy_prod) in + let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in + let na = generalized_name env sigma c t ids cl' na in + let decl = match b with + | None -> LocalAssum (na,t) + | Some b -> LocalDef (na,b,t) + in + mkProd_or_LetIn decl cl', sigma' + +let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = + let open Tacmach.New in + let env = pf_env gl in + let ids = pf_ids_of_hyps gl in + 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 = + let open Tacmach.New in + let open Tacticals.New in + Proofview.Goal.enter begin fun gl -> + let env = pf_env gl in + let sign = Proofview.Goal.hyps gl in + let sigma = project gl in + let init_ids = ids_of_named_context (Global.named_context()) in + let seek (d:named_declaration) (toquant:named_context) = + if List.exists (fun d' -> occur_var_in_decl env sigma (NamedDecl.get_id d') d) toquant + || dependent_in_decl sigma 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 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 EConstr.kind sigma c with + | Var id when mem_named_context_val id (val_of_named_context sign) && not (Id.List.mem id init_ids) + -> id::tothin + | _ -> tothin + in + let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in + let body = + if with_let then + match EConstr.kind sigma c with + | Var id -> id |> (fun id -> pf_get_hyp id 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 mkVar to_quantify_rev in + tclTHENLIST + [ Proofview.Unsafe.tclEVARS evd; + apply_type ~typecheck:false cl'' (if Option.is_empty body then c::args else args); + clear (List.rev tothin')] + end + +(** *) +let generalize_gen_let lconstr = Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let newcl, evd = + List.fold_right_i (generalize_goal gl) 0 lconstr + (Tacmach.New.pf_concl gl,Tacmach.New.project gl) + in + let (evd, _) = Typing.type_of env evd newcl in + let map ((_, c, b),_) = if Option.is_empty b then Some c else None in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) + (apply_type ~typecheck:false newcl (List.map_filter map lconstr)) +end + +let new_generalize_gen_let lconstr = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let ids = Tacmach.New.pf_ids_of_hyps gl in + let newcl, sigma, args = + List.fold_right_i + (fun i ((_,c,b),_ as o) (cl, sigma, args) -> + let sigma, t = Typing.type_of env sigma c in + let args = if Option.is_empty b then c :: args else args in + let cl, sigma = generalize_goal_gen env sigma ids i o t cl in + (cl, sigma, args)) + 0 lconstr (concl, sigma, []) + in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Refine.refine ~typecheck:false begin fun sigma -> + let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true newcl in + (sigma, applist (ev, args)) + end) + end + +let generalize_gen lconstr = + generalize_gen_let (List.map (fun (occs_c,na) -> + let (occs,c) = Redexpr.out_with_occurrences occs_c in + (occs,c,None),na) lconstr) + +let new_generalize_gen lconstr = + new_generalize_gen_let (List.map (fun ((occs,c),na) -> + (occs,c,None),na) lconstr) + +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 ? +Cela peut-être troublant de faire "Generalize Dependent H n" dans +"n:nat; H:n=n |- P(n)" et d'échouer parce que H a disparu après la +généralisation dépendante par n. + +let quantify lconstr = + List.fold_right + (fun com tac -> tclTHEN tac (tactic_com generalize_dep c)) + lconstr + tclIDTAC +*) + +(* Modifying/Adding an hypothesis *) + +(* Instantiating some arguments (whatever their position) of an hypothesis + or any term, leaving other arguments quantified. If operating on an + hypothesis of the goal, the new hypothesis replaces it. + + (c,lbind) are supposed to be of the form + ((t t1 t2 ... tm) , someBindings) + + in which case we pose a proof with body + + (fun y1...yp => H t1 t2 ... tm u1 ... uq) where yi are the + remaining arguments of H that lbind could not resolve, ui are a mix + of inferred args and yi. The overall effect is to remove from H as + much quantification as possible given lbind. *) +let specialize (c,lbind) ipat = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let sigma, term = + if lbind == NoBindings then + sigma, c + else + let typ_of_c = Retyping.get_type_of env sigma c in + (* If the term is lambda then we put a letin to put avoid + interaction between the term and the bindings. *) + let c = match EConstr.kind sigma c with + | Lambda(_,_,_) -> + mkLetIn(Name.Anonymous, c, typ_of_c, (mkRel 1)) + | _ -> c in + let clause = make_clenv_binding env sigma (c,typ_of_c) lbind in + let flags = { (default_unify_flags ()) with resolve_evars = true } in + let clause = clenv_unify_meta_types ~flags clause in + let sigma = clause.evd in + let (thd,tstack) = whd_nored_stack sigma (clenv_value clause) in + let c_hd , c_args = decompose_app sigma c in + let liftrel x = + match kind sigma x with + | Rel n -> mkRel (n+1) + | _ -> x in + (* We grab names used in product to remember them at re-abstracting phase *) + let typ_of_c_hd = pf_get_type_of gl c_hd in + let lprod, concl = decompose_prod_assum sigma typ_of_c_hd in + (* accumulator args: arguments to apply to c_hd: all infered + args + re-abstracted rels *) + let rec rebuild_lambdas sigma lprd args hd l = + match lprd , l with + | _, [] -> sigma,applist (hd, (List.map (nf_evar sigma) args)) + | Context.Rel.Declaration.LocalAssum(nme,_)::lp' , t::l' when occur_meta sigma t -> + (* nme has not been resolved, let us re-abstract it. Same + name but type updated by instanciation of other args. *) + let sigma,new_typ_of_t = Typing.type_of clause.env sigma t in + let liftedargs = List.map liftrel args in + (* lifting rels in the accumulator args *) + let sigma,hd' = rebuild_lambdas sigma lp' (liftedargs@[mkRel 1 ]) hd l' in + (* replace meta variable by the abstracted variable *) + let hd'' = subst_term sigma t hd' in + (* lambda expansion *) + sigma,mkLambda (nme,new_typ_of_t,hd'') + | Context.Rel.Declaration.LocalAssum(_,_)::lp' , t::l' -> + let sigma,hd' = rebuild_lambdas sigma lp' (args@[t]) hd l' in + sigma,hd' + | _ ,_ -> assert false in + let sigma,hd = rebuild_lambdas sigma (List.rev lprod) [] c_hd tstack in + Evd.clear_metas sigma, hd + in + let typ = Retyping.get_type_of env sigma term in + let tac = + match EConstr.kind sigma (fst(EConstr.decompose_app sigma (snd(EConstr.decompose_lam_assum sigma 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_opt 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 *) + (* TODO: add intro to be more homogeneous. It will break + scripts but will be easy to fix *) + (Tacticals.New.tclTHENLAST (cut typ) (exact_no_check term)) + | Some {CAst.loc;v=ipat} -> + (* Like pose proof with extra support for "with" bindings *) + (* even though the "with" bindings forces full application *) + let naming,tac = prepare_intros ?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 + +(*****************************) +(* Ad hoc unfold *) +(*****************************) + +(* The two following functions should already exist, but found nowhere *) +(* Unfolds x by its definition everywhere *) +let unfold_body x = + let open Context.Named.Declaration in + Proofview.Goal.enter begin fun gl -> + (* We normalize the given hypothesis immediately. *) + let env = Proofview.Goal.env gl in + let xval = match Environ.lookup_named x env with + | LocalAssum _ -> user_err ~hdr:"unfold_body" + (Id.print x ++ str" is not a defined hypothesis.") + | LocalDef (_,xval,_) -> xval + in + let xval = EConstr.of_constr xval in + Tacticals.New.afterHyp x begin fun aft -> + 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] + end + end + +let warn_cannot_remove_as_expected = + CWarnings.create ~name:"cannot-remove-as-expected" ~category:"tactics" + (fun (id,inglobal) -> + let pp = match inglobal with + | None -> mt () + | Some ref -> str ", it is used implicitly in " ++ Printer.pr_global ref in + str "Cannot remove " ++ Id.print id ++ pp ++ str ".") + +let clear_for_destruct ids = + Proofview.tclORELSE + (clear_gen (fun env sigma id err inglobal -> raise (ClearDependencyError (id,err,inglobal))) ids) + (function + | ClearDependencyError (id,err,inglobal),_ -> warn_cannot_remove_as_expected (id,inglobal); Proofview.tclUNIT () + | e -> iraise e) + +(* Either unfold and clear if defined or simply clear if not a definition *) +let expand_hyp id = + Tacticals.New.tclTRY (unfold_body id) <*> clear_for_destruct [id] + +(*****************************) +(* High-level induction *) +(*****************************) + +(* + * A "natural" induction tactic + * + - [H0:T0, ..., Hi:Ti, hyp0:P->I(args), Hi+1:Ti+1, ..., Hn:Tn |-G] is the goal + - [hyp0] is the induction hypothesis + - we extract from [args] the variables which are not rigid parameters + of the inductive type, this is [indvars] (other terms are forgotten); + - we look for all hyps depending of [hyp0] or one of [indvars]: + this is [dephyps] of types [deptyps] respectively + - [statuslist] tells for each hyps in [dephyps] after which other hyp + fixed in the context they must be moved (when induction is done) + - [hyp0succ] is the name of the hyp fixed in the context after which to + move the subterms of [hyp0succ] in the i-th branch where it is supposed + to be the i-th constructor of the inductive type. + + Strategy: (cf in [induction_with_atomization_of_ind_arg]) + - requantify and clear all [dephyps] + - apply induction on [hyp0] + - clear those of [indvars] that are variables and [hyp0] + - in the i-th subgoal, intro the arguments of the i-th constructor + of the inductive type after [hyp0succ] (done in + [induct_discharge]) let the induction hypotheses on top of the + hyps because they may depend on variables between [hyp0] and the + top. A counterpart is that the dep hyps programmed to be intro-ed + on top must now be intro-ed after the induction hypotheses + - move each of [dephyps] at the right place following the + [statuslist] + + *) + +let warn_unused_intro_pattern env sigma = + 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_econstr_env env sigma (snd (c env sigma)))) names) + +let check_unused_names env sigma names = + if not (List.is_empty names) then + warn_unused_intro_pattern env sigma names + +let intropattern_of_name gl avoid = function + | Anonymous -> IntroNaming IntroAnonymous + | Name id -> IntroNaming (IntroIdentifier (new_fresh_id avoid id gl)) + +let rec consume_pattern avoid na isdep gl = let open CAst in function + | [] -> ((CAst.make @@ intropattern_of_name gl avoid na), []) + | {loc;v=IntroForthcoming true}::names when not isdep -> + consume_pattern avoid na isdep gl names + | {loc;v=IntroForthcoming _}::names as fullpat -> + let avoid = Id.Set.union avoid (explicit_intro_names names) in + (CAst.make ?loc @@ intropattern_of_name gl avoid na, fullpat) + | {loc;v=IntroNaming IntroAnonymous}::names -> + let avoid = Id.Set.union avoid (explicit_intro_names names) in + (CAst.make ?loc @@ intropattern_of_name gl avoid na, names) + | {loc;v=IntroNaming (IntroFresh id')}::names -> + let avoid = Id.Set.union avoid (explicit_intro_names names) in + (CAst.make ?loc @@ IntroNaming (IntroIdentifier (new_fresh_id avoid id' gl)), names) + | pat::names -> (pat,names) + +let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) = + let tophyp = match tophyp with None -> MoveLast | Some hyp -> MoveAfter hyp in + let newlstatus = (* if some IH has taken place at the top of hyps *) + List.map (function (hyp,MoveLast) -> (hyp,tophyp) | x -> x) lstatus + in + Tacticals.New.tclTHEN + (intros_move rstatus) + (intros_move newlstatus) + +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 with_evars avoid thin dest pat tac = + Proofview.tclORELSE + (dest_intro_patterns with_evars avoid thin dest pat tac) + begin function (e, info) -> match e with + | 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 with_evars avoid thin MoveLast pat tac + | e -> Proofview.tclZERO ~info e + end + +type elim_arg_kind = RecArg | IndArg | OtherArg + +type recarg_position = + | AfterFixedPosition of Id.t option (* None = top of context *) + +let update_dest (recargdests,tophyp as dests) = function + | [] -> dests + | hyp::_ -> + (match recargdests with + | AfterFixedPosition None -> AfterFixedPosition (Some hyp) + | x -> x), + (match tophyp with None -> Some hyp | x -> x) + +let get_recarg_dest (recargdests,tophyp) = + match recargdests with + | AfterFixedPosition None -> MoveLast + | AfterFixedPosition (Some id) -> MoveAfter id + +(* Current policy re-introduces recursive arguments of destructed + variable at the place of the original variable while induction + hypothesese are introduced at the top of the context. Since in the + general case of an inductive scheme, the induction hypotheses can + arrive just after the recursive arguments (e.g. as in "forall + t1:tree, P t1 -> forall t2:tree, P t2 -> P (node t1 t2)", we need + to update the position for t2 after "P t1" is introduced if ever t2 + had to be introduced at the top of the context). +*) + +let induct_discharge with_evars dests avoid' tac (avoid,ra) names = + let avoid = Id.Set.union avoid avoid' in + let rec peel_tac ra dests names thin = + match ra with + | (RecArg,_,deprec,recvarname) :: + (IndArg,_,depind,hyprecname) :: ra' -> + Proofview.Goal.enter begin fun gl -> + let (recpat,names) = match names with + | [{CAst.loc;v=IntroNaming (IntroIdentifier id)} as pat] -> + let id' = next_ident_away (add_prefix "IH" id) avoid in + (pat, [CAst.make @@ IntroNaming (IntroIdentifier id')]) + | _ -> consume_pattern avoid (Name recvarname) deprec gl names in + let dest = get_recarg_dest dests in + dest_intro_patterns with_evars avoid thin dest [recpat] (fun ids thin -> + Proofview.Goal.enter begin fun gl -> + let (hyprec,names) = + consume_pattern avoid (Name hyprecname) depind gl names + in + dest_intro_patterns with_evars avoid thin MoveLast [hyprec] (fun ids' thin -> + peel_tac ra' (update_dest dests ids') names thin) + end) + end + | (IndArg,_,dep,hyprecname) :: ra' -> + Proofview.Goal.enter begin fun gl -> + (* 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 with_evars avoid thin MoveLast [pat] (fun ids thin -> + peel_tac ra' (update_dest dests ids) names thin) + end + | (RecArg,_,dep,recvarname) :: ra' -> + Proofview.Goal.enter begin fun gl -> + let (pat,names) = + consume_pattern avoid (Name recvarname) dep gl names in + let dest = get_recarg_dest dests in + 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 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 with_evars avoid thin dest [pat] (fun ids thin -> + peel_tac ra' dests names thin) + end + | [] -> + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + check_unused_names env sigma names; + Tacticals.New.tclTHEN (clear_wildcards thin) (tac dests) + end + in + peel_tac ra dests names [] + +(* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas + s'embêter à regarder si un letin_tac ne fait pas des + substitutions aussi sur l'argument voisin *) + +let expand_projections env sigma c = + let rec aux env c = + match EConstr.kind sigma c with + | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) [] + | _ -> map_constr_with_full_binders sigma push_rel aux env c + in + aux env c + + +(* Marche pas... faut prendre en compte l'occurrence précise... *) + +let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in + let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in + let typ0 = reduce_to_quantified_ref indref tmptyp0 in + let prods, indtyp = decompose_prod_assum sigma typ0 in + let hd,argl = decompose_app sigma indtyp in + let env' = push_rel_context prods env in + let params = List.firstn nparams argl in + let params' = List.map (expand_projections env' sigma) params in + (* le gl est important pour ne pas préévaluer *) + let rec atomize_one i args args' avoid = + if Int.equal i nparams then + let t = applist (hd, params@args) in + Tacticals.New.tclTHEN + (change_in_hyp None (make_change_arg t) (hyp0,InHypTypeOnly)) + (tac avoid) + else + let c = List.nth argl (i-1) in + match EConstr.kind sigma c with + | Var id when not (List.exists (fun c -> occur_var env sigma id c) args') && + not (List.exists (fun c -> occur_var env sigma id c) params') -> + (* Based on the knowledge given by the user, all + constraints on the variable are generalizable in the + current environment so that it is clearable after destruction *) + atomize_one (i-1) (c::args) (c::args') (Id.Set.add id avoid) + | _ -> + let c' = expand_projections env' sigma c in + let dependent t = dependent sigma c t in + if List.exists dependent params' || + List.exists dependent args' + then + (* This is a case where the argument is constrained in a + way which would require some kind of inversion; we + follow the (old) discipline of not generalizing over + this term, since we don't try to invert the + constraint anyway. *) + atomize_one (i-1) (c::args) (c'::args') avoid + else + (* We reason blindly on the term and do as if it were + generalizable, ignoring the constraints coming from + its structure *) + let id = match EConstr.kind sigma c with + | Var id -> id + | _ -> + let type_of = Tacmach.New.pf_unsafe_type_of gl in + id_of_name_using_hdchar env sigma (type_of c) Anonymous in + let x = fresh_id_in_env avoid id env in + Tacticals.New.tclTHEN + (letin_tac None (Name x) c None allHypsAndConcl) + (atomize_one (i-1) (mkVar x::args) (mkVar x::args') (Id.Set.add x avoid)) + in + atomize_one (List.length argl) [] [] Id.Set.empty + end + +(* [cook_sign] builds the lists [beforetoclear] (preceding the + ind. var.) and [aftertoclear] (coming after the ind. var.) of hyps + that must be erased, the lists of hyps to be generalize [decldeps] on the + goal together with the places [(lstatus,rstatus)] where to re-intro + them after induction. To know where to re-intro the dep hyp, we + remember the name of the hypothesis [lhyp] after which (if the dep + hyp is more recent than [hyp0]) or [rhyp] before which (if older + than [hyp0]) its equivalent must be moved when the induction has + been applied. Since computation of dependencies and [rhyp] is from + more ancient (on the right) to more recent hyp (on the left) but + the computation of [lhyp] progresses from the other way, [cook_hyp] + is in two passes (an alternative would have been to write an + higher-order algorithm). We use references to reduce + the accumulation of arguments. + + To summarize, the situation looks like this + + Goal(n,x) -| H6:(Q n); x:A; H5:True; H4:(le O n); H3:(P n); H2:True; n:nat + Left Right + + Induction hypothesis is H4 ([hyp0]) + Variable parameters of (le O n) is the singleton list with "n" ([indvars]) + The dependent hyps are H3 and H6 ([dephyps]) + For H3 the memorized places are H5 ([lhyp]) and H2 ([rhyp]) + because these names are among the hyp which are fixed through the induction + For H6 the neighbours are None ([lhyp]) and H5 ([rhyp]) + For H3, because on the right of H4, we remember rhyp (here H2) + For H6, because on the left of H4, we remember lhyp (here None) + For H4, we remember lhyp (here H5) + + The right neighbour is then translated into the left neighbour + because move_hyp tactic needs the name of the hyp _after_ which we + move the hyp to move. + + But, say in the 2nd subgoal of the hypotheses, the goal will be + + (m:nat)((P m)->(Q m)->(Goal m)) -> (P Sm)-> (Q Sm)-> (Goal Sm) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^ + both go where H4 was goes where goes where + H3 was H6 was + + We have to intro and move m and the recursive hyp first, but then + where to move H3 ??? Only the hyp on its right is relevant, but we + have to translate it into the name of the hyp on the left + + Note: this case where some hyp(s) in [dephyps] has(have) the same + left neighbour as [hyp0] is the only problematic case with right + neighbours. For the other cases (e.g. an hyp H1:(R n) between n and H2 + would have posed no problem. But for uniformity, we decided to use + the right hyp for all hyps on the right of H4. + + Other solutions are welcome + + PC 9 fev 06: Adapted to accept multi argument principle with no + main arg hyp. hyp0 is now optional, meaning that it is possible + that there is no main induction hypotheses. In this case, we + consider the last "parameter" (in [indvars]) as the limit between + "left" and "right", BUT it must be included in indhyps. + + Other solutions are still welcome + +*) + +exception Shunt of Id.t move_location + +let cook_sign hyp0_opt inhyps indvars env sigma = + (* First phase from L to R: get [toclear], [decldep] and [statuslist] + for the hypotheses before (= more ancient than) hyp0 (see above) *) + let toclear = ref [] in + let avoid = ref Id.Set.empty in + let decldeps = ref [] in + let ldeps = ref [] in + let rstatus = ref [] in + let lstatus = ref [] in + let before = ref true in + let maindep = ref false in + let seek_deps env decl rhyp = + let decl = map_named_decl EConstr.of_constr 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; + (* Note that if there was no main induction hypotheses, then hyp + is one of indvars too *) + toclear := hyp::!toclear; + MoveFirst (* fake value *) + end else if Id.Set.mem hyp indvars then begin + (* The variables in indvars are such that they don't occur any + more after generalization, so declare them to clear. *) + toclear := hyp::!toclear; + rhyp + end else + let dephyp0 = List.is_empty inhyps && + (Option.cata (fun id -> occur_var_in_decl env sigma id decl) false hyp0_opt) + in + let depother = List.is_empty inhyps && + (Id.Set.exists (fun id -> occur_var_in_decl env sigma id decl) indvars || + List.exists (fun decl' -> occur_var_in_decl env sigma (NamedDecl.get_id decl') decl) !decldeps) + in + if not (List.is_empty inhyps) && Id.List.mem hyp inhyps + || dephyp0 || depother + then begin + decldeps := decl::!decldeps; + avoid := Id.Set.add hyp !avoid; + maindep := dephyp0 || !maindep; + if !before then begin + toclear := hyp::!toclear; + rstatus := (hyp,rhyp)::!rstatus + end + else begin + toclear := hyp::!toclear; + ldeps := hyp::!ldeps (* status computed in 2nd phase *) + end; + MoveBefore hyp end + else + MoveBefore hyp + in + 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 = 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 + lstatus := (hyp,lhyp)::!lstatus; + lhyp + end else + if Id.List.mem hyp !toclear then lhyp else MoveAfter hyp + in + try + let _ = + fold_named_context_reverse compute_lstatus ~init:MoveLast env in + raise (Shunt MoveLast) (* ?? FIXME *) + with Shunt lhyp0 -> + let lhyp0 = match lhyp0 with + | MoveLast -> None + | MoveAfter hyp -> Some hyp + | _ -> assert false in + let statuslists = (!lstatus,List.rev !rstatus) in + let recargdests = AfterFixedPosition (if Option.is_empty hyp0_opt then None else lhyp0) in + (statuslists, (recargdests,None), !toclear, !decldeps, !avoid, !maindep) + +(* + The general form of an induction principle is the following: + + forall prm1 prm2 ... prmp, (induction parameters) + forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates) + branch1, branch2, ... , branchr, (branches of the principle) + forall (x1:Ti_1) (x2:Ti_2) ... (xni:Ti_ni), (induction arguments) + (HI: I prm1..prmp x1...xni) (optional main induction arg) + -> (Qi x1...xni HI (f prm1...prmp x1...xni)).(conclusion) + ^^ ^^^^^^^^^^^^^^^^^^^^^^^^ + optional optional argument added if + even if HI principle generated by functional + present above induction, only if HI does not exist + [indarg] [farg] + + HI is not present when the induction principle does not come directly from an + inductive type (like when it is generated by functional induction for + example). HI is present otherwise BUT may not appear in the conclusion + (dependent principle). HI and (f...) cannot be both present. + + Principles taken from functional induction have the final (f...).*) + +(* [rel_contexts] and [rel_declaration] actually contain triples, and + lists are actually in reverse order to fit [compose_prod]. *) +type elim_scheme = { + elimc: constr with_bindings option; + elimt: types; + indref: GlobRef.t option; + params: rel_context; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) + nparams: int; (* number of parameters *) + predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) + npredicates: int; (* Number of predicates *) + branches: rel_context; (* branchr,...,branch1 *) + nbranches: int; (* Number of branches *) + args: rel_context; (* (xni, Ti_ni) ... (x1, Ti_1) *) + nargs: int; (* number of arguments *) + indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) + if HI is in premisses, None otherwise *) + concl: types; (* Qi x1...xni HI (f...), HI and (f...) + are optional and mutually exclusive *) + indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) + farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) +} + +let empty_scheme = + { + elimc = None; + elimt = mkProp; + indref = None; + params = []; + nparams = 0; + predicates = []; + npredicates = 0; + branches = []; + nbranches = 0; + args = []; + nargs = 0; + indarg = None; + concl = mkProp; + indarg_in_concl = false; + farg_in_concl = false; + } + +let make_base n id = + if Int.equal n 0 || Int.equal n 1 then id + else + (* This extends the name to accept new digits if it already ends with *) + (* digits *) + Id.of_string (atompart_of_id (make_ident (Id.to_string id) (Some 0))) + +(* Builds two different names from an optional inductive type and a + number, also deals with a list of names to avoid. If the inductive + type is None, then hyprecname is IHi where i is a number. *) +let make_up_names n ind_opt cname = + let is_hyp = String.equal (atompart_of_id cname) "H" in + let base = Id.to_string (make_base n cname) in + let ind_prefix = "IH" in + let base_ind = + if is_hyp then + match ind_opt with + | None -> Id.of_string ind_prefix + | Some ind_id -> add_prefix ind_prefix (Nametab.basename_of_global ind_id) + else add_prefix ind_prefix cname in + let hyprecname = make_base n base_ind in + let avoid = + if Int.equal n 1 (* Only one recursive argument *) || Int.equal n 0 then Id.Set.empty + else + (* Forbid to use cname, cname0, hyprecname and hyprecname0 *) + (* in order to get names such as f1, f2, ... *) + let avoid = + Id.Set.add (make_ident (Id.to_string hyprecname) None) + (Id.Set.singleton (make_ident (Id.to_string hyprecname) (Some 0))) in + if not (String.equal (atompart_of_id cname) "H") then + Id.Set.add (make_ident base (Some 0)) (Id.Set.add (make_ident base None) avoid) + else avoid in + Id.of_string base, hyprecname, avoid + +let error_ind_scheme s = + let s = if not (String.is_empty s) then s^" " else s in + user_err ~hdr:"Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") + +let coq_eq sigma = Evarutil.new_global sigma Coqlib.(lib_ref "core.eq.type") +let coq_eq_refl sigma = Evarutil.new_global sigma Coqlib.(lib_ref "core.eq.refl") + +let coq_heq_ref = lazy (Coqlib.lib_ref "core.JMeq.type") +let coq_heq sigma = Evarutil.new_global sigma (Lazy.force coq_heq_ref) +let coq_heq_refl sigma = Evarutil.new_global sigma (Coqlib.lib_ref "core.JMeq.refl") +(* let coq_heq_refl = lazy (glob (lib_ref "core.JMeq.refl")) *) + +let mkEq sigma t x y = + let sigma, eq = coq_eq sigma in + sigma, mkApp (eq, [| t; x; y |]) + +let mkRefl sigma t x = + let sigma, refl = coq_eq_refl sigma in + sigma, mkApp (refl, [| t; x |]) + +let mkHEq sigma t x u y = + let sigma, c = coq_heq sigma in + sigma, mkApp (c,[| t; x; u; y |]) + +let mkHRefl sigma t x = + let sigma, c = coq_heq_refl sigma in + sigma, mkApp (c, [| t; x |]) + +let lift_togethern n l = + let l', _ = + List.fold_right + (fun x (acc, n) -> + (lift n x :: acc, succ n)) + l ([], n) + in l' + +let lift_list l = List.map (lift 1) l + +let ids_of_constr sigma ?(all=false) vars c = + let rec aux vars c = + match EConstr.kind sigma c with + | Var id -> Id.Set.add id vars + | App (f, args) -> + (match EConstr.kind sigma f with + | Construct ((ind,_),_) + | Ind (ind,_) -> + let (mib,mip) = Global.lookup_inductive ind in + Array.fold_left_from + (if all then 0 else mib.Declarations.mind_nparams) + aux vars args + | _ -> EConstr.fold sigma aux vars c) + | _ -> EConstr.fold sigma aux vars c + in aux vars c + +let decompose_indapp sigma f args = + match EConstr.kind sigma f with + | Construct ((ind,_),_) + | Ind (ind,_) -> + let (mib,mip) = Global.lookup_inductive ind in + let first = mib.Declarations.mind_nparams_rec in + let pars, args = Array.chop first args in + mkApp (f, pars), args + | _ -> f, args + +let mk_term_eq homogeneous env sigma ty t ty' t' = + if homogeneous then + let sigma, eq = mkEq sigma ty t t' in + let sigma, refl = mkRefl sigma ty' t' in + sigma, (eq, refl) + else + let sigma, heq = mkHEq sigma ty t ty' t' in + let sigma, hrefl = mkHRefl sigma ty' t' in + sigma, (heq, hrefl) + +let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = + let open Context.Rel.Declaration in + Refine.refine ~typecheck:false begin fun sigma -> + let eqslen = List.length eqs in + (* Abstract by the "generalized" hypothesis equality proof if necessary. *) + let sigma, abshypeq, abshypt = + if dep then + let ty = lift 1 c in + let homogeneous = Reductionops.is_conv env sigma ty typ in + let sigma, (eq, refl) = + mk_term_eq homogeneous (push_rel_context ctx env) sigma ty (mkRel 1) typ (mkVar id) in + sigma, mkProd (Anonymous, eq, lift 1 concl), [| refl |] + else sigma, concl, [||] + in + (* Abstract by equalities *) + let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) + let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> LocalAssum (Anonymous, x)) eqs) in + let decl = match body with + | None -> LocalAssum (Name id, c) + | Some body -> LocalDef (Name id, body, c) + in + (* Abstract by the "generalized" hypothesis. *) + let genarg = mkProd_or_LetIn decl abseqs in + (* Abstract by the extension of the context *) + let genctyp = it_mkProd_or_LetIn genarg ctx in + (* The goal will become this product. *) + let (sigma, genc) = Evarutil.new_evar env sigma ~principal:true genctyp in + (* Apply the old arguments giving the proper instantiation of the hyp *) + let instc = mkApp (genc, Array.of_list args) in + (* Then apply to the original instantiated hyp. *) + let instc = Option.cata (fun _ -> instc) (mkApp (instc, [| mkVar id |])) body in + (* Apply the reflexivity proofs on the indices. *) + let appeqs = mkApp (instc, Array.of_list refls) in + (* Finally, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) + (sigma, mkApp (appeqs, abshypt)) + end + +let hyps_of_vars env sigma sign nogen hyps = + if Id.Set.is_empty hyps then [] + else + let (_,lh) = + Context.Named.fold_inside + (fun (hs,hl) d -> + 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 + let xvars = global_vars_set_of_decl env sigma d in + if not (Id.Set.is_empty (Id.Set.diff xvars hs)) then + (Id.Set.add x hs, x :: hl) + else (hs, hl)) + ~init:(hyps,[]) + sign + in lh + +exception Seen + +let linear sigma vars args = + let seen = ref vars in + try + Array.iter (fun i -> + let rels = ids_of_constr sigma ~all:true Id.Set.empty i in + let seen' = + Id.Set.fold (fun id acc -> + if Id.Set.mem id acc then raise Seen + else Id.Set.add id acc) + rels !seen + in seen := seen') + args; + true + with Seen -> false + +let is_defined_variable env id = + env |> lookup_named id |> is_local_def + +let abstract_args gl generalize_vars dep id defined f args = + let open Tacmach.New in + let open Context.Rel.Declaration in + let sigma = ref (Tacmach.New.project gl) in + let env = Tacmach.New.pf_env gl in + let concl = Tacmach.New.pf_concl gl in + let dep = dep || local_occur_var !sigma id concl in + let avoid = ref Id.Set.empty in + let get_id name = + let id = new_fresh_id !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") gl in + avoid := Id.Set.add id !avoid; id + in + (* Build application generalized w.r.t. the argument plus the necessary eqs. + From env |- c : forall G, T and args : G we build + (T[G'], G' : ctx, env ; G' |- args' : G, eqs := G'_i = G_i, refls : G' = G, vars to generalize) + + eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *) + *) + let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = + let name, ty, arity = + let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in + let decl = List.hd rel in + RelDecl.get_name decl, RelDecl.get_type decl, c + in + let argty = Tacmach.New.pf_unsafe_type_of gl arg in + let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in + let () = sigma := sigma' in + let lenctx = List.length ctx in + let liftargty = lift lenctx argty in + let leq = constr_cmp !sigma Reduction.CUMUL liftargty ty in + match EConstr.kind !sigma arg with + | Var id when not (is_defined_variable env id) && leq && not (Id.Set.mem id nongenvars) -> + (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, + Id.Set.add id nongenvars, Id.Set.remove id vars, env) + | _ -> + let name = get_id name in + let decl = LocalAssum (Name name, ty) in + let ctx = decl :: ctx in + let c' = mkApp (lift 1 c, [|mkRel 1|]) in + let args = arg :: args in + let liftarg = lift (List.length ctx) arg in + let eq, refl = + if leq then + let sigma', eq = mkEq !sigma (lift 1 ty) (mkRel 1) liftarg in + let sigma', refl = mkRefl sigma' (lift (-lenctx) ty) arg in + sigma := sigma'; eq, refl + else + let sigma', eq = mkHEq !sigma (lift 1 ty) (mkRel 1) liftargty liftarg in + let sigma', refl = mkHRefl sigma' argty arg in + sigma := sigma'; eq, refl + in + let eqs = eq :: lift_list eqs in + let refls = refl :: refls in + let argvars = ids_of_constr !sigma vars arg in + (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, + nongenvars, Id.Set.union argvars vars, env) + in + let f', args' = decompose_indapp !sigma f args in + let dogen, f', args' = + let parvars = ids_of_constr !sigma ~all:true Id.Set.empty f' in + if not (linear !sigma parvars args') then true, f, args + else + match Array.findi (fun i x -> not (isVar !sigma x) || is_defined_variable env (destVar !sigma x)) args' with + | None -> false, f', args' + | Some nonvar -> + let before, after = Array.chop nonvar args' in + true, mkApp (f', before), after + in + if dogen then + let tyf' = Tacmach.New.pf_unsafe_type_of gl f' in + let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = + Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' + in + let args, refls = List.rev args, List.rev refls in + let vars = + if generalize_vars then + let nogen = Id.Set.add id nogen in + hyps_of_vars (pf_env gl) (project gl) (Proofview.Goal.hyps gl) nogen vars + else [] + in + let body, c' = + if defined then Some c', Retyping.get_type_of ctxenv !sigma c' + else None, c' + in + let typ = Tacmach.New.pf_get_hyp_typ id gl in + let tac = make_abstract_generalize (pf_env gl) id typ concl dep ctx body c' eqs args refls in + let tac = Proofview.Unsafe.tclEVARS !sigma <*> tac in + Some (tac, dep, succ (List.length ctx), vars) + else None + +let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = + let open Context.Named.Declaration in + Proofview.Goal.enter begin fun gl -> + Coqlib.(check_required_library jmeq_module_name); + let sigma = Tacmach.New.project gl in + let (f, args, def, id, oldid) = + let oldid = Tacmach.New.pf_get_new_id id gl in + match Tacmach.New.pf_get_hyp id gl with + | LocalAssum (_,t) -> let f, args = decompose_app sigma t in + (f, args, false, id, oldid) + | LocalDef (_,t,_) -> + let f, args = decompose_app sigma t in + (f, args, true, id, oldid) + in + if List.is_empty args then Proofview.tclUNIT () + else + let args = Array.of_list args in + let newc = abstract_args gl generalize_vars force_dep id def f args in + match newc with + | None -> Proofview.tclUNIT () + | Some (tac, dep, n, vars) -> + let tac = + if dep then + Tacticals.New.tclTHENLIST [ + tac; + rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro; + generalize_dep ~with_let:true (mkVar oldid)] + else Tacticals.New.tclTHENLIST [ + tac; + 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 ; + Tacticals.New.tclMAP (fun id -> + Tacticals.New.tclTRY (generalize_dep ~with_let:true (mkVar id))) vars]) + end + +let compare_upto_variables sigma x y = + let rec compare x y = + if (isVar sigma x || isRel sigma x) && (isVar sigma y || isRel sigma y) then true + else compare_constr sigma compare x y + in + compare x y + +let specialize_eqs id = + let open Context.Rel.Declaration in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let ty = Tacmach.New.pf_get_hyp_typ id gl in + let evars = ref (Proofview.Goal.sigma gl) in + let unif env evars c1 c2 = + compare_upto_variables !evars c1 c2 && + (match Evarconv.conv env !evars c1 c2 with + | Some sigma -> evars := sigma; true + | None -> false) + in + let rec aux in_eqs ctx acc ty = + match EConstr.kind !evars ty with + | Prod (na, t, b) -> + (match EConstr.kind !evars t with + | App (eq, [| eqty; x; y |]) when EConstr.is_global !evars Coqlib.(lib_ref "core.eq.type") eq -> + let c = if noccur_between !evars 1 (List.length ctx) x then y else x in + let pt = mkApp (eq, [| eqty; c; c |]) in + let ind = destInd !evars eq in + let p = mkApp (mkConstructUi (ind,0), [| eqty; c |]) in + if unif (push_rel_context ctx env) evars pt t then + aux true ctx (mkApp (acc, [| p |])) (subst1 p b) + else acc, in_eqs, ctx, ty + | App (heq, [| eqty; x; eqty'; y |]) when EConstr.is_global !evars (Lazy.force coq_heq_ref) heq -> + let eqt, c = if noccur_between !evars 1 (List.length ctx) x then eqty', y else eqty, x in + let pt = mkApp (heq, [| eqt; c; eqt; c |]) in + let ind = destInd !evars heq in + let p = mkApp (mkConstructUi (ind,0), [| eqt; c |]) in + if unif (push_rel_context ctx env) evars pt t then + aux true ctx (mkApp (acc, [| p |])) (subst1 p b) + else acc, in_eqs, ctx, ty + | _ -> + if in_eqs then acc, in_eqs, ctx, ty + else + let sigma, e = Evarutil.new_evar (push_rel_context ctx env) !evars t in + evars := sigma; + aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) + | t -> acc, in_eqs, ctx, ty + in + let acc, worked, ctx, ty = aux false [] (mkVar id) ty in + let ctx' = nf_rel_context_evar !evars ctx in + let ctx'' = List.map (function + | LocalDef (n,k,t) when isEvar !evars k -> LocalAssum (n,t) + | decl -> decl) ctx' + in + let ty' = it_mkProd_or_LetIn ty ctx'' in + let acc' = it_mkLambda_or_LetIn acc ctx'' in + let ty' = Tacred.whd_simpl env !evars ty' + and acc' = Tacred.whd_simpl env !evars acc' in + let ty' = Evarutil.nf_evar !evars ty' in + if worked then + Tacticals.New.tclTHENFIRST + (internal_cut true id ty') + (exact_no_check ((* refresh_universes_strict *) acc')) + else + Tacticals.New.tclFAIL 0 (str "Nothing to do in hypothesis " ++ Id.print id) + end + +let specialize_eqs id = Proofview.Goal.enter begin fun gl -> + let msg = str "Specialization not allowed on dependent hypotheses" in + Proofview.tclOR (clear [id]) + (fun _ -> Tacticals.New.tclZEROMSG msg) >>= fun () -> + specialize_eqs id +end + +let occur_rel sigma n c = + let res = not (noccurn sigma n c) in + res + +(* This function splits the products of the induction scheme [elimt] into four + parts: + - branches, easily detectable (they are not referred by rels in the subterm) + - what was found before branches (acc1) that is: parameters and predicates + - what was found after branches (acc3) that is: args and indarg if any + if there is no branch, we try to fill in acc3 with args/indargs. + We also return the conclusion. +*) +let decompose_paramspred_branch_args sigma elimt = + let open Context.Rel.Declaration in + let rec cut_noccur elimt acc2 = + match EConstr.kind sigma elimt with + | Prod(nme,tpe,elimt') -> + let hd_tpe,_ = decompose_app sigma (snd (decompose_prod_assum sigma tpe)) in + if not (occur_rel sigma 1 elimt') && isRel sigma hd_tpe + then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2) + else let acc3,ccl = decompose_prod_assum sigma elimt in acc2 , acc3 , ccl + | App(_, _) | Rel _ -> acc2 , [] , elimt + | _ -> error_ind_scheme "" in + let rec cut_occur elimt acc1 = + match EConstr.kind sigma elimt with + | Prod(nme,tpe,c) when occur_rel sigma 1 c -> cut_occur c (LocalAssum (nme,tpe)::acc1) + | Prod(nme,tpe,c) -> let acc2,acc3,ccl = cut_noccur elimt [] in acc1,acc2,acc3,ccl + | App(_, _) | Rel _ -> acc1,[],[],elimt + | _ -> error_ind_scheme "" in + let acc1, acc2 , acc3, ccl = cut_occur elimt [] in + (* Particular treatment when dealing with a dependent empty type elim scheme: + if there is no branch, then acc1 contains all hyps which is wrong (acc1 + should contain parameters and predicate only). This happens for an empty + type (See for example Empty_set_ind, as False would actually be ok). Then + we must find the predicate of the conclusion to separate params_pred from + args. We suppose there is only one predicate here. *) + match acc2 with + | [] -> + let hyps,ccl = decompose_prod_assum sigma elimt in + let hd_ccl_pred,_ = decompose_app sigma ccl in + begin match EConstr.kind sigma hd_ccl_pred with + | Rel i -> let acc3,acc1 = List.chop (i-1) hyps in acc1 , [] , acc3 , ccl + | _ -> error_ind_scheme "" + end + | _ -> acc1, acc2 , acc3, ccl + + +let exchange_hd_app sigma subst_hd t = + let hd,args= decompose_app sigma t in mkApp (subst_hd,Array.of_list args) + +(* Builds an elim_scheme from its type and calling form (const+binding). We + first separate branches. We obtain branches, hyps before (params + preds), + hyps after (args <+ indarg if present>) and conclusion. Then we proceed as + follows: + + - separate parameters and predicates in params_preds. For that we build: + forall (x1:Ti_1)(xni:Ti_ni) (HI:I prm1..prmp x1...xni), DUMMY x1...xni HI/farg + ^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^ + optional opt + Free rels appearing in this term are parameters (branches should not + appear, and the only predicate would have been Qi but we replaced it by + DUMMY). We guess this heuristic catches all params. TODO: generalize to + the case where args are merged with branches (?) and/or where several + predicates are cited in the conclusion. + + - finish to fill in the elim_scheme: indarg/farg/args and finally indref. *) +let compute_elim_sig sigma ?elimc elimt = + let open Context.Rel.Declaration in + let params_preds,branches,args_indargs,conclusion = + decompose_paramspred_branch_args sigma elimt in + + let ccl = exchange_hd_app sigma (mkVar (Id.of_string "__QI_DUMMY__")) conclusion in + let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in + let nparams = Int.Set.cardinal (free_rels sigma concl_with_args) in + let preds,params = List.chop (List.length params_preds - nparams) params_preds in + + (* A first approximation, further analysis will tweak it *) + let res = ref { empty_scheme with + (* This fields are ok: *) + elimc = elimc; elimt = elimt; concl = conclusion; + predicates = preds; npredicates = List.length preds; + branches = branches; nbranches = List.length branches; + farg_in_concl = isApp sigma ccl && isApp sigma (last_arg sigma ccl); + params = params; nparams = nparams; + (* all other fields are unsure at this point. Including these:*) + args = args_indargs; nargs = List.length args_indargs; } in + try + (* Order of tests below is important. Each of them exits if successful. *) + (* 1- First see if (f x...) is in the conclusion. *) + if !res.farg_in_concl + then begin + res := { !res with + indarg = None; + indarg_in_concl = false; farg_in_concl = true }; + raise Exit + end; + (* 2- If no args_indargs (=!res.nargs at this point) then no indarg *) + if Int.equal !res.nargs 0 then raise Exit; + (* 3- Look at last arg: is it the indarg? *) + ignore ( + match List.hd args_indargs with + | LocalDef (hiname,_,hi) -> error_ind_scheme "" + | LocalAssum (hiname,hi) -> + let hi_ind, hi_args = decompose_app sigma hi in + let hi_is_ind = (* hi est d'un type globalisable *) + match EConstr.kind sigma hi_ind with + | Ind (mind,_) -> true + | Var _ -> true + | Const _ -> true + | Construct _ -> true + | _ -> false in + let hi_args_enough = (* hi a le bon nbre d'arguments *) + Int.equal (List.length hi_args) (List.length params + !res.nargs -1) in + (* FIXME: Ces deux tests ne sont pas suffisants. *) + if not (hi_is_ind && hi_args_enough) then raise Exit (* No indarg *) + else (* Last arg is the indarg *) + res := {!res with + indarg = Some (List.hd !res.args); + indarg_in_concl = occur_rel sigma 1 ccl; + args = List.tl !res.args; nargs = !res.nargs - 1; + }; + raise Exit); + raise Exit(* exit anyway *) + with Exit -> (* Ending by computing indref: *) + match !res.indarg with + | None -> !res (* No indref *) + | Some (LocalDef _) -> error_ind_scheme "" + | Some (LocalAssum (_,ind)) -> + let indhd,indargs = decompose_app sigma ind in + try {!res with indref = Some (fst (Termops.global_of_constr sigma indhd)) } + with e when CErrors.noncritical e -> + error "Cannot find the inductive type of the inductive scheme." + +let compute_scheme_signature evd scheme names_info ind_type_guess = + let open Context.Rel.Declaration in + let f,l = decompose_app evd scheme.concl in + (* Vérifier que les arguments de Qi sont bien les xi. *) + let cond, check_concl = + match scheme.indarg with + | Some (LocalDef _) -> + error "Strange letin, cannot recognize an induction scheme." + | None -> (* Non standard scheme *) + let cond hd = EConstr.eq_constr evd hd ind_type_guess && not scheme.farg_in_concl + in (cond, fun _ _ -> ()) + | Some (LocalAssum (_,ind)) -> (* Standard scheme from an inductive type *) + let indhd,indargs = decompose_app evd ind in + let cond hd = EConstr.eq_constr evd hd indhd in + let check_concl is_pred p = + (* Check again conclusion *) + let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f == IndArg in + let ind_is_ok = + List.equal (fun c1 c2 -> EConstr.eq_constr evd c1 c2) + (List.lastn scheme.nargs indargs) + (Context.Rel.to_extended_list mkRel 0 scheme.args) in + if not (ccl_arg_ok && ind_is_ok) then + error_ind_scheme "the conclusion of" + in (cond, check_concl) + in + let is_pred n c = + let hd = fst (decompose_app evd c) in + match EConstr.kind evd hd with + | Rel q when n < q && q <= n+scheme.npredicates -> IndArg + | _ when cond hd -> RecArg + | _ -> OtherArg + in + let rec check_branch p c = + match EConstr.kind evd c with + | Prod (_,t,c) -> + (is_pred p t, true, not (Vars.noccurn evd 1 c)) :: check_branch (p+1) c + | LetIn (_,_,_,c) -> + (OtherArg, false, not (Vars.noccurn evd 1 c)) :: check_branch (p+1) c + | _ when is_pred p c == IndArg -> [] + | _ -> raise Exit + in + let rec find_branches p lbrch = + match lbrch with + | LocalAssum (_,t) :: brs -> + (try + let lchck_brch = check_branch p t in + let n = List.fold_left + (fun n (b,_,_) -> if b == RecArg then n+1 else n) 0 lchck_brch in + let recvarname, hyprecname, avoid = + make_up_names n scheme.indref names_info in + let namesign = + List.map (fun (b,is_assum,dep) -> + (b,is_assum,dep,if b == IndArg then hyprecname else recvarname)) + lchck_brch in + (avoid,namesign) :: find_branches (p+1) brs + with Exit-> error_ind_scheme "the branches of") + | LocalDef _ :: _ -> error_ind_scheme "the branches of" + | [] -> check_concl is_pred p; [] + in + Array.of_list (find_branches 0 (List.rev scheme.branches)) + +(* Check that the elimination scheme has a form similar to the + elimination schemes built by Coq. Schemes may have the standard + form computed from an inductive type OR (feb. 2006) a non standard + form. That is: with no main induction argument and with an optional + extra final argument of the form (f x y ...) in the conclusion. In + the non standard case, naming of generated hypos is slightly + different. *) +let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info = + let scheme = compute_elim_sig evd ~elimc:elimc elimt in + evd, (compute_scheme_signature evd scheme names_info ind_type_guess, scheme) + +let guess_elim isrec dep s hyp0 gl = + let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in + let (mind, u), _ = Tacmach.New.pf_reduce_to_quantified_ind gl tmptyp0 in + let env = Tacmach.New.pf_env gl in + let sigma = Tacmach.New.project gl in + let sigma, elimc = + if isrec && not (is_nonrec mind) + then + let gr = lookup_eliminator mind s in + Evd.fresh_global env sigma gr + else + let u = EInstance.kind sigma u in + if dep then + let (sigma, ind) = build_case_analysis_scheme env sigma (mind, u) true s in + let ind = EConstr.of_constr ind in + (sigma, ind) + else + let (sigma, ind) = build_case_analysis_scheme_default env sigma (mind, u) s in + let ind = EConstr.of_constr ind in + (sigma, ind) + in + let elimt = Typing.unsafe_type_of env sigma elimc in + sigma, ((elimc, NoBindings), elimt), mkIndU (mind, u) + +let given_elim hyp0 (elimc,lbind as e) gl = + let sigma = Tacmach.New.project gl in + let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in + let ind_type_guess,_ = decompose_app sigma (snd (decompose_prod sigma tmptyp0)) in + let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in + Tacmach.New.project gl, (e, elimt), ind_type_guess + +type scheme_signature = + (Id.Set.t * (elim_arg_kind * bool * bool * Id.t) list) array + +type eliminator_source = + | ElimUsing of (eliminator * EConstr.types) * scheme_signature + | ElimOver of bool * Id.t + +let find_induction_type isrec elim hyp0 gl = + let sigma = Tacmach.New.project gl in + let scheme,elim = + match elim with + | None -> + let sort = Tacticals.New.elimination_sort_of_goal gl in + let _, (elimc,elimt),_ = guess_elim isrec false sort hyp0 gl in + let scheme = compute_elim_sig sigma ~elimc elimt in + (* We drop the scheme waiting to know if it is dependent *) + scheme, ElimOver (isrec,hyp0) + | Some e -> + let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in + let scheme = compute_elim_sig sigma ~elimc elimt in + if Option.is_empty scheme.indarg then error "Cannot find induction type"; + let indsign = compute_scheme_signature evd scheme hyp0 ind_guess in + let elim = ({elimindex = Some(-1); elimbody = elimc; elimrename = None},elimt) in + scheme, ElimUsing (elim,indsign) + in + match scheme.indref with + | None -> error_ind_scheme "" + | Some ref -> ref, scheme.nparams, elim + +let get_elim_signature elim hyp0 gl = + compute_elim_signature (given_elim hyp0 elim gl) hyp0 + +let is_functional_induction elimc gl = + let sigma = Tacmach.New.project gl in + let scheme = compute_elim_sig sigma ~elimc (Tacmach.New.pf_unsafe_type_of gl (fst elimc)) in + (* The test is not safe: with non-functional induction on non-standard + induction scheme, this may fail *) + Option.is_empty scheme.indarg + +(* Wait the last moment to guess the eliminator so as to know if we + need a dependent one or not *) + +let get_eliminator elim dep s gl = + 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 (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (Tacmach.New.project gl) (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 + of lid are parameters (first ones), the other are + arguments. Returns the clause obtained. *) +let recolle_clenv i params args elimclause gl = + let _,arr = destApp elimclause.evd elimclause.templval.rebus in + let lindmv = + Array.map + (fun x -> + match EConstr.kind elimclause.evd x with + | Meta mv -> mv + | _ -> 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 , pf_get_hyp_typ id gl, lindmv.(i)) + 0 params in + let clauses_args = + 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. *) + List.fold_right + (fun e acc -> + let x,y,i = e in + (* 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 elimclause' = clenv_fchain ~with_univs:false i acc indclause in + elimclause') + (List.rev clauses) + elimclause + +(* Unification of the goal and the principle applied to meta variables: + (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 = + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in + let i = match i with None -> index_of_ind_arg sigma elimt | Some i -> i in + (* elimclause contains this: (elimc ?i ?j ?k...?l) *) + let elimc = contract_letin_in_lam_header sigma elimc in + let elimc = mkCast (elimc, DEFAULTcast, elimt) in + let elimclause = Tacmach.New.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 + 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 with_evars hyp0 inhyps elim indvars names induct_tac = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let concl = Tacmach.New.pf_concl gl in + let statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env sigma in + let dep_in_concl = Option.cata (fun id -> occur_var env sigma id concl) false hyp0 in + let dep = dep_in_hyps || dep_in_concl in + let tmpcl = it_mkNamedProd_or_LetIn concl deps in + let s = Retyping.get_sort_family_of env sigma tmpcl in + let deps_cstr = + List.fold_left + (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 gl in + let branchletsigns = + let f (_,is_not_let,_,_) = is_not_let in + Array.map (fun (_,l) -> List.map f l) indsign in + let names = compute_induction_names branchletsigns names in + Array.iter (check_name_unicity env toclear []) names; + let tac = + (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) + (Tacticals.New.tclTHENLIST [ + (* Generalize dependent hyps (but not args) *) + if deps = [] then Proofview.tclUNIT () else apply_type ~typecheck:false tmpcl deps_cstr; + (* side-conditions in elim (resp case) schemes come last (resp first) *) + induct_tac elim; + Tacticals.New.tclMAP expand_hyp toclear; + ]) + (Array.map2 + (induct_discharge with_evars lhyp0 avoid + (re_intro_dependent_hypotheses statuslists)) + indsign names) + in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac + end + +let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyps = + Proofview.Goal.enter begin fun gl -> + let elim_info = find_induction_type isrec elim hyp0 gl in + atomize_param_of_ind_then elim_info hyp0 (fun indvars -> + 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 = + str"Not the right number of induction arguments (expected " ++ + pr_enum (fun x -> x) [ + if scheme.farg_in_concl then str "the function name" else mt(); + if scheme.nparams != 0 then int scheme.nparams ++ str (String.plural scheme.nparams " parameter") else mt (); + if scheme.nargs != 0 then int scheme.nargs ++ str (String.plural scheme.nargs " argument") else mt ()] ++ str ")." + +(* Induction on a list of induction arguments. Analyze the elim + scheme (which is mandatory for multiple ind args), check that all + parameters and arguments are given (mandatory too). + Main differences with induction_from_context is that there is no + main induction argument. On the other hand, all args and params + must be given, so we help a bit the unifier by making the "pattern" + by hand before calling induction_tac *) +let induction_without_atomization isrec with_evars elim names lid = + Proofview.Goal.enter begin fun gl -> + let sigma, (indsign,scheme) = get_elim_signature elim (List.hd lid) gl in + let nargs_indarg_farg = + scheme.nargs + (if scheme.farg_in_concl then 1 else 0) in + if not (Int.equal (List.length lid) (scheme.nparams + nargs_indarg_farg)) + then + Tacticals.New.tclZEROMSG (msg_not_right_number_induction_arguments scheme) + else + let indvars,lid_params = List.chop nargs_indarg_farg lid in + (* terms to patternify we must patternify indarg or farg if present in concl *) + let realindvars = List.rev (if scheme.farg_in_concl then List.tl indvars else indvars) in + let lidcstr = List.map mkVar (List.rev indvars) in + let params = List.rev lid_params in + let indvars = + (* Temporary hack for compatibility, while waiting for better + analysis of the form of induction schemes: a scheme like + gt_wf_rec was taken as a functional scheme with no parameters, + 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 List.is_empty indvars then Id.Set.singleton (List.hd lid_params) else Id.Set.of_list indvars in + let induct_tac elim = Tacticals.New.tclTHENLIST [ + (* pattern to make the predicate appear. *) + 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 + let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in + 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 = + Proofview.Goal.enter begin fun gl -> + if occur_var (Tacmach.New.pf_env gl) (Tacmach.New.project gl) id (Tacmach.New.pf_concl gl) && + cls.concl_occs == NoOccurrences + then user_err + (str "Conclusion must be mentioned: it depends on " ++ Id.print id + ++ str "."); + match cls.onhyps with + | Some hyps -> + let to_erase d = + 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 (Tacmach.New.pf_env gl) (Tacmach.New.project gl) id d in + if List.exists test (id::inhyps) then Some id' else None in + 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 typ = + if elim == None then + (* w/o an scheme, the term has to be applied at least until + obtaining an inductive type (even though the arity might be + known only by pattern-matching, as in the case of a term of + the form "nat_rect ?A ?o ?s n", with ?A to be inferred by + matching. *) + let sign,t = splay_prod env sigma typ in it_mkProd t sign + else + (* Otherwise, we exclude the case of an induction argument in an + explicitly functional type. Henceforth, we can complete the + pattern until it has as type an atomic type (even though this + atomic type can hide a functional type, for which the "using" + clause has a scheme). *) + typ in + let rec find_clause typ = + try + let indclause = make_clenv_binding env sigma (c,typ) lbind in + if must_be_closed && occur_meta indclause.evd (clenv_value indclause) then + error "Need a fully applied argument."; + (* We lose the possibility of coercions in with-bindings *) + pose_all_metas_as_evars env indclause.evd (clenv_value indclause) + with e when catchable_exception e -> + try find_clause (try_red_product env sigma typ) + with Redelimination -> raise e in + find_clause typ + +let check_expected_type env sigma (elimc,bl) elimt = + (* Compute the expected template type of the term in case a using + clause is given *) + let sign,_ = splay_prod env sigma elimt in + let n = List.length sign in + if n == 0 then error "Scheme cannot be applied."; + let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in + let sigma = solve_evar_clause env sigma true cl bl in + let (_,u,_) = destProd sigma cl.cl_concl in + fun t -> Option.has_some (Evarconv.cumul env sigma t u) + +let check_enough_applied env sigma elim = + (* A heuristic to decide whether the induction arg is enough applied *) + match elim with + | None -> + (* No eliminator given *) + fun u -> + let t,_ = decompose_app sigma (whd_all env sigma u) in isInd sigma t + | Some elimc -> + let elimt = Retyping.get_type_of env sigma (fst elimc) in + let scheme = compute_elim_sig sigma ~elimc elimt in + match scheme.indref with + | None -> + (* in the absence of information, do not assume it may be + partially applied *) + fun _ -> true + | Some _ -> + (* Last argument is supposed to be the induction argument *) + check_expected_type env sigma elimc elimt + +let guard_no_unifiable = Proofview.guard_no_unifiable >>= function + | None -> Proofview.tclUNIT () + | Some l -> + Proofview.tclENV >>= function env -> + Proofview.tclEVARMAP >>= function sigma -> + Proofview.tclZERO (RefinerError (env, sigma, UnresolvedBindings l)) + +let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim + id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let ccl = Proofview.Goal.concl gl in + let check = check_enough_applied env sigma elim in + let (sigma', c) = use_bindings env sigma elim false (c0,lbind) t0 in + let abs = AbstractPattern (from_prefix,check,Name id,(pending,c),cls,false) in + let (id,sign,_,lastlhyp,ccl,res) = make_abstraction env sigma' ccl abs in + match res with + | None -> + (* pattern not found *) + let with_eq = Option.map (fun eq -> (false,mk_eq_name env id eq)) eqname in + let inhyps = if List.is_empty inhyps then inhyps else Option.fold_left (fun inhyps (_,heq) -> heq::inhyps) inhyps with_eq in + (* we restart using bindings after having tried type-class + resolution etc. on the term given by the user *) + let flags = tactic_infer_flags (with_evars && (* do not give a success semantics to edestruct on an open term yet *) false) in + let (sigma, c0) = finish_evar_resolution ~flags env sigma (pending,c0) in + let tac = + (if isrec then + (* Historically, induction has side conditions last *) + Tacticals.New.tclTHENFIRST + else + (* and destruct has side conditions first *) + Tacticals.New.tclTHENLAST) + (Tacticals.New.tclTHENLIST [ + Refine.refine ~typecheck:false begin fun sigma -> + let b = not with_evars && with_eq != None in + let (sigma, c) = use_bindings env sigma elim b (c0,lbind) t0 in + let t = Retyping.get_type_of env sigma c in + mkletin_goal env sigma with_eq false (id,lastlhyp,ccl,c) (Some t) + end; + if with_evars then Proofview.shelve_unifiable else guard_no_unifiable; + if is_arg_pure_hyp + then Proofview.tclEVARMAP >>= fun sigma -> Tacticals.New.tclTRY (clear [destVar sigma c0]) + else Proofview.tclUNIT (); + if isrec then Proofview.cycle (-1) else Proofview.tclUNIT () + ]) + (tac inhyps) + in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac + + | Some (sigma', c) -> + (* pattern found *) + (* TODO: if ind has predicate parameters, use JMeq instead of eq *) + let env = reset_with_named_context sign env in + let with_eq = Option.map (fun eq -> (false,mk_eq_name env id eq)) eqname in + let inhyps = if List.is_empty inhyps then inhyps else Option.fold_left (fun inhyps (_,heq) -> heq::inhyps) inhyps with_eq in + let tac = + Tacticals.New.tclTHENLIST [ + Refine.refine ~typecheck:false begin fun sigma -> + mkletin_goal env sigma with_eq true (id,lastlhyp,ccl,c) None + end; + (tac inhyps) + ] + in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma') tac + end + +let has_generic_occurrences_but_goal cls id env sigma ccl = + clause_with_generic_context_selection cls && + (* TODO: whd_evar of goal *) + (cls.concl_occs != NoOccurrences || not (occur_var env sigma id ccl)) + +let induction_gen clear_flag isrec with_evars elim + ((_pending,(c,lbind)),(eqname,names) as arg) cls = + let inhyps = match cls with + | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps + | _ -> [] in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let evd = Proofview.Goal.sigma gl in + let ccl = Proofview.Goal.concl gl in + let cls = Option.default allHypsAndConcl cls in + let t = typ_of env evd c in + let is_arg_pure_hyp = + isVar evd c && not (mem_named_context_val (destVar evd c) (Global.named_context_val ())) + && lbind == NoBindings && not with_evars && Option.is_empty eqname + && clear_flag == None + && has_generic_occurrences_but_goal cls (destVar evd c) env evd ccl in + let enough_applied = check_enough_applied env evd elim t in + if is_arg_pure_hyp && enough_applied then + (* First case: induction on a variable already in an inductive type and + with maximal abstraction over the variable. + This is a situation where the induction argument is a + clearable variable of the goal w/o occurrence selection + and w/o equality kept: no need to generalize *) + let id = destVar evd c in + Tacticals.New.tclTHEN + (clear_unselected_context id inhyps cls) + (induction_with_atomization_of_ind_arg + isrec with_evars elim names id inhyps) + else + (* Otherwise, we look for the pattern, possibly adding missing arguments and + declaring the induction argument as a new local variable *) + let id = + (* Type not the right one if partially applied but anyway for internal use*) + let x = id_of_name_using_hdchar env evd t Anonymous in + new_fresh_id Id.Set.empty x gl in + let info_arg = (is_arg_pure_hyp, not enough_applied) in + pose_induction_arg_then + isrec with_evars info_arg elim id arg t inhyps cls + (induction_with_atomization_of_ind_arg + isrec with_evars elim names id) + end + +(* Induction on a list of arguments. First make induction arguments + atomic (using letins), then do induction. The specificity here is + that all arguments and parameters of the scheme are given + (mandatory for the moment), so we don't need to deal with + parameters of the inductive type as in induction_gen. *) +let induction_gen_l isrec with_evars elim names lc = + let newlc = ref [] in + let lc = List.map (function + | (c,None) -> c + | (c,Some{CAst.loc;v=eqname}) -> + 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' -> + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma c with + | Var id when not (mem_named_context_val id (Global.named_context_val ())) + && not with_evars -> + let () = newlc:= id::!newlc in + atomize_list l' + + | _ -> + Proofview.Goal.enter begin fun gl -> + let type_of = Tacmach.New.pf_unsafe_type_of gl in + let sigma = Tacmach.New.project gl in + Proofview.tclENV >>= fun env -> + let x = + id_of_name_using_hdchar env sigma (type_of c) Anonymous in + + let id = new_fresh_id Id.Set.empty x gl in + let newl' = List.map (fun r -> replace_term sigma c (mkVar id) r) l' in + let () = newlc:=id::!newlc in + Tacticals.New.tclTHEN + (letin_tac None (Name id) c None allHypsAndConcl) + (atomize_list newl') + end in + Tacticals.New.tclTHENLIST + [ + (atomize_list lc); + (Proofview.tclUNIT () >>= fun () -> (* ensure newlc has been computed *) + induction_without_atomization isrec with_evars elim names !newlc) + ] + +(* Induction either over a term, over a quantified premisse, or over + several quantified premisses (like with functional induction + principles). + TODO: really unify induction with one and induction with several + args *) +let induction_destruct isrec with_evars (lc,elim) = + match lc with + | [] -> assert false (* ensured by syntax, but if called inside caml? *) + | [c,(eqname,names as allnames),cls] -> + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + match elim with + | Some elim when is_functional_induction elim gl -> + (* 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 _,c = force_destruction_arg false env sigma c in + onInductionArg + (fun _clear_flag c -> + induction_gen_l isrec with_evars elim names + [with_no_bindings c,eqname]) c + | _ -> + (* standard induction *) + onOpenInductionArg env sigma + (fun clear_flag c -> induction_gen clear_flag isrec with_evars elim (c,allnames) cls) c + end + | _ -> + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + match elim with + | None -> + (* Several arguments, without "using" clause *) + (* TODO: Do as if the arguments after the first one were called with *) + (* "destruct", but selecting occurrences on the initial copy of *) + (* the goal *) + let (a,b,cl) = List.hd lc in + let l = List.tl lc in + (* TODO *) + Tacticals.New.tclTHEN + (onOpenInductionArg env sigma (fun clear_flag a -> + induction_gen clear_flag isrec with_evars None (a,b) cl) a) + (Tacticals.New.tclMAP (fun (a,b,cl) -> + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + onOpenInductionArg env sigma (fun clear_flag a -> + induction_gen clear_flag false with_evars None (a,b) cl) a + end) l) + | Some elim -> + (* Several induction hyps with induction scheme *) + 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."; + (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 *) + let names,rest = List.sep_last (List.map snd newlc) in + if List.exists (fun n -> not (Option.is_empty n)) rest then + error "'as' clause with multiple arguments and 'using' clause can only occur last."; + let newlc = List.map (fun (x,_) -> (x,None)) newlc in + induction_gen_l isrec with_evars elim names newlc + end + +let induction ev clr c l e = + induction_gen clr true ev e + ((Evd.empty,(c,NoBindings)),(None,l)) None + +let destruct ev clr c l e = + induction_gen clr false ev e + ((Evd.empty,(c,NoBindings)),(None,l)) None + +(* + * Eliminations giving the type instead of the proof. + * These tactics use the default elimination constant and + * no substitutions at all. + * May be they should be integrated into Elim ... + *) + +let elim_scheme_type elim t = + Proofview.Goal.enter begin fun gl -> + let clause = mk_clenv_type_of gl elim in + match EConstr.kind clause.evd (last_arg clause.evd clause.templval.rebus) with + | Meta mv -> + let clause' = + (* t is inductive, then CUMUL or CONV is irrelevant *) + clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t + (clenv_meta_type clause mv) clause in + Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false + | _ -> anomaly (Pp.str "elim_scheme_type.") + end + +let elim_type t = + Proofview.Goal.enter begin fun gl -> + let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in + let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t) + end + +let case_type t = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Tacmach.New.pf_env gl in + let ((ind, u), t) = reduce_to_atomic_ind env sigma t in + let u = EInstance.kind sigma u in + let s = Tacticals.New.elimination_sort_of_goal gl in + let (evd, elimc) = build_case_analysis_scheme_default env sigma (ind, u) s in + let elimc = EConstr.of_constr elimc in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t) + end + + +(************************************************) +(* Tactics related with logic connectives *) +(************************************************) + +(* Reflexivity tactics *) + +let (forward_setoid_reflexivity, setoid_reflexivity) = Hook.make () + +let maybe_betadeltaiota_concl allowred gl = + let concl = Tacmach.New.pf_concl gl in + let sigma = Tacmach.New.project gl in + if not allowred then concl + else + let env = Proofview.Goal.env gl in + whd_all env sigma concl + +let reflexivity_red allowred = + Proofview.Goal.enter begin fun gl -> + (* PL: usual reflexivity don't perform any reduction when searching + for an equality, but we may need to do some when called back from + inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) + let sigma = Tacmach.New.project gl in + let concl = maybe_betadeltaiota_concl allowred gl in + match match_with_equality_type sigma concl with + | None -> Proofview.tclZERO NoEquationFound + | Some _ -> one_constructor 1 NoBindings + end + +let reflexivity = + Proofview.tclORELSE + (reflexivity_red false) + begin function (e, info) -> match e with + | NoEquationFound -> Hook.get forward_setoid_reflexivity + | e -> Proofview.tclZERO ~info e + end + +let intros_reflexivity = (Tacticals.New.tclTHEN intros reflexivity) + +(* Symmetry tactics *) + +(* This tactic first tries to apply a constant named sym_eq, where eq + is the name of the equality predicate. If this constant is not + defined and the conclusion is a=b, it solves the goal doing (Cut + b=a;Intro H;Case H;Constructor 1) *) + +let (forward_setoid_symmetry, setoid_symmetry) = Hook.make () + +(* This is probably not very useful any longer *) +let prove_symmetry hdcncl eq_kind = + let symc = + match eq_kind with + | MonomorphicLeibnizEq (c1,c2) -> mkApp(hdcncl,[|c2;c1|]) + | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp(hdcncl,[|typ;c2;c1|]) + | HeterogenousEq (t1,c1,t2,c2) -> mkApp(hdcncl,[|t2;c2;t1;c1|]) in + Tacticals.New.tclTHENFIRST (cut symc) + (Tacticals.New.tclTHENLIST + [ intro; + Tacticals.New.onLastHyp simplest_case; + one_constructor 1 NoBindings ]) + +let match_with_equation sigma c = + Proofview.tclENV >>= fun env -> + try + let res = match_with_equation env sigma c in + Proofview.tclUNIT res + with NoEquationFound -> + Proofview.tclZERO NoEquationFound + +let symmetry_red allowred = + Proofview.Goal.enter begin fun gl -> + (* PL: usual symmetry don't perform any reduction when searching + for an equality, but we may need to do some when called back from + inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) + let sigma = Tacmach.New.project gl in + let concl = maybe_betadeltaiota_concl allowred gl in + match_with_equation sigma concl >>= fun with_eqn -> + match with_eqn with + | Some eq_data,_,_ -> + Tacticals.New.tclTHEN + (convert_concl_no_check concl DEFAULTcast) + (Tacticals.New.pf_constr_of_global eq_data.sym >>= apply) + | None,eq,eq_kind -> prove_symmetry eq eq_kind + end + +let symmetry = + Proofview.tclORELSE + (symmetry_red false) + begin function (e, info) -> match e with + | NoEquationFound -> Hook.get forward_setoid_symmetry + | e -> Proofview.tclZERO ~info e + end + +let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make () + + +let symmetry_in id = + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in + let sign,t = decompose_prod_assum sigma ctype in + Proofview.tclORELSE + begin + match_with_equation sigma t >>= fun (_,hdcncl,eq) -> + let symccl = + match eq with + | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |]) + | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |]) + | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in + Tacticals.New.tclTHENS (cut (EConstr.it_mkProd_or_LetIn symccl sign)) + [ intro_replacing id; + Tacticals.New.tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ] + end + begin function (e, info) -> match e with + | NoEquationFound -> Hook.get forward_setoid_symmetry_in id + | e -> Proofview.tclZERO ~info e + end + end + +let intros_symmetry = + Tacticals.New.onClause + (function + | None -> Tacticals.New.tclTHEN intros symmetry + | Some id -> symmetry_in id) + +(* Transitivity tactics *) + +(* This tactic first tries to apply a constant named eq_trans, where eq + is the name of the equality predicate. If this constant is not + defined and the conclusion is a=b, it solves the goal doing + Cut x1=x2; + [Cut x2=x3; [Intros e1 e2; Case e2;Assumption + | Idtac] + | Idtac] + --Eduardo (19/8/97) +*) + +let (forward_setoid_transitivity, setoid_transitivity) = Hook.make () + + +(* This is probably not very useful any longer *) +let prove_transitivity hdcncl eq_kind t = + Proofview.Goal.enter begin fun gl -> + let (eq1,eq2) = match eq_kind with + | MonomorphicLeibnizEq (c1,c2) -> + mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]) + | PolymorphicLeibnizEq (typ,c1,c2) -> + mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |]) + | HeterogenousEq (typ1,c1,typ2,c2) -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let type_of = Typing.unsafe_type_of env sigma in + let typt = type_of t in + (mkApp(hdcncl, [| typ1; c1; typt ;t |]), + mkApp(hdcncl, [| typt; t; typ2; c2 |])) + in + Tacticals.New.tclTHENFIRST (cut eq2) + (Tacticals.New.tclTHENFIRST (cut eq1) + (Tacticals.New.tclTHENLIST + [ Tacticals.New.tclDO 2 intro; + Tacticals.New.onLastHyp simplest_case; + assumption ])) + end + +let transitivity_red allowred t = + Proofview.Goal.enter begin fun gl -> + (* PL: usual transitivity don't perform any reduction when searching + for an equality, but we may need to do some when called back from + inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) + let sigma = Tacmach.New.project gl in + let concl = maybe_betadeltaiota_concl allowred gl in + match_with_equation sigma concl >>= fun with_eqn -> + match with_eqn with + | Some eq_data,_,_ -> + Tacticals.New.tclTHEN + (convert_concl_no_check concl DEFAULTcast) + (match t with + | None -> Tacticals.New.pf_constr_of_global eq_data.trans >>= eapply + | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans >>= fun trans -> apply_list [trans; t]) + | None,eq,eq_kind -> + match t with + | None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.") + | Some t -> prove_transitivity eq eq_kind t + end + +let transitivity_gen t = + Proofview.tclORELSE + (transitivity_red false t) + begin function (e, info) -> match e with + | NoEquationFound -> Hook.get forward_setoid_transitivity t + | e -> Proofview.tclZERO ~info e + end + +let etransitivity = transitivity_gen None +let transitivity t = transitivity_gen (Some t) + +let intros_transitivity n = Tacticals.New.tclTHEN intros (transitivity_gen n) + +let constr_eq ~strict x y = + let fail = Tacticals.New.tclFAIL 0 (str "Not equal") in + let fail_universes = Tacticals.New.tclFAIL 0 (str "Not equal (due to universes)") in + Proofview.Goal.enter begin fun gl -> + let env = Tacmach.New.pf_env gl in + let evd = Tacmach.New.project gl in + match EConstr.eq_constr_universes env evd x y with + | Some csts -> + let csts = UnivProblem.to_constraints ~force_weak:false (Evd.universes evd) csts in + if strict then + if Evd.check_constraints evd csts then Proofview.tclUNIT () + else fail_universes + else + (match Evd.add_constraints evd csts with + | evd -> Proofview.Unsafe.tclEVARS evd + | exception Univ.UniverseInconsistency _ -> + fail_universes) + | None -> fail + end + +let unify ?(state=TransparentState.full) x y = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + try + let core_flags = + { (default_unify_flags ()).core_unify_flags with + modulo_delta = state; + modulo_conv_on_closed_terms = Some state} in + (* What to do on merge and subterm flags?? *) + let flags = { (default_unify_flags ()) with + core_unify_flags = core_flags; + merge_unify_flags = core_flags; + subterm_unify_flags = { core_flags with modulo_delta = TransparentState.empty } } + in + let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in + Proofview.Unsafe.tclEVARS sigma + with e when CErrors.noncritical e -> + Proofview.tclZERO (PretypeError (env, sigma, CannotUnify (x, y, None))) + end + +module Simple = struct + (** Simplified version of some of the above tactics *) + + let intro x = intro_move (Some x) MoveLast + + let apply c = + apply_with_bindings_gen false false [None,(CAst.make (c,NoBindings))] + let eapply c = + apply_with_bindings_gen false true [None,(CAst.make (c,NoBindings))] + let elim c = elim false None (c,NoBindings) None + let case c = general_case_analysis false None (c,NoBindings) + + let apply_in id c = + apply_in false false id [None,(CAst.make (c, NoBindings))] None + +end + + +(** Tacticals defined directly in term of Proofview *) +module New = struct + open Genredexpr + open Locus + + let reduce_after_refine = + reduce + (Lazy {rBeta=true;rMatch=true;rFix=true;rCofix=true; + rZeta=false;rDelta=false;rConst=[]}) + {onhyps = Some []; concl_occs = AllOccurrences } + + let refine ~typecheck c = + Refine.refine ~typecheck c <*> + reduce_after_refine +end diff --git a/tactics/tactics.mli b/tactics/tactics.mli new file mode 100644 index 0000000000..75b5caaa36 --- /dev/null +++ b/tactics/tactics.mli @@ -0,0 +1,462 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open EConstr +open Environ +open Evd +open Clenv +open Redexpr +open Pattern +open Unification +open Tactypes +open Locus +open Ltac_pretype + +(** 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. } *) + +val is_quantified_hypothesis : Id.t -> Proofview.Goal.t -> bool + +(** {6 Primitive tactics. } *) + +val introduction : Id.t -> unit Proofview.tactic +val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic +val convert_hyp : ?check:bool -> named_declaration -> unit Proofview.tactic +val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic +val convert_hyp_no_check : named_declaration -> unit Proofview.tactic +val mutual_fix : + Id.t -> int -> (Id.t * int * constr) list -> int -> unit Proofview.tactic +val fix : Id.t -> int -> unit Proofview.tactic +val mutual_cofix : Id.t -> (Id.t * constr) list -> int -> unit Proofview.tactic +val cofix : Id.t -> unit Proofview.tactic + +val convert : constr -> constr -> unit Proofview.tactic +val convert_leq : constr -> constr -> unit Proofview.tactic + +(** {6 Introduction tactics. } *) + +val fresh_id_in_env : Id.Set.t -> Id.t -> env -> Id.t +val fresh_id : Id.Set.t -> Id.t -> Goal.goal sigma -> Id.t +val find_intro_names : rel_context -> Goal.goal sigma -> Id.t list + +val intro : unit Proofview.tactic +val introf : unit Proofview.tactic +val intro_move : Id.t option -> Id.t Logic.move_location -> unit Proofview.tactic +val intro_move_avoid : Id.t option -> Id.Set.t -> Id.t Logic.move_location -> unit Proofview.tactic + + (** [intro_avoiding idl] acts as intro but prevents the new Id.t + to belong to [idl] *) +val intro_avoiding : Id.Set.t -> unit Proofview.tactic + +val intro_replacing : Id.t -> unit Proofview.tactic +val intro_using : Id.t -> unit Proofview.tactic +val intro_mustbe_force : Id.t -> unit Proofview.tactic +val intro_then : (Id.t -> unit Proofview.tactic) -> unit Proofview.tactic +val intros_using : Id.t list -> unit Proofview.tactic +val intros_replacing : Id.t list -> unit Proofview.tactic +val intros_possibly_replacing : Id.t list -> unit Proofview.tactic + +(** [auto_intros_tac names] handles Automatic Introduction of binders *) +val auto_intros_tac : Names.Name.t list -> unit Proofview.tactic + +val intros : unit Proofview.tactic + +(** [depth_of_quantified_hypothesis b h g] returns the index of [h] in + the conclusion of goal [g], up to head-reduction if [b] is [true] *) +val depth_of_quantified_hypothesis : + bool -> quantified_hypothesis -> Proofview.Goal.t -> int + +val intros_until : quantified_hypothesis -> unit Proofview.tactic + +val intros_clearing : bool list -> unit Proofview.tactic + +(** Assuming a tactic [tac] depending on an hypothesis Id.t, + [try_intros_until tac arg] first assumes that arg denotes a + quantified hypothesis (denoted by name or by index) and try to + introduce it in context before to apply [tac], otherwise assume the + hypothesis is already in context and directly apply [tac] *) + +val try_intros_until : + (Id.t -> unit Proofview.tactic) -> quantified_hypothesis -> unit Proofview.tactic + +type evars_flag = bool (* true = pose evars false = fail on evars *) +type rec_flag = bool (* true = recursive false = not recursive *) +type advanced_flag = bool (* true = advanced false = basic *) +type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) + +(** Apply a tactic on a quantified hypothesis, an hypothesis in context + or a term with bindings *) + +type 'a core_destruction_arg = + | ElimOnConstr of 'a + | ElimOnIdent of lident + | ElimOnAnonHyp of int + +type 'a destruction_arg = + clear_flag * 'a core_destruction_arg + +val onInductionArg : + (clear_flag -> constr with_bindings -> 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 *) + +val use_clear_hyp_by_default : unit -> bool + +(** {6 Introduction tactics with eliminations. } *) + +val intro_patterns : evars_flag -> intro_patterns -> unit Proofview.tactic +val intro_patterns_to : evars_flag -> Id.t Logic.move_location -> intro_patterns -> + unit Proofview.tactic +val intro_patterns_bound_to : evars_flag -> int -> Id.t Logic.move_location -> intro_patterns -> + unit Proofview.tactic +val intro_pattern_to : evars_flag -> Id.t Logic.move_location -> delayed_open_constr intro_pattern_expr -> + unit Proofview.tactic + +(** Implements user-level "intros", with [] standing for "**" *) +val intros_patterns : evars_flag -> intro_patterns -> unit Proofview.tactic + +(** {6 Exact tactics. } *) + +val assumption : unit Proofview.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 -> unit Proofview.tactic + +(** {6 Reduction tactics. } *) + +type tactic_reduction = Reductionops.reduction_function +type e_tactic_reduction = Reductionops.e_reduction_function + +type change_arg = patvar_map -> env -> evar_map -> evar_map * constr + +val make_change_arg : constr -> change_arg +val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic +val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic +val reduct_in_concl : tactic_reduction * cast_kind -> unit Proofview.tactic +val e_reduct_in_concl : check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic +val change_in_concl : (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic +val change_concl : constr -> unit Proofview.tactic +val change_in_hyp : (occurrences * constr_pattern) option -> change_arg -> + hyp_location -> unit Proofview.tactic +val red_in_concl : unit Proofview.tactic +val red_in_hyp : hyp_location -> unit Proofview.tactic +val red_option : goal_location -> unit Proofview.tactic +val hnf_in_concl : unit Proofview.tactic +val hnf_in_hyp : hyp_location -> unit Proofview.tactic +val hnf_option : goal_location -> unit Proofview.tactic +val simpl_in_concl : unit Proofview.tactic +val simpl_in_hyp : hyp_location -> unit Proofview.tactic +val simpl_option : goal_location -> unit Proofview.tactic +val normalise_in_concl : unit Proofview.tactic +val normalise_in_hyp : hyp_location -> unit Proofview.tactic +val normalise_option : goal_location -> unit Proofview.tactic +val normalise_vm_in_concl : unit Proofview.tactic +val unfold_in_concl : + (occurrences * evaluable_global_reference) list -> unit Proofview.tactic +val unfold_in_hyp : + (occurrences * evaluable_global_reference) list -> hyp_location -> unit Proofview.tactic +val unfold_option : + (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic +val change : + 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 +val unfold_constr : GlobRef.t -> unit Proofview.tactic + +(** {6 Modification of the local context. } *) + +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 -> intro_pattern option -> unit Proofview.tactic + +val move_hyp : Id.t -> Id.t Logic.move_location -> unit Proofview.tactic +val rename_hyp : (Id.t * Id.t) list -> unit Proofview.tactic + +val revert : Id.t list -> unit Proofview.tactic + +(** {6 Resolution tactics. } *) + +val apply_type : typecheck:bool -> constr -> constr list -> unit Proofview.tactic +val bring_hyps : named_context -> unit Proofview.tactic + +val apply : constr -> unit Proofview.tactic +val eapply : constr -> unit Proofview.tactic + +val apply_with_bindings_gen : + advanced_flag -> evars_flag -> (clear_flag * constr with_bindings CAst.t) list -> unit Proofview.tactic + +val apply_with_delayed_bindings_gen : + advanced_flag -> evars_flag -> (clear_flag * delayed_open_constr_with_bindings CAst.t) list -> unit Proofview.tactic + +val apply_with_bindings : constr with_bindings -> unit Proofview.tactic +val eapply_with_bindings : constr with_bindings -> unit Proofview.tactic + +val cut_and_apply : constr -> unit Proofview.tactic + +val apply_in : + advanced_flag -> evars_flag -> Id.t -> + (clear_flag * constr with_bindings CAst.t) list -> + intro_pattern option -> unit Proofview.tactic + +val apply_delayed_in : + advanced_flag -> evars_flag -> Id.t -> + (clear_flag * delayed_open_constr_with_bindings CAst.t) list -> + intro_pattern option -> unit Proofview.tactic + +(** {6 Elimination tactics. } *) + +(* + The general form of an induction principle is the following: + + forall prm1 prm2 ... prmp, (induction parameters) + forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates) + branch1, branch2, ... , branchr, (branches of the principle) + forall (x1:Ti_1) (x2:Ti_2) ... (xni:Ti_ni), (induction arguments) + (HI: I prm1..prmp x1...xni) (optional main induction arg) + -> (Qi x1...xni HI (f prm1...prmp x1...xni)).(conclusion) + ^^ ^^^^^^^^^^^^^^^^^^^^^^^^ + optional optional + even if HI argument added if principle + present above generated by functional induction + [indarg] [farg] + + HI is not present when the induction principle does not come directly from an + inductive type (like when it is generated by functional induction for + example). HI is present otherwise BUT may not appear in the conclusion + (dependent principle). HI and (f...) cannot be both present. + + Principles taken from functional induction have the final (f...). +*) + +(** [rel_contexts] and [rel_declaration] actually contain triples, and + lists are actually in reverse order to fit [compose_prod]. *) +type elim_scheme = { + elimc: constr with_bindings option; + elimt: types; + indref: GlobRef.t option; + params: rel_context; (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) + nparams: int; (** number of parameters *) + predicates: rel_context; (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) + npredicates: int; (** Number of predicates *) + branches: rel_context; (** branchr,...,branch1 *) + nbranches: int; (** Number of branches *) + args: rel_context; (** (xni, Ti_ni) ... (x1, Ti_1) *) + nargs: int; (** number of arguments *) + indarg: rel_declaration option; (** Some (H,I prm1..prmp x1...xni) + if HI is in premisses, None otherwise *) + concl: types; (** Qi x1...xni HI (f...), HI and (f...) + are optional and mutually exclusive *) + indarg_in_concl: bool; (** true if HI appears at the end of conclusion *) + farg_in_concl: bool; (** true if (f...) appears at the end of conclusion *) +} + +val compute_elim_sig : evar_map -> ?elimc:constr with_bindings -> types -> elim_scheme + +(** elim principle with the index of its inductive arg *) +type eliminator = { + elimindex : int option; (** None = find it automatically *) + elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *) + elimbody : constr with_bindings +} + +val general_elim : evars_flag -> clear_flag -> + constr with_bindings -> eliminator -> unit Proofview.tactic + +val general_elim_clause : evars_flag -> unify_flags -> Id.t option -> + clausenv -> eliminator -> unit Proofview.tactic + +val default_elim : evars_flag -> clear_flag -> constr with_bindings -> + unit Proofview.tactic +val simplest_elim : constr -> unit Proofview.tactic +val elim : + evars_flag -> clear_flag -> constr with_bindings -> constr with_bindings option -> unit Proofview.tactic + +val induction : evars_flag -> clear_flag -> constr -> or_and_intro_pattern option -> + constr with_bindings option -> unit Proofview.tactic + +(** {6 Case analysis tactics. } *) + +val general_case_analysis : evars_flag -> clear_flag -> constr with_bindings -> unit Proofview.tactic +val simplest_case : constr -> unit Proofview.tactic + +val destruct : evars_flag -> clear_flag -> constr -> or_and_intro_pattern option -> + constr with_bindings option -> unit Proofview.tactic + +(** {6 Generic case analysis / induction tactics. } *) + +(** Implements user-level "destruct" and "induction" *) + +val induction_destruct : rec_flag -> evars_flag -> + (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 + +(** {6 Eliminations giving the type instead of the proof. } *) + +val case_type : types -> unit Proofview.tactic +val elim_type : types -> unit Proofview.tactic + +(** {6 Constructor tactics. } *) + +val constructor_tac : evars_flag -> int option -> int -> + constr bindings -> unit Proofview.tactic +val any_constructor : evars_flag -> unit Proofview.tactic option -> unit Proofview.tactic +val one_constructor : int -> constr bindings -> unit Proofview.tactic + +val left : constr bindings -> unit Proofview.tactic +val right : constr bindings -> unit Proofview.tactic +val split : constr bindings -> unit Proofview.tactic + +val left_with_bindings : evars_flag -> constr bindings -> unit Proofview.tactic +val right_with_bindings : evars_flag -> constr bindings -> unit Proofview.tactic +val split_with_bindings : evars_flag -> constr bindings list -> unit Proofview.tactic + +val simplest_left : unit Proofview.tactic +val simplest_right : unit Proofview.tactic +val simplest_split : unit Proofview.tactic + +(** {6 Equality tactics. } *) + +val setoid_reflexivity : unit Proofview.tactic Hook.t +val reflexivity_red : bool -> unit Proofview.tactic +val reflexivity : unit Proofview.tactic +val intros_reflexivity : unit Proofview.tactic + +val setoid_symmetry : unit Proofview.tactic Hook.t +val symmetry_red : bool -> unit Proofview.tactic +val symmetry : unit Proofview.tactic +val setoid_symmetry_in : (Id.t -> unit Proofview.tactic) Hook.t +val intros_symmetry : clause -> unit Proofview.tactic + +val setoid_transitivity : (constr option -> unit Proofview.tactic) Hook.t +val transitivity_red : bool -> constr option -> unit Proofview.tactic +val transitivity : constr -> unit Proofview.tactic +val etransitivity : unit Proofview.tactic +val intros_transitivity : constr option -> unit Proofview.tactic + +(** {6 Cut tactics. } *) + +val assert_before_replacing: Id.t -> types -> unit Proofview.tactic +val assert_after_replacing : Id.t -> types -> unit Proofview.tactic +val assert_before : Name.t -> types -> unit Proofview.tactic +val assert_after : Name.t -> types -> unit Proofview.tactic + +val assert_as : (* true = before *) bool -> + (* optionally tell if a specialization of some hyp: *) Id.t option -> + intro_pattern option -> constr -> unit Proofview.tactic + +(** Implements the tactics assert, enough and pose proof; note that "by" + applies on the first goal for both assert and enough *) + +val assert_by : Name.t -> types -> unit Proofview.tactic -> + unit Proofview.tactic +val enough_by : Name.t -> types -> unit Proofview.tactic -> + unit Proofview.tactic +val pose_proof : Name.t -> constr -> + unit Proofview.tactic + +(** Common entry point for user-level "assert", "enough" and "pose proof" *) + +val forward : bool -> unit Proofview.tactic option option -> + intro_pattern option -> constr -> unit Proofview.tactic + +(** Implements the tactic cut, actually a modus ponens rule *) + +val cut : types -> unit Proofview.tactic + +(** {6 Tactics for adding local definitions. } *) + +val pose_tac : Name.t -> constr -> unit Proofview.tactic + +val letin_tac : (bool * intro_pattern_naming) option -> + Name.t -> constr -> types option -> clause -> unit Proofview.tactic + +(** Common entry point for user-level "set", "pose" and "remember" *) + +val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option -> + Name.t -> (evar_map * constr) -> clause -> unit Proofview.tactic + +(** {6 Generalize tactics. } *) + +val generalize : constr list -> unit Proofview.tactic +val generalize_gen : (constr Locus.with_occurrences * Name.t) 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 -> unit Proofview.tactic + +(** {6 Other tactics. } *) + +(** Syntactic equality up to universes. With [strict] the universe + constraints must be already true to succeed, without [strict] they + are added to the evar map. *) +val constr_eq : strict:bool -> constr -> constr -> unit Proofview.tactic + +val unify : ?state:TransparentState.t -> constr -> constr -> unit Proofview.tactic + +val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> Id.t -> unit Proofview.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 + +val subst_one : + (bool -> Id.t -> Id.t * constr * bool -> unit Proofview.tactic) Hook.t + +val declare_intro_decomp_eq : + ((int -> unit Proofview.tactic) -> Coqlib.coq_eq_data * types * + (types * constr * constr) -> + constr * types -> unit Proofview.tactic) -> unit + +(** {6 Simple form of basic tactics. } *) + +module Simple : sig + (** Simplified version of some of the above tactics *) + + val intro : Id.t -> unit Proofview.tactic + val apply : constr -> unit Proofview.tactic + val eapply : constr -> unit Proofview.tactic + val elim : constr -> unit Proofview.tactic + val case : constr -> unit Proofview.tactic + val apply_in : Id.t -> constr -> unit Proofview.tactic + +end + +(** {6 Tacticals defined directly in term of Proofview} *) + +module New : sig + + val refine : typecheck:bool -> (evar_map -> evar_map * constr) -> unit Proofview.tactic + (** [refine ~typecheck c] is [Refine.refine ~typecheck c] + followed by beta-iota-reduction of the conclusion. *) + + val reduce_after_refine : unit Proofview.tactic + (** The reducing tactic called after {!refine}. *) + +end diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib new file mode 100644 index 0000000000..1861c5b99b --- /dev/null +++ b/tactics/tactics.mllib @@ -0,0 +1,26 @@ +Dnet +Dn +Btermdn +Tacticals +Hipattern +Ind_tables +Eqschemes +Elimschemes +Genredexpr +Redops +Redexpr +Ppred +Tactics +Abstract +Elim +Equality +Contradiction +Inv +Leminv +Hints +Auto +Eauto +Class_tactics +Term_dnet +Eqdecide +Autorewrite diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml new file mode 100644 index 0000000000..e273891500 --- /dev/null +++ b/tactics/term_dnet.ml @@ -0,0 +1,427 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(*i*) +open Util +open Constr +open Names +open Globnames +open Mod_subst +open Pp (* debug *) +(*i*) + + +(* Representation/approximation of terms to use in the dnet: + * + * - no meta or evar (use ['a pattern] for that) + * + * - [Rel]s and [Sort]s are not taken into account (that's why we need + * a second pass of linear filterin on the results - it's not a perfect + * term indexing structure) + + * - Foralls and LetIns are represented by a context DCtx (a list of + * generalization, similar to rel_context, and coded with DCons and + * DNil). This allows for matching under an unfinished context + *) + +module DTerm = +struct + + type 't t = + | DRel + | DSort + | DRef of GlobRef.t + | DCtx of 't * 't (* (binding list, subterm) = Prods and LetIns *) + | DLambda of 't * 't + | DApp of 't * 't (* binary app *) + | DCase of case_info * 't * 't * 't array + | DFix of int array * int * 't array * 't array + | DCoFix of int * 't array * 't array + + (* special constructors only inside the left-hand side of DCtx or + DApp. Used to encode lists of foralls/letins/apps as contexts *) + | DCons of ('t * 't option) * 't + | DNil + + (* debug *) + let _pr_dconstr f : 'a t -> Pp.t = function + | DRel -> str "*" + | DSort -> str "Sort" + | DRef _ -> str "Ref" + | DCtx (ctx,t) -> f ctx ++ spc() ++ str "|-" ++ spc () ++ f t + | DLambda (t1,t2) -> str "fun"++ spc() ++ f t1 ++ spc() ++ str"->" ++ spc() ++ f t2 + | DApp (t1,t2) -> f t1 ++ spc() ++ f t2 + | DCase (_,t1,t2,ta) -> str "case" + | DFix _ -> str "fix" + | DCoFix _ -> str "cofix" + | DCons ((t,dopt),tl) -> f t ++ (match dopt with + Some t' -> str ":=" ++ f t' + | None -> str "") ++ spc() ++ str "::" ++ spc() ++ f tl + | DNil -> str "[]" + + (* + * Functional iterators for the t datatype + * a.k.a boring and error-prone boilerplate code + *) + + let map f = function + | (DRel | DSort | DNil | DRef _) as c -> c + | DCtx (ctx,c) -> DCtx (f ctx, f c) + | DLambda (t,c) -> DLambda (f t, f c) + | DApp (t,u) -> DApp (f t,f u) + | DCase (ci,p,c,bl) -> DCase (ci, f p, f c, Array.map f bl) + | DFix (ia,i,ta,ca) -> + DFix (ia,i,Array.map f ta,Array.map f ca) + | DCoFix(i,ta,ca) -> + DCoFix (i,Array.map f ta,Array.map f ca) + | DCons ((t,topt),u) -> DCons ((f t,Option.map f topt), f u) + + let compare_ci ci1 ci2 = + let c = ind_ord ci1.ci_ind ci2.ci_ind in + if c = 0 then + let c = Int.compare ci1.ci_npar ci2.ci_npar in + if c = 0 then + let c = Array.compare Int.compare ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls in + if c = 0 then + Array.compare Int.compare ci1.ci_cstr_nargs ci2.ci_cstr_nargs + else c + else c + else c + + let compare cmp t1 t2 = match t1, t2 with + | DRel, DRel -> 0 + | DRel, _ -> -1 | _, DRel -> 1 + | DSort, DSort -> 0 + | DSort, _ -> -1 | _, DSort -> 1 + | DRef gr1, DRef gr2 -> GlobRef.Ordered.compare gr1 gr2 + | DRef _, _ -> -1 | _, DRef _ -> 1 + + | DCtx (tl1, tr1), DCtx (tl2, tr2) + | DLambda (tl1, tr1), DLambda (tl2, tr2) + | DApp (tl1, tr1), DApp (tl2, tr2) -> + let c = cmp tl1 tl2 in + if c = 0 then cmp tr1 tr2 else c + | DCtx _, _ -> -1 | _, DCtx _ -> 1 + | DLambda _, _ -> -1 | _, DLambda _ -> 1 + | DApp _, _ -> -1 | _, DApp _ -> 1 + + | DCase (ci1, c1, t1, p1), DCase (ci2, c2, t2, p2) -> + let c = cmp c1 c2 in + if c = 0 then + let c = cmp t1 t2 in + if c = 0 then + let c = Array.compare cmp p1 p2 in + if c = 0 then compare_ci ci1 ci2 + else c + else c + else c + | DCase _, _ -> -1 | _, DCase _ -> 1 + + | DFix (i1, j1, tl1, pl1), DFix (i2, j2, tl2, pl2) -> + let c = Int.compare j1 j2 in + if c = 0 then + let c = Array.compare Int.compare i1 i2 in + if c = 0 then + let c = Array.compare cmp tl1 tl2 in + if c = 0 then Array.compare cmp pl1 pl2 + else c + else c + else c + | DFix _, _ -> -1 | _, DFix _ -> 1 + + | DCoFix (i1, tl1, pl1), DCoFix (i2, tl2, pl2) -> + let c = Int.compare i1 i2 in + if c = 0 then + let c = Array.compare cmp tl1 tl2 in + if c = 0 then Array.compare cmp pl1 pl2 + else c + else c + | DCoFix _, _ -> -1 | _, DCoFix _ -> 1 + + | DCons ((t1, ot1), u1), DCons ((t2, ot2), u2) -> + let c = cmp t1 t2 in + if Int.equal c 0 then + let c = Option.compare cmp ot1 ot2 in + if Int.equal c 0 then cmp u1 u2 + else c + else c + | DCons _, _ -> -1 | _, DCons _ -> 1 + + | DNil, DNil -> 0 + + let fold f acc = function + | (DRel | DNil | DSort | DRef _) -> acc + | DCtx (ctx,c) -> f (f acc ctx) c + | DLambda (t,c) -> f (f acc t) c + | DApp (t,u) -> f (f acc t) u + | DCase (ci,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl + | DFix (ia,i,ta,ca) -> + Array.fold_left f (Array.fold_left f acc ta) ca + | DCoFix(i,ta,ca) -> + Array.fold_left f (Array.fold_left f acc ta) ca + | DCons ((t,topt),u) -> f (Option.fold_left f (f acc t) topt) u + + let choose f = function + | (DRel | DSort | DNil | DRef _) -> invalid_arg "choose" + | DCtx (ctx,c) -> f ctx + | DLambda (t,c) -> f t + | DApp (t,u) -> f u + | DCase (ci,p,c,bl) -> f c + | DFix (ia,i,ta,ca) -> f ta.(0) + | DCoFix (i,ta,ca) -> f ta.(0) + | DCons ((t,topt),u) -> f u + + let dummy_cmp () () = 0 + + let fold2 (f:'a -> 'b -> 'c -> 'a) (acc:'a) (c1:'b t) (c2:'c t) : 'a = + let head w = map (fun _ -> ()) w in + if not (Int.equal (compare dummy_cmp (head c1) (head c2)) 0) + then invalid_arg "fold2:compare" else + match c1,c2 with + | (DRel, DRel | DNil, DNil | DSort, DSort | DRef _, DRef _) -> acc + | (DCtx (c1,t1), DCtx (c2,t2) + | DApp (c1,t1), DApp (c2,t2) + | DLambda (c1,t1), DLambda (c2,t2)) -> f (f acc c1 c2) t1 t2 + | DCase (ci,p1,c1,bl1),DCase (_,p2,c2,bl2) -> + Array.fold_left2 f (f (f acc p1 p2) c1 c2) bl1 bl2 + | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> + Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 + | DCoFix(i,ta1,ca1), DCoFix(_,ta2,ca2) -> + Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 + | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> + f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2 + | (DRel | DNil | DSort | DRef _ | DCtx _ | DApp _ | DLambda _ | DCase _ + | DFix _ | DCoFix _ | DCons _), _ -> assert false + + let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t = + let head w = map (fun _ -> ()) w in + if not (Int.equal (compare dummy_cmp (head c1) (head c2)) 0) + then invalid_arg "map2_t:compare" else + match c1,c2 with + | (DRel, DRel | DSort, DSort | DNil, DNil | DRef _, DRef _) as cc -> + let (c,_) = cc in c + | DCtx (c1,t1), DCtx (c2,t2) -> DCtx (f c1 c2, f t1 t2) + | DLambda (t1,c1), DLambda (t2,c2) -> DLambda (f t1 t2, f c1 c2) + | DApp (t1,u1), DApp (t2,u2) -> DApp (f t1 t2,f u1 u2) + | DCase (ci,p1,c1,bl1), DCase (_,p2,c2,bl2) -> + DCase (ci, f p1 p2, f c1 c2, Array.map2 f bl1 bl2) + | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> + DFix (ia,i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) + | DCoFix (i,ta1,ca1), DCoFix (_,ta2,ca2) -> + DCoFix (i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) + | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> + DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2) + | (DRel | DNil | DSort | DRef _ | DCtx _ | DApp _ | DLambda _ | DCase _ + | DFix _ | DCoFix _ | DCons _), _ -> assert false + + let terminal = function + | (DRel | DSort | DNil | DRef _) -> true + | DLambda _ | DApp _ | DCase _ | DFix _ | DCoFix _ | DCtx _ | DCons _ -> + false + + let compare t1 t2 = compare dummy_cmp t1 t2 + +end + +(* + * Terms discrimination nets + * Uses the general dnet datatype on DTerm.t + * (here you can restart reading) + *) + +(* + * Construction of the module + *) + +module type IDENT = +sig + type t + val compare : t -> t -> int + val subst : substitution -> t -> t + val constr_of : t -> constr +end + +module type OPT = +sig + val reduce : constr -> constr + val direction : bool +end + +module Make = + functor (Ident : IDENT) -> + functor (Opt : OPT) -> +struct + + module TDnet : Dnet.S with type ident=Ident.t + and type 'a structure = 'a DTerm.t + and type meta = int + = Dnet.Make(DTerm)(Ident)(Int) + + type t = TDnet.t + + type ident = TDnet.ident + + (** We will freshen metas on the fly, to cope with the implementation defect + of Term_dnet which requires metas to be all distinct. *) + let fresh_meta = + let index = ref 0 in + fun () -> + let ans = !index in + let () = index := succ ans in + ans + + open DTerm + open TDnet + + let pat_of_constr c : term_pattern = + (* To each evar we associate a unique identifier. *) + let metas = ref Evar.Map.empty in + let rec pat_of_constr c = match Constr.kind c with + | Rel _ -> Term DRel + | Sort _ -> Term DSort + | Var i -> Term (DRef (VarRef i)) + | Const (c,u) -> Term (DRef (ConstRef c)) + | Ind (i,u) -> Term (DRef (IndRef i)) + | Construct (c,u)-> Term (DRef (ConstructRef c)) + | Meta _ -> assert false + | Evar (i,_) -> + let meta = + try Evar.Map.find i !metas + with Not_found -> + let meta = fresh_meta () in + let () = metas := Evar.Map.add i meta !metas in + meta + in + Meta meta + | Case (ci,c1,c2,ca) -> + Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca)) + | Fix ((ia,i),(_,ta,ca)) -> + Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca)) + | CoFix (i,(_,ta,ca)) -> + Term(DCoFix(i,Array.map pat_of_constr ta,Array.map pat_of_constr ca)) + | Cast (c,_,_) -> pat_of_constr c + | Lambda (_,t,c) -> Term(DLambda (pat_of_constr t, pat_of_constr c)) + | (Prod (_,_,_) | LetIn(_,_,_,_)) -> + let (ctx,c) = ctx_of_constr (Term DNil) c in Term (DCtx (ctx,c)) + | App (f,ca) -> + Array.fold_left (fun c a -> Term (DApp (c,a))) + (pat_of_constr f) (Array.map pat_of_constr ca) + | Proj (p,c) -> + Term (DApp (Term (DRef (ConstRef (Projection.constant p))), pat_of_constr c)) + + and ctx_of_constr ctx c = match Constr.kind c with + | Prod (_,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c + | LetIn(_,d,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t, Some (pat_of_constr d)),ctx))) c + | _ -> ctx,pat_of_constr c + in + pat_of_constr c + + let empty_ctx : term_pattern -> term_pattern = function + | Meta _ as c -> c + | Term (DCtx(_,_)) as c -> c + | c -> Term (DCtx (Term DNil, c)) + + (* + * Basic primitives + *) + + let empty = TDnet.empty + + let subst s t = + let sleaf id = Ident.subst s id in + let snode = function + | DTerm.DRef gr -> DTerm.DRef (fst (subst_global s gr)) + | n -> n in + TDnet.map sleaf snode t + + let union = TDnet.union + + let add (c:constr) (id:Ident.t) (dn:t) = + let c = Opt.reduce c in + let c = empty_ctx (pat_of_constr c) in + TDnet.add dn c id + + + let new_meta () = Meta (fresh_meta ()) + + let rec remove_cap : term_pattern -> term_pattern = function + | Term (DCons (t,u)) -> Term (DCons (t,remove_cap u)) + | Term DNil -> new_meta() + | Meta _ as m -> m + | _ -> assert false + + let under_prod : term_pattern -> term_pattern = function + | Term (DCtx (t,u)) -> Term (DCtx (remove_cap t,u)) + | Meta m -> Term (DCtx(new_meta(), Meta m)) + | _ -> assert false + + (* debug *) +(* let rec pr_term_pattern p = + (fun pr_t -> function + | Term t -> pr_t t + | Meta m -> str"["++Pp.int (Obj.magic m)++str"]" + ) (pr_dconstr pr_term_pattern) p*) + + let search_pat cpat dpat dn = + let whole_c = EConstr.of_constr cpat in + (* if we are at the root, add an empty context *) + let dpat = under_prod (empty_ctx dpat) in + TDnet.Idset.fold + (fun id acc -> + let c_id = Opt.reduce (Ident.constr_of id) in + let c_id = EConstr.of_constr c_id in + let (ctx,wc) = + try Termops.align_prod_letin Evd.empty whole_c c_id (* FIXME *) + with Invalid_argument _ -> [],c_id in + let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in + try + let _ = Termops.filtering Evd.empty ctx Reduction.CUMUL wc whole_c in + id :: acc + with Termops.CannotFilter -> (* msgnl(str"recon "++Termops.print_constr_env (Global.env()) wc); *) acc + ) (TDnet.find_match dpat dn) [] + + (* + * High-level primitives describing specific search problems + *) + + let search_pattern dn pat = + let pat = Opt.reduce pat in + search_pat pat (empty_ctx (pat_of_constr pat)) dn + + let find_all dn = Idset.elements (TDnet.find_all dn) + + let map f dn = TDnet.map f (fun x -> x) dn + + let refresh_metas dn = + let new_metas = ref Int.Map.empty in + let refresh_one_meta i = + try Int.Map.find i !new_metas + with Not_found -> + let new_meta = fresh_meta () in + let () = new_metas := Int.Map.add i new_meta !new_metas in + new_meta + in + TDnet.map_metas refresh_one_meta dn +end + +module type S = +sig + type t + type ident + + val empty : t + val add : constr -> ident -> t -> t + val union : t -> t -> t + val subst : substitution -> t -> t + val search_pattern : t -> constr -> ident list + val find_all : t -> ident list + val map : (ident -> ident) -> t -> t + val refresh_metas : t -> t +end diff --git a/tactics/term_dnet.mli b/tactics/term_dnet.mli new file mode 100644 index 0000000000..7bce577899 --- /dev/null +++ b/tactics/term_dnet.mli @@ -0,0 +1,92 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Constr +open Mod_subst + +(** Dnets on constr terms. + + An instantiation of Dnet on (an approximation of) constr. It + associates a term (possibly with Evar) with an + identifier. Identifiers must be unique (no two terms sharing the + same ident), and there must be a way to recover the full term from + the identifier (function constr_of). + + Optionally, a pre-treatment on terms can be performed before adding + or searching (reduce). Practically, it is used to do some kind of + delta-reduction on terms before indexing them. + + The results returned here are perfect, since post-filtering is done + inside here. + + See tactics/dnet.mli for more details. +*) + +(** Identifiers to store (right hand side of the association) *) +module type IDENT = sig + type t + val compare : t -> t -> int + + (** how to substitute them for storage *) + val subst : substitution -> t -> t + + (** how to recover the term from the identifier *) + val constr_of : t -> constr +end + +(** Options : *) +module type OPT = sig + + (** pre-treatment to terms before adding or searching *) + val reduce : constr -> constr + + (** direction of post-filtering w.r.t sort subtyping : + - true means query <= terms in the structure + - false means terms <= query + *) + val direction : bool +end + +module type S = +sig + type t + type ident + + val empty : t + + (** [add c i dn] adds the binding [(c,i)] to [dn]. [c] can be a + closed term or a pattern (with untyped Evars). No Metas accepted *) + val add : constr -> ident -> t -> t + + (** merge of dnets. Faster than re-adding all terms *) + val union : t -> t -> t + + val subst : substitution -> t -> t + + (* + * High-level primitives describing specific search problems + *) + + (** [search_pattern dn c] returns all terms/patterns in dn + matching/matched by c *) + val search_pattern : t -> constr -> ident list + + (** [find_all dn] returns all idents contained in dn *) + val find_all : t -> ident list + + val map : (ident -> ident) -> t -> t + + val refresh_metas : t -> t +end + +module Make : + functor (Ident : IDENT) -> + functor (Opt : OPT) -> + S with type ident = Ident.t |