From 3ef7797ef6fc605dfafb32523261fe1b023aeecb Mon Sep 17 00:00:00 2001 From: Samuel Mimram Date: Fri, 28 Apr 2006 14:59:16 +0000 Subject: Imported Upstream version 8.0pl3+8.1alpha --- tactics/auto.ml | 325 +++--- tactics/auto.mli | 77 +- tactics/autorewrite.ml | 106 +- tactics/autorewrite.mli | 5 +- tactics/btermdn.ml | 5 +- tactics/btermdn.mli | 2 +- tactics/contradiction.ml | 2 +- tactics/contradiction.mli | 2 +- tactics/dhyp.ml | 8 +- tactics/dhyp.mli | 2 +- tactics/dn.ml | 2 +- tactics/dn.mli | 2 +- tactics/eauto.ml4 | 142 ++- tactics/eauto.mli | 10 +- tactics/elim.ml | 3 +- tactics/elim.mli | 2 +- tactics/eqdecide.ml4 | 97 +- tactics/equality.ml | 431 ++++---- tactics/equality.mli | 57 +- tactics/evar_tactics.ml | 75 ++ tactics/evar_tactics.mli | 22 + tactics/extraargs.ml4 | 98 +- tactics/extraargs.mli | 25 +- tactics/extratactics.ml4 | 330 ++++-- tactics/extratactics.mli | 22 +- tactics/hiddentac.ml | 15 +- tactics/hiddentac.mli | 27 +- tactics/hipattern.ml | 366 ------- tactics/hipattern.ml4 | 353 +++++++ tactics/hipattern.mli | 14 +- tactics/inv.ml | 61 +- tactics/inv.mli | 12 +- tactics/leminv.ml | 29 +- tactics/leminv.mli | 4 +- tactics/nbtermdn.ml | 7 +- tactics/nbtermdn.mli | 5 +- tactics/refine.ml | 81 +- tactics/refine.mli | 5 +- tactics/setoid_replace.ml | 2366 ++++++++++++++++++++++++++++++++++---------- tactics/setoid_replace.mli | 64 +- tactics/tacinterp.ml | 819 +++++++-------- tactics/tacinterp.mli | 34 +- tactics/tacticals.ml | 46 +- tactics/tacticals.mli | 15 +- tactics/tactics.ml | 1913 ++++++++++++++++++++++------------- tactics/tactics.mli | 108 +- tactics/tauto.ml4 | 44 +- tactics/termdn.ml | 19 +- tactics/termdn.mli | 7 +- 49 files changed, 5269 insertions(+), 2997 deletions(-) create mode 100644 tactics/evar_tactics.ml create mode 100644 tactics/evar_tactics.mli delete mode 100644 tactics/hipattern.ml create mode 100644 tactics/hipattern.ml4 (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index d7130f35..d5e5e556 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: auto.ml,v 1.63.2.3 2005/05/15 12:47:04 herbelin Exp $ *) +(* $Id: auto.ml 7937 2006-01-28 19:58:11Z herbelin $ *) open Pp open Util @@ -15,6 +15,7 @@ open Nameops open Term open Termops open Sign +open Environ open Inductive open Evd open Reduction @@ -38,21 +39,21 @@ open Library open Printer open Declarations open Tacexpr +open Mod_subst (****************************************************************************) (* The Type of Constructions Autotactic Hints *) (****************************************************************************) type auto_tactic = - | Res_pf of constr * unit clausenv (* Hint Apply *) - | ERes_pf of constr * unit clausenv (* Hint EApply *) + | Res_pf of constr * clausenv (* Hint Apply *) + | ERes_pf of constr * clausenv (* Hint EApply *) | Give_exact of constr - | Res_pf_THEN_trivial_fail of constr * unit clausenv (* Hint Immediate *) - | Unfold_nth of global_reference (* Hint Unfold *) + | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *) + | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of glob_tactic_expr (* Hint Extern *) type pri_auto_tactic = { - hname : identifier; (* name of the hint *) pri : int; (* A number between 0 and 4, 4 = lower priority *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) code : auto_tactic (* the tactic to apply when the concl matches pat *) @@ -103,7 +104,7 @@ let lookup_tacs (hdc,c) (l,l',dn) = module Constr_map = Map.Make(struct - type t = constr_label + type t = global_reference let compare = Pervasives.compare end) @@ -134,24 +135,28 @@ module Hint_db = struct end -type frozen_hint_db_table = Hint_db.t Stringmap.t +module Hintdbmap = Gmap -type hint_db_table = Hint_db.t Stringmap.t ref +type frozen_hint_db_table = (string,Hint_db.t) Hintdbmap.t + +type hint_db_table = (string,Hint_db.t) Hintdbmap.t ref type hint_db_name = string -let searchtable = (ref Stringmap.empty : hint_db_table) +let searchtable = (ref Hintdbmap.empty : hint_db_table) let searchtable_map name = - Stringmap.find name !searchtable + Hintdbmap.find name !searchtable let searchtable_add (name,db) = - searchtable := Stringmap.add name db !searchtable + searchtable := Hintdbmap.add name db !searchtable +let current_db_names () = + Hintdbmap.dom !searchtable (**************************************************************************) (* Definition of the summary *) (**************************************************************************) -let init () = searchtable := Stringmap.empty +let init () = searchtable := Hintdbmap.empty let freeze () = !searchtable let unfreeze fs = searchtable := fs @@ -177,21 +182,25 @@ let try_head_pattern c = try head_pattern_bound c with BoundPattern -> error "Bound head variable" -let make_exact_entry name (c,cty) = +let make_exact_entry (c,cty) = let cty = strip_outer_cast cty in match kind_of_term cty with | Prod (_,_,_) -> failwith "make_exact_entry" | _ -> (head_of_constr_reference (List.hd (head_constr cty)), - { hname=name; pri=0; pat=None; code=Give_exact c }) + { pri=0; pat=None; code=Give_exact c }) + +let dummy_goal = + {it={evar_hyps=empty_named_context_val;evar_concl=mkProp;evar_body=Evar_empty}; + sigma=Evd.empty} -let make_apply_entry env sigma (eapply,verbose) name (c,cty) = +let make_apply_entry env sigma (eapply,verbose) (c,cty) = let cty = hnf_constr env sigma cty in match kind_of_term cty with | Prod _ -> - let ce = mk_clenv_from () (c,cty) in - let c' = (clenv_template_type ce).rebus in + let ce = mk_clenv_from dummy_goal (c,cty) in + let c' = clenv_type ce in let pat = Pattern.pattern_of_constr c' in let hd = (try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry") in @@ -199,72 +208,66 @@ let make_apply_entry env sigma (eapply,verbose) name (c,cty) = in if eapply & (nmiss <> 0) then begin if verbose then - if !Options.v7 then - warn (str "the hint: EApply " ++ prterm c ++ - str " will only be used by EAuto") - else - warn (str "the hint: eapply " ++ prterm c ++ - str " will only be used by eauto"); + warn (str "the hint: eapply " ++ pr_lconstr c ++ + str " will only be used by eauto"); (hd, - { hname = name; - pri = nb_hyp cty + nmiss; + { pri = nb_hyp cty + nmiss; pat = Some pat; - code = ERes_pf(c,ce) }) + code = ERes_pf(c,{ce with templenv=empty_env}) }) end else (hd, - { hname = name; - pri = nb_hyp cty; + { pri = nb_hyp cty; pat = Some pat; - code = Res_pf(c,ce) }) + code = Res_pf(c,{ce with templenv=empty_env}) }) | _ -> failwith "make_apply_entry" (* eap is (e,v) with e=true if eapply and v=true if verbose c is a constr cty is the type of constr *) -let make_resolves env sigma name eap (c,cty) = +let make_resolves env sigma eap c = + let cty = type_of env sigma c in let ents = map_succeed - (fun f -> f name (c,cty)) - [make_exact_entry; make_apply_entry env sigma eap] + (fun f -> f (c,cty)) + [make_exact_entry; make_apply_entry env sigma (eap,Options.is_verbose())] in - if ents = [] then - errorlabstrm "Hint" (prterm c ++ spc () ++ str "cannot be used as a hint"); + if ents = [] then + errorlabstrm "Hint" + (pr_lconstr c ++ spc() ++ str"cannot be used as a hint"); ents + (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma (hname,_,htyp) = try - [make_apply_entry env sigma (true, false) hname + [make_apply_entry env sigma (true, false) (mkVar hname, htyp)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly "make_resolve_hyp" (* REM : in most cases hintname = id *) -let make_unfold (hintname, ref) = - (Pattern.label_of_ref ref, - { hname = hintname; - pri = 4; +let make_unfold (ref, eref) = + (ref, + { pri = 4; pat = None; - code = Unfold_nth ref }) + code = Unfold_nth eref }) -let make_extern name pri pat tacast = +let make_extern pri pat tacast = let hdconstr = try_head_pattern pat in (hdconstr, - { hname = name; - pri=pri; + { pri=pri; pat = Some pat; code= Extern tacast }) -let make_trivial env sigma (name,c) = +let make_trivial env sigma c = let t = hnf_constr env sigma (type_of env sigma c) in let hd = head_of_constr_reference (List.hd (head_constr t)) in - let ce = mk_clenv_from () (c,t) in - (hd, { hname = name; - pri=1; - pat = Some (Pattern.pattern_of_constr (clenv_template_type ce).rebus); - code=Res_pf_THEN_trivial_fail(c,ce) }) + let ce = mk_clenv_from dummy_goal (c,t) in + (hd, { pri=1; + pat = Some (Pattern.pattern_of_constr (clenv_type ce)); + code=Res_pf_THEN_trivial_fail(c,{ce with templenv=empty_env}) }) open Vernacexpr @@ -291,7 +294,7 @@ let forward_subst_tactic = let set_extern_subst_tactic f = forward_subst_tactic := f let subst_autohint (_,subst,(local,name,hintlist as obj)) = - let trans_clenv clenv = Clenv.subst_clenv (fun _ a -> a) subst clenv in + let trans_clenv clenv = Clenv.subst_clenv subst clenv in let trans_data data code = { data with pat = option_smartmap (subst_pattern subst) data.pat ; @@ -299,29 +302,32 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) = } in let subst_hint (lab,data as hint) = - let lab' = subst_label subst lab in + let lab',elab' = subst_global subst lab in + let lab' = + try head_of_constr_reference (List.hd (head_constr_bound elab' [])) + with Tactics.Bound -> lab' in let data' = match data.code with | Res_pf (c, clenv) -> - let c' = Term.subst_mps subst c in + let c' = subst_mps subst c in if c==c' then data else trans_data data (Res_pf (c', trans_clenv clenv)) | ERes_pf (c, clenv) -> - let c' = Term.subst_mps subst c in + let c' = subst_mps subst c in if c==c' then data else trans_data data (ERes_pf (c', trans_clenv clenv)) | Give_exact c -> - let c' = Term.subst_mps subst c in + let c' = subst_mps subst c in if c==c' then data else trans_data data (Give_exact c') | Res_pf_THEN_trivial_fail (c, clenv) -> - let c' = Term.subst_mps subst c in + let c' = subst_mps subst c in if c==c' then data else let code' = Res_pf_THEN_trivial_fail (c', trans_clenv clenv) in trans_data data code' | Unfold_nth ref -> - let ref' = subst_global subst ref in - if ref==ref' then data else - trans_data data (Unfold_nth ref') + let ref' = subst_evaluable_reference subst ref in + if ref==ref' then data else + trans_data data (Unfold_nth ref') | Extern tac -> let tac' = !forward_subst_tactic subst tac in if tac==tac' then data else @@ -353,19 +359,12 @@ let (inAutoHint,outAutoHint) = (* The "Hint" vernacular command *) (**************************************************************************) let add_resolves env sigma clist local dbnames = - List.iter + List.iter (fun dbname -> Lib.add_anonymous_leaf (inAutoHint (local,dbname, - List.flatten - (List.map - (fun (name,c) -> - let ty = type_of env sigma c in - let verbose = Options.is_verbose() in - make_resolves env sigma name (true,verbose) (c,ty)) clist - ) - ))) + List.flatten (List.map (make_resolves env sigma true) clist)))) dbnames @@ -376,12 +375,9 @@ let add_unfolds l local dbnames = dbnames -let add_extern name pri (patmetas,pat) tacast local dbname = +let add_extern pri (patmetas,pat) tacast local dbname = (* We check that all metas that appear in tacast have at least one occurence in the left pattern pat *) -(* TODO - let tacmetas = Coqast.collect_metas tacast in -*) let tacmetas = [] in match (list_subtract tacmetas patmetas) with | i::_ -> @@ -389,10 +385,10 @@ let add_extern name pri (patmetas,pat) tacast local dbname = (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound") | [] -> Lib.add_anonymous_leaf - (inAutoHint(local,dbname, [make_extern name pri pat tacast])) + (inAutoHint(local,dbname, [make_extern pri pat tacast])) -let add_externs name pri pat tacast local dbnames = - List.iter (add_extern name pri pat tacast local) dbnames +let add_externs pri pat tacast local dbnames = + List.iter (add_extern pri pat tacast local) dbnames let add_trivials env sigma l local dbnames = List.iter @@ -408,53 +404,39 @@ let set_extern_intern_tac f = forward_intern_tac := f let add_hints local dbnames0 h = let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in + let env = Global.env() and sigma = Evd.empty in + let f = Constrintern.interp_constr sigma env in match h with | HintsResolve lhints -> - let env = Global.env() and sigma = Evd.empty in - let f (n,c) = - let c = Constrintern.interp_constr sigma env c in - let n = match n with - | None -> (*id_of_global (reference_of_constr c)*) - id_of_string "" - | Some n -> n in - (n,c) in add_resolves env sigma (List.map f lhints) local dbnames | HintsImmediate lhints -> - let env = Global.env() and sigma = Evd.empty in - let f (n,c) = - let c = Constrintern.interp_constr sigma env c in - let n = match n with - | None -> (*id_of_global (reference_of_constr c)*) - id_of_string "" - | Some n -> n in - (n,c) in add_trivials env sigma (List.map f lhints) local dbnames | HintsUnfold lhints -> - let f (n,locqid) = - let r = Nametab.global locqid in - let n = match n with - | None -> id_of_global r - | Some n -> n in - (n,r) in + let f qid = + let r = Nametab.global qid in + let r' = match r with + | ConstRef c -> EvalConstRef c + | VarRef c -> EvalVarRef c + | _ -> + errorlabstrm "evalref_of_ref" + (str "Cannot coerce" ++ spc () ++ pr_global r ++ spc () ++ + str "to an evaluable reference") + in + (r,r') in add_unfolds (List.map f lhints) local dbnames - | HintsConstructors (hintname, lqid) -> + | HintsConstructors lqid -> let add_one qid = let env = Global.env() and sigma = Evd.empty in let isp = global_inductive qid in let consnames = (snd (Global.lookup_inductive isp)).mind_consnames in let lcons = list_tabulate (fun i -> mkConstruct (isp,i+1)) (Array.length consnames) in - let lcons = List.map2 - (fun id c -> (id,c)) (Array.to_list consnames) lcons in add_resolves env sigma lcons local dbnames in List.iter add_one lqid - | HintsExtern (hintname, pri, patcom, tacexp) -> - let hintname = match hintname with - Some h -> h - | _ -> id_of_string "" in + | HintsExtern (pri, patcom, tacexp) -> let pat = Constrintern.interp_constrpattern Evd.empty (Global.env()) patcom in let tacexp = !forward_intern_tac (fst pat) tacexp in - add_externs hintname pri pat tacexp local dbnames + add_externs pri pat tacexp local dbnames | HintsDestruct(na,pri,loc,pat,code) -> if dbnames0<>[] then warn (str"Database selection not implemented for destruct hints"); @@ -465,25 +447,15 @@ let add_hints local dbnames0 h = (**************************************************************************) let fmt_autotactic = - if !Options.v7 then - function - | Res_pf (c,clenv) -> (str"Apply " ++ prterm c) - | ERes_pf (c,clenv) -> (str"EApply " ++ prterm c) - | Give_exact c -> (str"Exact " ++ prterm c) - | Res_pf_THEN_trivial_fail (c,clenv) -> - (str"Apply " ++ prterm c ++ str" ; Trivial") - | Unfold_nth c -> (str"Unfold " ++ pr_global c) - | Extern tac -> (str "Extern " ++ Pptactic.pr_glob_tactic tac) - else function - | Res_pf (c,clenv) -> (str"apply " ++ prterm c) - | ERes_pf (c,clenv) -> (str"eapply " ++ prterm c) - | Give_exact c -> (str"exact " ++ prterm c) + | Res_pf (c,clenv) -> (str"apply " ++ pr_lconstr c) + | ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c) + | Give_exact c -> (str"exact " ++ pr_lconstr c) | Res_pf_THEN_trivial_fail (c,clenv) -> - (str"apply " ++ prterm c ++ str" ; trivial") - | Unfold_nth c -> (str"unfold " ++ pr_global c) + (str"apply " ++ pr_lconstr c ++ str" ; trivial") + | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) | Extern tac -> - (str "(external) " ++ Pptacticnew.pr_glob_tactic (Global.env()) tac) + (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac) let fmt_hint v = (fmt_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ()) @@ -498,20 +470,20 @@ let fmt_hints_db (name,db,hintlist) = (* Print all hints associated to head c in any database *) let fmt_hint_list_for_head c = - let dbs = stringmap_to_list !searchtable in + let dbs = Hintdbmap.to_list !searchtable in let valid_dbs = map_succeed (fun (name,db) -> (name,db,Hint_db.map_all c db)) dbs in if valid_dbs = [] then - (str "No hint declared for :" ++ pr_ref_label c) + (str "No hint declared for :" ++ pr_global c) else hov 0 - (str"For " ++ pr_ref_label c ++ str" -> " ++ fnl () ++ + (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++ hov 0 (prlist fmt_hints_db valid_dbs)) -let fmt_hint_ref ref = fmt_hint_list_for_head (label_of_ref ref) +let fmt_hint_ref ref = fmt_hint_list_for_head ref (* Print all hints associated to head id in any database *) let print_hint_ref ref = ppnl(fmt_hint_ref ref) @@ -523,7 +495,7 @@ let fmt_hint_term cl = | [] -> assert false in let hd = head_of_constr_reference hdc in - let dbs = stringmap_to_list !searchtable in + let dbs = Hintdbmap.to_list !searchtable in let valid_dbs = if occur_existential cl then map_succeed @@ -556,7 +528,7 @@ let print_hint_db db = Hint_db.iter (fun head hintlist -> msg (hov 0 - (str "For " ++ pr_ref_label head ++ str " -> " ++ + (str "For " ++ pr_global head ++ str " -> " ++ fmt_hint_list hintlist))) db @@ -568,7 +540,7 @@ let print_hint_db_by_name dbname = (* displays all the hints of all databases *) let print_searchtable () = - Stringmap.iter + Hintdbmap.iter (fun name db -> msg (str "In the database " ++ str name ++ fnl ()); print_hint_db db) @@ -588,19 +560,18 @@ let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) (* Try unification with the precompiled clause, then use registered Apply *) let unify_resolve (c,clenv) gls = - let (wc,kONT) = startWalk gls in - let clenv' = connect_clenv wc clenv in + let clenv' = connect_clenv gls clenv in let _ = clenv_unique_resolver false clenv' gls in h_simplest_apply c gls (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types *) -let make_local_hint_db g = +let make_local_hint_db lems g = let sign = pf_hyps g in - let hintlist = list_map_append (make_resolve_hyp (pf_env g) (project g)) sign - in Hint_db.add_list hintlist Hint_db.empty - + let hintlist = list_map_append (pf_apply make_resolve_hyp g) sign in + let hintlist' = list_map_append (pf_apply make_resolves g true) lems in + Hint_db.add_list hintlist' (Hint_db.add_list hintlist Hint_db.empty) (* 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 @@ -654,7 +625,7 @@ and my_find_search db_list local_db hdc concl = (local_db::db_list) in List.map - (fun ({pri=b; pat=p; code=t} as patac) -> + (fun {pri=b; pat=p; code=t} -> (b, match t with | Res_pf (term,cl) -> unify_resolve (term,cl) @@ -664,7 +635,7 @@ and my_find_search db_list local_db hdc concl = tclTHEN (unify_resolve (term,cl)) (trivial_fail_db db_list local_db) - | Unfold_nth c -> unfold_constr c + | Unfold_nth c -> unfold_in_concl [[],c] | Extern tacast -> conclPattern concl (out_some p) tacast)) tacl @@ -677,32 +648,30 @@ and trivial_resolve db_list local_db cl = with Bound | Not_found -> [] -let trivial dbnames gl = +let trivial lems dbnames gl = let db_list = List.map (fun x -> try searchtable_map x with Not_found -> - if !Options.v7 then - error ("Trivial: "^x^": No such Hint database") - else - error ("trivial: "^x^": No such Hint database")) + error ("trivial: "^x^": No such Hint database")) ("core"::dbnames) in - tclTRY (trivial_fail_db db_list (make_local_hint_db gl)) gl + tclTRY (trivial_fail_db db_list (make_local_hint_db lems gl)) gl -let full_trivial gl = - let dbnames = stringmap_dom !searchtable in +let full_trivial lems gl = + let dbnames = Hintdbmap.dom !searchtable in let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map (fun x -> searchtable_map x) dbnames in - tclTRY (trivial_fail_db db_list (make_local_hint_db gl)) gl + tclTRY (trivial_fail_db db_list (make_local_hint_db lems gl)) gl -let gen_trivial = function - | None -> full_trivial - | Some l -> trivial l +let gen_trivial lems = function + | None -> full_trivial lems + | Some l -> trivial lems l -let h_trivial l = Refiner.abstract_tactic (TacTrivial l) (gen_trivial l) +let h_trivial lems l = + Refiner.abstract_tactic (TacTrivial (lems,l)) (gen_trivial lems l) (**************************************************************************) (* The classical Auto tactic *) @@ -760,7 +729,7 @@ let rec search_gen decomp n db_list local_db extra_sign goal = try [make_apply_entry (pf_env g') (project g') (true,false) - hid (mkVar hid, htyp)] + (mkVar hid, htyp)] with Failure _ -> [] in search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d] g') @@ -778,44 +747,41 @@ let rec search_gen decomp n db_list local_db extra_sign goal = let search = search_gen 0 let default_search_depth = ref 5 - -let auto n dbnames gl = + +let auto n lems dbnames gl = let db_list = List.map (fun x -> try searchtable_map x with Not_found -> - if !Options.v7 then - error ("Auto: "^x^": No such Hint database") - else - error ("auto: "^x^": No such Hint database")) + error ("auto: "^x^": No such Hint database")) ("core"::dbnames) in let hyps = pf_hyps gl in - tclTRY (search n db_list (make_local_hint_db gl) hyps) gl + tclTRY (search n db_list (make_local_hint_db lems gl) hyps) gl -let default_auto = auto !default_search_depth [] +let default_auto = auto !default_search_depth [] [] -let full_auto n gl = - let dbnames = stringmap_dom !searchtable in +let full_auto n lems gl = + let dbnames = Hintdbmap.dom !searchtable in let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map (fun x -> searchtable_map x) dbnames in let hyps = pf_hyps gl in - tclTRY (search n db_list (make_local_hint_db gl) hyps) gl + tclTRY (search n db_list (make_local_hint_db lems gl) hyps) gl -let default_full_auto gl = full_auto !default_search_depth gl +let default_full_auto gl = full_auto !default_search_depth [] gl -let gen_auto n dbnames = +let gen_auto n lems dbnames = let n = match n with None -> !default_search_depth | Some n -> n in match dbnames with - | None -> full_auto n - | Some l -> auto n l + | None -> full_auto n lems + | Some l -> auto n lems l let inj_or_var = option_app (fun n -> Genarg.ArgArg n) -let h_auto n l = - Refiner.abstract_tactic (TacAuto (inj_or_var n,l)) (gen_auto n l) +let h_auto n lems l = + Refiner.abstract_tactic (TacAuto (inj_or_var n,lems,l)) (gen_auto n lems l) (**************************************************************************) (* The "destructing Auto" from Eduardo *) @@ -830,7 +796,7 @@ let default_search_decomp = ref 1 let destruct_auto des_opt n gl = let hyps = pf_hyps gl in search_gen des_opt n [searchtable_map "core"] - (make_local_hint_db gl) hyps gl + (make_local_hint_db [] gl) hyps gl let dautomatic des_opt n = tclTRY (destruct_auto des_opt n) @@ -842,13 +808,21 @@ let dauto = function | Some n, Some p -> dautomatic p n | None, Some p -> dautomatic p !default_search_depth -let h_dauto (n,p) = +let h_dauto (n,p) = Refiner.abstract_tactic (TacDAuto (inj_or_var n,p)) (dauto (n,p)) (***************************************) (*** A new formulation of Auto *********) (***************************************) +let make_resolve_any_hyp env sigma (id,_,ty) = + let ents = + map_succeed + (fun f -> f (mkVar id,ty)) + [make_exact_entry; make_apply_entry env sigma (true,false)] + in + ents + type autoArguments = | UsingTDB | Destructing @@ -869,7 +843,7 @@ let compileAutoArg contac = function then tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac] else - tclFAIL 0 ((string_of_id id)^"is not a conjunction")) + tclFAIL 0 (pr_id id ++ str" is not a conjunction")) ctx) g) | UsingTDB -> (tclTHEN @@ -888,10 +862,7 @@ let rec super_search n db_list local_db argl goal = :: (tclTHEN intro (fun g -> - let (hid,_,htyp) = pf_last_hyp g in - let hintl = - make_resolves (pf_env g) (project g) - hid (true,false) (mkVar hid, htyp) in + let hintl = pf_apply make_resolve_any_hyp g (pf_last_hyp g) in super_search n db_list (Hint_db.add_list hintl local_db) argl g)) :: @@ -910,8 +881,8 @@ let search_superauto n to_add argl g = (fun (id,c) -> add_named_decl (id, None, pf_type_of g c)) to_add empty_named_context in let db0 = list_map_append (make_resolve_hyp (pf_env g) (project g)) sigma in - let db = Hint_db.add_list db0 (make_local_hint_db g) in - super_search n [Stringmap.find "core" !searchtable] db argl g + let db = Hint_db.add_list db0 (make_local_hint_db [] g) in + super_search n [Hintdbmap.find "core" !searchtable] db argl g let superauto n to_add argl = tclTRY (tclCOMPLETE (search_superauto n to_add argl)) @@ -921,7 +892,7 @@ let default_superauto g = superauto !default_search_depth [] [] g let interp_to_add gl locqid = let r = Nametab.global locqid in let id = id_of_global r in - (next_ident_away id (pf_ids_of_hyps gl), constr_of_reference r) + (next_ident_away id (pf_ids_of_hyps gl), constr_of_global r) let gen_superauto nopt l a b gl = let n = match nopt with Some n -> n | None -> !default_search_depth in diff --git a/tactics/auto.mli b/tactics/auto.mli index ec8c0d71..ecd20f0d 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: auto.mli,v 1.22.2.2 2005/01/21 16:41:52 herbelin Exp $ i*) +(*i $Id: auto.mli 7937 2006-01-28 19:58:11Z herbelin $ i*) (*i*) open Util @@ -21,20 +21,20 @@ open Environ open Evd open Libnames open Vernacexpr +open Mod_subst (*i*) type auto_tactic = - | Res_pf of constr * unit clausenv (* Hint Apply *) - | ERes_pf of constr * unit clausenv (* Hint EApply *) + | Res_pf of constr * clausenv (* Hint Apply *) + | ERes_pf of constr * clausenv (* Hint EApply *) | Give_exact of constr - | Res_pf_THEN_trivial_fail of constr * unit clausenv (* Hint Immediate *) - | Unfold_nth of global_reference (* Hint Unfold *) + | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *) + | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of Tacexpr.glob_tactic_expr (* Hint Extern *) open Rawterm type pri_auto_tactic = { - hname : identifier; (* name of the hint *) pri : int; (* A number between 0 and 4, 4 = lower priority *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) code : auto_tactic; (* the tactic to apply when the concl matches pat *) @@ -48,19 +48,19 @@ module Hint_db : sig type t val empty : t - val find : constr_label -> t -> search_entry - val map_all : constr_label -> t -> pri_auto_tactic list - val map_auto : constr_label * constr -> t -> pri_auto_tactic list - val add_one : constr_label * pri_auto_tactic -> t -> t - val add_list : (constr_label * pri_auto_tactic) list -> t -> t - val iter : (constr_label -> stored_data list -> unit) -> t -> unit + val find : global_reference -> t -> search_entry + val map_all : global_reference -> t -> pri_auto_tactic list + val map_auto : global_reference * constr -> t -> pri_auto_tactic list + val add_one : global_reference * pri_auto_tactic -> t -> t + val add_list : (global_reference * pri_auto_tactic) list -> t -> t + val iter : (global_reference -> stored_data list -> unit) -> t -> unit end -type frozen_hint_db_table = Hint_db.t Stringmap.t +type hint_db_name = string -type hint_db_table = Hint_db.t Stringmap.t ref +val searchtable_map : hint_db_name -> Hint_db.t -type hint_db_name = string +val current_db_names : unit -> hint_db_name list val add_hints : locality_flag -> hint_db_name list -> hints -> unit @@ -72,25 +72,20 @@ val print_hint_ref : global_reference -> unit val print_hint_db_by_name : hint_db_name -> unit -val searchtable : hint_db_table - (* [make_exact_entry hint_name (c, ctyp)]. - [hint_name] is the name of then hint; [c] is the term given as an exact proof to solve the goal; [ctyp] is the type of [hc]. *) -val make_exact_entry : - identifier -> constr * constr -> constr_label * pri_auto_tactic +val make_exact_entry : constr * constr -> global_reference * pri_auto_tactic -(* [make_apply_entry (eapply,verbose) name (c,cty)]. +(* [make_apply_entry (eapply,verbose) (c,cty)]. [eapply] is true if this hint will be used only with EApply; - [name] is the name of then hint; [c] is the term given as an exact proof to solve the goal; [cty] is the type of [hc]. *) val make_apply_entry : - env -> evar_map -> bool * bool -> identifier -> constr * constr - -> constr_label * pri_auto_tactic + env -> evar_map -> bool * bool -> constr * constr + -> global_reference * pri_auto_tactic (* A constr which is Hint'ed will be: (1) used as an Exact, if it does not start with a product @@ -100,8 +95,8 @@ val make_apply_entry : has missing arguments. *) val make_resolves : - env -> evar_map -> identifier -> bool * bool -> constr * constr -> - (constr_label * pri_auto_tactic) list + env -> evar_map -> bool -> constr -> + (global_reference * pri_auto_tactic) list (* [make_resolve_hyp hname htyp]. used to add an hypothesis to the local hint database; @@ -110,13 +105,13 @@ val make_resolves : val make_resolve_hyp : env -> evar_map -> named_declaration -> - (constr_label * pri_auto_tactic) list + (global_reference * pri_auto_tactic) list -(* [make_extern name pri pattern tactic_expr] *) +(* [make_extern pri pattern tactic_expr] *) val make_extern : - identifier -> int -> constr_pattern -> Tacexpr.glob_tactic_expr - -> constr_label * pri_auto_tactic + int -> constr_pattern -> Tacexpr.glob_tactic_expr + -> global_reference * pri_auto_tactic val set_extern_interp : (patvar_map -> Tacexpr.glob_tactic_expr -> tactic) -> unit @@ -126,20 +121,20 @@ val set_extern_intern_tac : -> unit val set_extern_subst_tactic : - (Names.substitution -> Tacexpr.glob_tactic_expr -> Tacexpr.glob_tactic_expr) + (substitution -> Tacexpr.glob_tactic_expr -> Tacexpr.glob_tactic_expr) -> unit (* Create a Hint database from the pairs (name, constr). Useful to take the current goal hypotheses as hints *) -val make_local_hint_db : goal sigma -> Hint_db.t +val make_local_hint_db : constr list -> goal sigma -> Hint_db.t val priority : (int * 'a) list -> 'a list val default_search_depth : int ref (* Try unification with the precompiled clause, then use registered Apply *) -val unify_resolve : (constr * unit clausenv) -> tactic +val unify_resolve : (constr * clausenv) -> tactic (* [ConclPattern concl pat tacast]: if the term concl matches the pattern pat, (in sense of @@ -150,29 +145,29 @@ val conclPattern : constr -> constr_pattern -> Tacexpr.glob_tactic_expr -> tacti (* The Auto tactic *) -val auto : int -> hint_db_name list -> tactic +val auto : int -> constr list -> hint_db_name list -> tactic (* auto with default search depth and with the hint database "core" *) val default_auto : tactic (* auto with all hint databases except the "v62" compatibility database *) -val full_auto : int -> tactic +val full_auto : int -> constr list -> tactic (* auto with default search depth and with all hint databases except the "v62" compatibility database *) val default_full_auto : tactic (* The generic form of auto (second arg [None] means all bases) *) -val gen_auto : int option -> hint_db_name list option -> tactic +val gen_auto : int option -> constr list -> hint_db_name list option -> tactic (* The hidden version of auto *) -val h_auto : int option -> hint_db_name list option -> tactic +val h_auto : int option -> constr list -> hint_db_name list option -> tactic (* Trivial *) -val trivial : hint_db_name list -> tactic -val gen_trivial : hint_db_name list option -> tactic -val full_trivial : tactic -val h_trivial : hint_db_name list option -> tactic +val trivial : constr list -> hint_db_name list -> tactic +val gen_trivial : constr list -> hint_db_name list option -> tactic +val full_trivial : constr list -> tactic +val h_trivial : constr list -> hint_db_name list option -> tactic val fmt_autotactic : auto_tactic -> Pp.std_ppcmds diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 5706e134..ceeb4763 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Ast -open Coqast +(* $Id: autorewrite.ml 8114 2006-03-02 18:09:27Z herbelin $ *) + open Equality open Hipattern open Names @@ -20,9 +20,11 @@ open Term open Util open Vernacinterp open Tacexpr +open Mod_subst (* Rewriting rules *) -type rew_rule = constr * bool * glob_tactic_expr +(* the type is the statement of the lemma constr. Used to elim duplicates. *) +type rew_rule = constr * types * bool * glob_tactic_expr (* Summary and Object declaration *) let rewtab = @@ -39,10 +41,25 @@ let _ = Summary.survive_module = false; Summary.survive_section = false } +let print_rewrite_hintdb bas = + try + let hints = Stringmap.find bas !rewtab in + ppnl (str "Database " ++ str bas ++ (Pp.cut ()) ++ + prlist_with_sep Pp.cut + (fun (c,typ,d,t) -> + str (if d then "rewrite -> " else "rewrite <- ") ++ + Printer.pr_lconstr c ++ str " of type " ++ Printer.pr_lconstr typ ++ + str " then use tactic " ++ + Pptactic.pr_glob_tactic (Global.env()) t) hints) + with + Not_found -> + errorlabstrm "AutoRewrite" + (str ("Rewriting base "^(bas)^" does not exist")) + type raw_rew_rule = constr * bool * raw_tactic_expr (* Applies all the rules of one base *) -let one_base tac_main bas = +let one_base general_rewrite_maybe_in tac_main bas = let lrul = try Stringmap.find bas !rewtab @@ -50,24 +67,75 @@ let one_base tac_main bas = errorlabstrm "AutoRewrite" (str ("Rewriting base "^(bas)^" does not exist")) in - let lrul = List.map (fun (c,b,t) -> (c,b,Tacinterp.eval_tactic t)) lrul in + let lrul = List.map (fun (c,_,b,t) -> (c,b,Tacinterp.eval_tactic t)) lrul in tclREPEAT_MAIN (tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) -> tclTHEN tac (tclREPEAT_MAIN - (tclTHENSFIRSTn (general_rewrite dir csr) [|tac_main|] tc))) + (tclTHENSFIRSTn (general_rewrite_maybe_in dir csr) [|tac_main|] tc))) tclIDTAC lrul)) (* The AutoRewrite tactic *) let autorewrite tac_main lbas = tclREPEAT_MAIN (tclPROGRESS (List.fold_left (fun tac bas -> - tclTHEN tac (one_base tac_main bas)) tclIDTAC lbas)) + tclTHEN tac (one_base general_rewrite tac_main bas)) tclIDTAC lbas)) + +let autorewrite_in id tac_main lbas gl = + (* let's check at once if id exists (to raise the appropriate error) *) + let _ = Tacmach.pf_get_hyp gl id in + let general_rewrite_in = + let id = ref id in + let to_be_cleared = ref false in + fun dir cstr gl -> + let last_hyp_id = + match (Environ.named_context_of_val gl.Evd.it.Evd.evar_hyps) with + (last_hyp_id,_,_)::_ -> last_hyp_id + | _ -> (* even the hypothesis id is missing *) + error ("No such hypothesis : " ^ (string_of_id !id)) + in + let gl' = general_rewrite_in dir !id cstr gl in + let gls = (fst gl').Evd.it in + match gls with + g::_ -> + (match Environ.named_context_of_val g.Evd.evar_hyps with + (lastid,_,_)::_ -> + if last_hyp_id <> lastid then + begin + let gl'' = + if !to_be_cleared then + tclTHEN (fun _ -> gl') (tclTRY (clear [!id])) gl + else gl' in + id := lastid ; + to_be_cleared := true ; + gl'' + end + else + begin + to_be_cleared := false ; + gl' + end + | _ -> assert false) (* there must be at least an hypothesis *) + | _ -> assert false (* rewriting cannot complete a proof *) + in + tclREPEAT_MAIN (tclPROGRESS + (List.fold_left (fun tac bas -> + tclTHEN tac (one_base general_rewrite_in tac_main bas)) tclIDTAC lbas)) + gl (* Functions necessary to the library object declaration *) let cache_hintrewrite (_,(rbase,lrl)) = let l = try - lrl @ Stringmap.find rbase !rewtab + let oldl = Stringmap.find rbase !rewtab in + let lrl = + List.map + (fun (c,dummy,b,t) -> + (* here we substitute the dummy value with the right one *) + c,Typing.type_of (Global.env ()) Evd.empty c,b,t) lrl in + (List.filter + (fun (_,typ,_,_) -> + not (List.exists (fun (_,typ',_,_) -> Term.eq_constr typ typ') oldl) + ) lrl) @ oldl with | Not_found -> lrl in @@ -76,11 +144,16 @@ let cache_hintrewrite (_,(rbase,lrl)) = let export_hintrewrite x = Some x let subst_hintrewrite (_,subst,(rbase,list as node)) = - let subst_first (cst,b,t as pair) = - let cst' = Term.subst_mps subst cst in + let subst_first (cst,typ,b,t as pair) = + let cst' = subst_mps subst cst in + let typ' = + (* here we do not have the environment and Global.env () is not the + one where cst' lives in. Thus we can just put a dummy value and + override it in cache_hintrewrite *) + typ (* dummy value, it will be recomputed by cache_hintrewrite *) in let t' = Tacinterp.subst_tactic subst t in - if cst == cst' & t == t' then pair else - (cst',b,t) + if cst == cst' && t == t' then pair else + (cst',typ',b,t') in let list' = list_smartmap subst_first list in if list' == list then node else @@ -100,5 +173,10 @@ let (in_hintrewrite,out_hintrewrite)= (* To add rewriting rules to a base *) let add_rew_rules base lrul = - let lrul = List.rev_map (fun (c,b,t) -> (c,b,Tacinterp.glob_tactic t)) lrul in - Lib.add_anonymous_leaf (in_hintrewrite (base,lrul)) + let lrul = + List.rev_map + (fun (c,b,t) -> + (c,mkProp (* dummy value *), b,Tacinterp.glob_tactic t) + ) lrul + in + Lib.add_anonymous_leaf (in_hintrewrite (base,lrul)) diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index e97cde83..47d3c86a 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: autorewrite.mli,v 1.5.10.1 2004/07/16 19:30:52 herbelin Exp $ i*) +(*i $Id: autorewrite.mli 7034 2005-05-18 19:30:44Z sacerdot $ i*) (*i*) open Tacmach @@ -20,3 +20,6 @@ val add_rew_rules : string -> raw_rew_rule list -> unit (* The AutoRewrite tactic *) val autorewrite : tactic -> string list -> tactic +val autorewrite_in : Names.identifier -> tactic -> string list -> tactic + +val print_rewrite_hintdb : string -> unit diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index c5cdd540..f0b23b8d 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: btermdn.ml,v 1.5.16.1 2004/07/16 19:30:52 herbelin Exp $ *) +(* $Id: btermdn.ml 6427 2004-12-07 17:41:10Z sacerdot $ *) open Term open Termdn open Pattern +open Libnames (* Discrimination nets with bounded depth. See the module dn.ml for further explanations. @@ -34,7 +35,7 @@ let bounded_constr_val_discr (t,depth) = | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) -type 'a t = (constr_label,constr_pattern * int,'a) Dn.t +type 'a t = (global_reference,constr_pattern * int,'a) Dn.t let create = Dn.create diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index fe247495..1ac33557 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: btermdn.mli,v 1.8.16.1 2004/07/16 19:30:52 herbelin Exp $ i*) +(*i $Id: btermdn.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) (*i*) open Term diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index c9d0ead5..0f274aae 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: contradiction.ml,v 1.3.2.1 2004/07/16 19:30:52 herbelin Exp $ *) +(* $Id: contradiction.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Util open Term diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli index 90ec101c..d94a1ef2 100644 --- a/tactics/contradiction.mli +++ b/tactics/contradiction.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: contradiction.mli,v 1.2.2.1 2004/07/16 19:30:52 herbelin Exp $ i*) +(*i $Id: contradiction.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) (*i*) open Names diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml index fb672d0b..511e0950 100644 --- a/tactics/dhyp.ml +++ b/tactics/dhyp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: dhyp.ml,v 1.30.2.1 2004/07/16 19:30:52 herbelin Exp $ *) +(* $Id: dhyp.ml 7732 2005-12-26 13:51:24Z herbelin $ *) (* Chet's comments about this tactic : @@ -129,7 +129,6 @@ open Libobject open Library open Pattern open Matching -open Ast open Pcoq open Tacexpr open Libnames @@ -266,11 +265,10 @@ let match_dpat dp cls gls = | ({onhyps=lo;onconcl=false},HypLocation(_,hypd,concld)) -> let hl = match lo with Some l -> l - | None -> List.map (fun id -> (id,[],(InHyp,ref None))) - (pf_ids_of_hyps gls) in + | None -> List.map (fun id -> (id,[],InHyp)) (pf_ids_of_hyps gls) in if not (List.for_all - (fun (id,_,(hl,_)) -> + (fun (id,_,hl) -> let cltyp = pf_get_hyp_typ gls id in let cl = pf_concl gls in (hl=InHyp) & diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli index a0cef679..630092f0 100644 --- a/tactics/dhyp.mli +++ b/tactics/dhyp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: dhyp.mli,v 1.8.2.1 2004/07/16 19:30:52 herbelin Exp $ i*) +(*i $Id: dhyp.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) (*i*) open Names diff --git a/tactics/dn.ml b/tactics/dn.ml index 55116831..ab908ff9 100644 --- a/tactics/dn.ml +++ b/tactics/dn.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: dn.ml,v 1.5.16.1 2004/07/16 19:30:52 herbelin Exp $ *) +(* $Id: dn.ml 5920 2004-07-16 20:01:26Z herbelin $ *) (* This file implements the basic structure of what Chet called ``discrimination nets''. If my understanding is right, it serves diff --git a/tactics/dn.mli b/tactics/dn.mli index a54007d8..f8efd053 100644 --- a/tactics/dn.mli +++ b/tactics/dn.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: dn.mli,v 1.4.16.1 2004/07/16 19:30:52 herbelin Exp $ i*) +(*i $Id: dn.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) (* Discrimination nets. *) diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 31d79948..457f8318 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: eauto.ml4,v 1.11.2.1 2004/07/16 19:30:52 herbelin Exp $ *) +(* $Id: eauto.ml4 7991 2006-02-05 22:56:16Z herbelin $ *) open Pp open Util @@ -32,7 +32,7 @@ open Rawterm let e_give_exact c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in if occur_existential t1 or occur_existential t2 then - tclTHEN (unify t1) (exact_check c) gl + tclTHEN (Clenvtac.unify t1) (exact_check c) gl else exact_check c gl let assumption id = e_give_exact (mkVar id) @@ -40,19 +40,19 @@ let assumption id = e_give_exact (mkVar id) let e_assumption gl = tclFIRST (List.map assumption (pf_ids_of_hyps gl)) gl +TACTIC EXTEND eassumption +| [ "eassumption" ] -> [ e_assumption ] +END + let e_resolve_with_bindings_tac (c,lbind) gl = - let (wc,kONT) = startWalk gl in - let t = w_hnf_constr wc (w_type_of wc c) in - let clause = make_clenv_binding_apply wc (-1) (c,t) lbind in - e_res_pf kONT clause gl + let t = pf_hnf_constr gl (pf_type_of gl c) in + let clause = make_clenv_binding_apply gl (-1) (c,t) lbind in + Clenvtac.e_res_pf clause gl let e_resolve_constr c gls = e_resolve_with_bindings_tac (c,NoBindings) gls -(* V8 TACTIC EXTEND eexact +TACTIC EXTEND eexact | [ "eexact" constr(c) ] -> [ e_give_exact c ] -END*) -TACTIC EXTEND Eexact -| [ "EExact" constr(c) ] -> [ e_give_exact c ] END let e_give_exact_constr = h_eexact @@ -62,11 +62,8 @@ let registered_e_assumption gl = (pf_ids_of_hyps gl)) gl (* This automatically define h_eApply (among other things) *) -(*V8 TACTIC EXTEND eapply - [ "eapply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ] -END*) TACTIC EXTEND eapply - [ "EApply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ] + [ "eapply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ] END let vernac_e_resolve_constr c = h_eapply (c,NoBindings) @@ -75,8 +72,7 @@ let e_constructor_tac boundopt i lbind gl = let cl = pf_concl gl in let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in let nconstr = - Array.length (snd (Global.lookup_inductive mind)).mind_consnames - and sigma = project gl in + Array.length (snd (Global.lookup_inductive mind)).mind_consnames in if i=0 then error "The constructors are numbered starting from 1"; if i > nconstr then error "Not enough constructors"; begin match boundopt with @@ -87,7 +83,8 @@ let e_constructor_tac boundopt i lbind gl = end; let cons = mkConstruct (ith_constructor_of_inductive mind i) in let apply_tac = e_resolve_with_bindings_tac (cons,lbind) in - (tclTHENLIST [convert_concl_no_check redcl; intros; apply_tac]) gl + (tclTHENLIST [convert_concl_no_check redcl DEFAULTcast +; intros; apply_tac]) gl let e_one_constructor i = e_constructor_tac None i @@ -107,33 +104,30 @@ let e_right = e_constructor_tac (Some 2) 2 let e_split = e_constructor_tac (Some 1) 1 (* This automatically define h_econstructor (among other things) *) -(*V8 TACTIC EXTEND eapply - [ "econstructor" integer(n) with_bindings(c) ] -> [ e_constructor_tac None n c ] -END*) TACTIC EXTEND econstructor - [ "EConstructor" integer(n) "with" bindings(c) ] -> [ e_constructor_tac None n c ] - | [ "EConstructor" integer(n) ] -> [ e_constructor_tac None n NoBindings ] - | [ "EConstructor" tactic_opt(t) ] -> [ e_any_constructor (option_app Tacinterp.eval_tactic t) ] + [ "econstructor" integer(n) "with" bindings(c) ] -> [ e_constructor_tac None n c ] +| [ "econstructor" integer(n) ] -> [ e_constructor_tac None n NoBindings ] +| [ "econstructor" tactic_opt(t) ] -> [ e_any_constructor (option_app Tacinterp.eval_tactic t) ] END TACTIC EXTEND eleft - [ "ELeft" "with" bindings(l) ] -> [e_left l] - | [ "ELeft"] -> [e_left NoBindings] + [ "eleft" "with" bindings(l) ] -> [e_left l] +| [ "eleft"] -> [e_left NoBindings] END TACTIC EXTEND eright - [ "ERight" "with" bindings(l) ] -> [e_right l] - | [ "ERight" ] -> [e_right NoBindings] + [ "eright" "with" bindings(l) ] -> [e_right l] +| [ "eright" ] -> [e_right NoBindings] END TACTIC EXTEND esplit - [ "ESplit" "with" bindings(l) ] -> [e_split l] - | [ "ESplit"] -> [e_split NoBindings] + [ "esplit" "with" bindings(l) ] -> [e_split l] +| [ "esplit"] -> [e_split NoBindings] END TACTIC EXTEND eexists - [ "EExists" bindings(l) ] -> [e_split l] + [ "eexists" bindings(l) ] -> [e_split l] END @@ -162,29 +156,10 @@ let prolog_tac l n gl = with UserError ("Refiner.tclFIRST",_) -> errorlabstrm "Prolog.prolog" (str "Prolog failed") -(* V8 TACTIC EXTEND prolog +TACTIC EXTEND prolog | [ "prolog" "[" constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ] -END*) -TACTIC EXTEND Prolog -| [ "Prolog" "[" constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ] END -(* -let vernac_prolog = - let uncom = function - | Constr c -> c - | _ -> assert false - in - let gentac = - hide_tactic "Prolog" - (function - | (Integer n) :: al -> prolog_tac (List.map uncom al) n - | _ -> assert false) - in - fun coms n -> - gentac ((Integer n) :: (List.map (fun com -> (Constr com)) coms)) -*) - open Auto (***************************************************************************) @@ -192,8 +167,7 @@ open Auto (***************************************************************************) let unify_e_resolve (c,clenv) gls = - let (wc,kONT) = startWalk gls in - let clenv' = connect_clenv wc clenv in + let clenv' = connect_clenv gls clenv in let _ = clenv_unique_resolver false clenv' gls in vernac_e_resolve_constr c gls @@ -219,7 +193,7 @@ and e_my_find_search db_list local_db hdc concl = list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list) in let tac_of_hint = - fun ({pri=b; pat = p; code=t} as patac) -> + fun {pri=b; pat = p; code=t} -> (b, let tac = match t with @@ -229,7 +203,7 @@ and e_my_find_search db_list local_db hdc concl = | Res_pf_THEN_trivial_fail (term,cl) -> tclTHEN (unify_e_resolve (term,cl)) (e_trivial_fail_db db_list local_db) - | Unfold_nth c -> unfold_constr c + | Unfold_nth c -> unfold_in_concl [[],c] | Extern tacast -> conclPattern concl (out_some p) tacast in @@ -309,7 +283,7 @@ module SearchProblem = struct filter_tactics s.tacres (List.map (fun id -> (e_give_exact_constr (mkVar id), - (str "Exact" ++ spc () ++ pr_id id))) + (str "exact" ++ spc () ++ pr_id id))) (pf_ids_of_hyps g)) in List.map (fun (res,pp) -> { depth = s.depth; tacres = res; @@ -327,7 +301,7 @@ module SearchProblem = struct { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = ldb :: List.tl s.localdb }) - (filter_tactics s.tacres [Tactics.intro,(str "Intro")]) + (filter_tactics s.tacres [Tactics.intro,(str "intro")]) in let rec_tacs = let l = @@ -380,33 +354,32 @@ let e_breadth_search debug n db_list local_db gl = s.SearchProblem.tacres with Not_found -> error "EAuto: breadth first search failed" -let e_search_auto debug (in_depth,p) db_list gl = - let local_db = make_local_hint_db gl in +let e_search_auto debug (in_depth,p) lems db_list gl = + let local_db = make_local_hint_db lems gl in if in_depth then e_depth_search debug p db_list local_db gl else e_breadth_search debug p db_list local_db gl -let eauto debug np dbnames = +let eauto debug np lems dbnames = let db_list = List.map (fun x -> - try Stringmap.find x !searchtable + try searchtable_map x with Not_found -> error ("EAuto: "^x^": No such Hint database")) ("core"::dbnames) in - tclTRY (e_search_auto debug np db_list) + tclTRY (e_search_auto debug np lems db_list) -let full_eauto debug n gl = - let dbnames = stringmap_dom !searchtable in +let full_eauto debug n lems gl = + let dbnames = current_db_names () in let dbnames = list_subtract dbnames ["v62"] in - let db_list = List.map (fun x -> Stringmap.find x !searchtable) dbnames in - let local_db = make_local_hint_db gl in - tclTRY (e_search_auto debug n db_list) gl + let db_list = List.map searchtable_map dbnames in + tclTRY (e_search_auto debug n lems db_list) gl -let gen_eauto d np = function - | None -> full_eauto d np - | Some l -> eauto d np l +let gen_eauto d np lems = function + | None -> full_eauto d np lems + | Some l -> eauto d np lems l let make_depth = function | None -> !default_search_depth @@ -422,10 +395,7 @@ open Genarg (* Hint bases *) -let pr_hintbases _prc _prt = function - | None -> str " with *" - | Some [] -> mt () - | Some l -> str " with " ++ Util.prlist_with_sep spc str l +let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases ARGUMENT EXTEND hintbases TYPED AS preident_list_opt @@ -435,14 +405,26 @@ ARGUMENT EXTEND hintbases | [ ] -> [ Some [] ] END -TACTIC EXTEND EAuto -| [ "EAuto" int_or_var_opt(n) int_or_var_opt(p) hintbases(db) ] -> - [ gen_eauto false (make_dimension n p) db ] -END +let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_coma prc -V7 TACTIC EXTEND EAutodebug -| [ "EAutod" int_or_var_opt(n) int_or_var_opt(p) hintbases(db) ] -> - [ gen_eauto true (make_dimension n p) db ] +ARGUMENT EXTEND constr_coma_sequence + TYPED AS constr_list + PRINTED BY pr_constr_coma_sequence +| [ constr(c) "," constr_coma_sequence(l) ] -> [ c::l ] +| [ constr(c) ] -> [ [c] ] END +let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc +ARGUMENT EXTEND auto_using + TYPED AS constr_list + PRINTED BY pr_auto_using +| [ "using" constr_coma_sequence(l) ] -> [ l ] +| [ ] -> [ [] ] +END + +TACTIC EXTEND eauto +| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ gen_eauto false (make_dimension n p) lems db ] +END diff --git a/tactics/eauto.mli b/tactics/eauto.mli index c3084e65..4621088e 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -10,9 +10,13 @@ open Term open Proof_type open Tacexpr +open Auto +open Topconstr (*i*) -val rawwit_hintbases : string list option raw_abstract_argument_type +val rawwit_hintbases : hint_db_name list option raw_abstract_argument_type + +val rawwit_auto_using : constr_expr list raw_abstract_argument_type val e_assumption : tactic @@ -23,3 +27,7 @@ val e_resolve_constr : constr -> tactic val vernac_e_resolve_constr : constr -> tactic val e_give_exact_constr : constr -> tactic + +val gen_eauto : bool -> bool * int -> constr list -> + hint_db_name list option -> tactic + diff --git a/tactics/elim.ml b/tactics/elim.ml index 5573f9ea..2e079567 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: elim.ml,v 1.37.2.1 2004/07/16 19:30:53 herbelin Exp $ *) +(* $Id: elim.ml 7538 2005-11-08 17:14:52Z herbelin $ *) open Pp open Util @@ -181,7 +181,6 @@ let double_ind h1 h2 gls = if abs_i < abs_j then (abs_i,abs_j) else if abs_i > abs_j then (abs_j,abs_i) else error "Both hypotheses are the same" in - let cl = pf_concl gls in (tclTHEN (tclDO abs_i intro) (onLastHyp (fun id -> diff --git a/tactics/elim.mli b/tactics/elim.mli index a891cd9d..d01d3027 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: elim.mli,v 1.10.2.1 2004/07/16 19:30:53 herbelin Exp $ i*) +(*i $Id: elim.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) (*i*) open Names diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4 index 8edfcb3e..9cbc549f 100644 --- a/tactics/eqdecide.ml4 +++ b/tactics/eqdecide.ml4 @@ -14,7 +14,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: eqdecide.ml4,v 1.6.2.1 2004/07/16 19:30:53 herbelin Exp $ *) +(* $Id: eqdecide.ml4 8652 2006-03-22 08:27:14Z herbelin $ *) open Util open Names @@ -46,11 +46,11 @@ open Coqlib 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 correspoing pairs of arguments. + 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 left half + 4. Once all the arguments have been rewritten, solve the remaining half of the disjunction by reflexivity. Eduardo Gimenez (30/3/98). @@ -58,35 +58,36 @@ open Coqlib let clear_last = (tclLAST_HYP (fun c -> (clear [destVar c]))) -let mkBranches = +let choose_eq eqonleft = + if eqonleft then h_simplest_left else h_simplest_right +let choose_noteq eqonleft = + if eqonleft then h_simplest_right else h_simplest_left + +let mkBranches c1 c2 = tclTHENSEQ - [intro; - tclLAST_HYP h_simplest_elim; - clear_last; - intros ; + [generalize [c2]; + h_simplest_elim c1; + intros; tclLAST_HYP h_simplest_case; clear_last; intros] -let solveRightBranch = - tclTHEN h_simplest_right +let solveNoteqBranch side = + tclTHEN (choose_noteq side) (tclTHEN (intro_force true) (onLastHyp (fun id -> Extratactics.h_discrHyp (Rawterm.NamedHyp id)))) -let h_solveRightBranch = - Refiner.abstract_extended_tactic "solveRightBranch" [] solveRightBranch - -(* -let h_solveRightBranch = - hide_atomic_tactic "solveRightBranch" solveRightBranch -*) +let h_solveNoteqBranch side = + Refiner.abstract_extended_tactic "solveNoteqBranch" [] + (solveNoteqBranch side) (* Constructs the type {c1=c2}+{~c1=c2} *) -let mkDecideEqGoal rectype c1 c2 g = +let mkDecideEqGoal eqonleft op rectype c1 c2 g = let equality = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in let disequality = mkApp(build_coq_not (), [|equality|]) in - mkApp(build_coq_sumbool (), [|equality; disequality |]) + if eqonleft then mkApp(op, [|equality; disequality |]) + else mkApp(op, [|disequality; equality |]) (* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *) @@ -97,42 +98,45 @@ let mkGenDecideEqGoal rectype g = and yname = next_ident_away (id_of_string "y") hypnames in (mkNamedProd xname rectype (mkNamedProd yname rectype - (mkDecideEqGoal rectype (mkVar xname) (mkVar yname) g))) + (mkDecideEqGoal true (build_coq_sumbool ()) + rectype (mkVar xname) (mkVar yname) g))) -let eqCase tac = +let eqCase tac = (tclTHEN intro (tclTHEN (tclLAST_HYP Extratactics.h_rewriteLR) (tclTHEN clear_last tac))) -let diseqCase = +let diseqCase eqonleft = let diseq = id_of_string "diseq" in let absurd = id_of_string "absurd" in (tclTHEN (intro_using diseq) - (tclTHEN h_simplest_right + (tclTHEN (choose_noteq eqonleft) (tclTHEN red_in_concl (tclTHEN (intro_using absurd) (tclTHEN (h_simplest_apply (mkVar diseq)) (tclTHEN (Extratactics.h_injHyp (Rawterm.NamedHyp absurd)) - full_trivial)))))) + (full_trivial []))))))) -let solveArg a1 a2 tac g = +let solveArg eqonleft op a1 a2 tac g = let rectype = pf_type_of g a1 in - let decide = mkDecideEqGoal rectype a1 a2 g in - (tclTHENS - (h_elim_type decide) - [(eqCase tac);diseqCase;default_auto]) g + let decide = mkDecideEqGoal eqonleft op rectype a1 a2 g in + let subtacs = + if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto] + else [diseqCase eqonleft;eqCase tac;default_auto] in + (tclTHENS (h_elim_type decide) subtacs) g -let solveLeftBranch rectype g = +let solveEqBranch rectype g = try - let (lhs,rhs) = match_eqdec_partial (pf_concl g) in + let (eqonleft,op,lhs,rhs,_) = match_eqdec (pf_concl g) in let (mib,mip) = Global.lookup_inductive rectype in - let nparams = mip.mind_nparams in + let nparams = mib.mind_nparams in let getargs l = list_skipn nparams (snd (decompose_app l)) in let rargs = getargs rhs and largs = getargs lhs in List.fold_right2 - solveArg largs rargs (tclTHEN h_simplest_left h_reflexivity) g + (solveArg eqonleft op) largs rargs + (tclTHEN (choose_eq eqonleft) h_reflexivity) g with PatternMatchingFailure -> error "Unexpected conclusion!" (* The tactic Decide Equality *) @@ -143,31 +147,33 @@ let hd_app c = match kind_of_term c with let decideGralEquality g = try - let typ = match_eqdec (pf_concl g) in + let eqonleft,_,c1,c2,typ = match_eqdec (pf_concl g) in let headtyp = hd_app (pf_compute g typ) in let rectype = match kind_of_term headtyp with | Ind mi -> mi | _ -> error "This decision procedure only works for inductive objects" - in + in (tclTHEN - mkBranches - (tclORELSE h_solveRightBranch (solveLeftBranch rectype))) g + (mkBranches c1 c2) + (tclORELSE (h_solveNoteqBranch eqonleft) (solveEqBranch rectype))) + g with PatternMatchingFailure -> - error "The goal does not have the expected form" + error "The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}" +let decideEqualityGoal = tclTHEN intros decideGralEquality let decideEquality c1 c2 g = let rectype = (pf_type_of g c1) in let decide = mkGenDecideEqGoal rectype g in - (tclTHENS (cut decide) [default_auto;decideGralEquality]) g + (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) g (* The tactic Compare *) let compare c1 c2 g = let rectype = pf_type_of g c1 in - let decide = mkDecideEqGoal rectype c1 c2 g in + let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 g in (tclTHENS (cut decide) [(tclTHEN intro (tclTHEN (tclLAST_HYP simplest_case) @@ -177,12 +183,11 @@ let compare c1 c2 g = (* User syntax *) -TACTIC EXTEND DecideEquality - [ "Decide" "Equality" constr(c1) constr(c2) ] -> [ decideEquality c1 c2 ] -| [ "Decide" "Equality" ] -> [ decideGralEquality ] +TACTIC EXTEND decide_equality + [ "decide" "equality" constr(c1) constr(c2) ] -> [ decideEquality c1 c2 ] +| [ "decide" "equality" ] -> [ decideEqualityGoal ] END -TACTIC EXTEND Compare -| [ "Compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] +TACTIC EXTEND compare +| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] END - diff --git a/tactics/equality.ml b/tactics/equality.ml index 994abb9d..be79c348 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: equality.ml,v 1.120.2.4 2004/11/21 22:24:09 herbelin Exp $ *) +(* $Id: equality.ml 8677 2006-04-02 17:05:59Z herbelin $ *) open Pp open Util @@ -20,7 +20,6 @@ open Inductiveops open Environ open Libnames open Reductionops -open Instantiate open Typeops open Typing open Retyping @@ -40,6 +39,7 @@ open Coqlib open Vernacexpr open Setoid_replace open Declarations +open Indrec (* Rewriting tactics *) @@ -48,10 +48,28 @@ open Declarations with type (A:)(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 + -- Eduardo (19/8/97) *) -let general_rewrite_bindings lft2rgt (c,l) gl = +let general_s_rewrite_clause = function + | None -> general_s_rewrite + | Some id -> general_s_rewrite_in id + +(* Ad hoc asymmetric general_elim_clause *) +let general_elim_clause cls c elim = 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 (general_elim c elim ~allow_K:false) + | Some id -> + general_elim_in id c elim + +let elimination_sort_of_clause = function + | None -> elimination_sort_of_goal + | Some id -> elimination_sort_of_hyp id + +let general_rewrite_bindings_clause cls lft2rgt (c,l) gl = let ctype = pf_type_of gl c in let env = pf_env gl in let sigma = project gl in @@ -59,21 +77,27 @@ let general_rewrite_bindings lft2rgt (c,l) gl = match match_with_equation t with | None -> if l = NoBindings - then general_s_rewrite lft2rgt c gl + then general_s_rewrite_clause cls lft2rgt c [] gl else error "The term provided does not end with an equation" | Some (hdcncl,_) -> let hdcncls = string_of_inductive hdcncl in - let suffix = Indrec.elimination_suffix (elimination_sort_of_goal gl)in + let suffix = elimination_suffix (elimination_sort_of_clause cls gl) in + let dir = if cls=None then lft2rgt else not lft2rgt in + let rwr_thm = if dir then hdcncls^suffix^"_r" else hdcncls^suffix in let elim = - if lft2rgt then - pf_global gl (id_of_string (hdcncls^suffix^"_r")) - else - pf_global gl (id_of_string (hdcncls^suffix)) + try pf_global gl (id_of_string rwr_thm) + with Not_found -> + error ("Cannot find rewrite principle "^rwr_thm) in - tclNOTSAMEGOAL (general_elim (c,l) (elim,NoBindings) ~allow_K:false) gl - (* was tclWEAK_PROGRESS which only fails for tactics generating one subgoal - and did not fail for useless conditional rewritings generating an - extra condition *) + general_elim_clause cls (c,l) (elim,NoBindings) gl + +let general_rewrite_bindings = general_rewrite_bindings_clause None +let general_rewrite l2r c = general_rewrite_bindings l2r (c,NoBindings) + +let general_rewrite_bindings_in l2r id = + general_rewrite_bindings_clause (Some id) l2r +let general_rewrite_in l2r id c = + general_rewrite_bindings_clause (Some id) l2r (c,NoBindings) (* Conditional rewriting, the success of a rewriting is related to the resolution of the conditions by a given tactic *) @@ -82,73 +106,69 @@ let conditional_rewrite lft2rgt tac (c,bl) = tclTHENSFIRSTn (general_rewrite_bindings lft2rgt (c,bl)) [|tclIDTAC|] (tclCOMPLETE tac) -let general_rewrite lft2rgt c = general_rewrite_bindings lft2rgt (c,NoBindings) - let rewriteLR_bindings = general_rewrite_bindings true let rewriteRL_bindings = general_rewrite_bindings false let rewriteLR = general_rewrite true let rewriteRL = general_rewrite false -(* The Rewrite in tactic *) -let general_rewrite_in lft2rgt id (c,l) gl = - let ctype = pf_type_of gl c in - let env = pf_env gl in - let sigma = project gl in - let _,t = splay_prod env sigma ctype in - match match_with_equation t with - | None -> (* Do not deal with setoids yet *) - error "The term provided does not end with an equation" - | Some (hdcncl,_) -> - let hdcncls = string_of_inductive hdcncl in - let suffix = - Indrec.elimination_suffix (elimination_sort_of_hyp id gl) in - let rwr_thm = - if lft2rgt then hdcncls^suffix else hdcncls^suffix^"_r" in - let elim = - try pf_global gl (id_of_string rwr_thm) - with Not_found -> - error ("Cannot find rewrite principle "^rwr_thm) in - general_elim_in id (c,l) (elim,NoBindings) gl - -let rewriteLRin = general_rewrite_in true -let rewriteRLin = general_rewrite_in false +let rewriteLRin_bindings = general_rewrite_bindings_in true +let rewriteRLin_bindings = general_rewrite_bindings_in false let conditional_rewrite_in lft2rgt id tac (c,bl) = - tclTHENSFIRSTn (general_rewrite_in lft2rgt id (c,bl)) + tclTHENSFIRSTn (general_rewrite_bindings_in lft2rgt id (c,bl)) [|tclIDTAC|] (tclCOMPLETE tac) let rewriteRL_clause = function | None -> rewriteRL_bindings - | Some id -> rewriteRLin id + | Some id -> rewriteRLin_bindings id (* Replacing tactics *) -(* eqt,sym_eqt : equality on Type and its symmetry theorem +(* eq,sym_eq : equality on Type and its symmetry theorem c2 c1 : 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 abstract_replace clause c2 c1 unsafe gl = +let abstract_replace clause c2 c1 unsafe tac gl = let t1 = pf_type_of gl c1 and t2 = pf_type_of gl c2 in if unsafe or (pf_conv_x gl t1 t2) then - let e = (build_coq_eqT_data ()).eq in - let sym = (build_coq_eqT_data ()).sym in + let e = build_coq_eq () in + let sym = build_coq_sym_eq () in let eq = applist (e, [t1;c1;c2]) in tclTHENS (assert_tac false Anonymous eq) [onLastHyp (fun id -> tclTHEN (tclTRY (rewriteRL_clause clause (mkVar id,NoBindings))) (clear [id])); - tclORELSE assumption - (tclTRY (tclTHEN (apply sym) assumption))] gl + tclFIRST + [assumption; + tclTHEN (apply sym) assumption; + tclTRY (tclCOMPLETE tac) + ] + ] gl else error "terms does not have convertible types" -let replace c2 c1 gl = abstract_replace None c2 c1 false gl -let replace_in id c2 c1 gl = abstract_replace (Some id) c2 c1 false gl +let replace c2 c1 gl = abstract_replace None c2 c1 false tclIDTAC gl + +let replace_in id c2 c1 gl = abstract_replace (Some id) c2 c1 false tclIDTAC gl + +let replace_by c2 c1 tac gl = abstract_replace None c2 c1 false tac gl + +let replace_in_by id c2 c1 tac gl = abstract_replace (Some id) c2 c1 false tac gl + + +let new_replace c2 c1 id tac_opt gl = + let tac = + match tac_opt with + | Some tac -> tac + | _ -> tclIDTAC + in + abstract_replace id c2 c1 false tac gl (* End of Eduardo's code. The rest of this file could be improved using the functions match_with_equation, etc that I defined @@ -156,24 +176,8 @@ let replace_in id c2 c1 gl = abstract_replace (Some id) c2 c1 false gl -- Eduardo (19/8/97) *) -(* Tactics for equality reasoning with the "eq" or "eqT" - relation This code will work with any equivalence relation which - is substitutive *) - -(* Patterns *) - -let build_coq_eq eq = eq.eq -let build_ind eq = eq.ind -let build_rect eq = - match eq.rect with - | None -> assert false - | Some c -> c - -(*********** List of constructions depending of the initial state *) - -let find_eq_pattern aritysort sort = - (* "eq" now accept arguments in Type and elimination to Type *) - Coqlib.build_coq_eq () +(* Tactics for equality reasoning with the "eq" relation. This code + will work with any equivalence relation which is substitutive *) (* [find_positions t1 t2] @@ -317,7 +321,7 @@ let discriminable env sigma t1 t2 = the continuation then constructs the case-split. *) let descend_then sigma env head dirn = - let IndType (indf,_) as indt = + let IndType (indf,_) = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> assert false in let ind,_ = dest_ind_family indf in @@ -360,7 +364,7 @@ let descend_then sigma env head dirn = giving [True], and all the rest giving False. *) let construct_discriminator sigma env dirn c sort = - let (IndType(indf,_) as indt) = + let IndType(indf,_) = try find_rectype env sigma (type_of env sigma c) with Not_found -> (* one can find Rel(k) in case of dependent constructors @@ -395,8 +399,7 @@ let rec build_discriminator sigma env dirn c sort = function try find_rectype env sigma cty with Not_found -> assert false in let (ind,_) = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in - let _,arsort = get_arity env indf in - let nparams = mip.mind_nparams in + let nparams = mib.mind_nparams in let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in let newc = mkRel(cnum_nlams-(argnum-nparams)) in let subval = build_discriminator sigma cnum_env dirn newc sort l in @@ -420,7 +423,7 @@ let gen_absurdity id gl = let discrimination_pf e (t,t1,t2) discriminator lbeq gls = let i = build_coq_I () in let absurd_term = build_coq_False () in - let eq_elim = build_ind lbeq in + let eq_elim = lbeq.ind in (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term) exception NotDiscriminable @@ -437,7 +440,6 @@ let discrEq (lbeq,(t,t1,t2)) id gls = let e_env = push_named (e,None,t) env in let discriminator = build_discriminator sigma e_env dirn (mkVar e) sort cpath in - let (indt,_) = find_mrectype env sigma t in let (pf, absurd_term) = discrimination_pf e (t,t1,t2) discriminator lbeq gls in @@ -457,22 +459,16 @@ let onEquality tac id gls = errorlabstrm "" (pr_id id ++ str": not a primitive equality") in tac eq id gls -let check_equality tac id gls = - let eqn = pf_whd_betadeltaiota gls (pf_get_hyp_typ gls id) in +let onNegatedEquality tac gls = + let ccl = pf_concl gls in let eq = - try find_eq_data_decompose eqn + try match kind_of_term (hnf_constr (pf_env gls) (project gls) ccl) with + | Prod (_,t,u) when is_empty_type u -> + find_eq_data_decompose (pf_whd_betadeltaiota gls t) + | _ -> raise PatternMatchingFailure with PatternMatchingFailure -> - errorlabstrm "" (str "The goal should negate an equality") - in tac eq id gls - -let onNegatedEquality tac gls = - if is_matching_not (pf_concl gls) then - (tclTHEN (tclTHEN hnf_in_concl intro) (onLastHyp(check_equality tac))) gls - else if is_matching_imp_False (pf_concl gls)then - (tclTHEN intro (onLastHyp (check_equality tac))) gls - else - errorlabstrm "extract_negated_equality_then" - (str"The goal should negate an equality") + errorlabstrm "" (str "Not a negated primitive equality") + in tclTHEN introf (onLastHyp (tac eq)) gls let discrSimpleClause = function | None -> onNegatedEquality discrEq @@ -577,33 +573,34 @@ let minimal_free_rels env sigma (c,cty) = *) -let sig_clausal_form env sigma sort_of_ty siglen ty (dFLT,dFLTty) = +let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let { intro = exist_term } = find_sigma_data sort_of_ty in - let isevars = Evarutil.create_evar_defs sigma in + let isevars = ref (Evd.create_evar_defs sigma) in let rec sigrec_clausal_form siglen p_i = if siglen = 0 then - if Evarconv.the_conv_x_leq env isevars dFLTty p_i then + (* is the default value typable with the expected type *) + let dflt_typ = type_of env sigma dflt in + if Evarconv.e_cumul env isevars dflt_typ p_i then (* the_conv_x had a side-effect on isevars *) - dFLT + dflt else error "Cannot solve an unification problem" else let (a,p_i_minus_1) = match whd_beta_stack p_i with | (_sigS,[a;p]) -> (a,p) | _ -> anomaly "sig_clausal_form: should be a sigma type" in - let ev = Evarutil.new_isevar isevars env (dummy_loc,InternalHole) - (Evarutil.new_Type ()) in + let ev = Evarutil.e_new_evar isevars env a in let rty = beta_applist(p_i_minus_1,[ev]) in let tuple_tail = sigrec_clausal_form (siglen-1) rty in match - Instantiate.existential_opt_value (Evarutil.evars_of isevars) + Evd.existential_opt_value (Evd.evars_of !isevars) (destEvar ev) with | Some w -> applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) | None -> anomaly "Not enough components to build the dependent tuple" in let scf = sigrec_clausal_form siglen ty in - Evarutil.nf_evar (Evarutil.evars_of isevars) scf + Evarutil.nf_evar (Evd.evars_of !isevars) scf (* The problem is to build a destructor (a generalization of the predecessor) which, when applied to a term made of constructors @@ -675,25 +672,23 @@ let make_iterated_tuple env sigma dflt (z,zty) = let dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in (tuple,tuplety,dfltval) -let rec build_injrec sigma env (t1,t2) c = function - | [] -> - make_iterated_tuple env sigma (t1,type_of env sigma t1) - (c,type_of env sigma c) +let rec build_injrec sigma env dflt c = function + | [] -> make_iterated_tuple env sigma dflt (c,type_of env sigma c) | ((sp,cnum),argnum)::l -> let cty = type_of env sigma c in let (ity,_) = find_mrectype env sigma cty in let (mib,mip) = lookup_mind_specif env ity in - let nparams = mip.mind_nparams in + let nparams = mib.mind_nparams in let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in let newc = mkRel(cnum_nlams-(argnum-nparams)) in let (subval,tuplety,dfltval) = - build_injrec sigma cnum_env (t1,t2) newc l + build_injrec sigma cnum_env dflt newc l in (kont subval (dfltval,tuplety), tuplety,dfltval) -let build_injector sigma env (t1,t2) c cpath = - let (injcode,resty,_) = build_injrec sigma env (t1,t2) c cpath in +let build_injector sigma env dflt c cpath = + let (injcode,resty,_) = build_injrec sigma env dflt c cpath in (injcode,resty) let try_delta_expand env sigma t = @@ -702,7 +697,7 @@ let try_delta_expand env sigma t = match kind_of_term c with | Construct _ -> whdt | App (f,_) -> hd_rec f - | Cast (c,_) -> hd_rec c + | Cast (c,_,_) -> hd_rec c | _ -> t in hd_rec whdt @@ -730,7 +725,8 @@ let injEq (eq,(t,t1,t2)) id gls = (fun (cpath,t1_0,t2_0) -> try let (injbody,resty) = - build_injector sigma e_env (t1_0,t2_0) (mkVar e) cpath in + (* take arbitrarily t1_0 as the injector default value *) + build_injector sigma e_env t1_0 (mkVar e) cpath in let injfun = mkNamedLambda e t injbody in let _ = type_of env sigma injfun in (injfun,resty) with e when catchable_exception e -> @@ -794,7 +790,8 @@ let decompEqThen ntac (lbeq,(t,t1,t2)) id gls = map_succeed (fun (cpath,t1_0,t2_0) -> let (injbody,resty) = - build_injector sigma e_env (t1_0,t2_0) (mkVar e) cpath in + (* take arbitrarily t1_0 as the injector default value *) + build_injector sigma e_env t1_0 (mkVar e) cpath in let injfun = mkNamedLambda e t injbody in try let _ = type_of env sigma injfun in (injfun,resty) @@ -833,67 +830,37 @@ let swap_equands gls eqn = let swapEquandsInConcl gls = let (lbeq,(t,e1,e2)) = find_eq_data_decompose (pf_concl gls) in let sym_equal = lbeq.sym in - refine (applist(sym_equal,[t;e2;e1;mkMeta (Clenv.new_meta())])) gls + refine (applist(sym_equal,[t;e2;e1;Evarutil.mk_new_meta()])) gls let swapEquandsInHyp id gls = - ((tclTHENS (cut_replacing id (swap_equands gls (pf_get_hyp_typ gls id))) - ([tclIDTAC; - (tclTHEN (swapEquandsInConcl) (exact_no_check (mkVar id)))]))) gls + cut_replacing id (swap_equands gls (pf_get_hyp_typ gls id)) + (tclTHEN swapEquandsInConcl) gls (* find_elim determines which elimination principle is necessary to - eliminate lbeq on sort_of_gl. It yields the boolean true wether - it is a dependent elimination principle (as idT.rect) and false - otherwise *) + eliminate lbeq on sort_of_gl. + This is somehow an artificial choice as we could take eq_rect in + all cases (eq_ind - and eq_rec - are instances of eq_rect) [HH 2/4/06]. +*) -let find_elim sort_of_gl lbeq = +let find_elim sort_of_gl lbeq = match kind_of_term sort_of_gl with - | Sort(Prop Null) (* Prop *) -> (lbeq.ind, false) - | Sort(Prop Pos) (* Set *) -> - (match lbeq.rrec with - | Some eq_rec -> (eq_rec, false) - | None -> errorlabstrm "find_elim" - (str "this type of elimination is not allowed")) - | _ (* Type *) -> + | Sort(Prop Null) (* Prop *) -> lbeq.ind + | _ (* Set/Type *) -> (match lbeq.rect with - | Some eq_rect -> (eq_rect, true) + | Some eq_rect -> eq_rect | None -> errorlabstrm "find_elim" - (str "this type of elimination is not allowed")) - -(* builds a predicate [e:t][H:(lbeq t e t1)](body e) - to be used as an argument for equality dependent elimination principle: - Preconditon: dependent body (mkRel 1) *) - -let build_dependent_rewrite_predicate (t,t1,t2) body lbeq gls = - let e = pf_get_new_id (id_of_string "e") gls in - let h = pf_get_new_id (id_of_string "HH") gls in - let eq_term = lbeq.eq in - (mkNamedLambda e t - (mkNamedLambda h (applist (eq_term, [t;t1;(mkRel 1)])) - (lift 1 body))) - -(* builds a predicate [e:t](body e) ??? - to be used as an argument for equality non-dependent elimination principle: - Preconditon: dependent body (mkRel 1) *) + (str "this type of substitution is not allowed")) -let build_non_dependent_rewrite_predicate (t,t1,t2) body gls = - lambda_create (pf_env gls) (t,body) +(* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *) let bareRevSubstInConcl lbeq body (t,e1,e2) gls = - let (eq_elim,dep) = - try - find_elim (pf_type_of gls (pf_concl gls)) lbeq - with e when catchable_exception e -> - errorlabstrm "RevSubstIncConcl" - (str "this type of substitution is not allowed") - in - let p = - if dep then - (build_dependent_rewrite_predicate (t,e1,e2) body lbeq gls) - else - (build_non_dependent_rewrite_predicate (t,e1,e2) body gls) - in - refine (applist(eq_elim,[t;e1;p;mkMeta(Clenv.new_meta()); - e2;mkMeta(Clenv.new_meta())])) gls + (* find substitution scheme *) + let eq_elim = find_elim (pf_type_of gls (pf_concl gls)) lbeq in + (* build substitution predicate *) + let p = lambda_create (pf_env gls) (t,body) in + (* apply substitution scheme *) + refine (applist(eq_elim,[t;e1;p;Evarutil.mk_new_meta(); + e2;Evarutil.mk_new_meta()])) gls (* [subst_tuple_term dep_pair B] @@ -925,8 +892,7 @@ let bareRevSubstInConcl lbeq body (t,e1,e2) gls = let decomp_tuple_term env c t = let rec decomprec inner_code ex exty = try - let {proj1 = p1; proj2 = p2 },(a,p,car,cdr) = - find_sigma_data_decompose ex in + let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in let car_code = applist (p1,[a;p;inner_code]) and cdr_code = applist (p2,[a;p;inner_code]) in let cdrtyp = beta_applist (p,[car]) in @@ -942,48 +908,41 @@ let subst_tuple_term env sigma dep_pair b = let abst_B = List.fold_right (fun (e,t) body -> lambda_create env (t,subst_term e body)) e_list b in - let app_B = applist(abst_B,proj_list) in app_B + applist(abst_B,proj_list) -(* |- (P e2) - BY RevSubstInConcl (eq T e1 e2) - |- (P e1) - |- (eq T e1 e2) - *) -(* Redondant avec Replace ! *) +(* Comme "replace" mais decompose les egalites dependantes *) -let substInConcl_RL eqn gls = - let (lbeq,(t,e1,e2)) = find_eq_data_decompose eqn in - let body = subst_tuple_term (pf_env gls) (project gls) e2 (pf_concl gls) in +let cutSubstInConcl_RL eqn gls = + let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose eqn in + let body = pf_apply subst_tuple_term gls e2 (pf_concl gls) in assert (dependent (mkRel 1) body); - bareRevSubstInConcl lbeq body (t,e1,e2) gls + bareRevSubstInConcl lbeq body eq gls (* |- (P e1) - BY SubstInConcl (eq T e1 e2) + BY CutSubstInConcl_LR (eq T e1 e2) |- (P e2) |- (eq T e1 e2) *) -let substInConcl_LR eqn gls = - (tclTHENS (substInConcl_RL (swap_equands gls eqn)) +let cutSubstInConcl_LR eqn gls = + (tclTHENS (cutSubstInConcl_RL (swap_equands gls eqn)) ([tclIDTAC; swapEquandsInConcl])) gls -let substInConcl l2r = if l2r then substInConcl_LR else substInConcl_RL +let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL -let substInHyp_LR eqn id gls = - let (lbeq,(t,e1,e2)) = find_eq_data_decompose eqn in - let body = subst_term e1 (pf_get_hyp_typ gls id) in - if not (dependent (mkRel 1) body) then errorlabstrm "SubstInHyp" (mt ()); - (tclTHENS (cut_replacing id (subst1 e2 body)) - ([tclIDTAC; - (tclTHENS (bareRevSubstInConcl lbeq body (t,e1,e2)) - ([exact_no_check (mkVar id);tclIDTAC]))])) gls +let cutSubstInHyp_LR eqn id gls = + let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose eqn in + let body = pf_apply subst_tuple_term gls e1 (pf_get_hyp_typ gls id) in + assert (dependent (mkRel 1) body); + cut_replacing id (subst1 e2 body) + (tclTHENFIRST (bareRevSubstInConcl lbeq body eq)) gls -let substInHyp_RL eqn id gls = - (tclTHENS (substInHyp_LR (swap_equands gls eqn) id) +let cutSubstInHyp_RL eqn id gls = + (tclTHENS (cutSubstInHyp_LR (swap_equands gls eqn) id) ([tclIDTAC; swapEquandsInConcl])) gls -let substInHyp l2r = if l2r then substInHyp_LR else substInHyp_RL +let cutSubstInHyp l2r = if l2r then cutSubstInHyp_LR else cutSubstInHyp_RL let try_rewrite tac gls = try @@ -996,77 +955,51 @@ let try_rewrite tac gls = (str "Cannot find a well-typed generalization of the goal that" ++ str " makes the proof progress") -let subst l2r eqn cls gls = +let cutSubstClause l2r eqn cls gls = match cls with - | None -> substInConcl l2r eqn gls - | Some id -> substInHyp l2r eqn id gls + | None -> cutSubstInConcl l2r eqn gls + | Some id -> cutSubstInHyp l2r eqn id gls -(* |- (P a) - * SubstConcl_LR a=b - * |- (P b) - * |- a=b - *) +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 substConcl l2r eqn gls = try_rewrite (subst l2r eqn None) gls -let substConcl_LR = substConcl true +let substClause l2r c cls gls = + let eq = pf_type_of gls c in + tclTHENS (cutSubstClause l2r eq cls) [tclIDTAC; exact_no_check c] gls -(* id:(P a) |- G - * SubstHyp a=b id - * id:(P b) |- G - * id:(P a) |-a=b -*) +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 -let hypSubst l2r id cls gls = - onClauses (function - | None -> - (tclTHENS (substInConcl l2r (pf_get_hyp_typ gls id)) - ([tclIDTAC; exact_no_check (mkVar id)])) - | Some (hypid,_,_) -> - (tclTHENS (substInHyp l2r (pf_get_hyp_typ gls id) hypid) - ([tclIDTAC;exact_no_check (mkVar id)]))) - cls gls +(* Renaming scheme correspondence new name (old name) -let hypSubst_LR = hypSubst true + give equality give proof of equality -(* id:a=b |- (P a) - * HypSubst id. - * id:a=b |- (P b) - *) -let substHypInConcl l2r id gls = try_rewrite (hypSubst l2r id onConcl) gls -let substHypInConcl_LR = substHypInConcl true + / cutSubstClause (subst) substClause (HypSubst on hyp) +raw | cutSubstInHyp (substInHyp) substInHyp (none) + \ cutSubstInConcl (substInConcl) substInConcl (none) -(* id:a=b H:(P a) |- G - SubstHypInHyp id H. - id:a=b H:(P b) |- G -*) -(* |- (P b) - SubstConcl_RL a=b - |- (P a) - |- a=b -*) -let substConcl_RL = substConcl false + / cutRewriteClause (none) rewriteClause (none) +user| cutRewriteInHyp (substHyp) rewriteInHyp (none) + \ cutRewriteInConcl (substConcl) rewriteInConcl (substHypInConcl on hyp) -(* id:(P b) |-G - SubstHyp_RL a=b id - id:(P a) |- G - |- a=b +raw = raise typing error or PatternMatchingFailure +user = raise user error specific to rewrite *) -let substHyp l2r eqn id gls = try_rewrite (subst l2r eqn (Some id)) gls -let substHyp_RL = substHyp false +(* Summary of obsolete forms +let substInConcl = cutSubstInConcl +let substInHyp = cutSubstInHyp +let hypSubst l2r id = substClause l2r (mkVar id) +let hypSubst_LR = hypSubst true let hypSubst_RL = hypSubst false - -(* id:a=b |- (P b) - * HypSubst id. - * id:a=b |- (P a) - *) -let substHypInConcl_RL = substHypInConcl false - -(* id:a=b H:(P b) |- G - SubstHypInHyp id H. - id:a=b H:(P a) |- G +let substHypInConcl l2r id = rewriteInConcl l2r (mkVar id) +let substConcl = cutRewriteInConcl +let substHyp = cutRewriteInHyp *) +(**********************************************************************) (* Substitutions tactics (JCF) *) let unfold_body x gl = @@ -1077,13 +1010,12 @@ let unfold_body x gl = | _ -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis") in let aft = afterHyp x gl in - let hl = List.fold_right - (fun (y,yval,_) cl -> (y,[],(InHyp,ref None)) :: cl) aft [] in + let hl = List.fold_right (fun (y,yval,_) cl -> (y,[],InHyp) :: cl) aft [] in let xvar = mkVar x in let rfun _ _ c = replace_term xvar xval c in tclTHENLIST [tclMAP (fun h -> reduct_in_hyp rfun h) hl; - reduct_in_concl rfun] gl + reduct_in_concl (rfun,DEFAULTcast)] gl @@ -1135,8 +1067,10 @@ let subst_one x gl = let introtac = function (id,None,_) -> intro_using id | (id,Some hval,htyp) -> - forward true (Name id) (mkCast(replace_term varx rhs hval, - replace_term varx rhs htyp)) in + letin_tac true (Name id) + (mkCast(replace_term varx rhs hval,DEFAULTcast, + replace_term varx rhs htyp)) nowhere + in let need_rewrite = dephyps <> [] || depconcl in tclTHENLIST ((if need_rewrite then @@ -1181,7 +1115,7 @@ let rewrite_assumption_cond_in faildir hyp gl = | [] -> error "No such assumption" | (id,_,t)::rest -> (try let dir = faildir t gl in - general_rewrite_in dir hyp ((mkVar id),NoBindings) gl + general_rewrite_in dir hyp (mkVar id) gl with Failure _ | UserError _ -> arec rest) in arec (pf_hyps gl) @@ -1216,3 +1150,6 @@ let replace_term_in_left t = rewrite_assumption_cond_in (cond_eq_term_left t) let replace_term_in_right t = rewrite_assumption_cond_in (cond_eq_term_right t) let replace_term_in t = rewrite_assumption_cond_in (cond_eq_term t) + +let _ = Setoid_replace.register_replace replace +let _ = Setoid_replace.register_general_rewrite general_rewrite diff --git a/tactics/equality.mli b/tactics/equality.mli index ab439c39..3e4bfed7 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: equality.mli,v 1.26.2.1 2004/07/16 19:30:53 herbelin Exp $ i*) +(*i $Id: equality.mli 8651 2006-03-21 21:54:43Z jforest $ i*) (*i*) open Names @@ -24,24 +24,34 @@ open Tacexpr open Rawterm (*i*) -val find_eq_pattern : sorts -> sorts -> constr - val general_rewrite_bindings : bool -> constr with_bindings -> tactic val general_rewrite : bool -> constr -> tactic -val rewriteLR_bindings : constr with_bindings -> tactic -val rewriteRL_bindings : constr with_bindings -> tactic +(* Obsolete, use [general_rewrite_bindings l2r] +[val rewriteLR_bindings : constr with_bindings -> tactic] +[val rewriteRL_bindings : constr with_bindings -> tactic] +*) + +(* Equivalent to [general_rewrite l2r] *) val rewriteLR : constr -> tactic val rewriteRL : constr -> tactic +(* Warning: old [general_rewrite_in] is now [general_rewrite_bindings_in] *) + +val general_rewrite_bindings_in : + bool -> identifier -> constr with_bindings -> tactic +val general_rewrite_in : + bool -> identifier -> constr -> tactic + val conditional_rewrite : bool -> tactic -> constr with_bindings -> tactic -val general_rewrite_in : bool -> identifier -> constr with_bindings -> tactic val conditional_rewrite_in : bool -> identifier -> tactic -> constr with_bindings -> tactic val replace : constr -> constr -> tactic val replace_in : identifier -> constr -> constr -> tactic - +val replace_by : constr -> constr -> tactic -> tactic +val replace_in_by : identifier -> constr -> constr -> tactic -> tactic +val new_replace : constr -> constr -> identifier option -> tactic option -> tactic val discr : identifier -> tactic val discrConcl : tactic val discrClause : clause -> tactic @@ -55,15 +65,38 @@ val dEq : quantified_hypothesis option -> tactic val dEqThen : (int -> tactic) -> quantified_hypothesis option -> tactic val make_iterated_tuple : - env -> evar_map -> (constr * constr) -> (constr * constr) - -> constr * constr * constr + env -> evar_map -> constr -> (constr * types) -> constr * constr * constr +(* The family cutRewriteIn expect an equality statement *) +val cutRewriteInHyp : bool -> types -> identifier -> tactic +val cutRewriteInConcl : bool -> constr -> tactic + +(* The family rewriteIn expect the proof of an equality *) +val rewriteInHyp : bool -> constr -> identifier -> tactic +val rewriteInConcl : bool -> constr -> tactic + +(* Expect the proof of an equality; fails with raw internal errors *) +val substClause : bool -> constr -> identifier option -> tactic + +(* +(* [substHypInConcl l2r id] is obsolete: use [rewriteInConcl l2r (mkVar id)] *) val substHypInConcl : bool -> identifier -> tactic + +(* [substConcl] is an obsolete synonym for [cutRewriteInConcl] *) val substConcl : bool -> constr -> tactic -val substHyp : bool -> constr -> identifier -> tactic -val hypSubst_LR : identifier -> clause -> tactic -val hypSubst_RL : identifier -> clause -> tactic +(* [substHyp] is an obsolete synonym of [cutRewriteInHyp] *) +val substHyp : bool -> types -> identifier -> tactic +*) + +(* Obsolete, use [rewriteInConcl lr (mkVar id)] in concl + or [rewriteInHyp lr (mkVar id) (Some hyp)] in hyp + (which, if they fail, raise only UserError, not PatternMatchingFailure) + or [substClause lr (mkVar id) None] + or [substClause lr (mkVar id) (Some hyp)] +[val hypSubst_LR : identifier -> clause -> tactic] +[val hypSubst_RL : identifier -> clause -> tactic] +*) val discriminable : env -> evar_map -> constr -> constr -> bool diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml new file mode 100644 index 00000000..73f88206 --- /dev/null +++ b/tactics/evar_tactics.ml @@ -0,0 +1,75 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* c :: acc + | _ -> fold_constr evrec acc c + in + evrec [] c + +let instantiate n rawc ido gl = + let sigma = gl.sigma in + let evl = + match ido with + ConclLocation () -> evar_list sigma gl.it.evar_concl + | HypLocation (id,hloc) -> + let decl = Environ.lookup_named_val id gl.it.evar_hyps in + match hloc with + InHyp -> + (match decl with + (_,None,typ) -> evar_list sigma typ + | _ -> error + "please be more specific : in type or value ?") + | InHypTypeOnly -> + let (_, _, typ) = decl in evar_list sigma typ + | InHypValueOnly -> + (match decl with + (_,Some body,_) -> evar_list sigma body + | _ -> error "not a let .. in hypothesis") in + if List.length evl < n then + error "not enough uninstantiated existential variables"; + if n <= 0 then error "incorrect existential variable index"; + let ev,_ = destEvar (List.nth evl (n-1)) in + let evd' = w_refine (pf_env gl) ev rawc (create_evar_defs sigma) in + Refiner.tclEVARS (evars_of evd') gl + +(* +let pfic gls c = + let evc = gls.sigma in + Constrintern.interp_constr evc (Global.env_of_context gls.it.evar_hyps) c + +let instantiate_tac = function + | [Integer n; Command com] -> + (fun gl -> instantiate n (pfic gl com) gl) + | [Integer n; Constr c] -> + (fun gl -> instantiate n c gl) + | _ -> invalid_arg "Instantiate called with bad arguments" +*) + +let let_evar name typ gls = + let evd = Evd.create_evar_defs gls.sigma in + let evd',evar = Evarutil.new_evar evd (pf_env gls) typ in + Refiner.tclTHEN (Refiner.tclEVARS (evars_of evd')) + (Tactics.letin_tac true name evar nowhere) gls + diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli new file mode 100644 index 00000000..dbf7db31 --- /dev/null +++ b/tactics/evar_tactics.mli @@ -0,0 +1,22 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Rawterm.rawconstr -> + (identifier * hyp_location_flag, unit) location -> tactic + +(*i +val instantiate_tac : tactic_arg list -> tactic +i*) + +val let_evar : name -> Term.types -> tactic diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index 34348834..ca1e43cb 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -8,24 +8,118 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: extraargs.ml4,v 1.5.2.1 2004/07/16 19:30:53 herbelin Exp $ *) +(* $Id: extraargs.ml4 7841 2006-01-11 11:24:54Z herbelin $ *) open Pp open Pcoq open Genarg +open Names +open Tacexpr +open Tacinterp (* Rewriting orientation *) let _ = Metasyntax.add_token_obj "<-" let _ = Metasyntax.add_token_obj "->" -let pr_orient _prc _prt = function +let pr_orient _prc _prlc _prt = function | true -> Pp.mt () | false -> Pp.str " <-" + ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient | [ "->" ] -> [ true ] | [ "<-" ] -> [ false ] | [ ] -> [ true ] END +(* For Setoid rewrite *) +let pr_morphism_signature _ _ _ = Setoid_replace.pr_morphism_signature + +ARGUMENT EXTEND morphism_signature + TYPED AS morphism_signature + PRINTED BY pr_morphism_signature + | [ constr(out) ] -> [ [],out ] + | [ constr(c) "++>" morphism_signature(s) ] -> + [ let l,out = s in (Some true,c)::l,out ] + | [ constr(c) "-->" morphism_signature(s) ] -> + [ let l,out = s in (Some false,c)::l,out ] + | [ constr(c) "==>" morphism_signature(s) ] -> + [ let l,out = s in (None,c)::l,out ] +END + +let pr_gen prc _prlc _prtac c = prc c + +let pr_rawc _prc _prlc _prtac raw = Printer.pr_rawconstr raw + +let interp_raw _ _ (t,_) = t + +let glob_raw = Tacinterp.intern_constr + +let subst_raw = Tacinterp.subst_rawconstr_and_expr + +ARGUMENT EXTEND raw + TYPED AS rawconstr + PRINTED BY pr_rawc + + INTERPRETED BY interp_raw + GLOBALIZED BY glob_raw + SUBSTITUTED BY subst_raw + + RAW_TYPED AS constr_expr + RAW_PRINTED BY pr_gen + + GLOB_TYPED AS rawconstr_and_expr + GLOB_PRINTED BY pr_gen + [ lconstr(c) ] -> [ c ] +END + +type 'id gen_place= ('id * hyp_location_flag,unit) location + +type loc_place = identifier Util.located gen_place +type place = identifier gen_place + +let pr_gen_place pr_id = function + ConclLocation () -> Pp.mt () + | HypLocation (id,InHyp) -> str "in " ++ pr_id id + | HypLocation (id,InHypTypeOnly) -> + str "in (Type of " ++ pr_id id ++ str ")" + | HypLocation (id,InHypValueOnly) -> + str "in (Value of " ++ pr_id id ++ str ")" + +let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id) +let pr_place _ _ _ = pr_gen_place Nameops.pr_id + +let intern_place ist = function + ConclLocation () -> ConclLocation () + | HypLocation (id,hl) -> HypLocation (intern_hyp ist id,hl) + +let interp_place ist gl = function + ConclLocation () -> ConclLocation () + | HypLocation (id,hl) -> HypLocation (interp_hyp ist gl id,hl) + +let subst_place subst pl = pl + +ARGUMENT EXTEND hloc + TYPED AS place + PRINTED BY pr_place + INTERPRETED BY interp_place + GLOBALIZED BY intern_place + SUBSTITUTED BY subst_place + RAW_TYPED AS loc_place + RAW_PRINTED BY pr_loc_place + GLOB_TYPED AS loc_place + GLOB_PRINTED BY pr_loc_place + [ ] -> + [ ConclLocation () ] + | [ "in" "|-" "*" ] -> + [ ConclLocation () ] +| [ "in" ident(id) ] -> + [ HypLocation ((Util.dummy_loc,id),InHyp) ] +| [ "in" "(" "Type" "of" ident(id) ")" ] -> + [ HypLocation ((Util.dummy_loc,id),InHypTypeOnly) ] +| [ "in" "(" "Value" "of" ident(id) ")" ] -> + [ HypLocation ((Util.dummy_loc,id),InHypValueOnly) ] + + END + diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index 2b4746ae..004fef02 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -6,13 +6,36 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraargs.mli,v 1.3.2.2 2005/01/21 17:14:10 herbelin Exp $ i*) +(*i $Id: extraargs.mli 6621 2005-01-21 17:24:37Z herbelin $ i*) open Tacexpr open Term +open Names open Proof_type open Topconstr +open Rawterm val rawwit_orient : bool raw_abstract_argument_type val wit_orient : bool closed_abstract_argument_type val orient : bool Pcoq.Gram.Entry.e + +val rawwit_morphism_signature : + Setoid_replace.morphism_signature raw_abstract_argument_type +val wit_morphism_signature : + Setoid_replace.morphism_signature closed_abstract_argument_type +val morphism_signature : + Setoid_replace.morphism_signature Pcoq.Gram.Entry.e + +val rawwit_raw : constr_expr raw_abstract_argument_type +val wit_raw : rawconstr closed_abstract_argument_type +val raw : constr_expr Pcoq.Gram.Entry.e + +type 'id gen_place= ('id * hyp_location_flag,unit) location + +type loc_place = identifier Util.located gen_place +type place = identifier gen_place + +val rawwit_hloc : loc_place raw_abstract_argument_type +val wit_hloc : place closed_abstract_argument_type +val hloc : loc_place Pcoq.Gram.Entry.e + diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 237f0a0d..a9ee65d7 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -8,122 +8,194 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: extratactics.ml4,v 1.21.2.2 2004/11/15 11:06:49 herbelin Exp $ *) +(* $Id: extratactics.ml4 8651 2006-03-21 21:54:43Z jforest $ *) open Pp open Pcoq open Genarg open Extraargs +open Mod_subst +open Names (* Equality *) open Equality -TACTIC EXTEND Rewrite - [ "Rewrite" orient(b) constr_with_bindings(c) ] -> [general_rewrite_bindings b c] +TACTIC EXTEND rewrite +| [ "rewrite" orient(b) constr_with_bindings(c) ] -> + [general_rewrite_bindings b c] END -TACTIC EXTEND RewriteIn - [ "Rewrite" orient(b) constr_with_bindings(c) "in" hyp(h) ] -> - [general_rewrite_in b h c] +TACTIC EXTEND rewrite_in +| [ "rewrite" orient(b) constr_with_bindings(c) "in" hyp(h) ] -> + [general_rewrite_bindings_in b h c] END let h_rewriteLR x = h_rewrite true (x,Rawterm.NoBindings) -TACTIC EXTEND Replace - [ "Replace" constr(c1) "with" constr(c2) ] -> [ replace c1 c2 ] +(* Julien: Mise en commun des differentes version de replace with in by + TODO: améliorer l'affichage et deplacer dans extraargs + +*) + + +let pr_by_arg_tac prc _ _ opt_c = + match opt_c with + | None -> mt () + | Some c -> spc () ++ hov 2 (str "by" ++ spc () ) + +(* Julien Forest: on voudrait pouvoir passer la loc mais je +n'ai pas reussi +*) + +let pr_in_arg_hyp = +fun prc _ _ opt_c-> + match opt_c with + | None -> mt () + | Some c -> + spc () ++ hov 2 (str "by" ++ spc () ++ + Pptactic.pr_or_var (fun _ -> mt ()) + (ArgVar(Util.dummy_loc,c)) + ) + + + + +ARGUMENT EXTEND by_arg_tac + TYPED AS tactic_opt + PRINTED BY pr_by_arg_tac +| [ "by" tactic(c) ] -> [ Some c ] +| [ ] -> [ None ] +END + +ARGUMENT EXTEND in_arg_hyp + TYPED AS ident_opt + PRINTED BY pr_in_arg_hyp +| [ "in" int_or_var(c) ] -> + [ match c with + | ArgVar(_,c) -> Some (c) + | _ -> Util.error "in must be used with an identifier" + ] +| [ ] -> [ None ] +END + +TACTIC EXTEND replace +| ["replace" constr(c1) "with" constr(c2) in_arg_hyp(in_hyp) by_arg_tac(tac) ] -> + [ new_replace c1 c2 in_hyp (Util.option_app Tacinterp.eval_tactic tac) ] END -TACTIC EXTEND ReplaceIn - [ "Replace" constr(c1) "with" constr(c2) "in" hyp(h) ] -> +(* Julien: + old version + +TACTIC EXTEND replace +| [ "replace" constr(c1) "with" constr(c2) ] -> + [ replace c1 c2 ] +END + +TACTIC EXTEND replace_by +| [ "replace" constr(c1) "with" constr(c2) "by" tactic(tac) ] -> + [ replace_by c1 c2 (snd tac) ] + +END + +TACTIC EXTEND replace_in +| [ "replace" constr(c1) "with" constr(c2) "in" hyp(h) ] -> [ replace_in h c1 c2 ] END -TACTIC EXTEND Replacetermleft - [ "Replace" "->" constr(c) ] -> [ replace_term_left c ] +TACTIC EXTEND replace_in_by +| [ "replace" constr(c1) "with" constr(c2) "in" hyp(h) "by" tactic(tac) ] -> + [ replace_in_by h c1 c2 (snd tac) ] +END + +*) + +TACTIC EXTEND replace_term_left + [ "replace" "->" constr(c) ] -> [ replace_term_left c ] END -TACTIC EXTEND Replacetermright - [ "Replace" "<-" constr(c) ] -> [ replace_term_right c ] +TACTIC EXTEND replace_term_right + [ "replace" "<-" constr(c) ] -> [ replace_term_right c ] END -TACTIC EXTEND Replaceterm - [ "Replace" constr(c) ] -> [ replace_term c ] +TACTIC EXTEND replace_term + [ "replace" constr(c) ] -> [ replace_term c ] END -TACTIC EXTEND ReplacetermInleft - [ "Replace" "->" constr(c) "in" hyp(h) ] +TACTIC EXTEND replace_term_in_left + [ "replace" "->" constr(c) "in" hyp(h) ] -> [ replace_term_in_left c h ] END -TACTIC EXTEND ReplacetermInright - [ "Replace" "<-" constr(c) "in" hyp(h) ] +TACTIC EXTEND replace_term_in_right + [ "replace" "<-" constr(c) "in" hyp(h) ] -> [ replace_term_in_right c h ] END -TACTIC EXTEND ReplacetermIn - [ "Replace" constr(c) "in" hyp(h) ] +TACTIC EXTEND replace_term_in + [ "replace" constr(c) "in" hyp(h) ] -> [ replace_term_in c h ] END -TACTIC EXTEND DEq - [ "Simplify_eq" quantified_hypothesis_opt(h) ] -> [ dEq h ] +TACTIC EXTEND simplify_eq + [ "simplify_eq" quantified_hypothesis_opt(h) ] -> [ dEq h ] END -TACTIC EXTEND Discriminate - [ "Discriminate" quantified_hypothesis_opt(h) ] -> [ discr_tac h ] +TACTIC EXTEND discriminate + [ "discriminate" quantified_hypothesis_opt(h) ] -> [ discr_tac h ] END let h_discrHyp id = h_discriminate (Some id) -TACTIC EXTEND Injection - [ "Injection" quantified_hypothesis_opt(h) ] -> [ injClause h ] +TACTIC EXTEND injection + [ "injection" quantified_hypothesis_opt(h) ] -> [ injClause h ] END let h_injHyp id = h_injection (Some id) -TACTIC EXTEND ConditionalRewrite - [ "Conditional" tactic(tac) "Rewrite" orient(b) constr_with_bindings(c) ] +TACTIC EXTEND conditional_rewrite +| [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c) ] -> [ conditional_rewrite b (snd tac) c ] -END - -TACTIC EXTEND ConditionalRewriteIn - [ "Conditional" tactic(tac) "Rewrite" orient(b) constr_with_bindings(c) +| [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c) "in" hyp(h) ] -> [ conditional_rewrite_in b h (snd tac) c ] END -TACTIC EXTEND DependentRewrite -| [ "Dependent" "Rewrite" orient(b) hyp(id) ] -> [ substHypInConcl b id ] -| [ "CutRewrite" orient(b) constr(eqn) ] -> [ substConcl b eqn ] -| [ "CutRewrite" orient(b) constr(eqn) "in" hyp(id) ] - -> [ substHyp b eqn id ] +TACTIC EXTEND dependent_rewrite +| [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] +| [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ] + -> [ rewriteInHyp b c id ] +END + +TACTIC EXTEND cut_rewrite +| [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] +| [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] + -> [ cutRewriteInHyp b eqn id ] END (* Contradiction *) open Contradiction -TACTIC EXTEND Absurd - [ "Absurd" constr(c) ] -> [ absurd c ] +TACTIC EXTEND absurd + [ "absurd" constr(c) ] -> [ absurd c ] END -TACTIC EXTEND Contradiction - [ "Contradiction" constr_with_bindings_opt(c) ] -> [ contradiction c ] +TACTIC EXTEND contradiction + [ "contradiction" constr_with_bindings_opt(c) ] -> [ contradiction c ] END (* AutoRewrite *) open Autorewrite -TACTIC EXTEND AutorewriteV7 - [ "AutoRewrite" "[" ne_preident_list(l) "]" ] -> - [ autorewrite Refiner.tclIDTAC l ] -| [ "AutoRewrite" "[" ne_preident_list(l) "]" "using" tactic(t) ] -> - [ autorewrite (snd t) l ] -END -TACTIC EXTEND AutorewriteV8 - [ "AutoRewrite" "with" ne_preident_list(l) ] -> + +TACTIC EXTEND autorewrite + [ "autorewrite" "with" ne_preident_list(l) ] -> [ autorewrite Refiner.tclIDTAC l ] -| [ "AutoRewrite" "with" ne_preident_list(l) "using" tactic(t) ] -> +| [ "autorewrite" "with" ne_preident_list(l) "using" tactic(t) ] -> [ autorewrite (snd t) l ] +| [ "autorewrite" "with" ne_preident_list(l) "in" ident(id) ] -> + [ autorewrite_in id Refiner.tclIDTAC l ] +| [ "autorewrite" "with" ne_preident_list(l) "in" ident(id) "using" tactic(t) ] -> + [ autorewrite_in id (snd t) l ] END let add_rewrite_hint name ort t lcsr = @@ -131,19 +203,9 @@ let add_rewrite_hint name ort t lcsr = let f c = Constrintern.interp_constr sigma env c, ort, t in add_rew_rules name (List.map f lcsr) -(* V7 *) -VERNAC COMMAND EXTEND HintRewriteV7 - [ "Hint" "Rewrite" orient(o) "[" ne_constr_list(l) "]" "in" preident(b) ] -> - [ add_rewrite_hint b o (Tacexpr.TacId "") l ] -| [ "Hint" "Rewrite" orient(o) "[" ne_constr_list(l) "]" "in" preident(b) - "using" tactic(t) ] -> - [ add_rewrite_hint b o t l ] -END - -(* V8 *) -VERNAC COMMAND EXTEND HintRewriteV8 +VERNAC COMMAND EXTEND HintRewrite [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident(b) ] -> - [ add_rewrite_hint b o (Tacexpr.TacId "") l ] + [ add_rewrite_hint b o (Tacexpr.TacId []) l ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ":" preident(b) ] -> [ add_rewrite_hint b o t l ] @@ -154,8 +216,8 @@ END open Refine -TACTIC EXTEND Refine - [ "Refine" castedopenconstr(c) ] -> [ refine c ] +TACTIC EXTEND refine + [ "refine" casted_open_constr(c) ] -> [ refine c ] END let refine_tac = h_refine @@ -164,18 +226,81 @@ let refine_tac = h_refine open Setoid_replace -TACTIC EXTEND SetoidReplace - [ "Setoid_replace" constr(c1) "with" constr(c2) ] - -> [ setoid_replace c1 c2 None] +TACTIC EXTEND setoid_replace + [ "setoid_replace" constr(c1) "with" constr(c2) ] -> + [ setoid_replace None c1 c2 ~new_goals:[] ] + | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel)] -> + [ setoid_replace (Some rel) c1 c2 ~new_goals:[] ] + | [ "setoid_replace" constr(c1) "with" constr(c2) "generate" "side" "conditions" constr_list(l) ] -> + [ setoid_replace None c1 c2 ~new_goals:l ] + | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) ] -> + [ setoid_replace (Some rel) c1 c2 ~new_goals:l ] + | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) ] -> + [ setoid_replace_in h None c1 c2 ~new_goals:[] ] + | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel)] -> + [ setoid_replace_in h (Some rel) c1 c2 ~new_goals:[] ] + | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "generate" "side" "conditions" constr_list(l) ] -> + [ setoid_replace_in h None c1 c2 ~new_goals:l ] + | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) ] -> + [ setoid_replace_in h (Some rel) c1 c2 ~new_goals:l ] +END + +TACTIC EXTEND setoid_rewrite + [ "setoid_rewrite" orient(b) constr(c) ] + -> [ general_s_rewrite b c ~new_goals:[] ] + | [ "setoid_rewrite" orient(b) constr(c) "generate" "side" "conditions" constr_list(l) ] + -> [ general_s_rewrite b c ~new_goals:l ] + | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) ] -> + [ general_s_rewrite_in h b c ~new_goals:[] ] + | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) "generate" "side" "conditions" constr_list(l) ] -> + [ general_s_rewrite_in h b c ~new_goals:l ] +END + +VERNAC COMMAND EXTEND AddSetoid1 + [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + [ add_setoid n a aeq t ] +| [ "Add" "Morphism" constr(m) ":" ident(n) ] -> + [ new_named_morphism n m None ] +| [ "Add" "Morphism" constr(m) "with" "signature" morphism_signature(s) "as" ident(n) ] -> + [ new_named_morphism n m (Some s)] +END + +VERNAC COMMAND EXTEND AddRelation1 + [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "symmetry" "proved" "by" constr(t') "as" ident(n) ] -> + [ add_relation n a aeq (Some t) (Some t') None ] +| [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "as" ident(n) ] -> + [ add_relation n a aeq (Some t) None None ] +| [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + [ add_relation n a aeq None None None ] +END + +VERNAC COMMAND EXTEND AddRelation2 + [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(t') "as" ident(n) ] -> + [ add_relation n a aeq None (Some t') None ] +| [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(t') "transitivity" "proved" "by" constr(t'') "as" ident(n) ] -> + [ add_relation n a aeq None (Some t') (Some t'') ] END -TACTIC EXTEND SetoidRewrite - [ "Setoid_rewrite" orient(b) constr(c) ] -> [ general_s_rewrite b c ] +VERNAC COMMAND EXTEND AddRelation3 + [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "transitivity" "proved" "by" constr(t') "as" ident(n) ] -> + [ add_relation n a aeq (Some t) None (Some t') ] +| [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "symmetry" "proved" "by" constr(t') "transitivity" "proved" "by" constr(t'') "as" ident(n) ] -> + [ add_relation n a aeq (Some t) (Some t') (Some t'') ] +| [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(t) "as" ident(n) ] -> + [ add_relation n a aeq None None (Some t) ] END -VERNAC COMMAND EXTEND AddSetoid -| [ "Add" "Setoid" constr(a) constr(aeq) constr(t) ] -> [ add_setoid a aeq t ] -| [ "Add" "Morphism" constr(m) ":" ident(s) ] -> [ new_named_morphism s m ] +TACTIC EXTEND setoid_symmetry + [ "setoid_symmetry" ] -> [ setoid_symmetry ] + | [ "setoid_symmetry" "in" ident(n) ] -> [ setoid_symmetry_in n ] +END + +TACTIC EXTEND setoid_reflexivity + [ "setoid_reflexivity" ] -> [ setoid_reflexivity ] +END + +TACTIC EXTEND setoid_transitivity + [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ] END (* Inversion lemmas (Leminv) *) @@ -226,11 +351,28 @@ END (* Subst *) -TACTIC EXTEND Subst -| [ "Subst" ne_var_list(l) ] -> [ subst l ] -| [ "Subst" ] -> [ subst_all ] +TACTIC EXTEND subst +| [ "subst" ne_var_list(l) ] -> [ subst l ] +| [ "subst" ] -> [ subst_all ] +END + +open Evar_tactics + +(* evar creation *) + +TACTIC EXTEND evar + [ "evar" "(" ident(id) ":" constr(typ) ")" ] -> [ let_evar (Name id) typ ] +| [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ] +END + +open Tacexpr + +TACTIC EXTEND instantiate + [ "instantiate" "(" integer(i) ":=" raw(c) ")" hloc(hl) ] -> + [instantiate i c hl ] END + (** Nijmegen "step" tactic for setoid rewriting *) open Tacticals @@ -257,7 +399,7 @@ let step left x tac = let l = List.map (fun lem -> tclTHENLAST - (apply_with_bindings (constr_of_reference lem, ImplicitBindings [x])) + (apply_with_bindings (lem, ImplicitBindings [x])) tac) !(if left then transitivity_left_table else transitivity_right_table) in @@ -271,7 +413,7 @@ let cache_transitivity_lemma (_,(left,lem)) = else transitivity_right_table := lem :: !transitivity_right_table -let subst_transitivity_lemma (_,subst,(b,ref)) = (b,subst_global subst ref) +let subst_transitivity_lemma (_,subst,(b,ref)) = (b,subst_mps subst ref) let (inTransitivity,_) = declare_object {(default_object "TRANSITIVITY-STEPS") with @@ -303,27 +445,33 @@ let _ = (* Main entry points *) -let add_transitivity_lemma left ref = - add_anonymous_leaf (inTransitivity (left,Nametab.global ref)) +let add_transitivity_lemma left lem = + let lem' = Constrintern.interp_constr Evd.empty (Global.env ()) lem in + add_anonymous_leaf (inTransitivity (left,lem')) (* Vernacular syntax *) -TACTIC EXTEND Stepl -| ["Stepl" constr(c) "by" tactic(tac) ] -> [ step true c (snd tac) ] -| ["Stepl" constr(c) ] -> [ step true c tclIDTAC ] +TACTIC EXTEND stepl +| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (snd tac) ] +| ["stepl" constr(c) ] -> [ step true c tclIDTAC ] END -TACTIC EXTEND Stepr -| ["Stepr" constr(c) "by" tactic(tac) ] -> [ step false c (snd tac) ] -| ["Stepr" constr(c) ] -> [ step false c tclIDTAC ] +TACTIC EXTEND stepr +| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (snd tac) ] +| ["stepr" constr(c) ] -> [ step false c tclIDTAC ] END VERNAC COMMAND EXTEND AddStepl -| [ "Declare" "Left" "Step" global(id) ] -> - [ add_transitivity_lemma true id ] +| [ "Declare" "Left" "Step" constr(t) ] -> + [ add_transitivity_lemma true t ] END VERNAC COMMAND EXTEND AddStepr -| [ "Declare" "Right" "Step" global(id) ] -> - [ add_transitivity_lemma false id ] +| [ "Declare" "Right" "Step" constr(t) ] -> + [ add_transitivity_lemma false t ] +END + +VERNAC COMMAND EXTEND ImplicitTactic +| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> + [ Tacinterp.declare_implicit_tactic (Tacinterp.interp tac) ] END diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli index 78a94190..d0034ca5 100644 --- a/tactics/extratactics.mli +++ b/tactics/extratactics.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extratactics.mli,v 1.3.10.2 2005/01/21 17:14:10 herbelin Exp $ i*) +(*i $Id: extratactics.mli 8651 2006-03-21 21:54:43Z jforest $ i*) open Names open Term @@ -18,3 +18,23 @@ val h_injHyp : quantified_hypothesis -> tactic val h_rewriteLR : constr -> tactic val refine_tac : Genarg.open_constr -> tactic + + + +(* Julien: Mise en commun des differentes version de replace with in by + TODO: deplacer dans extraargs + +*) + + +val rawwit_in_arg_hyp: identifier option Tacexpr.raw_abstract_argument_type +val in_arg_hyp: identifier option Pcoq.Gram.Entry.e + + + +val rawwit_by_arg_tac : + (Tacexpr.raw_tactic_expr option, Topconstr.constr_expr, + Tacexpr.raw_tactic_expr) + Genarg.abstract_argument_type + +val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.Entry.e diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml index f35c624b..1fe1c51e 100644 --- a/tactics/hiddentac.ml +++ b/tactics/hiddentac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: hiddentac.ml,v 1.21.2.1 2004/07/16 19:30:53 herbelin Exp $ *) +(* $Id: hiddentac.ml 7875 2006-01-16 09:55:24Z herbelin $ *) open Term open Proof_type @@ -28,6 +28,7 @@ let h_intro x = h_intro_move (Some x) None let h_intros_until x = abstract_tactic (TacIntrosUntil x) (intros_until x) let h_assumption = abstract_tactic TacAssumption assumption let h_exact c = abstract_tactic (TacExact c) (exact_check c) +let h_exact_no_check c = abstract_tactic (TacExactNoCheck c) (exact_no_check c) let h_apply cb = abstract_tactic (TacApply cb) (apply_with_bindings cb) let h_elim cb cbo = abstract_tactic (TacElim (cb,cbo)) (elim cb cbo) let h_elim_type c = abstract_tactic (TacElimType c) (elim_type c) @@ -41,15 +42,14 @@ let h_mutual_cofix id l = abstract_tactic (TacMutualCofix (id,l)) (mutual_cofix id l) let h_cut c = abstract_tactic (TacCut c) (cut c) -let h_true_cut na c = abstract_tactic (TacTrueCut (na,c)) (true_cut na c) -let h_forward b na c = abstract_tactic (TacForward (b,na,c)) (forward b na c) let h_generalize cl = abstract_tactic (TacGeneralize cl) (generalize cl) let h_generalize_dep c = abstract_tactic (TacGeneralizeDep c)(generalize_dep c) let h_let_tac na c cl = abstract_tactic (TacLetTac (na,c,cl)) (letin_tac true na c cl) -let h_instantiate n c cls = - abstract_tactic (TacInstantiate (n,c,cls)) - (Evar_refiner.instantiate n c (simple_clause_of cls)) +let h_instantiate n c ido = +(Evar_tactics.instantiate n c ido) + (* abstract_tactic (TacInstantiate (n,c,cls)) + (Evar_refiner.instantiate n c (simple_clause_of cls)) *) (* Derived basic tactics *) let h_simple_induction h = @@ -64,7 +64,8 @@ let h_specialize n d = abstract_tactic (TacSpecialize (n,d)) (new_hyp n d) let h_lapply c = abstract_tactic (TacLApply c) (cut_and_apply c) (* Context management *) -let h_clear l = abstract_tactic (TacClear l) (clear l) +let h_clear b l = abstract_tactic (TacClear (b,l)) + ((if b then keep else clear) l) let h_clear_body l = abstract_tactic (TacClearBody l) (clear_body l) let h_move dep id1 id2 = abstract_tactic (TacMove (dep,id1,id2)) (move_hyp dep id1 id2) diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli index 1b37291c..bfab1f45 100644 --- a/tactics/hiddentac.mli +++ b/tactics/hiddentac.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: hiddentac.mli,v 1.19.2.2 2005/01/21 16:41:52 herbelin Exp $ i*) +(*i $Id: hiddentac.mli 8651 2006-03-21 21:54:43Z jforest $ i*) (*i*) open Names @@ -29,6 +29,7 @@ val h_intros_until : quantified_hypothesis -> tactic val h_assumption : tactic val h_exact : constr -> tactic +val h_exact_no_check : constr -> tactic val h_apply : constr with_bindings -> tactic @@ -45,25 +46,22 @@ val h_mutual_cofix : identifier -> (identifier * constr) list -> tactic val h_cofix : identifier option -> tactic val h_cut : constr -> tactic -val h_true_cut : name -> constr -> tactic val h_generalize : constr list -> tactic val h_generalize_dep : constr -> tactic -val h_forward : bool -> name -> constr -> tactic val h_let_tac : name -> constr -> Tacticals.clause -> tactic -val h_instantiate : int -> constr -> Tacticals.clause -> tactic +val h_instantiate : int -> Rawterm.rawconstr -> + (identifier * hyp_location_flag, unit) location -> tactic (* Derived basic tactics *) -val h_simple_induction : quantified_hypothesis * (bool ref * intro_pattern_expr list ref list) list ref -> tactic +val h_simple_induction : quantified_hypothesis -> tactic val h_simple_destruct : quantified_hypothesis -> tactic val h_new_induction : - constr induction_arg -> constr with_bindings option -> - intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref - -> tactic + constr induction_arg list -> constr with_bindings option -> + intro_pattern_expr -> tactic val h_new_destruct : - constr induction_arg -> constr with_bindings option -> - intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref - -> tactic + constr induction_arg list -> constr with_bindings option -> + intro_pattern_expr -> tactic val h_specialize : int option -> constr with_bindings -> tactic val h_lapply : constr -> tactic @@ -71,16 +69,13 @@ val h_lapply : constr -> tactic (* Context management *) -val h_clear : identifier list -> tactic +val h_clear : bool -> identifier list -> tactic val h_clear_body : identifier list -> tactic val h_move : bool -> identifier -> identifier -> tactic val h_rename : identifier -> identifier -> tactic (* Constructors *) -(*i -val h_any_constructor : tactic -> tactic -i*) val h_constructor : int -> constr bindings -> tactic val h_left : constr bindings -> tactic val h_right : constr bindings -> tactic @@ -92,7 +87,7 @@ val h_simplest_right : tactic (* Conversion *) -val h_reduce : Tacred.red_expr -> Tacticals.clause -> tactic +val h_reduce : Redexpr.red_expr -> Tacticals.clause -> tactic val h_change : constr occurrences option -> constr -> Tacticals.clause -> tactic diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml deleted file mode 100644 index 0ada5a06..00000000 --- a/tactics/hipattern.ml +++ /dev/null @@ -1,366 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a option - -type testing_function = constr -> bool - -let mkmeta n = Nameops.make_ident "X" (Some n) -let mkPMeta n = PMeta (Some (mkmeta n)) -let meta1 = mkmeta 1 -let meta2 = mkmeta 2 -let meta3 = mkmeta 3 -let meta4 = mkmeta 4 - -let op2bool = function Some _ -> true | None -> false - -let match_with_non_recursive_type t = - match kind_of_term t with - | App _ -> - let (hdapp,args) = decompose_app t in - (match kind_of_term hdapp with - | Ind ind -> - if not (Global.lookup_mind (fst ind)).mind_finite then - Some (hdapp,args) - else - None - | _ -> None) - | _ -> None - -let is_non_recursive_type t = op2bool (match_with_non_recursive_type t) - -(* A general conjunction type is a non-recursive inductive type with - only one constructor. *) - -let match_with_conjunction t = - let (hdapp,args) = decompose_app t in - match kind_of_term hdapp with - | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in - if (Array.length mip.mind_consnames = 1) - && (not (mis_is_recursive (ind,mib,mip))) - && (mip.mind_nrealargs = 0) - then - Some (hdapp,args) - else - None - | _ -> None - -let is_conjunction t = op2bool (match_with_conjunction t) - -(* A general disjunction type is a non-recursive inductive type all - whose constructors have a single argument. *) - -let match_with_disjunction t = - let (hdapp,args) = decompose_app t in - match kind_of_term hdapp with - | Ind ind -> - let car = mis_constr_nargs ind in - if array_for_all (fun ar -> ar = 1) car && - (let (mib,mip) = Global.lookup_inductive ind in - not (mis_is_recursive (ind,mib,mip))) - then - Some (hdapp,args) - else - None - | _ -> None - -let is_disjunction t = op2bool (match_with_disjunction t) - -let match_with_empty_type t = - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with - | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in - let nconstr = Array.length mip.mind_consnames in - if nconstr = 0 then Some hdapp else None - | _ -> None - -let is_empty_type t = op2bool (match_with_empty_type t) - -let match_with_unit_type t = - let (hdapp,args) = decompose_app t in - match (kind_of_term 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 = - nb_prod c = mip.mind_nparams in - if nconstr = 1 && array_for_all zero_args constr_types then - Some hdapp - else - None - | _ -> None - -let is_unit_type t = op2bool (match_with_unit_type t) - -(* Checks if a given term is an application of an - inductive binary relation R, so that R has only one constructor - establishing its reflexivity. *) - -(* ["(A : ?)(x:A)(? A x x)"] and ["(x : ?)(? x x)"] *) -let x = Name (id_of_string "x") -let y = Name (id_of_string "y") -let name_A = Name (id_of_string "A") -let coq_refl_rel1_pattern = - PProd - (name_A, PMeta None, - PProd (x, PRel 1, PApp (PMeta None, [|PRel 2; PRel 1; PRel 1|]))) -let coq_refl_rel2_pattern = - PProd (x, PMeta None, PApp (PMeta None, [|PRel 1; PRel 1|])) - -let coq_refl_reljm_pattern = -PProd - (name_A, PMeta None, - PProd (x, PRel 1, PApp (PMeta None, [|PRel 2; PRel 1; PRel 2;PRel 1|]))) - -let match_with_equation t = - let (hdapp,args) = decompose_app t in - match (kind_of_term 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 - if nconstr = 1 && - (is_matching coq_refl_rel1_pattern constr_types.(0) || - is_matching coq_refl_rel2_pattern constr_types.(0) || - is_matching coq_refl_reljm_pattern constr_types.(0)) - then - Some (hdapp,args) - else - None - | _ -> None - -let is_equation t = op2bool (match_with_equation t) - -(* ["(?1 -> ?2)"] *) -let imp a b = PProd (Anonymous, a, b) -let coq_arrow_pattern = imp (mkPMeta 1) (mkPMeta 2) -let match_arrow_pattern t = - match matches coq_arrow_pattern t with - | [(m1,arg);(m2,mind)] -> assert (m1=meta1 & m2=meta2); (arg, mind) - | _ -> anomaly "Incorrect pattern matching" - -let match_with_nottype t = - try - let (arg,mind) = match_arrow_pattern t in - if is_empty_type mind then Some (mind,arg) else None - with PatternMatchingFailure -> None - -let is_nottype t = op2bool (match_with_nottype t) - -let match_with_forall_term c= - match kind_of_term c with - | Prod (nam,a,b) -> Some (nam,a,b) - | _ -> None - -let is_forall_term c = op2bool (match_with_forall_term c) - -let match_with_imp_term c= - match kind_of_term c with - | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b) - | _ -> None - -let is_imp_term c = op2bool (match_with_imp_term c) - -let rec has_nodep_prod_after n c = - match kind_of_term c with - | Prod (_,_,b) -> - ( n>0 || not (dependent (mkRel 1) b)) - && (has_nodep_prod_after (n-1) b) - | _ -> true - -let has_nodep_prod = has_nodep_prod_after 0 - -let match_with_nodep_ind t = - let (hdapp,args) = decompose_app t in - match (kind_of_term 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 = has_nodep_prod_after mip.mind_nparams in - if array_for_all nodep_constr mip.mind_nf_lc then - let params= - if mip.mind_nrealargs=0 then args else - fst (list_chop mip.mind_nparams args) in - Some (hdapp,params,mip.mind_nrealargs) - else - None - | _ -> None - -let is_nodep_ind t=op2bool (match_with_nodep_ind t) - -let match_with_sigma_type t= - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with - | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in - if (Array.length (mib.mind_packets)=1) && - (mip.mind_nrealargs=0) && - (Array.length mip.mind_consnames=1) && - has_nodep_prod_after (mip.mind_nparams+1) mip.mind_nf_lc.(0) then - (*allowing only 1 existential*) - Some (hdapp,args) - else - None - | _ -> None - -let is_sigma_type t=op2bool (match_with_sigma_type t) - -(***** Destructing patterns bound to some theory *) - -let rec first_match matcher = function - | [] -> raise PatternMatchingFailure - | (pat,build_set)::l -> - try (build_set (),matcher pat) - with PatternMatchingFailure -> first_match matcher l - -(*** Equality *) - -(* Patterns "(eq ?1 ?2 ?3)", "(eqT ?1 ?2 ?3)" and "(idT ?1 ?2 ?3)" *) -let coq_eq_pattern_gen eq = - lazy (PApp(PRef (Lazy.force eq), [|mkPMeta 1;mkPMeta 2;mkPMeta 3|])) -let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref -(*let coq_eqT_pattern = coq_eq_pattern_gen coq_eqT_ref*) -let coq_idT_pattern = coq_eq_pattern_gen coq_idT_ref - -let match_eq eqn eq_pat = - match matches (Lazy.force eq_pat) eqn with - | [(m1,t);(m2,x);(m3,y)] -> - assert (m1 = meta1 & m2 = meta2 & m3 = meta3); - (t,x,y) - | _ -> anomaly "match_eq: an eq pattern should match 3 terms" - -let equalities = - [coq_eq_pattern, build_coq_eq_data; -(* coq_eqT_pattern, build_coq_eqT_data;*) - coq_idT_pattern, build_coq_idT_data] - -let find_eq_data_decompose eqn = (* fails with PatternMatchingFailure *) - first_match (match_eq eqn) equalities - -open Tacmach -open Tacticals - -let match_eq_nf gls eqn eq_pat = - match pf_matches gls (Lazy.force eq_pat) eqn with - | [(m1,t);(m2,x);(m3,y)] -> - assert (m1 = meta1 & m2 = meta2 & m3 = meta3); - (t,pf_whd_betadeltaiota gls x,pf_whd_betadeltaiota gls y) - | _ -> anomaly "match_eq: an eq pattern should match 3 terms" - -let dest_nf_eq gls eqn = - try - snd (first_match (match_eq_nf gls eqn) equalities) - with PatternMatchingFailure -> - error "Not an equality" - -(*** Sigma-types *) - -(* Patterns "(existS ?1 ?2 ?3 ?4)" and "(existT ?1 ?2 ?3 ?4)" *) -let coq_ex_pattern_gen ex = - lazy(PApp(PRef (Lazy.force ex), [|mkPMeta 1;mkPMeta 2;mkPMeta 3;mkPMeta 4|])) -let coq_existS_pattern = coq_ex_pattern_gen coq_existS_ref -let coq_existT_pattern = coq_ex_pattern_gen coq_existT_ref - -let match_sigma ex ex_pat = - match matches (Lazy.force ex_pat) ex with - | [(m1,a);(m2,p);(m3,car);(m4,cdr)] as l -> - assert (m1=meta1 & m2=meta2 & m3=meta3 & m4=meta4); - (a,p,car,cdr) - | _ -> - anomaly "match_sigma: a successful sigma pattern should match 4 terms" - -let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) - first_match (match_sigma ex) - [coq_existS_pattern, build_sigma_set; - coq_existT_pattern, build_sigma_type] - -(* Pattern "(sig ?1 ?2)" *) -let coq_sig_pattern = - lazy (PApp (PRef (Lazy.force coq_sig_ref), [| (mkPMeta 1); (mkPMeta 2) |])) - -let match_sigma t = - match matches (Lazy.force coq_sig_pattern) t with - | [(_,a); (_,p)] -> (a,p) - | _ -> anomaly "Unexpected pattern" - -let is_matching_sigma t = is_matching (Lazy.force coq_sig_pattern) t - -(*** Decidable equalities *) - -(* Pattern "(sumbool (eq ?1 ?2 ?3) ?4)" *) -let coq_eqdec_partial_pattern = - lazy - (PApp - (PRef (Lazy.force coq_sumbool_ref), - [| Lazy.force coq_eq_pattern; (mkPMeta 4) |])) - -let match_eqdec_partial t = - match matches (Lazy.force coq_eqdec_partial_pattern) t with - | [_; (_,lhs); (_,rhs); _] -> (lhs,rhs) - | _ -> anomaly "Unexpected pattern" - -(* The expected form of the goal for the tactic Decide Equality *) - -(* Pattern "(x,y:?1){x=y}+{~(x=y)}" *) -(* i.e. "(x,y:?1)(sumbool (eq ?1 x y) ~(eq ?1 x y))" *) -let x = Name (id_of_string "x") -let y = Name (id_of_string "y") -let coq_eqdec_pattern = - lazy - (PProd (x, (mkPMeta 1), PProd (y, (mkPMeta 1), - PApp (PRef (Lazy.force coq_sumbool_ref), - [| PApp (PRef (Lazy.force coq_eq_ref), - [| (mkPMeta 1); PRel 2; PRel 1 |]); - PApp (PRef (Lazy.force coq_not_ref), - [|PApp (PRef (Lazy.force coq_eq_ref), - [| (mkPMeta 1); PRel 2; PRel 1 |])|]) |])))) - -let match_eqdec t = - match matches (Lazy.force coq_eqdec_pattern) t with - | [(_,typ)] -> typ - | _ -> anomaly "Unexpected pattern" - -(* Patterns "~ ?" and "? -> False" *) -let coq_not_pattern = lazy(PApp(PRef (Lazy.force coq_not_ref), [|PMeta None|])) -let coq_imp_False_pattern = - lazy (imp (PMeta None) (PRef (Lazy.force coq_False_ref))) - -let is_matching_not t = is_matching (Lazy.force coq_not_pattern) t -let is_matching_imp_False t = is_matching (Lazy.force coq_imp_False_pattern) t diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 new file mode 100644 index 00000000..64a0e0f1 --- /dev/null +++ b/tactics/hipattern.ml4 @@ -0,0 +1,353 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a option + +type testing_function = constr -> bool + +let mkmeta n = Nameops.make_ident "X" (Some n) +let meta1 = mkmeta 1 +let meta2 = mkmeta 2 +let meta3 = mkmeta 3 +let meta4 = mkmeta 4 + +let op2bool = function Some _ -> true | None -> false + +let match_with_non_recursive_type t = + match kind_of_term t with + | App _ -> + let (hdapp,args) = decompose_app t in + (match kind_of_term hdapp with + | Ind ind -> + if not (Global.lookup_mind (fst ind)).mind_finite then + Some (hdapp,args) + else + None + | _ -> None) + | _ -> None + +let is_non_recursive_type t = op2bool (match_with_non_recursive_type t) + +(* A general conjunction type is a non-recursive inductive type with + only one constructor. *) + +let match_with_conjunction t = + let (hdapp,args) = decompose_app t in + match kind_of_term hdapp with + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + if (Array.length mip.mind_consnames = 1) + && (not (mis_is_recursive (ind,mib,mip))) + && (mip.mind_nrealargs = 0) + then + Some (hdapp,args) + else + None + | _ -> None + +let is_conjunction t = op2bool (match_with_conjunction t) + +(* A general disjunction type is a non-recursive inductive type all + whose constructors have a single argument. *) + +let match_with_disjunction t = + let (hdapp,args) = decompose_app t in + match kind_of_term hdapp with + | Ind ind -> + let car = mis_constr_nargs ind in + if array_for_all (fun ar -> ar = 1) car && + (let (mib,mip) = Global.lookup_inductive ind in + not (mis_is_recursive (ind,mib,mip))) + then + Some (hdapp,args) + else + None + | _ -> None + +let is_disjunction t = op2bool (match_with_disjunction t) + +let match_with_empty_type t = + let (hdapp,args) = decompose_app t in + match (kind_of_term hdapp) with + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + let nconstr = Array.length mip.mind_consnames in + if nconstr = 0 then Some hdapp else None + | _ -> None + +let is_empty_type t = op2bool (match_with_empty_type t) + +let match_with_unit_type t = + let (hdapp,args) = decompose_app t in + match (kind_of_term 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 = + nb_prod c = mib.mind_nparams in + if nconstr = 1 && array_for_all zero_args constr_types then + Some hdapp + else + None + | _ -> None + +let is_unit_type t = op2bool (match_with_unit_type t) + +(* Checks if a given term is an application of an + inductive binary relation R, so that R has only one constructor + establishing its reflexivity. *) + +let coq_refl_rel1_pattern = PATTERN [ forall A:_, forall x:A, _ A x x ] +let coq_refl_rel2_pattern = PATTERN [ forall x:_, _ x x ] +let coq_refl_reljm_pattern = PATTERN [ forall A:_, forall x:A, _ A x A x ] + +let match_with_equation t = + let (hdapp,args) = decompose_app t in + match (kind_of_term 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 + if nconstr = 1 && + (is_matching coq_refl_rel1_pattern constr_types.(0) || + is_matching coq_refl_rel2_pattern constr_types.(0) || + is_matching coq_refl_reljm_pattern constr_types.(0)) + then + Some (hdapp,args) + else + None + | _ -> None + +let is_equation t = op2bool (match_with_equation t) + +let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ] + +let match_arrow_pattern t = + match matches coq_arrow_pattern t with + | [(m1,arg);(m2,mind)] -> assert (m1=meta1 & m2=meta2); (arg, mind) + | _ -> anomaly "Incorrect pattern matching" + +let match_with_nottype t = + try + let (arg,mind) = match_arrow_pattern t in + if is_empty_type mind then Some (mind,arg) else None + with PatternMatchingFailure -> None + +let is_nottype t = op2bool (match_with_nottype t) + +let match_with_forall_term c= + match kind_of_term c with + | Prod (nam,a,b) -> Some (nam,a,b) + | _ -> None + +let is_forall_term c = op2bool (match_with_forall_term c) + +let match_with_imp_term c= + match kind_of_term c with + | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b) + | _ -> None + +let is_imp_term c = op2bool (match_with_imp_term c) + +let rec has_nodep_prod_after n c = + match kind_of_term c with + | Prod (_,_,b) -> + ( n>0 || not (dependent (mkRel 1) b)) + && (has_nodep_prod_after (n-1) b) + | _ -> true + +let has_nodep_prod = has_nodep_prod_after 0 + +let match_with_nodep_ind t = + let (hdapp,args) = decompose_app t in + match (kind_of_term 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 = has_nodep_prod_after mib.mind_nparams in + if array_for_all nodep_constr mip.mind_nf_lc then + let params= + if 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 t=op2bool (match_with_nodep_ind t) + +let match_with_sigma_type t= + let (hdapp,args) = decompose_app t in + match (kind_of_term hdapp) with + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + if (Array.length (mib.mind_packets)=1) && + (mip.mind_nrealargs=0) && + (Array.length mip.mind_consnames=1) && + has_nodep_prod_after (mib.mind_nparams+1) mip.mind_nf_lc.(0) then + (*allowing only 1 existential*) + Some (hdapp,args) + else + None + | _ -> None + +let is_sigma_type t=op2bool (match_with_sigma_type t) + +(***** Destructing patterns bound to some theory *) + +let rec first_match matcher = function + | [] -> raise PatternMatchingFailure + | (pat,build_set)::l -> + try (build_set (),matcher pat) + with PatternMatchingFailure -> first_match matcher l + +(*** Equality *) + +(* Patterns "(eq ?1 ?2 ?3)" and "(identity ?1 ?2 ?3)" *) +let coq_eq_pattern_gen eq = lazy PATTERN [ %eq ?X1 ?X2 ?X3 ] +let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref +let coq_identity_pattern = coq_eq_pattern_gen coq_identity_ref + +let match_eq eqn eq_pat = + match matches (Lazy.force eq_pat) eqn with + | [(m1,t);(m2,x);(m3,y)] -> + assert (m1 = meta1 & m2 = meta2 & m3 = meta3); + (t,x,y) + | _ -> anomaly "match_eq: an eq pattern should match 3 terms" + +let equalities = + [coq_eq_pattern, build_coq_eq_data; + coq_identity_pattern, build_coq_identity_data] + +let find_eq_data_decompose eqn = (* fails with PatternMatchingFailure *) + first_match (match_eq eqn) equalities + +open Tacmach +open Tacticals + +let match_eq_nf gls eqn eq_pat = + match pf_matches gls (Lazy.force eq_pat) eqn with + | [(m1,t);(m2,x);(m3,y)] -> + assert (m1 = meta1 & m2 = meta2 & m3 = meta3); + (t,pf_whd_betadeltaiota gls x,pf_whd_betadeltaiota gls y) + | _ -> anomaly "match_eq: an eq pattern should match 3 terms" + +let dest_nf_eq gls eqn = + try + snd (first_match (match_eq_nf gls eqn) equalities) + with PatternMatchingFailure -> + error "Not an equality" + +(*** Sigma-types *) + +(* Patterns "(existS ?1 ?2 ?3 ?4)" and "(existT ?1 ?2 ?3 ?4)" *) +let coq_ex_pattern_gen ex = lazy PATTERN [ %ex ?X1 ?X2 ?X3 ?X4 ] +let coq_existS_pattern = coq_ex_pattern_gen coq_existS_ref +let coq_existT_pattern = coq_ex_pattern_gen coq_existT_ref + +let match_sigma ex ex_pat = + match matches (Lazy.force ex_pat) ex with + | [(m1,a);(m2,p);(m3,car);(m4,cdr)] -> + assert (m1=meta1 & m2=meta2 & m3=meta3 & m4=meta4); + (a,p,car,cdr) + | _ -> + anomaly "match_sigma: a successful sigma pattern should match 4 terms" + +let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) + first_match (match_sigma ex) + [coq_existS_pattern, build_sigma_set; + coq_existT_pattern, build_sigma_type] + +(* Pattern "(sig ?1 ?2)" *) +let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ] + +let match_sigma t = + match matches (Lazy.force coq_sig_pattern) t with + | [(_,a); (_,p)] -> (a,p) + | _ -> anomaly "Unexpected pattern" + +let is_matching_sigma t = is_matching (Lazy.force coq_sig_pattern) t + +(*** Decidable equalities *) + +(* The expected form of the goal for the tactic Decide Equality *) + +(* Pattern "{x=y}+{~(x=y)}" *) +(* i.e. "(sumbool (eq ?1 x y) ~(eq ?1 x y))" *) + +let coq_eqdec_inf_pattern = + lazy PATTERN [ { ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 } ] + +let coq_eqdec_inf_rev_pattern = + lazy PATTERN [ { ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 } ] + +let coq_eqdec_pattern = + lazy PATTERN [ %coq_or_ref (?X2 = ?X3 :> ?X1) (~ ?X2 = ?X3 :> ?X1) ] + +let coq_eqdec_rev_pattern = + lazy PATTERN [ %coq_or_ref (~ ?X2 = ?X3 :> ?X1) (?X2 = ?X3 :> ?X1) ] + +let op_or = coq_or_ref +let op_sum = coq_sumbool_ref + +let match_eqdec t = + let eqonleft,op,subst = + try true,op_sum,matches (Lazy.force coq_eqdec_inf_pattern) t + with PatternMatchingFailure -> + try false,op_sum,matches (Lazy.force coq_eqdec_inf_rev_pattern) t + with PatternMatchingFailure -> + try true,op_or,matches (Lazy.force coq_eqdec_pattern) t + with PatternMatchingFailure -> + false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in + match subst with + | [(_,typ);(_,c1);(_,c2)] -> + eqonleft, Libnames.constr_of_global (Lazy.force op), c1, c2, typ + | _ -> anomaly "Unexpected pattern" + +(* Patterns "~ ?" and "? -> False" *) +let coq_not_pattern = lazy PATTERN [ ~ _ ] +let coq_imp_False_pattern = lazy PATTERN [ _ -> %coq_False_ref ] + +let is_matching_not t = is_matching (Lazy.force coq_not_pattern) t +let is_matching_imp_False t = is_matching (Lazy.force coq_imp_False_pattern) t + +(* 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 index 7e2aa8f2..1627a8ca 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: hipattern.mli,v 1.13.2.1 2004/07/16 19:30:53 herbelin Exp $ i*) +(*i $Id: hipattern.mli 8652 2006-03-22 08:27:14Z herbelin $ i*) (*i*) open Util @@ -37,8 +37,6 @@ open Proof_trees intersection of the free-rels of the term and the current stack be contained in the arguments of the application *) -val is_imp_term : constr -> bool - (*s 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. @@ -98,7 +96,7 @@ val is_sigma_type : testing_function open Coqlib -(* Match terms [(eq A t u)], [(eqT A t u)] or [(identityT A t u)] *) +(* Match terms [(eq A t u)] or [(identity A t u)] *) (* Returns associated lemmas and [A,t,u] *) val find_eq_data_decompose : constr -> coq_leibniz_eq_data * (constr * constr * constr) @@ -113,11 +111,9 @@ val match_sigma : constr -> constr * constr val is_matching_sigma : constr -> bool -(* Match a term of the form [{x=y}+{_}], returns [x] and [y] *) -val match_eqdec_partial : constr -> constr * constr - -(* Match a term of the form [(x,y:t){x=y}+{~x=y}], returns [t] *) -val match_eqdec : constr -> constr +(* 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 : constr -> bool * constr * constr * constr * constr (* Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) open Proof_type diff --git a/tactics/inv.ml b/tactics/inv.ml index e4bab195..c48a90ac 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: inv.ml,v 1.53.2.3 2005/09/08 12:28:00 herbelin Exp $ *) +(* $Id: inv.ml 7880 2006-01-16 13:59:08Z herbelin $ *) open Pp open Util @@ -46,13 +46,13 @@ let collect_meta_variables c = let check_no_metas clenv ccl = if occur_meta ccl then - let metas = List.map (fun n -> Metamap.find n clenv.namenv) - (collect_meta_variables ccl) in + let metas = List.filter (fun na -> na<>Anonymous) + (List.map (Evd.meta_name clenv.env) (collect_meta_variables ccl)) in errorlabstrm "inversion" (str ("Cannot find an instantiation for variable"^ (if List.length metas = 1 then " " else "s ")) ++ - prlist_with_sep pr_coma pr_id metas - (* ajouter "in " ++ prterm ccl mais il faut le bon contexte *)) + prlist_with_sep pr_coma pr_name metas + (* ajouter "in " ++ pr_lconstr ccl mais il faut le bon contexte *)) let var_occurs_in_pf gl id = let env = pf_env gl in @@ -88,8 +88,7 @@ let var_occurs_in_pf gl id = type inversion_status = Dep of constr option | NoDep let compute_eqn env sigma n i ai = - (ai,get_type_of env sigma ai), - (mkRel (n-i),get_type_of env sigma (mkRel (n-i))) + (ai, (mkRel (n-i),get_type_of env sigma (mkRel (n-i)))) let make_inv_predicate env sigma indf realargs id status concl = let nrealargs = List.length realargs in @@ -112,7 +111,7 @@ let make_inv_predicate env sigma indf realargs id status concl = | None -> let sort = get_sort_of env sigma concl in let p = make_arity env true indf sort in - abstract_list_all env sigma p concl (realargs@[mkVar id]) in + Unification.abstract_list_all env sigma p concl (realargs@[mkVar id]) in let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in (* We lift to make room for the equations *) (hyps,lift nrealargs bodypred) @@ -128,14 +127,13 @@ let make_inv_predicate env sigma indf realargs id status concl = In any case, we carry along the rest of pairs *) let rec build_concl eqns n = function | [] -> (prod_it concl eqns,n) - | ((ai,ati),(xi,ti))::restlist -> + | (ai,(xi,ti))::restlist -> let (lhs,eqnty,rhs) = if closed0 ti then (xi,ti,ai) else - make_iterated_tuple env' sigma (ai,ati) (xi,ti) + make_iterated_tuple env' sigma ai (xi,ti) in - let sort = get_sort_of env sigma concl in let eq_term = Coqlib.build_coq_eq () in let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in build_concl ((Anonymous,lift n eqn)::eqns) (n+1) restlist @@ -306,17 +304,16 @@ let remember_first_eq id x = if !x = None then x := Some id a rewrite rule. It erases the clause which is given as input *) let projectAndApply thin id eqname names depids gls = - let env = pf_env gls in - let clearer id = - if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC) in - let subst_hyp_LR id = tclTHEN (tclTRY(hypSubst_LR id onConcl)) (clearer id) in - let subst_hyp_RL id = tclTHEN (tclTRY(hypSubst_RL id onConcl)) (clearer id) in + let subst_hyp l2r id = + tclTHEN (tclTRY(rewriteInConcl l2r (mkVar id))) + (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC)) + in let substHypIfVariable tac id gls = let (t,t1,t2) = Hipattern.dest_nf_eq gls (pf_get_hyp_typ gls id) in match (kind_of_term t1, kind_of_term t2) with - | Var id1, _ -> generalizeRewriteIntros (subst_hyp_LR id) depids id1 gls - | _, Var id2 -> generalizeRewriteIntros (subst_hyp_RL id) depids id2 gls - | _ -> tac id gls + | Var id1, _ -> generalizeRewriteIntros (subst_hyp true id) depids id1 gls + | _, Var id2 -> generalizeRewriteIntros (subst_hyp false id) depids id2 gls + | _ -> tac id gls in let deq_trailer id neqns = tclTHENSEQ @@ -326,7 +323,7 @@ let projectAndApply thin id eqname names depids gls = (intro_move idopt None) (* try again to substitute and if still not a variable after *) (* decomposition, arbitrarily try to rewrite RL !? *) - (tclTRY (onLastHyp (substHypIfVariable subst_hyp_RL)))) + (tclTRY (onLastHyp (substHypIfVariable (subst_hyp false))))) names); (if names = [] then clear [id] else tclIDTAC)] in @@ -380,6 +377,8 @@ let rewrite_equations_gene othin neqns ba gl = let rec get_names allow_conj = function | IntroWildcard -> error "Discarding pattern not allowed for inversion equations" + | IntroAnonymous -> + error "Anonymous pattern not allowed for inversion equations" | IntroOrAndPattern [l] -> if allow_conj then if l = [] then (None,[]) else @@ -401,7 +400,6 @@ let rewrite_equations othin neqns names ba gl = let (depids,nodepids) = split_dep_and_nodep ba.assums gl in let rewrite_eqns = let first_eq = ref None in - let update id = if !first_eq = None then first_eq := Some id in match othin with | Some thin -> tclTHENSEQ @@ -446,12 +444,11 @@ let rewrite_equations_tac (gene, othin) id neqns names ba = let raw_inversion inv_kind indbinding id status names gl = let env = pf_env gl and sigma = project gl in let c = mkVar id in - let (wc,kONT) = startWalk gl in let t = strong_prodspine (pf_whd_betadeltaiota gl) (pf_type_of gl c) in - let indclause = mk_clenv_from wc (c,t) in + let indclause = mk_clenv_from gl (c,t) in let indclause' = clenv_constrain_with_bindings indbinding indclause in - let newc = clenv_instance_template indclause' in - let ccl = clenv_instance_template_type indclause' in + let newc = clenv_value indclause' in + let ccl = clenv_type indclause' in check_no_metas indclause' ccl; let IndType (indf,realargs) = try find_rectype env sigma ccl @@ -477,7 +474,7 @@ let raw_inversion inv_kind indbinding id status names gl = (fun id -> (tclTHEN (apply_term (mkVar id) - (list_tabulate (fun _ -> mkMeta(Clenv.new_meta())) neqns)) + (list_tabulate (fun _ -> Evarutil.mk_new_meta()) neqns)) reflexivity))]) gl @@ -524,15 +521,15 @@ open Tacexpr let inv k = inv_gen false k NoDep -let half_inv_tac id = inv SimpleInversion None (NamedHyp id) -let inv_tac id = inv FullInversion None (NamedHyp id) -let inv_clear_tac id = inv FullInversionClear None (NamedHyp id) +let half_inv_tac id = inv SimpleInversion IntroAnonymous (NamedHyp id) +let inv_tac id = inv FullInversion IntroAnonymous (NamedHyp id) +let inv_clear_tac id = inv FullInversionClear IntroAnonymous (NamedHyp id) let dinv k c = inv_gen false k (Dep c) -let half_dinv_tac id = dinv SimpleInversion None None (NamedHyp id) -let dinv_tac id = dinv FullInversion None None (NamedHyp id) -let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) +let half_dinv_tac id = dinv SimpleInversion None IntroAnonymous (NamedHyp id) +let dinv_tac id = dinv FullInversion None IntroAnonymous (NamedHyp id) +let dinv_clear_tac id = dinv FullInversionClear None IntroAnonymous (NamedHyp id) (* InvIn will bring the specified clauses into the conclusion, and then * perform inversion on the named hypothesis. After, it will intro them diff --git a/tactics/inv.mli b/tactics/inv.mli index e19d8232..bd38d08f 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: inv.mli,v 1.10.2.1 2004/07/16 19:30:53 herbelin Exp $ i*) +(*i $Id: inv.mli 7880 2006-01-16 13:59:08Z herbelin $ i*) (*i*) open Names @@ -21,19 +21,19 @@ type inversion_status = Dep of constr option | NoDep val inv_gen : bool -> inversion_kind -> inversion_status -> - intro_pattern_expr option -> quantified_hypothesis -> tactic + intro_pattern_expr -> quantified_hypothesis -> tactic val invIn_gen : - inversion_kind -> intro_pattern_expr option -> identifier list -> + inversion_kind -> intro_pattern_expr -> identifier list -> quantified_hypothesis -> tactic val inv_clause : - inversion_kind -> intro_pattern_expr option -> identifier list -> + inversion_kind -> intro_pattern_expr -> identifier list -> quantified_hypothesis -> tactic -val inv : inversion_kind -> intro_pattern_expr option -> +val inv : inversion_kind -> intro_pattern_expr -> quantified_hypothesis -> tactic -val dinv : inversion_kind -> constr option -> intro_pattern_expr option -> +val dinv : inversion_kind -> constr option -> intro_pattern_expr -> quantified_hypothesis -> tactic val half_inv_tac : identifier -> tactic diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 1be465f5..7974ce56 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: leminv.ml,v 1.41.2.1 2004/07/16 19:30:54 herbelin Exp $ *) +(* $Id: leminv.ml 7837 2006-01-11 09:47:32Z herbelin $ *) open Pp open Util @@ -40,7 +40,7 @@ let not_work_message = "tactic fails to build the inversion lemma, may be becaus let no_inductive_inconstr env constr = (str "Cannot recognize an inductive predicate in " ++ - prterm_env env constr ++ + pr_lconstr_env env 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.") @@ -216,7 +216,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = errorlabstrm "lemma_inversion" (str"Computed inversion goal was not closed in initial signature"); *) - let invSign = named_context invEnv in + let invSign = named_context_val invEnv in let pfs = mk_pftreestate (mk_goal invSign invGoal) in let pfs = solve_pftreestate (tclTHEN intro (onLastHyp inv_op)) pfs in let (pfterm,meta_types) = extract_open_pftreestate pfs in @@ -245,9 +245,11 @@ let add_inversion_lemma name env sigma t sort dep inv_op = let invProof = inversion_scheme env sigma t sort dep inv_op in let _ = declare_constant name - (DefinitionEntry { const_entry_body = invProof; - const_entry_type = None; - const_entry_opaque = false }, + (DefinitionEntry + { const_entry_body = invProof; + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = true && (Options.boxed_definitions())}, IsProof Lemma) in () @@ -256,13 +258,15 @@ let add_inversion_lemma name env sigma t sort dep inv_op = (* inv_op = Inv (derives de complete inv. lemma) * inv_op = InvNoThining (derives de semi inversion lemma) *) -let inversion_lemma_from_goal n na id sort dep_option inv_op = +let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op = let pts = get_pftreestate() in let gl = nth_goal_of_pftreestate n pts in - let t = pf_get_hyp_typ gl id in + let t = + try pf_get_hyp_typ gl id + with Not_found -> Pretype_errors.error_var_not_found_loc loc id in let env = pf_env gl and sigma = project gl in - let fv = global_vars env t in (* Pourquoi ??? + let fv = global_vars env t in let thin_ids = thin_ids (hyps,fv) in if not(list_subset thin_ids fv) then errorlabstrm "lemma_inversion" @@ -287,15 +291,14 @@ let add_inversion_lemma_exn na com comsort bool tac = let lemInv id c gls = try - let (wc,kONT) = startWalk gls in - let clause = mk_clenv_type_of wc c in + let clause = mk_clenv_type_of gls c in let clause = clenv_constrain_with_bindings [(-1,mkVar id)] clause in - elim_res_pf kONT clause true gls + Clenvtac.res_pf clause ~allow_K:true gls with | UserError (a,b) -> errorlabstrm "LemInv" (str "Cannot refine current goal with the lemma " ++ - prterm_env (Global.env()) c) + pr_lconstr_env (Global.env()) c) let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id diff --git a/tactics/leminv.mli b/tactics/leminv.mli index 6617edf2..3e12f770 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -1,4 +1,4 @@ - +open Util open Names open Term open Rawterm @@ -12,7 +12,7 @@ val lemInv_clause : quantified_hypothesis -> constr -> identifier list -> tactic val inversion_lemma_from_goal : - int -> identifier -> identifier -> sorts -> bool -> + int -> identifier -> identifier located -> sorts -> bool -> (identifier -> tactic) -> unit val add_inversion_lemma_exn : identifier -> constr_expr -> rawsort -> bool -> (identifier -> tactic) -> diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml index bd4fb60e..0867d220 100644 --- a/tactics/nbtermdn.ml +++ b/tactics/nbtermdn.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: nbtermdn.ml,v 1.7.16.1 2004/07/16 19:30:54 herbelin Exp $ *) +(* $Id: nbtermdn.ml 6427 2004-12-07 17:41:10Z sacerdot $ *) open Util open Names @@ -14,6 +14,7 @@ open Term open Libobject open Library open Pattern +open Libnames (* Named, bounded-depth, term-discrimination nets. Implementation: @@ -28,11 +29,11 @@ open Pattern type ('na,'a) t = { mutable table : ('na,constr_pattern * 'a) Gmap.t; - mutable patterns : (constr_label option,'a Btermdn.t) Gmap.t } + mutable patterns : (global_reference option,'a Btermdn.t) Gmap.t } type ('na,'a) frozen_t = ('na,constr_pattern * 'a) Gmap.t - * (constr_label option,'a Btermdn.t) Gmap.t + * (global_reference option,'a Btermdn.t) Gmap.t let create () = { table = Gmap.empty; diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli index 90656619..579b24d4 100644 --- a/tactics/nbtermdn.mli +++ b/tactics/nbtermdn.mli @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: nbtermdn.mli,v 1.8.16.1 2004/07/16 19:30:54 herbelin Exp $ i*) +(*i $Id: nbtermdn.mli 6427 2004-12-07 17:41:10Z sacerdot $ i*) (*i*) open Term open Pattern +open Libnames (*i*) (* Named, bounded-depth, term-discrimination nets. *) @@ -34,4 +35,4 @@ val freeze : ('na,'a) t -> ('na,'a) frozen_t val unfreeze : ('na,'a) frozen_t -> ('na,'a) t -> unit val empty : ('na,'a) t -> unit val to2lists : ('na,'a) t -> ('na * (constr_pattern * 'a)) list * - (constr_label option * 'a Btermdn.t) list + (global_reference option * 'a Btermdn.t) list diff --git a/tactics/refine.ml b/tactics/refine.ml index 4a2fb01b..712e1f81 100644 --- a/tactics/refine.ml +++ b/tactics/refine.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: refine.ml,v 1.34.2.2 2004/07/16 19:30:54 herbelin Exp $ *) +(* $Id: refine.ml 7837 2006-01-11 09:47:32Z herbelin $ *) (* JCF -- 6 janvier 1998 EXPERIMENTAL *) @@ -66,12 +66,12 @@ and sg_proofs = (term_with_holes option) list (* pour debugger *) let rec pp_th (TH(c,mm,sg)) = - (str"TH=[ " ++ hov 0 (prterm c ++ fnl () ++ + (str"TH=[ " ++ hov 0 (pr_lconstr c ++ fnl () ++ (* pp_mm mm ++ fnl () ++ *) pp_sg sg) ++ str "]") and pp_mm l = hov 0 (prlist_with_sep (fun _ -> (fnl ())) - (fun (n,c) -> (int n ++ str" --> " ++ prterm c)) l) + (fun (n,c) -> (int n ++ str" --> " ++ pr_lconstr c)) l) and pp_sg sg = hov 0 (prlist_with_sep (fun _ -> (fnl ())) (function None -> (str"None") | Some th -> (pp_th th)) sg) @@ -89,72 +89,71 @@ and pp_sg sg = * meta_map correspond à celui des buts qui seront engendrés par le refine. *) -let replace_by_meta env gmm = function +let replace_by_meta env = function | TH (m, mm, sgp) when isMeta (strip_outer_cast m) -> m,mm,sgp | (TH (c,mm,_)) as th -> - let n = Clenv.new_meta() in + let n = Evarutil.new_meta() in let m = mkMeta n in (* quand on introduit une mv on calcule son type *) let ty = match kind_of_term c with | Lambda (Name id,c1,c2) when isCast c2 -> - mkNamedProd id c1 (snd (destCast c2)) + let _,_,t = destCast c2 in mkNamedProd id c1 t | Lambda (Anonymous,c1,c2) when isCast c2 -> - mkArrow c1 (snd (destCast c2)) + let _,_,t = destCast c2 in mkArrow c1 t | _ -> (* (App _ | Case _) -> *) - Retyping.get_type_of_with_meta env Evd.empty (gmm@mm) c + Retyping.get_type_of_with_meta env Evd.empty mm c (* | Fix ((_,j),(v,_,_)) -> v.(j) (* en pleine confiance ! *) | _ -> invalid_arg "Tcc.replace_by_meta (TO DO)" *) in - mkCast (m,ty),[n,ty],[Some th] + mkCast (m,DEFAULTcast, ty),[n,ty],[Some th] exception NoMeta -let replace_in_array env gmm a = +let replace_in_array keep_length env a = if array_for_all (function (TH (_,_,[])) -> true | _ -> false) a then raise NoMeta; let a' = Array.map (function - | (TH (c,mm,[])) -> c,mm,[] - | th -> replace_by_meta env gmm th) a + | (TH (c,mm,[])) when not keep_length -> c,mm,[] + | th -> replace_by_meta env th) a in - let v' = Array.map (fun (x,_,_) -> x) a' in - let mm = Array.fold_left (@) [] (Array.map (fun (_,x,_) -> x) a') in - let sgp = Array.fold_left (@) [] (Array.map (fun (_,_,x) -> x) a') in + let v' = Array.map pi1 a' in + let mm = Array.fold_left (@) [] (Array.map pi2 a') in + let sgp = Array.fold_left (@) [] (Array.map pi3 a') in v',mm,sgp let fresh env n = let id = match n with Name x -> x | _ -> id_of_string "_" in next_global_ident_away true id (ids_of_named_context (named_context env)) -let rec compute_metamap env gmm c = match kind_of_term c with +let rec compute_metamap env c = match kind_of_term c with (* le terme est directement une preuve *) | (Const _ | Evar _ | Ind _ | Construct _ | Sort _ | Var _ | Rel _) -> TH (c,[],[]) + (* le terme est une mv => un but *) | Meta n -> - (* - Pp.warning (Printf.sprintf ("compute_metamap: MV(%d) sans type !\n") n); - let ty = Retyping.get_type_of_with_meta env Evd.empty lmeta c in - *) TH (c,[],[None]) - | Cast (m,ty) when isMeta m -> + + | Cast (m,_, ty) when isMeta m -> TH (c,[destMeta m,ty],[None]) + (* abstraction => il faut décomposer si le terme dessous n'est pas pur * attention : dans ce cas il faut remplacer (Rel 1) par (Var x) * où x est une variable FRAICHE *) | Lambda (name,c1,c2) -> let v = fresh env name in let env' = push_named (v,None,c1) env in - begin match compute_metamap env' gmm (subst1 (mkVar v) c2) with + begin match compute_metamap env' (subst1 (mkVar v) c2) with (* terme de preuve complet *) | TH (_,_,[]) -> TH (c,[],[]) (* terme de preuve incomplet *) | th -> - let m,mm,sgp = replace_by_meta env' gmm th in + let m,mm,sgp = replace_by_meta env' th in TH (mkLambda (Name v,c1,m), mm, sgp) end @@ -163,21 +162,21 @@ let rec compute_metamap env gmm c = match kind_of_term c with error "Refine: body of let-in cannot contain existentials"; let v = fresh env name in let env' = push_named (v,Some c1,t1) env in - begin match compute_metamap env' gmm (subst1 (mkVar v) c2) with + begin match compute_metamap env' (subst1 (mkVar v) c2) with (* terme de preuve complet *) | TH (_,_,[]) -> TH (c,[],[]) (* terme de preuve incomplet *) | th -> - let m,mm,sgp = replace_by_meta env' gmm th in + let m,mm,sgp = replace_by_meta env' th in TH (mkLetIn (Name v,c1,t1,m), mm, sgp) end (* 4. Application *) | App (f,v) -> - let a = Array.map (compute_metamap env gmm) (Array.append [|f|] v) in + let a = Array.map (compute_metamap env) (Array.append [|f|] v) in begin try - let v',mm,sgp = replace_in_array env gmm a in + let v',mm,sgp = replace_in_array false env a in let v'' = Array.sub v' 1 (Array.length v) in TH (mkApp(v'.(0), v''),mm,sgp) with NoMeta -> @@ -188,10 +187,10 @@ let rec compute_metamap env gmm c = match kind_of_term c with (* bof... *) let nbr = Array.length v in let v = Array.append [|p;cc|] v in - let a = Array.map (compute_metamap env gmm) v in + let a = Array.map (compute_metamap env) v in begin try - let v',mm,sgp = replace_in_array env gmm a in + let v',mm,sgp = replace_in_array false env a in let v'' = Array.sub v' 2 nbr in TH (mkCase (ci,v'.(0),v'.(1),v''),mm,sgp) with NoMeta -> @@ -205,12 +204,12 @@ let rec compute_metamap env gmm c = match kind_of_term c with let fi' = Array.map (fun id -> Name id) vi in let env' = push_named_rec_types (fi',ai,v) env in let a = Array.map - (compute_metamap env' gmm) + (compute_metamap env') (Array.map (substl (List.map mkVar (Array.to_list vi))) v) in begin try - let v',mm,sgp = replace_in_array env' gmm a in + let v',mm,sgp = replace_in_array true env' a in let fix = mkFix ((ni,i),(fi',ai,v')) in TH (fix,mm,sgp) with NoMeta -> @@ -218,7 +217,7 @@ let rec compute_metamap env gmm c = match kind_of_term c with end (* Cast. Est-ce bien exact ? *) - | Cast (c,t) -> compute_metamap env gmm c + | Cast (c,_,t) -> compute_metamap env c (*let TH (c',mm,sgp) = compute_metamap sign c in TH (mkCast (c',t),mm,sgp) *) @@ -235,12 +234,12 @@ let rec compute_metamap env gmm c = match kind_of_term c with let fi' = Array.map (fun id -> Name id) vi in let env' = push_named_rec_types (fi',ai,v) env in let a = Array.map - (compute_metamap env' gmm) + (compute_metamap env') (Array.map (substl (List.map mkVar (Array.to_list vi))) v) in begin try - let v',mm,sgp = replace_in_array env' gmm a in + let v',mm,sgp = replace_in_array true env' a in let cofix = mkCoFix (i,(fi',ai,v')) in TH (cofix,mm,sgp) with NoMeta -> @@ -253,14 +252,14 @@ let rec compute_metamap env gmm c = match kind_of_term c with * Réalise le 3. ci-dessus *) -let rec tcc_aux subst (TH (c,mm,sgp) as th) gl = +let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = let c = substl subst c in match (kind_of_term c,sgp) with (* mv => sous-but : on ne fait rien *) | Meta _ , _ -> tclIDTAC gl - | Cast (c,_), _ when isMeta c -> + | Cast (c,_,_), _ when isMeta c -> tclIDTAC gl (* terme pur => refine *) @@ -339,8 +338,8 @@ let rec tcc_aux subst (TH (c,mm,sgp) as th) gl = let refine oc gl = let sigma = project gl in - let env = pf_env gl in - let (gmm,c) = Clenv.exist_to_meta sigma oc in - let th = compute_metamap env gmm c in - tcc_aux [] th gl - + let (sigma,c) = Evarutil.evars_to_metas sigma oc in + (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise + complicated to update meta types when passing through a binder *) + let th = compute_metamap (pf_env gl) c in + tclTHEN (Refiner.tclEVARS sigma) (tcc_aux [] th) gl diff --git a/tactics/refine.mli b/tactics/refine.mli index e053aea6..aae1f5e1 100644 --- a/tactics/refine.mli +++ b/tactics/refine.mli @@ -6,9 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: refine.mli,v 1.7.2.1 2004/07/16 19:30:55 herbelin Exp $ i*) +(*i $Id: refine.mli 6099 2004-09-12 11:38:09Z barras $ i*) -open Term open Tacmach -val refine : Pretyping.open_constr -> tactic +val refine : Evd.open_constr -> tactic diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml index 74b062e0..a6331927 100644 --- a/tactics/setoid_replace.ml +++ b/tactics/setoid_replace.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: setoid_replace.ml,v 1.31.2.1 2004/07/16 19:30:55 herbelin Exp $ *) +(* $Id: setoid_replace.ml 8683 2006-04-05 15:47:39Z letouzey $ *) open Tacmach open Proof_type @@ -22,6 +22,8 @@ open Util open Pp open Printer open Environ +open Clenv +open Unification open Tactics open Tacticals open Vernacexpr @@ -29,106 +31,365 @@ open Safe_typing open Nametab open Decl_kinds open Constrintern - -type setoid = - { set_a : constr; - set_aeq : constr; - set_th : constr +open Mod_subst + +let replace = ref (fun _ _ -> assert false) +let register_replace f = replace := f + +let general_rewrite = ref (fun _ _ -> assert false) +let register_general_rewrite f = general_rewrite := f + +(* util function; it should be in util.mli *) +let prlist_with_sepi sep elem = + let rec aux n = + function + | [] -> mt () + | [h] -> elem n h + | h::t -> + let e = elem n h and s = sep() and r = aux (n+1) t in + e ++ s ++ r + in + aux 1 + +type relation = + { rel_a: constr ; + rel_aeq: constr; + rel_refl: constr option; + rel_sym: constr option; + rel_trans : constr option; + rel_quantifiers_no: int (* it helps unification *); + rel_X_relation_class: constr; + rel_Xreflexive_relation_class: constr + } + +type 'a relation_class = + Relation of 'a (* the rel_aeq of the relation or the relation *) + | Leibniz of constr option (* the carrier (if eq is partially instantiated) *) + +type 'a morphism = + { args : (bool option * 'a relation_class) list; + output : 'a relation_class; + lem : constr; + morphism_theory : constr } -type morphism = - { lem : constr; - profil : bool list; - arg_types : constr list; - lem2 : constr option +type funct = + { f_args : constr list; + f_output : constr } +type morphism_class = + ACMorphism of relation morphism + | ACFunction of funct + +let subst_mps_in_relation_class subst = + function + Relation t -> Relation (subst_mps subst t) + | Leibniz t -> Leibniz (option_app (subst_mps subst) t) + +let subst_mps_in_argument_class subst (variance,rel) = + variance, subst_mps_in_relation_class subst rel + +let constr_relation_class_of_relation_relation_class = + function + Relation relation -> Relation relation.rel_aeq + | Leibniz t -> Leibniz t + + let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c let constant dir s = Coqlib.gen_constant "Setoid_replace" ("Setoids"::dir) s - -let global_constant dir s =Coqlib.gen_constant "Setoid_replace" ("Init"::dir) s +let gen_constant dir s = Coqlib.gen_constant "Setoid_replace" dir s +let reference dir s = Coqlib.gen_reference "Setoid_replace" ("Setoids"::dir) s +let eval_reference dir s = EvalConstRef (destConst (constant dir s)) +let eval_init_reference dir s = EvalConstRef (destConst (gen_constant ("Init"::dir) s)) let current_constant id = try global_reference id with Not_found -> - anomaly ("Setoid: cannot find "^(string_of_id id)) - -(* Setoid_theory *) - -let coq_Setoid_Theory = lazy(constant ["Setoid"] "Setoid_Theory") - -let coq_seq_refl = lazy(constant ["Setoid"] "Seq_refl") -let coq_seq_sym = lazy(constant ["Setoid"] "Seq_sym") -let coq_seq_trans = lazy(constant ["Setoid"] "Seq_trans") - -let coq_fleche = lazy(constant ["Setoid"] "fleche") - -(* Coq constants *) + anomaly ("Setoid: cannot find " ^ (string_of_id id)) -let coqeq = lazy(global_constant ["Logic"] "eq") +(* From Setoid.v *) -let coqconj = lazy(global_constant ["Logic"] "conj") -let coqand = lazy(global_constant ["Logic"] "and") -let coqproj1 = lazy(global_constant ["Logic"] "proj1") -let coqproj2 = lazy(global_constant ["Logic"] "proj2") - -(************************* Table of declared setoids **********************) +let coq_reflexive = + lazy(gen_constant ["Relations"; "Relation_Definitions"] "reflexive") +let coq_symmetric = + lazy(gen_constant ["Relations"; "Relation_Definitions"] "symmetric") +let coq_transitive = + lazy(gen_constant ["Relations"; "Relation_Definitions"] "transitive") +let coq_relation = + lazy(gen_constant ["Relations"; "Relation_Definitions"] "relation") +let coq_Relation_Class = lazy(constant ["Setoid"] "Relation_Class") +let coq_Argument_Class = lazy(constant ["Setoid"] "Argument_Class") +let coq_Setoid_Theory = lazy(constant ["Setoid"] "Setoid_Theory") +let coq_Morphism_Theory = lazy(constant ["Setoid"] "Morphism_Theory") +let coq_Build_Morphism_Theory= lazy(constant ["Setoid"] "Build_Morphism_Theory") +let coq_Compat = lazy(constant ["Setoid"] "Compat") -(* Setoids are stored in a table which is synchronised with the Reset mechanism. *) +let coq_AsymmetricReflexive = lazy(constant ["Setoid"] "AsymmetricReflexive") +let coq_SymmetricReflexive = lazy(constant ["Setoid"] "SymmetricReflexive") +let coq_SymmetricAreflexive = lazy(constant ["Setoid"] "SymmetricAreflexive") +let coq_AsymmetricAreflexive = lazy(constant ["Setoid"] "AsymmetricAreflexive") +let coq_Leibniz = lazy(constant ["Setoid"] "Leibniz") -module Cmap = Map.Make(struct type t = constr let compare = compare end) +let coq_RAsymmetric = lazy(constant ["Setoid"] "RAsymmetric") +let coq_RSymmetric = lazy(constant ["Setoid"] "RSymmetric") +let coq_RLeibniz = lazy(constant ["Setoid"] "RLeibniz") -let setoid_table = ref Gmap.empty +let coq_ASymmetric = lazy(constant ["Setoid"] "ASymmetric") +let coq_AAsymmetric = lazy(constant ["Setoid"] "AAsymmetric") -let setoid_table_add (s,th) = setoid_table := Gmap.add s th !setoid_table -let setoid_table_find s = Gmap.find s !setoid_table -let setoid_table_mem s = Gmap.mem s !setoid_table +let coq_seq_refl = lazy(constant ["Setoid"] "Seq_refl") +let coq_seq_sym = lazy(constant ["Setoid"] "Seq_sym") +let coq_seq_trans = lazy(constant ["Setoid"] "Seq_trans") -let subst_setoid subst setoid = - let set_a' = subst_mps subst setoid.set_a in - let set_aeq' = subst_mps subst setoid.set_aeq in - let set_th' = subst_mps subst setoid.set_th in - if set_a' == setoid.set_a - && set_aeq' == setoid.set_aeq - && set_th' == setoid.set_th +let coq_variance = lazy(constant ["Setoid"] "variance") +let coq_Covariant = lazy(constant ["Setoid"] "Covariant") +let coq_Contravariant = lazy(constant ["Setoid"] "Contravariant") +let coq_Left2Right = lazy(constant ["Setoid"] "Left2Right") +let coq_Right2Left = lazy(constant ["Setoid"] "Right2Left") +let coq_MSNone = lazy(constant ["Setoid"] "MSNone") +let coq_MSCovariant = lazy(constant ["Setoid"] "MSCovariant") +let coq_MSContravariant = lazy(constant ["Setoid"] "MSContravariant") + +let coq_singl = lazy(constant ["Setoid"] "singl") +let coq_cons = lazy(constant ["Setoid"] "cons") + +let coq_equality_morphism_of_asymmetric_areflexive_transitive_relation = + lazy(constant ["Setoid"] + "equality_morphism_of_asymmetric_areflexive_transitive_relation") +let coq_equality_morphism_of_symmetric_areflexive_transitive_relation = + lazy(constant ["Setoid"] + "equality_morphism_of_symmetric_areflexive_transitive_relation") +let coq_equality_morphism_of_asymmetric_reflexive_transitive_relation = + lazy(constant ["Setoid"] + "equality_morphism_of_asymmetric_reflexive_transitive_relation") +let coq_equality_morphism_of_symmetric_reflexive_transitive_relation = + lazy(constant ["Setoid"] + "equality_morphism_of_symmetric_reflexive_transitive_relation") +let coq_make_compatibility_goal = + lazy(constant ["Setoid"] "make_compatibility_goal") +let coq_make_compatibility_goal_eval_ref = + lazy(eval_reference ["Setoid"] "make_compatibility_goal") +let coq_make_compatibility_goal_aux_eval_ref = + lazy(eval_reference ["Setoid"] "make_compatibility_goal_aux") + +let coq_App = lazy(constant ["Setoid"] "App") +let coq_ToReplace = lazy(constant ["Setoid"] "ToReplace") +let coq_ToKeep = lazy(constant ["Setoid"] "ToKeep") +let coq_ProperElementToKeep = lazy(constant ["Setoid"] "ProperElementToKeep") +let coq_fcl_singl = lazy(constant ["Setoid"] "fcl_singl") +let coq_fcl_cons = lazy(constant ["Setoid"] "fcl_cons") + +let coq_setoid_rewrite = lazy(constant ["Setoid"] "setoid_rewrite") +let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1") +let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2") +let coq_unit = lazy(gen_constant ["Init"; "Datatypes"] "unit") +let coq_tt = lazy(gen_constant ["Init"; "Datatypes"] "tt") +let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq") + +let coq_morphism_theory_of_function = + lazy(constant ["Setoid"] "morphism_theory_of_function") +let coq_morphism_theory_of_predicate = + lazy(constant ["Setoid"] "morphism_theory_of_predicate") +let coq_relation_of_relation_class = + lazy(eval_reference ["Setoid"] "relation_of_relation_class") +let coq_directed_relation_of_relation_class = + lazy(eval_reference ["Setoid"] "directed_relation_of_relation_class") +let coq_interp = lazy(eval_reference ["Setoid"] "interp") +let coq_Morphism_Context_rect2 = + lazy(eval_reference ["Setoid"] "Morphism_Context_rect2") +let coq_iff = lazy(gen_constant ["Init";"Logic"] "iff") +let coq_impl = lazy(constant ["Setoid"] "impl") + + +(************************* Table of declared relations **********************) + + +(* Relations are stored in a table which is synchronised with the Reset mechanism. *) + +let relation_table = ref Gmap.empty + +let relation_table_add (s,th) = relation_table := Gmap.add s th !relation_table +let relation_table_find s = Gmap.find s !relation_table +let relation_table_mem s = Gmap.mem s !relation_table + +let prrelation s = + str "(" ++ pr_lconstr s.rel_a ++ str "," ++ pr_lconstr s.rel_aeq ++ str ")" + +let prrelation_class = + function + Relation eq -> + (try prrelation (relation_table_find eq) + with Not_found -> + str "[[ Error: " ++ pr_lconstr eq ++ + str " is not registered as a relation ]]") + | Leibniz (Some ty) -> pr_lconstr ty + | Leibniz None -> str "_" + +let prmorphism_argument_gen prrelation (variance,rel) = + prrelation rel ++ + match variance with + None -> str " ==> " + | Some true -> str " ++> " + | Some false -> str " --> " + +let prargument_class = prmorphism_argument_gen prrelation_class + +let pr_morphism_signature (l,c) = + prlist (prmorphism_argument_gen Ppconstr.pr_constr_expr) l ++ + Ppconstr.pr_constr_expr c + +let prmorphism k m = + pr_lconstr k ++ str ": " ++ + prlist prargument_class m.args ++ + prrelation_class m.output + + +(* A function that gives back the only relation_class on a given carrier *) +(*CSC: this implementation is really inefficient. I should define a new + map to make it efficient. However, is this really worth of? *) +let default_relation_for_carrier ?(filter=fun _ -> true) a = + let rng = Gmap.rng !relation_table in + match List.filter (fun ({rel_a=rel_a} as r) -> rel_a = a && filter r) rng with + [] -> Leibniz (Some a) + | relation::tl -> + if tl <> [] then + ppnl + (str "Warning: There are several relations on the carrier \"" ++ + pr_lconstr a ++ str "\". The relation " ++ prrelation relation ++ + str " is chosen.") ; + Relation relation + +let find_relation_class rel = + try Relation (relation_table_find rel) + with + Not_found -> + let rel = Reduction.whd_betadeltaiota (Global.env ()) rel in + match kind_of_term rel with + | App (eq,[|ty|]) when eq_constr eq (Lazy.force coq_eq) -> Leibniz (Some ty) + | _ when eq_constr rel (Lazy.force coq_eq) -> Leibniz None + | _ -> raise Not_found + +let coq_iff_relation = lazy (find_relation_class (Lazy.force coq_iff)) +let coq_impl_relation = lazy (find_relation_class (Lazy.force coq_impl)) + +let relation_morphism_of_constr_morphism = + let relation_relation_class_of_constr_relation_class = + function + Leibniz t -> Leibniz t + | Relation aeq -> + Relation (try relation_table_find aeq with Not_found -> assert false) + in + function mor -> + let args' = + List.map + (fun (variance,rel) -> + variance, relation_relation_class_of_constr_relation_class rel + ) mor.args in + let output' = relation_relation_class_of_constr_relation_class mor.output in + {mor with args=args' ; output=output'} + +let subst_relation subst relation = + let rel_a' = subst_mps subst relation.rel_a in + let rel_aeq' = subst_mps subst relation.rel_aeq in + let rel_refl' = option_app (subst_mps subst) relation.rel_refl in + let rel_sym' = option_app (subst_mps subst) relation.rel_sym in + let rel_trans' = option_app (subst_mps subst) relation.rel_trans in + let rel_X_relation_class' = subst_mps subst relation.rel_X_relation_class in + let rel_Xreflexive_relation_class' = + subst_mps subst relation.rel_Xreflexive_relation_class + in + if rel_a' == relation.rel_a + && rel_aeq' == relation.rel_aeq + && rel_refl' == relation.rel_refl + && rel_sym' == relation.rel_sym + && rel_trans' == relation.rel_trans + && rel_X_relation_class' == relation.rel_X_relation_class + && rel_Xreflexive_relation_class'==relation.rel_Xreflexive_relation_class then - setoid + relation else - { set_a = set_a' ; - set_aeq = set_aeq' ; - set_th = set_th' ; + { rel_a = rel_a' ; + rel_aeq = rel_aeq' ; + rel_refl = rel_refl' ; + rel_sym = rel_sym'; + rel_trans = rel_trans'; + rel_quantifiers_no = relation.rel_quantifiers_no; + rel_X_relation_class = rel_X_relation_class'; + rel_Xreflexive_relation_class = rel_Xreflexive_relation_class' } -let equiv_list () = List.map (fun x -> x.set_aeq) (Gmap.rng !setoid_table) +let equiv_list () = List.map (fun x -> x.rel_aeq) (Gmap.rng !relation_table) let _ = - Summary.declare_summary "setoid-table" - { Summary.freeze_function = (fun () -> !setoid_table); - Summary.unfreeze_function = (fun t -> setoid_table := t); - Summary.init_function = (fun () -> setoid_table := Gmap .empty); + Summary.declare_summary "relation-table" + { Summary.freeze_function = (fun () -> !relation_table); + Summary.unfreeze_function = (fun t -> relation_table := t); + Summary.init_function = (fun () -> relation_table := Gmap .empty); Summary.survive_module = false; Summary.survive_section = false } -(* Declare a new type of object in the environment : "setoid-theory". *) - -let (setoid_to_obj, obj_to_setoid)= - let cache_set (_,(s, th)) = setoid_table_add (s,th) +(* Declare a new type of object in the environment : "relation-theory". *) + +let (relation_to_obj, obj_to_relation)= + let cache_set (_,(s, th)) = + let th' = + if relation_table_mem s then + begin + let old_relation = relation_table_find s in + let th' = + {th with rel_sym = + match th.rel_sym with + None -> old_relation.rel_sym + | Some t -> Some t} in + ppnl + (str "Warning: The relation " ++ prrelation th' ++ + str " is redeclared. The new declaration" ++ + (match th'.rel_refl with + None -> str "" + | Some t -> str " (reflevity proved by " ++ pr_lconstr t) ++ + (match th'.rel_sym with + None -> str "" + | Some t -> + (if th'.rel_refl = None then str " (" else str " and ") ++ + str "symmetry proved by " ++ pr_lconstr t) ++ + (if th'.rel_refl <> None && th'.rel_sym <> None then + str ")" else str "") ++ + str " replaces the old declaration" ++ + (match old_relation.rel_refl with + None -> str "" + | Some t -> str " (reflevity proved by " ++ pr_lconstr t) ++ + (match old_relation.rel_sym with + None -> str "" + | Some t -> + (if old_relation.rel_refl = None then + str " (" else str " and ") ++ + str "symmetry proved by " ++ pr_lconstr t) ++ + (if old_relation.rel_refl <> None && old_relation.rel_sym <> None + then str ")" else str "") ++ + str "."); + th' + end + else + th + in + relation_table_add (s,th') and subst_set (_,subst,(s,th as obj)) = let s' = subst_mps subst s in - let th' = subst_setoid subst th in + let th' = subst_relation subst th in if s' == s && th' == th then obj else - (s',th') + (s',th') and export_set x = Some x in - declare_object {(default_object "setoid-theory") with - cache_function = cache_set; - open_function = (fun i o -> if i=1 then cache_set o); - subst_function = subst_set; - classify_function = (fun (_,x) -> Substitute x); - export_function = export_set} + declare_object {(default_object "relation-theory") with + cache_function = cache_set; + load_function = (fun i o -> cache_set o); + subst_function = subst_set; + classify_function = (fun (_,x) -> Substitute x); + export_function = export_set} (******************************* Table of declared morphisms ********************) @@ -136,24 +397,56 @@ let (setoid_to_obj, obj_to_setoid)= let morphism_table = ref Gmap.empty -let morphism_table_add (m,c) = morphism_table := Gmap.add m c !morphism_table let morphism_table_find m = Gmap.find m !morphism_table -let morphism_table_mem m = Gmap.mem m !morphism_table +let morphism_table_add (m,c) = + let old = + try + morphism_table_find m + with + Not_found -> [] + in + try + let old_morph = + List.find + (function mor -> mor.args = c.args && mor.output = c.output) old + in + ppnl + (str "Warning: The morphism " ++ prmorphism m old_morph ++ + str " is redeclared. " ++ + str "The new declaration whose compatibility is proved by " ++ + pr_lconstr c.lem ++ str " replaces the old declaration whose" ++ + str " compatibility was proved by " ++ + pr_lconstr old_morph.lem ++ str ".") + with + Not_found -> morphism_table := Gmap.add m (c::old) !morphism_table + +let default_morphism ?(filter=fun _ -> true) m = + match List.filter filter (morphism_table_find m) with + [] -> raise Not_found + | m1::ml -> + if ml <> [] then + ppnl + (str "Warning: There are several morphisms associated to \"" ++ + pr_lconstr m ++ str"\". Morphism " ++ prmorphism m m1 ++ + str " is randomly chosen."); + relation_morphism_of_constr_morphism m1 let subst_morph subst morph = let lem' = subst_mps subst morph.lem in - let arg_types' = list_smartmap (subst_mps subst) morph.arg_types in - let lem2' = option_smartmap (subst_mps subst) morph.lem2 in + let args' = list_smartmap (subst_mps_in_argument_class subst) morph.args in + let output' = subst_mps_in_relation_class subst morph.output in + let morphism_theory' = subst_mps subst morph.morphism_theory in if lem' == morph.lem - && arg_types' == morph.arg_types - && lem2' == morph.lem2 + && args' == morph.args + && output' == morph.output + && morphism_theory' == morph.morphism_theory then morph else - { lem = lem' ; - profil = morph.profil ; - arg_types = arg_types' ; - lem2 = lem2' ; + { args = args' ; + output = output' ; + lem = lem' ; + morphism_theory = morphism_theory' } @@ -173,139 +466,42 @@ let (morphism_to_obj, obj_to_morphism)= let m' = subst_mps subst m in let c' = subst_morph subst c in if m' == m && c' == c then obj else - (m',c') + (m',c') and export_set x = Some x in declare_object {(default_object "morphism-definition") with - cache_function = cache_set; - open_function = (fun i o -> if i=1 then cache_set o); - subst_function = subst_set; - classify_function = (fun (_,x) -> Substitute x); - export_function = export_set} - -(************************** Adding a setoid to the database *********************) - -(* Find the setoid theory associated with a given type A. -This implies that only one setoid theory can be declared for -a given type A. *) - -let find_theory a = - try - setoid_table_find a - with Not_found -> - errorlabstrm "Setoid" - (str "No Declared Setoid Theory for " ++ - prterm a ++ fnl () ++ - str "Use Add Setoid to declare it") - -(* Add a Setoid to the database after a type verification. *) - -let eq_lem_common_sign env a eq = - let na = named_hd env a Anonymous in - let ne = named_hd env eq Anonymous in - [(ne,None,mkApp (eq, [|(mkRel 3);(mkRel 2)|])); - (ne,None,mkApp (eq, [|(mkRel 4);(mkRel 3)|])); - (na,None,a);(na,None,a);(na,None,a);(na,None,a)] - -(* Proof of (a,b,c,d:A)(eq a b)->(eq c d)->(eq a c)->(eq b d) *) -let eq_lem_proof env a eq sym trans = - let sign = eq_lem_common_sign env a eq in - let ne = named_hd env eq Anonymous in - let sign = (ne,None,mkApp (eq, [|(mkRel 6);(mkRel 4)|]))::sign in - let ccl = mkApp (eq, [|(mkRel 6);(mkRel 4)|]) in - let body = - mkApp (trans, - [|(mkRel 6);(mkRel 7);(mkRel 4); - (mkApp (sym, [|(mkRel 7);(mkRel 6);(mkRel 3)|])); - (mkApp (trans, - [|(mkRel 7);(mkRel 5);(mkRel 4);(mkRel 1);(mkRel 2)|]))|]) in - let p = it_mkLambda_or_LetIn body sign in - let t = it_mkProd_or_LetIn ccl sign in - (p,t) - -(* Proof of (a,b,c,d:A)(eq a b)->(eq c d)->((eq a c)<->(eq b d)) *) -let eq_lem2_proof env a eq sym trans = - let sign = eq_lem_common_sign env a eq in - let ccl1 = - mkArrow - (mkApp (eq, [|(mkRel 6);(mkRel 4)|])) - (mkApp (eq, [|(mkRel 6);(mkRel 4)|])) in - let ccl2 = - mkArrow - (mkApp (eq, [|(mkRel 5);(mkRel 3)|])) - (mkApp (eq, [|(mkRel 7);(mkRel 5)|])) in - let ccl = mkApp (Lazy.force coqand, [|ccl1;ccl2|]) in - let body = - mkApp ((Lazy.force coqconj), - [|ccl1;ccl2; - lambda_create env - (mkApp (eq, [|(mkRel 6);(mkRel 4)|]), - (mkApp (trans, - [|(mkRel 6);(mkRel 7);(mkRel 4); - (mkApp (sym, [|(mkRel 7);(mkRel 6);(mkRel 3)|])); - (mkApp (trans, - [|(mkRel 7);(mkRel 5);(mkRel 4);(mkRel 1);(mkRel 2)|]))|]))); - lambda_create env - (mkApp (eq, [|(mkRel 5);(mkRel 3)|]), - (mkApp (trans, - [|(mkRel 7);(mkRel 6);(mkRel 5);(mkRel 3); - (mkApp (trans, - [|(mkRel 6);(mkRel 4);(mkRel 5);(mkRel 1); - (mkApp (sym, [|(mkRel 5);(mkRel 4);(mkRel 2)|]))|]))|])))|]) - in - let p = it_mkLambda_or_LetIn body sign in - let t = it_mkProd_or_LetIn ccl sign in - (p,t) - -let gen_eq_lem_name = - let i = ref 0 in - function () -> - incr i; - make_ident "setoid_eq_ext" (Some !i) - -let add_setoid a aeq th = - if setoid_table_mem a - then errorlabstrm "Add Setoid" - (str "A Setoid Theory is already declared for " ++ prterm a) - else let env = Global.env () in - if (is_conv env Evd.empty (Typing.type_of env Evd.empty th) - (mkApp ((Lazy.force coq_Setoid_Theory), [| a; aeq |]))) - then (Lib.add_anonymous_leaf - (setoid_to_obj - (a, { set_a = a; - set_aeq = aeq; - set_th = th})); - let sym = mkApp ((Lazy.force coq_seq_sym), [|a; aeq; th|]) in - let trans = mkApp ((Lazy.force coq_seq_trans), [|a; aeq; th|]) in - let (eq_morph, eq_morph_typ) = eq_lem_proof env a aeq sym trans in - let (eq_morph2, eq_morph2_typ) = eq_lem2_proof env a aeq sym trans in - Options.if_verbose ppnl (prterm a ++str " is registered as a setoid"); - let eq_ext_name = gen_eq_lem_name () in - let eq_ext_name2 = gen_eq_lem_name () in - let _ = Declare.declare_constant eq_ext_name - ((DefinitionEntry {const_entry_body = eq_morph; - const_entry_type = Some eq_morph_typ; - const_entry_opaque = true}), - IsProof Lemma) in - let _ = Declare.declare_constant eq_ext_name2 - ((DefinitionEntry {const_entry_body = eq_morph2; - const_entry_type = Some eq_morph2_typ; - const_entry_opaque = true}), - IsProof Lemma) in - let eqmorph = (current_constant eq_ext_name) in - let eqmorph2 = (current_constant eq_ext_name2) in - (Lib.add_anonymous_leaf - (morphism_to_obj (aeq, - { lem = eqmorph; - profil = [true; true]; - arg_types = [a;a]; - lem2 = (Some eqmorph2)}))); - Options.if_verbose ppnl (prterm aeq ++str " is registered as a morphism")) - else errorlabstrm "Add Setoid" (str "Not a valid setoid theory") - -(* The vernac command "Add Setoid" *) -let add_setoid a aeq th = - add_setoid (constr_of a) (constr_of aeq) (constr_of th) + cache_function = cache_set; + load_function = (fun i o -> cache_set o); + subst_function = subst_set; + classify_function = (fun (_,x) -> Substitute x); + export_function = export_set} + +(************************** Printing relations and morphisms **********************) + +let print_setoids () = + Gmap.iter + (fun k relation -> + assert (k=relation.rel_aeq) ; + ppnl (str"Relation " ++ prrelation relation ++ str";" ++ + (match relation.rel_refl with + None -> str "" + | Some t -> str" reflexivity proved by " ++ pr_lconstr t) ++ + (match relation.rel_sym with + None -> str "" + | Some t -> str " symmetry proved by " ++ pr_lconstr t) ++ + (match relation.rel_trans with + None -> str "" + | Some t -> str " transitivity proved by " ++ pr_lconstr t))) + !relation_table ; + Gmap.iter + (fun k l -> + List.iter + (fun ({lem=lem} as mor) -> + ppnl (str "Morphism " ++ prmorphism k mor ++ + str ". Compatibility proved by " ++ + pr_lconstr lem ++ str ".")) + l) !morphism_table +;; (***************** Adding a morphism to the database ****************************) @@ -314,8 +510,8 @@ let add_setoid a aeq th = let edited = ref Gmap.empty -let new_edited id m profil = - edited := Gmap.add id (m,profil) !edited +let new_edited id m = + edited := Gmap.add id m !edited let is_edited id = Gmap.mem id !edited @@ -326,361 +522,1435 @@ let no_more_edited id = let what_edited id = Gmap.find id !edited -let check_is_dependent t n = - let rec aux t i n = - if (i add_suffix id "_ext" - | Const kn -> add_suffix (id_of_label (label kn)) "_ext" - | Ind (kn, i) -> add_suffix (id_of_label (label kn)) ((string_of_int i)^"_ext") - | Construct ((kn,i),j) -> add_suffix - (id_of_label (label kn)) ((string_of_int i)^(string_of_int j)^"_ext") - | _ -> errorlabstrm "New Morphism" (str "The term " ++ prterm m ++ str "is not a known name") - -let gen_lemma_tail m lisset body n = - let l = (List.length lisset) in - let a1 = Array.create l (mkRel 0) in - let a2 = Array.create l (mkRel 0) in - let rec aux i n = function - | true::q -> - a1.(i) <- (mkRel n); - a2.(i) <- (mkRel (n-1)); - aux (i+1) (n-2) q - | false::q -> - a1.(i) <- (mkRel n); - a2.(i) <- (mkRel n); - aux (i+1) (n-1) q - | [] -> () in - aux 0 n lisset; - if (eq_constr body mkProp) - then mkArrow (mkApp (m,a1)) (lift 1 (mkApp (m, a2))) - else if (setoid_table_mem body) - then mkApp ((setoid_table_find body).set_aeq, [|(mkApp (m, a1)); (mkApp (m, a2))|]) - else mkApp ((Lazy.force coqeq), [|body; (mkApp (m, a1)); (mkApp (m, a2))|]) - -let gen_lemma_middle m larg lisset body n = - let rec aux la li i n = match (la, li) with - | ([], []) -> gen_lemma_tail m lisset body n - | (t::q, true::lq) -> - mkArrow (mkApp ((setoid_table_find t).set_aeq, - [|(mkRel i); (mkRel (i-1))|])) (aux q lq (i-1) (n+1)) - | (t::q, false::lq) -> aux q lq (i-1) n - | _ -> assert false - in aux larg lisset n n - -let gen_compat_lemma env m body larg lisset = - let rec aux la li n = match (la, li) with - | (t::q, true::lq) -> - prod_create env (t,(prod_create env (t, (aux q lq (n+2))))) - | (t::q, false::lq) -> - prod_create env (t, (aux q lq (n+1))) - | ([],[]) -> gen_lemma_middle m larg lisset body n - | _ -> assert false - in aux larg lisset 0 - -let new_morphism m id hook = - if morphism_table_mem m - then errorlabstrm "New Morphism" - (str "The term " ++ prterm m ++ str " is already declared as a morphism") - else - let env = Global.env() in - let typeofm = (Typing.type_of env Evd.empty m) in - let typ = (nf_betaiota typeofm) in (* nf_bdi avant, mais bug *) - let (argsrev, body) = (decompose_prod typ) in - let args = (List.rev argsrev) in - if (args=[]) - then errorlabstrm "New Morphism" - (str "The term " ++ prterm m ++ str " is not a product") - else if (check_is_dependent typ (List.length args)) - then errorlabstrm "New Morphism" - (str "The term " ++ prterm m ++ str " should not be a dependent product") - else ( - let args_t = (List.map snd args) in - let poss = (List.map setoid_table_mem args_t) in - let lem = (gen_compat_lemma env m body args_t poss) in - new_edited id m poss; - Pfedit.start_proof id (IsGlobal (Proof Lemma)) - (Declare.clear_proofs (Global.named_context ())) - lem hook; - (Options.if_verbose msg (Pfedit.pr_open_subgoals ()))) - -let rec sub_bool l1 n = function - | [] -> [] - | true::q -> ((List.hd l1), n)::(sub_bool (List.tl l1) (n-2) q) - | false::q -> (sub_bool (List.tl l1) (n-1) q) - -let gen_lemma_iff_tail m mext larg lisset n k = - let a1 = Array.create k (mkRel 0) in - let a2 = Array.create k (mkRel 0) in - let nb = List.length lisset in - let b1 = Array.create nb (mkRel 0) in - let b2 = Array.create nb (mkRel 0) in - let rec aux i j = function - |[] -> () - |true::q -> - (a1.(i) <- (mkRel j); - a1.(i+1) <- (mkRel (j-1)); - a2.(i) <- (mkRel (j-1)); - a2.(i+1) <- (mkRel j); - aux (i+2) (j-2) q) - |false::q -> - (a1.(i) <- (mkRel j); - a2.(i) <- (mkRel j); - aux (i+1) (j-1) q) in - let rec aux2 i j = function - | (t,p)::q -> - let th = (setoid_table_find t).set_th - and equiv = (setoid_table_find t).set_aeq in - a1.(i) <- (mkRel j); - a2.(i) <- mkApp ((Lazy.force coq_seq_sym), - [|t; equiv; th; (mkRel p); (mkRel (p-1)); (mkRel j)|]); - aux2 (i+1) (j-1) q - | [] -> () in - let rec aux3 i j = function - | true::q -> - b1.(i) <- (mkRel j); - b2.(i) <- (mkRel (j-1)); - aux3 (i+1) (j-2) q - | false::q -> - b1.(i) <- (mkRel j); - b2.(i) <- (mkRel j); - aux3 (i+1) (j-1) q - | [] -> () in - aux 0 k lisset; - aux2 n (k-n) (sub_bool larg k lisset); - aux3 0 k lisset; - mkApp ((Lazy.force coqconj), - [|(mkArrow (mkApp (m,b1)) (lift 1 (mkApp (m, b2)))); - (mkArrow (mkApp (m,b2)) (lift 1 (mkApp (m, b1)))); - (mkApp (mext, a1));(mkApp (mext, a2))|]) - -let gen_lemma_iff_middle env m mext larg lisset n = - let rec aux la li i k = match (la, li) with - | ([], []) -> gen_lemma_iff_tail m mext larg lisset n k - | (t::q, true::lq) -> - lambda_create env ((mkApp ((setoid_table_find t).set_aeq, [|(mkRel i); (mkRel (i-1))|])), - (aux q lq (i-1) (k+1))) - | (t::q, false::lq) -> aux q lq (i-1) k - | _ -> assert false - in aux larg lisset n n - -let gen_lem_iff env m mext larg lisset = - let rec aux la li n = match (la, li) with - | (t::q, true::lq) -> - lambda_create env (t,(lambda_create env (t, (aux q lq (n+2))))) - | (t::q, false::lq) -> - lambda_create env (t, (aux q lq (n+1))) - | ([],[]) -> gen_lemma_iff_middle env m mext larg lisset n - | _ -> assert false - in aux larg lisset 0 - -let add_morphism lem_name (m,profil) = - if morphism_table_mem m - then errorlabstrm "New Morphism" - (str "The term " ++ prterm m ++ str " is already declared as a morpism") - else - let env = Global.env() in - let mext = (current_constant lem_name) in - let typeofm = (Typing.type_of env Evd.empty m) in - let typ = (nf_betaiota typeofm) in - let (argsrev, body) = (decompose_prod typ) in - let args = List.rev argsrev in - let args_t = (List.map snd args) in - let poss = (List.map setoid_table_mem args_t) in - let _ = assert (poss=profil) in - (if (eq_constr body mkProp) - then - (let lem_2 = gen_lem_iff env m mext args_t poss in - let lem2_name = add_suffix lem_name "2" in - let _ = Declare.declare_constant lem2_name - ((DefinitionEntry {const_entry_body = lem_2; - const_entry_type = None; - const_entry_opaque = true}), - IsProof Lemma) in - let lem2 = (current_constant lem2_name) in - (Lib.add_anonymous_leaf - (morphism_to_obj (m, - { lem = mext; - profil = poss; - arg_types = args_t; - lem2 = (Some lem2)}))); - Options.if_verbose message ((string_of_id lem2_name) ^ " is defined")) +(* also returns the triple (args_ty_quantifiers_rev,real_args_ty,real_output) + where the args_ty and the output are delifted *) +let check_is_dependent n args_ty output = + let m = List.length args_ty - n in + let args_ty_quantifiers, args_ty = Util.list_chop n args_ty in + let rec aux m t = + match kind_of_term t with + Prod (n,s,t) when m > 0 -> + if not (dependent (mkRel 1) t) then + let args,out = aux (m - 1) (subst1 (mkRel 1) (* dummy *) t) in + s::args,out + else + errorlabstrm "New Morphism" + (str "The morphism is not a quantified non dependent product.") + | _ -> [],t + in + let ty = compose_prod (List.rev args_ty) output in + let args_ty, output = aux m ty in + List.rev args_ty_quantifiers, args_ty, output + +let cic_relation_class_of_X_relation typ value = + function + {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=None} -> + mkApp ((Lazy.force coq_AsymmetricReflexive), + [| typ ; value ; rel_a ; rel_aeq; refl |]) + | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=Some sym} -> + mkApp ((Lazy.force coq_SymmetricReflexive), + [| typ ; rel_a ; rel_aeq; sym ; refl |]) + | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=None} -> + mkApp ((Lazy.force coq_AsymmetricAreflexive), + [| typ ; value ; rel_a ; rel_aeq |]) + | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=Some sym} -> + mkApp ((Lazy.force coq_SymmetricAreflexive), + [| typ ; rel_a ; rel_aeq; sym |]) + +let cic_relation_class_of_X_relation_class typ value = + function + Relation {rel_X_relation_class=x_relation_class} -> + mkApp (x_relation_class, [| typ ; value |]) + | Leibniz (Some t) -> + mkApp ((Lazy.force coq_Leibniz), [| typ ; t |]) + | Leibniz None -> assert false + + +let cic_precise_relation_class_of_relation = + function + {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=None} -> + mkApp ((Lazy.force coq_RAsymmetric), [| rel_a ; rel_aeq; refl |]) + | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=Some sym} -> + mkApp ((Lazy.force coq_RSymmetric), [| rel_a ; rel_aeq; sym ; refl |]) + | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=None} -> + mkApp ((Lazy.force coq_AAsymmetric), [| rel_a ; rel_aeq |]) + | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=Some sym} -> + mkApp ((Lazy.force coq_ASymmetric), [| rel_a ; rel_aeq; sym |]) + +let cic_precise_relation_class_of_relation_class = + function + Relation + {rel_aeq=rel_aeq; rel_Xreflexive_relation_class=lem; rel_refl=rel_refl } + -> + rel_aeq,lem,not(rel_refl=None) + | Leibniz (Some t) -> + mkApp ((Lazy.force coq_eq), [| t |]), + mkApp ((Lazy.force coq_RLeibniz), [| t |]), true + | Leibniz None -> assert false + +let cic_relation_class_of_relation_class rel = + cic_relation_class_of_X_relation_class + (Lazy.force coq_unit) (Lazy.force coq_tt) rel + +let cic_argument_class_of_argument_class (variance,arg) = + let coq_variant_value = + match variance with + None -> (Lazy.force coq_Covariant) (* dummy value, it won't be used *) + | Some true -> (Lazy.force coq_Covariant) + | Some false -> (Lazy.force coq_Contravariant) + in + cic_relation_class_of_X_relation_class (Lazy.force coq_variance) + coq_variant_value arg + +let cic_arguments_of_argument_class_list args = + let rec aux = + function + [] -> assert false + | [last] -> + mkApp ((Lazy.force coq_singl), [| Lazy.force coq_Argument_Class; last |]) + | he::tl -> + mkApp ((Lazy.force coq_cons), + [| Lazy.force coq_Argument_Class; he ; aux tl |]) + in + aux (List.map cic_argument_class_of_argument_class args) + +let gen_compat_lemma_statement quantifiers_rev output args m = + let output = cic_relation_class_of_relation_class output in + let args = cic_arguments_of_argument_class_list args in + args, output, + compose_prod quantifiers_rev + (mkApp ((Lazy.force coq_make_compatibility_goal), [| args ; output ; m |])) + +let morphism_theory_id_of_morphism_proof_id id = + id_of_string (string_of_id id ^ "_morphism_theory") + +(* apply_to_rels c [l1 ; ... ; ln] returns (c Rel1 ... reln) *) +let apply_to_rels c l = + if l = [] then c + else + let len = List.length l in + applistc c (Util.list_map_i (fun i _ -> mkRel (len - i)) 0 l) + +let apply_to_relation subst rel = + if Array.length subst = 0 then rel + else + let new_quantifiers_no = rel.rel_quantifiers_no - Array.length subst in + assert (new_quantifiers_no >= 0) ; + { rel_a = mkApp (rel.rel_a, subst) ; + rel_aeq = mkApp (rel.rel_aeq, subst) ; + rel_refl = option_app (fun c -> mkApp (c,subst)) rel.rel_refl ; + rel_sym = option_app (fun c -> mkApp (c,subst)) rel.rel_sym; + rel_trans = option_app (fun c -> mkApp (c,subst)) rel.rel_trans; + rel_quantifiers_no = new_quantifiers_no; + rel_X_relation_class = mkApp (rel.rel_X_relation_class, subst); + rel_Xreflexive_relation_class = + mkApp (rel.rel_Xreflexive_relation_class, subst) } + +let add_morphism lemma_infos mor_name (m,quantifiers_rev,args,output) = + let lem = + match lemma_infos with + None -> + (* the Morphism_Theory object has already been created *) + let applied_args = + let len = List.length quantifiers_rev in + let subst = + Array.of_list + (Util.list_map_i (fun i _ -> mkRel (len - i)) 0 quantifiers_rev) + in + List.map + (fun (v,rel) -> + match rel with + Leibniz (Some t) -> + assert (subst=[||]); + v, Leibniz (Some t) + | Leibniz None -> + assert (Array.length subst = 1); + v, Leibniz (Some (subst.(0))) + | Relation rel -> v, Relation (apply_to_relation subst rel)) args + in + compose_lam quantifiers_rev + (mkApp (Lazy.force coq_Compat, + [| cic_arguments_of_argument_class_list applied_args; + cic_relation_class_of_relation_class output; + apply_to_rels (current_constant mor_name) quantifiers_rev |])) + | Some (lem_name,argsconstr,outputconstr) -> + (* only the compatibility has been proved; we need to declare the + Morphism_Theory object *) + let mext = current_constant lem_name in + ignore ( + Declare.declare_internal_constant mor_name + (DefinitionEntry + {const_entry_body = + compose_lam quantifiers_rev + (mkApp ((Lazy.force coq_Build_Morphism_Theory), + [| argsconstr; outputconstr; apply_to_rels m quantifiers_rev ; + apply_to_rels mext quantifiers_rev |])); + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = Options.boxed_definitions()}, + IsDefinition Definition)) ; + mext + in + let mmor = current_constant mor_name in + let args_constr = + List.map + (fun (variance,arg) -> + variance, constr_relation_class_of_relation_relation_class arg) args in + let output_constr = constr_relation_class_of_relation_relation_class output in + Lib.add_anonymous_leaf + (morphism_to_obj (m, + { args = args_constr; + output = output_constr; + lem = lem; + morphism_theory = mmor })); + Options.if_verbose ppnl (pr_lconstr m ++ str " is registered as a morphism") + +(* first order matching with a bit of conversion *) +let unify_relation_carrier_with_type env rel t = + let raise_error quantifiers_no = + errorlabstrm "New Morphism" + (str "One morphism argument or its output has type " ++ pr_lconstr t ++ + str " but the signature requires an argument of type \"" ++ + pr_lconstr rel.rel_a ++ str " " ++ prvect_with_sep pr_spc (fun _ -> str "?") + (Array.make quantifiers_no 0) ++ str "\"") in + let args = + match kind_of_term t with + App (he',args') -> + let argsno = Array.length args' - rel.rel_quantifiers_no in + let args1 = Array.sub args' 0 argsno in + let args2 = Array.sub args' argsno rel.rel_quantifiers_no in + if is_conv env Evd.empty rel.rel_a (mkApp (he',args1)) then + args2 else - (Lib.add_anonymous_leaf - (morphism_to_obj (m, - { lem = mext; - profil = poss; - arg_types = args_t; - lem2 = None})))); - Options.if_verbose ppnl (prterm m ++str " is registered as a morphism") -let morphism_hook stre ref = + raise_error rel.rel_quantifiers_no + | _ -> + if rel.rel_quantifiers_no = 0 && is_conv env Evd.empty rel.rel_a t then + [||] + else + begin + let evars,args,instantiated_rel_a = + let ty = Typing.type_of env Evd.empty rel.rel_a in + let evd = Evd.create_evar_defs Evd.empty in + let evars,args,concl = + Clenv.clenv_environments_evars env evd + (Some rel.rel_quantifiers_no) ty + in + evars, args, + nf_betaiota + (match args with [] -> rel.rel_a | _ -> applist (rel.rel_a,args)) + in + let evars' = + w_unify true (*??? or false? *) env Reduction.CONV (*??? or cumul? *) + ~mod_delta:true (*??? or true? *) t instantiated_rel_a evars in + let args' = + List.map (Reductionops.nf_evar (Evd.evars_of evars')) args + in + Array.of_list args' + end + in + apply_to_relation args rel + +let unify_relation_class_carrier_with_type env rel t = + match rel with + Leibniz (Some t') -> + if is_conv env Evd.empty t t' then + rel + else + errorlabstrm "New Morphism" + (str "One morphism argument or its output has type " ++ pr_lconstr t ++ + str " but the signature requires an argument of type " ++ + pr_lconstr t') + | Leibniz None -> Leibniz (Some t) + | Relation rel -> Relation (unify_relation_carrier_with_type env rel t) + +(* first order matching with a bit of conversion *) +(* Note: the type checking operations performed by the function could *) +(* be done once and for all abstracting the morphism structure using *) +(* the quantifiers. Would the new structure be more suited than the *) +(* existent one for other tasks to? (e.g. pretty printing would expose *) +(* much more information: is it ok or is it too much information?) *) +let unify_morphism_with_arguments gl (c,av) + {args=args; output=output; lem=lem; morphism_theory=morphism_theory} t += + let al = Array.to_list av in + let argsno = List.length args in + let quantifiers,al' = Util.list_chop (List.length al - argsno) al in + let quantifiersv = Array.of_list quantifiers in + let c' = mkApp (c,quantifiersv) in + if dependent t c' then None else ( + (* these are pf_type_of we could avoid *) + let al'_type = List.map (Tacmach.pf_type_of gl) al' in + let args' = + List.map2 + (fun (var,rel) ty -> + var,unify_relation_class_carrier_with_type (pf_env gl) rel ty) + args al'_type in + (* this is another pf_type_of we could avoid *) + let ty = Tacmach.pf_type_of gl (mkApp (c,av)) in + let output' = unify_relation_class_carrier_with_type (pf_env gl) output ty in + let lem' = mkApp (lem,quantifiersv) in + let morphism_theory' = mkApp (morphism_theory,quantifiersv) in + Some + ({args=args'; output=output'; lem=lem'; morphism_theory=morphism_theory'}, + c',Array.of_list al')) + +let new_morphism m signature id hook = + if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then + errorlabstrm "New Morphism" (pr_id id ++ str " already exists") + else + let env = Global.env() in + let typeofm = Typing.type_of env Evd.empty m in + let typ = clos_norm_flags Closure.betaiotazeta empty_env Evd.empty typeofm in + let argsrev, output = + match signature with + None -> decompose_prod typ + | Some (_,output') -> + (* the carrier of the relation output' can be a Prod ==> + we must uncurry on the fly output. + E.g: A -> B -> C vs A -> (B -> C) + args output args output + *) + let rel = find_relation_class output' in + let rel_a,rel_quantifiers_no = + match rel with + Relation rel -> rel.rel_a, rel.rel_quantifiers_no + | Leibniz (Some t) -> t, 0 + | Leibniz None -> assert false in + let rel_a_n = + clos_norm_flags Closure.betaiotazeta empty_env Evd.empty rel_a in + try + let _,output_rel_a_n = decompose_lam_n rel_quantifiers_no rel_a_n in + let argsrev,_ = decompose_prod output_rel_a_n in + let n = List.length argsrev in + let argsrev',_ = decompose_prod typ in + let m = List.length argsrev' in + decompose_prod_n (m - n) typ + with UserError(_,_) -> + (* decompose_lam_n failed. This may happen when rel_a is an axiom, + a constructor, an inductive type, etc. *) + decompose_prod typ + in + let args_ty = List.rev argsrev in + let args_ty_len = List.length (args_ty) in + let args_ty_quantifiers_rev,args,args_instance,output,output_instance = + match signature with + None -> + if args_ty = [] then + errorlabstrm "New Morphism" + (str "The term " ++ pr_lconstr m ++ str " has type " ++ + pr_lconstr typeofm ++ str " that is not a product.") ; + ignore (check_is_dependent 0 args_ty output) ; + let args = + List.map + (fun (_,ty) -> None,default_relation_for_carrier ty) args_ty in + let output = default_relation_for_carrier output in + [],args,args,output,output + | Some (args,output') -> + assert (args <> []); + let number_of_arguments = List.length args in + let number_of_quantifiers = args_ty_len - number_of_arguments in + if number_of_quantifiers < 0 then + errorlabstrm "New Morphism" + (str "The morphism " ++ pr_lconstr m ++ str " has type " ++ + pr_lconstr typeofm ++ str " that attends at most " ++ int args_ty_len ++ + str " arguments. The signature that you specified requires " ++ + int number_of_arguments ++ str " arguments.") + else + begin + (* the real_args_ty returned are already delifted *) + let args_ty_quantifiers_rev, real_args_ty, real_output = + check_is_dependent number_of_quantifiers args_ty output in + let quantifiers_rel_context = + List.map (fun (n,t) -> n,None,t) args_ty_quantifiers_rev in + let env = push_rel_context quantifiers_rel_context env in + let find_relation_class t real_t = + try + let rel = find_relation_class t in + rel, unify_relation_class_carrier_with_type env rel real_t + with Not_found -> + errorlabstrm "Add Morphism" + (str "Not a valid signature: " ++ pr_lconstr t ++ + str " is neither a registered relation nor the Leibniz " ++ + str " equality.") + in + let find_relation_class_v (variance,t) real_t = + let relation,relation_instance = find_relation_class t real_t in + match relation, variance with + Leibniz _, None + | Relation {rel_sym = Some _}, None + | Relation {rel_sym = None}, Some _ -> + (variance, relation), (variance, relation_instance) + | Relation {rel_sym = None},None -> + errorlabstrm "Add Morphism" + (str "You must specify the variance in each argument " ++ + str "whose relation is asymmetric.") + | Leibniz _, Some _ + | Relation {rel_sym = Some _}, Some _ -> + errorlabstrm "Add Morphism" + (str "You cannot specify the variance of an argument " ++ + str "whose relation is symmetric.") + in + let args, args_instance = + List.split + (List.map2 find_relation_class_v args real_args_ty) in + let output,output_instance= find_relation_class output' real_output in + args_ty_quantifiers_rev, args, args_instance, output, output_instance + end + in + let argsconstr,outputconstr,lem = + gen_compat_lemma_statement args_ty_quantifiers_rev output_instance + args_instance (apply_to_rels m args_ty_quantifiers_rev) in + (* "unfold make_compatibility_goal" *) + let lem = + Reductionops.clos_norm_flags + (Closure.unfold_red (Lazy.force coq_make_compatibility_goal_eval_ref)) + env Evd.empty lem in + (* "unfold make_compatibility_goal_aux" *) + let lem = + Reductionops.clos_norm_flags + (Closure.unfold_red(Lazy.force coq_make_compatibility_goal_aux_eval_ref)) + env Evd.empty lem in + (* "simpl" *) + let lem = Tacred.nf env Evd.empty lem in + if Lib.is_modtype () then + begin + ignore + (Declare.declare_internal_constant id + (ParameterEntry lem, IsAssumption Logical)) ; + let mor_name = morphism_theory_id_of_morphism_proof_id id in + let lemma_infos = Some (id,argsconstr,outputconstr) in + add_morphism lemma_infos mor_name + (m,args_ty_quantifiers_rev,args,output) + end + else + begin + new_edited id + (m,args_ty_quantifiers_rev,args,argsconstr,output,outputconstr); + Pfedit.start_proof id (Global, Proof Lemma) + (Declare.clear_proofs (Global.named_context ())) + lem hook; + Options.if_verbose msg (Printer.pr_open_subgoals ()); + end + +let morphism_hook _ ref = let pf_id = id_of_global ref in + let mor_id = morphism_theory_id_of_morphism_proof_id pf_id in + let (m,quantifiers_rev,args,argsconstr,output,outputconstr) = + what_edited pf_id in if (is_edited pf_id) then - (add_morphism pf_id (what_edited pf_id); no_more_edited pf_id) + begin + add_morphism (Some (pf_id,argsconstr,outputconstr)) mor_id + (m,quantifiers_rev,args,output) ; + no_more_edited pf_id + end + +type morphism_signature = + (bool option * Topconstr.constr_expr) list * Topconstr.constr_expr + +let new_named_morphism id m sign = + let sign = + match sign with + None -> None + | Some (args,out) -> + Some + (List.map (fun (variance,ty) -> variance, constr_of ty) args, + constr_of out) + in + new_morphism (constr_of m) sign id morphism_hook + +(************************** Adding a relation to the database *********************) + +let check_a env a = + let typ = Typing.type_of env Evd.empty a in + let a_quantifiers_rev,_ = Reduction.dest_arity env typ in + a_quantifiers_rev + +let check_eq env a_quantifiers_rev a aeq = + let typ = + Sign.it_mkProd_or_LetIn + (mkApp ((Lazy.force coq_relation),[| apply_to_rels a a_quantifiers_rev |])) + a_quantifiers_rev in + if + not + (is_conv env Evd.empty (Typing.type_of env Evd.empty aeq) typ) + then + errorlabstrm "Add Relation Class" + (pr_lconstr aeq ++ str " should have type (" ++ pr_lconstr typ ++ str ")") + +let check_property env a_quantifiers_rev a aeq strprop coq_prop t = + if + not + (is_conv env Evd.empty (Typing.type_of env Evd.empty t) + (Sign.it_mkProd_or_LetIn + (mkApp ((Lazy.force coq_prop), + [| apply_to_rels a a_quantifiers_rev ; + apply_to_rels aeq a_quantifiers_rev |])) a_quantifiers_rev)) + then + errorlabstrm "Add Relation Class" + (str "Not a valid proof of " ++ str strprop ++ str ".") + +let check_refl env a_quantifiers_rev a aeq refl = + check_property env a_quantifiers_rev a aeq "reflexivity" coq_reflexive refl + +let check_sym env a_quantifiers_rev a aeq sym = + check_property env a_quantifiers_rev a aeq "symmetry" coq_symmetric sym + +let check_trans env a_quantifiers_rev a aeq trans = + check_property env a_quantifiers_rev a aeq "transitivity" coq_transitive trans + +let check_setoid_theory env a_quantifiers_rev a aeq th = + if + not + (is_conv env Evd.empty (Typing.type_of env Evd.empty th) + (Sign.it_mkProd_or_LetIn + (mkApp ((Lazy.force coq_Setoid_Theory), + [| apply_to_rels a a_quantifiers_rev ; + apply_to_rels aeq a_quantifiers_rev |])) a_quantifiers_rev)) + then + errorlabstrm "Add Relation Class" + (str "Not a valid proof of symmetry") + +let int_add_relation id a aeq refl sym trans = + let env = Global.env () in + let a_quantifiers_rev = check_a env a in + check_eq env a_quantifiers_rev a aeq ; + option_iter (check_refl env a_quantifiers_rev a aeq) refl ; + option_iter (check_sym env a_quantifiers_rev a aeq) sym ; + option_iter (check_trans env a_quantifiers_rev a aeq) trans ; + let quantifiers_no = List.length a_quantifiers_rev in + let aeq_rel = + { rel_a = a; + rel_aeq = aeq; + rel_refl = refl; + rel_sym = sym; + rel_trans = trans; + rel_quantifiers_no = quantifiers_no; + rel_X_relation_class = mkProp; (* dummy value, overwritten below *) + rel_Xreflexive_relation_class = mkProp (* dummy value, overwritten below *) + } in + let x_relation_class = + let subst = + let len = List.length a_quantifiers_rev in + Array.of_list + (Util.list_map_i (fun i _ -> mkRel (len - i + 2)) 0 a_quantifiers_rev) in + cic_relation_class_of_X_relation + (mkRel 2) (mkRel 1) (apply_to_relation subst aeq_rel) in + let _ = + Declare.declare_internal_constant id + (DefinitionEntry + {const_entry_body = + Sign.it_mkLambda_or_LetIn x_relation_class + ([ Name (id_of_string "v"),None,mkRel 1; + Name (id_of_string "X"),None,mkType (Termops.new_univ ())] @ + a_quantifiers_rev); + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = Options.boxed_definitions()}, + IsDefinition Definition) in + let id_precise = id_of_string (string_of_id id ^ "_precise_relation_class") in + let xreflexive_relation_class = + let subst = + let len = List.length a_quantifiers_rev in + Array.of_list + (Util.list_map_i (fun i _ -> mkRel (len - i)) 0 a_quantifiers_rev) + in + cic_precise_relation_class_of_relation (apply_to_relation subst aeq_rel) in + let _ = + Declare.declare_internal_constant id_precise + (DefinitionEntry + {const_entry_body = + Sign.it_mkLambda_or_LetIn xreflexive_relation_class a_quantifiers_rev; + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = Options.boxed_definitions() }, + IsDefinition Definition) in + let aeq_rel = + { aeq_rel with + rel_X_relation_class = current_constant id; + rel_Xreflexive_relation_class = current_constant id_precise } in + Lib.add_anonymous_leaf (relation_to_obj (aeq, aeq_rel)) ; + Options.if_verbose ppnl (pr_lconstr aeq ++ str " is registered as a relation"); + match trans with + None -> () + | Some trans -> + let mor_name = id_of_string (string_of_id id ^ "_morphism") in + let a_instance = apply_to_rels a a_quantifiers_rev in + let aeq_instance = apply_to_rels aeq a_quantifiers_rev in + let sym_instance = + option_app (fun x -> apply_to_rels x a_quantifiers_rev) sym in + let refl_instance = + option_app (fun x -> apply_to_rels x a_quantifiers_rev) refl in + let trans_instance = apply_to_rels trans a_quantifiers_rev in + let aeq_rel_class_and_var1, aeq_rel_class_and_var2, lemma, output = + match sym_instance, refl_instance with + None, None -> + (Some false, Relation aeq_rel), + (Some true, Relation aeq_rel), + mkApp + ((Lazy.force + coq_equality_morphism_of_asymmetric_areflexive_transitive_relation), + [| a_instance ; aeq_instance ; trans_instance |]), + Lazy.force coq_impl_relation + | None, Some refl_instance -> + (Some false, Relation aeq_rel), + (Some true, Relation aeq_rel), + mkApp + ((Lazy.force + coq_equality_morphism_of_asymmetric_reflexive_transitive_relation), + [| a_instance ; aeq_instance ; refl_instance ; trans_instance |]), + Lazy.force coq_impl_relation + | Some sym_instance, None -> + (None, Relation aeq_rel), + (None, Relation aeq_rel), + mkApp + ((Lazy.force + coq_equality_morphism_of_symmetric_areflexive_transitive_relation), + [| a_instance ; aeq_instance ; sym_instance ; trans_instance |]), + Lazy.force coq_iff_relation + | Some sym_instance, Some refl_instance -> + (None, Relation aeq_rel), + (None, Relation aeq_rel), + mkApp + ((Lazy.force + coq_equality_morphism_of_symmetric_reflexive_transitive_relation), + [| a_instance ; aeq_instance ; refl_instance ; sym_instance ; + trans_instance |]), + Lazy.force coq_iff_relation in + let _ = + Declare.declare_internal_constant mor_name + (DefinitionEntry + {const_entry_body = Sign.it_mkLambda_or_LetIn lemma a_quantifiers_rev; + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = Options.boxed_definitions()}, + IsDefinition Definition) + in + let a_quantifiers_rev = + List.map (fun (n,b,t) -> assert (b = None); n,t) a_quantifiers_rev in + add_morphism None mor_name + (aeq,a_quantifiers_rev,[aeq_rel_class_and_var1; aeq_rel_class_and_var2], + output) + +(* The vernac command "Add Relation ..." *) +let add_relation id a aeq refl sym trans = + int_add_relation id (constr_of a) (constr_of aeq) (option_app constr_of refl) + (option_app constr_of sym) (option_app constr_of trans) + +(************************ Add Setoid ******************************************) + +(* The vernac command "Add Setoid" *) +let add_setoid id a aeq th = + let a = constr_of a in + let aeq = constr_of aeq in + let th = constr_of th in + let env = Global.env () in + let a_quantifiers_rev = check_a env a in + check_eq env a_quantifiers_rev a aeq ; + check_setoid_theory env a_quantifiers_rev a aeq th ; + let a_instance = apply_to_rels a a_quantifiers_rev in + let aeq_instance = apply_to_rels aeq a_quantifiers_rev in + let th_instance = apply_to_rels th a_quantifiers_rev in + let refl = + Sign.it_mkLambda_or_LetIn + (mkApp ((Lazy.force coq_seq_refl), + [| a_instance; aeq_instance; th_instance |])) a_quantifiers_rev in + let sym = + Sign.it_mkLambda_or_LetIn + (mkApp ((Lazy.force coq_seq_sym), + [| a_instance; aeq_instance; th_instance |])) a_quantifiers_rev in + let trans = + Sign.it_mkLambda_or_LetIn + (mkApp ((Lazy.force coq_seq_trans), + [| a_instance; aeq_instance; th_instance |])) a_quantifiers_rev in + int_add_relation id a aeq (Some refl) (Some sym) (Some trans) -let new_named_morphism id m = new_morphism (constr_of m) id morphism_hook (****************************** The tactic itself *******************************) +type direction = + Left2Right + | Right2Left + +let prdirection = + function + Left2Right -> str "->" + | Right2Left -> str "<-" + type constr_with_marks = - | MApp of constr_with_marks array - | Toreplace - | Tokeep - | Mimp of constr_with_marks * constr_with_marks + | MApp of constr * morphism_class * constr_with_marks array * direction + | ToReplace + | ToKeep of constr * relation relation_class * direction let is_to_replace = function - | Tokeep -> false - | Toreplace -> true - | MApp _ -> true - | Mimp _ -> true + | ToKeep _ -> false + | ToReplace -> true + | MApp _ -> true let get_mark a = Array.fold_left (||) false (Array.map is_to_replace a) -let rec mark_occur t in_c = - if (eq_constr t in_c) then Toreplace else +let cic_direction_of_direction = + function + Left2Right -> Lazy.force coq_Left2Right + | Right2Left -> Lazy.force coq_Right2Left + +let opposite_direction = + function + Left2Right -> Right2Left + | Right2Left -> Left2Right + +let direction_of_constr_with_marks hole_direction = + function + MApp (_,_,_,dir) -> cic_direction_of_direction dir + | ToReplace -> hole_direction + | ToKeep (_,_,dir) -> cic_direction_of_direction dir + +type argument = + Toapply of constr (* apply the function to the argument *) + | Toexpand of name * types (* beta-expand the function w.r.t. an argument + of this type *) +let beta_expand c args_rev = + let rec to_expand = + function + [] -> [] + | (Toapply _)::tl -> to_expand tl + | (Toexpand (name,s))::tl -> (name,s)::(to_expand tl) in + let rec aux n = + function + [] -> [] + | (Toapply arg)::tl -> arg::(aux n tl) + | (Toexpand _)::tl -> (mkRel n)::(aux (n + 1) tl) + in + compose_lam (to_expand args_rev) + (mkApp (c, Array.of_list (List.rev (aux 1 args_rev)))) + +exception Optimize (* used to fall-back on the tactic for Leibniz equality *) + +let relation_class_that_matches_a_constr caller_name new_goals hypt = + let (heq, hargs) = decompose_app hypt in + let rec get_all_but_last_two = + function + [] + | [_] -> + errorlabstrm caller_name (pr_lconstr hypt ++ + str " is not a registered relation.") + | [_;_] -> [] + | he::tl -> he::(get_all_but_last_two tl) in + let all_aeq_args = get_all_but_last_two hargs in + let rec find_relation l subst = + let aeq = mkApp (heq,(Array.of_list l)) in + try + let rel = find_relation_class aeq in + match rel,new_goals with + Leibniz _,[] -> + assert (subst = []); + raise Optimize (* let's optimize the proof term size *) + | Leibniz (Some _), _ -> + assert (subst = []); + rel + | Leibniz None, _ -> + (* for well-typedness reasons it should have been catched by the + previous guard in the previous iteration. *) + assert false + | Relation rel,_ -> Relation (apply_to_relation (Array.of_list subst) rel) + with Not_found -> + if l = [] then + errorlabstrm caller_name + (pr_lconstr (mkApp (aeq, Array.of_list all_aeq_args)) ++ + str " is not a registered relation.") + else + let last,others = Util.list_sep_last l in + find_relation others (last::subst) + in + find_relation all_aeq_args [] + +(* rel1 is a subrelation of rel2 whenever + forall x1 x2, rel1 x1 x2 -> rel2 x1 x2 + The Coq part of the tactic, however, needs rel1 == rel2. + Hence the third case commented out. + Note: accepting user-defined subtrelations seems to be the last + useful generalization that does not go against the original spirit of + the tactic. +*) +let subrelation gl rel1 rel2 = + match rel1,rel2 with + Relation {rel_aeq=rel_aeq1}, Relation {rel_aeq=rel_aeq2} -> + Tacmach.pf_conv_x gl rel_aeq1 rel_aeq2 + | Leibniz (Some t1), Leibniz (Some t2) -> + Tacmach.pf_conv_x gl t1 t2 + | Leibniz None, _ + | _, Leibniz None -> assert false +(* This is the commented out case (see comment above) + | Leibniz (Some t1), Relation {rel_a=t2; rel_refl = Some _} -> + Tacmach.pf_conv_x gl t1 t2 +*) + | _,_ -> false + +(* this function returns the list of new goals opened by a constr_with_marks *) +let rec collect_new_goals = + function + MApp (_,_,a,_) -> List.concat (List.map collect_new_goals (Array.to_list a)) + | ToReplace + | ToKeep (_,Leibniz _,_) + | ToKeep (_,Relation {rel_refl=Some _},_) -> [] + | ToKeep (c,Relation {rel_aeq=aeq; rel_refl=None},_) -> [mkApp(aeq,[|c ; c|])] + +(* two marked_constr are equivalent if they produce the same set of new goals *) +let marked_constr_equiv_or_more_complex to_marked_constr gl c1 c2 = + let glc1 = collect_new_goals (to_marked_constr c1) in + let glc2 = collect_new_goals (to_marked_constr c2) in + List.for_all (fun c -> List.exists (fun c' -> pf_conv_x gl c c') glc1) glc2 + +let pr_new_goals i c = + let glc = collect_new_goals c in + str " " ++ int i ++ str ") side conditions:" ++ + (if glc = [] then str " no side conditions" + else + (pr_fnl () ++ str " " ++ + prlist_with_sep (fun () -> str "\n ") + (fun c -> str " ... |- " ++ pr_lconstr c) glc)) + +(* given a list of constr_with_marks, it returns the list where + constr_with_marks than open more goals than simpler ones in the list + are got rid of *) +let elim_duplicates gl to_marked_constr = + let rec aux = + function + [] -> [] + | he:: tl -> + if List.exists + (marked_constr_equiv_or_more_complex to_marked_constr gl he) tl + then aux tl + else he::aux tl + in + aux + +let filter_superset_of_new_goals gl new_goals l = + List.filter + (fun (_,_,c) -> + List.for_all + (fun g -> List.exists (pf_conv_x gl g) (collect_new_goals c)) new_goals) l + +(* given the array of lists [| l1 ; ... ; ln |] it returns the list of arrays + [ c1 ; ... ; cn ] that is the cartesian product of the sets l1, ..., ln *) +let cartesian_product gl a = + let rec aux = + function + [] -> assert false + | [he] -> List.map (fun e -> [e]) he + | he::tl -> + let tl' = aux tl in + List.flatten + (List.map (function e -> List.map (function l -> e :: l) tl') he) + in + List.map Array.of_list + (aux (List.map (elim_duplicates gl identity) (Array.to_list a))) + +let mark_occur gl ~new_goals t in_c input_relation input_direction = + let rec aux output_relation output_direction in_c = + if eq_constr t in_c then + if input_direction = output_direction + && subrelation gl input_relation output_relation then + [ToReplace] + else [] + else match kind_of_term in_c with | App (c,al) -> - let a = Array.map (mark_occur t) al - in if (get_mark a) then (MApp a) else Tokeep + let mors_and_cs_and_als = + let mors_and_cs_and_als = + let morphism_table_find c = + try morphism_table_find c with Not_found -> [] in + let rec aux acc = + function + [] -> + let c' = mkApp (c, Array.of_list acc) in + let al' = [||] in + List.map (fun m -> m,c',al') (morphism_table_find c') + | (he::tl) as l -> + let c' = mkApp (c, Array.of_list acc) in + let al' = Array.of_list l in + let acc' = acc @ [he] in + (List.map (fun m -> m,c',al') (morphism_table_find c')) @ + (aux acc' tl) + in + aux [] (Array.to_list al) in + let mors_and_cs_and_als = + List.map + (function (m,c,al) -> + relation_morphism_of_constr_morphism m, c, al) + mors_and_cs_and_als in + let mors_and_cs_and_als = + List.fold_left + (fun l (m,c,al) -> + match unify_morphism_with_arguments gl (c,al) m t with + Some res -> res::l + | None -> l + ) [] mors_and_cs_and_als + in + List.filter + (fun (mor,_,_) -> subrelation gl mor.output output_relation) + mors_and_cs_and_als + in + (* First we look for well typed morphisms *) + let res_mors = + List.fold_left + (fun res (mor,c,al) -> + let a = + let arguments = Array.of_list mor.args in + let apply_variance_to_direction default_dir = + function + None -> default_dir + | Some true -> output_direction + | Some false -> opposite_direction output_direction + in + Util.array_map2 + (fun a (variance,relation) -> + (aux relation + (apply_variance_to_direction Left2Right variance) a) @ + (aux relation + (apply_variance_to_direction Right2Left variance) a) + ) al arguments + in + let a' = cartesian_product gl a in + (List.map + (function a -> + if not (get_mark a) then + ToKeep (in_c,output_relation,output_direction) + else + MApp (c,ACMorphism mor,a,output_direction)) a') @ res + ) [] mors_and_cs_and_als in + (* Then we look for well typed functions *) + let res_functions = + (* the tactic works only if the function type is + made of non-dependent products only. However, here we + can cheat a bit by partially istantiating c to match + the requirement when the arguments to be replaced are + bound by non-dependent products only. *) + let typeofc = Tacmach.pf_type_of gl c in + let typ = nf_betaiota typeofc in + let rec find_non_dependent_function env c c_args_rev typ f_args_rev + a_rev + = + function + [] -> + if a_rev = [] then + [ToKeep (in_c,output_relation,output_direction)] + else + let a' = + cartesian_product gl (Array.of_list (List.rev a_rev)) + in + List.fold_left + (fun res a -> + if not (get_mark a) then + (ToKeep (in_c,output_relation,output_direction))::res + else + let err = + match output_relation with + Leibniz (Some typ') when pf_conv_x gl typ typ' -> + false + | Leibniz None -> assert false + | _ when output_relation = Lazy.force coq_iff_relation + -> false + | _ -> true + in + if err then res + else + let mor = + ACFunction{f_args=List.rev f_args_rev;f_output=typ} in + let func = beta_expand c c_args_rev in + (MApp (func,mor,a,output_direction))::res + ) [] a' + | (he::tl) as a-> + let typnf = Reduction.whd_betadeltaiota env typ in + match kind_of_term typnf with + Cast (typ,_,_) -> + find_non_dependent_function env c c_args_rev typ + f_args_rev a_rev a + | Prod (name,s,t) -> + let env' = push_rel (name,None,s) env in + let he = + (aux (Leibniz (Some s)) Left2Right he) @ + (aux (Leibniz (Some s)) Right2Left he) in + if he = [] then [] + else + let he0 = List.hd he in + begin + match noccurn 1 t, he0 with + _, ToKeep (arg,_,_) -> + (* invariant: if he0 = ToKeep (t,_,_) then every + element in he is = ToKeep (t,_,_) *) + assert + (List.for_all + (function + ToKeep(arg',_,_) when pf_conv_x gl arg arg' -> + true + | _ -> false) he) ; + (* generic product, to keep *) + find_non_dependent_function + env' c ((Toapply arg)::c_args_rev) + (subst1 arg t) f_args_rev a_rev tl + | true, _ -> + (* non-dependent product, to replace *) + find_non_dependent_function + env' c ((Toexpand (name,s))::c_args_rev) + (lift 1 t) (s::f_args_rev) (he::a_rev) tl + | false, _ -> + (* dependent product, to replace *) + (* This limitation is due to the reflexive + implementation and it is hard to lift *) + errorlabstrm "Setoid_replace" + (str "Cannot rewrite in the argument of a " ++ + str "dependent product. If you need this " ++ + str "feature, please report to the author.") + end + | _ -> assert false + in + find_non_dependent_function (Tacmach.pf_env gl) c [] typ [] [] + (Array.to_list al) + in + elim_duplicates gl identity (res_functions @ res_mors) | Prod (_, c1, c2) -> - if (dependent (mkRel 1) c2) - then Tokeep - else - let c1m = mark_occur t c1 in - let c2m = mark_occur t c2 in - if ((is_to_replace c1m)||(is_to_replace c2m)) - then (Mimp (c1m, c2m)) - else Tokeep - | _ -> Tokeep - -let create_args ca ma bl c1 c2 = - let rec aux i = function - | [] -> [] - | true::q -> - if (is_to_replace ma.(i)) - then (replace_term c1 c2 ca.(i))::ca.(i)::(aux (i+1) q) - else ca.(i)::ca.(i)::(aux (i+1) q) - | false::q -> ca.(i)::(aux (i+1) q) + if (dependent (mkRel 1) c2) + then + errorlabstrm "Setoid_replace" + (str "Cannot rewrite in the type of a variable bound " ++ + str "in a dependent product.") + else + let typeofc1 = Tacmach.pf_type_of gl c1 in + if not (Tacmach.pf_conv_x gl typeofc1 mkProp) then + (* to avoid this error we should introduce an impl relation + whose first argument is Type instead of Prop. However, + the type of the new impl would be Type -> Prop -> Prop + that is no longer a Relation_Definitions.relation. Thus + the Coq part of the tactic should be heavily modified. *) + errorlabstrm "Setoid_replace" + (str "Rewriting in a product A -> B is possible only when A " ++ + str "is a proposition (i.e. A is of type Prop). The type " ++ + pr_lconstr c1 ++ str " has type " ++ pr_lconstr typeofc1 ++ + str " that is not convertible to Prop.") + else + aux output_relation output_direction + (mkApp ((Lazy.force coq_impl), + [| c1 ; subst1 (mkRel 1 (*dummy*)) c2 |])) + | _ -> + if occur_term t in_c then + errorlabstrm "Setoid_replace" + (str "Trying to replace " ++ pr_lconstr t ++ str " in " ++ pr_lconstr in_c ++ + str " that is not an applicative context.") + else + [ToKeep (in_c,output_relation,output_direction)] + in + let aux2 output_relation output_direction = + List.map + (fun res -> output_relation,output_direction,res) + (aux output_relation output_direction in_c) in + let res = + (aux2 (Lazy.force coq_iff_relation) Right2Left) @ + (* This is the case of a proposition of signature A ++> iff or B --> iff *) + (aux2 (Lazy.force coq_iff_relation) Left2Right) @ + (aux2 (Lazy.force coq_impl_relation) Right2Left) in + let res = elim_duplicates gl (function (_,_,t) -> t) res in + let res' = filter_superset_of_new_goals gl new_goals res in + match res' with + [] when res = [] -> + errorlabstrm "Setoid_rewrite" + (str "Either the term " ++ pr_lconstr t ++ str " that must be " ++ + str "rewritten occurs in a covariant position or the goal is not " ++ + str "made of morphism applications only. You can replace only " ++ + str "occurrences that are in a contravariant position and such that " ++ + str "the context obtained by abstracting them is made of morphism " ++ + str "applications only.") + | [] -> + errorlabstrm "Setoid_rewrite" + (str "No generated set of side conditions is a superset of those " ++ + str "requested by the user. The generated sets of side conditions " ++ + str "are: " ++ + pr_fnl () ++ + prlist_with_sepi pr_fnl + (fun i (_,_,mc) -> pr_new_goals i mc) res) + | [he] -> he + | he::_ -> + ppnl + (str "Warning: The application of the tactic is subject to one of " ++ + str "the \nfollowing set of side conditions that the user needs " ++ + str "to prove:" ++ + pr_fnl () ++ + prlist_with_sepi pr_fnl + (fun i (_,_,mc) -> pr_new_goals i mc) res' ++ pr_fnl () ++ + str "The first set is randomly chosen. Use the syntax " ++ + str "\"setoid_rewrite ... generate side conditions ...\" to choose " ++ + str "a different set.") ; + he + +let cic_morphism_context_list_of_list hole_relation hole_direction out_direction += + let check = + function + (None,dir,dir') -> + mkApp ((Lazy.force coq_MSNone), [| dir ; dir' |]) + | (Some true,dir,dir') -> + assert (dir = dir'); + mkApp ((Lazy.force coq_MSCovariant), [| dir |]) + | (Some false,dir,dir') -> + assert (dir <> dir'); + mkApp ((Lazy.force coq_MSContravariant), [| dir |]) in + let rec aux = + function + [] -> assert false + | [(variance,out),(value,direction)] -> + mkApp ((Lazy.force coq_singl), [| Lazy.force coq_Argument_Class ; out |]), + mkApp ((Lazy.force coq_fcl_singl), + [| hole_relation; hole_direction ; out ; + direction ; out_direction ; + check (variance,direction,out_direction) ; value |]) + | ((variance,out),(value,direction))::tl -> + let outtl, valuetl = aux tl in + mkApp ((Lazy.force coq_cons), + [| Lazy.force coq_Argument_Class ; out ; outtl |]), + mkApp ((Lazy.force coq_fcl_cons), + [| hole_relation ; hole_direction ; out ; outtl ; + direction ; out_direction ; + check (variance,direction,out_direction) ; + value ; valuetl |]) + in aux + +let rec cic_type_nelist_of_list = + function + [] -> assert false + | [value] -> + mkApp ((Lazy.force coq_singl), [| mkType (Termops.new_univ ()) ; value |]) + | value::tl -> + mkApp ((Lazy.force coq_cons), + [| mkType (Termops.new_univ ()); value; cic_type_nelist_of_list tl |]) + +let syntactic_but_representation_of_marked_but hole_relation hole_direction = + let rec aux out (rel_out,precise_out,is_reflexive) = + function + MApp (f, m, args, direction) -> + let direction = cic_direction_of_direction direction in + let morphism_theory, relations = + match m with + ACMorphism { args = args ; morphism_theory = morphism_theory } -> + morphism_theory,args + | ACFunction { f_args = f_args ; f_output = f_output } -> + let mt = + if eq_constr out (cic_relation_class_of_relation_class + (Lazy.force coq_iff_relation)) + then + mkApp ((Lazy.force coq_morphism_theory_of_predicate), + [| cic_type_nelist_of_list f_args; f|]) + else + mkApp ((Lazy.force coq_morphism_theory_of_function), + [| cic_type_nelist_of_list f_args; f_output; f|]) + in + mt,List.map (fun x -> None,Leibniz (Some x)) f_args in + let cic_relations = + List.map + (fun (variance,r) -> + variance, + r, + cic_relation_class_of_relation_class r, + cic_precise_relation_class_of_relation_class r + ) relations in + let cic_args_relations,argst = + cic_morphism_context_list_of_list hole_relation hole_direction direction + (List.map2 + (fun (variance,trel,t,precise_t) v -> + (variance,cic_argument_class_of_argument_class (variance,trel)), + (aux t precise_t v, + direction_of_constr_with_marks hole_direction v) + ) cic_relations (Array.to_list args)) + in + mkApp ((Lazy.force coq_App), + [|hole_relation ; hole_direction ; + cic_args_relations ; out ; direction ; + morphism_theory ; argst|]) + | ToReplace -> + mkApp ((Lazy.force coq_ToReplace), [| hole_relation ; hole_direction |]) + | ToKeep (c,_,direction) -> + let direction = cic_direction_of_direction direction in + if is_reflexive then + mkApp ((Lazy.force coq_ToKeep), + [| hole_relation ; hole_direction ; precise_out ; direction ; c |]) + else + let c_is_proper = + let typ = mkApp (rel_out, [| c ; c |]) in + mkCast (Evarutil.mk_new_meta (),DEFAULTcast, typ) + in + mkApp ((Lazy.force coq_ProperElementToKeep), + [| hole_relation ; hole_direction; precise_out ; + direction; c ; c_is_proper |]) + in aux + +let apply_coq_setoid_rewrite hole_relation prop_relation c1 c2 (direction,h) + prop_direction m += + let hole_relation = cic_relation_class_of_relation_class hole_relation in + let hyp,hole_direction = h,cic_direction_of_direction direction in + let cic_prop_relation = cic_relation_class_of_relation_class prop_relation in + let precise_prop_relation = + cic_precise_relation_class_of_relation_class prop_relation + in + mkApp ((Lazy.force coq_setoid_rewrite), + [| hole_relation ; hole_direction ; cic_prop_relation ; + prop_direction ; c1 ; c2 ; + syntactic_but_representation_of_marked_but hole_relation hole_direction + cic_prop_relation precise_prop_relation m ; hyp |]) + +let check_evar_map_of_evars_defs evd = + let metas = Evd.meta_list evd in + let check_freemetas_is_empty rebus = + Evd.Metaset.iter + (fun m -> + if Evd.meta_defined evd m then () else + raise (Logic.RefinerError (Logic.OccurMetaGoal rebus))) + in + List.iter + (fun (_,binding) -> + match binding with + Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) -> + check_freemetas_is_empty rebus freemetas + | Evd.Clval (_,{Evd.rebus=rebus1; Evd.freemetas=freemetas1}, + {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) -> + check_freemetas_is_empty rebus1 freemetas1 ; + check_freemetas_is_empty rebus2 freemetas2 + ) metas + +(* For a correct meta-aware "rewrite in", we split unification + apart from the actual rewriting (Pierre L, 05/04/06) *) + +(* [unification_rewrite] searchs a match for [c1] in [but] and then + returns the modified objects (in particular [c1] and [c2]) *) + +let unification_rewrite c1 c2 cl but gl = + let (env',c1) = + try + (* ~mod_delta:false to allow to mark occurences that must not be + rewritten simply by replacing them with let-defined definitions + in the context *) + w_unify_to_subterm ~mod_delta:false (pf_env gl) (c1,but) cl.env + with + Pretype_errors.PretypeError _ -> + (* ~mod_delta:true to make Ring work (since it really + exploits conversion) *) + w_unify_to_subterm ~mod_delta:true (pf_env gl) (c1,but) cl.env in - aux 0 bl - - -let res_tac c a hyp = - let sa = setoid_table_find a in - let fin = match hyp with - | None -> Auto.full_trivial - | Some h -> - tclORELSE (tclTHEN (tclTRY (apply h)) (tclFAIL 0 "")) - (tclORELSE (tclTHEN (tclTRY (tclTHEN (apply (mkApp ((Lazy.force coq_seq_sym), [|sa.set_a; sa.set_aeq; sa.set_th|]))) (apply h))) (tclFAIL 0 "")) - Auto.full_trivial) in - tclORELSE (tclTHEN (tclTRY (apply (mkApp ((Lazy.force coq_seq_refl), [|sa.set_a; sa.set_aeq; sa.set_th;c|])))) (tclFAIL 0 "")) - (tclORELSE assumption - (tclORELSE (tclTHEN (tclTRY (apply (mkApp ((Lazy.force coq_seq_sym), [|sa.set_a; sa.set_aeq; sa.set_th|])))) assumption) - fin)) - -let id_res_tac c a = - let sa = setoid_table_find a in - (tclTRY (apply (mkApp ((Lazy.force coq_seq_refl), [|sa.set_a; sa.set_aeq; sa.set_th; c|])))) - -(* An exception to catchs errors *) - -exception Nothing_found of constr;; - -let rec create_tac_list i a al c1 c2 hyp args_t = function - | [] -> [] - | false::q -> create_tac_list (i+1) a al c1 c2 hyp args_t q - | true::q -> - if (is_to_replace a.(i)) - then (zapply false al.(i) a.(i) c1 c2 hyp)::(create_tac_list (i+1) a al c1 c2 hyp args_t q) - else (id_res_tac al.(i) (List.nth args_t i))::(create_tac_list (i+1) a al c1 c2 hyp args_t q) -(* else tclIDTAC::(create_tac_list (i+1) a al c1 c2 hyp q) *) - -and zapply is_r gl gl_m c1 c2 hyp glll = (match ((kind_of_term gl), gl_m) with - | ((App (c,al)),(MApp a)) -> ( - try - let m = morphism_table_find c in - let args = Array.of_list (create_args al a m.profil c1 c2) in - if is_r - then tclTHENS (apply (mkApp (m.lem, args))) - ((create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)@[tclIDTAC]) - else (match m.lem2 with - | None -> - tclTHENS (apply (mkApp (m.lem, args))) (create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil) - | Some xom -> - tclTHENS (apply (mkApp (xom, args))) (create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)) - with Not_found -> errorlabstrm "Setoid_replace" - (str "The term " ++ prterm c ++ str " has not been declared as a morphism")) - | ((Prod (_,hh, cc)),(Mimp (hhm, ccm))) -> - let al = [|hh; cc|] in - let a = [|hhm; ccm|] in - let fleche_constr = (Lazy.force coq_fleche) in - let fleche_cp = destConst fleche_constr in - let new_concl = (mkApp (fleche_constr, al)) in - if is_r - then - let m = morphism_table_find fleche_constr in - let args = Array.of_list (create_args al a m.profil c1 c2) in - tclTHEN (change_in_concl None new_concl) - (tclTHENS (apply (mkApp (m.lem, args))) - ((create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)@[unfold_constr (ConstRef fleche_cp)])) -(* ((create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)@[tclIDTAC])) *) - else (zapply is_r new_concl (MApp a) c1 c2 hyp) -(* let args = Array.of_list (create_args [|hh; cc|] [|hhm; ccm|] [true;true] c1 c2) in - if is_r - then tclTHENS (apply (mkApp ((Lazy.force coq_fleche_ext), args))) - ((create_tac_list 0 [|hhm; ccm|] [|hh; cc|] c1 c2 hyp [mkProp; mkProp] [true;true])@[tclIDTAC]) - else tclTHENS (apply (mkApp ((Lazy.force coq_fleche_ext2), args))) - ((create_tac_list 0 [|hhm; ccm|] [|hh; cc|] c1 c2 hyp [mkProp; mkProp] [true;true])@[tclIDTAC]) -*) - | (_, Toreplace) -> - if is_r - then (match hyp with - | None -> errorlabstrm "Setoid_replace" - (str "You should use the tactic Replace here") - | Some h -> - let hypt = pf_type_of glll h in - let (heq, hargs) = decompose_app hypt in - let rec get_last_two = function - | [c1;c2] -> (c1, c2) - | x::y::z -> get_last_two (y::z) - | _ -> assert false in - let (hc1,hc2) = get_last_two hargs in - if c1 = hc1 - then - apply (mkApp (Lazy.force coqproj2,[|(mkArrow hc1 hc2);(mkArrow hc2 hc1);h|])) - else - apply (mkApp (Lazy.force coqproj1,[|(mkArrow hc1 hc2);(mkArrow hc2 hc1);h|])) - ) - else (res_tac gl (pf_type_of glll gl) hyp) (* tclORELSE Auto.full_trivial tclIDTAC *) - | (_, Tokeep) -> (match hyp with - | None -> errorlabstrm "Setoid_replace" - (str "No replacable occurence of " ++ prterm c1 ++ str " found") - | Some _ ->errorlabstrm "Setoid_replace" - (str "No rewritable occurence of " ++ prterm c1 ++ str " found")) - | _ -> anomaly ("Bug in Setoid_replace")) glll - -let setoid_replace c1 c2 hyp gl = - let but = (pf_concl gl) in - (zapply true but (mark_occur c1 but) c1 c2 hyp) gl - -let general_s_rewrite lft2rgt c gl = - let ctype = pf_type_of gl c in - let (equiv, args) = decompose_app ctype in - let rec get_last_two = function - | [c1;c2] -> (c1, c2) - | x::y::z -> get_last_two (y::z) - | _ -> error "The term provided is not an equivalence" in - let (c1,c2) = get_last_two args in - if lft2rgt - then setoid_replace c1 c2 (Some c) gl - else setoid_replace c2 c1 (Some c) gl - -let setoid_rewriteLR = general_s_rewrite true - -let setoid_rewriteRL = general_s_rewrite false + let cl' = {cl with env = env' } in + let c2 = Clenv.clenv_nf_meta cl' c2 in + check_evar_map_of_evars_defs env' ; + env',Clenv.clenv_value cl', c1, c2 + +(* no unification is performed in this function. [sigma] is the + substitution obtained from an earlier unification. *) + +let relation_rewrite_no_unif c1 c2 hyp ~new_goals sigma gl = + let but = pf_concl gl in + try + let input_relation = + relation_class_that_matches_a_constr "Setoid_rewrite" + new_goals (Typing.mtype_of (pf_env gl) sigma (snd hyp)) in + let output_relation,output_direction,marked_but = + mark_occur gl ~new_goals c1 but input_relation (fst hyp) in + let cic_output_direction = cic_direction_of_direction output_direction in + let if_output_relation_is_iff gl = + let th = + apply_coq_setoid_rewrite input_relation output_relation c1 c2 hyp + cic_output_direction marked_but + in + let new_but = Termops.replace_term c1 c2 but in + let hyp1,hyp2,proj = + match output_direction with + Right2Left -> new_but, but, Lazy.force coq_proj1 + | Left2Right -> but, new_but, Lazy.force coq_proj2 + in + let impl1 = mkProd (Anonymous, hyp2, lift 1 hyp1) in + let impl2 = mkProd (Anonymous, hyp1, lift 1 hyp2) in + let th' = mkApp (proj, [|impl2; impl1; th|]) in + Tactics.refine + (mkApp (th',[|mkCast (Evarutil.mk_new_meta(), DEFAULTcast, new_but)|])) + gl in + let if_output_relation_is_if gl = + let th = + apply_coq_setoid_rewrite input_relation output_relation c1 c2 hyp + cic_output_direction marked_but + in + let new_but = Termops.replace_term c1 c2 but in + Tactics.refine + (mkApp (th, [|mkCast (Evarutil.mk_new_meta(), DEFAULTcast, new_but)|])) + gl in + if output_relation = (Lazy.force coq_iff_relation) then + if_output_relation_is_iff gl + else + if_output_relation_is_if gl + with + Optimize -> + !general_rewrite (fst hyp = Left2Right) (snd hyp) gl + +let relation_rewrite c1 c2 (input_direction,cl) ~new_goals gl = + let (sigma,cl,c1,c2) = unification_rewrite c1 c2 cl (pf_concl gl) gl in + relation_rewrite_no_unif c1 c2 (input_direction,cl) ~new_goals sigma gl + +let analyse_hypothesis gl c = + let ctype = pf_type_of gl c in + let eqclause = Clenv.make_clenv_binding gl (c,ctype) Rawterm.NoBindings in + let (equiv, args) = decompose_app (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 + | _ -> error "The term provided is not an equivalence" in + let others,(c1,c2) = split_last_two args in + eqclause,mkApp (equiv, Array.of_list others),c1,c2 + +let general_s_rewrite lft2rgt c ~new_goals gl = + let eqclause,_,c1,c2 = analyse_hypothesis gl c in + if lft2rgt then + relation_rewrite c1 c2 (Left2Right,eqclause) ~new_goals gl + else + relation_rewrite c2 c1 (Right2Left,eqclause) ~new_goals gl + +let relation_rewrite_in id c1 c2 (direction,eqclause) ~new_goals gl = + let hyp = pf_type_of gl (mkVar id) in + (* first, we find a match for c1 in the hyp *) + let (sigma,cl,c1,c2) = unification_rewrite c1 c2 eqclause hyp gl in + (* since we will actually rewrite in the opposite direction, we also need + to replace every occurrence of c2 (resp. c1) in hyp with something that + is convertible but not syntactically equal. To this aim we introduce a + let-in and then we will use the intro tactic to get rid of it *) + let let_in_abstract t in_t = + let t' = lift 1 t in + let in_t' = lift 1 in_t in + mkLetIn (Anonymous,t,pf_type_of gl t,subst_term t' in_t') in + let mangled_new_hyp = Termops.replace_term c1 c2 (let_in_abstract c2 hyp) in + let new_hyp = Termops.replace_term c1 c2 hyp in + let oppdir = opposite_direction direction in + cut_replacing id new_hyp + (tclTHENLAST + (tclTHEN (change_in_concl None mangled_new_hyp) + (tclTHEN intro + (relation_rewrite_no_unif c2 c1 (oppdir,cl) ~new_goals sigma)))) + gl + +let general_s_rewrite_in id lft2rgt c ~new_goals gl = + let eqclause,_,c1,c2 = analyse_hypothesis gl c in + if lft2rgt then + relation_rewrite_in id c1 c2 (Left2Right,eqclause) ~new_goals gl + else + relation_rewrite_in id c2 c1 (Right2Left,eqclause) ~new_goals gl + +let setoid_replace relation c1 c2 ~new_goals gl = + try + let relation = + match relation with + Some rel -> + (try + match find_relation_class rel with + Relation sa -> sa + | Leibniz _ -> raise Optimize + with + Not_found -> + errorlabstrm "Setoid_rewrite" + (pr_lconstr rel ++ str " is not a registered relation.")) + | None -> + match default_relation_for_carrier (pf_type_of gl c1) with + Relation sa -> sa + | Leibniz _ -> raise Optimize + in + let eq_left_to_right = mkApp (relation.rel_aeq, [| c1 ; c2 |]) in + let eq_right_to_left = mkApp (relation.rel_aeq, [| c2 ; c1 |]) in + let replace dir eq = + tclTHENS (assert_tac false Anonymous eq) + [onLastHyp (fun id -> + tclTHEN + (general_s_rewrite dir (mkVar id) ~new_goals) + (clear [id])); + Tacticals.tclIDTAC] + in + tclORELSE + (replace true eq_left_to_right) (replace false eq_right_to_left) gl + with + Optimize -> (!replace c1 c2) gl + +let setoid_replace_in id relation c1 c2 ~new_goals gl = + let hyp = pf_type_of gl (mkVar id) in + let new_hyp = Termops.replace_term c1 c2 hyp in + cut_replacing id new_hyp + (fun exact -> tclTHENLASTn + (setoid_replace relation c2 c1 ~new_goals) + [| exact; tclIDTAC |]) gl + +(* [setoid_]{reflexivity,symmetry,transitivity} tactics *) + +let setoid_reflexivity gl = + try + let relation_class = + relation_class_that_matches_a_constr "Setoid_reflexivity" + [] (pf_concl gl) in + match relation_class with + Leibniz _ -> assert false (* since [] is empty *) + | Relation rel -> + match rel.rel_refl with + None -> + errorlabstrm "Setoid_reflexivity" + (str "The relation " ++ prrelation rel ++ str " is not reflexive.") + | Some refl -> apply refl gl + with + Optimize -> reflexivity gl + +let setoid_symmetry gl = + try + let relation_class = + relation_class_that_matches_a_constr "Setoid_symmetry" + [] (pf_concl gl) in + match relation_class with + Leibniz _ -> assert false (* since [] is empty *) + | Relation rel -> + match rel.rel_sym with + None -> + errorlabstrm "Setoid_symmetry" + (str "The relation " ++ prrelation rel ++ str " is not symmetric.") + | Some sym -> apply sym gl + with + Optimize -> symmetry gl + +let setoid_symmetry_in id gl = + let new_hyp = + let _,he,c1,c2 = analyse_hypothesis gl (mkVar id) in + mkApp (he, [| c2 ; c1 |]) + in + cut_replacing id new_hyp (tclTHEN setoid_symmetry) gl + +let setoid_transitivity c gl = + try + let relation_class = + relation_class_that_matches_a_constr "Setoid_transitivity" + [] (pf_concl gl) in + match relation_class with + Leibniz _ -> assert false (* since [] is empty *) + | Relation rel -> + let ctyp = pf_type_of gl c in + let rel' = unify_relation_carrier_with_type (pf_env gl) rel ctyp in + match rel'.rel_trans with + None -> + errorlabstrm "Setoid_transitivity" + (str "The relation " ++ prrelation rel ++ str " is not transitive.") + | Some trans -> + let transty = nf_betaiota (pf_type_of gl trans) in + let argsrev, _ = + Reductionops.decomp_n_prod (pf_env gl) Evd.empty 2 transty in + let binder = + match List.rev argsrev with + _::(Name n2,None,_)::_ -> Rawterm.NamedHyp n2 + | _ -> assert false + in + apply_with_bindings + (trans, Rawterm.ExplicitBindings [ dummy_loc, binder, c ]) gl + with + Optimize -> transitivity c gl +;; + +Tactics.register_setoid_reflexivity setoid_reflexivity;; +Tactics.register_setoid_symmetry setoid_symmetry;; +Tactics.register_setoid_symmetry_in setoid_symmetry_in;; +Tactics.register_setoid_transitivity setoid_transitivity;; diff --git a/tactics/setoid_replace.mli b/tactics/setoid_replace.mli index 854fa478..5dc691a9 100644 --- a/tactics/setoid_replace.mli +++ b/tactics/setoid_replace.mli @@ -6,22 +6,72 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: setoid_replace.mli,v 1.3.6.2 2005/01/21 17:14:11 herbelin Exp $ i*) +(*i $Id: setoid_replace.mli 6621 2005-01-21 17:24:37Z herbelin $ i*) open Term open Proof_type open Topconstr +open Names + +type relation = + { rel_a: constr ; + rel_aeq: constr; + rel_refl: constr option; + rel_sym: constr option; + rel_trans : constr option; + rel_quantifiers_no: int (* it helps unification *); + rel_X_relation_class: constr; + rel_Xreflexive_relation_class: constr + } + +type 'a relation_class = + Relation of 'a (* the [rel_aeq] of the relation or the relation*) + | Leibniz of constr option (* the [carrier] (if [eq] is partially instantiated)*) + +type 'a morphism = + { args : (bool option * 'a relation_class) list; + output : 'a relation_class; + lem : constr; + morphism_theory : constr + } + +type morphism_signature = (bool option * constr_expr) list * constr_expr + +val pr_morphism_signature : morphism_signature -> Pp.std_ppcmds + +val register_replace : (constr -> constr -> tactic) -> unit +val register_general_rewrite : (bool -> constr -> tactic) -> unit + +val print_setoids : unit -> unit val equiv_list : unit -> constr list +val default_relation_for_carrier : + ?filter:(relation -> bool) -> types -> relation relation_class +(* [default_morphism] raises [Not_found] *) +val default_morphism : + ?filter:(constr morphism -> bool) -> constr -> relation morphism -val setoid_replace : constr -> constr -> constr option -> tactic +val setoid_replace : + constr option -> constr -> constr -> new_goals:constr list -> tactic +val setoid_replace_in : + identifier -> constr option -> constr -> constr -> new_goals:constr list -> + tactic -val setoid_rewriteLR : constr -> tactic +val general_s_rewrite : bool -> constr -> new_goals:constr list -> tactic +val general_s_rewrite_in : + identifier -> bool -> constr -> new_goals:constr list -> tactic -val setoid_rewriteRL : constr -> tactic +val setoid_reflexivity : tactic +val setoid_symmetry : tactic +val setoid_symmetry_in : identifier -> tactic +val setoid_transitivity : constr -> tactic -val general_s_rewrite : bool -> constr -> tactic +val add_relation : + Names.identifier -> constr_expr -> constr_expr -> constr_expr option -> + constr_expr option -> constr_expr option -> unit -val add_setoid : constr_expr -> constr_expr -> constr_expr -> unit +val add_setoid : + Names.identifier -> constr_expr -> constr_expr -> constr_expr -> unit -val new_named_morphism : Names.identifier -> constr_expr -> unit +val new_named_morphism : + Names.identifier -> constr_expr -> morphism_signature option -> unit diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 245b5a5b..e2487c4e 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacinterp.ml,v 1.84.2.11 2005/11/04 09:01:27 herbelin Exp $ *) +(* $Id: tacinterp.ml 8654 2006-03-22 15:36:58Z msozeau $ *) open Constrintern open Closure @@ -32,7 +32,6 @@ open Refiner open Tacmach open Tactic_debug open Topconstr -open Ast open Term open Termops open Tacexpr @@ -41,11 +40,12 @@ open Typing open Hiddentac open Genarg open Decl_kinds - -let strip_meta id = (* For Grammar v7 compatibility *) - let s = string_of_id id in - if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1)) - else id +open Mod_subst +open Printer +open Inductiveops +open Syntax_def +open Pretyping +open Pretyping.Default let error_syntactic_metavariables_not_allowed loc = user_err_loc @@ -115,8 +115,8 @@ let pr_value env = function | VVoid -> str "()" | VInteger n -> int n | VIntroPattern ipat -> pr_intro_pattern ipat - | VConstr c -> Printer.prterm_env env c - | VConstr_context c -> Printer.prterm_env env c + | VConstr c -> pr_lconstr_env env c + | VConstr_context c -> pr_lconstr_env env c | (VTactic _ | VRTactic _ | VFun _ | VRec _) -> str "" (* Transforms a named_context into a (string * constr) list *) @@ -126,7 +126,7 @@ let make_hyps = List.map (fun (id,_,typ) -> (id, typ)) let constr_of_id env id = construct_reference (Environ.named_context env) id -(* To embed several objects in Coqast.t *) +(* To embed tactics *) let ((tactic_in : (interp_sign -> raw_tactic_expr) -> Dyn.t), (tactic_out : Dyn.t -> (interp_sign -> raw_tactic_expr))) = create "tactic" @@ -155,42 +155,18 @@ let valueOut = function | ast -> anomalylabstrm "valueOut" (str "Not a Dynamic ast: ") -(* To embed constr in Coqast.t *) -let constrIn t = CDynamic (dummy_loc,Pretyping.constr_in t) +(* To embed constr *) +let constrIn t = CDynamic (dummy_loc,constr_in t) let constrOut = function | CDynamic (_,d) -> if (Dyn.tag d) = "constr" then - Pretyping.constr_out d + constr_out d else anomalylabstrm "constrOut" (str "Dynamic tag should be constr") | ast -> anomalylabstrm "constrOut" (str "Not a Dynamic ast") -let loc = dummy_loc - -(* Table of interpretation functions *) -let interp_tab = - (Hashtbl.create 17 : (string , interp_sign -> Coqast.t -> value) Hashtbl.t) -(* Adds an interpretation function *) -let interp_add (ast_typ,interp_fun) = - try - Hashtbl.add interp_tab ast_typ interp_fun - with - Failure _ -> - errorlabstrm "interp_add" - (str "Cannot add the interpretation function for " ++ str ast_typ ++ str " twice") - -(* Adds a possible existing interpretation function *) -let overwriting_interp_add (ast_typ,interp_fun) = - if Hashtbl.mem interp_tab ast_typ then - begin - Hashtbl.remove interp_tab ast_typ; - warning ("Overwriting definition of tactic interpreter command " ^ ast_typ) - end; - Hashtbl.add interp_tab ast_typ interp_fun - -(* Finds the interpretation function corresponding to a given ast type *) -let look_for_interp = Hashtbl.find interp_tab +let loc = dummy_loc (* Globalizes the identifier *) @@ -203,7 +179,7 @@ let find_reference env qid = let coerce_to_reference env = function | VConstr c -> - (try reference_of_constr c + (try global_of_constr c with Not_found -> invalid_arg_loc (loc, "Not a reference")) | v -> errorlabstrm "coerce_to_reference" (str "The value" ++ spc () ++ pr_value env v ++ @@ -220,7 +196,7 @@ let coerce_to_evaluable_ref env c = | VConstr c when isConst c -> EvalConstRef (destConst c) | VConstr c when isVar c -> EvalVarRef (destVar c) | VIntroPattern (IntroIdentifier id) - when Environ.evaluable_named id env -> EvalVarRef id + when Environ.evaluable_named id env -> EvalVarRef id | _ -> error_not_evaluable (pr_value env c) in if not (Tacred.is_evaluable env ev) then @@ -232,10 +208,10 @@ let coerce_to_inductive = function | x -> try let r = match x with - | VConstr c -> reference_of_constr c + | VConstr c -> global_of_constr c | _ -> failwith "" in errorlabstrm "coerce_to_inductive" - (Printer.pr_global r ++ str " is not an inductive type") + (pr_global r ++ str " is not an inductive type") with _ -> errorlabstrm "coerce_to_inductive" (str "Found an argument which should be an inductive type") @@ -244,14 +220,12 @@ let coerce_to_inductive = function (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) let atomic_mactab = ref Idmap.empty let add_primitive_tactic s tac = - (if not !Options.v7 then - let id = id_of_string s in - atomic_mactab := Idmap.add id tac !atomic_mactab) + let id = id_of_string s in + atomic_mactab := Idmap.add id tac !atomic_mactab let _ = - if not !Options.v7 then - (let nocl = {onhyps=Some[];onconcl=true; concl_occs=[]} in - List.iter + let nocl = {onhyps=Some[];onconcl=true; concl_occs=[]} in + List.iter (fun (s,t) -> add_primitive_tactic s (TacAtom(dummy_loc,t))) [ "red", TacReduce(Red false,nocl); "hnf", TacReduce(Hnf,nocl); @@ -261,8 +235,8 @@ let _ = "intros", TacIntroPattern []; "assumption", TacAssumption; "cofix", TacCofix None; - "trivial", TacTrivial None; - "auto", TacAuto(None,None); + "trivial", TacTrivial ([],None); + "auto", TacAuto(None,[],None); "left", TacLeft NoBindings; "right", TacRight NoBindings; "split", TacSplit(false,NoBindings); @@ -270,12 +244,12 @@ let _ = "reflexivity", TacReflexivity; "symmetry", TacSymmetry nocl ]; - List.iter + List.iter (fun (s,t) -> add_primitive_tactic s t) - [ "idtac",TacId ""; - "fail", TacFail(ArgArg 0,""); + [ "idtac",TacId []; + "fail", TacFail(ArgArg 0,[]); "fresh", TacArg(TacFreshId None) - ]) + ] let lookup_atomic id = Idmap.find id !atomic_mactab let is_atomic id = Idmap.mem id !atomic_mactab @@ -312,7 +286,7 @@ type interp_genarg_type = (glob_sign -> raw_generic_argument -> glob_generic_argument) * (interp_sign -> goal sigma -> glob_generic_argument -> closed_generic_argument) * - (Names.substitution -> glob_generic_argument -> glob_generic_argument) + (substitution -> glob_generic_argument -> glob_generic_argument) let extragenargtab = ref (Gmap.empty : (string,interp_genarg_type) Gmap.t) @@ -326,10 +300,12 @@ let lookup_genarg_glob id = let (f,_,_) = lookup_genarg id in f let lookup_interp_genarg id = let (_,f,_) = lookup_genarg id in f let lookup_genarg_subst id = let (_,_,f) = lookup_genarg id in f -(* Unboxes VRec *) -let unrec = function +(* Dynamically check that an argument is a tactic, possibly unboxing VRec *) +let coerce_to_tactic loc id = function | VRec v -> !v - | a -> a + | VTactic _ | VFun _ | VRTactic _ as a -> a + | _ -> user_err_loc + (loc, "", str "variable " ++ pr_id id ++ str " should be bound to a tactic") (*****************) (* Globalization *) @@ -381,7 +357,6 @@ let adjust_loc loc = if !strict_check then dummy_loc else loc (* Globalize a name which must be bound -- actually just check it is bound *) let intern_hyp ist (loc,id as locid) = - let (_,env) = get_current_context () in if not !strict_check then locid else if find_ident id ist then @@ -392,28 +367,18 @@ let intern_hyp ist (loc,id as locid) = let intern_hyp_or_metaid ist id = intern_hyp ist (skip_metaid id) let intern_int_or_var ist = function - | ArgVar locid as x -> ArgVar (intern_hyp ist locid) + | ArgVar locid -> ArgVar (intern_hyp ist locid) | ArgArg n as x -> x let intern_inductive ist = function | Ident (loc,id) when find_var id ist -> ArgVar (loc,id) | r -> ArgArg (Nametab.global_inductive r) -exception NotSyntacticRef - -let locate_reference qid = - match Nametab.extended_locate qid with - | TrueGlobal ref -> ref - | SyntacticDef kn -> - match Syntax_def.search_syntactic_definition loc kn with - | Rawterm.RRef (_,ref) -> ref - | _ -> raise NotSyntacticRef - let intern_global_reference ist = function - | Ident (loc,id) as r when find_var id ist -> ArgVar (loc,id) + | Ident (loc,id) when find_var id ist -> ArgVar (loc,id) | r -> let loc,qid = qualid_of_reference r in - try ArgArg (loc,locate_reference qid) + try ArgArg (loc,locate_global qid) with _ -> error_global_not_found_loc loc qid @@ -438,13 +403,12 @@ let intern_constr_reference strict ist = function RVar (loc,id), None | r -> let loc,qid = qualid_of_reference r in - RRef (loc,locate_reference qid), if strict then None else Some (CRef r) + RRef (loc,locate_global qid), if strict then None else Some (CRef r) let intern_reference strict ist r = (try Reference (intern_tac_ref ist r) with Not_found -> - (try - ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) + (try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) with Not_found -> (match r with | Ident (loc,id) when is_atomic id -> Tacexp (lookup_atomic id) @@ -453,13 +417,18 @@ let intern_reference strict ist r = let (loc,qid) = qualid_of_reference r in error_global_not_found_loc loc qid))) +let intern_message_token ist = function + | (MsgString _ | MsgInt _ as x) -> x + | MsgIdent id -> MsgIdent (intern_hyp_or_metaid ist id) + +let intern_message ist = List.map (intern_message_token ist) + let rec intern_intro_pattern lf ist = function | IntroOrAndPattern l -> IntroOrAndPattern (intern_case_intro_pattern lf ist l) - | IntroWildcard -> - IntroWildcard | IntroIdentifier id -> IntroIdentifier (intern_ident lf ist id) + | IntroWildcard | IntroAnonymous as x -> x and intern_case_intro_pattern lf ist = List.map (List.map (intern_intro_pattern lf ist)) @@ -469,19 +438,16 @@ let intern_quantified_hypothesis ist x = statically check the existence of a quantified hyp); thus nothing to do *) x -let intern_constr {ltacvars=lfun; gsigma=sigma; genv=env} c = +let intern_constr_gen isarity {ltacvars=lfun; gsigma=sigma; genv=env} c = let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in let c' = - warn (Constrintern.interp_rawconstr_gen false sigma env - false (fst lfun,[])) c in - begin if Options.do_translate () then try - (* Try to infer old case and type annotations *) - let _ = Pretyping.understand_gen_tcc sigma env [] None c' in - (* msgerrnl (str "Typage tactique OK");*) - () - with e -> (*msgerrnl (str "Warning: can't type tactic");*) () end; + warn (Constrintern.intern_gen isarity ~ltacvars:(fst lfun,[]) sigma env) c + in (c',if !strict_check then None else Some c) +let intern_constr = intern_constr_gen false +let intern_type = intern_constr_gen true + (* Globalize bindings *) let intern_binding ist (loc,b,c) = (loc,intern_quantified_hypothesis ist b,intern_constr ist c) @@ -504,7 +470,7 @@ let intern_clause_pattern ist (l,occl) = let intern_induction_arg ist = function | ElimOnConstr c -> ElimOnConstr (intern_constr ist c) | ElimOnAnonHyp n as x -> x - | ElimOnIdent (loc,id) as x -> + | ElimOnIdent (loc,id) -> if !strict_check then (* If in a defined tactic, no intros-until *) ElimOnConstr (intern_constr ist (CRef (Ident (dummy_loc,id)))) @@ -513,14 +479,14 @@ let intern_induction_arg ist = function (* Globalizes a reduction expression *) let intern_evaluable ist = function - | Ident (loc,id) as r when find_ltacvar id ist -> ArgVar (loc,id) + | Ident (loc,id) when find_ltacvar id ist -> ArgVar (loc,id) | Ident (_,id) when (not !strict_check & find_hyp id ist) or find_ctxvar id ist -> ArgArg (EvalVarRef id, None) | r -> let loc,qid = qualid_of_reference r in try - let e = match locate_reference qid with + let e = match locate_global qid with | ConstRef c -> EvalConstRef c | VarRef c -> EvalVarRef c | _ -> error_not_evaluable (pr_reference r) in @@ -529,7 +495,6 @@ let intern_evaluable ist = function | _ -> None in ArgArg (e,short_name) with - | NotSyntacticRef -> error_not_evaluable (pr_reference r) | Not_found -> match r with | Ident (loc,id) when not !strict_check -> @@ -550,15 +515,16 @@ let intern_redexp ist = function | Lazy f -> Lazy (intern_flag ist f) | Pattern l -> Pattern (List.map (intern_constr_occurrence ist) l) | Simpl o -> Simpl (option_app (intern_constr_occurrence ist) o) - | (Red _ | Hnf | ExtraRedExpr _ as r) -> r + | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r ) -> r + let intern_inversion_strength lf ist = function | NonDepInversion (k,idl,ids) -> NonDepInversion (k,List.map (intern_hyp_or_metaid ist) idl, - option_app (intern_intro_pattern lf ist) ids) + intern_intro_pattern lf ist ids) | DepInversion (k,copt,ids) -> DepInversion (k, option_app (intern_constr ist) copt, - option_app (intern_intro_pattern lf ist) ids) + intern_intro_pattern lf ist ids) | InversionUsing (c,idl) -> InversionUsing (intern_constr ist c, List.map (intern_hyp_or_metaid ist) idl) @@ -566,10 +532,15 @@ let intern_inversion_strength lf ist = function let intern_hyp_location ist (id,occs,hl) = (intern_hyp ist (skip_metaid id), occs, hl) +let interp_constrpattern_gen sigma env ltacvar c = + let c = intern_gen false ~allow_soapp:true ~ltacvars:(ltacvar,[]) + sigma env c in + pattern_of_rawconstr c + (* Reads a pattern *) let intern_pattern evc env lfun = function | Subterm (ido,pc) -> - let (metas,pat) = interp_constrpattern_gen evc env lfun pc in + let (metas,pat) = interp_constrpattern_gen evc env lfun pc in ido, metas, Subterm (ido,pat) | Term pc -> let (metas,pat) = interp_constrpattern_gen evc env lfun pc in @@ -582,6 +553,24 @@ let intern_constr_may_eval ist = function | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c) | ConstrTerm c -> ConstrTerm (intern_constr ist c) +(* External tactics *) +let print_xml_term = ref (fun _ -> failwith "print_xml_term unset") +let declare_xml_printer f = print_xml_term := f + +let internalise_tacarg ch = G_xml.parse_tactic_arg ch + +let extern_tacarg ch env sigma = function + | VConstr c -> !print_xml_term ch env sigma c + | VTactic _ | VRTactic _ | VFun _ | VVoid | VInteger _ | VConstr_context _ + | VIntroPattern _ | VRec _ -> + error "Only externing of terms is implemented" + +let extern_request ch req gl la = + output_string ch "\n"; + List.iter (pf_apply (extern_tacarg ch) gl) la; + output_string ch "\n" + (* Reads the hypotheses of a Match Context rule *) let rec intern_match_context_hyps evc env lfun = function | (Hyp ((_,na) as locna,mp))::tl -> @@ -615,7 +604,6 @@ let extract_let_names lrc = name::l) lrc [] - let clause_app f = function { onhyps=None; onconcl=b;concl_occs=nl } -> { onhyps=None; onconcl=b; concl_occs=nl } @@ -634,39 +622,46 @@ let rec intern_atomic lf ist x = option_app (intern_hyp ist) ido') | TacAssumption -> TacAssumption | TacExact c -> TacExact (intern_constr ist c) + | TacExactNoCheck c -> TacExactNoCheck (intern_constr ist c) | TacApply cb -> TacApply (intern_constr_with_bindings ist cb) | TacElim (cb,cbo) -> TacElim (intern_constr_with_bindings ist cb, option_app (intern_constr_with_bindings ist) cbo) - | TacElimType c -> TacElimType (intern_constr ist c) + | TacElimType c -> TacElimType (intern_type ist c) | TacCase cb -> TacCase (intern_constr_with_bindings ist cb) - | TacCaseType c -> TacCaseType (intern_constr ist c) + | TacCaseType c -> TacCaseType (intern_type ist c) | TacFix (idopt,n) -> TacFix (option_app (intern_ident lf ist) idopt,n) | TacMutualFix (id,n,l) -> - let f (id,n,c) = (intern_ident lf ist id,n,intern_constr ist c) in + let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in TacMutualFix (intern_ident lf ist id, n, List.map f l) | TacCofix idopt -> TacCofix (option_app (intern_ident lf ist) idopt) | TacMutualCofix (id,l) -> - let f (id,c) = (intern_ident lf ist id,intern_constr ist c) in + let f (id,c) = (intern_ident lf ist id,intern_type ist c) in TacMutualCofix (intern_ident lf ist id, List.map f l) - | TacCut c -> TacCut (intern_constr ist c) - | TacTrueCut (na,c) -> - TacTrueCut (intern_name lf ist na, intern_constr ist c) - | TacForward (b,na,c) -> - TacForward (b,intern_name lf ist na,intern_constr ist c) + | TacCut c -> TacCut (intern_type ist c) + | TacAssert (otac,ipat,c) -> + TacAssert (option_app (intern_tactic ist) otac, + intern_intro_pattern lf ist ipat, + intern_constr_gen (otac<>None) ist c) | TacGeneralize cl -> TacGeneralize (List.map (intern_constr ist) cl) | TacGeneralizeDep c -> TacGeneralizeDep (intern_constr ist c) | TacLetTac (na,c,cls) -> let na = intern_name lf ist na in TacLetTac (na,intern_constr ist c, (clause_app (intern_hyp_location ist) cls)) - | TacInstantiate (n,c,cls) -> +(* | TacInstantiate (n,c,idh) -> TacInstantiate (n,intern_constr ist c, - (clause_app (intern_hyp_location ist) cls)) + (match idh with + ConclLocation () -> ConclLocation () + | HypLocation (id,hloc) -> + HypLocation(intern_hyp_or_metaid ist id,hloc))) +*) (* Automation tactics *) - | TacTrivial l -> TacTrivial l - | TacAuto (n,l) -> TacAuto (option_app (intern_int_or_var ist) n,l) + | TacTrivial (lems,l) -> TacTrivial (List.map (intern_constr ist) lems,l) + | TacAuto (n,lems,l) -> + TacAuto (option_app (intern_int_or_var ist) n, + List.map (intern_constr ist) lems,l) | TacAutoTDB n -> TacAutoTDB n | TacDestructHyp (b,id) -> TacDestructHyp(b,intern_hyp ist id) | TacDestructConcl -> TacDestructConcl @@ -674,18 +669,18 @@ let rec intern_atomic lf ist x = | TacDAuto (n,p) -> TacDAuto (option_app (intern_int_or_var ist) n,p) (* Derived basic tactics *) - | TacSimpleInduction (h,ids) -> - TacSimpleInduction (intern_quantified_hypothesis ist h,ids) - | TacNewInduction (c,cbo,(ids,ids')) -> - TacNewInduction (intern_induction_arg ist c, + | TacSimpleInduction h -> + TacSimpleInduction (intern_quantified_hypothesis ist h) + | TacNewInduction (lc,cbo,ids) -> + TacNewInduction (List.map (intern_induction_arg ist) lc, option_app (intern_constr_with_bindings ist) cbo, - (option_app (intern_intro_pattern lf ist) ids,ids')) + (intern_intro_pattern lf ist ids)) | TacSimpleDestruct h -> TacSimpleDestruct (intern_quantified_hypothesis ist h) - | TacNewDestruct (c,cbo,(ids,ids')) -> - TacNewDestruct (intern_induction_arg ist c, + | TacNewDestruct (c,cbo,ids) -> + TacNewDestruct (List.map (intern_induction_arg ist) c, option_app (intern_constr_with_bindings ist) cbo, - (option_app (intern_intro_pattern lf ist) ids,ids')) + (intern_intro_pattern lf ist ids)) | TacDoubleInduction (h1,h2) -> let h1 = intern_quantified_hypothesis ist h1 in let h2 = intern_quantified_hypothesis ist h2 in @@ -698,7 +693,7 @@ let rec intern_atomic lf ist x = | TacLApply c -> TacLApply (intern_constr ist c) (* Context management *) - | TacClear l -> TacClear (List.map (intern_hyp_or_metaid ist) l) + | TacClear (b,l) -> TacClear (b,List.map (intern_hyp_or_metaid ist) l) | TacClearBody l -> TacClearBody (List.map (intern_hyp_or_metaid ist) l) | TacMove (dep,id1,id2) -> TacMove (dep,intern_hyp_or_metaid ist id1,intern_hyp_or_metaid ist id2) @@ -734,21 +729,13 @@ let rec intern_atomic lf ist x = let _ = lookup_tactic opn in TacExtend (adjust_loc loc,opn,List.map (intern_genarg ist) l) | TacAlias (loc,s,l,(dir,body)) -> - let (l1,l2) = ist.ltacvars in - let ist' = { ist with ltacvars = ((List.map fst l)@l1,l2) } in - let l = List.map (fun (id,a) -> (strip_meta id,intern_genarg ist a)) l in - try TacAlias (loc,s,l,(dir,intern_tactic ist' body)) + let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in + try TacAlias (loc,s,l,(dir,body)) with e -> raise (locate_error_in_file (string_of_dirpath dir) e) and intern_tactic ist tac = (snd (intern_tactic_seq ist tac) : glob_tactic_expr) and intern_tactic_seq ist = function - (* Traducteur v7->v8 *) - | TacAtom (_,TacReduce (Unfold [_,Ident (_,id)],_)) - when string_of_id id = "INZ" & !Options.translate_syntax - -> ist.ltacvars, (TacId "") - (* Fin traducteur v7->v8 *) - | TacAtom (loc,t) -> let lf = ref ist.ltacvars in let t = intern_atomic lf ist t in @@ -767,12 +754,13 @@ and intern_tactic_seq ist = function let (l1,l2) = ist.ltacvars in let ist' = { ist with ltacvars = ((extract_let_names l)@l1,l2) } in ist.ltacvars, TacLetIn (l,intern_tactic ist' u) - | TacMatchContext (lr,lmr) -> - ist.ltacvars, TacMatchContext(lr, intern_match_rule ist lmr) - | TacMatch (c,lmr) -> - ist.ltacvars, TacMatch (intern_tactic ist c,intern_match_rule ist lmr) - | TacId _ as x -> ist.ltacvars, x - | TacFail (n,x) -> ist.ltacvars, TacFail (intern_int_or_var ist n,x) + | TacMatchContext (lz,lr,lmr) -> + ist.ltacvars, TacMatchContext(lz,lr, intern_match_rule ist lmr) + | TacMatch (lz,c,lmr) -> + ist.ltacvars, TacMatch (lz,intern_tactic ist c,intern_match_rule ist lmr) + | TacId l -> ist.ltacvars, TacId (intern_message ist l) + | TacFail (n,l) -> + ist.ltacvars, TacFail (intern_int_or_var ist n,intern_message ist l) | TacProgress tac -> ist.ltacvars, TacProgress (intern_tactic ist tac) | TacAbstract (tac,s) -> ist.ltacvars, TacAbstract (intern_tactic ist tac,s) | TacThen (t1,t2) -> @@ -793,6 +781,7 @@ and intern_tactic_seq ist = function ist.ltacvars, TacOrelse (intern_tactic ist tac1,intern_tactic ist tac2) | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_tactic ist) l) | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_tactic ist) l) + | TacComplete tac -> ist.ltacvars, TacComplete (intern_tactic ist tac) | TacArg a -> ist.ltacvars, TacArg (intern_tacarg true ist a) and intern_tactic_fun ist (var,body) = @@ -811,13 +800,14 @@ and intern_tacarg strict ist = function | MetaIdArg (loc,s) -> (* $id can occur in Grammar tactic... *) let id = id_of_string s in - if find_ltacvar id ist or Options.do_translate() - then Reference (ArgVar (adjust_loc loc,strip_meta id)) + if find_ltacvar id ist then Reference (ArgVar (adjust_loc loc,id)) else error_syntactic_metavariables_not_allowed loc | TacCall (loc,f,l) -> TacCall (loc, intern_tactic_reference ist f, List.map (intern_tacarg !strict_check ist) l) + | TacExternal (loc,com,req,la) -> + TacExternal (loc,com,req,List.map (intern_tacarg !strict_check ist) la) | TacFreshId _ as x -> x | Tacexp t -> Tacexp (intern_tactic ist t) | TacDynamic(loc,t) as x -> @@ -858,7 +848,7 @@ and intern_genarg ist x = | IdentArgType -> let lf = ref ([],[]) in in_gen globwit_ident(intern_ident lf ist (out_gen rawwit_ident x)) - | HypArgType -> + | VarArgType -> in_gen globwit_var (intern_hyp ist (out_gen rawwit_var x)) | RefArgType -> in_gen globwit_ref (intern_global_reference ist (out_gen rawwit_ref x)) @@ -874,14 +864,12 @@ and intern_genarg ist x = (intern_quantified_hypothesis ist (out_gen rawwit_quant_hyp x)) | RedExprArgType -> in_gen globwit_red_expr (intern_redexp ist (out_gen rawwit_red_expr x)) - | TacticArgType -> - in_gen globwit_tactic (intern_tactic ist (out_gen rawwit_tactic x)) - | OpenConstrArgType -> - in_gen globwit_open_constr - ((),intern_constr ist (snd (out_gen rawwit_open_constr x))) - | CastedOpenConstrArgType -> - in_gen globwit_casted_open_constr - ((),intern_constr ist (snd (out_gen rawwit_casted_open_constr x))) + | TacticArgType n -> + in_gen (globwit_tactic n) (intern_tactic ist + (out_gen (rawwit_tactic n) x)) + | OpenConstrArgType b -> + in_gen (globwit_open_constr_gen b) + ((),intern_constr ist (snd (out_gen (rawwit_open_constr_gen b) x))) | ConstrWithBindingsArgType -> in_gen globwit_constr_with_bindings (intern_constr_with_bindings ist (out_gen rawwit_constr_with_bindings x)) @@ -952,21 +940,12 @@ let rec read_match_rule evc env lfun = function | [] -> [] (* For Match Context and Match *) -exception No_match exception Not_coherent_metas -exception Eval_fail of string - -let is_failure = function - | FailError _ | Stdpp.Exc_located (_,FailError _) -> true - | _ -> false +exception Eval_fail of std_ppcmds let is_match_catchable = function - | No_match | Eval_fail _ -> true - | e -> is_failure e or Logic.catchable_exception e - -let hack_fail_level_shift = ref 0 -let hack_fail_level n = - if n >= !hack_fail_level_shift then n - !hack_fail_level_shift else 0 + | PatternMatchingFailure | Eval_fail _ -> true + | e -> Logic.catchable_exception e (* Verifies if the matched list is coherent with respect to lcm *) let rec verify_metas_coherence gl lcm = function @@ -977,17 +956,9 @@ let rec verify_metas_coherence gl lcm = function raise Not_coherent_metas | [] -> [] -(* Tries to match a pattern and a constr *) -let apply_matching pat csr = - try - (matches pat csr) - with - PatternMatchingFailure -> raise No_match - (* Tries to match one hypothesis pattern with a list of hypotheses *) let apply_one_mhyp_context ist env gl lmatch (hypname,pat) (lhyps,nocc) = let get_id_couple id = function -(* | Name idpat -> [idpat,VIdentifier id]*) | Name idpat -> [idpat,VConstr (mkVar id)] | Anonymous -> [] in let rec apply_one_mhyp_context_rec nocc = function @@ -1002,18 +973,18 @@ let apply_one_mhyp_context ist env gl lmatch (hypname,pat) (lhyps,nocc) = apply_one_mhyp_context_rec 0 tl) | Subterm (ic,t) -> (try - let (lm,ctxt) = sub_match nocc t hyp in + let (lm,ctxt) = match_subterm nocc t hyp in let lmeta = verify_metas_coherence gl lmatch lm in ((get_id_couple id hypname)@(give_context ctxt ic), lmeta,(id,hyp),(hyps,nocc + 1)) with - | NextOccurrence _ -> + | PatternMatchingFailure -> apply_one_mhyp_context_rec 0 tl | Not_coherent_metas -> apply_one_mhyp_context_rec (nocc + 1) hyps)) | [] -> db_hyp_pattern_failure ist.debug env (hypname,pat); - raise No_match + raise PatternMatchingFailure in apply_one_mhyp_context_rec nocc lhyps @@ -1022,7 +993,7 @@ let constr_to_id loc = function | _ -> invalid_arg_loc (loc, "Not an identifier") let constr_to_qid loc c = - try shortest_qualid_of_global Idset.empty (reference_of_constr c) + try shortest_qualid_of_global Idset.empty (global_of_constr c) with _ -> invalid_arg_loc (loc, "Not a global reference") (* Debug reference *) @@ -1038,7 +1009,7 @@ let get_debug () = !debug let interp_ident ist id = try match List.assoc id ist.lfun with | VIntroPattern (IntroIdentifier id) -> id - | VConstr c as v when isVar c -> + | VConstr c when isVar c -> (* This happends e.g. in definitions like "Tac H = Clear H; Intro H" *) (* c is then expected not to belong to the proof context *) (* would be checkable if env were known from interp_ident *) @@ -1047,10 +1018,17 @@ let interp_ident ist id = str ") should have been bound to an identifier") with Not_found -> id +let interp_hint_base ist s = + try match List.assoc (id_of_string s) ist.lfun with + | VIntroPattern (IntroIdentifier id) -> string_of_id id + | _ -> user_err_loc(loc,"", str "An ltac name (" ++ str s ++ + str ") should have been bound to a hint base name") + with Not_found -> s + let interp_intro_pattern_var ist id = try match List.assoc id ist.lfun with | VIntroPattern ipat -> ipat - | VConstr c as v when isVar c -> + | VConstr c when isVar c -> (* This happends e.g. in definitions like "Tac H = Clear H; Intro H" *) (* c is then expected not to belong to the proof context *) (* would be checkable if env were known from interp_ident *) @@ -1078,7 +1056,7 @@ let is_variable env id = List.mem id (ids_of_named_context (Environ.named_context env)) let variable_of_value env = function - | VConstr c as v when isVar c -> destVar c + | VConstr c when isVar c -> destVar c | VIntroPattern (IntroIdentifier id) when is_variable env id -> id | _ -> raise Not_found @@ -1088,8 +1066,8 @@ let id_of_Identifier = variable_of_value (* Extract a constr from a value, if any *) let constr_of_VConstr = constr_of_value -(* Interprets an variable *) -let interp_var ist gl (loc,id) = +(* Interprets a bound variable (especially an existing hypothesis) *) +let interp_hyp ist gl (loc,id) = (* Look first in lfun for a value coercible to a variable *) try let v = List.assoc id ist.lfun in @@ -1104,9 +1082,6 @@ let interp_var ist gl (loc,id) = else user_err_loc (loc,"eval_variable",pr_id id ++ str " not found") -(* Interprets an existing hypothesis (i.e. a declared variable) *) -let interp_hyp = interp_var - let interp_name ist = function | Anonymous -> Anonymous | Name id -> Name (interp_ident ist id) @@ -1124,13 +1099,13 @@ let interp_clause_pattern ist gl (l,occl) = (* Interprets a qualified name *) let interp_reference ist env = function | ArgArg (_,r) -> r - | ArgVar (loc,id) -> coerce_to_reference env (unrec (List.assoc id ist.lfun)) + | ArgVar (loc,id) -> coerce_to_reference env (List.assoc id ist.lfun) let pf_interp_reference ist gl = interp_reference ist (pf_env gl) let interp_inductive ist = function | ArgArg r -> r - | ArgVar (_,id) -> coerce_to_inductive (unrec (List.assoc id ist.lfun)) + | ArgVar (_,id) -> coerce_to_inductive (List.assoc id ist.lfun) let interp_evaluable ist env = function | ArgArg (r,Some (loc,id)) -> @@ -1143,8 +1118,7 @@ let interp_evaluable ist env = function | EvalConstRef _ -> r | _ -> Pretype_errors.error_var_not_found_loc loc id) | ArgArg (r,None) -> r - | ArgVar (_,id) -> - coerce_to_evaluable_ref env (unrec (List.assoc id ist.lfun)) + | ArgVar (_,id) -> coerce_to_evaluable_ref env (List.assoc id ist.lfun) (* Interprets an hypothesis name *) let interp_hyp_location ist gl (id,occs,hl) = (interp_hyp ist gl id,occs,hl) @@ -1175,61 +1149,110 @@ let rec intropattern_ids = function | IntroIdentifier id -> [id] | IntroOrAndPattern ll -> List.flatten (List.map intropattern_ids (List.flatten ll)) - | IntroWildcard -> [] + | IntroWildcard | IntroAnonymous -> [] let rec extract_ids = function | (id,VIntroPattern ipat)::tl -> intropattern_ids ipat @ extract_ids tl | _::tl -> extract_ids tl | [] -> [] +(* To retype a list of key*constr with undefined key *) let retype_list sigma env lst = List.fold_right (fun (x,csr) a -> try (x,Retyping.get_judgment_of env sigma csr)::a with | Anomaly _ -> a) lst [] -let interp_casted_constr ocl ist sigma env (c,ce) = - let (l1,l2) = constr_list ist env in - let tl1 = retype_list sigma env l1 in - let csr = - match ce with - | None -> - Pretyping.understand_gen_ltac sigma env (tl1,l2) ocl c - (* If at toplevel (ce<>None), the error can be due to an incorrect - context at globalization time: we retype with the now known - intros/lettac/inversion hypothesis names *) - | Some c -> interp_constr_gen sigma env (l1,l2) c ocl - in - db_constr ist.debug env csr; - csr +(* List.map (fun (x,csr) -> (x,Retyping.get_judgment_of env sigma csr)) lst*) -let interp_constr ist sigma env c = - interp_casted_constr None ist sigma env c +let implicit_tactic = ref None + +let declare_implicit_tactic tac = implicit_tactic := Some tac + +open Evd + +let solvable_by_tactic env evi (ev,args) src = + match (!implicit_tactic, src) with + | Some tac, (ImplicitArg _ | QuestionMark) + when + Environ.named_context_of_val evi.evar_hyps = + Environ.named_context env -> + let id = id_of_string "H" in + start_proof id (Local,Proof Lemma) evi.evar_hyps evi.evar_concl + (fun _ _ -> ()); + begin + try + by (tclCOMPLETE tac); + let _,(const,_,_) = cook_proof () in + delete_current_proof (); const.const_entry_body + with e when Logic.catchable_exception e -> + delete_current_proof(); + raise Exit + end + | _ -> raise Exit + +let solve_remaining_evars env initial_sigma evars c = + let isevars = ref evars in + let rec proc_rec c = + match kind_of_term (Reductionops.whd_evar (evars_of !isevars) c) with + | Evar (ev,args as k) when not (Evd.in_dom initial_sigma ev) -> + let (loc,src) = evar_source ev !isevars in + let sigma = evars_of !isevars in + (try + let evi = Evd.map sigma ev in + let c = solvable_by_tactic env evi k src in + isevars := Evd.evar_define ev c !isevars; + c + with Exit -> + Pretype_errors.error_unsolvable_implicit loc env sigma src) + | _ -> map_constr proc_rec c + in + map_constr proc_rec c -(* Interprets an open constr expression casted by the current goal *) -let pf_interp_openconstr_gen casted ist gl (c,ce) = - let sigma = project gl in - let env = pf_env gl in - let (ltacvars,l) = constr_list ist env in +let interp_gen kind ist sigma env (c,ce) = + let (ltacvars,unbndltacvars) = constr_list ist env in let typs = retype_list sigma env ltacvars in - let ocl = if casted then Some (pf_concl gl) else None in - match ce with - | None -> - Pretyping.understand_gen_tcc sigma env typs ocl c + let c = match ce with + | None -> c (* If at toplevel (ce<>None), the error can be due to an incorrect context at globalization time: we retype with the now known intros/lettac/inversion hypothesis names *) - | Some c -> interp_openconstr_gen sigma env (ltacvars,l) c ocl + | Some c -> + let ltacdata = (List.map fst ltacvars,unbndltacvars) in + intern_gen (kind = IsType) ~ltacvars:ltacdata sigma env c in + understand_ltac sigma env (typs,unbndltacvars) kind c + +(* Interprets a constr and solve remaining evars with default tactic *) +let interp_econstr kind ist sigma env cc = + let evars,c = interp_gen kind ist sigma env cc in + let csr = solve_remaining_evars env sigma evars c in + db_constr ist.debug env csr; + csr + +(* Interprets an open constr *) +let interp_open_constr ccl ist sigma env cc = + let isevars,c = interp_gen (OfType ccl) ist sigma env cc in + (evars_of isevars,c) + +let interp_constr = interp_econstr (OfType None) + +let interp_type = interp_econstr IsType + +(* Interprets a constr expression casted by the current goal *) +let pf_interp_casted_constr ist gl cc = + interp_econstr (OfType (Some (pf_concl gl))) ist (project gl) (pf_env gl) cc -let pf_interp_casted_openconstr = pf_interp_openconstr_gen true -let pf_interp_openconstr = pf_interp_openconstr_gen false +(* Interprets an open constr expression *) +let pf_interp_open_constr casted ist gl cc = + let cl = if casted then Some (pf_concl gl) else None in + interp_open_constr cl ist (project gl) (pf_env gl) cc (* Interprets a constr expression *) let pf_interp_constr ist gl = interp_constr ist (project gl) (pf_env gl) -(* Interprets a constr expression casted by the current goal *) -let pf_interp_casted_constr ist gl c = - interp_casted_constr (Some(pf_concl gl)) ist (project gl) (pf_env gl) c +(* Interprets a type expression *) +let pf_interp_type ist gl = + interp_type ist (project gl) (pf_env gl) (* Interprets a reduction expression *) let interp_unfold ist env (l,qid) = @@ -1249,14 +1272,14 @@ let redexp_interp ist sigma env = function | Lazy f -> Lazy (interp_flag ist env f) | Pattern l -> Pattern (List.map (interp_pattern ist sigma env) l) | Simpl o -> Simpl (option_app (interp_pattern ist sigma env) o) - | (Red _ | Hnf | ExtraRedExpr _ as r) -> r + | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r let pf_redexp_interp ist gl = redexp_interp ist (project gl) (pf_env gl) let interp_may_eval f ist gl = function | ConstrEval (r,c) -> let redexp = pf_redexp_interp ist gl r in - pf_reduction_of_redexp gl redexp (f ist gl c) + pf_reduction_of_red_expr gl redexp (f ist gl c) | ConstrContext ((loc,s),c) -> (try let ic = f ist gl c @@ -1277,10 +1300,31 @@ let interp_constr_may_eval ist gl c = csr end +let message_of_value = function + | VVoid -> str "()" + | VInteger n -> int n + | VIntroPattern ipat -> pr_intro_pattern ipat + | VConstr_context c | VConstr c -> pr_constr c + | VRec _ | VTactic _ | VRTactic _ | VFun _ -> str "" + +let rec interp_message ist = function + | [] -> mt() + | MsgString s :: l -> pr_arg str s ++ interp_message ist l + | MsgInt n :: l -> pr_arg int n ++ interp_message ist l + | MsgIdent (_,id) :: l -> + let v = + try List.assoc id ist.lfun + with Not_found -> user_err_loc (loc,"",pr_id id ++ str " not found") in + pr_arg message_of_value v ++ interp_message ist l + +let rec interp_message_nl ist = function + | [] -> mt() + | l -> interp_message ist l ++ fnl() + let rec interp_intro_pattern ist = function | IntroOrAndPattern l -> IntroOrAndPattern (interp_case_intro_pattern ist l) - | IntroWildcard -> IntroWildcard | IntroIdentifier id -> interp_intro_pattern_var ist id + | IntroWildcard | IntroAnonymous as x -> x and interp_case_intro_pattern ist = List.map (List.map (interp_intro_pattern ist)) @@ -1335,8 +1379,8 @@ let rec val_interp ist gl (tac:glob_tactic_expr) = | TacLetIn (l,u) -> let addlfun = interp_letin ist gl l in val_interp { ist with lfun=addlfun@ist.lfun } gl u - | TacMatchContext (lr,lmr) -> interp_match_context ist gl lr lmr - | TacMatch (c,lmr) -> interp_match ist gl c lmr + | TacMatchContext (lz,lr,lmr) -> interp_match_context ist gl lz lr lmr + | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr | TacArg a -> interp_tacarg ist gl a (* Delayed evaluation *) | t -> VTactic (dummy_loc,eval_tactic ist t) @@ -1349,13 +1393,10 @@ let rec val_interp ist gl (tac:glob_tactic_expr) = and eval_tactic ist = function | TacAtom (loc,t) -> fun gl -> catch_error loc (interp_atomic ist gl t) gl - | TacFun (it,body) -> assert false - | TacLetRecIn (lrc,u) -> assert false - | TacLetIn (l,u) -> assert false - | TacMatchContext _ -> assert false - | TacMatch (c,lmr) -> assert false - | TacId s -> tclIDTAC_MESSAGE s - | TacFail (n,s) -> tclFAIL (hack_fail_level (interp_int_or_var ist n)) s + | TacFun _ | TacLetRecIn _ | TacLetIn _ -> assert false + | TacMatchContext _ | TacMatch _ -> assert false + | TacId s -> tclIDTAC_MESSAGE (interp_message_nl ist s) + | TacFail (n,s) -> tclFAIL (interp_int_or_var ist n) (interp_message ist s) | TacProgress tac -> tclPROGRESS (interp_tactic ist tac) | TacAbstract (tac,s) -> Tactics.tclABSTRACT s (interp_tactic ist tac) | TacThen (t1,t2) -> tclTHEN (interp_tactic ist t1) (interp_tactic ist t2) @@ -1369,26 +1410,32 @@ and eval_tactic ist = function tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2) | TacFirst l -> tclFIRST (List.map (interp_tactic ist) l) | TacSolve l -> tclSOLVE (List.map (interp_tactic ist) l) + | TacComplete tac -> tclCOMPLETE (interp_tactic ist tac) | TacArg a -> assert false -and interp_ltac_reference isapplied ist gl = function - | ArgVar (loc,id) -> unrec (List.assoc id ist.lfun) +and interp_ltac_reference isapplied mustbetac ist gl = function + | ArgVar (loc,id) -> + let v = List.assoc id ist.lfun in + if mustbetac then coerce_to_tactic loc id v else v | ArgArg (loc,r) -> let v = val_interp {lfun=[];debug=ist.debug} gl (lookup r) in if isapplied then v else locate_tactic_call loc v and interp_tacarg ist gl = function | TacVoid -> VVoid - | Reference r -> interp_ltac_reference false ist gl r + | Reference r -> interp_ltac_reference false false ist gl r | Integer n -> VInteger n | IntroPattern ipat -> VIntroPattern ipat | ConstrMayEval c -> VConstr (interp_constr_may_eval ist gl c) | MetaIdArg (loc,id) -> assert false + | TacCall (loc,r,[]) -> interp_ltac_reference false true ist gl r | TacCall (loc,f,l) -> - let fv = interp_ltac_reference true ist gl f + let fv = interp_ltac_reference true true ist gl f and largs = List.map (interp_tacarg ist gl) l in List.iter check_is_value largs; interp_app ist gl fv largs loc + | TacExternal (loc,com,req,la) -> + interp_external loc ist gl com req (List.map (interp_tacarg ist gl) la) | TacFreshId idopt -> let s = match idopt with None -> "H" | Some s -> s in let id = Tactics.fresh_id (extract_ids ist.lfun) (id_of_string s) gl in @@ -1406,7 +1453,7 @@ and interp_tacarg ist gl = function else if tg = "value" then value_out t else if tg = "constr" then - VConstr (Pretyping.constr_out t) + VConstr (constr_out t) else anomaly_loc (loc, "Tacinterp.val_interp", (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">")) @@ -1435,10 +1482,10 @@ and tactic_of_value vle g = | _ -> raise NotTactic (* Evaluation with FailError catching *) -and eval_with_fail ist tac goal = +and eval_with_fail ist is_lazy goal tac = try (match val_interp ist goal tac with - | VTactic (loc,tac) -> VRTactic (catch_error loc tac goal) + | VTactic (loc,tac) when not is_lazy -> VRTactic (catch_error loc tac goal) | a -> a) with | Stdpp.Exc_located (_,FailError (0,s)) | FailError (0,s) -> @@ -1478,8 +1525,8 @@ and interp_letin ist gl = function with Not_found -> try let t = tactic_of_value v in - let ndc = Environ.named_context env in - start_proof id IsLocal ndc typ (fun _ _ -> ()); + let ndc = Environ.named_context_val env in + start_proof id (Local,Proof Lemma) ndc typ (fun _ _ -> ()); by t; let (_,({const_entry_body = pft},_,_)) = cook_proof () in delete_proof (dummy_loc,id); @@ -1488,23 +1535,15 @@ and interp_letin ist gl = function delete_proof (dummy_loc,id); errorlabstrm "Tacinterp.interp_letin" (str "Term or fully applied tactic expected in Let") - in (id,VConstr (mkCast (csr,typ)))::(interp_letin ist gl tl) + in (id,VConstr (mkCast (csr,DEFAULTcast, typ)))::(interp_letin ist gl tl) (* Interprets the Match Context expressions *) -and interp_match_context ist g lr lmr = +and interp_match_context ist g lz lr lmr = let rec apply_goal_sub ist env goal nocc (id,c) csr mt mhyps hyps = - try - let (lgoal,ctxt) = sub_match nocc c csr in - let lctxt = give_context ctxt id in - if mhyps = [] then - let lgoal = List.map (fun (id,c) -> (id,VConstr c)) lgoal in - eval_with_fail { ist with lfun=lgoal@lctxt@ist.lfun } mt goal - else - apply_hyps_context ist env goal mt lctxt lgoal mhyps hyps - with - | e when is_failure e -> raise e - | NextOccurrence _ -> raise No_match - | e when is_match_catchable e -> + let (lgoal,ctxt) = match_subterm nocc c csr in + let lctxt = give_context ctxt id in + try apply_hyps_context ist env lz goal mt lctxt lgoal mhyps hyps + with e when is_match_catchable e -> apply_goal_sub ist env goal (nocc + 1) (id,c) csr mt mhyps hyps in let rec apply_match_context ist env goal nrs lex lpt = begin @@ -1513,11 +1552,9 @@ and interp_match_context ist g lr lmr = | (All t)::tl -> begin db_mc_pattern_success ist.debug; - try eval_with_fail ist t goal - with - | e when is_failure e -> raise e - | e when is_match_catchable e -> - apply_match_context ist env goal (nrs+1) (List.tl lex) tl + try eval_with_fail ist lz goal t + with e when is_match_catchable e -> + apply_match_context ist env goal (nrs+1) (List.tl lex) tl end | (Pat (mhyps,mgoal,mt))::tl -> let hyps = make_hyps (pf_hyps goal) in @@ -1527,33 +1564,19 @@ and interp_match_context ist g lr lmr = (match mgoal with | Term mg -> (try - (let lgoal = apply_matching mg concl in - begin - db_matched_concl ist.debug (pf_env goal) concl; - if mhyps = [] then - begin - db_mc_pattern_success ist.debug; - let lgoal = List.map (fun (id,c) -> (id,VConstr c)) lgoal in - eval_with_fail {ist with lfun=lgoal@ist.lfun} mt goal - end - else - apply_hyps_context ist env goal mt [] lgoal mhyps hyps - end) - with - | e when is_failure e -> raise e - | e when is_match_catchable e -> - begin - (match e with - | No_match -> db_matching_failure ist.debug + let lgoal = matches mg concl in + db_matched_concl ist.debug (pf_env goal) concl; + apply_hyps_context ist env lz goal mt [] lgoal mhyps hyps + with e when is_match_catchable e -> + (match e with + | PatternMatchingFailure -> db_matching_failure ist.debug | Eval_fail s -> db_eval_failure ist.debug s | _ -> db_logic_failure ist.debug e); - apply_match_context ist env goal (nrs+1) (List.tl lex) tl - end) + apply_match_context ist env goal (nrs+1) (List.tl lex) tl) | Subterm (id,mg) -> (try apply_goal_sub ist env goal 0 (id,mg) concl mt mhyps hyps - with - | e when is_failure e -> raise e - | e when is_match_catchable e -> + with + | PatternMatchingFailure -> apply_match_context ist env goal (nrs+1) (List.tl lex) tl)) | _ -> errorlabstrm "Tacinterp.apply_match_context" @@ -1567,7 +1590,7 @@ and interp_match_context ist g lr lmr = (read_match_rule (project g) env (fst (constr_list ist env)) lmr) (* Tries to match the hypotheses in a Match Context *) -and apply_hyps_context ist env goal mt lctxt lgmatch mhyps hyps = +and apply_hyps_context ist env lz goal mt lctxt lgmatch mhyps hyps = let rec apply_hyps_context_rec lfun lmatch lhyps_rest current = function | Hyp ((_,hypname),mhyp)::tl as mhyps -> let (lids,lm,hyp_match,next) = @@ -1578,18 +1601,21 @@ and apply_hyps_context ist env goal mt lctxt lgmatch mhyps hyps = let nextlhyps = list_except hyp_match lhyps_rest in apply_hyps_context_rec (lfun@lids) (lmatch@lm) nextlhyps (nextlhyps,0) tl - with - | e when is_failure e -> raise e - | e when is_match_catchable e -> + with e when is_match_catchable e -> apply_hyps_context_rec lfun lmatch lhyps_rest next mhyps end | [] -> let lmatch = List.map (fun (id,c) -> (id,VConstr c)) lmatch in db_mc_pattern_success ist.debug; - eval_with_fail {ist with lfun=lmatch@lfun@ist.lfun} mt goal + eval_with_fail {ist with lfun=lmatch@lfun@ist.lfun} lz goal mt in apply_hyps_context_rec lctxt lgmatch hyps (hyps,0) mhyps +and interp_external loc ist gl com req la = + let f ch = extern_request ch req gl la in + let g ch = internalise_tacarg ch in + interp_tacarg ist gl (System.connect f g com) + (* Interprets extended tactic generic arguments *) and interp_genarg ist goal x = match genarg_tag x with @@ -1607,8 +1633,8 @@ and interp_genarg ist goal x = (interp_intro_pattern ist (out_gen globwit_intro_pattern x)) | IdentArgType -> in_gen wit_ident (interp_ident ist (out_gen globwit_ident x)) - | HypArgType -> - in_gen wit_var (mkVar (interp_hyp ist goal (out_gen globwit_var x))) + | VarArgType -> + in_gen wit_var (interp_hyp ist goal (out_gen globwit_var x)) | RefArgType -> in_gen wit_ref (pf_interp_reference ist goal (out_gen globwit_ref x)) | SortArgType -> @@ -1626,13 +1652,11 @@ and interp_genarg ist goal x = (out_gen globwit_quant_hyp x)) | RedExprArgType -> in_gen wit_red_expr (pf_redexp_interp ist goal (out_gen globwit_red_expr x)) - | TacticArgType -> in_gen wit_tactic (out_gen globwit_tactic x) - | OpenConstrArgType -> - in_gen wit_open_constr - (pf_interp_openconstr ist goal (snd (out_gen globwit_open_constr x))) - | CastedOpenConstrArgType -> - in_gen wit_casted_open_constr - (pf_interp_casted_openconstr ist goal (snd (out_gen globwit_casted_open_constr x))) + | TacticArgType n -> in_gen (wit_tactic n) (out_gen (globwit_tactic n) x) + | OpenConstrArgType casted -> + in_gen (wit_open_constr_gen casted) + (pf_interp_open_constr casted ist goal + (snd (out_gen (globwit_open_constr_gen casted) x))) | ConstrWithBindingsArgType -> in_gen wit_constr_with_bindings (interp_constr_with_bindings ist goal (out_gen globwit_constr_with_bindings x)) @@ -1646,33 +1670,28 @@ and interp_genarg ist goal x = | ExtraArgType s -> lookup_interp_genarg s ist goal x (* Interprets the Match expressions *) -and interp_match ist g constr lmr = - let rec apply_sub_match ist nocc (id,c) csr mt = - try - let (lm,ctxt) = sub_match nocc c csr in - let lctxt = give_context ctxt id in - let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in - val_interp {ist with lfun=lm@lctxt@ist.lfun} g mt - with | NextOccurrence _ -> raise No_match - | e when is_match_catchable e -> - apply_sub_match ist (nocc + 1) (id,c) csr mt +and interp_match ist g lz constr lmr = + let rec apply_match_subterm ist nocc (id,c) csr mt = + let (lm,ctxt) = match_subterm nocc c csr in + let lctxt = give_context ctxt id in + let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in + try eval_with_fail {ist with lfun=lm@lctxt@ist.lfun} lz g mt + with e when is_match_catchable e -> + apply_match_subterm ist (nocc + 1) (id,c) csr mt in let rec apply_match ist csr = function | (All t)::_ -> - (try val_interp ist g t + (try eval_with_fail ist lz g t with e when is_match_catchable e -> apply_match ist csr []) | (Pat ([],Term c,mt))::tl -> (try - let lm = apply_matching c csr in + let lm = matches c csr in let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in - val_interp - { ist with lfun=lm@ist.lfun } g mt + eval_with_fail { ist with lfun=lm@ist.lfun } lz g mt with e when is_match_catchable e -> apply_match ist csr tl) | (Pat ([],Subterm (id,c),mt))::tl -> - (try - apply_sub_match ist 0 (id,c) csr mt - with | No_match -> - apply_match ist csr tl) + (try apply_match_subterm ist 0 (id,c) csr mt + with PatternMatchingFailure -> apply_match ist csr tl) | _ -> errorlabstrm "Tacinterp.apply_match" (str "No matching clauses for match") in @@ -1683,14 +1702,7 @@ and interp_match ist g constr lmr = errorlabstrm "Tacinterp.apply_match" (str "Argument of match does not evaluate to a term") in let ilr = read_match_rule (project g) env (fst (constr_list ist env)) lmr in - try - incr hack_fail_level_shift; - let x = apply_match ist csr ilr in - decr hack_fail_level_shift; - x - with e -> - decr hack_fail_level_shift; - raise e + apply_match ist csr ilr (* Interprets tactic expressions : returns a "tactic" *) and interp_tactic ist tac gl = @@ -1711,37 +1723,48 @@ and interp_atomic ist gl = function (option_app (interp_hyp ist gl) ido') | TacAssumption -> h_assumption | TacExact c -> h_exact (pf_interp_casted_constr ist gl c) + | TacExactNoCheck c -> h_exact_no_check (pf_interp_constr ist gl c) | TacApply cb -> h_apply (interp_constr_with_bindings ist gl cb) | TacElim (cb,cbo) -> h_elim (interp_constr_with_bindings ist gl cb) (option_app (interp_constr_with_bindings ist gl) cbo) - | TacElimType c -> h_elim_type (pf_interp_constr ist gl c) + | TacElimType c -> h_elim_type (pf_interp_type ist gl c) | TacCase cb -> h_case (interp_constr_with_bindings ist gl cb) - | TacCaseType c -> h_case_type (pf_interp_constr ist gl c) + | TacCaseType c -> h_case_type (pf_interp_type ist gl c) | TacFix (idopt,n) -> h_fix (option_app (interp_ident ist) idopt) n | TacMutualFix (id,n,l) -> - let f (id,n,c) = (interp_ident ist id,n,pf_interp_constr ist gl c) in + let f (id,n,c) = (interp_ident ist id,n,pf_interp_type ist gl c) in h_mutual_fix (interp_ident ist id) n (List.map f l) | TacCofix idopt -> h_cofix (option_app (interp_ident ist) idopt) | TacMutualCofix (id,l) -> - let f (id,c) = (interp_ident ist id,pf_interp_constr ist gl c) in + let f (id,c) = (interp_ident ist id,pf_interp_type ist gl c) in h_mutual_cofix (interp_ident ist id) (List.map f l) - | TacCut c -> h_cut (pf_interp_constr ist gl c) - | TacTrueCut (na,c) -> - h_true_cut (interp_name ist na) (pf_interp_constr ist gl c) - | TacForward (b,na,c) -> - h_forward b (interp_name ist na) (pf_interp_constr ist gl c) + | TacCut c -> h_cut (pf_interp_type ist gl c) + | TacAssert (t,ipat,c) -> + let c = (if t=None then pf_interp_constr else pf_interp_type) ist gl c in + abstract_tactic (TacAssert (t,ipat,c)) + (Tactics.forward (option_app (interp_tactic ist) t) + (interp_intro_pattern ist ipat) c) | TacGeneralize cl -> h_generalize (List.map (pf_interp_constr ist gl) cl) | TacGeneralizeDep c -> h_generalize_dep (pf_interp_constr ist gl c) | TacLetTac (na,c,clp) -> let clp = interp_clause ist gl clp in h_let_tac (interp_name ist na) (pf_interp_constr ist gl c) clp - | TacInstantiate (n,c,ido) -> h_instantiate n (pf_interp_constr ist gl c) - (clause_app (interp_hyp_location ist gl) ido) - +(* | TacInstantiate (n,c,idh) -> h_instantiate n (fst c) + (* pf_interp_constr ist gl c *) + (match idh with + ConclLocation () -> ConclLocation () + | HypLocation (id,hloc) -> + HypLocation(interp_hyp ist gl id,hloc)) +*) (* Automation tactics *) - | TacTrivial l -> Auto.h_trivial l - | TacAuto (n, l) -> Auto.h_auto (option_app (interp_int_or_var ist) n) l + | TacTrivial (lems,l) -> + Auto.h_trivial (List.map (pf_interp_constr ist gl) lems) + (option_app (List.map (interp_hint_base ist)) l) + | TacAuto (n,lems,l) -> + Auto.h_auto (option_app (interp_int_or_var ist) n) + (List.map (pf_interp_constr ist gl) lems) + (option_app (List.map (interp_hint_base ist)) l) | TacAutoTDB n -> Dhyp.h_auto_tdb n | TacDestructHyp (b,id) -> Dhyp.h_destructHyp b (interp_hyp ist gl id) | TacDestructConcl -> Dhyp.h_destructConcl @@ -1749,21 +1772,18 @@ and interp_atomic ist gl = function | TacDAuto (n,p) -> Auto.h_dauto (option_app (interp_int_or_var ist) n,p) (* Derived basic tactics *) - | TacSimpleInduction (h,ids) -> - let h = - if !Options.v7 then interp_declared_or_quantified_hypothesis ist gl h - else interp_quantified_hypothesis ist h in - h_simple_induction (h,ids) - | TacNewInduction (c,cbo,(ids,ids')) -> - h_new_induction (interp_induction_arg ist gl c) + | TacSimpleInduction h -> + h_simple_induction (interp_quantified_hypothesis ist h) + | TacNewInduction (lc,cbo,ids) -> + h_new_induction (List.map (interp_induction_arg ist gl) lc) (option_app (interp_constr_with_bindings ist gl) cbo) - (option_app (interp_intro_pattern ist) ids,ids') + (interp_intro_pattern ist ids) | TacSimpleDestruct h -> h_simple_destruct (interp_quantified_hypothesis ist h) - | TacNewDestruct (c,cbo,(ids,ids')) -> - h_new_destruct (interp_induction_arg ist gl c) + | TacNewDestruct (c,cbo,ids) -> + h_new_destruct (List.map (interp_induction_arg ist gl) c) (option_app (interp_constr_with_bindings ist gl) cbo) - (option_app (interp_intro_pattern ist) ids,ids') + (interp_intro_pattern ist ids) | TacDoubleInduction (h1,h2) -> let h1 = interp_quantified_hypothesis ist h1 in let h2 = interp_quantified_hypothesis ist h2 in @@ -1778,7 +1798,7 @@ and interp_atomic ist gl = function | TacLApply c -> h_lapply (pf_interp_constr ist gl c) (* Context management *) - | TacClear l -> h_clear (List.map (interp_hyp ist gl) l) + | TacClear (b,l) -> h_clear b (List.map (interp_hyp ist gl) l) | TacClearBody l -> h_clear_body (List.map (interp_hyp ist gl) l) | TacMove (dep,id1,id2) -> h_move dep (interp_hyp ist gl id1) (interp_hyp ist gl id2) @@ -1810,11 +1830,11 @@ and interp_atomic ist gl = function (* Equality and inversion *) | TacInversion (DepInversion (k,c,ids),hyp) -> Inv.dinv k (option_app (pf_interp_constr ist gl) c) - (option_app (interp_intro_pattern ist) ids) + (interp_intro_pattern ist ids) (interp_declared_or_quantified_hypothesis ist gl hyp) | TacInversion (NonDepInversion (k,idl,ids),hyp) -> Inv.inv_clause k - (option_app (interp_intro_pattern ist) ids) + (interp_intro_pattern ist ids) (List.map (interp_hyp ist gl) idl) (interp_declared_or_quantified_hypothesis ist gl hyp) | TacInversion (InversionUsing (c,idl),hyp) -> @@ -1836,29 +1856,31 @@ and interp_atomic ist gl = function VIntroPattern (out_gen globwit_intro_pattern x) | IdentArgType -> VIntroPattern (IntroIdentifier (out_gen globwit_ident x)) - | HypArgType -> - VConstr (mkVar (interp_var ist gl (out_gen globwit_var x))) + | VarArgType -> + VConstr (mkVar (interp_hyp ist gl (out_gen globwit_var x))) | RefArgType -> - VConstr (constr_of_reference + VConstr (constr_of_global (pf_interp_reference ist gl (out_gen globwit_ref x))) | SortArgType -> - VConstr (mkSort (Pretyping.interp_sort (out_gen globwit_sort x))) + VConstr (mkSort (interp_sort (out_gen globwit_sort x))) | ConstrArgType -> VConstr (pf_interp_constr ist gl (out_gen globwit_constr x)) | ConstrMayEvalArgType -> VConstr (interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x)) - | TacticArgType -> - val_interp ist gl (out_gen globwit_tactic x) + | TacticArgType n -> + val_interp ist gl (out_gen (globwit_tactic n) x) | StringArgType | BoolArgType - | QuantHypArgType | RedExprArgType | OpenConstrArgType - | CastedOpenConstrArgType | ConstrWithBindingsArgType | BindingsArgType + | QuantHypArgType | RedExprArgType + | OpenConstrArgType _ | ConstrWithBindingsArgType | BindingsArgType | ExtraArgType _ | List0ArgType _ | List1ArgType _ | OptArgType _ | PairArgType _ -> error "This generic type is not supported in alias" in let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in let v = locate_tactic_call loc (val_interp { ist with lfun=lfun } gl body) - in tactic_of_value v gl + in + try tactic_of_value v gl + with NotTactic -> user_err_loc (loc,"",str "not a tactic") (* Initial call for interpretation *) let interp_tac_gen lfun debug t gl = @@ -1888,11 +1910,11 @@ let subst_quantified_hypothesis _ x = x let subst_declared_or_quantified_hypothesis _ x = x -let subst_inductive subst (kn,i) = (subst_kn subst kn,i) - -let subst_rawconstr subst (c,e) = +let subst_rawconstr_and_expr subst (c,e) = assert (e=None); (* e<>None only for toplevel tactics *) - (subst_raw subst c,None) + (Detyping.subst_rawconstr subst c,None) + +let subst_rawconstr = subst_rawconstr_and_expr (* shortening *) let subst_binding subst (loc,b,c) = (loc,subst_quantified_hypothesis subst b,subst_rawconstr subst c) @@ -1910,10 +1932,6 @@ let subst_induction_arg subst = function | ElimOnAnonHyp n as x -> x | ElimOnIdent id as x -> x -let subst_evaluable_reference subst = function - | EvalVarRef id -> EvalVarRef id - | EvalConstRef kn -> EvalConstRef (subst_kn subst kn) - let subst_and_short_name f (c,n) = assert (n=None); (* since tacdef are strictly globalized *) (f c,None) @@ -1927,11 +1945,23 @@ let subst_located f (_loc,id) = (loc,f id) let subst_reference subst = subst_or_var (subst_located (subst_kn subst)) +(*CSC: subst_global_reference is used "only" for RefArgType, that propagates + to the syntactic non-terminals "global", used in commands such as + Print. It is also used for non-evaluable references. *) let subst_global_reference subst = - subst_or_var (subst_located (subst_global subst)) + let subst_global ref = + let ref',t' = subst_global subst ref in + if not (eq_constr (constr_of_global ref') t') then + ppnl (str "Warning: the reference " ++ pr_global ref ++ str " is not " ++ + str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ + pr_global ref') ; + ref' + in + subst_or_var (subst_located subst_global) let subst_evaluable subst = - subst_or_var (subst_and_short_name (subst_evaluable_reference subst)) + let subst_eval_ref = subst_evaluable_reference subst in + subst_or_var (subst_and_short_name subst_eval_ref) let subst_unfold subst (l,e) = (l,subst_evaluable subst e) @@ -1948,7 +1978,7 @@ let subst_redexp subst = function | Lazy f -> Lazy (subst_flag subst f) | Pattern l -> Pattern (List.map (subst_constr_occurrence subst) l) | Simpl o -> Simpl (option_app (subst_constr_occurrence subst) o) - | (Red _ | Hnf | ExtraRedExpr _ as r) -> r + | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r let subst_raw_may_eval subst = function | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_rawconstr subst c) @@ -1971,6 +2001,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacIntroPattern _ | TacIntrosUntil _ | TacIntroMove _ as x -> x | TacAssumption as x -> x | TacExact c -> TacExact (subst_rawconstr subst c) + | TacExactNoCheck c -> TacExactNoCheck (subst_rawconstr subst c) | TacApply cb -> TacApply (subst_raw_with_bindings subst cb) | TacElim (cb,cbo) -> TacElim (subst_raw_with_bindings subst cb, @@ -1985,16 +2016,15 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacMutualCofix (id,l) -> TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_rawconstr subst c)) l) | TacCut c -> TacCut (subst_rawconstr subst c) - | TacTrueCut (ido,c) -> TacTrueCut (ido, subst_rawconstr subst c) - | TacForward (b,na,c) -> TacForward (b,na,subst_rawconstr subst c) + | TacAssert (b,na,c) -> TacAssert (b,na,subst_rawconstr subst c) | TacGeneralize cl -> TacGeneralize (List.map (subst_rawconstr subst) cl) | TacGeneralizeDep c -> TacGeneralizeDep (subst_rawconstr subst c) | TacLetTac (id,c,clp) -> TacLetTac (id,subst_rawconstr subst c,clp) - | TacInstantiate (n,c,ido) -> TacInstantiate (n,subst_rawconstr subst c,ido) - +(*| TacInstantiate (n,c,ido) -> TacInstantiate (n,subst_rawconstr subst c,ido) +*) (* Automation tactics *) - | TacTrivial l -> TacTrivial l - | TacAuto (n,l) -> TacAuto (n,l) + | TacTrivial (lems,l) -> TacTrivial (List.map (subst_rawconstr subst) lems,l) + | TacAuto (n,lems,l) -> TacAuto (n,List.map (subst_rawconstr subst) lems,l) | TacAutoTDB n -> TacAutoTDB n | TacDestructHyp (b,id) -> TacDestructHyp(b,id) | TacDestructConcl -> TacDestructConcl @@ -2003,12 +2033,12 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Derived basic tactics *) | TacSimpleInduction h as x -> x - | TacNewInduction (c,cbo,ids) -> - TacNewInduction (subst_induction_arg subst c, + | TacNewInduction (lc,cbo,ids) -> (* Pierre C. est-ce correct? *) + TacNewInduction (List.map (subst_induction_arg subst) lc, option_app (subst_raw_with_bindings subst) cbo, ids) | TacSimpleDestruct h as x -> x | TacNewDestruct (c,cbo,ids) -> - TacNewDestruct (subst_induction_arg subst c, + TacNewDestruct (List.map (subst_induction_arg subst) c, (* Julien F. est-ce correct? *) option_app (subst_raw_with_bindings subst) cbo, ids) | TacDoubleInduction (h1,h2) as x -> x | TacDecomposeAnd c -> TacDecomposeAnd (subst_rawconstr subst c) @@ -2020,7 +2050,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacLApply c -> TacLApply (subst_rawconstr subst c) (* Context management *) - | TacClear l as x -> x + | TacClear _ as x -> x | TacClearBody l as x -> x | TacMove (dep,id1,id2) as x -> x | TacRename (id1,id2) as x -> x @@ -2065,10 +2095,10 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with | TacLetIn (l,u) -> let l = List.map (fun (n,c,b) -> (n,option_app (subst_tactic subst) c,subst_tacarg subst b)) l in TacLetIn (l,subst_tactic subst u) - | TacMatchContext (lr,lmr) -> - TacMatchContext(lr, subst_match_rule subst lmr) - | TacMatch (c,lmr) -> - TacMatch (subst_tactic subst c,subst_match_rule subst lmr) + | TacMatchContext (lz,lr,lmr) -> + TacMatchContext(lz,lr, subst_match_rule subst lmr) + | TacMatch (lz,c,lmr) -> + TacMatch (lz,subst_tactic subst c,subst_match_rule subst lmr) | TacId _ | TacFail _ as x -> x | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr) | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s) @@ -2084,6 +2114,7 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2) | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) + | TacComplete tac -> TacComplete (subst_tactic subst tac) | TacArg a -> TacArg (subst_tacarg subst a) and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) @@ -2094,6 +2125,8 @@ and subst_tacarg subst = function | MetaIdArg (_loc,_) -> assert false | TacCall (_loc,f,l) -> TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) + | TacExternal (_loc,com,req,la) -> + TacExternal (_loc,com,req,List.map (subst_tacarg subst) la) | (TacVoid | IntroPattern _ | Integer _ | TacFreshId _) as x -> x | Tacexp t -> Tacexp (subst_tactic subst t) | TacDynamic(_,t) as x -> @@ -2123,7 +2156,7 @@ and subst_genarg subst (x:glob_generic_argument) = | IntroPatternArgType -> in_gen globwit_intro_pattern (out_gen globwit_intro_pattern x) | IdentArgType -> in_gen globwit_ident (out_gen globwit_ident x) - | HypArgType -> in_gen globwit_var (out_gen globwit_var x) + | VarArgType -> in_gen globwit_var (out_gen globwit_var x) | RefArgType -> in_gen globwit_ref (subst_global_reference subst (out_gen globwit_ref x)) @@ -2139,14 +2172,12 @@ and subst_genarg subst (x:glob_generic_argument) = (out_gen globwit_quant_hyp x)) | RedExprArgType -> in_gen globwit_red_expr (subst_redexp subst (out_gen globwit_red_expr x)) - | TacticArgType -> - in_gen globwit_tactic (subst_tactic subst (out_gen globwit_tactic x)) - | OpenConstrArgType -> - in_gen globwit_open_constr - ((),subst_rawconstr subst (snd (out_gen globwit_open_constr x))) - | CastedOpenConstrArgType -> - in_gen globwit_casted_open_constr - ((),subst_rawconstr subst (snd (out_gen globwit_casted_open_constr x))) + | TacticArgType n -> + in_gen (globwit_tactic n) + (subst_tactic subst (out_gen (globwit_tactic n) x)) + | OpenConstrArgType b -> + in_gen (globwit_open_constr_gen b) + ((),subst_rawconstr subst (snd (out_gen (globwit_open_constr_gen b) x))) | ConstrWithBindingsArgType -> in_gen globwit_constr_with_bindings (subst_raw_with_bindings subst (out_gen globwit_constr_with_bindings x)) @@ -2201,6 +2232,17 @@ let (inMD,outMD) = classify_function = (fun (_,o) -> Substitute o); export_function = (fun x -> Some x)} +let print_ltac id = + try + let kn = Nametab.locate_tactic id in + let t = lookup kn in + str "Ltac" ++ spc() ++ pr_qualid id ++ str ":=" ++ spc() ++ + Pptactic.pr_glob_tactic (Global.env ()) t + with + Not_found -> + errorlabstrm "print_ltac" + (pr_qualid id ++ spc() ++ str "is not a user defined tactic") + (* Adds a definition for tactics in the table *) let make_absolute_name (loc,id) = let kn = Lib.make_kn id in @@ -2234,8 +2276,9 @@ let add_tacdef isrec tacl = let glob_tactic x = intern_tactic (make_empty_glob_sign ()) x let glob_tactic_env l env x = - intern_tactic - { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env } + Options.with_option strict_check + (intern_tactic + { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env }) x let interp_redexp env evc r = diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 1f75b5a4..68f6f6ac 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tacinterp.mli,v 1.13.2.1 2004/07/16 19:30:55 herbelin Exp $ i*) +(*i $Id: tacinterp.mli 7841 2006-01-11 11:24:54Z herbelin $ i*) (*i*) open Dyn @@ -19,6 +19,7 @@ open Term open Tacexpr open Genarg open Topconstr +open Mod_subst (*i*) (* Values for interpretation *) @@ -78,7 +79,7 @@ val add_interp_genarg : (glob_sign -> raw_generic_argument -> glob_generic_argument) * (interp_sign -> goal sigma -> glob_generic_argument -> closed_generic_argument) * - (Names.substitution -> glob_generic_argument -> glob_generic_argument) + (substitution -> glob_generic_argument -> glob_generic_argument) -> unit val interp_genarg : @@ -87,20 +88,32 @@ val interp_genarg : val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument +val intern_constr : + glob_sign -> constr_expr -> rawconstr_and_expr + +val intern_hyp : + glob_sign -> identifier Util.located -> identifier Util.located + val subst_genarg : - Names.substitution -> glob_generic_argument -> glob_generic_argument + substitution -> glob_generic_argument -> glob_generic_argument + +val subst_rawconstr_and_expr : + substitution -> rawconstr_and_expr -> rawconstr_and_expr (* Interprets any expression *) val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value (* Interprets redexp arguments *) val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr - -> Tacred.red_expr + -> Redexpr.red_expr (* Interprets tactic expressions *) val interp_tac_gen : (identifier * value) list -> debug_info -> raw_tactic_expr -> tactic +val interp_hyp : interp_sign -> goal sigma -> + identifier Util.located -> identifier + (* Initial call for interpretation *) val glob_tactic : raw_tactic_expr -> glob_tactic_expr @@ -116,11 +129,12 @@ val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr val hide_interp : raw_tactic_expr -> tactic option -> tactic -(* Adds an interpretation function *) -val interp_add : string * (interp_sign -> Coqast.t -> value) -> unit - -(* Adds a possible existing interpretation function *) -val overwriting_interp_add : string * (interp_sign -> Coqast.t -> value) -> - unit +(* Declare the default tactic to fill implicit arguments *) +val declare_implicit_tactic : tactic -> unit +(* Declare the xml printer *) +val declare_xml_printer : + (out_channel -> Environ.env -> Evd.evar_map -> constr -> unit) -> unit +(* printing *) +val print_ltac : Libnames.qualid -> std_ppcmds diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 77898afb..d7bbb2a4 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacticals.ml,v 1.60.2.1 2004/07/16 19:30:55 herbelin Exp $ *) +(* $Id: tacticals.ml 7909 2006-01-21 11:09:18Z herbelin $ *) open Pp open Util @@ -22,6 +22,7 @@ open Libnames open Refiner open Tacmach open Clenv +open Clenvtac open Pattern open Matching open Evar_refiner @@ -90,7 +91,7 @@ let tclLAST_HYP = tclNTH_HYP 1 let tclTRY_sign (tac : constr->tactic) sign gl = let rec arec = function - | [] -> tclFAIL 0 "no applicable hypothesis" + | [] -> tclFAIL 0 (str "no applicable hypothesis") | [s] -> tac (mkVar s) (*added in order to get useful error messages *) | (s::sl) -> tclORELSE (tac (mkVar s)) (arec sl) in @@ -118,15 +119,13 @@ type clause = identifier gclause let allClauses = { onhyps=None; onconcl=true; concl_occs=[] } let allHyps = { onhyps=None; onconcl=false; concl_occs=[] } -let onHyp id = - { onhyps=Some[(id,[],(InHyp, ref None))]; onconcl=false; concl_occs=[] } +let onHyp id = { onhyps=Some[(id,[],InHyp)]; onconcl=false; concl_occs=[] } let onConcl = { onhyps=Some[]; onconcl=true; concl_occs=[] } let simple_clause_list_of cl gls = let hyps = match cl.onhyps with - None -> - List.map (fun id -> Some(id,[],(InHyp,ref None))) (pf_ids_of_hyps gls) + None -> List.map (fun id -> Some(id,[],InHyp)) (pf_ids_of_hyps gls) | Some l -> List.map (fun h -> Some h) l in if cl.onconcl then None::hyps else hyps @@ -134,7 +133,7 @@ let simple_clause_list_of cl gls = (* OR-branch *) let tryClauses tac cl gls = let rec firstrec = function - | [] -> tclFAIL 0 "no applicable hypothesis" + | [] -> tclFAIL 0 (str "no applicable hypothesis") | [cls] -> tac cls (* added in order to get a useful error message *) | cls::tl -> (tclORELSE (tac cls) (firstrec tl)) in @@ -173,8 +172,7 @@ let clause_type cls gl = (* Functions concerning matching of clausal environments *) let pf_is_matching gls pat n = - let (wc,_) = startWalk gls in - is_matching_conv (w_env wc) (w_Underlying wc) pat n + is_matching_conv (pf_env gls) (project gls) pat n let pf_matches gls pat n = matches_conv (pf_env gls) (project gls) pat n @@ -268,9 +266,9 @@ type branch_assumptions = { assums : named_context} (* the list of assumptions introduced *) let compute_induction_names n = function - | None -> + | IntroAnonymous -> Array.make n [] - | Some (IntroOrAndPattern names) when List.length names = n -> + | IntroOrAndPattern names when List.length names = n -> Array.of_list names | _ -> errorlabstrm "" (str "Expects " ++ int n ++ str " lists of names") @@ -288,7 +286,7 @@ let compute_construtor_signatures isrec (_,k as ity) = | _ -> anomaly "compute_construtor_signatures" in let (mib,mip) = Global.lookup_inductive ity in - let n = mip.mind_nparams in + let n = mib.mind_nparams in let lc = Array.map (fun c -> snd (decompose_prod_n_assum n c)) mip.mind_nf_lc in let lrecargs = dest_subterms mip.mind_recargs in @@ -324,23 +322,22 @@ let general_elim_then_using elim isrec allnames tac predicate (indbindings,elimbindings) c gl = let (ity,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in (* applying elimination_scheme just a little modified *) - let (wc,kONT) = startWalk gl in - let indclause = mk_clenv_from wc (c,t) in + let indclause = mk_clenv_from gl (c,t) in let indclause' = clenv_constrain_with_bindings indbindings indclause in - let elimclause = mk_clenv_from () (elim,w_type_of wc elim) in + let elimclause = mk_clenv_from gl (elim,pf_type_of gl elim) in let indmv = - match kind_of_term (last_arg (clenv_template elimclause).rebus) with + match kind_of_term (last_arg elimclause.templval.Evd.rebus) with | Meta mv -> mv | _ -> error "elimination" in let pmv = - let p, _ = decompose_app (clenv_template_type elimclause).rebus in + let p, _ = decompose_app elimclause.templtyp.Evd.rebus in match kind_of_term p with | Meta p -> p | _ -> let name_elim = match kind_of_term elim with - | Const kn -> string_of_kn kn + | Const kn -> string_of_con kn | Var id -> string_of_id id | _ -> "\b" in @@ -351,7 +348,7 @@ let general_elim_then_using let branchsigns = compute_construtor_signatures isrec ity in let brnames = compute_induction_names (Array.length branchsigns) allnames in let after_tac ce i gl = - let (hd,largs) = decompose_app (clenv_template_type ce).rebus in + let (hd,largs) = decompose_app ce.templtyp.Evd.rebus in let ba = { branchsign = branchsigns.(i); branchnames = brnames.(i); nassums = @@ -360,8 +357,8 @@ let general_elim_then_using 0 branchsigns.(i); branchnum = i+1; ity = ity; - largs = List.map (clenv_instance_term ce) largs; - pred = clenv_instance_term ce hd } + largs = List.map (clenv_nf_meta ce) largs; + pred = clenv_nf_meta ce hd } in tac ba gl in @@ -369,9 +366,10 @@ let general_elim_then_using let elimclause' = match predicate with | None -> elimclause' - | Some p -> clenv_assign pmv p elimclause' + | Some p -> + clenv_unify true Reduction.CONV (mkMeta pmv) p elimclause' in - elim_res_pf_THEN_i kONT elimclause' branchtacs gl + elim_res_pf_THEN_i elimclause' branchtacs gl let elimination_then_using tac predicate (indbindings,elimbindings) c gl = @@ -379,7 +377,7 @@ let elimination_then_using tac predicate (indbindings,elimbindings) c gl = let elim = Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) in general_elim_then_using - elim true None tac predicate (indbindings,elimbindings) c gl + elim true IntroAnonymous tac predicate (indbindings,elimbindings) c gl let elimination_then tac = elimination_then_using tac None diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 111a5e2d..7ceddc8b 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -6,9 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tacticals.mli,v 1.38.2.2 2005/01/21 16:41:52 herbelin Exp $ i*) +(*i $Id: tacticals.mli 7909 2006-01-21 11:09:18Z herbelin $ i*) (*i*) +open Pp open Names open Term open Sign @@ -24,7 +25,7 @@ open Tacexpr (* Tacticals i.e. functions from tactics to tactics. *) val tclIDTAC : tactic -val tclIDTAC_MESSAGE : string -> tactic +val tclIDTAC_MESSAGE : std_ppcmds -> tactic val tclORELSE : tactic -> tactic -> tactic val tclTHEN : tactic -> tactic -> tactic val tclTHENSEQ : tactic list -> tactic @@ -46,7 +47,7 @@ val tclTRY : tactic -> tactic val tclINFO : tactic -> tactic val tclCOMPLETE : tactic -> tactic val tclAT_LEAST_ONCE : tactic -> tactic -val tclFAIL : int -> string -> tactic +val tclFAIL : int -> std_ppcmds -> tactic val tclDO : int -> tactic -> tactic val tclPROGRESS : tactic -> tactic val tclWEAK_PROGRESS : tactic -> tactic @@ -129,13 +130,13 @@ type branch_assumptions = { (* Useful for [as intro_pattern] modifier *) val compute_induction_names : - int -> intro_pattern_expr option -> intro_pattern_expr list array + int -> intro_pattern_expr -> intro_pattern_expr list array val elimination_sort_of_goal : goal sigma -> sorts_family val elimination_sort_of_hyp : identifier -> goal sigma -> sorts_family val general_elim_then_using : - constr -> (* isrec: *) bool -> intro_pattern_expr option -> + constr -> (* isrec: *) bool -> intro_pattern_expr -> (branch_args -> tactic) -> constr option -> (arg_bindings * arg_bindings) -> constr -> tactic @@ -148,11 +149,11 @@ val elimination_then : (arg_bindings * arg_bindings) -> constr -> tactic val case_then_using : - intro_pattern_expr option -> (branch_args -> tactic) -> + intro_pattern_expr -> (branch_args -> tactic) -> constr option -> (arg_bindings * arg_bindings) -> constr -> tactic val case_nodep_then_using : - intro_pattern_expr option -> (branch_args -> tactic) -> + intro_pattern_expr -> (branch_args -> tactic) -> constr option -> (arg_bindings * arg_bindings) -> constr -> tactic val simple_elimination_then : diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 2ba09e52..1d97dc4f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tactics.ml,v 1.162.2.7 2005/07/13 16:18:57 herbelin Exp $ *) +(* $Id: tactics.ml 8701 2006-04-12 08:07:35Z courtieu $ *) open Pp open Util @@ -31,6 +31,7 @@ open Proof_type open Logic open Evar_refiner open Clenv +open Clenvtac open Refiner open Tacticals open Hipattern @@ -39,6 +40,8 @@ open Nametab open Genarg open Tacexpr open Decl_kinds +open Evarutil +open Indrec exception Bound @@ -47,7 +50,7 @@ let rec nb_prod x = match kind_of_term c with Prod(_,_,t) -> count (n+1) t | LetIn(_,a,_,t) -> count n (subst1 a t) - | Cast(c,_) -> count n c + | Cast(c,_,_) -> count n c | _ -> n in count 0 x @@ -141,28 +144,24 @@ type tactic_reduction = env -> evar_map -> constr -> constr reduction function either to the conclusion or to a certain hypothesis *) -let reduct_in_concl redfun gl = - convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) gl +let reduct_in_concl (redfun,sty) gl = + convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty gl -let reduct_in_hyp redfun (id,_,(where,where')) gl = +let reduct_in_hyp redfun (id,_,where) gl = let (_,c, ty) = pf_get_hyp gl id in let redfun' = (*under_casts*) (pf_reduce redfun gl) in match c with | None -> if where = InHypValueOnly then errorlabstrm "" (pr_id id ++ str "has no value"); - if Options.do_translate () then where' := Some where; convert_hyp_no_check (id,None,redfun' ty) gl | Some b -> - let where = - if !Options.v7 & where = InHyp then InHypValueOnly else where in let b' = if where <> InHypTypeOnly then redfun' b else b in let ty' = if where <> InHypValueOnly then redfun' ty else ty in - if Options.do_translate () then where' := Some where; convert_hyp_no_check (id,Some b',ty') gl let reduct_option redfun = function - | Some id -> reduct_in_hyp redfun id + | Some id -> reduct_in_hyp (fst redfun) id | None -> reduct_in_concl redfun (* The following tactic determines whether the reduction @@ -182,10 +181,13 @@ let change_and_check cv_pb t env sigma c = (* Use cumulutavity only if changing the conclusion not a subterm *) let change_on_subterm cv_pb t = function | None -> change_and_check cv_pb t - | Some occl -> contextually false occl (change_and_check CONV t) + | Some occl -> contextually false occl (change_and_check Reduction.CONV t) -let change_in_concl occl t = reduct_in_concl (change_on_subterm CUMUL t occl) -let change_in_hyp occl t = reduct_in_hyp (change_on_subterm CONV t occl) +let change_in_concl occl t = + reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast) + +let change_in_hyp occl t = + reduct_in_hyp (change_on_subterm Reduction.CONV t occl) let change_option occl t = function Some id -> change_in_hyp occl t id @@ -200,22 +202,23 @@ let change occl c cls = onClauses (change_option occl c) cls (* Pour usage interne (le niveau User est pris en compte par reduce) *) -let red_in_concl = reduct_in_concl red_product +let red_in_concl = reduct_in_concl (red_product,DEFAULTcast) let red_in_hyp = reduct_in_hyp red_product -let red_option = reduct_option red_product -let hnf_in_concl = reduct_in_concl hnf_constr +let red_option = reduct_option (red_product,DEFAULTcast) +let hnf_in_concl = reduct_in_concl (hnf_constr,DEFAULTcast) let hnf_in_hyp = reduct_in_hyp hnf_constr -let hnf_option = reduct_option hnf_constr -let simpl_in_concl = reduct_in_concl nf +let hnf_option = reduct_option (hnf_constr,DEFAULTcast) +let simpl_in_concl = reduct_in_concl (nf,DEFAULTcast) let simpl_in_hyp = reduct_in_hyp nf -let simpl_option = reduct_option nf -let normalise_in_concl = reduct_in_concl compute +let simpl_option = reduct_option (nf,DEFAULTcast) +let normalise_in_concl = reduct_in_concl (compute,DEFAULTcast) let normalise_in_hyp = reduct_in_hyp compute -let normalise_option = reduct_option compute -let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname) -let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) -let unfold_option loccname = reduct_option (unfoldn loccname) -let pattern_option l = reduct_option (pattern_occs l) +let normalise_option = reduct_option (compute,DEFAULTcast) +let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) +let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,DEFAULTcast) +let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) +let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) +let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast) (* A function which reduces accordingly to a reduction expression, as the command Eval does. *) @@ -228,7 +231,7 @@ let needs_check = function let reduce redexp cl goal = (if needs_check redexp then with_check else (fun x -> x)) - (redin_combinator (reduction_of_redexp redexp) cl) + (redin_combinator (Redexpr.reduction_of_red_expr redexp) cl) goal (* Unfolding occurrences of a constant *) @@ -300,6 +303,8 @@ let intro_force force_flag = intro_gen (IntroAvoid []) None force_flag let intro = intro_force false let introf = intro_force true +let intro_avoiding l = intro_gen (IntroAvoid l) None false + let introf_move_name destopt = intro_gen (IntroAvoid []) destopt true (* For backwards compatibility *) @@ -313,7 +318,7 @@ let rec intros_using = function let intros = tclREPEAT (intro_force false) -let intro_erasing id = tclTHEN (thin [id]) (intro_using id) +let intro_erasing id = tclTHEN (thin [id]) (introduction id) let intros_replacing ids gls = let rec introrec = function @@ -341,7 +346,9 @@ let pf_lookup_hypothesis_as_renamed_gen red h gl = let rec aux ccl = match pf_lookup_hypothesis_as_renamed env ccl h with | None when red -> - aux (reduction_of_redexp (Red true) env (project gl) ccl) + aux + ((fst (Redexpr.reduction_of_red_expr (Red true))) + env (project gl) ccl) | x -> x in try aux (pf_concl gl) @@ -428,7 +435,7 @@ let rec intros_rmove = function * of the type of a term. *) let apply_type hdcty argl gl = - refine (applist (mkCast (mkMeta (new_meta()),hdcty),argl)) gl + refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl let apply_term hdc argl gl = refine (applist (hdc,argl)) gl @@ -438,39 +445,33 @@ let bring_hyps hyps = else (fun gl -> let newcl = List.fold_right mkNamedProd_or_LetIn hyps (pf_concl gl) in - let f = mkCast (mkMeta (new_meta()),newcl) in + let f = mkCast (Evarutil.mk_new_meta(),DEFAULTcast, newcl) in refine_no_check (mkApp (f, instance_from_named_context hyps)) gl) (* Resolution with missing arguments *) let apply_with_bindings (c,lbind) gl = - let apply = - match kind_of_term c with - | Lambda _ -> res_pf_cast - | _ -> res_pf - in - let (wc,kONT) = startWalk 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 thm_ty0 = nf_betaiota (w_type_of wc c) in + let thm_ty0 = nf_betaiota (pf_type_of gl c) in let rec try_apply thm_ty = try let n = nb_prod thm_ty - nb_prod (pf_concl gl) in if n<0 then error "Apply: theorem has not enough premisses."; - let clause = make_clenv_binding_apply wc n (c,thm_ty) lbind in - apply kONT clause gl - with (RefinerError _|UserError _|Failure _) as exn -> + let clause = make_clenv_binding_apply gl n (c,thm_ty) lbind in + Clenvtac.res_pf clause gl + with (Pretype_errors.PretypeError _|RefinerError _|UserError _|Failure _) as exn -> let red_thm = - try red_product (w_env wc) (w_Underlying wc) thm_ty + try red_product (pf_env gl) (project gl) thm_ty with (Redelimination | UserError _) -> raise exn in try_apply red_thm in try try_apply thm_ty0 - with (RefinerError _|UserError _|Failure _) -> + with (Pretype_errors.PretypeError _|RefinerError _|UserError _|Failure _) -> (* Last chance: if the head is a variable, apply may try second order unification *) - let clause = make_clenv_binding_apply wc (-1) (c,thm_ty0) lbind in - apply kONT clause gl + let clause = make_clenv_binding_apply gl (-1) (c,thm_ty0) lbind in + Clenvtac.res_pf clause gl let apply c = apply_with_bindings (c,NoBindings) @@ -481,9 +482,8 @@ let apply_list = function (* Resolution with no reduction on the type *) let apply_without_reduce c gl = - let (wc,kONT) = startWalk gl in - let clause = mk_clenv_type_of wc c in - res_pf kONT clause gl + let clause = mk_clenv_type_of gl c in + res_pf clause gl (* A useful resolution tactic which, if c:A->B, transforms |- C into |- B -> C and |- A @@ -502,6 +502,10 @@ let apply_without_reduce c gl = end. *) +(**************************) +(* Cut tactics *) +(**************************) + let cut_and_apply c gl = let goal_constr = pf_concl gl in match kind_of_term (pf_hnf_constr gl (pf_type_of gl c)) with @@ -511,24 +515,6 @@ let cut_and_apply c gl = (apply_term c [mkMeta (new_meta())]) gl | _ -> error "Imp_elim needs a non-dependent product" -(**************************) -(* Cut tactics *) -(**************************) - -let assert_tac first na c gl = - match kind_of_term (hnf_type_of gl c) with - | Sort s -> - let id = match na with - | Anonymous -> - let d = match s with Prop _ -> "H" | Type _ -> "X" in - fresh_id [] (id_of_string d) gl - | Name id -> id - in - (if first then internal_cut else internal_cut_rev) id c gl - | _ -> error "Not a proposition or a type" - -let true_cut = assert_tac true - let cut c gl = match kind_of_term (hnf_type_of gl c) with | Sort _ -> @@ -541,14 +527,13 @@ let cut c gl = | _ -> error "Not a proposition or a type" let cut_intro t = tclTHENFIRST (cut t) intro - -let cut_replacing id t = - tclTHENFIRST - (cut t) - (tclORELSE + +let cut_replacing id t tac = + tclTHENS (cut t) + [tclORELSE (intro_replacing id) - (tclORELSE (intro_erasing id) - (intro_using id))) + (tclORELSE (intro_erasing id) (intro_using id)); + tac (refine_no_check (mkVar id)) ] let cut_in_parallel l = let rec prec = function @@ -557,226 +542,6 @@ let cut_in_parallel l = in prec (List.rev l) -(**************************) -(* Generalize tactics *) -(**************************) - -let generalize_goal gl c cl = - let t = pf_type_of gl c in - match kind_of_term c with - | Var id -> - (* The choice of remembering or not a non dependent name has an impact - on the future Intro naming strategy! *) - (* if dependent c cl then mkNamedProd id t cl - else mkProd (Anonymous,t,cl) *) - mkNamedProd id t cl - | _ -> - let cl' = subst_term c cl in - if noccurn 1 cl' then - mkProd (Anonymous,t,cl) - (* On ne se casse pas la tete : on prend pour nom de variable - la premiere lettre du type, meme si "ci" est une - constante et qu'on pourrait prendre directement son nom *) - else - prod_name (Global.env()) (Anonymous, t, cl') - -let generalize_dep c gl = - let env = pf_env gl in - let sign = pf_hyps gl in - let init_ids = ids_of_named_context (Global.named_context()) in - let rec seek d toquant = - if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant - or dependent_in_decl c d then - d::toquant - else - toquant in - let to_quantify = Sign.fold_named_context seek sign ~init:[] in - let to_quantify_rev = List.rev to_quantify in - let qhyps = List.map (fun (id,_,_) -> id) to_quantify_rev in - let tothin = List.filter (fun id -> not (List.mem id init_ids)) qhyps in - let tothin' = - match kind_of_term c with - | Var id when mem_named_context id sign & not (List.mem id init_ids) - -> id::tothin - | _ -> tothin - in - let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in - let cl'' = generalize_goal gl c cl' in - let args = Array.to_list (instance_from_named_context to_quantify_rev) in - tclTHEN - (apply_type cl'' (c::args)) - (thin (List.rev tothin')) - gl - -let generalize lconstr gl = - let newcl = List.fold_right (generalize_goal gl) lconstr (pf_concl gl) in - apply_type newcl lconstr gl - -(* 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 -*) - -(* A dependent cut rule à la sequent calculus - ------------------------------------------ - Sera simplifiable le jour où il y aura un let in primitif dans constr - - [letin_tac b na c (occ_hyp,occ_ccl) gl] transforms - [...x1:T1(c),...,x2:T2(c),... |- G(c)] into - [...x:T;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 - - [occ_hyp,occ_ccl] tells which occurrences of [c] have to be substituted; - if [occ_hyp = []] and [occ_ccl = None] then [c] is substituted - wherever it occurs, otherwise [c] is substituted only in hyps - present in [occ_hyps] at the specified occurrences (everywhere if - the list of occurrences is empty), and in the goal at the specified - occurrences if [occ_goal] is not [None]; - - if name = Anonymous, the name is build from the first letter of the type; - - The tactic first quantify the goal over x1, x2,... then substitute then - re-intro x1, x2,... at their initial place ([marks] is internally - used to remember the place of x1, x2, ...: it is the list of hypotheses on - the left of each x1, ...). -*) - - - -let occurrences_of_hyp id cls = - let rec hyp_occ = function - [] -> None - | (id',occs,hl)::_ when id=id' -> Some occs - | _::l -> hyp_occ l in - match cls.onhyps with - None -> Some [] - | Some l -> hyp_occ l - -let occurrences_of_goal cls = - if cls.onconcl then Some cls.concl_occs else None - -let in_every_hyp cls = (cls.onhyps = None) - -(* -(* Implementation with generalisation then re-intro: introduces noise *) -(* in proofs *) - -let letin_abstract id c occs gl = - let env = pf_env gl in - let compute_dependency _ (hyp,_,_ as d) ctxt = - let d' = - try - match occurrences_of_hyp hyp occs with - | None -> raise Not_found - | Some occ -> - let newdecl = subst_term_occ_decl occ c d in - if d = newdecl then - if not (everywhere occs) - then raise (RefinerError (DoesNotOccurIn (c,hyp))) - else raise Not_found - else - (subst1_decl (mkVar id) newdecl, true) - with Not_found -> - (d,List.exists - (fun ((id,_,_),dep) -> dep && occur_var_in_decl env id d) ctxt) - in d'::ctxt - in - let ctxt' = fold_named_context compute_dependency env ~init:[] in - let compute_marks ((depdecls,marks as accu),lhyp) ((hyp,_,_) as d,b) = - if b then ((d::depdecls,(hyp,lhyp)::marks), lhyp) - else (accu, Some hyp) in - let (depdecls,marks),_ = List.fold_left compute_marks (([],[]),None) ctxt' in - let ccl = match occurrences_of_goal occs with - | None -> pf_concl gl - | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl)) - in - (depdecls,marks,ccl) - -let letin_tac with_eq name c occs gl = - let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in - let id = - if name = Anonymous then fresh_id [] x gl else - if not (mem_named_context x (pf_hyps gl)) then x else - error ("The variable "^(string_of_id x)^" is already declared") in - let (depdecls,marks,ccl)= letin_abstract id c occs gl in - let t = pf_type_of gl c in - let tmpcl = List.fold_right mkNamedProd_or_LetIn depdecls ccl in - let args = Array.to_list (instance_from_named_context depdecls) in - let newcl = mkNamedLetIn id c t tmpcl in - let lastlhyp = if marks=[] then None else snd (List.hd marks) in - tclTHENLIST - [ apply_type newcl args; - thin (List.map (fun (id,_,_) -> id) depdecls); - intro_gen (IntroMustBe id) lastlhyp false; - if with_eq then tclIDTAC else thin_body [id]; - intros_move marks ] gl -*) - -(* Implementation without generalisation: abbrev will be lost in hyps in *) -(* in the extracted proof *) - -let letin_abstract id c occs gl = - let env = pf_env gl in - let compute_dependency _ (hyp,_,_ as d) depdecls = - match occurrences_of_hyp hyp occs with - | None -> depdecls - | Some occ -> - let newdecl = subst_term_occ_decl occ c d in - if occ = [] & d = newdecl then - if not (in_every_hyp occs) - then raise (RefinerError (DoesNotOccurIn (c,hyp))) - else depdecls - else - (subst1_decl (mkVar id) newdecl)::depdecls in - let depdecls = fold_named_context compute_dependency env ~init:[] in - let ccl = match occurrences_of_goal occs with - | None -> pf_concl gl - | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl)) in - let lastlhyp = if depdecls = [] then None else Some(pi1(list_last depdecls)) in - (depdecls,lastlhyp,ccl) - -let letin_tac with_eq name c occs gl = - let id = - let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in - if name = Anonymous then fresh_id [] x gl else - if not (mem_named_context x (pf_hyps gl)) then x else - error ("The variable "^(string_of_id x)^" is already declared") in - let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in - let t = Evarutil.refresh_universes (pf_type_of gl c) in - let newcl = mkNamedLetIn id c t ccl in - tclTHENLIST - [ convert_concl_no_check newcl; - intro_gen (IntroMustBe id) lastlhyp true; - if with_eq then tclIDTAC else thin_body [id]; - tclMAP convert_hyp_no_check depdecls ] gl - -let check_hypotheses_occurrences_list env (_,occl) = - let rec check acc = function - | (hyp,_) :: rest -> - if List.mem hyp acc then - error ("Hypothesis "^(string_of_id hyp)^" occurs twice"); - if not (mem_named_context hyp (named_context env)) then - error ("No such hypothesis: " ^ (string_of_id hyp)); - check (hyp::acc) rest - | [] -> () - in check [] occl - -let nowhere = {onhyps=Some[]; onconcl=false; concl_occs=[]} - -(* Tactic Assert (b=false) and Pose (b=true): - the behaviour of Pose is corrected by the translator. - not that of Assert *) -let forward b na c = - let wh = if !Options.v7 && b then onConcl else nowhere in - letin_tac b na c wh - (********************************************************************) (* Exact tactics *) (********************************************************************) @@ -838,9 +603,8 @@ let rec intros_clearing = function (* Adding new hypotheses *) let new_hyp mopt (c,lbind) g = - let (wc,kONT) = startWalk g in - let clause = make_clenv_binding wc (c,w_type_of wc c) lbind in - let (thd,tstack) = whd_stack (clenv_instance_template clause) in + let clause = make_clenv_binding g (c,pf_type_of g c) lbind in + let (thd,tstack) = whd_stack (clenv_value clause) in let nargs = List.length tstack in let cut_pf = applist(thd, @@ -848,10 +612,25 @@ let new_hyp mopt (c,lbind) g = | Some m -> if m < nargs then list_firstn m tstack else tstack | None -> tstack) in - (tclTHENLAST (tclTHEN (kONT clause.hook) + (tclTHENLAST (tclTHEN (tclEVARS (evars_of clause.env)) (cut (pf_type_of g cut_pf))) ((tclORELSE (apply cut_pf) (exact_no_check cut_pf)))) g +(* Keeping only a few hypotheses *) + +let keep hyps gl = + let env = Global.env() in + let ccl = pf_concl gl in + let cl,_ = + fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> + if List.mem hyp hyps + or List.exists (occur_var_in_decl env hyp) keep + or occur_var env hyp ccl + then (clear,decl::keep) + else (hyp::clear,keep)) + ~init:([],[]) (pf_env gl) + in thin cl gl + (************************) (* Introduction tactics *) (************************) @@ -860,8 +639,7 @@ let constructor_tac boundopt i lbind gl = let cl = pf_concl gl in let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in let nconstr = - Array.length (snd (Global.lookup_inductive mind)).mind_consnames - and sigma = project gl in + Array.length (snd (Global.lookup_inductive mind)).mind_consnames in if i=0 then error "The constructors are numbered starting from 1"; if i > nconstr then error "Not enough constructors"; begin match boundopt with @@ -872,7 +650,8 @@ let constructor_tac boundopt i lbind gl = end; let cons = mkConstruct (ith_constructor_of_inductive mind i) in let apply_tac = apply_with_bindings (cons,lbind) in - (tclTHENLIST [convert_concl_no_check redcl; intros; apply_tac]) gl + (tclTHENLIST + [convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) gl let one_constructor i = constructor_tac None i @@ -903,171 +682,413 @@ let simplest_split = split NoBindings (* Elimination tactics *) (********************************************) - -(* kONT : ?? - * wc : ?? - * elimclause : ?? - * inclause : ?? - * gl : the current goal -*) - let last_arg c = match kind_of_term c with - | App (f,cl) -> array_last cl + | App (f,cl) -> + array_last cl | _ -> anomaly "last_arg" -let elimination_clause_scheme kONT elimclause indclause allow_K gl = +let elimination_clause_scheme allow_K elimclause indclause gl = let indmv = - (match kind_of_term (last_arg (clenv_template elimclause).rebus) with + (match kind_of_term (last_arg elimclause.templval.rebus) with | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" (str "The type of elimination clause is not well-formed")) in let elimclause' = clenv_fchain indmv elimclause indclause in - elim_res_pf kONT elimclause' allow_K gl + res_pf elimclause' ~allow_K:allow_K gl + +(* cast added otherwise tactics Case (n1,n2) generates (?f x y) and + * refine fails *) + +let type_clenv_binding wc (c,t) lbind = + clenv_type (make_clenv_binding wc (c,t) lbind) + +(* + * 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 + *) + +let general_elim_clause elimtac (c,lbindc) (elimc,lbindelimc) gl = + let ct = pf_type_of gl c in + let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in + let indclause = make_clenv_binding gl (c,t) lbindc in + let elimt = pf_type_of gl elimc in + let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in + elimtac elimclause indclause gl + +let general_elim c e ?(allow_K=true) = + general_elim_clause (elimination_clause_scheme allow_K) c e + +(* Elimination tactic with bindings but using the default elimination + * constant associated with the type. *) + +let find_eliminator c gl = + let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + lookup_eliminator ind (elimination_sort_of_goal gl) + +let default_elim (c,_ as cx) gl = + general_elim cx (find_eliminator c gl,NoBindings) gl + +let elim_in_context c = function + | Some elim -> general_elim c elim ~allow_K:true + | None -> default_elim c + +let elim (c,lbindc as cx) elim = + match kind_of_term c with + | Var id when lbindc = NoBindings -> + tclTHEN (tclTRY (intros_until_id id)) (elim_in_context cx elim) + | _ -> elim_in_context cx elim + +(* The simplest elimination tactic, with no substitutions at all. *) + +let simplest_elim c = default_elim (c,NoBindings) + +(* Elimination in hypothesis *) + +let elimination_in_clause_scheme id elimclause indclause gl = + let (hypmv,indmv) = + match clenv_independent elimclause with + [k1;k2] -> (k1,k2) + | _ -> errorlabstrm "elimination_clause" + (str "The type of elimination clause is not well-formed") in + let elimclause' = clenv_fchain indmv elimclause indclause in + let hyp = mkVar id in + let hyp_typ = pf_type_of gl hyp in + let hypclause = + mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in + let elimclause'' = clenv_fchain hypmv elimclause' hypclause in + let new_hyp_prf = clenv_value elimclause'' in + let new_hyp_typ = clenv_type elimclause'' in + if eq_constr hyp_typ new_hyp_typ then + errorlabstrm "general_rewrite_in" + (str "Nothing to rewrite in " ++ pr_id id); + tclTHEN + (tclEVARS (evars_of elimclause''.env)) + (cut_replacing id new_hyp_typ + (fun x gls -> refine_no_check new_hyp_prf gls)) gl + +let general_elim_in id = + general_elim_clause (elimination_in_clause_scheme id) + +(* Case analysis tactics *) + +let general_case_analysis_in_context (c,lbindc) gl = + let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + let sort = elimination_sort_of_goal gl in + let case = + if occur_term c (pf_concl gl) then make_case_dep else make_case_gen in + let elim = pf_apply case gl mind sort in + general_elim (c,lbindc) (elim,NoBindings) gl + +let general_case_analysis (c,lbindc as cx) = + match kind_of_term c with + | Var id when lbindc = NoBindings -> + tclTHEN (tclTRY (intros_until_id id)) + (general_case_analysis_in_context cx) + | _ -> + general_case_analysis_in_context cx + +let simplest_case c = general_case_analysis (c,NoBindings) + +(*****************************) +(* Decomposing introductions *) +(*****************************) + +let clear_last = tclLAST_HYP (fun c -> (clear [destVar c])) +let case_last = tclLAST_HYP simplest_case + +let rec explicit_intro_names = function +| (IntroWildcard | IntroAnonymous) :: l -> explicit_intro_names l +| IntroIdentifier id :: l -> id :: explicit_intro_names l +| IntroOrAndPattern ll :: l' -> + List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll) +| [] -> [] + + (* We delay thinning until the completion of the whole intros tactic + to ensure that dependent hypotheses are cleared in the right + dependency order (see bug #1000); we use fresh names, not used in + the tactic, for the hyps to clear *) +let rec intros_patterns avoid thin destopt = function + | IntroWildcard :: l -> + tclTHEN + (intro_gen (IntroAvoid (avoid@explicit_intro_names l)) None true) + (onLastHyp (fun id -> + tclORELSE + (tclTHEN (clear [id]) (intros_patterns avoid thin destopt l)) + (intros_patterns avoid (id::thin) destopt l))) + | IntroIdentifier id :: l -> + tclTHEN + (intro_gen (IntroMustBe id) destopt true) + (intros_patterns avoid thin destopt l) + | IntroAnonymous :: l -> + tclTHEN + (intro_gen (IntroAvoid (avoid@explicit_intro_names l)) destopt true) + (intros_patterns avoid thin destopt l) + | IntroOrAndPattern ll :: l' -> + tclTHEN + introf + (tclTHENS + (tclTHEN case_last clear_last) + (List.map (fun l -> intros_patterns avoid thin destopt (l@l')) ll)) + | [] -> clear thin + +let intros_pattern = intros_patterns [] [] + +let intro_pattern destopt pat = intros_patterns [] [] destopt [pat] + +let intro_patterns = function + | [] -> tclREPEAT intro + | l -> intros_pattern None l + +(**************************) +(* Other cut tactics *) +(**************************) + +let hid = id_of_string "H" +let xid = id_of_string "X" + +let make_id s = fresh_id [] (match s with Prop _ -> hid | Type _ -> xid) + +let prepare_intros s ipat gl = match ipat with + | IntroAnonymous -> make_id s gl, tclIDTAC + | IntroWildcard -> let id = make_id s gl in id, thin [id] + | IntroIdentifier id -> id, tclIDTAC + | IntroOrAndPattern ll -> make_id s gl, + (tclTHENS + (tclTHEN case_last clear_last) + (List.map (intros_pattern None) ll)) + +let ipat_of_name = function + | Anonymous -> IntroAnonymous + | Name id -> IntroIdentifier id + +let assert_as first ipat c gl = + match kind_of_term (hnf_type_of gl c) with + | Sort s -> + let id,tac = prepare_intros s ipat gl in + tclTHENS ((if first then internal_cut else internal_cut_rev) id c) + (if first then [tclIDTAC; tac] else [tac; tclIDTAC]) gl + | _ -> error "Not a proposition or a type" + +let assert_tac first na = assert_as first (ipat_of_name na) +let true_cut = assert_tac true + +(**************************) +(* Generalize tactics *) +(**************************) + +let generalize_goal gl c cl = + let t = pf_type_of gl c in + match kind_of_term c with + | Var id -> + (* The choice of remembering or not a non dependent name has an impact + on the future Intro naming strategy! *) + (* if dependent c cl then mkNamedProd id t cl + else mkProd (Anonymous,t,cl) *) + mkNamedProd id t cl + | _ -> + let cl' = subst_term c cl in + if noccurn 1 cl' then + mkProd (Anonymous,t,cl) + (* On ne se casse pas la tete : on prend pour nom de variable + la premiere lettre du type, meme si "ci" est une + constante et qu'on pourrait prendre directement son nom *) + else + prod_name (Global.env()) (Anonymous, t, cl') + +let generalize_dep c gl = + let env = pf_env gl in + let sign = pf_hyps gl in + let init_ids = ids_of_named_context (Global.named_context()) in + let rec seek d toquant = + if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant + or dependent_in_decl c d then + d::toquant + else + toquant in + let to_quantify = Sign.fold_named_context seek sign ~init:[] in + let to_quantify_rev = List.rev to_quantify in + let qhyps = List.map (fun (id,_,_) -> id) to_quantify_rev in + let tothin = List.filter (fun id -> not (List.mem id init_ids)) qhyps in + let tothin' = + match kind_of_term c with + | Var id when mem_named_context id sign & not (List.mem id init_ids) + -> id::tothin + | _ -> tothin + in + let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in + let cl'' = generalize_goal gl c cl' in + let args = Array.to_list (instance_from_named_context to_quantify_rev) in + tclTHEN + (apply_type cl'' (c::args)) + (thin (List.rev tothin')) + gl + +let generalize lconstr gl = + let newcl = List.fold_right (generalize_goal gl) lconstr (pf_concl gl) in + apply_type newcl lconstr gl + +(* 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 +*) + +(* A dependent cut rule à la sequent calculus + ------------------------------------------ + Sera simplifiable le jour où il y aura un let in primitif dans constr + + [letin_tac b na c (occ_hyp,occ_ccl) gl] transforms + [...x1:T1(c),...,x2:T2(c),... |- G(c)] into + [...x:T;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 -(* cast added otherwise tactics Case (n1,n2) generates (?f x y) and - * refine fails *) + [occ_hyp,occ_ccl] tells which occurrences of [c] have to be substituted; + if [occ_hyp = []] and [occ_ccl = None] then [c] is substituted + wherever it occurs, otherwise [c] is substituted only in hyps + present in [occ_hyps] at the specified occurrences (everywhere if + the list of occurrences is empty), and in the goal at the specified + occurrences if [occ_goal] is not [None]; -let type_clenv_binding wc (c,t) lbind = - clenv_instance_template_type (make_clenv_binding wc (c,t) lbind) + if name = Anonymous, the name is build from the first letter of the type; -(* - * 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 - *) + The tactic first quantify the goal over x1, x2,... then substitute then + re-intro x1, x2,... at their initial place ([marks] is internally + used to remember the place of x1, x2, ...: it is the list of hypotheses on + the left of each x1, ...). +*) -let general_elim (c,lbindc) (elimc,lbindelimc) ?(allow_K=true) gl = - let (wc,kONT) = startWalk gl in - let ct = pf_type_of gl c in - let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in - let indclause = make_clenv_binding wc (c,t) lbindc in - let elimt = w_type_of wc elimc in - let elimclause = make_clenv_binding wc (elimc,elimt) lbindelimc in - elimination_clause_scheme kONT elimclause indclause allow_K gl -(* Elimination tactic with bindings but using the default elimination - * constant associated with the type. *) -let find_eliminator c gl = - let env = pf_env gl in - let (ind,t) = reduce_to_quantified_ind env (project gl) (pf_type_of gl c) in - let s = elimination_sort_of_goal gl in - Indrec.lookup_eliminator ind s -(* with Not_found -> - let dir, base = repr_path (path_of_inductive env ind) in - let id = Indrec.make_elimination_ident base s in - errorlabstrm "default_elim" - (str "Cannot find the elimination combinator :" ++ - pr_id id ++ spc () ++ - str "The elimination of the inductive definition :" ++ - pr_id base ++ spc () ++ str "on sort " ++ - spc () ++ print_sort (new_sort_in_family s) ++ - str " is probably not allowed") -(* lookup_eliminator prints the message *) *) -let default_elim (c,lbindc) gl = - general_elim (c,lbindc) (find_eliminator c gl,NoBindings) gl - -let elim_in_context (c,_ as cx) elim gl = - match elim with - | Some (elimc,lbindelimc) -> general_elim cx (elimc,lbindelimc) gl - | None -> general_elim cx (find_eliminator c gl,NoBindings) gl +let occurrences_of_hyp id cls = + let rec hyp_occ = function + [] -> None + | (id',occs,hl)::_ when id=id' -> Some occs + | _::l -> hyp_occ l in + match cls.onhyps with + None -> Some [] + | Some l -> hyp_occ l -let elim (c,lbindc as cx) elim = - match kind_of_term c with - | Var id when lbindc = NoBindings -> - tclTHEN (tclTRY (intros_until_id id)) (elim_in_context cx elim) - | _ -> elim_in_context cx elim +let occurrences_of_goal cls = + if cls.onconcl then Some cls.concl_occs else None -(* The simplest elimination tactic, with no substitutions at all. *) +let in_every_hyp cls = (cls.onhyps=None) -let simplest_elim c = default_elim (c,NoBindings) +(* +(* Implementation with generalisation then re-intro: introduces noise *) +(* in proofs *) -(* Elimination in hypothesis *) +let letin_abstract id c occs gl = + let env = pf_env gl in + let compute_dependency _ (hyp,_,_ as d) ctxt = + let d' = + try + match occurrences_of_hyp hyp occs with + | None -> raise Not_found + | Some occ -> + let newdecl = subst_term_occ_decl occ c d in + if occ = [] & d = newdecl then + if not (in_every_hyp occs) + then raise (RefinerError (DoesNotOccurIn (c,hyp))) + else raise Not_found + else + (subst1_decl (mkVar id) newdecl, true) + with Not_found -> + (d,List.exists + (fun ((id,_,_),dep) -> dep && occur_var_in_decl env id d) ctxt) + in d'::ctxt + in + let ctxt' = fold_named_context compute_dependency env ~init:[] in + let compute_marks ((depdecls,marks as accu),lhyp) ((hyp,_,_) as d,b) = + if b then ((d::depdecls,(hyp,lhyp)::marks), lhyp) + else (accu, Some hyp) in + let (depdecls,marks),_ = List.fold_left compute_marks (([],[]),None) ctxt' in + let ccl = match occurrences_of_goal occs with + | None -> pf_concl gl + | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl)) + in + (depdecls,marks,ccl) -let elimination_in_clause_scheme kONT id elimclause indclause = - let (hypmv,indmv) = - match clenv_independent elimclause with - [k1;k2] -> (k1,k2) - | _ -> errorlabstrm "elimination_clause" - (str "The type of elimination clause is not well-formed") in - let elimclause' = clenv_fchain indmv elimclause indclause in - let hyp = mkVar id in - let hyp_typ = clenv_type_of elimclause' hyp in - let hypclause = - mk_clenv_from_n elimclause'.hook (Some 0) (hyp, hyp_typ) in - let elimclause'' = clenv_fchain hypmv elimclause' hypclause in - let new_hyp_prf = clenv_instance_template elimclause'' in - let new_hyp_typ = clenv_instance_template_type elimclause'' in - if eq_constr hyp_typ new_hyp_typ then - errorlabstrm "general_rewrite_in" - (str "Nothing to rewrite in " ++ pr_id id); - tclTHEN - (kONT elimclause''.hook) - (tclTHENS - (cut new_hyp_typ) - [ (* Try to insert the new hyp at the same place *) - tclORELSE (intro_replacing id) - (tclTHEN (clear [id]) (introduction id)); - refine_no_check new_hyp_prf]) - -let general_elim_in id (c,lbindc) (elimc,lbindelimc) gl = - let (wc,kONT) = startWalk gl in - let ct = pf_type_of gl c in - let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in - let indclause = make_clenv_binding wc (c,t) lbindc in - let elimt = w_type_of wc elimc in - let elimclause = make_clenv_binding wc (elimc,elimt) lbindelimc in - elimination_in_clause_scheme kONT id elimclause indclause gl +let letin_tac with_eq name c occs gl = + let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in + let id = + if name = Anonymous then fresh_id [] x gl else + if not (mem_named_context x (pf_hyps gl)) then x else + error ("The variable "^(string_of_id x)^" is already declared") in + let (depdecls,marks,ccl)= letin_abstract id c occs gl in + let t = pf_type_of gl c in + let tmpcl = List.fold_right mkNamedProd_or_LetIn depdecls ccl in + let args = Array.to_list (instance_from_named_context depdecls) in + let newcl = mkNamedLetIn id c t tmpcl in + let lastlhyp = if marks=[] then None else snd (List.hd marks) in + tclTHENLIST + [ apply_type newcl args; + thin (List.map (fun (id,_,_) -> id) depdecls); + intro_gen (IntroMustBe id) lastlhyp false; + if with_eq then tclIDTAC else thin_body [id]; + intros_move marks ] gl +*) -(* Case analysis tactics *) +(* Implementation without generalisation: abbrev will be lost in hyps in *) +(* in the extracted proof *) -let general_case_analysis_in_context (c,lbindc) gl = +let letin_abstract id c occs gl = let env = pf_env gl in - let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in - let sigma = project gl in - let sort = elimination_sort_of_goal gl in - let case = if occur_term c (pf_concl gl) then Indrec.make_case_dep - else Indrec.make_case_gen in - let elim = case env sigma mind sort in - general_elim (c,lbindc) (elim,NoBindings) gl - -let general_case_analysis (c,lbindc as cx) = - match kind_of_term c with - | Var id when lbindc = NoBindings -> - tclTHEN (tclTRY (intros_until_id id)) - (general_case_analysis_in_context cx) - | _ -> - general_case_analysis_in_context cx + let compute_dependency _ (hyp,_,_ as d) depdecls = + match occurrences_of_hyp hyp occs with + | None -> depdecls + | Some occ -> + let newdecl = subst_term_occ_decl occ c d in + if occ = [] & d = newdecl then + if not (in_every_hyp occs) + then raise (RefinerError (DoesNotOccurIn (c,hyp))) + else depdecls + else + (subst1_decl (mkVar id) newdecl)::depdecls in + let depdecls = fold_named_context compute_dependency env ~init:[] in + let ccl = match occurrences_of_goal occs with + | None -> pf_concl gl + | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl)) in + let lastlhyp = if depdecls = [] then None else Some(pi1(list_last depdecls)) in + (depdecls,lastlhyp,ccl) -let simplest_case c = general_case_analysis (c,NoBindings) +let letin_tac with_eq name c occs gl = + let id = + let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in + if name = Anonymous then fresh_id [] x gl else + if not (mem_named_context x (pf_hyps gl)) then x else + error ("The variable "^(string_of_id x)^" is already declared") in + let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in + let t = refresh_universes (pf_type_of gl c) in + let newcl = mkNamedLetIn id c t ccl in + tclTHENLIST + [ convert_concl_no_check newcl DEFAULTcast; + intro_gen (IntroMustBe id) lastlhyp true; + if with_eq then tclIDTAC else thin_body [id]; + tclMAP convert_hyp_no_check depdecls ] gl + +(* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *) +let forward usetac ipat c gl = + match usetac with + | None -> + let t = refresh_universes (pf_type_of gl c) in + tclTHENS (assert_as true ipat t) [exact_no_check c; tclIDTAC] gl + | Some tac -> + tclTHENS (assert_as true ipat c) [tac; tclIDTAC] gl (*****************************) -(* Decomposing introductions *) +(* High-level induction *) (*****************************) -let clear_last = tclLAST_HYP (fun c -> (clear [destVar c])) -let case_last = tclLAST_HYP simplest_case - -let rec intro_pattern destopt = function - | IntroWildcard -> - tclTHEN intro clear_last - | IntroIdentifier id -> - intro_gen (IntroMustBe id) destopt true - | IntroOrAndPattern l -> - tclTHEN introf - (tclTHENS - (tclTHEN case_last clear_last) - (List.map (intros_pattern destopt) l)) - -and intros_pattern destopt l = tclMAP (intro_pattern destopt) l - -let intro_patterns = function - | [] -> tclREPEAT intro - | l -> intros_pattern None l - (* * A "natural" induction tactic * @@ -1100,20 +1121,12 @@ let intro_patterns = function *) -let rec str_intro_pattern = function - | IntroOrAndPattern pll -> - "["^(String.concat "|" - (List.map - (fun pl -> String.concat " " (List.map str_intro_pattern pl)) pll)) - ^"]" - | IntroWildcard -> "_" - | IntroIdentifier id -> string_of_id id - let check_unused_names names = if names <> [] & Options.is_verbose () then let s = if List.tl names = [] then " " else "s " in - let names = String.concat " " (List.map str_intro_pattern names) in - warning ("Unused introduction pattern"^s^": "^names) + msg_warning + (str"Unused introduction pattern" ++ str s ++ + str": " ++ prlist_with_sep spc pr_intro_pattern names) let rec first_name_buggy = function | IntroOrAndPattern [] -> None @@ -1121,100 +1134,48 @@ let rec first_name_buggy = function | IntroOrAndPattern ((p::_)::_) -> first_name_buggy p | IntroWildcard -> None | IntroIdentifier id -> Some id + | IntroAnonymous -> assert false + +let consume_pattern avoid id gl = function + | [] -> (IntroIdentifier (fresh_id avoid id gl), []) + | IntroAnonymous::names -> + let avoid = avoid@explicit_intro_names names in + (IntroIdentifier (fresh_id avoid id gl), names) + | pat::names -> (pat,names) type elim_arg_kind = RecArg | IndArg | OtherArg -let induct_discharge statuslists destopt avoid' ((avoid7,avoid8),ra) (names,force,rnames) gl = - let avoid7 = avoid7 @ avoid' in - let avoid8 = avoid8 @ avoid' in +let induct_discharge statuslists destopt avoid' (avoid,ra) names gl = + let avoid = avoid @ avoid' in let (lstatus,rstatus) = statuslists in let tophyp = ref None in let rec peel_tac ra names gl = match ra with - | (RecArg,(recvarname7,recvarname8)) :: - (IndArg,(hyprecname7,hyprecname8)) :: ra' -> - let recpat,hyprec,names = match names with - | [] -> - let idrec7 = (fresh_id avoid7 recvarname7 gl) in - let idrec8 = (fresh_id avoid8 recvarname8 gl) in - let idhyp7 = (fresh_id avoid7 hyprecname7 gl) in - let idhyp8 = (fresh_id avoid8 hyprecname8 gl) in - if Options.do_translate() & - (idrec7 <> idrec8 or idhyp7 <> idhyp8) - then force := true; - let idrec = if !Options.v7 then idrec7 else idrec8 in - let idhyp = if !Options.v7 then idhyp7 else idhyp8 in - (IntroIdentifier idrec, IntroIdentifier idhyp, []) + | (RecArg,recvarname) :: + (IndArg,hyprecname) :: ra' -> + let recpat,names = match names with | [IntroIdentifier id as pat] -> - let id7 = next_ident_away (add_prefix "IH" id) avoid7 in - let id8 = next_ident_away (add_prefix "IH" id) avoid8 in - if Options.do_translate() & id7 <> id8 then force := true; - let id = if !Options.v7 then id7 else id8 in - (pat, IntroIdentifier id, []) - | [pat] -> - let idhyp7 = (fresh_id avoid7 hyprecname7 gl) in - let idhyp8 = (fresh_id avoid8 hyprecname8 gl) in - if Options.do_translate() & idhyp7 <> idhyp8 then force := true; - let idhyp = if !Options.v7 then idhyp7 else idhyp8 in - (pat, IntroIdentifier idhyp, []) - | pat1::pat2::names -> (pat1,pat2,names) in + let id = next_ident_away (add_prefix "IH" id) avoid in + (pat, [IntroIdentifier id]) + | _ -> consume_pattern avoid recvarname gl names in + let hyprec,names = consume_pattern avoid hyprecname gl names in (* This is buggy for intro-or-patterns with different first hypnames *) if !tophyp=None then tophyp := first_name_buggy hyprec; - rnames := !rnames @ [recpat; hyprec]; tclTHENLIST - [ intros_pattern destopt [recpat]; - intros_pattern None [hyprec]; + [ intros_patterns avoid [] destopt [recpat]; + intros_patterns avoid [] None [hyprec]; peel_tac ra' names ] gl - | (IndArg,(hyprecname7,hyprecname8)) :: ra' -> + | (IndArg,hyprecname) :: ra' -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) - let pat,names = match names with - | [] -> IntroIdentifier (fresh_id avoid8 hyprecname8 gl), [] - | pat::names -> pat,names in - rnames := !rnames @ [pat]; - tclTHEN (intros_pattern destopt [pat]) (peel_tac ra' names) gl - | (RecArg,(recvarname7,recvarname8)) :: ra' -> - let introtac,names = match names with - | [] -> - let id8 = fresh_id avoid8 recvarname8 gl in - let i = - if !Options.v7 then IntroAvoid avoid7 else IntroMustBe id8 - in - (* For translator *) - let id7 = fresh_id avoid7 (default_id gl - (match kind_of_term (pf_concl gl) with - | Prod (name,t,_) -> (name,None,t) - | LetIn (name,b,t,_) -> (name,Some b,t) - | _ -> raise (RefinerError IntroNeedsProduct))) gl in - if Options.do_translate() & id7 <> id8 then force := true; - let id = if !Options.v7 then id7 else id8 in - rnames := !rnames @ [IntroIdentifier id]; - intro_gen i destopt false, [] - | pat::names -> - rnames := !rnames @ [pat]; - intros_pattern destopt [pat],names in - tclTHEN introtac (peel_tac ra' names) gl + let pat,names = consume_pattern avoid hyprecname gl names in + tclTHEN (intros_patterns avoid [] destopt [pat]) (peel_tac ra' names) gl + | (RecArg,recvarname) :: ra' -> + let pat,names = consume_pattern avoid recvarname gl names in + tclTHEN (intros_patterns avoid [] destopt [pat]) (peel_tac ra' names) gl | (OtherArg,_) :: ra' -> - let introtac,names = match names with - | [] -> - (* For translator *) - let id7 = fresh_id avoid7 (default_id gl - (match kind_of_term (pf_concl gl) with - | Prod (name,t,_) -> (name,None,t) - | LetIn (name,b,t,_) -> (name,Some b,t) - | _ -> raise (RefinerError IntroNeedsProduct))) gl in - let id8 = fresh_id avoid8 (default_id gl - (match kind_of_term (pf_concl gl) with - | Prod (name,t,_) -> (name,None,t) - | LetIn (name,b,t,_) -> (name,Some b,t) - | _ -> raise (RefinerError IntroNeedsProduct))) gl in - if Options.do_translate() & id7 <> id8 then force := true; - let id = if !Options.v7 then id7 else id8 in - let avoid = if !Options.v7 then avoid7 else avoid8 in - rnames := !rnames @ [IntroIdentifier id]; - intro_gen (IntroAvoid avoid) destopt false, [] - | pat::names -> - rnames := !rnames @ [pat]; - intros_pattern destopt [pat],names in - tclTHEN introtac (peel_tac ra' names) gl + let pat,names = match names with + | [] -> IntroAnonymous, [] + | pat::names -> pat,names in + tclTHEN (intros_patterns avoid [] destopt [pat]) (peel_tac ra' names) gl | [] -> check_unused_names names; tclIDTAC gl @@ -1335,11 +1296,25 @@ let find_atomic_param_of_ind nparams indtyp = would have posed no problem. But for uniformity, we decided to use the right hyp for all hyps on the right of H4. - Others solutions are welcome *) + Others 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 identifier option -let cook_sign hyp0 indvars env = +let cook_sign hyp0_opt indvars_init env = + let hyp0,indvars = + match hyp0_opt with + | None -> List.hd (List.rev indvars_init) , indvars_init + | Some h -> h,indvars_init in (* First phase from L to R: get [indhyps], [decldep] and [statuslist] for the hypotheses before (= more ancient than) hyp0 (see above) *) let allindhyps = hyp0::indvars in @@ -1352,6 +1327,9 @@ let cook_sign hyp0 indvars env = let seek_deps env (hyp,_,_ as decl) rhyp = if hyp = hyp0 then begin before:=false; + (* If there was no main induction hypotheses, then hyp is one of + indvars too, so add it to indhyps. *) + (if hyp0_opt=None then indhyps := hyp::!indhyps); None (* fake value *) end else if List.mem hyp indvars then begin (* warning: hyp can still occur after induction *) @@ -1374,7 +1352,7 @@ let cook_sign hyp0 indvars env = in let _ = fold_named_context seek_deps env ~init:None in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) - let compute_lstatus lhyp (hyp,_,_ as d) = + let compute_lstatus lhyp (hyp,_,_) = if hyp = hyp0 then raise (Shunt lhyp); if List.mem hyp !ldeps then begin lstatus := (hyp,lhyp)::!lstatus; @@ -1384,49 +1362,89 @@ let cook_sign hyp0 indvars env = in try let _ = fold_named_context_reverse compute_lstatus ~init:None env in - anomaly "hyp0 not found" +(* anomaly "hyp0 not found" *) + raise (Shunt (None)) (* ?? FIXME *) with Shunt lhyp0 -> let statuslists = (!lstatus,List.rev !rstatus) in - (statuslists, lhyp0, !indhyps, !decldeps) + (statuslists, (if hyp0_opt=None then None else lhyp0) , !indhyps, !decldeps) + -let induction_tac varname typ ((elimc,lbindelimc),elimt) gl = +(* + 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: (Term.constr * constr Rawterm.bindings) option; + elimt: types; + indref: global_reference 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; + } + + +(* Unification between ((elimc:elimt) ?i ?j ?k ?l ... ?m) and the + hypothesis on which the induction is made *) +let induction_tac varname typ scheme (*(elimc,lbindelimc),elimt*) gl = + let elimc,lbindelimc = + match scheme.elimc with | Some x -> x | None -> error "No definition of the principle" in + let elimt = scheme.elimt in let c = mkVar varname in - let (wc,kONT) = startWalk gl in - let indclause = make_clenv_binding wc (c,typ) NoBindings in + let indclause = make_clenv_binding gl (c,typ) NoBindings in let elimclause = - make_clenv_binding wc (mkCast (elimc,elimt),elimt) lbindelimc in - elimination_clause_scheme kONT elimclause indclause true gl - -let make_up_names7 n ind (old_style,cname) = - if old_style (* = V6.3 version of Induction on hypotheses *) - then - let recvarname = - if n=1 then - cname - else (* To force renumbering if there is only one *) - make_ident (string_of_id cname ) (Some 1) in - recvarname, add_prefix "Hrec" recvarname, [] - else - let is_hyp = atompart_of_id cname = "H" in - let hyprecname = - add_prefix "IH" (if is_hyp then Nametab.id_of_global ind else cname) in - let avoid = - if n=1 (* Only one recursive argument *) - or - (* Rem: no recursive argument (especially if Destruct) *) - n=0 (* & atompart_of_id cname <> "H" (* for 7.1 compatibility *)*) - then [] - else - (* Forbid to use cname, cname0, hyprecname and hyprecname0 *) - (* in order to get names such as f1, f2, ... *) - let avoid = - (make_ident (string_of_id cname) (Some 0)) ::(*here for 7.1 cmpat*) - (make_ident (string_of_id hyprecname) None) :: - (make_ident (string_of_id hyprecname) (Some 0)) :: [] in - if atompart_of_id cname <> "H" then - (make_ident (string_of_id cname) None) :: avoid - else avoid in - cname, hyprecname, avoid + make_clenv_binding gl + (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in + elimination_clause_scheme true elimclause indclause gl let make_base n id = if n=0 or n=1 then id @@ -1435,12 +1453,19 @@ let make_base n id = (* digits *) id_of_string (atompart_of_id (make_ident (string_of_id id) (Some 0))) -let make_up_names8 n ind (_,cname) = +(* Builds tw 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 HIi where i is a number. *) +let make_up_names n ind_opt cname = let is_hyp = atompart_of_id cname = "H" in let base = string_of_id (make_base n cname) in - let hyprecname = - add_prefix "IH" - (make_base n (if is_hyp then Nametab.id_of_global ind else cname)) in + let base_ind = + if is_hyp then + match ind_opt with + | None -> id_of_string "" + | Some ind_id -> Nametab.id_of_global ind_id + else cname in + let hyprecname = add_prefix "IH" (make_base n base_ind) in let avoid = if n=1 (* Only one recursive argument *) or n=0 then [] else @@ -1475,109 +1500,432 @@ let error_ind_scheme s = let s = if s <> "" then s^" " else s in error ("Cannot recognise "^s^"an induction schema") + + + +let occur_rel n c = + let res = not (noccurn n c) in + res + +let list_filter_firsts f l = + let rec list_filter_firsts_aux f acc l = + match l with + | e::l' when f e -> list_filter_firsts_aux f (acc@[e]) l' + | _ -> acc,l + in + list_filter_firsts_aux f [] l + +let count_rels_from n c = + let rels = free_rels c in + let cpt,rg = ref 0, ref n in + while Intset.mem !rg rels do + cpt:= !cpt+1; rg:= !rg+1; + done; + !cpt + +let count_nonfree_rels_from n c = + let rels = free_rels c in + if Intset.exists (fun x -> x >= n) rels then + let cpt,rg = ref 0, ref n in + while not (Intset.mem !rg rels) do + cpt:= !cpt+1; rg:= !rg+1; + done; + !cpt + else raise Not_found + + +(* cuts a list in two parts, first of size n. Size must be greater than n *) +let cut_list n l = + let rec cut_list_aux acc n l = + if n<=0 then acc,l + else match l with + | [] -> assert false + | e::l' -> cut_list_aux (acc@[e]) (n-1) l' in + let res = cut_list_aux [] n l in + res + + +(* This functions splits the products of the induction scheme [elimt] in three + 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 elimt = + let rec cut_noccur elimt acc2 : rel_context * rel_context * types = + match kind_of_term elimt with + | Prod(nme,tpe,elimt') -> + let hd_tpe,_ = decompose_app (snd (decompose_prod_assum tpe)) in + if not (occur_rel 1 elimt') && isRel hd_tpe + then cut_noccur elimt' ((nme,None,tpe)::acc2) + else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl + | App(_, _) | Rel _ -> acc2 , [] , elimt + | _ -> error "cannot recognise an induction schema" in + let rec cut_occur elimt acc1 : rel_context * rel_context * rel_context * types = + match kind_of_term elimt with + | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c ((nme,None,tpe)::acc1) + | Prod(nme,tpe,c) -> let acc2,acc3,ccl = cut_noccur elimt [] in acc1,acc2,acc3,ccl + | App(_, _) | Rel _ -> acc1,[],[],elimt + | _ -> error "cannot recognise an induction schema" 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. *) + if List.length acc2 <> 0 then acc1, acc2 , acc3, ccl + else + let hyps,ccl = decompose_prod_assum elimt in + let hd_ccl_pred,_ = decompose_app ccl in + match kind_of_term hd_ccl_pred with + | Rel i -> let acc3,acc1 = cut_list (i-1) hyps in acc1 , [] , acc3 , ccl + | _ -> error "cannot recognize an induction schema" + + + +let exchange_hd_app subst_hd t = + let hd,args= decompose_app t in mkApp (subst_hd,Array.of_list args) + + +exception NoLastArg +exception NoLastArgCcl + +(* Builds an elim_scheme frome 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 ?elimc elimt = + let params_preds,branches,args_indargs,conclusion = + decompose_paramspred_branch_args elimt in + + let ccl = exchange_hd_app (mkVar (id_of_string "__QI_DUMMY__")) conclusion in + let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in + let nparams = Intset.cardinal (free_rels concl_with_args) in + let preds,params = cut_list (List.length params_preds - nparams) params_preds in + + (* A first approximation, further anlysis 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 = (try isApp (last_arg ccl) with _ -> false); + 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 !res.nargs=0 then raise Exit; + (* 3- Look at last arg: is it the indarg? *) + ignore ( + match List.hd args_indargs with + | hiname,Some _,hi -> error "cannot recognize an induction schema" + | hiname,None,hi -> + let hi_ind, hi_args = decompose_app hi in + let hi_is_ind = (* hi est d'un type inductif *) + match kind_of_term hi_ind with | Ind (mind,_) -> true | _ -> false in + let hi_args_enough = (* hi a le bon nbre d'arguments *) + 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 1 ccl; + args = List.tl !res.args; nargs = !res.nargs - 1; + }; + raise Exit); + raise Exit(* exit anyway *) + with Exit -> (* Ending by computing indrev: *) + match !res.indarg with + | None -> !res (* No indref *) + | Some ( _,Some _,_) -> error "Cannot recognise an induction scheme" + | Some ( _,None,ind) -> + let indhd,indargs = decompose_app ind in + try {!res with indref = Some (global_of_constr indhd) } + with _ -> error "Cannot find the inductive type of the inductive schema";; + (* Check that the elimination scheme has a form similar to the - elimination schemes built by Coq *) -let compute_elim_signature elimt names_info = - let nparams = ref 0 in - let hyps,ccl = decompose_prod_assum elimt in - let n = List.length hyps in - if n = 0 then error_ind_scheme ""; - let f,l = decompose_app ccl in - let _,indbody,ind = List.hd hyps in - if indbody <> None then error "Cannot recognise an induction scheme"; - let nargs = List.length l in - let dep = (nargs >= 1 && list_last l = mkRel 1) in - let nrealargs = if dep then nargs-1 else nargs in - let args = if dep then list_firstn nrealargs l else l in - let realargs,hyps1 = chop_context nrealargs (List.tl hyps) in - if args <> extended_rel_list 1 realargs then - error_ind_scheme "the conclusion of"; - let indhd,indargs = decompose_app ind in - let indt = - try reference_of_constr indhd - with _ -> error "Cannot find the inductive type of the inductive schema" in - let nparams = List.length indargs - nrealargs in - let revparams, revhyps2 = chop_context nparams (List.rev hyps1) in - let rec check_elim npred = function - | (na,None,t)::l when isSort (snd (decompose_prod_assum t)) -> - check_elim (npred+1) l - | l -> - let is_pred n c = - let hd = fst (decompose_app c) in match kind_of_term hd with - | Rel q when n < q & q <= n+npred -> IndArg - | _ when hd = indhd -> RecArg - | _ -> OtherArg in - let rec check_branch p c = match kind_of_term c with - | Prod (_,t,c) -> is_pred p t :: check_branch (p+1) c - | LetIn (_,_,_,c) -> OtherArg :: check_branch (p+1) c -(* | App (f,_) when is_pred p f = IndArg -> []*) - | _ when is_pred p c = IndArg -> [] - | _ -> raise Exit in - let rec find_branches p = function - | (_,None,t)::brs -> - (match try Some (check_branch p t) with Exit -> None with - | Some l -> - let n7 = List.fold_left - (fun n b -> if b=IndArg then n+1 else n) 0 l in - let n8 = List.fold_left - (fun n b -> if b=RecArg then n+1 else n) 0 l in - let recvarname7, hyprecname7, avoid7 = make_up_names7 n7 indt names_info in - let recvarname8, hyprecname8, avoid8 = make_up_names8 n8 indt names_info in - let namesign = List.map - (fun b -> (b,if b=IndArg then (hyprecname7,hyprecname8) - else (recvarname7,recvarname8))) l in - ((avoid7,avoid8),namesign) :: find_branches (p+1) brs - | None -> error_ind_scheme "the branches of") - | (_,Some _,_)::_ -> error_ind_scheme "the branches of" - | [] -> - (* Check again conclusion *) - let ccl_arg_ok = is_pred (p + List.length realargs + 1) f = IndArg in - let ind_is_ok = - list_lastn nrealargs indargs = extended_rel_list 0 realargs in - if not (ccl_arg_ok & ind_is_ok) then - error "Cannot recognize the conclusion of an induction schema"; - [] in - find_branches 0 l in - nparams, indt, (Array.of_list (check_elim 0 revhyps2)) - -let find_elim_signature isrec style elim hyp0 gl = + 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 elimc elimt names_info = + let scheme = compute_elim_sig ~elimc:elimc elimt in + let f,l = decompose_app scheme.concl in + (* Vérifier que les arguments de Qi sont bien les xi. *) + match scheme.indarg with + | Some (_,Some _,_) -> error "strange letin, cannot recognize an induction schema" + | None -> (* Non standard scheme *) + let npred = List.length scheme.predicates in + let is_pred n c = + let hd = fst (decompose_app c) in match kind_of_term hd with + | Rel q when n < q & q <= n+npred -> IndArg + | _ -> OtherArg in + let rec check_branch p c = + match kind_of_term c with + | Prod (_,t,c) -> is_pred p t :: check_branch (p+1) c + | LetIn (_,_,_,c) -> OtherArg :: check_branch (p+1) c + | _ when is_pred p c = IndArg -> [] + | _ -> raise Exit in + let rec find_branches p lbrch = + match lbrch with + | (_,None,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 -> (b,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") + | (_,Some _,_)::_ -> error_ind_scheme "the branches of" + | [] -> [] in + let indsign = Array.of_list (find_branches 0 (List.rev scheme.branches)) in + indsign,scheme + + | Some ( _,None,ind) -> (* Standard scheme from an inductive type *) + let indhd,indargs = decompose_app ind in + let npred = List.length scheme.predicates in + let is_pred n c = + let hd = fst (decompose_app c) in match kind_of_term hd with + | Rel q when n < q & q <= n+npred -> IndArg + | _ when hd = indhd -> RecArg + | _ -> OtherArg in + let rec check_branch p c = match kind_of_term c with + | Prod (_,t,c) -> is_pred p t :: check_branch (p+1) c + | LetIn (_,_,_,c) -> OtherArg :: check_branch (p+1) c + | _ when is_pred p c = IndArg -> [] + | _ -> raise Exit in + let rec find_branches p lbrch = + match lbrch with + | (_,None,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 -> (b,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") + | (_,Some _,_)::_ -> error_ind_scheme "the branches of" + | [] -> + (* Check again conclusion *) + + let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f = IndArg in + let ind_is_ok = + list_lastn scheme.nargs indargs + = extended_rel_list 0 scheme.args in + if not (ccl_arg_ok & ind_is_ok) then + error "Cannot recognize the conclusion of an induction schema"; + [] + in + let indsign = Array.of_list (find_branches 0 (List.rev scheme.branches)) in + indsign,scheme + + +let find_elim_signature isrec elim hyp0 gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let (elimc,elimt) = match elim with | None -> let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in let s = elimination_sort_of_goal gl in let elimc = - if isrec then Indrec.lookup_eliminator mind s - else pf_apply Indrec.make_case_gen gl mind s in + if isrec then lookup_eliminator mind s + else pf_apply make_case_gen gl mind s in let elimt = pf_type_of gl elimc in ((elimc, NoBindings), elimt) | Some (elimc,lbind as e) -> (e, pf_type_of gl elimc) in - let name_info = (style,hyp0) in - let nparams,indref,indsign = compute_elim_signature elimt name_info in - (elimc,elimt,nparams,indref,indsign) + let indsign,elim_scheme = compute_elim_signature elimc elimt hyp0 in + (indsign,elim_scheme) + + +let mapi f l = + let rec mapi_aux f i l = + match l with + | [] -> [] + | e::l' -> f e i :: mapi_aux f (i+1) l' in + mapi_aux f 0 l + + +(* Instanciate 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 scheme lid elimclause gl = + let _,arr = destApp elimclause.templval.rebus in + let lindmv = + Array.map + (fun x -> + match kind_of_term x with + | Meta mv -> mv + | _ -> errorlabstrm "elimination_clause" + (str "The type of elimination clause is not well-formed")) + arr in + let nmv = Array.length lindmv in + let lidparams,lidargs = cut_list (scheme.nparams) lid in + let nidargs = List.length lidargs in + (* parameters correspond to first elts of lid. *) + let clauses_params = + mapi (fun id i -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i)) lidparams in + (* arguments correspond to last elts of lid. *) + let clauses_args = + mapi + (fun id i -> mkVar id , pf_get_hyp_typ gl id , lindmv.(nmv-nidargs+i)) + lidargs in + let clause_indarg = + match scheme.indarg with + | None -> [] + | Some (x,_,typx) -> [] + in + let clauses = clauses_params@clauses_args@clause_indarg 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 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_felim indvars (* (elimc,lbindelimc) elimt *) scheme gl = + let elimt = scheme.elimt in + let elimc,lbindelimc = + match scheme.elimc with | Some x -> x | None -> error "No definition of the principle" in + (* elimclause contains this: (elimc ?i ?j ?k...?l) *) + let elimclause = + make_clenv_binding gl (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in + (* elimclause' is built from elimclause by instanciating all args and params. *) + let elimclause' = recolle_clenv scheme indvars elimclause gl in + (* one last resolution (useless?) *) + let resolved = clenv_unique_resolver true elimclause' gl in + clenv_refine resolved gl + +(* Induction with several induction arguments, main differences with + induction_from_context is that there is no main induction argument, + so we chose one to be the positioning reference. 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_felim + FIXME: REUNIF AVEC induction_tac_felim? *) +let induction_from_context_l isrec elim_info lid names gl = + let indsign,scheme = elim_info in + (* number of all args, counting farg and indarg if present. *) + let nargs_indarg_farg = scheme.nargs + + (if scheme.farg_in_concl then 1 else 0) + + (if scheme.indarg <> None then 1 else 0) in + (* Number of given induction args must be exact. *) + if List.length lid <> nargs_indarg_farg + scheme.nparams then + error "not the right number of arguments given to induction scheme"; + let env = pf_env gl in + (* hyp0 is used for re-introducing hyps at the right place afterward. + We chose the first element of the list of variables on which to + induct. It is probably the first of them appearing in the + context. *) + let hyp0,indvars,lid_params = + match lid with + | [] -> anomaly "induction_from_context_l" + | e::l -> + let nargs_without_first = nargs_indarg_farg - 1 in + let ivs,lp = cut_list nargs_without_first l in + e, ivs, lp in + let statlists,lhyp0,indhyps,deps = cook_sign None (hyp0::indvars) env in + let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in + let names = compute_induction_names (Array.length indsign) names in + let dephyps = List.map (fun (id,_,_) -> id) deps in + let deps_cstr = + List.fold_left (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in + (* terms to patternify we must patternify indarg or farg if present in concl *) + let lid_in_pattern = + if scheme.indarg <> None & not scheme.indarg_in_concl then List.rev indvars + else List.rev (hyp0::indvars) in + let lidcstr = List.map (fun x -> mkVar x) lid_in_pattern in + let realindvars = (* hyp0 is a real induction arg if it is not the + farg in the conclusion of the induction scheme *) + List.rev ((if scheme.farg_in_concl then indvars else hyp0::indvars) @ lid_params) in + (* Magistral effet de bord: comme dans induction_from_context. *) + tclTHENLIST + [ + (* Generalize dependent hyps (but not args) *) + if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr; + thin dephyps; (* clear dependent hyps *) + (* pattern to make the predicate appear. *) + reduce (Pattern (List.map (fun e -> ([],e)) lidcstr)) onConcl; + (* FIXME: Tester ca avec un principe dependant et non-dependant *) + (if isrec then tclTHENFIRSTn else tclTHENLASTn) + (tclTHENLIST [ + (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all + possible holes using arguments given by the user (but the + functional one). *) + induction_tac_felim realindvars scheme; + tclTRY (thin (List.rev (indhyps))); + ]) + (array_map2 + (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names) + ] + gl + + -let induction_from_context isrec elim_info hyp0 (names,b_rnames) gl = +let induction_from_context isrec elim_info hyp0 names gl = (*test suivant sans doute inutile car refait par le letin_tac*) if List.mem hyp0 (ids_of_named_context (Global.named_context())) then errorlabstrm "induction" (str "Cannot generalize a global variable"); - let elimc,elimt,nparams,indref,indsign = elim_info in + let indsign,scheme = elim_info in + + let indref = match scheme.indref with | None -> assert false | Some x -> x in let tmptyp0 = pf_get_hyp_typ gl hyp0 in let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in + let env = pf_env gl in - let indvars = find_atomic_param_of_ind nparams (snd (decompose_prod typ0)) in - let (statlists,lhyp0,indhyps,deps) = cook_sign hyp0 indvars env in + let indvars = find_atomic_param_of_ind scheme.nparams (snd (decompose_prod typ0)) in + (* induction_from_context_l isrec elim_info (hyp0::List.rev indvars) names gl *) + let statlists,lhyp0,indhyps,deps = cook_sign (Some hyp0) indvars env in let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in let names = compute_induction_names (Array.length indsign) names in - (* For translator *) - let names' = Array.map ref (Array.make (Array.length indsign) []) in - let b = ref false in - b_rnames := (b,Array.to_list names')::!b_rnames; - let names = array_map2 (fun n n' -> (n,b,n')) names names' in - (* End translator *) let dephyps = List.map (fun (id,_,_) -> id) deps in - let args = + let deps_cstr = List.fold_left (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in @@ -1590,11 +1938,11 @@ let induction_from_context isrec elim_info hyp0 (names,b_rnames) gl = "ind_rec ... (hyp0 ?)", les buts correspondant à des arguments de hyp0 sont maintenant à la fin et c'est tclTHENFIRSTn qui marche !!! *) tclTHENLIST - [ if deps = [] then tclIDTAC else apply_type tmpcl args; + [ if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr; thin dephyps; (if isrec then tclTHENFIRSTn else tclTHENLASTn) (tclTHENLIST - [ induction_tac hyp0 typ0 (elimc,elimt); + [ induction_tac hyp0 typ0 scheme (*scheme.elimc,scheme.elimt*); thin [hyp0]; tclTRY (thin indhyps) ]) (array_map2 @@ -1602,15 +1950,38 @@ let induction_from_context isrec elim_info hyp0 (names,b_rnames) gl = ] gl + + +exception TryNewInduct of exn + let induction_with_atomization_of_ind_arg isrec elim names hyp0 gl = - let (elimc,elimt,nparams,indref,indsign as elim_info) = - find_elim_signature isrec false elim hyp0 gl in - tclTHEN - (atomize_param_of_ind (indref,nparams) hyp0) - (induction_from_context isrec elim_info hyp0 names) gl + let (indsign,scheme as elim_info) = find_elim_signature isrec elim hyp0 gl in + if scheme.indarg = None then (* This is not a standard induction scheme (the + argument is probably a parameter) So try the + more general induction mechanism. *) + induction_from_context_l isrec elim_info [hyp0] names gl + else + let indref = match scheme.indref with | None -> assert false | Some x -> x in + tclTHEN + (atomize_param_of_ind (indref,scheme.nparams) hyp0) + (induction_from_context isrec elim_info hyp0 names) gl + +(* Induction on a list of induction arguments. Analyse the elim + scheme (which is mandatory for multiple ind args), check that all + parameters and arguments are given (mandatory too). *) +let induction_without_atomization isrec elim names lid gl = + let (indsign,scheme as elim_info) = + find_elim_signature isrec elim (List.hd lid) gl in + let awaited_nargs = + scheme.nparams + scheme.nargs + + (if scheme.farg_in_concl then 1 else 0) + + (if scheme.indarg <> None then 1 else 0) + in + let nlid = List.length lid in + if nlid <> awaited_nargs + then error "Not the right number of induction arguments" + else induction_from_context_l isrec elim_info lid names gl -(* This is Induction since V7 ("natural" induction both in quantified - premisses and introduced ones) *) let new_induct_gen isrec elim names c gl = match kind_of_term c with | Var id when not (mem_named_context id (Global.named_context())) -> @@ -1623,18 +1994,119 @@ let new_induct_gen isrec elim names c gl = (letin_tac true (Name id) c allClauses) (induction_with_atomization_of_ind_arg isrec elim names id) gl -let new_induct_destruct isrec c elim names = match c with - | ElimOnConstr c -> new_induct_gen isrec elim names c - | ElimOnAnonHyp n -> - tclTHEN (intros_until_n n) - (tclLAST_HYP (new_induct_gen isrec elim names)) - (* Identifier apart because id can be quantified in goal and not typable *) - | ElimOnIdent (_,id) -> - tclTHEN (tclTRY (intros_until_id id)) - (new_induct_gen isrec elim names (mkVar id)) +(* The two following functions should already exist, but found nowhere *) +(* Unfolds x by its definition everywhere *) +let unfold_body x gl = + let hyps = pf_hyps gl in + let xval = + match Sign.lookup_named x hyps with + (_,Some xval,_) -> xval + | _ -> errorlabstrm "unfold_body" + (pr_id x ++ str" is not a defined hypothesis") in + let aft = afterHyp x gl in + let hl = List.fold_right (fun (y,yval,_) cl -> (y,[],InHyp) :: cl) aft [] in + let xvar = mkVar x in + let rfun _ _ c = replace_term xvar xval c in + tclTHENLIST + [tclMAP (fun h -> reduct_in_hyp rfun h) hl; + reduct_in_concl (rfun,DEFAULTcast)] gl + +(* Unfolds x by its definition everywhere and clear x. This may raise + an error if x is not defined. *) +let unfold_all x gl = + let (_,xval,_) = pf_get_hyp gl x in + (* If x has a body, simply replace x with body and clear x *) + if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl + else tclIDTAC gl + + +(* 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 new_induct_gen. *) +let new_induct_gen_l isrec elim names lc gl = + let newlc = ref [] in + let letids = ref [] in + let rec atomize_list l gl = + match l with + | [] -> tclIDTAC gl + | c::l' -> + match kind_of_term c with + | Var id when not (mem_named_context id (Global.named_context())) -> + let _ = newlc:= id::!newlc in + atomize_list l' gl + + | _ -> + let x = + id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in + + let id = fresh_id [] x gl in + let newl' = List.map (replace_term c (mkVar id)) l' in + let _ = newlc:=id::!newlc in + let _ = letids:=id::!letids in + tclTHEN + (letin_tac true (Name id) c allClauses) + (atomize_list newl') gl in + tclTHENLIST + [ + (atomize_list lc); + (fun gl' -> (* recompute each time to have the new value of newlc *) + induction_without_atomization isrec elim names !newlc gl') ; + (* after induction, try to unfold all letins created by atomize_list + FIXME: unfold_all does not exist anywhere else? *) + (fun gl' -> (* recompute each time to have the new value of letids *) + tclMAP (fun x -> tclTRY (unfold_all x)) !letids gl') + ] + gl -let new_induct = new_induct_destruct true -let new_destruct = new_induct_destruct false + +let induct_destruct_l isrec lc elim names = + (* Several induction hyps: induction scheme is mandatory *) + let _ = + if elim = None + then + error ("Induction scheme must be given when several induction hypothesis.\n" + ^ "Example: induction x1 x2 x3 using my_scheme.") in + let newlc = + List.map + (fun x -> + match x with (* FIXME: should we deal with ElimOnIdent? *) + | ElimOnConstr x -> x + | _ -> error "don't know where to find some argument") + lc in + new_induct_gen_l isrec 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 induct_destruct isrec lc elim names = + assert (List.length lc > 0); (* ensured by syntax, but if called inside caml? *) + if List.length lc = 1 then (* induction on one arg: use old mechanism *) + try + let c = List.hd lc in + match c with + | ElimOnConstr c -> new_induct_gen isrec elim names c + | ElimOnAnonHyp n -> + tclTHEN (intros_until_n n) + (tclLAST_HYP (new_induct_gen isrec elim names)) + (* Identifier apart because id can be quantified in goal and not typable *) + | ElimOnIdent (_,id) -> + tclTHEN (tclTRY (intros_until_id id)) + (new_induct_gen isrec elim names (mkVar id)) + with (* If this fails, try with new mechanism but if it fails too, + then the exception is the first one. *) + | x -> (try induct_destruct_l isrec lc elim names with _ -> raise x) + else induct_destruct_l isrec lc elim names + + + + +let new_induct = induct_destruct true +let new_destruct = induct_destruct false (* The registered tactic, which calls the default elimination * if no elimination constant is provided. *) @@ -1645,23 +2117,12 @@ let new_destruct = new_induct_destruct false let raw_induct s = tclTHEN (intros_until_id s) (tclLAST_HYP simplest_elim) let raw_induct_nodep n = tclTHEN (intros_until_n n) (tclLAST_HYP simplest_elim) -(* This was Induction in 6.3 (hybrid form) *) -let induction_from_context_old_style hyp b_ids gl = - let elim_info = find_elim_signature true true None hyp gl in - let x = induction_from_context true elim_info hyp (None,b_ids) gl in - (* For translator *) fst (List.hd !b_ids) := true; - x - -let simple_induct_id hyp b_ids = - if !Options.v7 then - tclORELSE (raw_induct hyp) (induction_from_context_old_style hyp b_ids) - else - raw_induct hyp +let simple_induct_id hyp = raw_induct hyp let simple_induct_nodep = raw_induct_nodep let simple_induct = function - | NamedHyp id,b_ids -> simple_induct_id id b_ids - | AnonHyp n,_ -> simple_induct_nodep n + | NamedHyp id -> simple_induct_id id + | AnonHyp n -> simple_induct_nodep n (* Destruction tactics *) @@ -1682,25 +2143,25 @@ let simple_destruct = function *) let elim_scheme_type elim t gl = - let (wc,kONT) = startWalk gl in - let clause = mk_clenv_type_of wc elim in - match kind_of_term (last_arg (clenv_template clause).rebus) with + let clause = mk_clenv_type_of gl elim in + match kind_of_term (last_arg clause.templval.rebus) with | Meta mv -> let clause' = (* t is inductive, then CUMUL or CONV is irrelevant *) - clenv_unify true CUMUL t (clenv_instance_type clause mv) clause in - elim_res_pf kONT clause' true gl + clenv_unify true Reduction.CUMUL t + (clenv_meta_type clause mv) clause in + res_pf clause' ~allow_K:true gl | _ -> anomaly "elim_scheme_type" let elim_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in - let elimc = Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) in + let elimc = lookup_eliminator ind (elimination_sort_of_goal gl) in elim_scheme_type elimc t gl let case_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in let env = pf_env gl in - let elimc = Indrec.make_case_gen env (project gl) ind (elimination_sort_of_goal gl) in + let elimc = make_case_gen env (project gl) ind (elimination_sort_of_goal gl) in elim_scheme_type elimc t gl @@ -1773,9 +2234,12 @@ let dImp cls = (* Reflexivity tactics *) +let setoid_reflexivity = ref (fun _ -> assert false) +let register_setoid_reflexivity f = setoid_reflexivity := f + let reflexivity gl = match match_with_equation (pf_concl gl) with - | None -> error "The conclusion is not a substitutive equation" + | None -> !setoid_reflexivity gl | Some (hdcncl,args) -> one_constructor 1 NoBindings gl let intros_reflexivity = (tclTHEN intros reflexivity) @@ -1787,9 +2251,12 @@ let intros_reflexivity = (tclTHEN intros reflexivity) defined and the conclusion is a=b, it solves the goal doing (Cut b=a;Intro H;Case H;Constructor 1) *) +let setoid_symmetry = ref (fun _ -> assert false) +let register_setoid_symmetry f = setoid_symmetry := f + let symmetry gl = match match_with_equation (pf_concl gl) with - | None -> error "The conclusion is not a substitutive equation" + | None -> !setoid_symmetry gl | Some (hdcncl,args) -> let hdcncls = string_of_inductive hdcncl in begin @@ -1810,12 +2277,14 @@ let symmetry gl = gl end +let setoid_symmetry_in = ref (fun _ _ -> assert false) +let register_setoid_symmetry_in f = setoid_symmetry_in := f + let symmetry_in id gl = let ctype = pf_type_of gl (mkVar id) in let sign,t = decompose_prod_assum ctype in match match_with_equation t with - | None -> (* Do not deal with setoids yet *) - error "The term provided does not end with an equation" + | None -> !setoid_symmetry_in id gl | Some (hdcncl,args) -> let symccl = match args with | [t1; c1; t2; c2] -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) @@ -1845,9 +2314,12 @@ let intros_symmetry = --Eduardo (19/8/97) *) +let setoid_transitivity = ref (fun _ _ -> assert false) +let register_setoid_transitivity f = setoid_transitivity := f + let transitivity t gl = match match_with_equation (pf_concl gl) with - | None -> error "The conclusion is not a substitutive equation" + | None -> !setoid_transitivity t gl | Some (hdcncl,args) -> let hdcncls = string_of_inductive hdcncl in begin @@ -1886,7 +2358,6 @@ let interpretable_as_section_decl d1 d2 = match d1,d2 with | (_,None,t1), (_,_,t2) -> eq_constr t1 t2 let abstract_subproof name tac gls = - let env = Global.env() in let current_sign = Global.named_context() and global_sign = pf_hyps gls in let sign,secsign = @@ -1894,16 +2365,15 @@ let abstract_subproof name tac gls = (fun (id,_,_ as d) (s1,s2) -> if mem_named_context id current_sign & interpretable_as_section_decl (Sign.lookup_named id current_sign) d - then (s1,add_named_decl d s2) + then (s1,push_named_context_val d s2) else (add_named_decl d s1,s2)) - global_sign (empty_named_context,empty_named_context) in + global_sign (empty_named_context,empty_named_context_val) in let na = next_global_ident_away false name (pf_ids_of_hyps gls) in let concl = it_mkNamedProd_or_LetIn (pf_concl gls) sign in if occur_existential concl then - if !Options.v7 then error "Abstract cannot handle existentials" - else error "\"abstract\" cannot handle existentials"; + error "\"abstract\" cannot handle existentials"; let lemme = - start_proof na (IsGlobal (Proof Lemma)) secsign concl (fun _ _ -> ()); + start_proof na (Global, Proof Lemma) secsign concl (fun _ _ -> ()); let _,(const,kind,_) = try by (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)); @@ -1913,9 +2383,8 @@ let abstract_subproof name tac gls = (delete_current_proof(); raise e) in (* Faudrait un peu fonctionnaliser cela *) let cd = Entries.DefinitionEntry const in - let sp = Declare.declare_internal_constant na (cd,IsProof Lemma) in - let newenv = Global.env() in - constr_of_reference (ConstRef (snd sp)) + let con = Declare.declare_internal_constant na (cd,IsProof Lemma) in + constr_of_global (ConstRef con) in exact_no_check (applist (lemme, @@ -1928,3 +2397,29 @@ let tclABSTRACT name_op tac gls = | None -> add_suffix (get_current_proof_name ()) "_subproof" in abstract_subproof s tac gls + + +let admit_as_an_axiom gls = + let current_sign = Global.named_context() + and global_sign = pf_hyps gls in + let sign,secsign = + List.fold_right + (fun (id,_,_ as d) (s1,s2) -> + if mem_named_context id current_sign & + interpretable_as_section_decl (Sign.lookup_named id current_sign) d + then (s1,add_named_decl d s2) + else (add_named_decl d s1,s2)) + global_sign (empty_named_context,empty_named_context) in + let name = add_suffix (get_current_proof_name ()) "_admitted" in + let na = next_global_ident_away false name (pf_ids_of_hyps gls) in + let concl = it_mkNamedProd_or_LetIn (pf_concl gls) sign in + if occur_existential concl then error "\"admit\" cannot handle existentials"; + let axiom = + let cd = Entries.ParameterEntry concl in + let con = Declare.declare_internal_constant na (cd,IsAssumption Logical) in + constr_of_global (ConstRef con) + in + exact_no_check + (applist (axiom, + List.rev (Array.to_list (instance_from_named_context sign)))) + gls diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 1155d845..5d04da9a 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tactics.mli,v 1.59.2.2 2005/01/21 16:41:52 herbelin Exp $ i*) +(*i $Id: tactics.mli 8698 2006-04-11 15:12:48Z jforest $ i*) (*i*) open Names @@ -19,7 +19,7 @@ open Reduction open Evd open Evar_refiner open Clenv -open Tacred +open Redexpr open Tacticals open Libnames open Genarg @@ -32,7 +32,7 @@ open Rawterm (*s General functions. *) -val type_clenv_binding : named_context sigma -> +val type_clenv_binding : goal sigma -> constr * constr -> constr bindings -> constr val string_of_inductive : constr -> string @@ -46,7 +46,7 @@ exception Bound val introduction : identifier -> tactic val refine : constr -> tactic -val convert_concl : constr -> tactic +val convert_concl : constr -> cast_kind -> tactic val convert_hyp : named_declaration -> tactic val thin : identifier list -> tactic val mutual_fix : @@ -63,6 +63,9 @@ val intro : tactic val introf : tactic val intro_force : bool -> tactic val intro_move : identifier option -> identifier option -> tactic + (* [intro_avoiding idl] acts as intro but prevents the new identifier + to belong to [idl] *) +val intro_avoiding : identifier list -> tactic val intro_replacing : identifier -> tactic val intro_using : identifier -> tactic @@ -110,8 +113,8 @@ val exact_proof : Topconstr.constr_expr -> tactic type tactic_reduction = env -> evar_map -> constr -> constr val reduct_in_hyp : tactic_reduction -> hyp_location -> tactic -val reduct_option : tactic_reduction -> simple_clause -> tactic -val reduct_in_concl : tactic_reduction -> tactic +val reduct_option : tactic_reduction * cast_kind -> simple_clause -> tactic +val reduct_in_concl : tactic_reduction * cast_kind -> tactic val change_in_concl : constr occurrences option -> constr -> tactic val change_in_hyp : constr occurrences option -> constr -> hyp_location -> tactic @@ -124,9 +127,10 @@ val hnf_option : simple_clause -> tactic val simpl_in_concl : tactic val simpl_in_hyp : hyp_location -> tactic val simpl_option : simple_clause -> tactic -val normalise_in_concl: tactic +val normalise_in_concl : tactic val normalise_in_hyp : hyp_location -> tactic val normalise_option : simple_clause -> tactic +val normalise_vm_in_concl : tactic val unfold_in_concl : (int list * evaluable_global_reference) list -> tactic val unfold_in_hyp : (int list * evaluable_global_reference) list -> hyp_location -> tactic @@ -144,6 +148,7 @@ val pattern_option : (int list * constr) list -> simple_clause -> tactic val clear : identifier list -> tactic val clear_body : identifier list -> tactic +val keep : identifier list -> tactic val new_hyp : int option -> constr with_bindings -> tactic @@ -165,21 +170,67 @@ val cut_and_apply : constr -> tactic (*s Elimination tactics. *) -val general_elim : constr with_bindings -> constr with_bindings -> - ?allow_K:bool -> tactic + +(* + 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: (Term.constr * constr Rawterm.bindings) option; + elimt: types; + indref: global_reference 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 : ?elimc: (Term.constr * constr Rawterm.bindings) -> types -> elim_scheme + +val general_elim : + constr with_bindings -> constr with_bindings -> ?allow_K:bool -> tactic +val general_elim_in : + identifier -> constr with_bindings -> constr with_bindings -> tactic + val default_elim : constr with_bindings -> tactic val simplest_elim : constr -> tactic val elim : constr with_bindings -> constr with_bindings option -> tactic -val general_elim_in : identifier -> constr * constr bindings -> - constr * constr bindings -> tactic +val simple_induct : quantified_hypothesis -> tactic -val simple_induct : quantified_hypothesis * (bool ref * intro_pattern_expr list ref list) list ref -> tactic -val general_elim_in : identifier -> constr * constr bindings -> - constr * constr bindings -> tactic - -val new_induct : constr induction_arg -> constr with_bindings option -> - intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref - -> tactic +val new_induct : constr induction_arg list -> constr with_bindings option -> + intro_pattern_expr -> tactic (*s Case analysis tactics. *) @@ -187,9 +238,8 @@ val general_case_analysis : constr with_bindings -> tactic val simplest_case : constr -> tactic val simple_destruct : quantified_hypothesis -> tactic -val new_destruct : constr induction_arg -> constr with_bindings option -> - intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref - -> tactic +val new_destruct : constr induction_arg list -> constr with_bindings option -> + intro_pattern_expr -> tactic (*s Eliminations giving the type instead of the proof. *) @@ -221,26 +271,36 @@ val simplest_split : tactic (*s Logical connective tactics. *) +val register_setoid_reflexivity : tactic -> unit val reflexivity : tactic val intros_reflexivity : tactic +val register_setoid_symmetry : tactic -> unit val symmetry : tactic +val register_setoid_symmetry_in : (identifier -> tactic) -> unit val symmetry_in : identifier -> tactic val intros_symmetry : clause -> tactic +val register_setoid_transitivity : (constr -> tactic) -> unit val transitivity : constr -> tactic val intros_transitivity : constr -> tactic val cut : constr -> tactic val cut_intro : constr -> tactic -val cut_replacing : identifier -> constr -> tactic +val cut_replacing : + identifier -> constr -> (tactic -> tactic) -> tactic val cut_in_parallel : constr list -> tactic -val assert_tac : bool -> name -> constr -> tactic +val assert_as : bool -> intro_pattern_expr -> constr -> tactic +val forward : tactic option -> intro_pattern_expr -> constr -> tactic + val true_cut : name -> constr -> tactic val letin_tac : bool -> name -> constr -> clause -> tactic -val forward : bool -> name -> constr -> tactic +val assert_tac : bool -> name -> constr -> tactic val generalize : constr list -> tactic val generalize_dep : constr -> tactic val tclABSTRACT : identifier option -> tactic -> tactic + +val admit_as_an_axiom : tactic + diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 553acc91..c91038fc 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -8,10 +8,8 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id: tauto.ml4,v 1.62.2.1 2004/07/16 19:30:55 herbelin Exp $ i*) +(*i $Id: tauto.ml4 7732 2005-12-26 13:51:24Z herbelin $ i*) -open Ast -open Coqast open Hipattern open Names open Libnames @@ -171,39 +169,11 @@ let tauto g = let default_intuition_tac = interp <:tactic< auto with * >> -let q_elim tac= - <:tactic< - match goal with - x : ?X1, H : ?X1 -> _ |- _ => generalize (H x); clear H; $tac - end >> - -let rec lfo n gl= - if n=0 then (tclFAIL 0 "LinearIntuition failed" gl) else - let p=if n<0 then n else (n-1) in - let lfo_rec=q_elim (Tacexpr.TacArg (valueIn (VTactic(dummy_loc,lfo p)))) in - intuition_gen (interp lfo_rec) gl - -let lfo_wrap n gl= - try lfo n gl - with - Refiner.FailError _ | UserError _ -> - errorlabstrm "LinearIntuition" [< str "LinearIntuition failed." >] - -TACTIC EXTEND Tauto -| [ "Tauto" ] -> [ tauto ] -END -(* Obsolete sinve V8.0 -TACTIC EXTEND TSimplif -| [ "Simplif" ] -> [ simplif_gen ] +TACTIC EXTEND tauto +| [ "tauto" ] -> [ tauto ] END -*) -TACTIC EXTEND Intuition -| [ "Intuition" ] -> [ intuition_gen default_intuition_tac ] -| [ "Intuition" tactic(t) ] -> [ intuition_gen (snd t) ] -END -(* Obsolete since V8.0 -TACTIC EXTEND LinearIntuition -| [ "LinearIntuition" ] -> [ lfo_wrap (-1)] -| [ "LinearIntuition" integer(n)] -> [ lfo_wrap n] + +TACTIC EXTEND intuition +| [ "intuition" ] -> [ intuition_gen default_intuition_tac ] +| [ "intuition" tactic(t) ] -> [ intuition_gen (snd t) ] END -*) diff --git a/tactics/termdn.ml b/tactics/termdn.ml index 9e77ddbd..65ad1dee 100644 --- a/tactics/termdn.ml +++ b/tactics/termdn.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: termdn.ml,v 1.15.8.1 2004/07/16 19:30:56 herbelin Exp $ *) +(* $Id: termdn.ml 7639 2005-12-02 10:01:15Z gregoire $ *) open Util open Names @@ -21,14 +21,14 @@ open Nametab See the module dn.ml for further explanations. Eduardo (5/8/97) *) -type 'a t = (constr_label,constr_pattern,'a) Dn.t +type 'a t = (global_reference,constr_pattern,'a) Dn.t (*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*) let decomp = let rec decrec acc c = match kind_of_term c with | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f - | Cast (c1,_) -> decrec acc c1 + | Cast (c1,_,_) -> decrec acc c1 | _ -> (c,acc) in decrec [] @@ -45,19 +45,18 @@ let constr_pat_discr t = None else match decomp_pat t with - | PRef (IndRef sp), args -> Some(IndNode sp,args) - | PRef (ConstructRef sp), args -> Some(CstrNode sp,args) - | PRef (VarRef id), args -> Some(VarNode id,args) + | PRef ((IndRef _) as ref), args + | PRef ((ConstructRef _ ) as ref), args + | PRef ((VarRef _) as ref), args -> Some(ref,args) | _ -> None let constr_val_discr t = let c, l = decomp t in match kind_of_term c with (* Const _,_) -> Some(TERM c,l) *) - | Ind ind_sp -> Some(IndNode ind_sp,l) - | Construct cstr_sp -> Some(CstrNode cstr_sp,l) - (* Ici, comment distinguer SectionVarNode de VarNode ?? *) - | Var id -> Some(VarNode id,l) + | Ind ind_sp -> Some(IndRef ind_sp,l) + | Construct cstr_sp -> Some(ConstructRef cstr_sp,l) + | Var id -> Some(VarRef id,l) | _ -> None (* Les deux fonctions suivantes ecrasaient les precedentes, diff --git a/tactics/termdn.mli b/tactics/termdn.mli index e3caf6d9..b65c0eeb 100644 --- a/tactics/termdn.mli +++ b/tactics/termdn.mli @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: termdn.mli,v 1.9.16.1 2004/07/16 19:30:56 herbelin Exp $ i*) +(*i $Id: termdn.mli 6427 2004-12-07 17:41:10Z sacerdot $ i*) (*i*) open Term open Pattern +open Libnames (*i*) (* Discrimination nets of terms. *) @@ -44,8 +45,8 @@ val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit (* These are for Nbtermdn *) val constr_pat_discr : - constr_pattern -> (constr_label * constr_pattern list) option + constr_pattern -> (global_reference * constr_pattern list) option val constr_val_discr : - constr -> (constr_label * constr list) option + constr -> (global_reference * constr list) option (*i*) -- cgit v1.2.3