From cfbfe13f5b515ae2e3c6cdd97e2ccee03bc26e56 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Sun, 1 Feb 2009 00:54:40 +0100 Subject: Imported Upstream version 8.2~rc2+dfsg --- tactics/auto.ml | 574 +++++++----- tactics/auto.mli | 52 +- tactics/class_tactics.ml4 | 872 +++++++++++------- tactics/decl_interp.ml | 8 +- tactics/decl_proof_instr.ml | 10 +- tactics/decl_proof_instr.mli | 2 +- tactics/dhyp.ml | 5 +- tactics/eauto.ml4 | 36 +- tactics/elim.ml | 4 +- tactics/equality.ml | 169 ++-- tactics/equality.mli | 12 +- tactics/evar_tactics.ml | 4 +- tactics/evar_tactics.mli | 3 +- tactics/extraargs.ml4 | 21 +- tactics/extraargs.mli | 10 +- tactics/extratactics.ml4 | 103 +-- tactics/hiddentac.ml | 15 +- tactics/hiddentac.mli | 9 +- tactics/hipattern.ml4 | 173 +++- tactics/hipattern.mli | 22 +- tactics/inv.ml | 40 +- tactics/refine.ml | 6 +- tactics/setoid_replace.ml | 2023 ------------------------------------------ tactics/setoid_replace.mli | 85 -- tactics/tacinterp.ml | 329 ++++--- tactics/tacinterp.mli | 12 +- tactics/tacticals.ml | 44 +- tactics/tacticals.mli | 10 +- tactics/tactics.ml | 710 +++++++++------ tactics/tactics.mli | 43 +- tactics/tauto.ml4 | 166 ++-- 31 files changed, 2038 insertions(+), 3534 deletions(-) delete mode 100644 tactics/setoid_replace.ml delete mode 100644 tactics/setoid_replace.mli (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index 066ed786..1212656b 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: auto.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: auto.ml 11739 2009-01-02 19:33:19Z herbelin $ *) open Pp open Util @@ -59,6 +59,8 @@ type pri_auto_tactic = { code : auto_tactic (* the tactic to apply when the concl matches pat *) } +type hint_entry = global_reference option * pri_auto_tactic + let pri_ord {pri=pri1} {pri=pri2} = pri1 - pri2 let pri_order {pri=pri1} {pri=pri2} = pri1 <= pri2 @@ -110,34 +112,60 @@ module Constr_map = Map.Make(struct let compare = Pervasives.compare end) +let is_transparent_gr (ids, csts) = function + | VarRef id -> Idpred.mem id ids + | ConstRef cst -> Cpred.mem cst csts + | IndRef _ | ConstructRef _ -> false + +let fmt_autotactic = + function + | 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 " ++ pr_lconstr c ++ str" ; trivial") + | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) + | Extern tac -> + (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac) + +let pr_autotactic = fmt_autotactic + module Hint_db = struct type t = { hintdb_state : Names.transparent_state; use_dn : bool; - hintdb_map : search_entry Constr_map.t + hintdb_map : search_entry Constr_map.t; + (* A list of unindexed entries starting with an unfoldable constant + or with no associated pattern. *) + hintdb_nopat : stored_data list } - let empty use_dn = { hintdb_state = empty_transparent_state; - use_dn = use_dn; - hintdb_map = Constr_map.empty } + let empty st use_dn = { hintdb_state = st; + use_dn = use_dn; + hintdb_map = Constr_map.empty; + hintdb_nopat = [] } let find key db = try Constr_map.find key db.hintdb_map with Not_found -> empty_se - + let map_all k db = let (l,l',_) = find k db in - Sort.merge pri_order l l' + Sort.merge pri_order (db.hintdb_nopat @ l) l' let map_auto (k,c) db = let st = if db.use_dn then Some db.hintdb_state else None in - lookup_tacs (k,c) st (find k db) - + let l' = lookup_tacs (k,c) st (find k db) in + Sort.merge pri_order db.hintdb_nopat l' + let is_exact = function | Give_exact _ -> true | _ -> false + let rebuild_db st' db = + { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map } + let add_one (k,v) db = let st',rebuild = match v.code with @@ -148,27 +176,43 @@ module Hint_db = struct | EvalConstRef cst -> (ids, Cpred.add cst csts)), true | _ -> db.hintdb_state, false in - let dnst, db = - if db.use_dn then - Some st', { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map } - else None, db + let dnst, db, k = + if db.use_dn then + let db', k' = + if rebuild then rebuild_db st' db, k + else (* not an unfold *) + (match k with + | Some gr -> db, if is_transparent_gr st' gr then None else k + | None -> db, None) + in + (Some st', db', k') + else None, db, k in - let oval = find k db in let pat = if not db.use_dn && is_exact v.code then None else v.pat in - { db with hintdb_map = Constr_map.add k (add_tac pat v dnst oval) db.hintdb_map; - hintdb_state = st' } + match k with + | None -> + if not (List.mem v db.hintdb_nopat) then + { db with hintdb_nopat = v :: db.hintdb_nopat } + else db + | Some gr -> + let oval = find gr db in + { db with hintdb_map = Constr_map.add gr (add_tac pat v dnst oval) db.hintdb_map; + hintdb_state = st' } let add_list l db = List.fold_right add_one l db - let iter f db = Constr_map.iter (fun k (l,l',_) -> f k (l@l')) db.hintdb_map + let iter f db = + f None db.hintdb_nopat; + Constr_map.iter (fun k (l,l',_) -> f (Some k) (l@l')) db.hintdb_map let transparent_state db = db.hintdb_state - let set_transparent_state db st = { db with hintdb_state = st } + let set_transparent_state db st = + let db = if db.use_dn then rebuild_db st db else db in + { db with hintdb_state = st } - let set_rigid db cst = - let (ids,csts) = db.hintdb_state in - { db with hintdb_state = (ids, Cpred.remove cst csts) } + let use_dn db = db.use_dn + end module Hintdbmap = Gmap @@ -235,21 +279,21 @@ let make_exact_entry pri (c,cty) = let ce = mk_clenv_from dummy_goal (c,cty) in let c' = clenv_type ce in let pat = Pattern.pattern_of_constr c' in - (head_of_constr_reference (List.hd (head_constr cty)), + (Some (head_of_constr_reference (fst (head_constr cty))), { pri=(match pri with Some pri -> pri | None -> 0); pat=Some pat; code=Give_exact c }) -let make_apply_entry env sigma (eapply,verbose) pri (c,cty) = - let cty = hnf_constr env sigma cty in - match kind_of_term cty with +let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) = + let cty = if hnf then hnf_constr env sigma cty else cty in + match kind_of_term cty with | Prod _ -> 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 + with BoundPattern -> failwith "make_apply_entry") in let nmiss = List.length (clenv_missing ce) in if nmiss = 0 then - (hd, + (Some hd, { pri = (match pri with None -> nb_hyp cty | Some p -> p); pat = Some pat; code = Res_pf(c,{ce with env=empty_env}) }) @@ -258,14 +302,14 @@ let make_apply_entry env sigma (eapply,verbose) pri (c,cty) = if verbose then warn (str "the hint: eapply " ++ pr_lconstr c ++ str " will only be used by eauto"); - (hd, + (Some hd, { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p); pat = Some pat; code = ERes_pf(c,{ce with env=empty_env}) }) end | _ -> failwith "make_apply_entry" -(* flags is (e,v) with e=true if eapply and v=true if verbose +(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose c is a constr cty is the type of constr *) @@ -279,14 +323,14 @@ let make_resolves env sigma flags pri c = if ents = [] then errorlabstrm "Hint" (pr_lconstr c ++ spc() ++ - (if fst flags then str"cannot be used as a hint." + (if pi1 flags then str"cannot be used as a hint." else str "can be used as a hint only for eauto.")); ents (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma (hname,_,htyp) = try - [make_apply_entry env sigma (true, false) None + [make_apply_entry env sigma (true, true, false) None (mkVar hname, htyp)] with | Failure _ -> [] @@ -294,23 +338,23 @@ let make_resolve_hyp env sigma (hname,_,htyp) = (* REM : in most cases hintname = id *) let make_unfold (ref, eref) = - (ref, + (Some ref, { pri = 4; pat = None; code = Unfold_nth eref }) let make_extern pri pat tacast = - let hdconstr = try_head_pattern pat in + let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri=pri; - pat = Some pat; + pat = pat; code= Extern tacast }) 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 hd = head_of_constr_reference (fst (head_constr t)) in let ce = mk_clenv_from dummy_goal (c,t) in - (hd, { pri=1; + (Some hd, { pri=1; pat = Some (Pattern.pattern_of_constr (clenv_type ce)); code=Res_pf_THEN_trivial_fail(c,{ce with env=empty_env}) }) @@ -328,15 +372,29 @@ let add_hint dbname hintlist = let db' = Hint_db.add_list hintlist db in searchtable_add (dbname,db') with Not_found -> - let db = Hint_db.add_list hintlist (Hint_db.empty false) in + let db = Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false) in searchtable_add (dbname,db) -type hint_action = CreateDB of bool | UpdateDB of (global_reference * pri_auto_tactic) list +let add_transparency dbname grs b = + let db = searchtable_map dbname in + let st = Hint_db.transparent_state db in + let st' = + List.fold_left (fun (ids, csts) gr -> + match gr with + | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts) + | EvalVarRef v -> (if b then Idpred.add else Idpred.remove) v ids, csts) + st grs + in searchtable_add (dbname, Hint_db.set_transparent_state db st') + +type hint_action = | CreateDB of bool * transparent_state + | AddTransparency of evaluable_global_reference list * bool + | AddTactic of (global_reference option * pri_auto_tactic) list let cache_autohint (_,(local,name,hints)) = match hints with - | CreateDB b -> searchtable_add (name, Hint_db.empty b) - | UpdateDB hints -> add_hint name hints + | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b) + | AddTransparency (grs, b) -> add_transparency name grs b + | AddTactic hints -> add_hint name hints let forward_subst_tactic = ref (fun _ -> failwith "subst_tactic is not installed for auto") @@ -351,11 +409,15 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) = code = code ; } in - let subst_hint (lab,data as hint) = - 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 subst_key gr = + let (lab'', elab') = subst_global subst gr in + let gr' = + (try head_of_constr_reference (fst (head_constr_bound elab')) + with Tactics.Bound -> lab'') + in if gr' == gr then gr else gr' + in + let subst_hint (k,data as hint) = + let k' = Option.smartmap subst_key k in let data' = match data.code with | Res_pf (c, clenv) -> let c' = subst_mps subst c in @@ -383,18 +445,21 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) = if tac==tac' then data else trans_data data (Extern tac') in - if lab' == lab && data' == data then hint else - (lab',data') + if k' == k && data' == data then hint else + (k',data') in match hintlist with | CreateDB _ -> obj - | UpdateDB hintlist -> + | AddTransparency (grs, b) -> + let grs' = list_smartmap (subst_evaluable_reference subst) grs in + if grs==grs' then obj else (local, name, AddTransparency (grs', b)) + | AddTactic hintlist -> let hintlist' = list_smartmap subst_hint hintlist in if hintlist' == hintlist then obj else - (local,name,UpdateDB hintlist') + (local,name,AddTactic hintlist') let classify_autohint (_,((local,name,hintlist) as obj)) = - if local or hintlist = (UpdateDB []) then Dispose else Substitute obj + if local or hintlist = (AddTactic []) then Dispose else Substitute obj let export_autohint ((local,name,hintlist) as obj) = if local then None else Some obj @@ -408,8 +473,8 @@ let (inAutoHint,outAutoHint) = export_function = export_autohint } -let create_hint_db l n b = - Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB b)) +let create_hint_db l n st b = + Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st))) (**************************************************************************) (* The "Hint" vernacular command *) @@ -419,29 +484,40 @@ let add_resolves env sigma clist local dbnames = (fun dbname -> Lib.add_anonymous_leaf (inAutoHint - (local,dbname, UpdateDB - (List.flatten (List.map (fun (x, y) -> - make_resolves env sigma (true,Flags.is_verbose()) x y) clist))))) + (local,dbname, AddTactic + (List.flatten (List.map (fun (x, hnf, y) -> + make_resolves env sigma (true,hnf,Flags.is_verbose()) x y) clist))))) dbnames let add_unfolds l local dbnames = List.iter (fun dbname -> Lib.add_anonymous_leaf - (inAutoHint (local,dbname, UpdateDB (List.map make_unfold l)))) + (inAutoHint (local,dbname, AddTactic (List.map make_unfold l)))) + dbnames + +let add_transparency l b local dbnames = + List.iter + (fun dbname -> Lib.add_anonymous_leaf + (inAutoHint (local,dbname, AddTransparency (l, b)))) dbnames -let add_extern pri (patmetas,pat) tacast local dbname = +let add_extern pri pat tacast local dbname = (* We check that all metas that appear in tacast have at least one occurence in the left pattern pat *) let tacmetas = [] in - match (list_subtract tacmetas patmetas) with - | i::_ -> - errorlabstrm "add_extern" - (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound.") - | [] -> + match pat with + | Some (patmetas,pat) -> + (match (list_subtract tacmetas patmetas) with + | i::_ -> + errorlabstrm "add_extern" + (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound.") + | [] -> + Lib.add_anonymous_leaf + (inAutoHint(local,dbname, AddTactic [make_extern pri (Some pat) tacast]))) + | None -> Lib.add_anonymous_leaf - (inAutoHint(local,dbname, UpdateDB [make_extern pri pat tacast])) + (inAutoHint(local,dbname, AddTactic [make_extern pri None tacast])) let add_externs pri pat tacast local dbnames = List.iter (add_extern pri pat tacast local) dbnames @@ -450,7 +526,7 @@ let add_trivials env sigma l local dbnames = List.iter (fun dbname -> Lib.add_anonymous_leaf ( - inAutoHint(local,dbname, UpdateDB (List.map (make_trivial env sigma) l)))) + inAutoHint(local,dbname, AddTactic (List.map (make_trivial env sigma) l)))) dbnames let forward_intern_tac = @@ -464,7 +540,7 @@ let add_hints local dbnames0 h = let f = Constrintern.interp_constr sigma env in match h with | HintsResolve lhints -> - add_resolves env sigma (List.map (fun (pri, x) -> pri, f x) lhints) local dbnames + add_resolves env sigma (List.map (fun (pri, b, x) -> pri, b, f x) lhints) local dbnames | HintsImmediate lhints -> add_trivials env sigma (List.map f lhints) local dbnames | HintsUnfold lhints -> @@ -478,21 +554,35 @@ let add_hints local dbnames0 h = (str "Cannot coerce" ++ spc () ++ pr_global gr ++ spc () ++ str "to an evaluable reference.") in - if !Flags.dump then Constrintern.add_glob (loc_of_reference r) gr; + Dumpglob.add_glob (loc_of_reference r) gr; (gr,r') in add_unfolds (List.map f lhints) local dbnames + | HintsTransparency (lhints, b) -> + let f r = + let gr = Syntax_def.global_with_alias r in + let r' = match gr with + | ConstRef c -> EvalConstRef c + | VarRef c -> EvalVarRef c + | _ -> + errorlabstrm "evalref_of_ref" + (str "Cannot coerce" ++ spc () ++ pr_global gr ++ spc () ++ + str "to an evaluable reference.") + in + Dumpglob.add_glob (loc_of_reference r) gr; + r' in + add_transparency (List.map f lhints) b local dbnames | HintsConstructors lqid -> let add_one qid = let env = Global.env() and sigma = Evd.empty in let isp = inductive_of_reference qid in let consnames = (snd (Global.lookup_inductive isp)).mind_consnames in let lcons = list_tabulate - (fun i -> None, mkConstruct (isp,i+1)) (Array.length consnames) in + (fun i -> None, true, mkConstruct (isp,i+1)) (Array.length consnames) in add_resolves env sigma lcons local dbnames in List.iter add_one lqid | HintsExtern (pri, patcom, tacexp) -> - let pat = Constrintern.interp_constrpattern Evd.empty (Global.env()) patcom in - let tacexp = !forward_intern_tac (fst pat) tacexp in + let pat = Option.map (Constrintern.intern_constr_pattern Evd.empty (Global.env())) patcom in + let tacexp = !forward_intern_tac (match pat with None -> [] | Some (l, _) -> l) tacexp in add_externs pri pat tacexp local dbnames | HintsDestruct(na,pri,loc,pat,code) -> if dbnames0<>[] then @@ -503,7 +593,7 @@ let add_hints local dbnames0 h = (* Functions for printing the hints *) (**************************************************************************) -let fmt_autotactic = +let pr_autotactic = function | Res_pf (c,clenv) -> (str"apply " ++ pr_lconstr c) | ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c) @@ -514,19 +604,19 @@ let fmt_autotactic = | Extern tac -> (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac) -let fmt_hint v = - (fmt_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ()) +let pr_hint v = + (pr_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ()) -let fmt_hint_list hintlist = - (str " " ++ hov 0 (prlist fmt_hint hintlist) ++ fnl ()) +let pr_hint_list hintlist = + (str " " ++ hov 0 (prlist pr_hint hintlist) ++ fnl ()) -let fmt_hints_db (name,db,hintlist) = +let pr_hints_db (name,db,hintlist) = (str "In the database " ++ str name ++ str ":" ++ if hintlist = [] then (str " nothing" ++ fnl ()) - else (fnl () ++ fmt_hint_list hintlist)) + else (fnl () ++ pr_hint_list hintlist)) (* Print all hints associated to head c in any database *) -let fmt_hint_list_for_head c = +let pr_hint_list_for_head c = let dbs = Hintdbmap.to_list !searchtable in let valid_dbs = map_succeed @@ -538,19 +628,16 @@ let fmt_hint_list_for_head c = else hov 0 (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++ - hov 0 (prlist fmt_hints_db valid_dbs)) + hov 0 (prlist pr_hints_db valid_dbs)) -let fmt_hint_ref ref = fmt_hint_list_for_head ref +let pr_hint_ref ref = pr_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) +let print_hint_ref ref = ppnl(pr_hint_ref ref) -let fmt_hint_term cl = +let pr_hint_term cl = try - let (hdc,args) = match head_constr_bound cl [] with - | hdc::args -> (hdc,args) - | [] -> assert false - in + let (hdc,args) = head_constr_bound cl in let hd = head_of_constr_reference hdc in let dbs = Hintdbmap.to_list !searchtable in let valid_dbs = @@ -568,14 +655,14 @@ let fmt_hint_term cl = (str "No hint applicable for current goal") else (str "Applicable Hints :" ++ fnl () ++ - hov 0 (prlist fmt_hints_db valid_dbs)) + hov 0 (prlist pr_hints_db valid_dbs)) with Bound | Match_failure _ | Failure _ -> (str "No hint applicable for current goal") let error_no_such_hint_database x = error ("No such Hint database: "^x^".") -let print_hint_term cl = ppnl (fmt_hint_term cl) +let print_hint_term cl = ppnl (pr_hint_term cl) (* print all hints that apply to the concl of the current goal *) let print_applicable_hint () = @@ -591,9 +678,15 @@ let print_hint_db db = str"Unfoldable constant definitions: " ++ pr_cpred csts ++ fnl ())); Hint_db.iter (fun head hintlist -> - msg (hov 0 - (str "For " ++ pr_global head ++ str " -> " ++ - fmt_hint_list hintlist))) + match head with + | Some head -> + msg (hov 0 + (str "For " ++ pr_global head ++ str " -> " ++ + pr_hint_list hintlist)) + | None -> + msg (hov 0 + (str "For any goal -> " ++ + pr_hint_list hintlist))) db let print_hint_db_by_name dbname = @@ -618,7 +711,10 @@ let print_searchtable () = (* tactics with a trace mechanism for automatic search *) (**************************************************************************) -let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) +let priority l = List.filter (fun (_,hint) -> hint.pri = 0) l + +let select_unfold_extern = + List.filter (function (_,{code = (Unfold_nth _ | Extern _)}) -> true | _ -> false) (* tell auto not to reuse already instantiated metas in unification (for compatibility, since otherwise, apply succeeds oftener) *) @@ -633,25 +729,33 @@ let auto_unif_flags = { (* Try unification with the precompiled clause, then use registered Apply *) -let unify_resolve_nodelta (c,clenv) gls = - let clenv' = connect_clenv gls clenv in - let _ = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gls in - h_simplest_apply c gls +let unify_resolve_nodelta (c,clenv) gl = + let clenv' = connect_clenv gl clenv in + let _ = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gl in + h_simplest_apply c gl -let unify_resolve flags (c,clenv) gls = - let clenv' = connect_clenv gls clenv in - let _ = clenv_unique_resolver false ~flags clenv' gls in - h_apply true false [c,NoBindings] gls +let unify_resolve flags (c,clenv) gl = + let clenv' = connect_clenv gl clenv in + let _ = clenv_unique_resolver false ~flags clenv' gl in + h_apply true false [inj_open c,NoBindings] gl +let unify_resolve_gen = function + | None -> unify_resolve_nodelta + | Some flags -> unify_resolve flags (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types *) -let make_local_hint_db eapply lems g = - let sign = pf_hyps g in - let hintlist = list_map_append (pf_apply make_resolve_hyp g) sign in - let hintlist' = list_map_append (pf_apply make_resolves g (eapply,false) None) lems in - Hint_db.add_list hintlist' (Hint_db.add_list hintlist (Hint_db.empty false)) +let add_hint_lemmas eapply lems hint_db gl = + let hintlist' = + list_map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in + Hint_db.add_list hintlist' hint_db + +let make_local_hint_db eapply lems gl = + let sign = pf_hyps gl in + let hintlist = list_map_append (pf_apply make_resolve_hyp gl) sign in + add_hint_lemmas eapply lems + (Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false)) gl (* 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 @@ -671,10 +775,13 @@ let forward_interp_tactic = let set_extern_interp f = forward_interp_tactic := f let conclPattern concl pat tac gl = - let constr_bindings = - try matches pat concl - with PatternMatchingFailure -> error "conclPattern" in - !forward_interp_tactic constr_bindings tac gl + let constr_bindings = + match pat with + | None -> [] + | Some pat -> + try matches pat concl + with PatternMatchingFailure -> error "conclPattern" in + !forward_interp_tactic constr_bindings tac gl (**************************************************************************) (* The Trivial tactic *) @@ -684,6 +791,10 @@ let conclPattern concl pat tac gl = (* Papageno : cette fonction a été pas mal simplifiée depuis que la base de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) +let flags_of_state st = + {auto_unif_flags with + modulo_conv_on_closed_terms = Some st; modulo_delta = st} + let rec trivial_fail_db mod_delta db_list local_db gl = let intro_tac = tclTHEN intro @@ -697,29 +808,12 @@ let rec trivial_fail_db mod_delta db_list local_db gl = (trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl and my_find_search_nodelta db_list local_db hdc concl = - let tacl = - if occur_existential concl then - list_map_append (Hint_db.map_all hdc) - (local_db::db_list) - else - list_map_append (Hint_db.map_auto (hdc,concl)) - (local_db::db_list) - in - List.map - (fun {pri=b; pat=p; code=t} -> - (b, - match t with - | Res_pf (term,cl) -> unify_resolve_nodelta (term,cl) - | ERes_pf (_,c) -> (fun gl -> error "eres_pf") - | Give_exact c -> exact_check c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN - (unify_resolve_nodelta (term,cl)) - (trivial_fail_db false db_list local_db) - | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> - conclPattern concl (Option.get p) tacast)) - tacl + if occur_existential concl then + List.map (fun hint -> (None,hint)) + (list_map_append (Hint_db.map_all hdc) (local_db::db_list)) + else + List.map (fun hint -> (None,hint)) + (list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list)) and my_find_search mod_delta = if mod_delta then my_find_search_delta @@ -727,46 +821,51 @@ and my_find_search mod_delta = and my_find_search_delta db_list local_db hdc concl = let flags = {auto_unif_flags with use_metas_eagerly = true} in - let tacl = if occur_existential concl then list_map_append (fun db -> - let st = {flags with modulo_delta = Hint_db.transparent_state db} in - List.map (fun x -> (st,x)) (Hint_db.map_all hdc db)) + if Hint_db.use_dn db then + let flags = flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (Some flags, x)) (Hint_db.map_auto (hdc,concl) db) + else + let flags = {flags with modulo_delta = Hint_db.transparent_state db} in + List.map (fun x -> (Some flags,x)) (Hint_db.map_all hdc db)) (local_db::db_list) else list_map_append (fun db -> - let (ids, csts as st) = Hint_db.transparent_state db in - let st, l = - let l = - if (Idpred.is_empty ids && Cpred.is_empty csts) - then Hint_db.map_auto (hdc,concl) db - else Hint_db.map_all hdc db - in {flags with modulo_delta = st}, l - in List.map (fun x -> (st,x)) l) + if Hint_db.use_dn db then + let flags = flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (Some flags, x)) (Hint_db.map_auto (hdc,concl) db) + else + let (ids, csts as st) = Hint_db.transparent_state db in + let flags, l = + let l = + if (Idpred.is_empty ids && Cpred.is_empty csts) + then Hint_db.map_auto (hdc,concl) db + else Hint_db.map_all hdc db + in {flags with modulo_delta = st}, l + in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) - in - List.map - (fun (st, {pri=b; pat=p; code=t}) -> - (b, - match t with - | Res_pf (term,cl) -> unify_resolve st (term,cl) - | ERes_pf (_,c) -> (fun gl -> error "eres_pf") - | Give_exact c -> exact_check c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN - (unify_resolve st (term,cl)) - (trivial_fail_db true db_list local_db) - | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> - conclPattern concl (Option.get p) tacast)) - tacl + +and tac_of_hint db_list local_db concl (flags, {pat=p; code=t}) = + match t with + | Res_pf (term,cl) -> unify_resolve_gen flags (term,cl) + | ERes_pf (_,c) -> (fun gl -> error "eres_pf") + | Give_exact c -> exact_check c + | Res_pf_THEN_trivial_fail (term,cl) -> + tclTHEN + (unify_resolve_gen flags (term,cl)) + (trivial_fail_db (flags <> None) db_list local_db) + | Unfold_nth c -> unfold_in_concl [all_occurrences,c] + | Extern tacast -> conclPattern concl p tacast and trivial_resolve mod_delta db_list local_db cl = try - let hdconstr = List.hd (head_constr_bound cl []) in - priority - (my_find_search mod_delta db_list local_db (head_of_constr_reference hdconstr) cl) + let hdconstr,_ = head_constr_bound cl in + List.map (tac_of_hint db_list local_db cl) + (priority + (my_find_search mod_delta db_list local_db + (head_of_constr_reference hdconstr) cl)) with Bound | Not_found -> [] @@ -804,70 +903,82 @@ let h_trivial lems l = let possible_resolve mod_delta db_list local_db cl = try - let hdconstr = List.hd (head_constr_bound cl []) in - List.map snd - (my_find_search mod_delta db_list local_db (head_of_constr_reference hdconstr) cl) + let hdconstr,_ = head_constr_bound cl in + List.map (tac_of_hint db_list local_db cl) + (my_find_search mod_delta db_list local_db + (head_of_constr_reference hdconstr) cl) with Bound | Not_found -> [] -let decomp_unary_term c gls = - let typc = pf_type_of gls c in - let hd = List.hd (head_constr typc) in - if Hipattern.is_conjunction hd then - simplest_case c gls - else - errorlabstrm "Auto.decomp_unary_term" (str "Not a unary type.") - -let decomp_empty_term c gls = - let typc = pf_type_of gls c in - let (hd,_) = decompose_app typc in - if Hipattern.is_empty_type hd then - simplest_case c gls +let decomp_unary_term_then (id,_,typc) kont1 kont2 gl = + try + let ccl = applist (head_constr typc) in + match Hipattern.match_with_conjunction ccl with + | Some (_,args) -> + tclTHEN (simplest_case (mkVar id)) (kont1 (List.length args)) gl + | None -> + kont2 gl + with UserError _ -> kont2 gl + +let decomp_empty_term (id,_,typc) gl = + if Hipattern.is_empty_type typc then + simplest_case (mkVar id) gl else errorlabstrm "Auto.decomp_empty_term" (str "Not an empty type.") +let extend_local_db gl decl db = + Hint_db.add_list (make_resolve_hyp (pf_env gl) (project gl) decl) db + +(* Try to decompose hypothesis [decl] into atomic components of a + conjunction with maximum depth [p] (or solve the goal from an + empty type) then call the continuation tactic with hint db extended + with the obtappined not-further-decomposable hypotheses *) + +let rec decomp_and_register_decl p kont (id,_,_ as decl) db gl = + if p = 0 then + kont (extend_local_db gl decl db) gl + else + tclORELSE0 + (decomp_empty_term decl) + (decomp_unary_term_then decl (intros_decomp (p-1) kont [] db) + (kont (extend_local_db gl decl db))) gl + +(* Introduce [n] hypotheses, then decompose then with maximum depth [p] and + call the continuation tactic [kont] with the hint db extended + with the so-obtained not-further-decomposable hypotheses *) + +and intros_decomp p kont decls db n = + if n = 0 then + decomp_and_register_decls p kont decls db + else + tclTHEN intro (tclLAST_DECL (fun d -> + (intros_decomp p kont (d::decls) db (n-1)))) + +(* Decompose hypotheses [hyps] with maximum depth [p] and + call the continuation tactic [kont] with the hint db extended + with the so-obtained not-further-decomposable hypotheses *) + +and decomp_and_register_decls p kont decls = + List.fold_left (decomp_and_register_decl p) kont decls + (* decomp is an natural number giving an indication on decomposition of conjunction in hypotheses, 0 corresponds to no decomposition *) (* n is the max depth of search *) (* local_db contains the local Hypotheses *) -let rec search_gen decomp n mod_delta db_list local_db extra_sign goal = - if n=0 then error "BOUND 2"; - let decomp_tacs = match decomp with - | 0 -> [] - | p -> - (tclTRY_sign decomp_empty_term extra_sign) - :: - (List.map - (fun id -> tclTHENSEQ - [decomp_unary_term (mkVar id); - clear [id]; - search_gen decomp p mod_delta db_list local_db []]) - (pf_ids_of_hyps goal)) - in - let intro_tac = - tclTHEN intro - (fun g' -> - let (hid,_,htyp as d) = pf_last_hyp g' in - let hintl = - try - [make_apply_entry (pf_env g') (project g') - (true,false) None - (mkVar hid, htyp)] - with Failure _ -> [] - in - search_gen decomp n mod_delta db_list (Hint_db.add_list hintl local_db) [d] g') - in - let rec_tacs = - List.map - (fun ntac -> - tclTHEN ntac - (search_gen decomp (n-1) mod_delta db_list local_db empty_named_context)) - (possible_resolve mod_delta db_list local_db (pf_concl goal)) - in - tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal +exception Uplift of tactic list +let rec search_gen p n mod_delta db_list local_db = + let rec search n local_db gl = + if n=0 then error "BOUND 2"; + tclFIRST + (assumption :: + intros_decomp p (search n) [] local_db 1 :: + List.map (fun ntac -> tclTHEN ntac (search (n-1) local_db)) + (possible_resolve mod_delta db_list local_db (pf_concl gl))) gl + in + search n local_db let search = search_gen 0 @@ -883,8 +994,7 @@ let delta_auto mod_delta n lems dbnames gl = error_no_such_hint_database x) ("core"::dbnames) in - let hyps = pf_hyps gl in - tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl) hyps) gl + tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl let auto = delta_auto false @@ -896,8 +1006,7 @@ let delta_full_auto mod_delta 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 mod_delta db_list (make_local_hint_db false lems gl) hyps) gl + tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl let full_auto = delta_full_auto false let new_full_auto = delta_full_auto true @@ -922,14 +1031,15 @@ let h_auto n lems l = (* Depth of search after decomposition of hypothesis, by default one look for an immediate solution *) -(* Papageno : de toute façon un paramète > 1 est traité comme 1 pour - l'instant *) -let default_search_decomp = ref 1 - -let destruct_auto des_opt lems n gl = - let hyps = pf_hyps gl in - search_gen des_opt n false (List.map searchtable_map ["core";"extcore"]) - (make_local_hint_db false lems gl) hyps gl +let default_search_decomp = ref 20 + +let destruct_auto p lems n gl = + decomp_and_register_decls p (fun local_db gl -> + search_gen p n false (List.map searchtable_map ["core";"extcore"]) + (add_hint_lemmas false lems local_db gl) gl) + (pf_hyps gl) + (Hint_db.empty empty_transparent_state false) + gl let dautomatic des_opt lems n = tclTRY (destruct_auto des_opt lems n) @@ -952,7 +1062,7 @@ let make_resolve_any_hyp env sigma (id,_,ty) = let ents = map_succeed (fun f -> f (mkVar id,ty)) - [make_exact_entry None; make_apply_entry env sigma (true,false) None] + [make_exact_entry None; make_apply_entry env sigma (true,true,false) None] in ents @@ -988,25 +1098,23 @@ let compileAutoArg contac = function let compileAutoArgList contac = List.map (compileAutoArg contac) -let rec super_search n db_list local_db argl goal = +let rec super_search n db_list local_db argl gl = if n = 0 then error "BOUND 2"; tclFIRST (assumption :: - (tclTHEN intro + tclTHEN intro (fun g -> 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)) + argl g) :: - ((List.map - (fun ntac -> + List.map (fun ntac -> tclTHEN ntac (super_search (n-1) db_list local_db argl)) - (possible_resolve false db_list local_db (pf_concl goal))) + (possible_resolve false db_list local_db (pf_concl gl)) @ - (compileAutoArgList - (super_search (n-1) db_list local_db argl) argl))) goal + compileAutoArgList (super_search (n-1) db_list local_db argl) argl) gl let search_superauto n to_add argl g = let sigma = diff --git a/tactics/auto.mli b/tactics/auto.mli index edaaa1c1..c9065ef3 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 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: auto.mli 11735 2009-01-02 17:22:31Z herbelin $ i*) (*i*) open Util @@ -44,20 +44,24 @@ type stored_data = pri_auto_tactic type search_entry = stored_data list * stored_data list * stored_data Btermdn.t +(* The head may not be bound. *) + +type hint_entry = global_reference option * pri_auto_tactic + module Hint_db : sig type t - val empty : bool -> t + val empty : transparent_state -> bool -> t 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 + val add_one : hint_entry -> t -> t + val add_list : (hint_entry) list -> t -> t + val iter : (global_reference option -> stored_data list -> unit) -> t -> unit + val use_dn : t -> bool val transparent_state : t -> transparent_state val set_transparent_state : t -> transparent_state -> t - val set_rigid : t -> constant -> t end type hint_db_name = string @@ -68,7 +72,12 @@ val searchtable_map : hint_db_name -> hint_db val searchtable_add : (hint_db_name * hint_db) -> unit -val create_hint_db : bool -> hint_db_name -> bool -> unit +(* [create_hint_db local name st use_dn]. + [st] is a transparency state for unification using this db + [use_dn] switches the use of the discrimination net for all hints + and patterns. *) + +val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit val current_db_names : unit -> hint_db_name list @@ -86,16 +95,18 @@ val print_hint_db_by_name : hint_db_name -> unit [c] is the term given as an exact proof to solve the goal; [ctyp] is the type of [c]. *) -val make_exact_entry : int option -> constr * constr -> global_reference * pri_auto_tactic +val make_exact_entry : int option -> constr * constr -> hint_entry (* [make_apply_entry (eapply,verbose) pri (c,cty)]. [eapply] is true if this hint will be used only with EApply; + [hnf] should be true if we should expand the head of cty before searching for + products; [c] is the term given as an exact proof to solve the goal; - [cty] is the type of [hc]. *) - + [cty] is the type of [c]. *) + val make_apply_entry : - env -> evar_map -> bool * bool -> int option -> constr * constr - -> global_reference * pri_auto_tactic + env -> evar_map -> bool * bool * bool -> int option -> constr * constr + -> hint_entry (* A constr which is Hint'ed will be: (1) used as an Exact, if it does not start with a product @@ -105,8 +116,8 @@ val make_apply_entry : has missing arguments. *) val make_resolves : - env -> evar_map -> bool * bool -> int option -> constr -> - (global_reference * pri_auto_tactic) list + env -> evar_map -> bool * bool * bool -> int option -> constr -> + hint_entry list (* [make_resolve_hyp hname htyp]. used to add an hypothesis to the local hint database; @@ -114,14 +125,13 @@ val make_resolves : If the hyp cannot be used as a Hint, the empty list is returned. *) val make_resolve_hyp : - env -> evar_map -> named_declaration -> - (global_reference * pri_auto_tactic) list + env -> evar_map -> named_declaration -> hint_entry list (* [make_extern pri pattern tactic_expr] *) val make_extern : - int -> constr_pattern -> Tacexpr.glob_tactic_expr - -> global_reference * pri_auto_tactic + int -> constr_pattern option -> Tacexpr.glob_tactic_expr + -> hint_entry val set_extern_interp : (patvar_map -> Tacexpr.glob_tactic_expr -> tactic) -> unit @@ -140,7 +150,7 @@ val set_extern_subst_tactic : val make_local_hint_db : bool -> constr list -> goal sigma -> hint_db -val priority : (int * 'a) list -> 'a list +val priority : ('a * pri_auto_tactic) list -> ('a * pri_auto_tactic) list val default_search_depth : int ref @@ -156,7 +166,7 @@ val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the right values to build a tactic *) -val conclPattern : constr -> constr_pattern -> Tacexpr.glob_tactic_expr -> tactic +val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -> tactic (* The Auto tactic *) @@ -192,7 +202,7 @@ 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 +val pr_autotactic : auto_tactic -> Pp.std_ppcmds (*s The following is not yet up to date -- Papageno. *) diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index 6eb5e359..e609fb77 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -9,7 +9,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: class_tactics.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: class_tactics.ml4 11823 2009-01-21 15:32:37Z msozeau $ *) open Pp open Util @@ -43,7 +43,8 @@ open Evd let default_eauto_depth = 100 let typeclasses_db = "typeclass_instances" -let _ = Auto.auto_init := (fun () -> Auto.create_hint_db false typeclasses_db false) +let _ = Auto.auto_init := (fun () -> + Auto.create_hint_db false typeclasses_db full_transparent_state true) let check_imported_library d = let d' = List.map id_of_string d in @@ -60,26 +61,20 @@ let init_setoid () = (** Typeclasses instance search tactic / eauto *) -let evars_of_term init c = - let rec evrec acc c = - match kind_of_term c with - | Evar (n, _) -> Intset.add n acc - | _ -> fold_constr evrec acc c - in - evrec init c - let intersects s t = Intset.exists (fun el -> Intset.mem el t) s open Auto -let e_give_exact c gl = +let e_give_exact flags 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 (Clenvtac.unify t1) (exact_check c) gl - else exact_check c gl - -let assumption id = e_give_exact (mkVar id) + if occur_existential t1 or occur_existential t2 then + tclTHEN (Clenvtac.unify (* ~flags *) t1) (exact_no_check c) gl + else exact_check c gl +(* let t1 = (pf_type_of gl c) in *) +(* tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl *) + +let assumption flags id = e_give_exact flags (mkVar id) open Unification @@ -89,19 +84,21 @@ let auto_unif_flags = { modulo_delta = var_full_transparent_state; } -let unify_e_resolve st (c,clenv) gls = +let unify_e_resolve flags (c,clenv) gls = let clenv' = connect_clenv gls clenv in - let clenv' = clenv_unique_resolver false - ~flags:{auto_unif_flags with modulo_delta = st} clenv' gls + let clenv' = clenv_unique_resolver false ~flags clenv' gls in - Clenvtac.clenv_refine true clenv' gls + Clenvtac.clenv_refine true ~with_classes:false clenv' gls -let unify_resolve st (c,clenv) gls = +let unify_resolve flags (c,clenv) gls = let clenv' = connect_clenv gls clenv in - let clenv' = clenv_unique_resolver false - ~flags:{auto_unif_flags with modulo_delta = st} clenv' gls + let clenv' = clenv_unique_resolver false ~flags clenv' gls in - Clenvtac.clenv_refine false clenv' gls + Clenvtac.clenv_refine false ~with_classes:false clenv' gls + +let flags_of_state st = + {auto_unif_flags with + modulo_conv_on_closed_terms = Some st; modulo_delta = st} let rec e_trivial_fail_db db_list local_db goal = let tacl = @@ -119,47 +116,43 @@ let rec e_trivial_fail_db db_list local_db goal = and e_my_find_search db_list local_db hdc concl = let hdc = head_of_constr_reference hdc in let hintl = - if occur_existential concl then - list_map_append - (fun db -> - let st = Hint_db.transparent_state db in - List.map (fun x -> (st, x)) (Hint_db.map_all hdc db)) - (local_db::db_list) - else - list_map_append - (fun db -> - let st = Hint_db.transparent_state db in - List.map (fun x -> (st, x)) (Hint_db.map_auto (hdc,concl) db)) - (local_db::db_list) + list_map_append + (fun db -> + if Hint_db.use_dn db then + let flags = flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (flags, x)) (Hint_db.map_auto (hdc,concl) db) + else + let flags = flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (flags, x)) (Hint_db.map_all hdc db)) + (local_db::db_list) in let tac_of_hint = - fun (st, {pri=b; pat = p; code=t}) -> + fun (flags, {pri=b; pat = p; code=t}) -> let tac = match t with - | Res_pf (term,cl) -> unify_resolve st (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve st (term,cl) - | Give_exact (c) -> e_give_exact c + | Res_pf (term,cl) -> unify_resolve flags (term,cl) + | ERes_pf (term,cl) -> unify_e_resolve flags (term,cl) + | Give_exact (c) -> e_give_exact flags c | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve st (term,cl)) + tclTHEN (unify_e_resolve flags (term,cl)) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> conclPattern concl - (Option.get p) tacast + | Extern tacast -> conclPattern concl p tacast in - (tac,b,fmt_autotactic t) + (tac,b,pr_autotactic t) in List.map tac_of_hint hintl and e_trivial_resolve db_list local_db gl = try e_my_find_search db_list local_db - (List.hd (head_constr_bound gl [])) gl + (fst (head_constr_bound gl)) gl with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = try e_my_find_search db_list local_db - (List.hd (head_constr_bound gl [])) gl + (fst (head_constr_bound gl)) gl with Bound | Not_found -> [] let find_first_goal gls = @@ -184,14 +177,14 @@ let rec catchable = function | e -> Logic.catchable_exception e let is_dep gl gls = - let evs = evars_of_term Intset.empty gl.evar_concl in + let evs = Evarutil.evars_of_term gl.evar_concl in if evs = Intset.empty then false else List.fold_left (fun b gl -> if b then b else - let evs' = evars_of_term Intset.empty gl.evar_concl in + let evs' = Evarutil.evars_of_term gl.evar_concl in intersects evs evs') false gls @@ -210,7 +203,7 @@ module SearchProblem = struct prlist (pr_ev evars) (sig_it gls) let filter_tactics (glls,v) l = - let glls,nv = apply_tac_list tclNORMEVAR glls in + let glls,nv = apply_tac_list Refiner.tclNORMEVAR glls in let v p = v (nv p) in let rec aux = function | [] -> [] @@ -243,37 +236,35 @@ module SearchProblem = struct [] else let (cut, do_cut, ldb as hdldb) = List.hd s.localdb in - if !cut then [] + if !cut then +(* let {it=gls; sigma=sigma} = fst s.tacres in *) +(* msg (str"cut:" ++ pr_ev sigma (List.hd gls) ++ str"\n"); *) + [] else begin - Option.iter (fun r -> r := true) do_cut; let {it=gl; sigma=sigma} = fst s.tacres in + Option.iter (fun r -> +(* msg (str"do cut:" ++ pr_ev sigma (List.hd gl) ++ str"\n"); *) + r := true) do_cut; + let sigma = Evarutil.nf_evars sigma in + let gl = List.map (Evarutil.nf_evar_info sigma) gl in let nbgl = List.length gl in - let g = { it = List.hd gl ; sigma = sigma } in +(* let gl' = { it = gl ; sigma = sigma } in *) +(* let tacres' = gl', snd s.tacres in *) let new_db, localdb = let tl = List.tl s.localdb in match tl with | [] -> hdldb, tl | (cut', do', ldb') :: rest -> - if not (is_dep (Evarutil.nf_evar_info sigma (List.hd gl)) (List.tl gl)) then + if not (is_dep (List.hd gl) (List.tl gl)) then let fresh = ref false in - if do' = None then + if do' = None then ( +(* msg (str"adding a cut:" ++ pr_ev sigma (List.hd gl) ++ str"\n"); *) (fresh, None, ldb), (cut', Some fresh, ldb') :: rest - else - (cut', None, ldb), tl + ) else ( +(* msg (str"keeping the previous cut:" ++ pr_ev sigma (List.hd gl) ++ str"\n"); *) + (cut', None, ldb), tl ) else hdldb, tl in let localdb = new_db :: localdb in - let assumption_tacs = - let l = - filter_tactics s.tacres - (List.map - (fun id -> (Eauto.e_give_exact_constr (mkVar id), 0, - (str "exact" ++ spc () ++ pr_id id))) - (List.filter (fun id -> filter_hyp (pf_get_hyp_typ g id)) - (pf_ids_of_hyps g))) - in - List.map (fun (res,pri,pp) -> { s with tacres = res; pri = 0; - last_tactic = pp; localdb = List.tl s.localdb }) l - in let intro_tac = List.map (fun ((lgls,_) as res,pri,pp) -> @@ -300,14 +291,13 @@ module SearchProblem = struct last_tactic = pp; pri = pri; localdb = list_tabulate (fun _ -> new_db) (nbgl'-nbgl) @ localdb } in - let concl = Evarutil.nf_evar (project g) (pf_concl g) in let rec_tacs = let l = - filter_tactics s.tacres (e_possible_resolve s.dblist ldb concl) + filter_tactics s.tacres (e_possible_resolve s.dblist ldb (List.hd gl).evar_concl) in List.map possible_resolve l in - List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) + List.sort compare (intro_tac @ rec_tacs) end let pp s = @@ -318,46 +308,6 @@ end module Search = Explore.Make(SearchProblem) - -let filter_pat c = - try - let morg = Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism")) in - let morc = constr_of_global morg in - match kind_of_term c with - | App(morph, [| t; r; m |]) when eq_constr morph morc -> - (fun y -> - (match y.pat with - Some (PApp (PRef mor, [| t'; r'; m' |])) when mor = morg -> - (match m' with - | PRef c -> if isConst m then eq_constr (constr_of_global c) m else false - | _ -> true) - | _ -> true)) - | _ -> fun _ -> true - with _ -> fun _ -> true - -let morphism_class = - lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism")))) - -let morphism_proxy_class = - lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.MorphismProxy")))) - -let filter c = - try let morc = constr_of_global (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism"))) in - match kind_of_term c with - | App(morph, [| t; r; m |]) when eq_constr morph morc -> - (fun y -> - let (_, r) = decompose_prod y in - (match kind_of_term r with - App (morph', [| t'; r'; m' |]) when eq_constr morph' morc -> - (match kind_of_term m' with - | Rel n -> true - | Const c -> eq_constr m m' - | App _ -> true - | _ -> false) - | _ -> false)) - | _ -> fun _ -> true - with _ -> fun _ -> true - let make_initial_state n gls dblist localdbs = { depth = n; tacres = gls; @@ -379,11 +329,39 @@ let e_breadth_search debug s = in let s = tac s in s.tacres with Not_found -> error "eauto: breadth first search failed." + +(* A special one for getting everything into a dnet. *) + +let is_transparent_gr (ids, csts) = function + | VarRef id -> Idpred.mem id ids + | ConstRef cst -> Cpred.mem cst csts + | IndRef _ | ConstructRef _ -> false + +let make_resolve_hyp env sigma st flags pri (id, _, cty) = + let ctx, ar = decompose_prod cty in + let keep = + match kind_of_term (fst (decompose_app ar)) with + | Const c -> is_class (ConstRef c) + | Ind i -> is_class (IndRef i) + | _ -> false + in + if keep then let c = mkVar id in + map_succeed + (fun f -> f (c,cty)) + [make_exact_entry pri; make_apply_entry env sigma flags pri] + else [] + +let make_local_hint_db st eapply lems g = + let sign = pf_hyps g in + let hintlist = list_map_append (pf_apply make_resolve_hyp g st (eapply,false,false) None) sign in + let hintlist' = list_map_append (pf_apply make_resolves g (eapply,false,false) None) lems in + Hint_db.add_list hintlist' (Hint_db.add_list hintlist (Hint_db.empty st true)) + let e_search_auto debug (in_depth,p) lems st db_list gls = let sigma = Evd.sig_sig (fst gls) and gls' = Evd.sig_it (fst gls) in let local_dbs = List.map (fun gl -> - let db = make_local_hint_db true lems ({it = gl; sigma = sigma}) in - (ref false, None, Hint_db.set_transparent_state db st)) gls' in + let db = make_local_hint_db st true lems ({it = gl; sigma = sigma}) in + (ref false, None, db)) gls' in let state = make_initial_state p gls db_list local_dbs in if in_depth then e_depth_search debug state @@ -394,7 +372,8 @@ let full_eauto debug n lems gls = let dbnames = current_db_names () in let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map searchtable_map dbnames in - e_search_auto debug n lems empty_transparent_state db_list gls + let db = searchtable_map typeclasses_db in + e_search_auto debug n lems (Hint_db.transparent_state db) db_list gls let nf_goal (gl, valid) = { gl with sigma = Evarutil.nf_evars gl.sigma }, valid @@ -415,16 +394,23 @@ let valid goals p res_sigma l = else sigma) !res_sigma goals l in raise (Found evm) + +let is_dependent ev evm = + Evd.fold (fun ev' evi dep -> + if ev = ev' then dep + else dep || occur_evar ev evi.evar_concl) + evm false let resolve_all_evars_once debug (mode, depth) env p evd = let evm = Evd.evars_of evd in let goals, evm' = Evd.fold - (fun ev evi (gls, evm) -> + (fun ev evi (gls, evm') -> if evi.evar_body = Evar_empty && Typeclasses.is_resolvable evi - && p ev evi then ((ev,evi) :: gls, Evd.add evm ev (Typeclasses.mark_unresolvable evi)) else - (gls, Evd.add evm ev evi)) +(* && not (is_dependent ev evm) *) + && p ev evi then ((ev,evi) :: gls, Evd.add evm' ev (Typeclasses.mark_unresolvable evi)) else + (gls, Evd.add evm' ev evi)) evm ([], Evd.empty) in let goals = List.rev goals in @@ -463,7 +449,7 @@ let rec merge_deps deps = function let split_evars evm = Evd.fold (fun ev evi acc -> - let deps = evars_of_term (Intset.singleton ev) evi.evar_concl in + let deps = Intset.union (Intset.singleton ev) (Evarutil.evars_of_term evi.evar_concl) in merge_deps deps acc) evm [] @@ -501,7 +487,7 @@ let resolve_all_evars debug m env p oevd do_split fail = (fun ev evi (b,acc) -> (* focus on one instance if only one was searched for *) if class_of_constr evi.evar_concl <> None then - if not b then + if not b (* || do_split *) then true, Some ev else b, None else b, acc) evm (false, None) @@ -528,35 +514,36 @@ let _ = VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings -| [ "Typeclasses" "unfold" reference_list(cl) ] -> [ - add_hints false [typeclasses_db] (Vernacexpr.HintsUnfold cl) +| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ + add_hints false [typeclasses_db] (Vernacexpr.HintsTransparency (cl, true)) ] END - + VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings -| [ "Typeclasses" "rigid" reference_list(cl) ] -> [ - let db = searchtable_map typeclasses_db in - let db' = - List.fold_left (fun acc r -> - let gr = Syntax_def.global_with_alias r in - match gr with - | ConstRef c -> Hint_db.set_rigid acc c - | _ -> acc) db cl - in - searchtable_add (typeclasses_db,db') - ] +| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ + add_hints false [typeclasses_db] (Vernacexpr.HintsTransparency (cl, false)) + ] END (** Typeclass-based rewriting. *) -let respect_proj = lazy (mkConst (snd (List.hd (Lazy.force morphism_class).cl_projs))) +let morphism_class = + lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism")))) + +let morphism_proxy_class = + lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.MorphismProxy")))) + +let respect_proj = lazy (mkConst (Option.get (snd (List.hd (Lazy.force morphism_class).cl_projs)))) let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) -let try_find_reference dir s = +let try_find_global_reference dir s = let sp = Libnames.make_path (make_dir ("Coq"::dir)) (id_of_string s) in - constr_of_global (Nametab.absolute_reference sp) - + Nametab.absolute_reference sp + +let try_find_reference dir s = + constr_of_global (try_find_global_reference dir s) + let gen_constant dir s = Coqlib.gen_constant "Class_setoid" dir s let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1") let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2") @@ -565,23 +552,28 @@ let iff = lazy (gen_constant ["Init"; "Logic"] "iff") let coq_all = lazy (gen_constant ["Init"; "Logic"] "all") let impl = lazy (gen_constant ["Program"; "Basics"] "impl") let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow") -let coq_id = lazy (gen_constant ["Program"; "Basics"] "id") +let coq_id = lazy (gen_constant ["Init"; "Datatypes"] "id") let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive") +let reflexive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "reflexivity") let reflexive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "reflexivity") let symmetric_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Symmetric") let symmetric_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "symmetry") +let symmetric_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "symmetry") let transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive") let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity") +let transitive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "transitivity") let coq_inverse = lazy (gen_constant (* ["Classes"; "RelationClasses"] "inverse" *) ["Program"; "Basics"] "flip") let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) +(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; new_Type (); rel |]) *) let complement = lazy (gen_constant ["Classes"; "RelationClasses"] "complement") +let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") let respectful_dep = lazy (gen_constant ["Classes"; "Morphisms"] "respectful_dep") @@ -592,6 +584,8 @@ let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultR let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) +(* let mk_relation a = mkProd (Anonymous, a, mkProd (Anonymous, a, new_Type ())) *) + let coq_relationT = lazy (gen_constant ["Classes";"Relations"] "relationT") let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive") @@ -638,8 +632,6 @@ let split_head = function hd :: tl -> hd, tl | [] -> assert(false) -exception DependentMorphism - let build_signature isevars env m (cstrs : 'a option list) (finalcstr : 'a Lazy.t option) (f : 'a -> constr) = let new_evar isevars env t = Evarutil.e_new_evar isevars env @@ -656,21 +648,28 @@ let build_signature isevars env m (cstrs : 'a option list) (finalcstr : 'a Lazy. let t = Reductionops.whd_betadeltaiota env (Evd.evars_of !isevars) ty in match kind_of_term t, l with | Prod (na, ty, b), obj :: cstrs -> - if dependent (mkRel 1) ty then raise DependentMorphism; - let (b, arg, evars) = aux (Environ.push_rel (na, None, ty) env) b cstrs in - let ty = Reductionops.nf_betaiota ty in - let relty = mk_relty ty obj in - let arg' = mkApp (Lazy.force respectful, [| ty ; b ; relty ; arg |]) in - mkProd(na, ty, b), arg', (ty, relty) :: evars + if dependent (mkRel 1) b then + let (b, arg, evars) = aux (Environ.push_rel (na, None, ty) env) b cstrs in + let ty = Reductionops.nf_betaiota ty in + let pred = mkLambda (na, ty, b) in + let liftarg = mkLambda (na, ty, arg) in + let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in + mkProd(na, ty, b), arg', (ty, None) :: evars + else + let (b', arg, evars) = aux env (subst1 mkProp b) cstrs in + let ty = Reductionops.nf_betaiota ty in + let relty = mk_relty ty obj in + let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in + mkProd(na, ty, b), newarg, (ty, Some relty) :: evars | _, obj :: _ -> anomaly "build_signature: not enough products" | _, [] -> (match finalcstr with None -> let t = Reductionops.nf_betaiota ty in let rel = mk_relty t None in - t, rel, [t, rel] + t, rel, [t, Some rel] | Some codom -> let (t, rel) = Lazy.force codom in - t, rel, [t, rel]) + t, rel, [t, Some rel]) in aux env m cstrs let morphism_proof env evars carrier relation x = @@ -678,18 +677,15 @@ let morphism_proof env evars carrier relation x = mkApp (Lazy.force morphism_proxy_type, [| carrier ; relation; x |]) in Evarutil.e_new_evar evars env goal -let find_class_proof proof_type proof_method env carrier relation = +let find_class_proof proof_type proof_method env evars carrier relation = try - let goal = - mkApp (Lazy.force proof_type, [| carrier ; relation |]) - in - let inst = resolve_one_typeclass env goal in - mkApp (Lazy.force proof_method, [| carrier ; relation ; inst |]) + let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in + Typeclasses.resolve_one_typeclass env evars goal with e when Logic.catchable_exception e -> raise Not_found -let reflexive_proof env = find_class_proof reflexive_type reflexive_proof env -let symmetric_proof env = find_class_proof symmetric_type symmetric_proof env -let transitive_proof env = find_class_proof transitive_type transitive_proof env +let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env +let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env +let get_transitive_proof env = find_class_proof transitive_type transitive_proof env exception FoundInt of int @@ -711,28 +707,29 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars let cl_args = [| appmtype' ; signature ; appm |] in let app = mkApp (Lazy.force morphism_type, cl_args) in let morph = Evarutil.e_new_evar evars env app in - let proj = - mkApp (Lazy.force respect_proj, - Array.append cl_args [|morph|]) - in - morph, proj, sigargs, appm, morphobjs, morphobjs' + morph, morph, sigargs, appm, morphobjs, morphobjs' in let projargs, respars, typeargs = array_fold_left2 (fun (acc, sigargs, typeargs') x y -> let (carrier, relation), sigargs = split_head sigargs in - match y with - None -> - let proof = morphism_proof env evars carrier relation x in - [ proof ; x ; x ] @ acc, sigargs, x :: typeargs' - | Some (p, (_, _, _, t')) -> - [ p ; t'; x ] @ acc, sigargs, t' :: typeargs') + match relation with + | Some relation -> + (match y with + | None -> + let proof = morphism_proof env evars carrier relation x in + [ proof ; x ; x ] @ acc, sigargs, x :: typeargs' + | Some (p, (_, _, _, t')) -> + [ p ; t'; x ] @ acc, sigargs, t' :: typeargs') + | None -> + if y <> None then error "Cannot rewrite the argument of a dependent function"; + x :: acc, sigargs, x :: typeargs') ([], sigargs, []) args args' in let proof = applistc proj (List.rev projargs) in let newt = applistc m' (List.rev typeargs) in match respars with - [ a, r ] -> (proof, (a, r, oldt, fnewt newt)) + [ a, Some r ] -> (proof, (a, r, oldt, fnewt newt)) | _ -> assert(false) (* Adapted from setoid_replace. *) @@ -755,24 +752,32 @@ let evd_convertible env evd x y = let decompose_setoid_eqhyp env sigma c left2right = let ctype = Typing.type_of env sigma c in - let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ctype) 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 applied relation." in - let others,(c1,c2) = split_last_two args in - let ty1, ty2 = - Typing.mtype_of env eqclause.evd c1, Typing.mtype_of env eqclause.evd c2 + let find_rel ty = + let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) 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 applied relation." in + let others,(c1,c2) = split_last_two args in + let ty1, ty2 = + Typing.mtype_of env eqclause.evd c1, Typing.mtype_of env eqclause.evd c2 + in + if not (evd_convertible env eqclause.evd ty1 ty2) then None + else + Some { cl=eqclause; prf=(Clenv.clenv_value eqclause); + car=ty1; rel=mkApp (equiv, Array.of_list others); + l2r=left2right; c1=c1; c2=c2; c=Some c; abs=None } in - if not (evd_convertible env eqclause.evd ty1 ty2) then - error "The term does not end with an applied homogeneous relation." - else - { cl=eqclause; prf=(Clenv.clenv_value eqclause); - car=ty1; rel=mkApp (equiv, Array.of_list others); - l2r=left2right; c1=c1; c2=c2; c=Some c; abs=None } - + match find_rel ctype with + | Some c -> c + | None -> + let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' ctx) with + | Some c -> c + | None -> error "The term does not end with an applied homogeneous relation." + let rewrite_unif_flags = { Unification.modulo_conv_on_closed_terms = None; Unification.use_metas_eagerly = true; @@ -798,32 +803,19 @@ let refresh_hypinfo env sigma hypinfo = match c with | Some c -> (* Refresh the clausenv to not get the same meta twice in the goal. *) - hypinfo := decompose_setoid_eqhyp cl.env (Evd.evars_of cl.evd) c l2r; + hypinfo := decompose_setoid_eqhyp env (Evd.evars_of cl.evd) c l2r; | _ -> () else () let unify_eqn env sigma hypinfo t = - try + if isEvar t then None + else try let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in let env', prf, c1, c2, car, rel = let left = if l2r then c1 else c2 in match abs with Some (absprf, absprfty) -> - (*if convertible env cl.evd left t then - cl, prf, c1, c2, car, rel - else raise Not_found*) let env' = clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl in - let env' = - let mvs = clenv_dependent false env' in - clenv_pose_metas_as_evars env' mvs - in - let c1 = Clenv.clenv_nf_meta env' c1 - and c2 = Clenv.clenv_nf_meta env' c2 - and car = Clenv.clenv_nf_meta env' car - and rel = Clenv.clenv_nf_meta env' rel in - hypinfo := { !hypinfo with - cl = env'; - abs = Some (Clenv.clenv_value env', Clenv.clenv_type env') }; env', prf, c1, c2, car, rel | None -> let env' = @@ -838,7 +830,7 @@ let unify_eqn env sigma hypinfo t = let mvs = clenv_dependent false env' in clenv_pose_metas_as_evars env' mvs in - let evd' = Typeclasses.resolve_typeclasses env'.env env'.evd in + let evd' = Typeclasses.resolve_typeclasses ~fail:false env'.env env'.evd in let env' = { env' with evd = evd' } in let nf c = Evarutil.nf_evar (Evd.evars_of evd') (Clenv.clenv_nf_meta env' c) in let c1 = nf c1 and c2 = nf c2 @@ -855,11 +847,11 @@ let unify_eqn env sigma hypinfo t = let res = if l2r then (prf, (car, rel, c1, c2)) else - try (mkApp (symmetric_proof env car rel, [| c1 ; c2 ; prf |]), (car, rel, c2, c1)) + try (mkApp (get_symmetric_proof env Evd.empty car rel, [| c1 ; c2 ; prf |]), (car, rel, c2, c1)) with Not_found -> (prf, (car, inverse car rel, c2, c1)) in Some (env', res) - with _ -> None + with e when catchable e -> None let unfold_impl t = match kind_of_term t with @@ -1041,16 +1033,18 @@ let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause g | None -> pf_concl gl, None in let cstr = - match is_hyp with - None -> (mkProp, inverse mkProp (Lazy.force impl)) - | Some _ -> (mkProp, Lazy.force impl) + let sort = mkProp in + let impl = Lazy.force impl in + match is_hyp with + | None -> (sort, inverse sort impl) + | Some _ -> (sort, impl) in - let evars = ref (Evd.create_evar_defs Evd.empty) in - let env = pf_env gl in let sigma = project gl in + let evars = ref (Evd.create_evar_defs sigma) in + let env = pf_env gl in let eq = build_new gl env sigma flags occs hypinfo concl (Some (Lazy.lazy_from_val cstr)) evars in - match eq with + match eq with | Some (p, (_, _, oldt, newt)) -> (try evars := Typeclasses.resolve_typeclasses env ~split:false ~fail:true !evars; @@ -1069,22 +1063,22 @@ let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause g mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) in cut_replacing id newt - (fun x -> Tactics.refine (mkApp (term, [| mkVar id |]))) + (fun x -> Tacmach.refine_no_check (mkApp (term, [| mkVar id |]))) | None -> (match abs with | None -> let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in tclTHENLAST (Tacmach.internal_cut_no_check false name newt) - (tclTHEN (Tactics.revert [name]) (Tactics.refine p)) + (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p)) | Some (t, ty) -> - Tactics.refine + Tacmach.refine_no_check (mkApp (mkLambda (Name (id_of_string "newt"), newt, mkLambda (Name (id_of_string "lemma"), ty, mkApp (p, [| mkRel 2 |]))), [| mkMeta goal_meta; t |]))) in - let evartac = + let evartac = let evd = Evd.evars_of undef in if not (evd = Evd.empty) then Refiner.tclEVARS (Evd.merge sigma evd) else tclIDTAC @@ -1104,8 +1098,7 @@ let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause g (* tclFAIL 1 (str"setoid rewrite failed") gl *) let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause gl = - try cl_rewrite_clause_aux ~flags hypinfo goal_meta occs clause gl - with DependentMorphism -> tclFAIL 0 (str " setoid rewrite failed: cannot handle dependent morphisms") gl + cl_rewrite_clause_aux ~flags hypinfo goal_meta occs clause gl let cl_rewrite_clause (evm,c) left2right occs clause gl = init_setoid (); @@ -1113,10 +1106,6 @@ let cl_rewrite_clause (evm,c) left2right occs clause gl = let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in let env = pf_env gl in let evars = Evd.merge (project gl) evm in -(* let c = *) -(* let j = Pretyping.Default.understand_judgment_tcc evars env c in *) -(* j.Environ.uj_val *) -(* in *) let hypinfo = ref (decompose_setoid_eqhyp env evars c left2right) in cl_rewrite_clause_aux hypinfo meta occs clause gl @@ -1248,9 +1237,7 @@ let declare_an_instance n s args = let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance binders instance fields = - new_instance binders instance fields - ~on_free_vars:Classes.fail_on_free_vars - None + new_instance binders instance (CRecord (dummy_loc,None,fields)) ~generalize:false None let require_library dirpath = let qualid = (dummy_loc, Libnames.qualid_of_dirpath (Libnames.dirpath_of_string dirpath)) in @@ -1259,17 +1246,17 @@ let require_library dirpath = let declare_instance_refl binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" in anew_instance binders instance - [((dummy_loc,id_of_string "reflexivity"),[],lemma)] + [((dummy_loc,id_of_string "reflexivity"),lemma)] let declare_instance_sym binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" in anew_instance binders instance - [((dummy_loc,id_of_string "symmetry"),[],lemma)] + [((dummy_loc,id_of_string "symmetry"),lemma)] let declare_instance_trans binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" in anew_instance binders instance - [((dummy_loc,id_of_string "transitivity"),[],lemma)] + [((dummy_loc,id_of_string "transitivity"),lemma)] let constr_tac = Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor (false,None))) @@ -1294,16 +1281,16 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in ignore( anew_instance binders instance - [((dummy_loc,id_of_string "PreOrder_Reflexive"), [], lemma1); - ((dummy_loc,id_of_string "PreOrder_Transitive"),[], lemma3)]) + [((dummy_loc,id_of_string "PreOrder_Reflexive"), lemma1); + ((dummy_loc,id_of_string "PreOrder_Transitive"),lemma3)]) | (None, Some lemma2, Some lemma3) -> let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in ignore( anew_instance binders instance - [((dummy_loc,id_of_string "PER_Symmetric"), [], lemma2); - ((dummy_loc,id_of_string "PER_Transitive"),[], lemma3)]) + [((dummy_loc,id_of_string "PER_Symmetric"), lemma2); + ((dummy_loc,id_of_string "PER_Transitive"),lemma3)]) | (Some lemma1, Some lemma2, Some lemma3) -> let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in @@ -1311,9 +1298,9 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance binders instance - [((dummy_loc,id_of_string "Equivalence_Reflexive"), [], lemma1); - ((dummy_loc,id_of_string "Equivalence_Symmetric"), [], lemma2); - ((dummy_loc,id_of_string "Equivalence_Transitive"),[], lemma3)]) + [((dummy_loc,id_of_string "Equivalence_Reflexive"), lemma1); + ((dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2); + ((dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)]) type 'a binders_let_argtype = (local_binder list, 'a) Genarg.abstract_argument_type @@ -1456,8 +1443,10 @@ let build_morphism_signature m = let t', sig_, evars = build_signature isevars env t cstrs None snd in let _ = List.iter (fun (ty, rel) -> - let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in - ignore (Evarutil.e_new_evar isevars env default)) + Option.iter (fun rel -> + let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in + ignore (Evarutil.e_new_evar isevars env default)) + rel) evars in let morph = @@ -1473,8 +1462,7 @@ let default_morphism sign m = let isevars = ref (Evd.create_evar_defs Evd.empty) in let t = Typing.type_of env Evd.empty m in let _, sign, evars = - try build_signature isevars env t (fst sign) (snd sign) (fun (ty, rel) -> rel) - with DependentMorphism -> error "Cannot infer the signature of dependent morphisms" + build_signature isevars env t (fst sign) (snd sign) (fun (ty, rel) -> rel) in let morph = mkApp (Lazy.force morphism_type, [| t; sign; m |]) @@ -1490,16 +1478,14 @@ let add_setoid binders a aeq t n = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance binders instance - [((dummy_loc,id_of_string "Equivalence_Reflexive"), [], mkappc "Seq_refl" [a;aeq;t]); - ((dummy_loc,id_of_string "Equivalence_Symmetric"), [], mkappc "Seq_sym" [a;aeq;t]); - ((dummy_loc,id_of_string "Equivalence_Transitive"),[], mkappc "Seq_trans" [a;aeq;t])]) + [((dummy_loc,id_of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); + ((dummy_loc,id_of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); + ((dummy_loc,id_of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) let add_morphism_infer m n = init_setoid (); let instance_id = add_suffix n "_Morphism" in - let instance = try build_morphism_signature m - with DependentMorphism -> error "Cannot infer the signature of dependent morphisms" - in + let instance = build_morphism_signature m in if Lib.is_modtype () then let cst = Declare.declare_internal_constant instance_id (Entries.ParameterEntry (instance,false), Decl_kinds.IsAssumption Decl_kinds.Logical) @@ -1513,7 +1499,8 @@ let add_morphism_infer m n = Command.start_proof instance_id kind instance (fun _ -> function Libnames.ConstRef cst -> - add_instance (Typeclasses.new_instance (Lazy.force morphism_class) None false cst); + add_instance (Typeclasses.new_instance + (Lazy.force morphism_class) None false cst); declare_projection n instance_id (ConstRef cst) | _ -> assert false); Pfedit.by (Tacinterp.interp <:tactic< Coq.Classes.SetoidTactics.add_morphism_tactic>>)) (); @@ -1529,10 +1516,8 @@ let add_morphism binders m s n = [cHole; s; m])) in let tac = Tacinterp.interp <:tactic> in - ignore(new_instance binders instance [] - ~on_free_vars:Classes.fail_on_free_vars - ~tac ~hook:(fun cst -> declare_projection n instance_id (ConstRef cst)) - None) + ignore(new_instance binders instance (CRecord (dummy_loc,None,[])) + ~generalize:false ~tac ~hook:(fun cst -> declare_projection n instance_id (ConstRef cst)) None) VERNAC COMMAND EXTEND AddSetoid1 [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> @@ -1573,62 +1558,59 @@ let check_evar_map_of_evars_defs evd = ) metas let unification_rewrite l2r c1 c2 cl car rel but gl = - let (env',c') = + let env = pf_env gl in + let (evd',c') = try (* ~flags:(false,true) to allow to mark occurrences that must not be rewritten simply by replacing them with let-defined definitions in the context *) - Unification.w_unify_to_subterm ~flags:rewrite_unif_flags (pf_env gl) ((if l2r then c1 else c2),but) cl.evd + Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env ((if l2r then c1 else c2),but) cl.evd with Pretype_errors.PretypeError _ -> (* ~flags:(true,true) to make Ring work (since it really exploits conversion) *) Unification.w_unify_to_subterm ~flags:rewrite2_unif_flags - (pf_env gl) ((if l2r then c1 else c2),but) cl.evd + env ((if l2r then c1 else c2),but) cl.evd + in + let evd' = Typeclasses.resolve_typeclasses ~fail:false env evd' in + let cl' = {cl with evd = evd'} in + let cl' = + let mvs = clenv_dependent false cl' in + clenv_pose_metas_as_evars cl' mvs in - let cl' = {cl with evd = env'} in - let c1 = Clenv.clenv_nf_meta cl' c1 - and c2 = Clenv.clenv_nf_meta cl' c2 in - check_evar_map_of_evars_defs env'; - let prf = Clenv.clenv_value cl' in - let prfty = Clenv.clenv_type cl' in + let nf c = Evarutil.nf_evar (Evd.evars_of cl'.evd) (Clenv.clenv_nf_meta cl' c) in + let c1 = nf c1 and c2 = nf c2 and car = nf car and rel = nf rel in + check_evar_map_of_evars_defs cl'.evd; + let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)} -let get_hyp gl c clause l2r = - let hi = decompose_setoid_eqhyp (pf_env gl) (project gl) c l2r in +let get_hyp gl (evm,c) clause l2r = + let evars = Evd.merge (project gl) evm in + let hi = decompose_setoid_eqhyp (pf_env gl) evars c l2r in let but = match clause with Some id -> pf_get_hyp_typ gl id | None -> pf_concl gl in unification_rewrite hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl let general_rewrite_flags = { under_lambdas = false; on_morphisms = false } -let general_s_rewrite l2r occs c ~new_goals gl = +let general_s_rewrite cl l2r occs c ~new_goals gl = let meta = Evarutil.new_meta() in - let hypinfo = ref (get_hyp gl c None l2r) in - cl_rewrite_clause_aux ~flags:general_rewrite_flags hypinfo meta occs None gl - -let general_s_rewrite_in id l2r occs c ~new_goals gl = - let meta = Evarutil.new_meta() in - let hypinfo = ref (get_hyp gl c (Some id) l2r) in - cl_rewrite_clause_aux ~flags:general_rewrite_flags hypinfo meta occs (Some (([],id), [])) gl + let hypinfo = ref (get_hyp gl c cl l2r) in + let cl' = Option.map (fun id -> (([],id), [])) cl in + cl_rewrite_clause_aux ~flags:general_rewrite_flags hypinfo meta occs cl' gl +(* if fst c = Evd.empty || fst c == project gl then tac gl *) +(* else *) +(* let evars = Evd.merge (fst c) (project gl) in *) +(* tclTHEN (Refiner.tclEVARS evars) tac gl *) let general_s_rewrite_clause x = init_setoid (); match x with - | None -> general_s_rewrite - | Some id -> general_s_rewrite_in id + | None -> general_s_rewrite None + | Some id -> general_s_rewrite (Some id) let _ = Equality.register_general_setoid_rewrite_clause general_s_rewrite_clause -(* [setoid_]{reflexivity,symmetry,transitivity} tactics *) - -let relation_of_constr c = - match kind_of_term c with - | App (f, args) when Array.length args >= 2 -> - let relargs, args = array_chop (Array.length args - 2) args in - mkApp (f, relargs), args - | _ -> error "Not an applied relation." - let is_loaded d = let d' = List.map id_of_string d in let dir = make_dirpath (List.rev d') in @@ -1637,36 +1619,175 @@ let is_loaded d = let try_loaded f gl = if is_loaded ["Coq";"Classes";"RelationClasses"] then f gl else tclFAIL 0 (str"You need to require Coq.Classes.RelationClasses first") gl - -let setoid_reflexivity gl = + +let try_classes t gls = + try t gls + with (Pretype_errors.PretypeError _) as e -> raise e + +TACTIC EXTEND try_classes + [ "try_classes" tactic(t) ] -> [ try_classes (snd t) ] +END + +open Rawterm +open Environ +open Refiner + +let typeclass_app evm gl ?(bindings=NoBindings) c ty = + let nprod = nb_prod (pf_concl gl) in + let n = nb_prod ty - nprod in + if n<0 then error "Apply_tc: theorem has not enough premisses."; + Refiner.tclTHEN (Refiner.tclEVARS evm) + (fun gl -> + let clause = make_clenv_binding_apply gl (Some n) (c,ty) bindings in + let cl' = evar_clenv_unique_resolver true ~flags:default_unify_flags clause gl in + let evd' = Typeclasses.resolve_typeclasses cl'.env ~fail:true cl'.evd in + tclTHEN (Clenvtac.clenv_refine true {cl' with evd = evd'}) + tclNORMEVAR gl) gl + +open Tacinterp +open Pretyping + +let my_ist = + { lfun = []; + avoid_ids = []; + debug = Tactic_debug.DebugOff; + trace = [] } + +let rawconstr_and_expr (evd, c) = c + +let rawconstr_and_expr_of_rawconstr_bindings = function + | NoBindings -> NoBindings + | ImplicitBindings l -> ImplicitBindings (List.map rawconstr_and_expr l) + | ExplicitBindings l -> ExplicitBindings (List.map (fun (l,b,c) -> (l,b,rawconstr_and_expr c)) l) + +let my_glob_sign sigma env = { + ltacvars = [], [] ; + ltacrecvars = []; + gsigma = sigma ; + genv = env } + +let typeclass_app_constrexpr t ?(bindings=NoBindings) gl = let env = pf_env gl in - let rel, args = relation_of_constr (pf_concl gl) in - try - apply (reflexive_proof env (pf_type_of gl args.(0)) rel) gl - with Not_found -> - tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared reflexive relation") - gl - -let setoid_symmetry gl = + let evars = ref (create_evar_defs (project gl)) in + let gs = my_glob_sign (project gl) env in + let t', bl = Tacinterp.intern_constr_with_bindings gs (t,bindings) in + let j = Pretyping.Default.understand_judgment_tcc evars env (fst t') in + let bindings = Tacinterp.interp_bindings my_ist gl bl in + typeclass_app (Evd.evars_of !evars) gl ~bindings:bindings j.uj_val j.uj_type + +let typeclass_app_raw t gl = let env = pf_env gl in - let rel, args = relation_of_constr (pf_concl gl) in - try - apply (symmetric_proof env (pf_type_of gl args.(0)) rel) gl - with Not_found -> - tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared symmetric relation") - gl + let evars = ref (create_evar_defs (project gl)) in + let j = Pretyping.Default.understand_judgment_tcc evars env t in + typeclass_app (Evd.evars_of !evars) gl j.uj_val j.uj_type + +let pr_gen prc _prlc _prtac c = prc c + +let pr_ceb _prc _prlc _prtac raw = mt () + +let interp_constr_expr_bindings _ _ t = t + +let intern_constr_expr_bindings ist t = t + +open Pcoq.Tactic + +type constr_expr_bindings = constr_expr with_bindings + +ARGUMENT EXTEND constr_expr_bindings + TYPED AS constr_expr_bindings + PRINTED BY pr_ceb + + INTERPRETED BY interp_constr_expr_bindings + GLOBALIZED BY intern_constr_expr_bindings + + + [ constr_with_bindings(c) ] -> [ c ] +END + +TACTIC EXTEND apply_typeclasses +[ "typeclass_app" constr_expr_bindings(t) ] -> [ typeclass_app_constrexpr (fst t) ~bindings:(snd t) ] +END +TACTIC EXTEND apply_typeclasses_abbrev +[ "tcapp" raw(t) ] -> [ typeclass_app_raw t ] +END + +(* [setoid_]{reflexivity,symmetry,transitivity} tactics *) + +let not_declared env ty rel = + tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++ + str ty ++ str" relation. Maybe you need to import the Setoid library") + +let relation_of_constr env c = + match kind_of_term c with + | App (f, args) when Array.length args >= 2 -> + let relargs, args = array_chop (Array.length args - 2) args in + mkApp (f, relargs), args + | _ -> errorlabstrm "relation_of_constr" + (str "The term " ++ Printer.pr_constr_env env c ++ str" is not an applied relation.") -let setoid_transitivity c gl = +let setoid_proof gl ty fn fallback = let env = pf_env gl in - let rel, args = relation_of_constr (pf_concl gl) in - try + try + let rel, args = relation_of_constr env (pf_concl gl) in + let evm, car = project gl, pf_type_of gl args.(0) in + fn env evm car rel gl + with e -> + match fallback gl with + | Some tac -> tac gl + | None -> + match e with + | Not_found -> + let rel, args = relation_of_constr env (pf_concl gl) in + not_declared env ty rel gl + | _ -> raise e + +let setoid_reflexivity gl = + setoid_proof gl "reflexive" + (fun env evm car rel -> apply (get_reflexive_proof env evm car rel)) + (reflexivity_red true) + +let setoid_symmetry gl = + setoid_proof gl "symmetric" + (fun env evm car rel -> apply (get_symmetric_proof env evm car rel)) + (symmetry_red true) + +let setoid_transitivity c gl = + setoid_proof gl "transitive" + (fun env evm car rel -> apply_with_bindings - ((transitive_proof env (pf_type_of gl args.(0)) rel), - Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ]) gl - with Not_found -> - tclFAIL 0 - (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared transitive relation") gl - + ((get_transitive_proof env evm car rel), + Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ])) + (transitivity_red true c) + +(* + let setoid_proof gl ty ?(bindings=NoBindings) meth fallback = + try + typeclass_app_constrexpr + (CRef (Qualid (dummy_loc, Nametab.shortest_qualid_of_global Idset.empty + (Lazy.force meth)))) ~bindings gl + with Not_found | Typeclasses_errors.TypeClassError (_, _) | + Stdpp.Exc_located (_, Typeclasses_errors.TypeClassError (_, _)) -> + match fallback gl with + | Some tac -> tac gl + | None -> + let env = pf_env gl in + let rel, args = relation_of_constr env (pf_concl gl) in + not_declared env ty rel gl + +let setoid_reflexivity gl = + setoid_proof gl "reflexive" reflexive_proof_global (reflexivity_red true) + +let setoid_symmetry gl = + setoid_proof gl "symmetric" symmetric_proof_global (symmetry_red true) + +let setoid_transitivity c gl = + let binding_name = + next_ident_away (id_of_string "y") (ids_of_named_context (named_context (pf_env gl))) + in + setoid_proof gl "transitive" + ~bindings:(Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp binding_name, constrIn c ]) + transitive_proof_global (transitivity_red true c) +*) let setoid_symmetry_in id gl = let ctype = pf_type_of gl (mkVar id) in let binders,concl = Sign.decompose_prod_assum ctype in @@ -1696,49 +1817,11 @@ TACTIC EXTEND setoid_symmetry END TACTIC EXTEND setoid_reflexivity - [ "setoid_reflexivity" ] -> [ setoid_reflexivity ] +[ "setoid_reflexivity" ] -> [ setoid_reflexivity ] END TACTIC EXTEND setoid_transitivity - [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ] -END - -let try_classes t gls = - try t gls - with (Pretype_errors.PretypeError _) as e -> raise e - -TACTIC EXTEND try_classes - [ "try_classes" tactic(t) ] -> [ try_classes (snd t) ] -END - -open Rawterm - -let constrexpr = Pcoq.Tactic.open_constr -type 'a constr_expr_argtype = (open_constr_expr, 'a) Genarg.abstract_argument_type - -let (wit_constrexpr : Genarg.tlevel constr_expr_argtype), - (globwit_constrexpr : Genarg.glevel constr_expr_argtype), - (rawwit_const_expr : Genarg.rlevel constr_expr_argtype) = - Genarg.create_arg "constrexpr" - -open Environ -open Refiner - -TACTIC EXTEND apply_typeclasses - [ "typeclass_app" raw(t) ] -> [ fun gl -> - let nprod = nb_prod (pf_concl gl) in - let env = pf_env gl in - let evars = ref (create_evar_defs (project gl)) in - let j = Pretyping.Default.understand_judgment_tcc evars env t in - let n = nb_prod j.uj_type - nprod in - if n<0 then error "Apply_tc: theorem has not enough premisses."; - Refiner.tclTHEN (Refiner.tclEVARS (Evd.evars_of !evars)) - (fun gl -> - let clause = make_clenv_binding_apply gl (Some n) (j.uj_val,j.uj_type) NoBindings in - let cl' = evar_clenv_unique_resolver true ~flags:default_unify_flags clause gl in - let evd' = Typeclasses.resolve_typeclasses cl'.env ~fail:true cl'.evd in - Clenvtac.clenv_refine true {cl' with evd = evd'} gl) gl - ] +[ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ] END let rec head_of_constr t = @@ -1752,6 +1835,105 @@ let rec head_of_constr t = TACTIC EXTEND head_of_constr [ "head_of_constr" ident(h) constr(c) ] -> [ let c = head_of_constr c in - letin_tac None (Name h) c allHyps + letin_tac None (Name h) c None allHyps + ] +END + + +let coq_List_nth = lazy (gen_constant ["Lists"; "List"] "nth") +let coq_List_cons = lazy (gen_constant ["Lists"; "List"] "cons") +let coq_List_nil = lazy (gen_constant ["Lists"; "List"] "nil") + +let freevars c = + let rec frec acc c = match kind_of_term c with + | Var id -> Idset.add id acc + | _ -> fold_constr frec acc c + in + frec Idset.empty c + +let coq_zero = lazy (gen_constant ["Init"; "Datatypes"] "O") +let coq_succ = lazy (gen_constant ["Init"; "Datatypes"] "S") +let coq_nat = lazy (gen_constant ["Init"; "Datatypes"] "nat") + +let rec coq_nat_of_int = function + | 0 -> Lazy.force coq_zero + | n -> mkApp (Lazy.force coq_succ, [| coq_nat_of_int (pred n) |]) + +let varify_constr_list ty def varh c = + let vars = Idset.elements (freevars c) in + let mkaccess i = + mkApp (Lazy.force coq_List_nth, + [| ty; coq_nat_of_int i; varh; def |]) + in + let l = List.fold_right (fun id acc -> + mkApp (Lazy.force coq_List_cons, [| ty ; mkVar id; acc |])) + vars (mkApp (Lazy.force coq_List_nil, [| ty |])) + in + let subst = + list_map_i (fun i id -> (id, mkaccess i)) 0 vars + in + l, replace_vars subst c + +let coq_varmap_empty = lazy (gen_constant ["ring"; "Quote"] "Empty_vm") +let coq_varmap_node = lazy (gen_constant ["ring"; "Quote"] "Node_vm") +(* | Node_vm : A -> varmap -> varmap -> varmap. *) + +let coq_varmap_lookup = lazy (gen_constant ["ring"; "Quote"] "varmap_find") + +let coq_index_left = lazy (gen_constant ["ring"; "Quote"] "Left_idx") +let coq_index_right = lazy (gen_constant ["ring"; "Quote"] "Right_idx") +let coq_index_end = lazy (gen_constant ["ring"; "Quote"] "End_idx") + +let rec split_interleaved l r = function + | hd :: hd' :: tl' -> + split_interleaved (hd :: l) (hd' :: r) tl' + | hd :: [] -> (List.rev (hd :: l), List.rev r) + | [] -> (List.rev l, List.rev r) + +(* let rec mkidx i acc = *) +(* if i mod 2 = 0 then *) +(* let acc' = mkApp (Lazy.force coq_index_left, [|acc|]) in *) +(* if i = 0 then acc' *) +(* else mkidx (i / 2) acc' *) +(* else *) +(* let acc' = mkApp (Lazy.force coq_index_right, [|acc|]) in *) +(* if i = 1 then acc' *) +(* else mkidx (i / 2) acc' *) + +let rec mkidx i p = + if i mod 2 = 0 then + if i = 0 then mkApp (Lazy.force coq_index_left, [|Lazy.force coq_index_end|]) + else mkApp (Lazy.force coq_index_left, [|mkidx (i - p) (2 * p)|]) + else if i = 1 then mkApp (Lazy.force coq_index_right, [|Lazy.force coq_index_end|]) + else mkApp (Lazy.force coq_index_right, [|mkidx (i - p) (2 * p)|]) + +let varify_constr_varmap ty def varh c = + let vars = Idset.elements (freevars c) in + let mkaccess i = + mkApp (Lazy.force coq_varmap_lookup, + [| ty; def; i; varh |]) + in + let rec vmap_aux l cont = + match l with + | [] -> [], mkApp (Lazy.force coq_varmap_empty, [| ty |]) + | hd :: tl -> + let left, right = split_interleaved [] [] tl in + let leftvars, leftmap = vmap_aux left (fun x -> cont (mkApp (Lazy.force coq_index_left, [| x |]))) in + let rightvars, rightmap = vmap_aux right (fun x -> cont (mkApp (Lazy.force coq_index_right, [| x |]))) in + (hd, cont (Lazy.force coq_index_end)) :: leftvars @ rightvars, + mkApp (Lazy.force coq_varmap_node, [| ty; hd; leftmap ; rightmap |]) + in + let subst, vmap = vmap_aux (def :: List.map (fun x -> mkVar x) vars) (fun x -> x) in + let subst = List.map (fun (id, x) -> (destVar id, mkaccess x)) (List.tl subst) in + vmap, replace_vars subst c + + +TACTIC EXTEND varify + [ "varify" ident(varh) ident(h') constr(ty) constr(def) constr(c) ] -> [ + let vars, c' = varify_constr_varmap ty def (mkVar varh) c in + tclTHEN (letin_tac None (Name varh) vars None allHyps) + (letin_tac None (Name h') c' None allHyps) ] END + + diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml index 97225617..c99884c0 100644 --- a/tactics/decl_interp.ml +++ b/tactics/decl_interp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: decl_interp.ml 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: decl_interp.ml 11576 2008-11-10 19:13:15Z msozeau $ i*) open Util open Names @@ -94,8 +94,10 @@ let rec add_vars_of_simple_pattern globs = function (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) | CPatDelimiters (_,_,p) -> add_vars_of_simple_pattern globs p - | CPatCstr (_,_,pl) | CPatNotation(_,_,pl) -> + | CPatCstr (_,_,pl) -> List.fold_left add_vars_of_simple_pattern globs pl + | CPatNotation(_,_,(pl,pll)) -> + List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll)) | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs | _ -> globs @@ -342,7 +344,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = (fun (loc,(id,_)) -> RVar (loc,id)) params in let dum_args= - list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark false)) + list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark (Evd.Define false))) oib.Declarations.mind_nrealargs in raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in let pat_vars,aliases,patt = interp_pattern env pat in diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml index 5356868a..839a494a 100644 --- a/tactics/decl_proof_instr.ml +++ b/tactics/decl_proof_instr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: decl_proof_instr.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: decl_proof_instr.ml 11671 2008-12-12 12:43:03Z herbelin $ *) open Util open Pp @@ -107,7 +107,7 @@ let clean_tmp gls = clean_all (tmp_ids gls) gls let assert_postpone id t = - assert_as true (dummy_loc, Genarg.IntroIdentifier id) t + assert_tac (Name id) t (* start a proof *) @@ -264,7 +264,7 @@ let add_justification_hyps keep items gls = | _ -> let id=pf_get_new_id local_hyp_prefix gls in keep:=Idset.add id !keep; - tclTHEN (letin_tac None (Names.Name id) c Tacexpr.nowhere) + tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere) (thin_body [id]) gls in tclMAP add_aux items gls @@ -780,7 +780,7 @@ let consider_tac c hyps gls = | _ -> let id = pf_get_new_id (id_of_string "_tmp") gls in tclTHEN - (forward None (dummy_loc, Genarg.IntroIdentifier id) c) + (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c) (consider_match false [] [id] hyps) gls @@ -811,7 +811,7 @@ let rec build_function args body = let define_tac id args body gls = let t = build_function args body in - letin_tac None (Name id) t Tacexpr.nowhere gls + letin_tac None (Name id) t None Tacexpr.nowhere gls (* tactics for reconsider *) diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli index 2e235a01..877c8047 100644 --- a/tactics/decl_proof_instr.mli +++ b/tactics/decl_proof_instr.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: decl_proof_instr.mli 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: decl_proof_instr.mli 11481 2008-10-20 19:23:51Z herbelin $ *) open Refiner open Names diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml index 14731b26..f3e1559f 100644 --- a/tactics/dhyp.ml +++ b/tactics/dhyp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: dhyp.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: dhyp.ml 11739 2009-01-02 19:33:19Z herbelin $ *) (* Chet's comments about this tactic : @@ -131,6 +131,7 @@ open Pattern open Matching open Pcoq open Tacexpr +open Termops open Libnames (* two patterns - one for the type, and one for the type of the type *) @@ -248,7 +249,7 @@ let add_destructor_hint local na loc pat pri code = errorlabstrm "add_destructor_hint" (str "The tactic should be a function of the hypothesis name.") end in - let (_,pat) = Constrintern.interp_constrpattern Evd.empty (Global.env()) pat + let (_,pat) = Constrintern.intern_constr_pattern Evd.empty (Global.env()) pat in let pat = match loc with | HypLocation b -> diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 1503ca9a..67bdeb46 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: eauto.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: eauto.ml4 11735 2009-01-02 17:22:31Z herbelin $ *) open Pp open Util @@ -31,9 +31,9 @@ open Auto open Rawterm open Hiddentac -let e_give_exact c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in +let e_give_exact ?(flags=Unification.default_unify_flags) 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 (Clenvtac.unify t1) (exact_check c) gl + tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl else exact_check c gl let assumption id = e_give_exact (mkVar id) @@ -91,6 +91,8 @@ open Unification (* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) (***************************************************************************) +let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) + (* no delta yet *) let unify_e_resolve flags (c,clenv) gls = @@ -140,12 +142,11 @@ and e_my_find_search_nodelta db_list local_db hdc concl = tclTHEN (unify_e_resolve_nodelta (term,cl)) (e_trivial_fail_db false db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> conclPattern concl - (Option.get p) tacast + | Extern tacast -> conclPattern concl p tacast in - (tac,fmt_autotactic t)) + (tac,pr_autotactic t)) (*i - fun gls -> pPNL (fmt_autotactic t); Format.print_flush (); + fun gls -> pPNL (pr_autotactic t); Format.print_flush (); try tac gls with e when Logic.catchable_exception(e) -> (Format.print_string "Fail\n"; @@ -174,17 +175,16 @@ and e_my_find_search_delta db_list local_db hdc concl = match t with | Res_pf (term,cl) -> unify_resolve st (term,cl) | ERes_pf (term,cl) -> unify_e_resolve st (term,cl) - | Give_exact (c) -> e_give_exact_constr c + | Give_exact (c) -> e_give_exact ~flags:st c | Res_pf_THEN_trivial_fail (term,cl) -> tclTHEN (unify_e_resolve st (term,cl)) (e_trivial_fail_db true db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> conclPattern concl - (Option.get p) tacast + | Extern tacast -> conclPattern concl p tacast in - (tac,fmt_autotactic t)) + (tac,pr_autotactic t)) (*i - fun gls -> pPNL (fmt_autotactic t); Format.print_flush (); + fun gls -> pPNL (pr_autotactic t); Format.print_flush (); try tac gls with e when Logic.catchable_exception(e) -> (Format.print_string "Fail\n"; @@ -196,15 +196,15 @@ and e_my_find_search_delta db_list local_db hdc concl = and e_trivial_resolve mod_delta db_list local_db gl = try - Auto.priority + priority (e_my_find_search mod_delta db_list local_db - (List.hd (head_constr_bound gl [])) gl) + (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let e_possible_resolve mod_delta db_list local_db gl = try List.map snd (e_my_find_search mod_delta db_list local_db - (List.hd (head_constr_bound gl [])) gl) + (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id)) @@ -460,3 +460,9 @@ TACTIC EXTEND autosimpl | [ "autosimpl" hintbases(db) ] -> [ autosimpl (match db with None -> ["core"] | Some x -> "core"::x) None ] END + +TACTIC EXTEND unify +| ["unify" constr(x) constr(y) ] -> [ unify x y ] +| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ + unify ~state:(Hint_db.transparent_state (searchtable_map base)) x y ] +END diff --git a/tactics/elim.ml b/tactics/elim.ml index 55df0f0a..fa4a7caa 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: elim.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: elim.ml 11739 2009-01-02 19:33:19Z herbelin $ *) open Pp open Util @@ -128,7 +128,7 @@ let decompose_nonrec c gls = let decompose_and c gls = general_decompose - (fun (_,t) -> is_conjunction t) + (fun (_,t) -> is_record t) c gls let decompose_or c gls = diff --git a/tactics/equality.ml b/tactics/equality.ml index 7fb19423..ba18430a 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: equality.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: equality.ml 11800 2009-01-18 18:34:15Z msozeau $ *) open Pp open Util @@ -37,12 +37,12 @@ open Tacred open Rawterm open Coqlib open Vernacexpr -open Setoid_replace open Declarations open Indrec open Printer open Clenv open Clenvtac +open Evd (* Rewriting tactics *) @@ -55,25 +55,22 @@ open Clenvtac *) (* Ad hoc asymmetric general_elim_clause *) -let general_elim_clause with_evars cls c elim = +let general_elim_clause with_evars cls sigma c l elim = try (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 with_evars c elim ~allow_K:false) + tclNOTSAMEGOAL (tclTHEN (Refiner.tclEVARS sigma) + (general_elim with_evars (c,l) elim ~allow_K:false)) | Some id -> - general_elim_in with_evars id c elim) + tclTHEN (Refiner.tclEVARS sigma) (general_elim_in with_evars id (c,l) elim)) with Pretype_errors.PretypeError (env, (Pretype_errors.NoOccurrenceFound (c', _))) -> raise (Pretype_errors.PretypeError (env, (Pretype_errors.NoOccurrenceFound (c', cls)))) -let elimination_sort_of_clause = function - | None -> elimination_sort_of_goal - | Some id -> elimination_sort_of_hyp id - (* The next function decides in particular whether to try a regular rewrite or a setoid rewrite. Approach is to break everything, if [eq] appears in head position @@ -81,11 +78,7 @@ let elimination_sort_of_clause = function If occurrences are set, use setoid_rewrite. *) -let general_s_rewrite_clause = function - | None -> general_s_rewrite - | Some id -> general_s_rewrite_in id - -let general_setoid_rewrite_clause = ref general_s_rewrite_clause +let general_setoid_rewrite_clause = ref (fun _ -> assert false) let register_general_setoid_rewrite_clause = (:=) general_setoid_rewrite_clause let is_applied_setoid_relation = ref (fun _ -> false) @@ -96,39 +89,52 @@ let is_applied_relation t = | App (c, args) when Array.length args >= 2 -> true | _ -> false -let leibniz_rewrite_ebindings_clause cls lft2rgt (c,l) with_evars gl hdcncl = - let hdcncls = string_of_inductive hdcncl 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 = - try pf_global gl (id_of_string rwr_thm) - with Not_found -> - error ("Cannot find rewrite principle "^rwr_thm^".") - in general_elim_clause with_evars cls (c,l) (elim,NoBindings) gl +(* find_elim determines which elimination principle is necessary to + eliminate lbeq on sort_of_gl. *) -let leibniz_eq = Lazy.lazy_from_fun build_coq_eq +let find_elim hdcncl lft2rgt cls gl = + let suffix = elimination_suffix (elimination_sort_of_clause cls gl) in + let hdcncls = string_of_inductive hdcncl ^ suffix in + let rwr_thm = if lft2rgt = (cls = None) then hdcncls^"_r" else hdcncls in + try pf_global gl (id_of_string rwr_thm) + with Not_found -> error ("Cannot find rewrite principle "^rwr_thm^".") + +let leibniz_rewrite_ebindings_clause cls lft2rgt sigma c l with_evars gl hdcncl = + let elim = find_elim hdcncl lft2rgt cls gl in + general_elim_clause with_evars cls sigma c l (elim,NoBindings) gl + +let adjust_rewriting_direction args lft2rgt = + if List.length args = 1 then + (* equality to a constant, like in eq_true *) + (* more natural to see -> as the rewriting to the constant *) + not lft2rgt + else + (* other equality *) + lft2rgt -let general_rewrite_ebindings_clause cls lft2rgt occs (c,l) with_evars gl = +let general_rewrite_ebindings_clause cls lft2rgt occs ((c,l) : open_constr with_bindings) with_evars gl = if occs <> all_occurrences then ( !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl) else - let ctype = pf_apply get_type_of gl c in let env = pf_env gl in - let sigma = project gl in + let sigma, c' = c in + let sigma = Evd.merge sigma (project gl) in + let ctype = get_type_of env sigma c' in let rels, t = decompose_prod (whd_betaiotazeta ctype) in - match match_with_equation t with - | Some (hdcncl,_) -> (* Fast path: direct leibniz rewrite *) - leibniz_rewrite_ebindings_clause cls lft2rgt (c,l) with_evars gl hdcncl + match match_with_equality_type t with + | Some (hdcncl,args) -> (* Fast path: direct leibniz rewrite *) + let lft2rgt = adjust_rewriting_direction args lft2rgt in + leibniz_rewrite_ebindings_clause cls lft2rgt sigma c' l with_evars gl hdcncl | None -> let env' = List.fold_left (fun env (n,t) -> push_rel (n, None, t) env) env rels in let _,t' = splay_prod env' sigma t in (* Search for underlying eq *) - match match_with_equation t' with - | Some (hdcncl,_) -> (* Maybe a setoid relation with eq inside *) + match match_with_equality_type t' with + | Some (hdcncl,args) -> (* Maybe a setoid relation with eq inside *) + let lft2rgt = adjust_rewriting_direction args lft2rgt in if l = NoBindings && !is_applied_setoid_relation t then !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl else - (try leibniz_rewrite_ebindings_clause cls lft2rgt (c,l) with_evars gl hdcncl + (try leibniz_rewrite_ebindings_clause cls lft2rgt sigma c' l with_evars gl hdcncl with e -> try !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl with _ -> raise e) @@ -140,7 +146,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs (c,l) with_evars gl = let general_rewrite_ebindings = general_rewrite_ebindings_clause None let general_rewrite_bindings l2r occs (c,bl) = - general_rewrite_ebindings_clause None l2r occs (c,inj_ebindings bl) + general_rewrite_ebindings_clause None l2r occs (inj_open c,inj_ebindings bl) let general_rewrite l2r occs c = general_rewrite_bindings l2r occs (c,NoBindings) false @@ -148,9 +154,9 @@ let general_rewrite l2r occs c = let general_rewrite_ebindings_in l2r occs id = general_rewrite_ebindings_clause (Some id) l2r occs let general_rewrite_bindings_in l2r occs id (c,bl) = - general_rewrite_ebindings_clause (Some id) l2r occs (c,inj_ebindings bl) + general_rewrite_ebindings_clause (Some id) l2r occs (inj_open c,inj_ebindings bl) let general_rewrite_in l2r occs id c = - general_rewrite_ebindings_clause (Some id) l2r occs (c,NoBindings) + general_rewrite_ebindings_clause (Some id) l2r occs (inj_open c,NoBindings) let general_multi_rewrite l2r with_evars c cl = let occs_of = on_snd (List.fold_left @@ -186,7 +192,7 @@ let general_multi_rewrite l2r with_evars c cl = let do_hyps gl = (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) let ids = - let ids_in_c = Environ.global_vars_set (Global.env()) (fst c) in + let ids_in_c = Environ.global_vars_set (Global.env()) (snd (fst c)) in Idset.fold (fun id l -> list_remove id l) ids_in_c (pf_ids_of_hyps gl) in do_hyps_atleastonce ids gl in @@ -262,10 +268,10 @@ let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl = 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) + tclTHENS (assert_as false None eq) [onLastHyp (fun id -> tclTHEN - (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause)) + (tclTRY (general_multi_rewrite false false (inj_open (mkVar id),NoBindings) clause)) (clear [id])); tclFIRST [assumption; @@ -450,7 +456,8 @@ let injectable env sigma t1 t2 = let descend_then sigma env head dirn = let IndType (indf,_) = try find_rectype env sigma (get_type_of env sigma head) - with Not_found -> assert false in + with Not_found -> + error "Cannot project on an inductive type derived from a dependency." in let ind,_ = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in let cstr = get_constructors env indf in @@ -470,7 +477,7 @@ let descend_then sigma env head dirn = (interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in mkCase (ci, p, head, Array.of_list brl))) - + (* Now we need to construct the discriminator, given a discriminable position. This boils down to: @@ -819,11 +826,14 @@ let make_iterated_tuple env sigma dflt (z,zty) = 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 -> + try let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in let newc = mkRel(cnum_nlams-argnum) in let (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in (kont subval (dfltval,tuplety), - tuplety,dfltval) + tuplety,dfltval) + with + UserError _ -> failwith "caught" let build_injector sigma env dflt c cpath = let (injcode,resty,_) = build_injrec sigma env dflt c cpath in @@ -978,26 +988,11 @@ let swapEquandsInHyp 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. - 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 = - match kind_of_term sort_of_gl with - | Sort(Prop Null) (* Prop *) -> lbeq.ind - | _ (* Set/Type *) -> - (match lbeq.rect with - | Some eq_rect -> eq_rect - | None -> errorlabstrm "find_elim" - (str "This type of substitution is not allowed.")) - (* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *) let bareRevSubstInConcl lbeq body (t,e1,e2) gls = (* find substitution scheme *) - let eq_elim = find_elim (pf_apply get_type_of gls (pf_concl gls)) lbeq in + let eq_elim = find_elim lbeq.eq false None gls in (* build substitution predicate *) let p = lambda_create (pf_env gls) (t,body) in (* apply substitution scheme *) @@ -1050,14 +1045,16 @@ 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 - applist(abst_B,proj_list) - + beta_applist(abst_B,proj_list) + (* Comme "replace" mais decompose les egalites dependantes *) +exception NothingToRewrite + 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); + if not (dependent (mkRel 1) body) then raise NothingToRewrite; bareRevSubstInConcl lbeq body eq gls (* |- (P e1) @@ -1075,7 +1072,7 @@ let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL 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); + if not (dependent (mkRel 1) body) then raise NothingToRewrite; cut_replacing id (subst1 e2 body) (tclTHENFIRST (bareRevSubstInConcl lbeq body eq)) gls @@ -1095,6 +1092,9 @@ let try_rewrite tac gls = | e when catchable_exception e -> errorlabstrm "try_rewrite" (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") + | NothingToRewrite -> + errorlabstrm "try_rewrite" + (strbrk "Nothing to rewrite.") let cutSubstClause l2r eqn cls gls = match cls with @@ -1113,33 +1113,22 @@ 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 -(* Renaming scheme correspondence new name (old name) +(* Naming scheme for rewrite and cutrewrite tactics - give equality give proof of equality + give equality give proof of equality - / cutSubstClause (subst) substClause (HypSubst on hyp) -raw | cutSubstInHyp (substInHyp) substInHyp (none) - \ cutSubstInConcl (substInConcl) substInConcl (none) + / cutSubstClause substClause +raw | cutSubstInHyp substInHyp + \ cutSubstInConcl substInConcl - / cutRewriteClause (none) rewriteClause (none) -user| cutRewriteInHyp (substHyp) rewriteInHyp (none) - \ cutRewriteInConcl (substConcl) rewriteInConcl (substHypInConcl on hyp) + / cutRewriteClause rewriteClause +user| cutRewriteInHyp rewriteInHyp + \ cutRewriteInConcl rewriteInConcl raw = raise typing error or PatternMatchingFailure user = raise user error specific to rewrite *) -(* 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 -let substHypInConcl l2r id = rewriteInConcl l2r (mkVar id) -let substConcl = cutRewriteInConcl -let substHyp = cutRewriteInHyp -*) - (**********************************************************************) (* Substitutions tactics (JCF) *) @@ -1211,8 +1200,8 @@ let subst_one x gl = (id,None,_) -> intro_using id | (id,Some hval,htyp) -> letin_tac None (Name id) - (mkCast(replace_term varx rhs hval,DEFAULTcast, - replace_term varx rhs htyp)) nowhere + (replace_term varx rhs hval) + (Some (replace_term varx rhs htyp)) nowhere in let need_rewrite = dephyps <> [] || depconcl in tclTHENLIST @@ -1273,7 +1262,7 @@ let rewrite_multi_assumption_cond cond_eq_term cl gl = begin try let dir = cond_eq_term t gl in - general_multi_rewrite dir false (mkVar id,NoBindings) cl gl + general_multi_rewrite dir false (inj_open (mkVar id),NoBindings) cl gl with | Failure _ | UserError _ -> arec rest end in @@ -1333,14 +1322,4 @@ let replace_term_in_right t hyp = replace_multi_term (Some false) t (Tacticals.o let replace_term_in t hyp = replace_multi_term None t (Tacticals.onHyp hyp) - - - - - - - - -let _ = Setoid_replace.register_replace (fun tac_opt c2 c1 gl -> replace_in_clause_maybe_by c2 c1 onConcl tac_opt gl) -let _ = Setoid_replace.register_general_rewrite general_rewrite let _ = Tactics.register_general_multi_rewrite general_multi_rewrite diff --git a/tactics/equality.mli b/tactics/equality.mli index f05ebc6c..86ad3293 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 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: equality.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Util @@ -45,7 +45,7 @@ val rewriteRL : constr -> tactic val register_general_setoid_rewrite_clause : (identifier option -> bool -> - occurrences -> constr -> new_goals:constr list -> tactic) -> unit + occurrences -> open_constr -> new_goals:constr list -> tactic) -> unit val register_is_applied_setoid_relation : (constr -> bool) -> unit val general_rewrite_bindings_in : @@ -54,14 +54,14 @@ val general_rewrite_in : bool -> occurrences -> identifier -> constr -> evars_flag -> tactic val general_multi_rewrite : - bool -> evars_flag -> constr with_ebindings -> clause -> tactic + bool -> evars_flag -> open_constr with_bindings -> clause -> tactic val general_multi_multi_rewrite : - evars_flag -> (bool * multi * constr with_ebindings) list -> clause -> + evars_flag -> (bool * multi * open_constr with_bindings) list -> clause -> tactic option -> tactic -val conditional_rewrite : bool -> tactic -> constr with_ebindings -> tactic +val conditional_rewrite : bool -> tactic -> open_constr with_bindings -> tactic val conditional_rewrite_in : - bool -> identifier -> tactic -> constr with_ebindings -> tactic + bool -> identifier -> tactic -> open_constr with_bindings -> tactic val replace_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic val replace : constr -> constr -> tactic diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index 3c266c51..43c18a8b 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: evar_tactics.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: evar_tactics.ml 11576 2008-11-10 19:13:15Z msozeau $ *) open Term open Util @@ -75,5 +75,5 @@ let let_evar name typ gls = let evd = Evd.create_goal_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 None name evar nowhere) gls + (Tactics.letin_tac None name evar None nowhere) gls diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli index dbf7db31..cc06d2c6 100644 --- a/tactics/evar_tactics.mli +++ b/tactics/evar_tactics.mli @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: evar_tactics.mli 6621 2005-01-21 17:24:37Z herbelin $ i*) +(*i $Id: evar_tactics.mli 11512 2008-10-27 12:28:36Z herbelin $ i*) open Tacmach open Names open Tacexpr +open Termops val instantiate : int -> Rawterm.rawconstr -> (identifier * hyp_location_flag, unit) location -> tactic diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index a0230b28..694c3495 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: extraargs.ml4 11094 2008-06-10 19:35:23Z herbelin $ *) +(* $Id: extraargs.ml4 11800 2009-01-18 18:34:15Z msozeau $ *) open Pp open Pcoq @@ -16,6 +16,7 @@ open Genarg open Names open Tacexpr open Tacinterp +open Termops (* Rewriting orientation *) @@ -97,22 +98,6 @@ ARGUMENT EXTEND occurrences | [ var(id) ] -> [ ArgVar id ] END -(* For Setoid rewrite *) -let pr_morphism_signature _ _ _ s = - spc () ++ Setoid_replace.pr_morphism_signature s - -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 @@ -288,7 +273,7 @@ let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause = Option.map (fun l -> List.map - (fun id -> ( (all_occurrences_expr,trad_id id) ,Tacexpr.InHyp)) + (fun id -> ( (all_occurrences_expr,trad_id id),InHyp)) l ) hyps; diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index 74296ab0..bccb150f 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -6,13 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraargs.mli 10820 2008-04-20 18:18:49Z msozeau $ i*) +(*i $Id: extraargs.mli 11800 2009-01-18 18:34:15Z msozeau $ i*) open Tacexpr open Term open Names open Proof_type open Topconstr +open Termops open Rawterm val rawwit_orient : bool raw_abstract_argument_type @@ -23,13 +24,6 @@ val occurrences : (int list or_var) Pcoq.Gram.Entry.e val rawwit_occurrences : (int list or_var) raw_abstract_argument_type val wit_occurrences : (int list) typed_abstract_argument_type -val rawwit_morphism_signature : - Setoid_replace.morphism_signature raw_abstract_argument_type -val wit_morphism_signature : - Setoid_replace.morphism_signature typed_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 typed_abstract_argument_type val raw : constr_expr Pcoq.Gram.Entry.e diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 66716acd..ee01f839 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: extratactics.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: extratactics.ml4 11800 2009-01-18 18:34:15Z msozeau $ *) open Pp open Pcoq @@ -18,6 +18,7 @@ open Mod_subst open Names open Tacexpr open Rawterm +open Tactics (* Equality *) open Equality @@ -133,10 +134,10 @@ let h_injHyp id = h_injection_main (Term.mkVar id,NoBindings) TACTIC EXTEND conditional_rewrite | [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c) ] - -> [ conditional_rewrite b (snd tac) c ] + -> [ conditional_rewrite b (snd tac) (inj_open (fst c), snd c) ] | [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c) "in" hyp(h) ] - -> [ conditional_rewrite_in b h (snd tac) c ] + -> [ conditional_rewrite_in b h (snd tac) (inj_open (fst c), snd c) ] END TACTIC EXTEND dependent_rewrite @@ -216,87 +217,6 @@ END let refine_tac = h_refine -(* Setoid_replace *) - -open Setoid_replace - -(* TACTIC EXTEND setoid_replace *) -(* [ "setoid_replace" constr(c1) "with" constr(c2) by_arg_tac(tac)] -> *) -(* [ setoid_replace (Option.map Tacinterp.eval_tactic tac) None c1 c2 ~new_goals:[] ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) by_arg_tac(tac)] -> *) -(* [ setoid_replace (Option.map Tacinterp.eval_tactic tac) (Some rel) c1 c2 ~new_goals:[] ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac) ] -> *) -(* [ setoid_replace (Option.map Tacinterp.eval_tactic tac) None c1 c2 ~new_goals:l ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac) ] -> *) -(* [ setoid_replace (Option.map Tacinterp.eval_tactic tac) (Some rel) c1 c2 ~new_goals:l ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) by_arg_tac(tac) ] -> *) -(* [ setoid_replace_in (Option.map Tacinterp.eval_tactic tac) h None c1 c2 ~new_goals:[] ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) by_arg_tac(tac)] -> *) -(* [ setoid_replace_in (Option.map Tacinterp.eval_tactic tac) h (Some rel) c1 c2 ~new_goals:[] ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac)] -> *) -(* [ setoid_replace_in (Option.map Tacinterp.eval_tactic tac) 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) by_arg_tac(tac)] -> *) -(* [ setoid_replace_in (Option.map Tacinterp.eval_tactic tac) 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 *) - -(* 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 *) - -(* TACTIC EXTEND setoid_symmetry *) -(* [ "setoid_symmetry" ] -> [ setoid_symmetry ] *) -(* | [ "setoid_symmetry" "in" hyp(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) *) open Inv @@ -485,17 +405,6 @@ END -TACTIC EXTEND apply_in -| ["apply" ne_constr_with_bindings_list_sep(cl,",") "in" hyp(id) ] -> - [ apply_in false id cl ] -END - - -TACTIC EXTEND eapply_in -| ["eapply" ne_constr_with_bindings_list_sep(cl,",") "in" hyp(id) ] -> - [ apply_in true id cl ] -END - (* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as defined by Conor McBride *) TACTIC EXTEND generalize_eqs @@ -505,8 +414,8 @@ TACTIC EXTEND generalize_eqs_vars | ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize id ~generalize_vars:true ] END -TACTIC EXTEND conv -| ["conv" constr(x) constr(y) ] -> [ conv x y ] +TACTIC EXTEND dependent_pattern +| ["dependent_pattern" constr(c) ] -> [ dependent_pattern c ] END TACTIC EXTEND resolve_classes diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml index 31c1b02f..b270ba2d 100644 --- a/tactics/hiddentac.ml +++ b/tactics/hiddentac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: hiddentac.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: hiddentac.ml 11671 2008-12-12 12:43:03Z herbelin $ *) open Term open Proof_type @@ -39,9 +39,12 @@ let h_exact_no_check c = abstract_tactic (TacExactNoCheck (inj_open c)) (exact_no_check c) let h_vm_cast_no_check c = abstract_tactic (TacVmCastNoCheck (inj_open c)) (vm_cast_no_check c) -let h_apply simple ev cb = - abstract_tactic (TacApply (simple,ev,List.map inj_open_wb cb)) +let h_apply simple ev cb = + abstract_tactic (TacApply (simple,ev,cb,None)) (apply_with_ebindings_gen simple ev cb) +let h_apply_in simple ev cb (id,ipat as inhyp) = + abstract_tactic (TacApply (simple,ev,cb,Some inhyp)) + (apply_in simple ev id cb ipat) let h_elim ev cb cbo = abstract_tactic (TacElim (ev,inj_open_wb cb,Option.map inj_open_wb cbo)) (elim ev cb cbo) @@ -71,7 +74,7 @@ let h_generalize_dep c = abstract_tactic (TacGeneralizeDep (inj_open c))(generalize_dep c) let h_let_tac b na c cl = let with_eq = if b then None else Some (true,(dummy_loc,IntroAnonymous)) in - abstract_tactic (TacLetTac (na,inj_open c,cl,b)) (letin_tac with_eq na c cl) + abstract_tactic (TacLetTac (na,inj_open c,cl,b)) (letin_tac with_eq na c None cl) let h_instantiate n c ido = (Evar_tactics.instantiate n c ido) (* abstract_tactic (TacInstantiate (n,c,cls)) @@ -131,8 +134,8 @@ let h_symmetry c = abstract_tactic (TacSymmetry c) (intros_symmetry c) let h_transitivity c = abstract_tactic (TacTransitivity (inj_open c)) (intros_transitivity c) -let h_simplest_apply c = h_apply false false [c,NoBindings] -let h_simplest_eapply c = h_apply false true [c,NoBindings] +let h_simplest_apply c = h_apply false false [inj_open c,NoBindings] +let h_simplest_eapply c = h_apply false true [inj_open c,NoBindings] let h_simplest_elim c = h_elim false (c,NoBindings) None let h_simplest_case c = h_case false (c,NoBindings) diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli index 3e636668..0ebb024a 100644 --- a/tactics/hiddentac.mli +++ b/tactics/hiddentac.mli @@ -1,3 +1,4 @@ + (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* tactic val h_vm_cast_no_check : constr -> tactic val h_apply : advanced_flag -> evars_flag -> - constr with_ebindings list -> tactic + open_constr with_bindings list -> tactic +val h_apply_in : advanced_flag -> evars_flag -> + open_constr with_bindings list -> + identifier * intro_pattern_expr located option -> tactic val h_elim : evars_flag -> constr with_ebindings -> constr with_ebindings option -> tactic diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index de500f89..2e83ac70 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -8,13 +8,14 @@ (*i camlp4deps: "parsing/grammar.cma parsing/q_constr.cmo" i*) -(* $Id: hipattern.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: hipattern.ml4 11739 2009-01-02 19:33:19Z herbelin $ *) open Pp open Util open Names open Nameops open Term +open Sign open Termops open Reductionops open Inductiveops @@ -64,43 +65,107 @@ let match_with_non_recursive_type t = 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. *) +(* Test dependencies *) -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 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 + +(* A general conjunctive type is a non-recursive with-no-indices inductive + type with only one constructor and no dependencies between argument; + it is strict if it has the form + "Inductive I A1 ... An := C (_:A1) ... (_:An)" *) -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. *) +(* style: None = record; Some false = conjunction; Some true = strict conj *) -let match_with_disjunction t = +let match_with_one_constructor style 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 + | 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 + if style = Some true (* strict conjunction *) then + let ctx = + fst (decompose_prod_assum (snd + (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in + if + List.for_all + (fun (_,b,c) -> b=None && c = mkRel mib.mind_nparams) ctx + then + Some (hdapp,args) + else None + else + let ctyp = prod_applist mip.mind_nf_lc.(0) args in + let cargs = List.map pi3 (fst (decompose_prod_assum ctyp)) in + if style <> Some false || has_nodep_prod ctyp then + (* Record or non strict conjunction *) + Some (hdapp,List.rev cargs) + else + None + else + None + | _ -> None + +let match_with_conjunction ?(strict=false) t = + match_with_one_constructor (Some strict) t + +let match_with_record t = + match_with_one_constructor None t + +let is_conjunction ?(strict=false) t = + op2bool (match_with_conjunction ~strict t) + +let is_record t = + op2bool (match_with_record t) + + +(* A general disjunction type is a non-recursive with-no-indices inductive + type with of which all constructors have a single argument; + it is strict if it has the form + "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *) + +let test_strict_disjunction n lc = + array_for_all_i (fun i c -> + match fst (decompose_prod_assum (snd (decompose_prod_n_assum n c))) with + | [_,None,c] -> c = mkRel (n - i) + | _ -> false) 0 lc + +let match_with_disjunction ?(strict=false) t = + let (hdapp,args) = decompose_app t in + match kind_of_term hdapp with + | Ind ind -> + let car = mis_constr_nargs ind in + let (mib,mip) = Global.lookup_inductive ind in + if array_for_all (fun ar -> ar = 1) car && + not (mis_is_recursive (ind,mib,mip)) + then + if strict then + if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then + Some (hdapp,args) + else + None + else + let cargs = + Array.map (fun ar -> pi2 (destProd (prod_applist ar args))) + mip.mind_nf_lc in + Some (hdapp,Array.to_list cargs) + else + None + | _ -> None + +let is_disjunction ?(strict=false) t = + op2bool (match_with_disjunction ~strict t) -let is_disjunction t = op2bool (match_with_disjunction t) +(* An empty type is an inductive type, possible with indices, that has no + constructors *) let match_with_empty_type t = let (hdapp,args) = decompose_app t in @@ -113,22 +178,32 @@ let match_with_empty_type t = let is_empty_type t = op2bool (match_with_empty_type t) -let match_with_unit_type t = +(* This filters inductive types with one constructor with no arguments; + Parameters and indices are allowed *) + +let match_with_unit_or_eq_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 + let zero_args c = nb_prod c = mib.mind_nparams in + if nconstr = 1 && zero_args constr_types.(0) then Some hdapp - else + else None | _ -> None -let is_unit_type t = op2bool (match_with_unit_type t) +let is_unit_or_eq_type t = op2bool (match_with_unit_or_eq_type t) + +(* A unit type is an inductive type with no indices but possibly + (useless) parameters, and that has no constructors *) + +let is_unit_type t = + match match_with_conjunction t with + | Some (_,t) when List.length t = 0 -> true + | _ -> false (* Checks if a given term is an application of an inductive binary relation R, so that R has only one constructor @@ -157,6 +232,19 @@ let match_with_equation t = let is_equation t = op2bool (match_with_equation t) +let match_with_equality_type t = + let (hdapp,args) = decompose_app t in + match (kind_of_term hdapp) with + | Ind ind when args <> [] -> + let (mib,mip) = Global.lookup_inductive ind in + let nconstr = Array.length mip.mind_consnames in + if nconstr = 1 && constructor_nrealargs (Global.env()) (ind,1) = 0 + then + Some (hdapp,args) + else + None + | _ -> None + let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ] let match_arrow_pattern t = @@ -186,15 +274,6 @@ let match_with_imp_term c= 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 diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 86cd191e..3c423202 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 8866 2006-05-28 16:21:04Z herbelin $ i*) +(*i $Id: hipattern.mli 11739 2009-01-02 19:33:19Z herbelin $ i*) (*i*) open Util @@ -52,23 +52,31 @@ type testing_function = constr -> bool val match_with_non_recursive_type : (constr * constr list) matching_function val is_non_recursive_type : testing_function -val match_with_disjunction : (constr * constr list) matching_function -val is_disjunction : testing_function +val match_with_disjunction : ?strict:bool -> (constr * constr list) matching_function +val is_disjunction : ?strict:bool -> testing_function -val match_with_conjunction : (constr * constr list) matching_function -val is_conjunction : testing_function +val match_with_conjunction : ?strict:bool -> (constr * constr list) matching_function +val is_conjunction : ?strict:bool -> testing_function + +val match_with_record : (constr * constr list) matching_function +val is_record : testing_function val match_with_empty_type : constr matching_function val is_empty_type : testing_function -val match_with_unit_type : constr matching_function +(* type with only one constructor and no arguments, possibly with indices *) +val match_with_unit_or_eq_type : constr matching_function +val is_unit_or_eq_type : testing_function -(* type with only one constructor and no arguments *) +(* type with only one constructor and no arguments, no indices *) val is_unit_type : testing_function val match_with_equation : (constr * constr list) matching_function val is_equation : testing_function +(* type with only one constructor, no arguments and at least one dependency *) +val match_with_equality_type : (constr * constr list) matching_function + val match_with_nottype : (constr * constr) matching_function val is_nottype : testing_function diff --git a/tactics/inv.ml b/tactics/inv.ml index 68ebfd3c..977b602e 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: inv.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: inv.ml 11784 2009-01-14 11:36:32Z herbelin $ *) open Pp open Util @@ -109,8 +109,8 @@ let make_inv_predicate env sigma indf realargs id status concl = match dflt_concl with | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) | None -> - let sort = get_sort_of env sigma concl in - let p = make_arity env true indf sort in + let sort = get_sort_family_of env sigma concl in + let p = make_arity env true indf (new_sort_in_family sort) in Unification.abstract_list_all env (Evd.create_evar_defs sigma) p concl (realargs@[mkVar id]) in let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in @@ -469,7 +469,7 @@ let raw_inversion inv_kind id status names gl = case_nodep_then_using in (tclTHENS - (true_cut Anonymous cut_concl) + (assert_tac Anonymous cut_concl) [case_tac names (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns)) (Some elim_predicate) ([],[]) ind indclause; @@ -482,32 +482,14 @@ let raw_inversion inv_kind id status names gl = gl (* Error messages of the inversion tactics *) -let not_found_message ids = - if List.length ids = 1 then - (str "the variable" ++ spc () ++ str (string_of_id (List.hd ids)) ++ spc () ++ - str" was not found in the current environment") - else - (str "the variables [" ++ - spc () ++ prlist (fun id -> (str (string_of_id id) ++ spc ())) ids ++ - str" ] were not found in the current environment") - -let dep_prop_prop_message id = - errorlabstrm "Inv" - (str "Inversion on " ++ pr_id id ++ - str " would need dependent elimination from Prop to Prop.") - -let not_inductive_here id = - errorlabstrm "mind_specif_of_mind" - (str "Cannot recognize an inductive predicate in " ++ pr_id id ++ - str ". If there is one, may be the structure of the arity or of the type of constructors is hidden by constant definitions.") - -(* Noms d'errreurs obsolètes ?? *) let wrap_inv_error id = function - | UserError ("Case analysis",s) -> errorlabstrm "Inv needs Nodep Prop Set" s - | UserError("mind_specif_of_mind",_) -> not_inductive_here id - | UserError (a,b) -> errorlabstrm "Inv" b - | Invalid_argument "List.fold_left2" -> dep_prop_prop_message id - | Not_found -> errorlabstrm "Inv" (not_found_message [id]) + | Indrec.RecursionSchemeError + (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Prop Pos as k),i)) -> + errorlabstrm "" + (strbrk "Inversion would require case analysis on sort " ++ + pr_sort k ++ + strbrk " which is not allowed for inductive definition " ++ + pr_inductive (Global.env()) i ++ str ".") | e -> raise e (* The most general inversion tactic *) diff --git a/tactics/refine.ml b/tactics/refine.ml index 7ed58f6f..dff3b003 100644 --- a/tactics/refine.ml +++ b/tactics/refine.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: refine.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: refine.ml 11671 2008-12-12 12:43:03Z herbelin $ *) (* JCF -- 6 janvier 1998 EXPERIMENTAL *) @@ -275,7 +275,7 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = | Lambda (Name id,_,m), _ -> assert (isMeta (strip_outer_cast m)); begin match sgp with - | [None] -> introduction id gl + | [None] -> intro_mustbe_force id gl | [Some th] -> tclTHEN (introduction id) (onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)) gl @@ -314,7 +314,7 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = because of evars limitation, use non dependent assert instead *) | LetIn (Name id,c1,t1,c2), _ -> tclTHENS - (assert_tac true (Name id) t1) + (assert_tac (Name id) t1) [(match List.hd sgp with | None -> tclIDTAC | Some th -> onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)); diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml deleted file mode 100644 index 95d56f11..00000000 --- a/tactics/setoid_replace.ml +++ /dev/null @@ -1,2023 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 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.map (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 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 -> - anomalylabstrm "" - (str "Setoid: cannot find " ++ pr_id id ++ - str "(if loading Setoid.v under coqtop, use option \"-top Coq.Setoids.Setoid_tac\")") - -(* From Setoid.v *) - -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_tac"] "Relation_Class") -let coq_Argument_Class = lazy(constant ["Setoid_tac"] "Argument_Class") -let coq_Setoid_Theory = lazy(constant ["Setoid"] "Setoid_Theory") -let coq_Morphism_Theory = lazy(constant ["Setoid_tac"] "Morphism_Theory") -let coq_Build_Morphism_Theory= lazy(constant ["Setoid_tac"] "Build_Morphism_Theory") -let coq_Compat = lazy(constant ["Setoid_tac"] "Compat") - -let coq_AsymmetricReflexive = lazy(constant ["Setoid_tac"] "AsymmetricReflexive") -let coq_SymmetricReflexive = lazy(constant ["Setoid_tac"] "SymmetricReflexive") -let coq_SymmetricAreflexive = lazy(constant ["Setoid_tac"] "SymmetricAreflexive") -let coq_AsymmetricAreflexive = lazy(constant ["Setoid_tac"] "AsymmetricAreflexive") -let coq_Leibniz = lazy(constant ["Setoid_tac"] "Leibniz") - -let coq_RAsymmetric = lazy(constant ["Setoid_tac"] "RAsymmetric") -let coq_RSymmetric = lazy(constant ["Setoid_tac"] "RSymmetric") -let coq_RLeibniz = lazy(constant ["Setoid_tac"] "RLeibniz") - -let coq_ASymmetric = lazy(constant ["Setoid_tac"] "ASymmetric") -let coq_AAsymmetric = lazy(constant ["Setoid_tac"] "AAsymmetric") - -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_variance = lazy(constant ["Setoid_tac"] "variance") -let coq_Covariant = lazy(constant ["Setoid_tac"] "Covariant") -let coq_Contravariant = lazy(constant ["Setoid_tac"] "Contravariant") -let coq_Left2Right = lazy(constant ["Setoid_tac"] "Left2Right") -let coq_Right2Left = lazy(constant ["Setoid_tac"] "Right2Left") -let coq_MSNone = lazy(constant ["Setoid_tac"] "MSNone") -let coq_MSCovariant = lazy(constant ["Setoid_tac"] "MSCovariant") -let coq_MSContravariant = lazy(constant ["Setoid_tac"] "MSContravariant") - -let coq_singl = lazy(constant ["Setoid_tac"] "singl") -let coq_cons = lazy(constant ["Setoid_tac"] "necons") - -let coq_equality_morphism_of_asymmetric_areflexive_transitive_relation = - lazy(constant ["Setoid_tac"] - "equality_morphism_of_asymmetric_areflexive_transitive_relation") -let coq_equality_morphism_of_symmetric_areflexive_transitive_relation = - lazy(constant ["Setoid_tac"] - "equality_morphism_of_symmetric_areflexive_transitive_relation") -let coq_equality_morphism_of_asymmetric_reflexive_transitive_relation = - lazy(constant ["Setoid_tac"] - "equality_morphism_of_asymmetric_reflexive_transitive_relation") -let coq_equality_morphism_of_symmetric_reflexive_transitive_relation = - lazy(constant ["Setoid_tac"] - "equality_morphism_of_symmetric_reflexive_transitive_relation") -let coq_make_compatibility_goal = - lazy(constant ["Setoid_tac"] "make_compatibility_goal") -let coq_make_compatibility_goal_eval_ref = - lazy(eval_reference ["Setoid_tac"] "make_compatibility_goal") -let coq_make_compatibility_goal_aux_eval_ref = - lazy(eval_reference ["Setoid_tac"] "make_compatibility_goal_aux") - -let coq_App = lazy(constant ["Setoid_tac"] "App") -let coq_ToReplace = lazy(constant ["Setoid_tac"] "ToReplace") -let coq_ToKeep = lazy(constant ["Setoid_tac"] "ToKeep") -let coq_ProperElementToKeep = lazy(constant ["Setoid_tac"] "ProperElementToKeep") -let coq_fcl_singl = lazy(constant ["Setoid_tac"] "fcl_singl") -let coq_fcl_cons = lazy(constant ["Setoid_tac"] "fcl_cons") - -let coq_setoid_rewrite = lazy(constant ["Setoid_tac"] "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_tac"] "morphism_theory_of_function") -let coq_morphism_theory_of_predicate = - lazy(constant ["Setoid_tac"] "morphism_theory_of_predicate") -let coq_relation_of_relation_class = - lazy(eval_reference ["Setoid_tac"] "relation_of_relation_class") -let coq_directed_relation_of_relation_class = - lazy(eval_reference ["Setoid_tac"] "directed_relation_of_relation_class") -let coq_interp = lazy(eval_reference ["Setoid_tac"] "interp") -let coq_Morphism_Context_rect2 = - lazy(eval_reference ["Setoid_tac"] "Morphism_Context_rect2") -let coq_iff = lazy(gen_constant ["Init";"Logic"] "iff") -let coq_impl = lazy(constant ["Setoid_tac"] "impl") - - -(************************* Table of declared relations **********************) - - -(* Relations are stored in a table which is synchronised with the - Reset mechanism. The table maps the term denoting the relation to - the data of type relation that characterises the relation *) - -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 - Flags.if_warn msg_warning - (str "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.map (subst_mps subst) relation.rel_refl in - let rel_sym' = Option.map (subst_mps subst) relation.rel_sym in - let rel_trans' = Option.map (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 - relation - else - { 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.rel_aeq) (Gmap.rng !relation_table) - -let _ = - 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 : "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 - Flags.if_warn msg_warning - (strbrk "The relation " ++ prrelation th' ++ - strbrk " is redeclared. The new declaration" ++ - (match th'.rel_refl with - None -> mt () - | Some t -> strbrk " (reflexivity proved by " ++ pr_lconstr t) ++ - (match th'.rel_sym with - None -> mt () - | Some t -> - (if th'.rel_refl = None then strbrk " (" else strbrk " and ") - ++ strbrk "symmetry proved by " ++ pr_lconstr t) ++ - (if th'.rel_refl <> None && th'.rel_sym <> None then - str ")" else str "") ++ - strbrk " replaces the old declaration" ++ - (match old_relation.rel_refl with - None -> str "" - | Some t -> strbrk " (reflexivity proved by " ++ pr_lconstr t) ++ - (match old_relation.rel_sym with - None -> str "" - | Some t -> - (if old_relation.rel_refl = None then - strbrk " (" else strbrk " and ") ++ - strbrk "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_relation subst th in - if s' == s && th' == th then obj else - (s',th') - and export_set x = Some x - in - 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 ********************) - -(* Setoids are stored in a table which is synchronised with the Reset mechanism. *) - -let morphism_table = ref Gmap.empty - -let morphism_table_find m = Gmap.find 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 - Flags.if_warn msg_warning - (strbrk "The morphism " ++ prmorphism m old_morph ++ - strbrk " is redeclared. " ++ - strbrk "The new declaration whose compatibility is proved by " ++ - pr_lconstr c.lem ++ strbrk " replaces the old declaration whose" ++ - strbrk " 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 - Flags.if_warn msg_warning - (strbrk "There are several morphisms associated to \"" ++ - pr_lconstr m ++ strbrk "\". Morphism " ++ prmorphism m m1 ++ - strbrk " is randomly chosen."); - relation_morphism_of_constr_morphism m1 - -let subst_morph subst morph = - let lem' = subst_mps subst morph.lem 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 - && args' == morph.args - && output' == morph.output - && morphism_theory' == morph.morphism_theory - then - morph - else - { args = args' ; - output = output' ; - lem = lem' ; - morphism_theory = morphism_theory' - } - - -let _ = - Summary.declare_summary "morphism-table" - { Summary.freeze_function = (fun () -> !morphism_table); - Summary.unfreeze_function = (fun t -> morphism_table := t); - Summary.init_function = (fun () -> morphism_table := Gmap .empty); - Summary.survive_module = false; - Summary.survive_section = false } - -(* Declare a new type of object in the environment : "morphism-definition". *) - -let (morphism_to_obj, obj_to_morphism)= - let cache_set (_,(m, c)) = morphism_table_add (m, c) - and subst_set (_,subst,(m,c as obj)) = - let m' = subst_mps subst m in - let c' = subst_morph subst c in - if m' == m && c' == c then obj else - (m',c') - and export_set x = Some x - in - declare_object {(default_object "morphism-definition") 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} - -(************************** 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 ****************************) - -(* We maintain a table of the currently edited proofs of morphism lemma - in order to add them in the morphism_table when the user does Save *) - -let edited = ref Gmap.empty - -let new_edited id m = - edited := Gmap.add id m !edited - -let is_edited id = - Gmap.mem id !edited - -let no_more_edited id = - edited := Gmap.remove id !edited - -let what_edited id = - Gmap.find id !edited - -(* 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.map (fun c -> mkApp (c,subst)) rel.rel_refl ; - rel_sym = Option.map (fun c -> mkApp (c,subst)) rel.rel_sym; - rel_trans = Option.map (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 = Flags.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 })); - Flags.if_verbose ppnl (pr_lconstr m ++ str " is registered as a morphism") - -let error_cannot_unify_signature env k t t' = - errorlabstrm "New Morphism" - (str "One morphism argument or its output has type" ++ spc() ++ - pr_lconstr_env env t ++ strbrk " but the signature requires an argument" ++ - (if k = 0 then strbrk " of type " else - strbrk "whose type is an instance of ") ++ pr_lconstr_env env t' ++ - str ".") - -(* first order matching with a bit of conversion *) -let unify_relation_carrier_with_type env rel t = - 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 - error_cannot_unify_signature env rel.rel_quantifiers_no t rel.rel_a - | _ -> - try - let args = - Clenv.clenv_conv_leq env Evd.empty t rel.rel_a rel.rel_quantifiers_no - in - Array.of_list args - with Reduction.NotConvertible -> - error_cannot_unify_signature env rel.rel_quantifiers_no t rel.rel_a - 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 - error_cannot_unify_signature env 0 t t' - | Leibniz None -> Leibniz (Some t) - | Relation rel -> Relation (unify_relation_carrier_with_type env rel t) - -exception Impossible - -(* 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 avlen = Array.length av in - let argsno = List.length args in - if avlen < argsno then raise Impossible; (* partial application *) - let al = Array.to_list av in - let quantifiers,al' = Util.list_chop (avlen - argsno) al in - let quantifiersv = Array.of_list quantifiers in - let c' = mkApp (c,quantifiersv) in - if dependent t c' then raise Impossible; - (* 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 - ({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 = - try find_relation_class output' - with Not_found -> errorlabstrm "Add Morphism" - (str "Not a valid signature: " ++ pr_lconstr output' ++ - str " is neither a registered relation nor the Leibniz " ++ - str " equality.") 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 -> let _,t = decompose_prod typ in t, 0 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 expects 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.simpl env Evd.empty lem in - if Lib.is_modtype () then - begin - ignore - (Declare.declare_internal_constant id - (ParameterEntry (lem,false), 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) - (Decls.clear_proofs (Global.named_context ())) - lem hook; - Flags.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 - 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 = - Coqlib.check_required_library ["Coq";"Setoids";"Setoid_tac"]; - let sign = - match sign with - None -> None - | Some (args,out) -> - if args = [] then - error "Morphism signature expects at least one argument."; - 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 = Flags.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 = Flags.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)) ; - Flags.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.map (fun x -> apply_to_rels x a_quantifiers_rev) sym in - let refl_instance = - Option.map (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 = Flags.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 = - Coqlib.check_required_library ["Coq";"Setoids";"Setoid_tac"]; - int_add_relation id (constr_of a) (constr_of aeq) (Option.map constr_of refl) - (Option.map constr_of sym) (Option.map constr_of trans) - -(************************ Add Setoid ******************************************) - -(* The vernac command "Add Setoid" *) -let add_setoid id a aeq th = - Coqlib.check_required_library ["Coq";"Setoids";"Setoid_tac"]; - 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) - - -(****************************** The tactic itself *******************************) - -type direction = - Left2Right - | Right2Left - -let prdirection = - function - Left2Right -> str "->" - | Right2Left -> str "<-" - -type 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 - -let get_mark a = - Array.fold_left (||) false (Array.map is_to_replace a) - -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 subrelations 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_directions in_c = - if eq_constr t in_c then - if List.mem input_direction output_directions - && subrelation gl input_relation output_relation then - [ToReplace] - else [] - else - match kind_of_term in_c with - | App (c,al) -> - 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) -> - try (unify_morphism_with_arguments gl (c,al) m t) :: l - with Impossible -> 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 = - function - None -> [Left2Right;Right2Left] - | Some true -> output_directions - | Some false -> List.map opposite_direction output_directions - in - Util.array_map2 - (fun a (variance,relation) -> - (aux relation (apply_variance_to_direction variance) a) - ) al arguments - in - let a' = cartesian_product gl a in - List.flatten (List.map (fun output_direction -> - (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')) - output_directions) @ 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 instantiating 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 - List.map (fun output_direction -> - ToKeep (in_c,output_relation,output_direction)) - output_directions - 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 - List.map (fun output_direction -> - (ToKeep (in_c,output_relation,output_direction))) - output_directions @ 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 - List.map (fun output_direction -> - (MApp (func,mor,a,output_direction))) - output_directions @ res - ) [] a' - | (he::tl) -> - let typnf = Reduction.whd_betadeltaiota env typ in - match kind_of_term typnf with - | Prod (name,s,t) -> - let env' = push_rel (name,None,s) env in - let he = - (aux (Leibniz (Some s)) [Left2Right;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 - if (occur_term t c2) - then errorlabstrm "Setoid_replace" - (str "Cannot rewrite in the type of a variable bound " ++ - str "in a dependent product.") - else - List.map (fun output_direction -> - ToKeep (in_c,output_relation,output_direction)) - output_directions - 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_directions - (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 - List.map (fun output_direction -> - ToKeep (in_c,output_relation,output_direction)) - output_directions - 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) @ - (* [Left2Right] is the case of a prop 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" - (strbrk "Either the term " ++ pr_lconstr t ++ strbrk " that must be " ++ - strbrk "rewritten occurs in a covariant position or the goal is not" ++ - strbrk " made of morphism applications only. You can replace only " ++ - strbrk "occurrences that are in a contravariant position and such " ++ - strbrk "that the context obtained by abstracting them is made of " ++ - strbrk "morphism 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::_ -> - Flags.if_warn msg_warning - (strbrk "The application of the tactic is subject to one of " ++ - strbrk "the following set of side conditions that the user needs " ++ - strbrk "to prove:" ++ - pr_fnl () ++ - prlist_with_sepi pr_fnl - (fun i (_,_,mc) -> pr_new_goals i mc) res' ++ pr_fnl () ++ - strbrk "The first set is randomly chosen. Use the syntax " ++ - strbrk "\"setoid_rewrite ... generate side conditions ...\" to choose " ++ - strbrk "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.UnresolvedBindings [Evd.meta_name evd m]))) - 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 rewrite_unif_flags = { - modulo_conv_on_closed_terms = None; - use_metas_eagerly = true; - modulo_delta = empty_transparent_state; -} - -let rewrite2_unif_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly = true; - modulo_delta = empty_transparent_state; -} - -let unification_rewrite c1 c2 cl but gl = - let (env',c1) = - try - (* ~flags:(false,true) 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 ~flags:rewrite_unif_flags (pf_env gl) (c1,but) cl.evd - with - Pretype_errors.PretypeError _ -> - (* ~flags:(true,true) to make Ring work (since it really - exploits conversion) *) - w_unify_to_subterm ~flags:rewrite2_unif_flags - (pf_env gl) (c1,but) cl.evd - in - let cl' = {cl with evd = 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) all_occurrences (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 occs c ~new_goals gl = - if occs <> all_occurrences then - warning "Rewriting at selected occurrences not supported"; - 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. - Quite tricky to do properly since c1 can occur in c2 or vice-versa ! *) - let mangled_new_hyp = - let hyp = lift 2 hyp in - (* first, we backup every occurences of c1 in newly allocated (Rel 1) *) - let hyp = Termops.replace_term (lift 2 c1) (mkRel 1) hyp in - (* then, we factorize every occurences of c2 into (Rel 2) *) - let hyp = Termops.replace_term (lift 2 c2) (mkRel 2) hyp in - (* Now we substitute (Rel 1) (i.e. c1) for c2 *) - let hyp = subst1 (lift 1 c2) hyp in - (* Since subst1 has killed Rel 1 and decreased the other Rels, - Rel 1 is now coding for c2, we can build the let-in factorizing c2 *) - mkLetIn (Anonymous,c2,pf_type_of gl 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 occs c ~new_goals gl = - if occs <> all_occurrences then - warning "Rewriting at selected occurrences not supported"; - 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 - - -(* - [general_setoid_replace rewrite_tac try_prove_eq_tac_opt relation c1 c2 ~new_goals ] - common part of [setoid_replace] and [setoid_replace_in] (distinction is done using rewrite_tac). - - Algorith sketch: - 1- find the (setoid) relation [rel] between [c1] and [c2] using [relation] - 2- assert [H:rel c2 c1] - 3- replace [c1] with [c2] using [rewrite_tac] (should be [general_s_rewrite] if we want to replace in the - goal, and [general_s_rewrite_in id] if we want to replace in the hypothesis [id]). Possibly generate - new_goals if asked (cf general_s_rewrite) - 4- if [try_prove_eq_tac_opt] is [Some tac] try to complete [rel c2 c1] using tac and do nothing if - [try_prove_eq_tac_opt] is [None] -*) -let general_setoid_replace rewrite_tac try_prove_eq_tac_opt relation c1 c2 ~new_goals gl = - let try_prove_eq_tac = - match try_prove_eq_tac_opt with - | None -> Tacticals.tclIDTAC - | Some tac -> Tacticals.tclTRY (Tacticals.tclCOMPLETE tac ) - in - try - let carrier,args = decompose_app (pf_type_of gl c1) in - let relation = - match relation with - Some rel -> - (try - match find_relation_class rel with - Relation sa -> if not (eq_constr carrier sa.rel_a) then - errorlabstrm "Setoid_rewrite" - (str "the carrier of " ++ pr_lconstr rel ++ - str " does not match the type of " ++ pr_lconstr c1); - 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, Array.of_list (List.append args [ c1 ; c2 ])) in - let eq_right_to_left = mkApp (relation.rel_aeq, Array.of_list (List.append args [ c2 ; c1 ])) in - let replace dir eq = - tclTHENS (assert_tac false Anonymous eq) - [onLastHyp (fun id -> - tclTHEN - (rewrite_tac dir all_occurrences (mkVar id) ~new_goals) - (clear [id])); - try_prove_eq_tac] - in - tclORELSE - (replace true eq_left_to_right) (replace false eq_right_to_left) gl - with - Optimize -> (* (!replace tac_opt c1 c2) gl *) - let eq = mkApp (Lazy.force coq_eq, [| pf_type_of gl c1;c2 ; c1 |]) in - tclTHENS (assert_tac false Anonymous eq) - [onLastHyp (fun id -> - tclTHEN - (rewrite_tac false all_occurrences (mkVar id) ~new_goals) - (clear [id])); - try_prove_eq_tac] gl - -let setoid_replace = general_setoid_replace general_s_rewrite -let setoid_replace_in tac_opt id relation c1 c2 ~new_goals gl = - general_setoid_replace (general_s_rewrite_in id) tac_opt relation c1 c2 ~new_goals 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_red true 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_red true gl - -let setoid_symmetry_in id gl = - let ctype = pf_type_of gl (mkVar id) in - let binders,concl = Sign.decompose_prod_assum ctype in - let (equiv, args) = decompose_app concl 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 - let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in - let new_hyp' = mkApp (he, [| c2 ; c1 |]) in - let new_hyp = it_mkProd_or_LetIn new_hyp' binders in - tclTHENS (cut new_hyp) - [ intro_replacing id; - tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); assumption ] ] - 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_red true c gl -;; - diff --git a/tactics/setoid_replace.mli b/tactics/setoid_replace.mli deleted file mode 100644 index 6d736a0a..00000000 --- a/tactics/setoid_replace.mli +++ /dev/null @@ -1,85 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.std_ppcmds - -val register_replace : (tactic option -> constr -> constr -> tactic) -> unit -val register_general_rewrite : (bool -> occurrences -> 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 : - tactic option -> constr option -> constr -> constr -> new_goals:constr list -> tactic -val setoid_replace_in : - tactic option -> - identifier -> constr option -> constr -> constr -> new_goals:constr list -> - tactic - -val general_s_rewrite : - bool -> occurrences -> constr -> new_goals:constr list -> tactic -val general_s_rewrite_in : - identifier -> bool -> occurrences -> constr -> new_goals:constr list -> tactic - -val setoid_reflexivity : tactic -val setoid_symmetry : tactic -val setoid_symmetry_in : identifier -> tactic -val setoid_transitivity : constr -> tactic - -val add_relation : - Names.identifier -> constr_expr -> constr_expr -> constr_expr option -> - constr_expr option -> constr_expr option -> unit - -val add_setoid : - Names.identifier -> constr_expr -> constr_expr -> constr_expr -> unit - -val new_named_morphism : - Names.identifier -> constr_expr -> morphism_signature option -> unit - -val relation_table_find : constr -> relation -val relation_table_mem : constr -> bool - -val prrelation : relation -> Pp.std_ppcmds diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 3f8eb0ca..d9026a6d 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacinterp.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: tacinterp.ml 11745 2009-01-04 18:43:08Z herbelin $ *) open Constrintern open Closure @@ -96,7 +96,7 @@ let catch_error call_trace tac g = let (loc',c),tail = list_sep_last call_trace in let loc,e' = match e with Stdpp.Exc_located(loc,e) -> loc,e | _ ->dloc,e in if tail = [] then - let loc = if loc' = dloc then loc else loc' in + let loc = if loc = dloc then loc' else loc in raise (Stdpp.Exc_located(loc,e')) else raise (Stdpp.Exc_located(loc',LtacLocated((c,tail,loc),e'))) @@ -135,9 +135,6 @@ let rec pr_value env = function | VList (a::_) -> str "a list (first element is " ++ pr_value env a ++ str")" -(* Transforms a named_context into a (string * constr) list *) -let make_hyps = List.map (fun (id,_,typ) -> (id, typ)) - (* Transforms an id into a constr if possible, or fails *) let constr_of_id env id = construct_reference (Environ.named_context env) id @@ -375,15 +372,15 @@ let intern_or_var ist = function let loc_of_by_notation f = function | AN c -> f c - | ByNotation (loc,s) -> loc + | ByNotation (loc,s,_) -> loc let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef" let intern_inductive_or_by_notation = function | AN r -> Nametab.inductive_of_reference r - | ByNotation (loc,ntn) -> + | ByNotation (loc,ntn,sc) -> destIndRef (Notation.interp_notation_as_global_reference loc - (function IndRef ind -> true | _ -> false) ntn) + (function IndRef ind -> true | _ -> false) ntn sc) let intern_inductive ist = function | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id) @@ -565,10 +562,10 @@ let interp_global_reference r = let intern_evaluable_reference_or_by_notation = function | AN r -> evaluable_of_global_reference (interp_global_reference r) - | ByNotation (loc,ntn) -> + | ByNotation (loc,ntn,sc) -> evaluable_of_global_reference (Notation.interp_notation_as_global_reference loc - (function ConstRef _ | VarRef _ -> true | _ -> false) ntn) + (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) (* Globalizes a reduction expression *) let intern_evaluable ist = function @@ -597,33 +594,34 @@ let intern_red_expr ist = function | Simpl o -> Simpl (Option.map (intern_constr_with_occurrences ist) o) | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r ) -> r +let intern_in_hyp_as ist lf (id,ipat) = + (intern_hyp_or_metaid ist id, Option.map (intern_intro_pattern lf ist) ipat) + +let intern_hyp_list ist = List.map (intern_hyp_or_metaid ist) let intern_inversion_strength lf ist = function | NonDepInversion (k,idl,ids) -> - NonDepInversion (k,List.map (intern_hyp_or_metaid ist) idl, + NonDepInversion (k,intern_hyp_list ist idl, Option.map (intern_intro_pattern lf ist) ids) | DepInversion (k,copt,ids) -> DepInversion (k, Option.map (intern_constr ist) copt, Option.map (intern_intro_pattern lf ist) ids) | InversionUsing (c,idl) -> - InversionUsing (intern_constr ist c, List.map (intern_hyp_or_metaid ist) idl) + InversionUsing (intern_constr ist c, intern_hyp_list ist idl) (* Interprets an hypothesis name *) let intern_hyp_location ist (((b,occs),id),hl) = - (((b,List.map (intern_or_var ist) occs),intern_hyp ist (skip_metaid id)), hl) - -let interp_constrpattern_gen sigma env ?(as_type=false) ltacvar c = - let c = intern_gen as_type ~allow_patvar:true ~ltacvars:(ltacvar,[]) - sigma env c in - pattern_of_rawconstr c + (((b,List.map (intern_or_var ist) occs),intern_hyp_or_metaid ist id), hl) (* Reads a pattern *) let intern_pattern sigma env ?(as_type=false) lfun = function - | Subterm (ido,pc) -> - let (metas,pat) = interp_constrpattern_gen sigma env lfun pc in - ido, metas, Subterm (ido,pat) + | Subterm (b,ido,pc) -> + let ltacvars = (lfun,[]) in + let (metas,pat) = intern_constr_pattern sigma env ~ltacvars pc in + ido, metas, Subterm (b,ido,pat) | Term pc -> - let (metas,pat) = interp_constrpattern_gen sigma env ~as_type lfun pc in + let ltacvars = (lfun,[]) in + let (metas,pat) = intern_constr_pattern sigma env ~as_type ~ltacvars pc in None, metas, Term pat let intern_constr_may_eval ist = function @@ -658,6 +656,12 @@ let rec intern_match_goal_hyps sigma env lfun = function let lfun, metas2, hyps = intern_match_goal_hyps sigma env lfun tl in let lfun' = name_cons na (Option.List.cons ido lfun) in lfun', metas1@metas2, Hyp (locna,pat)::hyps + | (Def ((_,na) as locna,mv,mp))::tl -> + let ido, metas1, patv = intern_pattern sigma env ~as_type:false lfun mv in + let ido', metas2, patt = intern_pattern sigma env ~as_type:true lfun mp in + let lfun, metas3, hyps = intern_match_goal_hyps sigma env lfun tl in + let lfun' = name_cons na (Option.List.cons ido' (Option.List.cons ido lfun)) in + lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps | [] -> lfun, [], [] (* Utilities *) @@ -690,8 +694,9 @@ let rec intern_atomic lf ist x = | TacExact c -> TacExact (intern_constr ist c) | TacExactNoCheck c -> TacExactNoCheck (intern_constr ist c) | TacVmCastNoCheck c -> TacVmCastNoCheck (intern_constr ist c) - | TacApply (a,ev,cb) -> - TacApply (a,ev,List.map (intern_constr_with_bindings ist) cb) + | TacApply (a,ev,cb,inhyp) -> + TacApply (a,ev,List.map (intern_constr_with_bindings ist) cb, + Option.map (intern_in_hyp_as ist lf) inhyp) | TacElim (ev,cb,cbo) -> TacElim (ev,intern_constr_with_bindings ist cb, Option.map (intern_constr_with_bindings ist) cbo) @@ -709,7 +714,7 @@ let rec intern_atomic lf ist x = | TacCut c -> TacCut (intern_type ist c) | TacAssert (otac,ipat,c) -> TacAssert (Option.map (intern_tactic ist) otac, - intern_intro_pattern lf ist ipat, + Option.map (intern_intro_pattern lf ist) ipat, intern_constr_gen (otac<>None) ist c) | TacGeneralize cl -> TacGeneralize (List.map (fun (c,na) -> @@ -923,9 +928,10 @@ and intern_genarg ist x = (* how to know which names are bound by the intropattern *) in_gen globwit_intro_pattern (intern_intro_pattern lf ist (out_gen rawwit_intro_pattern x)) - | IdentArgType -> + | IdentArgType b -> let lf = ref ([],[]) in - in_gen globwit_ident(intern_ident lf ist (out_gen rawwit_ident x)) + in_gen (globwit_ident_gen b) + (intern_ident lf ist (out_gen (rawwit_ident_gen b) x)) | VarArgType -> in_gen globwit_var (intern_hyp ist (out_gen rawwit_var x)) | RefArgType -> @@ -994,9 +1000,18 @@ let eval_pattern lfun c = instantiate_pattern lvar c let read_pattern lfun = function - | Subterm (ido,pc) -> Subterm (ido,eval_pattern lfun pc) + | Subterm (b,ido,pc) -> Subterm (b,ido,eval_pattern lfun pc) | Term pc -> Term (eval_pattern lfun pc) +let value_of_ident id = VIntroPattern (IntroIdentifier id) + +let extend_values_with_bindings (ln,lm) lfun = + let lnames = List.map (fun (id,id') ->(id,value_of_ident id')) ln in + let lmatch = List.map (fun (id,c) -> (id,VConstr c)) lm in + (* For compatibility, bound variables are visible only if no other + binding of the same name exists *) + lmatch@lfun@lnames + (* Reads the hypotheses of a Match Context rule *) let cons_and_check_name id l = if List.mem id l then @@ -1010,6 +1025,10 @@ let rec read_match_goal_hyps lfun lidh = function let lidh' = name_fold cons_and_check_name na lidh in Hyp (locna,read_pattern lfun mp):: (read_match_goal_hyps lfun lidh' tl) + | (Def ((loc,na) as locna,mv,mp))::tl -> + let lidh' = name_fold cons_and_check_name na lidh in + Def (locna,read_pattern lfun mv, read_pattern lfun mp):: + (read_match_goal_hyps lfun lidh' tl) | [] -> [] (* Reads the rules of a Match Context or a Match *) @@ -1029,45 +1048,79 @@ let is_match_catchable = function | e -> Logic.catchable_exception e (* Verifies if the matched list is coherent with respect to lcm *) -let rec verify_metas_coherence gl lcm = function +(* While non-linear matching is modulo eq_constr in matches, merge of *) +(* different instances of the same metavars is here modulo conversion... *) +let verify_metas_coherence gl (ln1,lcm) (ln,lm) = + let rec aux = function | (num,csr)::tl -> if (List.for_all (fun (a,b) -> a<>num or pf_conv_x gl b csr) lcm) then - (num,csr)::(verify_metas_coherence gl lcm tl) + (num,csr)::aux tl else raise Not_coherent_metas - | [] -> [] + | [] -> lcm in + (ln@ln1,aux lm) (* 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 apply_one_mhyp_context ist env gl lmatch (hypname,patv,pat) lhyps = let get_id_couple id = function | Name idpat -> [idpat,VConstr (mkVar id)] | Anonymous -> [] in - let rec apply_one_mhyp_context_rec nocc = function - | (id,hyp)::tl as hyps -> - (match pat with - | Term t -> - (try - let lmeta = verify_metas_coherence gl lmatch (matches t hyp) in - (get_id_couple id hypname,lmeta,(id,hyp),(tl,0)) - with - | PatternMatchingFailure | Not_coherent_metas -> - apply_one_mhyp_context_rec 0 tl) - | Subterm (ic,t) -> + let match_pat lmatch hyp pat = + match pat with + | Term t -> + let lmeta = extended_matches t hyp in (try - 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 - | PatternMatchingFailure -> - apply_one_mhyp_context_rec 0 tl - | Not_coherent_metas -> - apply_one_mhyp_context_rec (nocc + 1) hyps)) + let lmeta = verify_metas_coherence gl lmatch lmeta in + ([],lmeta,(fun () -> raise PatternMatchingFailure)) + with + | Not_coherent_metas -> raise PatternMatchingFailure); + | Subterm (b,ic,t) -> + let rec match_next_pattern find_next () = + let (lmeta,ctxt,find_next') = find_next () in + try + let lmeta = verify_metas_coherence gl lmatch lmeta in + (give_context ctxt ic,lmeta,match_next_pattern find_next') + with + | Not_coherent_metas -> match_next_pattern find_next' () in + match_next_pattern(fun () -> match_subterm_gen b t hyp) () in + let rec apply_one_mhyp_context_rec = function + | (id,b,hyp as hd)::tl -> + (match patv with + | None -> + let rec match_next_pattern find_next () = + try + let (ids, lmeta, find_next') = find_next () in + (get_id_couple id hypname@ids, lmeta, hd, + match_next_pattern find_next') + with + | PatternMatchingFailure -> apply_one_mhyp_context_rec tl in + match_next_pattern (fun () -> match_pat lmatch hyp pat) () + | Some patv -> + match b with + | Some body -> + let rec match_next_pattern_in_body next_in_body () = + try + let (ids,lmeta,next_in_body') = next_in_body() in + let rec match_next_pattern_in_typ next_in_typ () = + try + let (ids',lmeta',next_in_typ') = next_in_typ() in + (get_id_couple id hypname@ids@ids', lmeta', hd, + match_next_pattern_in_typ next_in_typ') + with + | PatternMatchingFailure -> + match_next_pattern_in_body next_in_body' () in + match_next_pattern_in_typ + (fun () -> match_pat lmeta hyp pat) () + with PatternMatchingFailure -> apply_one_mhyp_context_rec tl + in + match_next_pattern_in_body + (fun () -> match_pat lmatch body patv) () + | None -> apply_one_mhyp_context_rec tl) | [] -> db_hyp_pattern_failure ist.debug env (hypname,pat); raise PatternMatchingFailure - in - apply_one_mhyp_context_rec nocc lhyps + in + apply_one_mhyp_context_rec lhyps let constr_to_id loc = function | VConstr c when isVar c -> destVar c @@ -1361,7 +1414,7 @@ let solvable_by_tactic env evi (ev,args) src = begin try by (tclCOMPLETE tac); - let _,(const,_,_) = cook_proof ignore in + let _,(const,_,_,_) = cook_proof ignore in delete_current_proof (); const.const_entry_body with e when Logic.catchable_exception e -> delete_current_proof(); @@ -1385,7 +1438,7 @@ let solve_remaining_evars env initial_sigma evd c = Pretype_errors.error_unsolvable_implicit loc env sigma evi src None) | _ -> map_constr proc_rec c in - proc_rec c + proc_rec (Evarutil.nf_isevar !evdref c) let interp_gen kind ist sigma env (c,ce) = let (ltacvars,unbndltacvars as vars) = constr_list ist env in @@ -1413,6 +1466,10 @@ let interp_open_constr ccl ist sigma env cc = let evd,c = interp_gen (OfType ccl) ist sigma env cc in (evars_of evd,c) +let interp_open_type ccl ist sigma env cc = + let evd,c = interp_gen IsType ist sigma env cc in + (evars_of evd,c) + let interp_constr = interp_econstr (OfType None) let interp_type = interp_econstr IsType @@ -1600,6 +1657,9 @@ let rec interp_intro_pattern ist gl = function and interp_or_and_intro_pattern ist gl = List.map (List.map (interp_intro_pattern ist gl)) +let interp_in_hyp_as ist gl (id,ipat) = + (interp_hyp ist gl id,Option.map (interp_intro_pattern ist gl) ipat) + (* Quantified named or numbered hypothesis or hypothesis in context *) (* (as in Inversion) *) let coerce_to_quantified_hypothesis = function @@ -1840,13 +1900,18 @@ and interp_letin ist gl llc u = val_interp ist gl u (* Interprets the Match Context expressions *) -and interp_match_goal ist g lz lr lmr = - let rec apply_goal_sub ist env goal nocc (id,c) csr mt mhyps hyps = - let (lgoal,ctxt) = match_subterm nocc c csr in - let lctxt = give_context ctxt id in +and interp_match_goal ist goal lz lr lmr = + let hyps = pf_hyps goal in + let hyps = if lr then List.rev hyps else hyps in + let concl = pf_concl goal in + let env = pf_env goal in + let rec apply_goal_sub app ist (id,c) csr mt mhyps hyps = + let rec match_next_pattern find_next () = + let (lgoal,ctxt,find_next') = find_next () 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 + with e when is_match_catchable e -> match_next_pattern find_next' () in + match_next_pattern (fun () -> match_subterm_gen app c csr) () in let rec apply_match_goal ist env goal nrs lex lpt = begin if lex<>[] then db_pattern_rule ist.debug nrs (List.hd lex); @@ -1859,27 +1924,24 @@ and interp_match_goal ist g lz lr lmr = apply_match_goal ist env goal (nrs+1) (List.tl lex) tl end | (Pat (mhyps,mgoal,mt))::tl -> - let hyps = make_hyps (pf_hyps goal) in - let hyps = if lr then List.rev hyps else hyps in - let mhyps = List.rev mhyps (* Sens naturel *) in - let concl = pf_concl goal in - (match mgoal with - | Term mg -> - (try - 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_goal 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 - | PatternMatchingFailure -> - apply_match_goal ist env goal (nrs+1) (List.tl lex) tl)) + let mhyps = List.rev mhyps (* Sens naturel *) in + (match mgoal with + | Term mg -> + (try + let lmatch = extended_matches mg concl in + db_matched_concl ist.debug env concl; + apply_hyps_context ist env lz goal mt [] lmatch 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_goal ist env goal (nrs+1) (List.tl lex) tl) + | Subterm (b,id,mg) -> + (try apply_goal_sub b ist (id,mg) concl mt mhyps hyps + with + | PatternMatchingFailure -> + apply_match_goal ist env goal (nrs+1) (List.tl lex) tl)) | _ -> errorlabstrm "Tacinterp.apply_match_goal" (v 0 (str "No matching clauses for match goal" ++ @@ -1887,31 +1949,36 @@ and interp_match_goal ist g lz lr lmr = fnl() ++ str "(use \"Set Ltac Debug\" for more info)" else mt()) ++ str".")) end in - let env = pf_env g in - apply_match_goal ist env g 0 lmr + apply_match_goal ist env goal 0 lmr (read_match_rule (fst (constr_list ist env)) lmr) (* Tries to match the hypotheses in a Match Context *) 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) = - apply_one_mhyp_context ist env goal lmatch (hypname,mhyp) current in - db_matched_hyp ist.debug (pf_env goal) hyp_match hypname; - begin + let rec apply_hyps_context_rec lfun lmatch lhyps_rest = function + | hyp_pat::tl -> + let (hypname, _, _ as hyp_pat) = + match hyp_pat with + | Hyp ((_,hypname),mhyp) -> hypname, None, mhyp + | Def ((_,hypname),mbod,mhyp) -> hypname, Some mbod, mhyp + in + let rec match_next_pattern find_next = + let (lids,lm,hyp_match,find_next') = find_next () in + db_matched_hyp ist.debug (pf_env goal) hyp_match hypname; try - let nextlhyps = list_except hyp_match lhyps_rest in - apply_hyps_context_rec (lfun@lids) (lmatch@lm) nextlhyps - (nextlhyps,0) tl + let id_match = pi1 hyp_match in + let nextlhyps = list_remove_assoc_in_triple id_match lhyps_rest in + apply_hyps_context_rec (lfun@lids) lm nextlhyps tl with e when is_match_catchable e -> - apply_hyps_context_rec lfun lmatch lhyps_rest next mhyps - end + match_next_pattern find_next' in + let init_match_pattern () = + apply_one_mhyp_context ist env goal lmatch hyp_pat lhyps_rest in + match_next_pattern init_match_pattern | [] -> - let lmatch = List.map (fun (id,c) -> (id,VConstr c)) lmatch in + let lfun = extend_values_with_bindings lmatch (lfun@ist.lfun) in db_mc_pattern_success ist.debug; - eval_with_fail {ist with lfun=lmatch@lfun@ist.lfun} lz goal mt + eval_with_fail {ist with lfun=lfun} lz goal mt in - apply_hyps_context_rec lctxt lgmatch hyps (hyps,0) mhyps + apply_hyps_context_rec lctxt lgmatch hyps mhyps and interp_external loc ist gl com req la = let f ch = extern_request ch req gl la in @@ -1933,9 +2000,9 @@ and interp_genarg ist gl x = | IntroPatternArgType -> in_gen wit_intro_pattern (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x)) - | IdentArgType -> - in_gen wit_ident - (interp_fresh_ident ist gl (out_gen globwit_ident x)) + | IdentArgType b -> + in_gen (wit_ident_gen b) + (interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x)) | VarArgType -> in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x)) | RefArgType -> @@ -2003,30 +2070,31 @@ and interp_genarg_var_list1 ist gl x = (* Interprets the Match expressions *) 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_subterm app ist (id,c) csr mt = + let rec match_next_pattern find_next () = + let (lmatch,ctxt,find_next') = find_next () in + let lctxt = give_context ctxt id in + let lfun = extend_values_with_bindings lmatch (lctxt@ist.lfun) in + try eval_with_fail {ist with lfun=lfun} lz g mt + with e when is_match_catchable e -> + match_next_pattern find_next' () in + match_next_pattern (fun () -> match_subterm_gen app c csr) () in let rec apply_match ist csr = function | (All 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 = - try matches c csr + let lmatch = + try extended_matches c csr with e -> debugging_exception_step ist false e (fun () -> str "matching with pattern" ++ fnl () ++ pr_constr_pattern_env (pf_env g) c); raise e in try - let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in - eval_with_fail { ist with lfun=lm@ist.lfun } lz g mt + let lfun = extend_values_with_bindings lmatch ist.lfun in + eval_with_fail { ist with lfun=lfun } lz g mt with e -> debugging_exception_step ist false e (fun () -> str "rule body for pattern" ++ @@ -2036,8 +2104,8 @@ and interp_match ist g lz constr lmr = debugging_step ist (fun () -> str "switching to the next rule"); apply_match ist csr tl) - | (Pat ([],Subterm (id,c),mt))::tl -> - (try apply_match_subterm ist 0 (id,c) csr mt + | (Pat ([],Subterm (b,id,c),mt))::tl -> + (try apply_match_subterm b ist (id,c) csr mt with PatternMatchingFailure -> apply_match ist csr tl) | _ -> errorlabstrm "Tacinterp.apply_match" (str @@ -2119,8 +2187,11 @@ and interp_atomic ist gl = function | TacExact c -> h_exact (pf_interp_casted_constr ist gl c) | TacExactNoCheck c -> h_exact_no_check (pf_interp_constr ist gl c) | TacVmCastNoCheck c -> h_vm_cast_no_check (pf_interp_constr ist gl c) - | TacApply (a,ev,cb) -> - h_apply a ev (List.map (interp_constr_with_bindings ist gl) cb) + | TacApply (a,ev,cb,None) -> + h_apply a ev (List.map (interp_open_constr_with_bindings ist gl) cb) + | TacApply (a,ev,cb,Some cl) -> + h_apply_in a ev (List.map (interp_open_constr_with_bindings ist gl) cb) + (interp_in_hyp_as ist gl cl) | TacElim (ev,cb,cbo) -> h_elim ev (interp_constr_with_bindings ist gl cb) (Option.map (interp_constr_with_bindings ist gl) cbo) @@ -2137,10 +2208,10 @@ and interp_atomic ist gl = function h_mutual_cofix b (interp_fresh_ident ist gl id) (List.map f l) | 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 + let c = (if t=None then interp_constr else interp_type) ist (project gl) (pf_env gl) c in abstract_tactic (TacAssert (t,ipat,inj_open c)) (Tactics.forward (Option.map (interp_tactic ist) t) - (interp_intro_pattern ist gl ipat) c) + (Option.map (interp_intro_pattern ist gl) ipat) c) | TacGeneralize cl -> h_generalize_gen (pf_interp_constr_with_occurrences_and_name_as_list ist gl cl) @@ -2230,7 +2301,7 @@ and interp_atomic ist gl = function (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> Equality.general_multi_multi_rewrite ev - (List.map (fun (b,m,c) -> (b,m,interp_constr_with_bindings ist gl c)) l) + (List.map (fun (b,m,c) -> (b,m,interp_open_constr_with_bindings ist gl c)) l) (interp_clause ist gl cl) (Option.map (interp_tactic ist) by) | TacInversion (DepInversion (k,c,ids),hyp) -> @@ -2263,10 +2334,10 @@ and interp_atomic ist gl = function | IntroPatternArgType -> VIntroPattern (snd (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))) - | IdentArgType -> + | IdentArgType b -> VIntroPattern (IntroIdentifier - (interp_fresh_ident ist gl (out_gen globwit_ident x))) + (interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x))) | VarArgType -> mk_hyp_value ist gl (out_gen globwit_var x) | RefArgType -> @@ -2437,13 +2508,16 @@ let subst_raw_may_eval subst = function | ConstrTerm c -> ConstrTerm (subst_rawconstr subst c) let subst_match_pattern subst = function - | Subterm (ido,pc) -> Subterm (ido,subst_pattern subst pc) + | Subterm (b,ido,pc) -> Subterm (b,ido,subst_pattern subst pc) | Term pc -> Term (subst_pattern subst pc) let rec subst_match_goal_hyps subst = function | Hyp (locs,mp) :: tl -> Hyp (locs,subst_match_pattern subst mp) :: subst_match_goal_hyps subst tl + | Def (locs,mv,mp) :: tl -> + Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp) + :: subst_match_goal_hyps subst tl | [] -> [] let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with @@ -2453,8 +2527,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacExact c -> TacExact (subst_rawconstr subst c) | TacExactNoCheck c -> TacExactNoCheck (subst_rawconstr subst c) | TacVmCastNoCheck c -> TacVmCastNoCheck (subst_rawconstr subst c) - | TacApply (a,ev,cb) -> - TacApply (a,ev,List.map (subst_raw_with_bindings subst) cb) + | TacApply (a,ev,cb,cl) -> + TacApply (a,ev,List.map (subst_raw_with_bindings subst) cb,cl) | TacElim (ev,cb,cbo) -> TacElim (ev,subst_raw_with_bindings subst cb, Option.map (subst_raw_with_bindings subst) cbo) @@ -2611,7 +2685,8 @@ and subst_genarg subst (x:glob_generic_argument) = | PreIdentArgType -> in_gen globwit_pre_ident (out_gen globwit_pre_ident x) | IntroPatternArgType -> in_gen globwit_intro_pattern (out_gen globwit_intro_pattern x) - | IdentArgType -> in_gen globwit_ident (out_gen globwit_ident x) + | IdentArgType b -> + in_gen (globwit_ident_gen b) (out_gen (globwit_ident_gen b) x) | VarArgType -> in_gen globwit_var (out_gen globwit_var x) | RefArgType -> in_gen globwit_ref (subst_global_reference subst diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 928e5914..add57cb5 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 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: tacinterp.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Dyn @@ -48,6 +48,9 @@ and interp_sign = val constr_of_id : Environ.env -> identifier -> constr (* To embed several objects in Coqast.t *) +val tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t +val tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr) + val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr val valueIn : value -> raw_tactic_arg @@ -99,6 +102,10 @@ val intern_tactic : val intern_constr : glob_sign -> constr_expr -> rawconstr_and_expr +val intern_constr_with_bindings : + glob_sign -> constr_expr * constr_expr Rawterm.bindings -> + rawconstr_and_expr * rawconstr_and_expr Rawterm.bindings + val intern_hyp : glob_sign -> identifier Util.located -> identifier Util.located @@ -124,6 +131,9 @@ val interp_tac_gen : (identifier * value) list -> identifier list -> val interp_hyp : interp_sign -> goal sigma -> identifier located -> identifier +val interp_bindings : interp_sign -> goal sigma -> rawconstr_and_expr Rawterm.bindings -> + Evd.open_constr Rawterm.bindings + (* Initial call for interpretation *) val glob_tactic : raw_tactic_expr -> glob_tactic_expr diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 3b13d1a0..28e987fa 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacticals.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: tacticals.ml 11735 2009-01-02 17:22:31Z herbelin $ *) open Pp open Util @@ -41,6 +41,7 @@ open Tacexpr let tclNORMEVAR = tclNORMEVAR let tclIDTAC = tclIDTAC let tclIDTAC_MESSAGE = tclIDTAC_MESSAGE +let tclORELSE0 = tclORELSE0 let tclORELSE = tclORELSE let tclTHEN = tclTHEN let tclTHENLIST = tclTHENLIST @@ -75,7 +76,7 @@ let tclIFTHENTRYELSEMUST = tclIFTHENTRYELSEMUST let unTAC = unTAC (* [rclTHENSEQ [t1;..;tn] is equivalent to t1;..;tn *) -let tclTHENSEQ = List.fold_left tclTHEN tclIDTAC +let tclTHENSEQ = tclTHENLIST (* map_tactical f [x1..xn] = (f x1);(f x2);...(f xn) *) (* tclMAP f [x1..xn] = (f x1);(f x2);...(f xn) *) @@ -88,10 +89,16 @@ let tclNTH_HYP m (tac : constr->tactic) gl = tac (try mkVar(let (id,_,_) = List.nth (pf_hyps gl) (m-1) in id) with Failure _ -> error "No such assumption.") gl +let tclNTH_DECL m tac gl = + tac (try List.nth (pf_hyps gl) (m-1) + with Failure _ -> error "No such assumption.") gl + (* apply a tactic to the last element of the signature *) let tclLAST_HYP = tclNTH_HYP 1 +let tclLAST_DECL = tclNTH_DECL 1 + let tclLAST_NHYPS n tac gl = tac (try list_firstn n (pf_ids_of_hyps gl) with Failure _ -> error "No such assumptions.") gl @@ -206,7 +213,7 @@ let onHyps find tac gl = tac (find gl) gl after id *) let afterHyp id gl = - fst (list_splitby (fun (hyp,_,_) -> hyp = id) (pf_hyps gl)) + fst (list_split_at (fun (hyp,_,_) -> hyp = id) (pf_hyps gl)) (* Create a singleton clause list with the last hypothesis from then context *) @@ -276,6 +283,13 @@ type branch_assumptions = { ba : branch_args; (* the branch args *) assums : named_context} (* the list of assumptions introduced *) +let fix_empty_or_and_pattern nv l = + (* 1- The syntax does not distinguish between "[ ]" for one clause with no + names and "[ ]" for no clause at all *) + (* 2- More generally, we admit "[ ]" for any disjunctive pattern of + arbitrary length *) + if l = [[]] then list_make nv [] else l + let check_or_and_pattern_size loc names n = if List.length names <> n then if n = 1 then @@ -288,10 +302,11 @@ let compute_induction_names n = function | None -> Array.make n [] | Some (loc,IntroOrAndPattern names) -> + let names = fix_empty_or_and_pattern n names in check_or_and_pattern_size loc names n; Array.of_list names - | _ -> - error "Unexpected introduction pattern." + | Some (loc,_) -> + user_err_loc (loc,"",str "Disjunctive/conjunctive introduction pattern expected.") let compute_construtor_signatures isrec (_,k as ity) = let rec analrec c recargs = @@ -313,23 +328,14 @@ let compute_construtor_signatures isrec (_,k as ity) = array_map2 analrec lc lrecargs let elimination_sort_of_goal gl = - match kind_of_term (hnf_type_of gl (pf_concl gl)) with - | Sort s -> - (match s with - | Prop Null -> InProp - | Prop Pos -> InSet - | Type _ -> InType) - | _ -> anomaly "goal should be a type" + pf_apply Retyping.get_sort_family_of gl (pf_concl gl) let elimination_sort_of_hyp id gl = - match kind_of_term (hnf_type_of gl (pf_get_hyp_typ gl id)) with - | Sort s -> - (match s with - | Prop Null -> InProp - | Prop Pos -> InSet - | Type _ -> InType) - | _ -> anomaly "goal should be a type" + pf_apply Retyping.get_sort_family_of gl (pf_get_hyp_typ gl id) +let elimination_sort_of_clause = function + | None -> elimination_sort_of_goal + | Some id -> elimination_sort_of_hyp id (* Find the right elimination suffix corresponding to the sort of the goal *) (* c should be of type A1->.. An->B with B an inductive definition *) diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 6826977b..25a0d897 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tacticals.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: tacticals.mli 11735 2009-01-02 17:22:31Z herbelin $ i*) (*i*) open Pp @@ -28,6 +28,7 @@ open Tacexpr val tclNORMEVAR : tactic val tclIDTAC : tactic val tclIDTAC_MESSAGE : std_ppcmds -> tactic +val tclORELSE0 : tactic -> tactic -> tactic val tclORELSE : tactic -> tactic -> tactic val tclTHEN : tactic -> tactic -> tactic val tclTHENSEQ : tactic list -> tactic @@ -57,8 +58,10 @@ val tclNOTSAMEGOAL : tactic -> tactic val tclTHENTRY : tactic -> tactic -> tactic val tclNTH_HYP : int -> (constr -> tactic) -> tactic +val tclNTH_DECL : int -> (named_declaration -> tactic) -> tactic val tclMAP : ('a -> tactic) -> 'a list -> tactic val tclLAST_HYP : (constr -> tactic) -> tactic +val tclLAST_DECL : (named_declaration -> tactic) -> tactic val tclLAST_NHYPS : int -> (identifier list -> tactic) -> tactic val tclTRY_sign : (constr -> tactic) -> named_context -> tactic val tclTRY_HYPS : (constr -> tactic) -> tactic @@ -136,6 +139,10 @@ type branch_assumptions = { val check_or_and_pattern_size : Util.loc -> or_and_intro_pattern_expr -> int -> unit +(* Tolerate "[]" to mean a disjunctive pattern of any length *) +val fix_empty_or_and_pattern : int -> or_and_intro_pattern_expr -> + or_and_intro_pattern_expr + (* Useful for [as intro_pattern] modifier *) val compute_induction_names : int -> intro_pattern_expr located option -> @@ -143,6 +150,7 @@ val compute_induction_names : val elimination_sort_of_goal : goal sigma -> sorts_family val elimination_sort_of_hyp : identifier -> goal sigma -> sorts_family +val elimination_sort_of_clause : identifier option -> goal sigma -> sorts_family val general_elim_then_using : (inductive -> goal sigma -> constr) -> rec_flag -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b02e84e7..5af5c0d5 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tactics.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: tactics.ml 11745 2009-01-04 18:43:08Z herbelin $ *) open Pp open Util @@ -85,15 +85,6 @@ let dloc = dummy_loc (* General functions *) (****************************************) -(* -let get_pairs_from_bindings = - let pair_from_binding = function - | [(Bindings binds)] -> binds - | _ -> error "not a binding list!" - in - List.map pair_from_binding -*) - let string_of_inductive c = try match kind_of_term c with | Ind ind_sp -> @@ -102,26 +93,16 @@ let string_of_inductive c = | _ -> raise Bound with Bound -> error "Bound head variable." -let rec head_constr_bound t l = - let t = strip_outer_cast(collapse_appl t) in - match kind_of_term t with - | Prod (_,_,c2) -> head_constr_bound c2 l - | LetIn (_,_,_,c2) -> head_constr_bound c2 l - | App (f,args) -> - head_constr_bound f (Array.fold_right (fun a l -> a::l) args l) - | Const _ -> t::l - | Ind _ -> t::l - | Construct _ -> t::l - | Var _ -> t::l - | _ -> raise Bound +let rec head_constr_bound t = + let t = strip_outer_cast t in + let _,ccl = decompose_prod_assum t in + let hd,args = decompose_app ccl in + match kind_of_term hd with + | Const _ | Ind _ | Construct _ | Var _ -> (hd,args) + | _ -> raise Bound let head_constr c = - try head_constr_bound c [] with Bound -> error "Bound head variable." - -(* -let bad_tactic_args s l = - raise (RefinerError (BadTacticArgs (s,l))) -*) + try head_constr_bound c with Bound -> error "Bound head variable." (******************************************) (* Primitive tactics *) @@ -169,6 +150,8 @@ let internal_cut_rev_replace = internal_cut_rev_gen true (* Moving hypotheses *) let move_hyp = Tacmach.move_hyp +let order_hyps = Tacmach.order_hyps + (* Renaming hypotheses *) let rename_hyp = Tacmach.rename_hyp @@ -192,25 +175,28 @@ let cofix = function type tactic_reduction = env -> evar_map -> constr -> constr -(* The following two tactics apply an arbitrary - reduction function either to the conclusion or to a - certain hypothesis *) - -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) gl = - let (_,c, ty) = pf_get_hyp gl id in +let pf_reduce_decl redfun where (id,c,ty) gl = let redfun' = pf_reduce redfun gl in match c with | None -> if where = InHypValueOnly then errorlabstrm "" (pr_id id ++ str "has no value."); - convert_hyp_no_check (id,None,redfun' ty) gl + (id,None,redfun' ty) | Some b -> let b' = if where <> InHypTypeOnly then redfun' b else b in let ty' = if where <> InHypValueOnly then redfun' ty else ty in - convert_hyp_no_check (id,Some b',ty') gl + (id,Some b',ty') + +(* The following two tactics apply an arbitrary + reduction function either to the conclusion or to a + certain hypothesis *) + +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) gl = + convert_hyp_no_check + (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl let reduct_option redfun = function | Some id -> reduct_in_hyp (fst redfun) id @@ -238,8 +224,8 @@ let change_on_subterm cv_pb t = function 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_in_hyp occl t id = + with_check (reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id) let change_option occl t = function Some id -> change_in_hyp occl t id @@ -276,16 +262,18 @@ let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast) (* A function which reduces accordingly to a reduction expression, as the command Eval does. *) -let needs_check = function +let checking_fun = function (* Expansion is not necessarily well-typed: e.g. expansion of t into x is not well-typed in [H:(P t); x:=t |- G] because x is defined after H *) - | Fold _ -> true - | _ -> false + | Fold _ -> with_check + | Pattern _ -> with_check + | _ -> (fun x -> x) let reduce redexp cl goal = - (if needs_check redexp then with_check else (fun x -> x)) - (redin_combinator (Redexpr.reduction_of_red_expr redexp) cl) - goal + let red = Redexpr.reduction_of_red_expr redexp in + match redexp with + (Fold _|Pattern _) -> with_check (redin_combinator red cl) goal + | _ -> redin_combinator red cl goal (* Unfolding occurrences of a constant *) @@ -402,9 +390,26 @@ let rec get_next_hyp_position id = function else get_next_hyp_position id right +let thin_for_replacing l gl = + try Tacmach.thin l gl + with Evarutil.ClearDependencyError (id,err) -> match err with + | Evarutil.OccurHypInSimpleClause None -> + errorlabstrm "" + (str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion.") + | Evarutil.OccurHypInSimpleClause (Some id') -> + errorlabstrm "" + (str "Cannot change " ++ pr_id id ++ + strbrk ", it is used in hypothesis " ++ pr_id id' ++ str".") + | Evarutil.EvarTypingBreak ev -> + errorlabstrm "" + (str "Cannot change " ++ pr_id id ++ + strbrk " without breaking the typing of " ++ + Printer.pr_existential (pf_env gl) ev ++ str".") + let intro_replacing id gl = let next_hyp = get_next_hyp_position id (pf_hyps gl) in - tclTHENLIST [thin [id]; introduction id; move_hyp true id next_hyp] gl + tclTHENLIST + [thin_for_replacing [id]; introduction id; move_hyp true id next_hyp] gl let intros_replacing ids gl = let rec introrec = function @@ -518,6 +523,13 @@ let bring_hyps hyps = let f = mkCast (Evarutil.mk_new_meta(),DEFAULTcast, newcl) in refine_no_check (mkApp (f, instance_from_named_context hyps)) gl) +let resolve_classes gl = + let env = pf_env gl and evd = project gl in + if evd = Evd.empty then tclIDTAC gl + else + let evd' = Typeclasses.resolve_typeclasses env (Evd.create_evar_defs evd) in + (tclTHEN (tclEVARS (Evd.evars_of evd')) tclNORMEVAR) gl + (**************************) (* Cut tactics *) (**************************) @@ -535,17 +547,11 @@ let cut c gl = let cut_intro t = tclTHENFIRST (cut t) intro -(* let cut_replacing id t tac = - tclTHENS (cut t) - [tclORELSE - (intro_replacing id) - (tclORELSE (intro_erasing id) (intro_using id)); - tac (refine_no_check (mkVar id)) ] *) - (* cut_replacing échoue si l'hypothèse à remplacer apparaît dans le but, ou dans une autre hypothèse *) let cut_replacing id t tac = - tclTHENS (cut t) [ intro_replacing id; tac (refine_no_check (mkVar id)) ] + tclTHENLAST (internal_cut_rev_replace id t) + (tac (refine_no_check (mkVar id))) let cut_in_parallel l = let rec prec = function @@ -704,72 +710,88 @@ let general_case_analysis with_evars (c,lbindc as cx) = let simplest_case c = general_case_analysis false (c,NoBindings) +(* Apply a tactic below the products of the conclusion of a lemma *) + +let descend_in_conjunctions with_evars tac exit c gl = + try + let (mind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + match match_with_record (snd (decompose_prod t)) with + | Some _ -> + let n = (mis_constr_nargs mind).(0) in + let sort = elimination_sort_of_goal gl in + let elim = pf_apply make_case_gen gl mind sort in + tclTHENLAST + (general_elim with_evars (c,NoBindings) (elim,NoBindings)) + (tclTHENLIST [ + tclDO n intro; + tclLAST_NHYPS n (fun l -> + tclFIRST + (List.map (fun id -> tclTHEN (tac (mkVar id)) (thin l)) l))]) + gl + | None -> + raise Exit + with RefinerError _|UserError _|Exit -> exit () + (****************************************************) (* Resolution tactics *) (****************************************************) -let resolve_classes gl = - let env = pf_env gl and evd = project gl in - if evd = Evd.empty then tclIDTAC gl - else - let evd' = Typeclasses.resolve_typeclasses env (Evd.create_evar_defs evd) in - (tclTHEN (tclEVARS (Evd.evars_of evd')) tclNORMEVAR) gl - (* Resolution with missing arguments *) -let general_apply with_delta with_destruct with_evars (c,lbind) gl = +let check_evars sigma evm gl = + let origsigma = gl.sigma in + let rest = + Evd.fold (fun ev evi acc -> + if not (Evd.mem origsigma ev) && not (Evd.is_defined sigma ev) + then Evd.add acc ev evi else acc) + evm Evd.empty + in + if rest <> Evd.empty then + errorlabstrm "apply" (str"Uninstantiated existential variables: " ++ + fnl () ++ pr_evar_map rest) + +let general_apply with_delta with_destruct with_evars (c,lbind) gl0 = let flags = if with_delta then default_unify_flags else default_no_delta_unify_flags in (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by step. *) - let concl_nprod = nb_prod (pf_concl gl) in + let concl_nprod = nb_prod (pf_concl gl0) in + let evm, c = c in let rec try_main_apply c gl = - let thm_ty0 = nf_betaiota (pf_type_of gl c) in - let try_apply thm_ty nprod = - let n = nb_prod thm_ty - nprod in - if n<0 then error "Applied theorem has not enough premisses."; - let clause = make_clenv_binding_apply gl (Some n) (c,thm_ty) lbind in - Clenvtac.res_pf clause ~with_evars:with_evars ~flags:flags gl in - try try_apply thm_ty0 concl_nprod - with PretypeError _|RefinerError _|UserError _|Failure _ as exn -> - let rec try_red_apply thm_ty = - try - (* Try to head-reduce the conclusion of the theorem *) - let red_thm = try_red_product (pf_env gl) (project gl) thm_ty in - try try_apply red_thm concl_nprod - with PretypeError _|RefinerError _|UserError _|Failure _ -> - try_red_apply red_thm - with Redelimination -> - (* Last chance: if the head is a variable, apply may try - second order unification *) - try if concl_nprod <> 0 then try_apply thm_ty 0 else raise Exit - with PretypeError _|RefinerError _|UserError _|Failure _|Exit -> - if with_destruct then - try - let (mind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in - match match_with_conjunction (snd (decompose_prod t)) with - | Some _ -> - let n = (mis_constr_nargs mind).(0) in - let sort = elimination_sort_of_goal gl in - let elim = pf_apply make_case_gen gl mind sort in - tclTHENLAST - (general_elim with_evars (c,NoBindings) (elim,NoBindings)) - (tclTHENLIST [ - tclDO n intro; - tclLAST_NHYPS n (fun l -> - tclFIRST - (List.map (fun id -> - tclTHEN (try_main_apply (mkVar id)) (thin l)) l)) - ]) gl - | None -> - raise Exit - with RefinerError _|UserError _|Exit -> raise exn - else - raise exn - in - try_red_apply thm_ty0 in - try_main_apply c gl + let thm_ty0 = nf_betaiota (pf_type_of gl c) in + let try_apply thm_ty nprod = + let n = nb_prod thm_ty - nprod in + if n<0 then error "Applied theorem has not enough premisses."; + let clause = make_clenv_binding_apply gl (Some n) (c,thm_ty) lbind in + let res = Clenvtac.res_pf clause ~with_evars:with_evars ~flags:flags gl in + if not with_evars then check_evars (fst res).sigma evm gl0; + res + in + try try_apply thm_ty0 concl_nprod + with PretypeError _|RefinerError _|UserError _|Failure _ as exn -> + let rec try_red_apply thm_ty = + try + (* Try to head-reduce the conclusion of the theorem *) + let red_thm = try_red_product (pf_env gl) (project gl) thm_ty in + try try_apply red_thm concl_nprod + with PretypeError _|RefinerError _|UserError _|Failure _ -> + try_red_apply red_thm + with Redelimination -> + (* Last chance: if the head is a variable, apply may try + second order unification *) + try if concl_nprod <> 0 then try_apply thm_ty 0 else raise Exit + with PretypeError _|RefinerError _|UserError _|Failure _|Exit -> + if with_destruct then + descend_in_conjunctions with_evars + try_main_apply (fun _ -> raise exn) c gl + else + raise exn + in try_red_apply thm_ty0 + in + if evm = Evd.empty then try_main_apply c gl0 + else + tclTHEN (tclEVARS (Evd.merge gl0.sigma evm)) (try_main_apply c) gl0 let rec apply_with_ebindings_gen b e = function | [] -> @@ -783,13 +805,13 @@ let apply_with_ebindings cb = apply_with_ebindings_gen false false [cb] let eapply_with_ebindings cb = apply_with_ebindings_gen false true [cb] let apply_with_bindings (c,bl) = - apply_with_ebindings (c,inj_ebindings bl) + apply_with_ebindings (inj_open c,inj_ebindings bl) let eapply_with_bindings (c,bl) = - apply_with_ebindings_gen false true [c,inj_ebindings bl] + apply_with_ebindings_gen false true [inj_open c,inj_ebindings bl] let apply c = - apply_with_ebindings (c,NoBindings) + apply_with_ebindings (inj_open c,NoBindings) let apply_list = function | c::l -> apply_with_bindings (c,ImplicitBindings l) @@ -819,27 +841,43 @@ let find_matching_clause unifier clause = with NotExtensibleClause -> failwith "Cannot apply" in find clause -let progress_with_clause innerclause clause = +let progress_with_clause flags innerclause clause = let ordered_metas = List.rev (clenv_independent clause) in if ordered_metas = [] then error "Statement without assumptions."; - let f mv = find_matching_clause (clenv_fchain mv clause) innerclause in + let f mv = + find_matching_clause (clenv_fchain mv ~flags clause) innerclause in try list_try_find f ordered_metas with Failure _ -> error "Unable to unify." -let apply_in_once gl innerclause (d,lbind) = +let apply_in_once_main flags innerclause (d,lbind) gl = let thm = nf_betaiota (pf_type_of gl d) in let rec aux clause = - try progress_with_clause innerclause clause + try progress_with_clause flags innerclause clause with err -> try aux (clenv_push_prod clause) - with NotExtensibleClause -> raise err - in aux (make_clenv_binding gl (d,thm) lbind) + with NotExtensibleClause -> raise err in + aux (make_clenv_binding gl (d,thm) lbind) + +let apply_in_once with_delta with_destruct with_evars id ((sigma,d),lbind) gl0 = + let flags = + if with_delta then default_unify_flags else default_no_delta_unify_flags in + let t' = pf_get_hyp_typ gl0 id in + let innerclause = mk_clenv_from_n gl0 (Some 0) (mkVar id,t') in + let rec aux c gl = + try + let clause = apply_in_once_main flags innerclause (c,lbind) gl in + let res = clenv_refine_in with_evars id clause gl in + if not with_evars then check_evars (fst res).sigma sigma gl0; + res + with exn when with_destruct -> + descend_in_conjunctions true aux (fun _ -> raise exn) c gl + in + if sigma = Evd.empty then aux d gl0 + else + tclTHEN (tclEVARS (Evd.merge gl0.sigma sigma)) (aux d) gl0 + + -let apply_in with_evars id lemmas gl = - let t' = pf_get_hyp_typ gl id in - let innermostclause = mk_clenv_from_n gl (Some 0) (mkVar id,t') in - let clause = List.fold_left (apply_in_once gl) innermostclause lemmas in - clenv_refine_in with_evars id clause gl (* A useful resolution tactic which, if c:A->B, transforms |- C into |- B -> C and |- A @@ -1013,7 +1051,7 @@ let constructor_tac with_evars expctdnumopt i lbind gl = Array.length (snd (Global.lookup_inductive mind)).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; let cons = mkConstruct (ith_constructor_of_inductive mind i) in - let apply_tac = general_apply true false with_evars (cons,lbind) in + let apply_tac = general_apply true false with_evars (inj_open cons,lbind) in (tclTHENLIST [convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) gl @@ -1062,11 +1100,6 @@ let register_general_multi_rewrite f = let clear_last = tclLAST_HYP (fun c -> (clear [destVar c])) let case_last = tclLAST_HYP simplest_case -let fix_empty_case nv l = - (* The syntax does not distinguish between "[ ]" for one clause with no names - and "[ ]" for no clause at all; so we are a bit liberal here *) - if Array.length nv = 0 & l = [[]] then [] else l - let error_unexpected_extra_pattern loc nb pat = let s1,s2,s3 = match pat with | IntroIdentifier _ -> "name", (plural nb " introduction pattern"), "no" @@ -1089,7 +1122,7 @@ let intro_or_and_pattern loc b ll l' tac = if bracketed then error_unexpected_extra_pattern loc' nb pat; l | ip :: l -> ip :: adjust_names_length nb (n-1) l in - let ll = fix_empty_case nv ll in + let ll = fix_empty_or_and_pattern (Array.length nv) ll in check_or_and_pattern_size loc ll (Array.length nv); tclTHENLASTn (tclTHEN case_last clear_last) @@ -1097,12 +1130,29 @@ let intro_or_and_pattern loc b ll l' tac = nv (Array.of_list ll)) gl) -let clear_if_atomic l2r id gl = - let eq = pf_type_of gl (mkVar id) in - let (_,lhs,rhs) = snd (find_eq_data_decompose eq) in - if l2r & isVar lhs then tclTRY (clear [destVar lhs;id]) gl - else if not l2r & isVar rhs then tclTRY (clear [destVar rhs;id]) gl - else tclIDTAC gl +let rewrite_hyp l2r id gl = + let rew_on l2r = + !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) in + let clear_var_and_eq c = + tclTRY (tclTHEN (clear [id]) (tclTRY (clear [destVar c]))) in + let t = pf_whd_betadeltaiota gl (pf_type_of gl (mkVar id)) in + (* TODO: detect setoid equality? better detect the different equalities *) + match match_with_equality_type t with + | Some (hdcncl,[_;lhs;rhs]) -> + if l2r & isVar lhs & not (occur_var (pf_env gl) (destVar lhs) rhs) then + tclTHEN (rew_on l2r allClauses) (clear_var_and_eq lhs) gl + else if not l2r & isVar rhs & not (occur_var (pf_env gl) (destVar rhs) lhs) then + tclTHEN (rew_on l2r allClauses) (clear_var_and_eq rhs) gl + else + tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl + | Some (hdcncl,[c]) -> + let l2r = not l2r in (* equality of the form eq_true *) + if isVar c then + tclTHEN (rew_on l2r allClauses) (clear_var_and_eq c) gl + else + tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl + | _ -> + error "Cannot find a known equation." let rec explicit_intro_names = function | (_, IntroIdentifier id) :: l -> @@ -1149,11 +1199,9 @@ let rec intros_patterns b avoid thin destopt = function tclTHEN (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true) (onLastHyp (fun id -> - tclTHENLIST [ - !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) - allClauses; - clear_if_atomic l2r id; - intros_patterns b avoid thin destopt l ])) + tclTHEN + (rewrite_hyp l2r id) + (intros_patterns b avoid thin destopt l))) | [] -> clear_wildcards thin let intros_pattern = intros_patterns false [] [] @@ -1170,23 +1218,25 @@ let intro_patterns = function let make_id s = fresh_id [] (default_id_of_sort s) -let prepare_intros s (loc,ipat) gl = match ipat with +let prepare_intros s ipat gl = match ipat with + | None -> make_id s gl, tclIDTAC + | Some (loc,ipat) -> match ipat with | IntroIdentifier id -> id, tclIDTAC | IntroAnonymous -> make_id s gl, tclIDTAC | IntroFresh id -> fresh_id [] id gl, tclIDTAC | IntroWildcard -> let id = make_id s gl in id, clear_wildcards [dloc,id] | IntroRewrite l2r -> let id = make_id s gl in - id, !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allClauses + id, !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) allClauses | IntroOrAndPattern ll -> make_id s gl, intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move) let ipat_of_name = function - | Anonymous -> IntroAnonymous - | Name id -> IntroIdentifier id + | Anonymous -> None + | Name id -> Some (dloc, IntroIdentifier id) let allow_replace c gl = function (* A rather arbitrary condition... *) - | _, IntroIdentifier id -> + | Some (_, IntroIdentifier id) -> fst (decompose_app (snd (decompose_lam_assum c))) = mkVar id | _ -> false @@ -1201,15 +1251,37 @@ let assert_as first ipat c gl = (if first then [tclIDTAC; tac] else [tac; tclIDTAC]) gl | _ -> error "Not a proposition or a type." -let assert_tac first na = assert_as first (dloc,ipat_of_name na) -let true_cut = assert_tac true +let assert_tac na = assert_as true (ipat_of_name na) + +(* apply in as *) + +let as_tac id ipat = match ipat with + | Some (loc,IntroRewrite l2r) -> + !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) allClauses + | Some (loc,IntroOrAndPattern ll) -> + intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move) + | Some (loc, + (IntroIdentifier _ | IntroAnonymous | IntroFresh _ | IntroWildcard)) -> + user_err_loc (loc,"", str "Disjunctive/conjunctive pattern expected") + | None -> tclIDTAC + +let general_apply_in with_delta with_destruct with_evars id lemmas ipat gl = + tclTHEN + (tclMAP (apply_in_once with_delta with_destruct with_evars id) lemmas) + (as_tac id ipat) + gl + +let apply_in simple with_evars = general_apply_in simple simple with_evars (**************************) (* Generalize tactics *) (**************************) -let generalized_name c t cl = function - | Name id as na -> na +let generalized_name c t ids cl = function + | Name id as na -> + if List.mem id ids then + errorlabstrm "" (pr_id id ++ str " is already used"); + na | Anonymous -> match kind_of_term c with | Var id -> @@ -1228,7 +1300,7 @@ let generalize_goal gl i ((occs,c),na) cl = let dummy_prod = it_mkProd_or_LetIn mkProp decls in let newdecls,_ = decompose_prod_n_assum i (subst_term c dummy_prod) in let cl' = subst_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in - let na = generalized_name c t cl' na in + let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in mkProd (na,t,cl') let generalize_dep c gl = @@ -1313,10 +1385,10 @@ let out_arg = function let occurrences_of_hyp id cls = let rec hyp_occ = function [] -> None - | (((b,occs),id'),hl)::_ when id=id' -> Some (b,List.map out_arg occs) + | (((b,occs),id'),hl)::_ when id=id' -> Some ((b,List.map out_arg occs),hl) | _::l -> hyp_occ l in match cls.onhyps with - None -> Some (all_occurrences) + None -> Some (all_occurrences,InHyp) | Some l -> hyp_occ l let occurrences_of_goal cls = @@ -1383,15 +1455,15 @@ let letin_tac with_eq name c occs gl = (* Implementation without generalisation: abbrev will be lost in hyps in *) (* in the extracted proof *) -let letin_abstract id c occs gl = +let letin_abstract id c (occs,check_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 = all_occurrences & d = newdecl then - if not (in_every_hyp occs) + if occ = (all_occurrences,InHyp) & d = newdecl then + if check_occs & not (in_every_hyp occs) then raise (RefinerError (DoesNotOccurIn (c,hyp))) else depdecls else @@ -1404,14 +1476,14 @@ let letin_abstract id c occs gl = if depdecls = [] then no_move else MoveAfter(pi1(list_last depdecls)) in (depdecls,lastlhyp,ccl) -let letin_tac with_eq name c occs gl = +let letin_tac_gen with_eq name c ty 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 = pf_type_of gl c in + let t = match ty with Some t -> t | None -> pf_type_of gl c in let newcl,eq_tac = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with @@ -1434,7 +1506,10 @@ let letin_tac with_eq name c occs gl = intro_gen dloc (IntroMustBe id) lastlhyp true; eq_tac; tclMAP convert_hyp_no_check depdecls ] gl - + +let letin_tac with_eq name c ty occs = + letin_tac_gen with_eq name c ty (occs,true) + (* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *) let forward usetac ipat c gl = match usetac with @@ -1444,6 +1519,9 @@ let forward usetac ipat c gl = | Some tac -> tclTHENFIRST (assert_as true ipat c) tac gl +let pose_proof na c = forward None (ipat_of_name na) c +let assert_by na t tac = forward (Some tac) (ipat_of_name na) t + (*****************************) (* Ad hoc unfold *) (*****************************) @@ -1523,7 +1601,7 @@ let rec first_name_buggy avoid gl (loc,pat) = match pat with | IntroWildcard -> no_move | IntroRewrite _ -> no_move | IntroIdentifier id -> MoveAfter id - | IntroAnonymous | IntroFresh _ -> assert false + | IntroAnonymous | IntroFresh _ -> (* buggy *) no_move let consume_pattern avoid id gl = function | [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), []) @@ -1618,14 +1696,14 @@ let atomize_param_of_ind (indref,nparams) hyp0 gl = | Var id -> let x = fresh_id [] id gl in tclTHEN - (letin_tac None (Name x) (mkVar id) allClauses) + (letin_tac None (Name x) (mkVar id) None allClauses) (atomize_one (i-1) ((mkVar x)::avoid)) gl | _ -> let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in let x = fresh_id [] id gl in tclTHEN - (letin_tac None (Name x) c allClauses) + (letin_tac None (Name x) c None allClauses) (atomize_one (i-1) ((mkVar x)::avoid)) gl else tclIDTAC gl @@ -1712,11 +1790,11 @@ let find_atomic_param_of_ind nparams indtyp = exception Shunt of identifier move_location -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 +let cook_sign hyp0_opt indvars env = + let hyp0,inhyps = + match hyp0_opt with + | None -> List.hd (List.rev indvars), [] + | Some (hyp0,at_least_in_hyps) -> hyp0, at_least_in_hyps 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 @@ -1739,9 +1817,9 @@ let cook_sign hyp0_opt indvars_init env = indhyps := hyp::!indhyps; rhyp end else - if (List.exists (fun id -> occur_var_in_decl env id decl) allindhyps - or List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) - !decldeps) + if inhyps <> [] && List.mem hyp inhyps || inhyps = [] && + (List.exists (fun id -> occur_var_in_decl env id decl) allindhyps || + List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) !decldeps) then begin decldeps := decl::!decldeps; if !before then @@ -1909,14 +1987,26 @@ let mkEq t x y = let mkRefl t x = mkApp ((build_coq_eq_data ()).refl, [| t; x |]) -let mkHEq t x u y = +let mkHEq t x u y = mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq", [| t; x; u; y |]) -let mkHRefl t x = +let mkHRefl t x = mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl", [| t; x |]) +(* let id = lazy (coq_constant "mkHEq" ["Init";"Datatypes"] "id") *) + +(* let mkHEq t x u y = *) +(* let ty = new_Type () in *) +(* mkApp (coq_constant "mkHEq" ["Logic";"EqdepFacts"] "eq_dep", *) +(* [| ty; mkApp (Lazy.force id, [|ty|]); t; x; u; y |]) *) + +(* let mkHRefl t x = *) +(* let ty = new_Type () in *) +(* mkApp (coq_constant "mkHEq" ["Logic";"EqdepFacts"] "eq_dep_intro", *) +(* [| ty; mkApp (Lazy.force id, [|ty|]); t; x |]) *) + let mkCoe a x p px y eq = mkApp (Option.get (build_coq_eq_data ()).rect, [| a; x; p; px; y; eq |]) @@ -1936,40 +2026,46 @@ let ids_of_constr vars c = let rec aux vars c = match kind_of_term c with | Var id -> if List.mem id vars then vars else id :: vars + | App (f, args) -> + (match kind_of_term f with + | Construct (ind,_) + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + array_fold_left_from mib.Declarations.mind_nparams + aux vars args + | _ -> fold_constr aux vars c) | _ -> fold_constr aux vars c in aux vars c let make_abstract_generalize gl id concl dep ctx c eqs args refls = let meta = Evarutil.new_meta() in - let cstr = + let term, typ = mkVar id, pf_get_hyp_typ gl id in + let eqslen = List.length eqs in + (* Abstract by the "generalized" hypothesis equality proof if necessary. *) + let abshypeq = + if dep then + mkProd (Anonymous, mkHEq (lift 1 c) (mkRel 1) typ term, lift 1 concl) + else concl + in (* Abstract by equalitites *) - let eqs = lift_togethern 1 eqs in - let abseqs = it_mkProd_or_LetIn ~init:concl (List.map (fun x -> (Anonymous, None, x)) eqs) in - (* Abstract by the "generalized" hypothesis and its equality proof *) - let term, typ = mkVar id, pf_get_hyp_typ gl id in - let abshyp = - let abshypeq = - if dep then - mkProd (Anonymous, mkHEq (lift 1 c) (mkRel 1) typ term, lift 1 abseqs) - else abseqs - in - mkProd (Name id, c, abshypeq) - in - (* Abstract by the extension of the context *) - let genctyp = it_mkProd_or_LetIn ~init:abshyp ctx in - (* The goal will become this product. *) - let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in - (* Apply the old arguments giving the proper instantiation of the hyp *) - let instc = mkApp (genc, Array.of_list args) in - (* Then apply to the original instanciated hyp. *) - let newc = mkApp (instc, [| mkVar id |]) in - (* Apply the reflexivity proof for the original hyp. *) - let newc = if dep then mkApp (newc, [| mkHRefl typ term |]) else newc in - (* Finaly, apply the remaining reflexivity proofs on the index, to get a term of type gl again *) - let appeqs = mkApp (newc, Array.of_list refls) in - appeqs - in cstr - + let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) + let abseqs = it_mkProd_or_LetIn ~init:(lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in + (* Abstract by the "generalized" hypothesis. *) + let genarg = mkProd (Name id, c, abseqs) in + (* Abstract by the extension of the context *) + let genctyp = it_mkProd_or_LetIn ~init:genarg ctx in + (* The goal will become this product. *) + let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in + (* Apply the old arguments giving the proper instantiation of the hyp *) + let instc = mkApp (genc, Array.of_list args) in + (* Then apply to the original instanciated hyp. *) + let instc = mkApp (instc, [| mkVar id |]) in + (* Apply the reflexivity proofs on the indices. *) + let appeqs = mkApp (instc, Array.of_list refls) in + (* Finaly, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) + let newc = if dep then mkApp (appeqs, [| mkHRefl typ term |]) else appeqs in + newc + let abstract_args gl id = let c = pf_get_hyp_typ gl id in let sigma = project gl in @@ -1998,26 +2094,36 @@ let abstract_args gl id = let liftargty = lift (List.length ctx) argty in let convertible = Reductionops.is_conv_leq ctxenv sigma liftargty ty in match kind_of_term arg with - | Var _ | Rel _ | Ind _ when convertible -> - (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, vars, env) - | _ -> - let name = get_id name in - let decl = (Name name, None, ty) in - let ctx = decl :: ctx in - let c' = mkApp (lift 1 c, [|mkRel 1|]) in - let args = arg :: args in - let liftarg = lift (List.length ctx) arg in - let eq, refl = - if convertible then - mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl argty arg - else - mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg - in - let eqs = eq :: lift_list eqs in - let refls = refl :: refls in - let vars = ids_of_constr vars arg in - (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, vars, env) + | Var _ | Rel _ | Ind _ when convertible -> + (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, vars, env) + | _ -> + let name = get_id name in + let decl = (Name name, None, ty) in + let ctx = decl :: ctx in + let c' = mkApp (lift 1 c, [|mkRel 1|]) in + let args = arg :: args in + let liftarg = lift (List.length ctx) arg in + let eq, refl = + if convertible then + mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl argty arg + else + mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg + in + let eqs = eq :: lift_list eqs in + let refls = refl :: refls in + let vars = ids_of_constr vars arg in + (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, vars, env) in + let f, args = + match kind_of_term f with + | Construct (ind,_) + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + let first = mib.Declarations.mind_nparams in + let pars, args = array_chop first args in + mkApp (f, pars), args + | _ -> f, args + in let arity, ctx, ctxenv, c', args, eqs, refls, vars, env = Array.fold_left aux (pf_type_of gl f,[],env,f,[],[],[],[],env) args in @@ -2040,10 +2146,31 @@ let abstract_generalize id ?(generalize_vars=true) gl = else tclTHENLIST [refine newc; clear [id]; tclDO n intro] in - if generalize_vars then - tclTHEN tac (tclMAP (fun id -> tclTRY (generalize_dep (mkVar id))) vars) gl + if generalize_vars then tclTHEN tac + (tclFIRST [revert (List.rev vars) ; + tclMAP (fun id -> tclTRY (generalize_dep (mkVar id))) vars]) gl else tac gl - + +let dependent_pattern c gl = + let cty = pf_type_of gl c in + let deps = + match kind_of_term cty with + | App (f, args) -> Array.to_list args + | _ -> [] + in + let varname c = match kind_of_term c with + | Var id -> id + | _ -> id_of_string (hdchar (pf_env gl) c) + in + let mklambda ty (c, id, cty) = + let conclvar = subst_term_occ all_occurrences c ty in + mkNamedLambda id cty conclvar + in + let subst = (c, varname c, cty) :: List.map (fun c -> (c, varname c, pf_type_of gl c)) deps in + let concllda = List.fold_left mklambda (pf_concl gl) subst in + let conclapp = applistc concllda (List.rev_map pi1 subst) in + convert_concl_no_check conclapp DEFAULTcast gl + let occur_rel n c = let res = not (noccurn n c) in res @@ -2466,7 +2593,8 @@ let induction_from_context_l isrec with_evars elim_info lid names gl = apply_induction_in_context isrec None indsign (hyp0::indvars) names induct_tac gl -let induction_from_context isrec with_evars elim_info (hyp0,lbind) names gl = +let induction_from_context isrec with_evars elim_info (hyp0,lbind) names + inhyps gl = 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 @@ -2479,12 +2607,11 @@ let induction_from_context isrec with_evars elim_info (hyp0,lbind) names gl = thin [hyp0] ] in apply_induction_in_context isrec - (Some hyp0) indsign indvars names induct_tac gl - + (Some (hyp0,inhyps)) indsign indvars names induct_tac gl exception TryNewInduct of exn -let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) gl = +let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) inhyps 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 @@ -2494,7 +2621,8 @@ let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbin 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 with_evars elim_info (hyp0,lbind) names) gl + (induction_from_context isrec with_evars elim_info + (hyp0,lbind) names inhyps) gl (* Induction on a list of induction arguments. Analyse the elim scheme (which is mandatory for multiple ind args), check that all @@ -2512,26 +2640,66 @@ let induction_without_atomization isrec with_evars elim names lid gl = then error "Not the right number of induction arguments." else induction_from_context_l isrec with_evars elim_info lid names gl +let enforce_eq_name id gl = function + | (b,(loc,IntroAnonymous)) -> + (b,(loc,IntroIdentifier (fresh_id [id] (add_prefix "Heq" id) gl))) + | (b,(loc,IntroFresh heq_base)) -> + (b,(loc,IntroIdentifier (fresh_id [id] heq_base gl))) + | x -> + x + +let has_selected_occurrences = function + | None -> false + | Some cls -> + cls.concl_occs <> all_occurrences_expr || + cls.onhyps <> None && List.exists (fun ((occs,_),hl) -> + occs <> all_occurrences_expr || hl <> InHyp) (Option.get cls.onhyps) + +(* assume that no occurrences are selected *) +let clear_unselected_context id inhyps cls gl = + match cls with + | None -> tclIDTAC gl + | Some cls -> + if occur_var (pf_env gl) id (pf_concl gl) && + cls.concl_occs = no_occurrences_expr + then errorlabstrm "" + (str "Conclusion must be mentioned: it depends on " ++ pr_id id + ++ str "."); + match cls.onhyps with + | Some hyps -> + let to_erase (id',_,_ as d) = + if List.mem id' inhyps then (* if selected, do not erase *) None + else + (* erase if not selected and dependent on id or selected hyps *) + let test id = occur_var_in_decl (pf_env gl) id d in + if List.exists test (id::inhyps) then Some id' else None in + let ids = list_map_filter to_erase (pf_hyps gl) in + thin ids gl + | None -> tclIDTAC gl + let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl = + let inhyps = match cls with + | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps + | _ -> [] in match kind_of_term c with | Var id when not (mem_named_context id (Global.named_context())) - & lbind = NoBindings & not with_evars & cls = None - & eqname = None -> - induction_with_atomization_of_ind_arg - isrec with_evars elim names (id,lbind) gl + & lbind = NoBindings & not with_evars & eqname = None + & not (has_selected_occurrences cls) -> + tclTHEN + (clear_unselected_context id inhyps cls) + (induction_with_atomization_of_ind_arg + isrec with_evars elim names (id,lbind) inhyps) 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 with_eq = - match eqname with - | Some eq -> Some (false,eq) - | _ -> - if cls <> None then Some (false,(dloc,IntroAnonymous)) else None in + (* We need the equality name now *) + let with_eq = Option.map (fun eq -> (false,eq)) eqname in + (* TODO: if ind has predicate parameters, use JMeq instead of eq *) tclTHEN - (letin_tac with_eq (Name id) c (Option.default allClauses cls)) + (letin_tac_gen with_eq (Name id) c None (Option.default allClauses cls,false)) (induction_with_atomization_of_ind_arg - isrec with_evars elim names (id,lbind)) gl + isrec with_evars elim names (id,lbind) inhyps) gl (* Induction on a list of arguments. First make induction arguments atomic (using letins), then do induction. The specificity here is @@ -2563,7 +2731,7 @@ let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl = let _ = newlc:=id::!newlc in let _ = letids:=id::!letids in tclTHEN - (letin_tac None (Name id) c allClauses) + (letin_tac None (Name id) c None allClauses) (atomize_list newl') gl in tclTHENLIST [ @@ -2763,12 +2931,15 @@ let reflexivity_red allowred gl = let concl = if not allowred then pf_concl gl else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) in - match match_with_equation concl with - | None -> !setoid_reflexivity gl - | Some _ -> one_constructor 1 NoBindings gl - -let reflexivity gl = reflexivity_red false gl - + match match_with_equality_type concl with + | None -> None + | Some _ -> Some (one_constructor 1 NoBindings) + +let reflexivity gl = + match reflexivity_red false gl with + | None -> !setoid_reflexivity gl + | Some tac -> tac gl + let intros_reflexivity = (tclTHEN intros reflexivity) (* Symmetry tactics *) @@ -2788,13 +2959,15 @@ let symmetry_red allowred gl = let concl = if not allowred then pf_concl gl else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) in - match match_with_equation concl with - | None -> !setoid_symmetry gl - | Some (hdcncl,args) -> + match match_with_equation concl with + | None -> None + | Some (hdcncl,args) -> Some (fun gl -> let hdcncls = string_of_inductive hdcncl in begin try - (apply (pf_parse_const gl ("sym_"^hdcncls)) gl) + tclTHEN + (convert_concl_no_check concl DEFAULTcast) + (apply (pf_parse_const gl ("sym_"^hdcncls))) gl with _ -> let symc = match args with | [t1; c1; t2; c2] -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) @@ -2808,9 +2981,12 @@ let symmetry_red allowred gl = tclLAST_HYP simplest_case; one_constructor 1 NoBindings ]) gl - end + end) -let symmetry gl = symmetry_red false gl +let symmetry gl = + match symmetry_red false gl with + | None -> !setoid_symmetry gl + | Some tac -> tac gl let setoid_symmetry_in = ref (fun _ _ -> assert false) let register_setoid_symmetry_in f = setoid_symmetry_in := f @@ -2860,8 +3036,8 @@ let transitivity_red allowred t gl = else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) in match match_with_equation concl with - | None -> !setoid_transitivity t gl - | Some (hdcncl,args) -> + | None -> None + | Some (hdcncl,args) -> Some (fun gl -> let hdcncls = string_of_inductive hdcncl in begin try @@ -2885,10 +3061,13 @@ let transitivity_red allowred t gl = [ tclDO 2 intro; tclLAST_HYP simplest_case; assumption ])) gl - end - -let transitivity t gl = transitivity_red false t gl + end) +let transitivity t gl = + match transitivity_red false t gl with + | None -> !setoid_transitivity t gl + | Some tac -> tac gl + let intros_transitivity n = tclTHEN intros (transitivity n) (* tactical to save as name a subproof such that the generalisation of @@ -2917,7 +3096,7 @@ let abstract_subproof name tac gl = error "\"abstract\" cannot handle existentials."; let lemme = start_proof na (Global, Proof Lemma) secsign concl (fun _ _ -> ()); - let _,(const,kind,_) = + let _,(const,_,kind,_) = try by (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)); let r = cook_proof ignore in @@ -2968,7 +3147,14 @@ let admit_as_an_axiom gl = List.rev (Array.to_list (instance_from_named_context sign)))) gl -let conv x y gl = - try let evd = Evarconv.the_conv_x_leq (pf_env gl) x y (Evd.create_evar_defs (project gl)) in - tclEVARS (Evd.evars_of evd) gl - with _ -> tclFAIL 0 (str"Not convertible") gl +let unify ?(state=full_transparent_state) x y gl = + try + let flags = + {default_unify_flags with + modulo_delta = state; + modulo_conv_on_closed_terms = Some state} + in + let evd = w_unify false (pf_env gl) Reduction.CONV + ~flags x y (Evd.create_evar_defs (project gl)) + in tclEVARS (Evd.evars_of evd) gl + with _ -> tclFAIL 0 (str"Not unifiable") gl diff --git a/tactics/tactics.mli b/tactics/tactics.mli index d39433d0..fb5c0efd 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 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: tactics.mli 11735 2009-01-02 17:22:31Z herbelin $ i*) (*i*) open Util @@ -42,8 +42,8 @@ val type_clenv_binding : goal sigma -> constr * constr -> open_constr bindings -> constr val string_of_inductive : constr -> string -val head_constr : constr -> constr list -val head_constr_bound : constr -> constr list -> constr list +val head_constr : constr -> constr * constr list +val head_constr_bound : constr -> constr * constr list val is_quantified_hypothesis : identifier -> goal sigma -> bool exception Bound @@ -184,19 +184,22 @@ val bring_hyps : named_context -> tactic val apply : constr -> tactic val apply_without_reduce : constr -> tactic val apply_list : constr list -> tactic - + val apply_with_ebindings_gen : - advanced_flag -> evars_flag -> constr with_ebindings list -> tactic + advanced_flag -> evars_flag -> open_constr with_ebindings list -> tactic val apply_with_bindings : constr with_bindings -> tactic val eapply_with_bindings : constr with_bindings -> tactic -val apply_with_ebindings : constr with_ebindings -> tactic -val eapply_with_ebindings : constr with_ebindings -> tactic +val apply_with_ebindings : open_constr with_ebindings -> tactic +val eapply_with_ebindings : open_constr with_ebindings -> tactic val cut_and_apply : constr -> tactic -val apply_in : evars_flag -> identifier -> constr with_ebindings list -> tactic +val apply_in : + advanced_flag -> evars_flag -> identifier -> + open_constr with_ebindings list -> + intro_pattern_expr located option -> tactic (*s Elimination tactics. *) @@ -324,19 +327,19 @@ val simplest_split : tactic (*s Logical connective tactics. *) val register_setoid_reflexivity : tactic -> unit -val reflexivity_red : bool -> tactic +val reflexivity_red : bool -> goal sigma -> tactic option val reflexivity : tactic val intros_reflexivity : tactic val register_setoid_symmetry : tactic -> unit -val symmetry_red : bool -> tactic +val symmetry_red : bool -> goal sigma -> tactic option 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_red : bool -> constr -> tactic +val transitivity_red : bool -> constr -> goal sigma -> tactic option val transitivity : constr -> tactic val intros_transitivity : constr -> tactic @@ -346,17 +349,19 @@ val cut_replacing : identifier -> constr -> (tactic -> tactic) -> tactic val cut_in_parallel : constr list -> tactic -val assert_as : bool -> intro_pattern_expr located -> constr -> tactic -val forward : tactic option -> intro_pattern_expr located -> constr -> tactic +val assert_as : bool -> intro_pattern_expr located option -> constr -> tactic +val forward : tactic option -> intro_pattern_expr located option -> constr -> tactic val letin_tac : (bool * intro_pattern_expr located) option -> name -> - constr -> clause -> tactic -val true_cut : name -> constr -> tactic -val assert_tac : bool -> name -> constr -> tactic + constr -> types option -> clause -> tactic +val assert_tac : name -> types -> tactic +val assert_by : name -> types -> tactic -> tactic +val pose_proof : name -> constr -> tactic + val generalize : constr list -> tactic val generalize_gen : ((occurrences * constr) * name) list -> tactic val generalize_dep : constr -> tactic -val conv : constr -> constr -> tactic +val unify : ?state:Names.transparent_state -> constr -> constr -> tactic val resolve_classes : tactic val tclABSTRACT : identifier option -> tactic -> tactic @@ -365,5 +370,7 @@ val admit_as_an_axiom : tactic val abstract_generalize : identifier -> ?generalize_vars:bool -> tactic +val dependent_pattern : constr -> tactic + val register_general_multi_rewrite : - (bool -> evars_flag -> constr with_ebindings -> clause -> tactic) -> unit + (bool -> evars_flag -> open_constr with_bindings -> clause -> tactic) -> unit diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 17ea121f..1729695d 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id: tauto.ml4 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: tauto.ml4 11739 2009-01-02 19:33:19Z herbelin $ i*) open Term open Hipattern @@ -21,19 +21,44 @@ open Tacinterp open Tactics open Util -let assoc_last ist = - match List.assoc (Names.id_of_string "X1") ist.lfun with +let assoc_var s ist = + match List.assoc (Names.id_of_string s) ist.lfun with | VConstr c -> c | _ -> failwith "tauto: anomaly" +(** Parametrization of tauto *) + +(* Whether conjunction and disjunction are restricted to binary connectives *) +(* (this is the compatibility mode) *) +let binary_mode = true + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* contravariant position in an hypothesis (this is the compatibility mode) *) +let strict_in_contravariant_hyp = true + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* an hypothesis and in the conclusion *) +let strict_in_hyp_and_ccl = false + +(* Whether unit type includes equality types *) +let strict_unit = false + + +(** Test *) + let is_empty ist = - if is_empty_type (assoc_last ist) then + if is_empty_type (assoc_var "X1" ist) then <:tactic> else <:tactic> -let is_unit ist = - if is_unit_type (assoc_last ist) then +(* Strictly speaking, this exceeds the propositional fragment as it + matches also equality types (and solves them if a reflexivity) *) +let is_unit_or_eq ist = + let test = if strict_unit then is_unit_type else is_unit_or_eq_type in + if test (assoc_var "X1" ist) then <:tactic> else <:tactic> @@ -47,93 +72,138 @@ let is_record t = | _ -> false let is_binary t = + isApp t && let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in mib.Declarations.mind_nparams = 2 | _ -> false - + +let iter_tac tacl = + List.fold_right (fun tac tacs -> <:tactic< $tac; $tacs >>) tacl + +(** Dealing with conjunction *) + let is_conj ist = - let ind = assoc_last ist in - if (is_conjunction ind) && (is_nodep_ind ind) (* && not (is_record ind) *) - && is_binary ind (* for compatibility, as (?X _ _) matches - applications with 2 or more arguments. *) + let ind = assoc_var "X1" ist in + if (not binary_mode || is_binary ind) (* && not (is_record ind) *) + && is_conjunction ~strict:strict_in_hyp_and_ccl ind then <:tactic> else <:tactic> +let flatten_contravariant_conj ist = + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + match match_with_conjunction ~strict:strict_in_contravariant_hyp typ with + | Some (_,args) -> + let i = List.length args in + if not binary_mode || i = 2 then + let newtyp = valueIn (VConstr (List.fold_right mkArrow args c)) in + let intros = + iter_tac (List.map (fun _ -> <:tactic< intro >>) args) + <:tactic< idtac >> in + <:tactic< + let newtyp := $newtyp in + assert newtyp by ($intros; apply id; split; assumption); + clear id + >> + else + <:tactic> + | _ -> + <:tactic> + +(** Dealing with disjunction *) + let is_disj ist = - if is_disjunction (assoc_last ist) && is_binary (assoc_last ist) then + let t = assoc_var "X1" ist in + if (not binary_mode || is_binary t) && + is_disjunction ~strict:strict_in_hyp_and_ccl t + then <:tactic> else <:tactic> +let flatten_contravariant_disj ist = + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + match match_with_disjunction ~strict:strict_in_contravariant_hyp typ with + | Some (_,args) -> + let i = List.length args in + if not binary_mode || i = 2 then + iter_tac (list_map_i (fun i arg -> + let typ = valueIn (VConstr (mkArrow arg c)) in + <:tactic< + let typ := $typ in + assert typ by (intro; apply id; constructor $i; assumption) + >>) 1 args) <:tactic< clear id >> + else + <:tactic> + | _ -> + <:tactic> + + +(** Main tactic *) + let not_dep_intros ist = <:tactic< repeat match goal with | |- (?X1 -> ?X2) => intro - | |- (Coq.Init.Logic.iff _ _) => unfold Coq.Init.Logic.iff - | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not - | H:(Coq.Init.Logic.iff _ _)|- _ => unfold Coq.Init.Logic.iff in H - | H:(Coq.Init.Logic.not _)|-_ => unfold Coq.Init.Logic.not in H - | H:(Coq.Init.Logic.iff _ _)->_|- _ => unfold Coq.Init.Logic.iff in H - | H:(Coq.Init.Logic.not _)->_|-_ => unfold Coq.Init.Logic.not in H + | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1 + | H:(Coq.Init.Logic.not _)|-_ => unfold Coq.Init.Logic.not at 1 in H + | H:(Coq.Init.Logic.not _)->_|-_ => unfold Coq.Init.Logic.not at 1 in H end >> let axioms ist = - let t_is_unit = tacticIn is_unit + let t_is_unit_or_eq = tacticIn is_unit_or_eq and t_is_empty = tacticIn is_empty in <:tactic< match reverse goal with - | |- ?X1 => $t_is_unit; constructor 1 + | |- ?X1 => $t_is_unit_or_eq; constructor 1 | _:?X1 |- _ => $t_is_empty; elimtype X1; assumption | _:?X1 |- ?X1 => assumption end >> let simplif ist = - let t_is_unit = tacticIn is_unit + let t_is_unit_or_eq = tacticIn is_unit_or_eq and t_is_conj = tacticIn is_conj + and t_flatten_contravariant_conj = tacticIn flatten_contravariant_conj + and t_flatten_contravariant_disj = tacticIn flatten_contravariant_disj and t_is_disj = tacticIn is_disj and t_not_dep_intros = tacticIn not_dep_intros in <:tactic< $t_not_dep_intros; repeat (match reverse goal with - | id: (?X1 _ _) |- _ => - $t_is_conj; elim id; do 2 intro; clear id - | id: (?X1 _ _) |- _ => $t_is_disj; elim id; intro; clear id + | id: ?X1 |- _ => $t_is_conj; elim id; do 2 intro; clear id + | id: (Coq.Init.Logic.iff _ _) |- _ => elim id; do 2 intro; clear id + | id: ?X1 |- _ => $t_is_disj; elim id; intro; clear id | id0: ?X1-> ?X2, id1: ?X1|- _ => (* generalize (id0 id1); intro; clear id0 does not work (see Marco Maggiesi's bug PR#301) so we instead use Assert and exact. *) assert X2; [exact (id0 id1) | clear id0] | id: ?X1 -> ?X2|- _ => - $t_is_unit; cut X2; + $t_is_unit_or_eq; cut X2; [ intro; clear id | (* id : ?X1 -> ?X2 |- ?X2 *) cut X1; [exact id| constructor 1; fail] ] - | id: (?X1 ?X2 ?X3) -> ?X4|- _ => - $t_is_conj; cut (X2-> X3-> X4); - [ intro; clear id - | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X2 -> ?X3 -> ?X4 *) - intro; intro; cut (X1 X2 X3); [exact id| split; assumption] - ] - | id: (?X1 ?X2 ?X3) -> ?X4|- _ => - $t_is_disj; - cut (X3-> X4); - [cut (X2-> X4); - [intro; intro; clear id - | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X2 -> ?X4 *) - intro; cut (X1 X2 X3); [exact id| left; assumption] - ] - | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X3 -> ?X4 *) - intro; cut (X1 X2 X3); [exact id| right; assumption] - ] - | |- (?X1 _ _) => $t_is_conj; split + | id: ?X1 -> ?X2|- _ => + $t_flatten_contravariant_conj + (* moved from "id:(?A/\?B)->?X2|-" to "?A->?B->?X2|-" *) + | id: (Coq.Init.Logic.iff ?X1 ?X2) -> ?X3|- _ => + assert ((X1 -> X2) -> (X2 -> X1) -> X3) + by (do 2 intro; apply id; split; assumption); + clear id + | id: ?X1 -> ?X2|- _ => + $t_flatten_contravariant_disj + (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2|-" and "?B->?X2|-" *) + | |- ?X1 => $t_is_conj; split + | |- (Coq.Init.Logic.iff _ _) => split end; $t_not_dep_intros) >> @@ -153,7 +223,7 @@ let rec tauto_intuit t_reduce solver ist = [ exact id | generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id; solve [ $t_tauto_intuit ]]] - | |- (?X1 _ _) => + | |- ?X1 => $t_is_disj; solve [left;$t_tauto_intuit | right;$t_tauto_intuit] end || @@ -164,13 +234,9 @@ let rec tauto_intuit t_reduce solver ist = || $t_solver ) >> - + let reduction_not_iff _ist = - <:tactic progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff - | H:_ |- _ => progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in H - end >> + <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >> let t_reduction_not_iff = tacticIn reduction_not_iff -- cgit v1.2.3