diff options
86 files changed, 1605 insertions, 1938 deletions
@@ -214,6 +214,7 @@ Tactic Language - A bound variable whose name is not used elsewhere now serves as metavariable in "match" and it gets instantiated by an identifier (allow e.g. to extract the name of a statement like "exists x, P x"). +- New printing of Ltac call trace for better debugging. Tactics @@ -259,6 +260,9 @@ Tactics * "rewrite 3?A" means rewriting A at most three times. * "rewrite ?A" means rewriting A as long as possible (possibly never). * many of the above extensions can be combined with each other. +- Introduction patterns better respect the structure of context in presence of + missing or extra names in nested disjunction-conjunction patterns [possible + source of rare incompatibilities]. - New syntax "rename a into b, c into d" for "rename a into b; rename c into d" - New tactics "dependent induction/destruction H [ generalizing id_1 .. id_n ]" to do induction-inversion on instantiated inductive families à la BasicElim. @@ -270,6 +274,7 @@ Tactics - Tactic "apply" now able to traverse conjunctions and to select the first matching lemma among the components of the conjunction; tactic apply also able to apply lemmas of conclusion an empty type. +- Tactic "apply" now supports application of several lemmas in a row. - Tactics "set" and "pose" can set functions using notation "(f x1..xn := c)". - New tactic "instantiate" (without argument). - Tactic firstorder "with" and "using" options have their meaning swapped for @@ -288,6 +293,7 @@ Tactics now obsolete. - Tactics f_equal is now done in ML instead of Ltac: it now works on any equality of functions, regardless of the arity of the function. +- New options "before id", "at top", "at bottom" for tactics "move"/"intro". - Some more debug of reflexive omega (romega), and internal clarifications. Moreover, romega now has a variant "romega with *" that can be also used on non-Z goals (nat, N, positive) via a call to a translation tactic named @@ -295,6 +301,8 @@ Tactics independantly of romega. - Tactic "remember" now supports an "in" clause to remember only selected occurrences of a term. +- Tactic "pose proof" supports name overwriting in case of specialization of an + hypothesis. Program @@ -180,7 +180,6 @@ archclean: clean-ide cleantheories rm -f bin/parser.opt$(EXE) bin/coq-interface.opt$(EXE) find . -name '*.cmx' -or -name '*.cmxa' -or -name '*.[soa]' | xargs rm -f rm -f $(TOOLS) - rm -f $(MINICOQ) clean-ide: rm -f $(COQIDECMO) $(COQIDECMX) $(COQIDECMO:.cmo=.cmi) $(COQIDEBYTE) $(COQIDEOPT) $(COQIDE) diff --git a/Makefile.build b/Makefile.build index 206c62c7b..7c2087634 100644 --- a/Makefile.build +++ b/Makefile.build @@ -606,14 +606,6 @@ $(COQDOC): $(COQDOCCMO) $(HIDE)$(OCAMLC) $(BYTEFLAGS) -custom -o $@ str.cma unix.cma $(COQDOCCMO) ########################################################################### -# minicoq -########################################################################### - -$(MINICOQ): $(MINICOQCMO) - $(SHOW)'OCAMLC -o $@' - $(HIDE)$(OCAMLC) $(BYTEFLAGS) -custom -o $@ $(CMA) $(MINICOQCMO) $(OSDEPLIBS) - -########################################################################### # Installation ########################################################################### diff --git a/Makefile.common b/Makefile.common index ef909f615..af380dd63 100644 --- a/Makefile.common +++ b/Makefile.common @@ -46,8 +46,6 @@ COQBINARIES:= $(COQMKTOP) $(COQC) \ endif OTHERBINARIES:=$(COQMKTOPBYTE) $(COQCBYTE) -MINICOQ:=bin/minicoq$(EXE) - CSDPCERT:=bin/csdpcert$(EXE) ########################################################################### @@ -123,8 +121,8 @@ CONFIG:=\ config/coq_config.cmo LIBREP:=\ - lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/util.cmo lib/bigint.cmo \ - lib/hashcons.cmo lib/dyn.cmo lib/system.cmo lib/flags.cmo \ + lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/flags.cmo \ + lib/util.cmo lib/bigint.cmo lib/hashcons.cmo lib/dyn.cmo lib/system.cmo \ lib/bstack.cmo lib/edit.cmo lib/gset.cmo lib/gmap.cmo \ lib/tlm.cmo lib/gmapl.cmo lib/profile.cmo lib/explore.cmo \ lib/predicate.cmo lib/rtree.cmo lib/heap.cmo lib/option.cmo @@ -411,8 +409,8 @@ COQDOCCMO:=$(CONFIG) tools/coqdoc/cdglobals.cmo tools/coqdoc/alpha.cmo \ MCHECKER:=\ config/coq_config.cmo \ lib/pp_control.cmo lib/pp.cmo lib/compat.cmo \ - lib/util.cmo lib/option.cmo lib/hashcons.cmo \ - lib/system.cmo lib/flags.cmo \ + lib/flags.cmo lib/util.cmo lib/option.cmo lib/hashcons.cmo \ + lib/system.cmo \ lib/predicate.cmo lib/rtree.cmo \ kernel/names.cmo kernel/univ.cmo \ kernel/esubst.cmo checker/term.cmo \ @@ -426,17 +424,11 @@ MCHECKER:=\ checker/safe_typing.cmo checker/check.cmo \ checker/check_stat.cmo checker/checker.cmo -# minicoq - -MINICOQCMO:=$(CONFIG) $(LIBREP) $(KERNEL) \ - parsing/lexer.cmo parsing/g_minicoq.cmo \ - toplevel/fhimsg.cmo toplevel/minicoq.cmo - # grammar modules with camlp4 GRAMMARNEEDEDCMO:=\ - lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/util.cmo lib/bigint.cmo \ - lib/dyn.cmo lib/flags.cmo lib/hashcons.cmo lib/predicate.cmo \ + lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/flags.cmo \ + lib/util.cmo lib/bigint.cmo lib/dyn.cmo lib/hashcons.cmo lib/predicate.cmo \ lib/rtree.cmo lib/option.cmo \ kernel/names.cmo kernel/univ.cmo \ kernel/esubst.cmo kernel/term.cmo kernel/mod_subst.cmo kernel/sign.cmo \ @@ -511,9 +503,9 @@ PRINTERSCMO:=\ parsing/lexer.cmo interp/ppextend.cmo interp/genarg.cmo \ interp/topconstr.cmo interp/notation.cmo interp/dumpglob.cmo interp/reserve.cmo \ library/impargs.cmo interp/constrextern.cmo \ - interp/syntax_def.cmo interp/implicit_quantifiers.cmo interp/constrintern.cmo \ - proofs/proof_trees.cmo proofs/logic.cmo proofs/refiner.cmo \ - proofs/tacexpr.cmo \ + interp/syntax_def.cmo interp/implicit_quantifiers.cmo \ + interp/constrintern.cmo proofs/proof_trees.cmo proofs/tacexpr.cmo \ + proofs/proof_type.cmo proofs/logic.cmo proofs/refiner.cmo \ proofs/evar_refiner.cmo proofs/pfedit.cmo proofs/tactic_debug.cmo \ proofs/decl_mode.cmo \ parsing/ppconstr.cmo parsing/extend.cmo parsing/pcoq.cmo \ @@ -871,7 +863,7 @@ STAGE2_TARGETS:=$(COQBINARIES) lib kernel byterun library proofs tactics \ interp parsing pretyping highparsing toplevel hightactics \ coqide-binaries coqide-byte coqide-opt $(COQIDEOPT) $(COQIDEBYTE) $(COQIDE) \ pcoq-binaries $(COQINTERFACE) $(CSDPCERT) coqbinaries pcoq $(TOOLS) tools \ - printers $(MINICOQ) debug + printers debug VO_TARGETS:=logic arith bool narith zarith qarith lists strings sets \ fsets allfsets relations wellfounded ints reals allreals \ setoids sorting natural integer rational numbers noreal \ diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml index d7bcde69c..bd335d304 100644 --- a/contrib/funind/functional_principles_proofs.ml +++ b/contrib/funind/functional_principles_proofs.ml @@ -136,7 +136,7 @@ let change_hyp_with_using msg hyp_id t tac : tactic = fun g -> let prov_id = pf_get_new_id hyp_id g in tclTHENS - ((* observe_tac msg *) (forward (Some (tclCOMPLETE tac)) (Genarg.IntroIdentifier prov_id) t)) + ((* observe_tac msg *) (forward (Some (tclCOMPLETE tac)) (dummy_loc,Genarg.IntroIdentifier prov_id) t)) [tclTHENLIST [ (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); @@ -388,7 +388,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = in (* observe_tac "rec hyp " *) (tclTHENS - (assert_as true (Genarg.IntroIdentifier rec_pte_id) t_x) + (assert_as true (dummy_loc, Genarg.IntroIdentifier rec_pte_id) t_x) [ (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); (* observe_tac "prove rec hyp" *) @@ -571,7 +571,7 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id fun g -> let prov_hid = pf_get_new_id hid g in tclTHENLIST[ - forward None (Genarg.IntroIdentifier prov_hid) (mkApp(mkVar hid,args)); + forward None (dummy_loc,Genarg.IntroIdentifier prov_hid) (mkApp(mkVar hid,args)); thin [hid]; h_rename [prov_hid,hid] ] g @@ -1497,7 +1497,7 @@ let prove_principle_for_gen (tclTHEN (forward (Some ((fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g))) - (Genarg.IntroIdentifier wf_thm_id) + (dummy_loc,Genarg.IntroIdentifier wf_thm_id) (mkApp (delayed_force well_founded,[|input_type;relation|]))) ( (* observe_tac *) @@ -1561,7 +1561,7 @@ let prove_principle_for_gen ); (* observe_tac "" *) (forward (Some (prove_rec_arg_acc)) - (Genarg.IntroIdentifier acc_rec_arg_id) + (dummy_loc,Genarg.IntroIdentifier acc_rec_arg_id) (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) ); (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); diff --git a/contrib/funind/g_indfun.ml4 b/contrib/funind/g_indfun.ml4 index dae76f2dd..d435f5135 100644 --- a/contrib/funind/g_indfun.ml4 +++ b/contrib/funind/g_indfun.ml4 @@ -90,11 +90,6 @@ END TACTIC EXTEND newfunind ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> [ - let pat = - match pat with - | None -> IntroAnonymous - | Some pat -> pat - in let c = match cl with | [] -> assert false | [c] -> c @@ -106,11 +101,6 @@ END TACTIC EXTEND snewfunind ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> [ - let pat = - match pat with - | None -> IntroAnonymous - | Some pat -> pat - in let c = match cl with | [] -> assert false | [c] -> c @@ -319,7 +309,7 @@ let poseq_unsafe idunsafe cstr gl = tclTHEN (Tactics.letin_tac None (Name idunsafe) cstr allClauses) (tclTHENFIRST - (Tactics.assert_as true IntroAnonymous (mkEq typ (mkVar idunsafe) cstr)) + (Tactics.assert_as true (Util.dummy_loc,IntroAnonymous) (mkEq typ (mkVar idunsafe) cstr)) Tactics.reflexivity) gl @@ -396,7 +386,7 @@ let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info l fun gl -> (functional_induction true (applist (info.fname, List.rev !list_constr_largs)) - None IntroAnonymous) gl)) + None None) gl)) nexttac)) ordered_info_list in (* we try each (f t u v) until one does not fail *) (* TODO: try also to mix functional schemes *) diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml index a6cbb3211..79ef00972 100644 --- a/contrib/funind/indfun.ml +++ b/contrib/funind/indfun.ml @@ -120,7 +120,7 @@ let functional_induction with_clean c princl pat = princ_infos args_as_induction_constr princ' - pat + (None,pat) None) subst_and_reduce g diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml index 63d44916b..f62d70ab9 100644 --- a/contrib/funind/invfun.ml +++ b/contrib/funind/invfun.ml @@ -280,13 +280,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.map (fun (_,_,br_type) -> List.map - (fun id -> Genarg.IntroIdentifier id) + (fun id -> dummy_loc, Genarg.IntroIdentifier id) (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) ) branches in (* before building the full intro pattern for the principle *) - let pat = Genarg.IntroOrAndPattern intro_pats in + let pat = Some (dummy_loc,Genarg.IntroOrAndPattern intro_pats) in let eq_ind = Coqlib.build_coq_eq () in let eq_construct = mkConstruct((destInd eq_ind),1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) @@ -297,7 +297,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (* We get the identifiers of this branch *) let this_branche_ids = List.fold_right - (fun pat acc -> + (fun (_,pat) acc -> match pat with | Genarg.IntroIdentifier id -> Idset.add id acc | _ -> anomaly "Not an identifier" @@ -447,7 +447,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem [ observe_tac "intro args_names" (tclMAP h_intro args_names); observe_tac "principle" (forward (Some (h_exact f_principle)) - (Genarg.IntroIdentifier principle_id) + (dummy_loc,Genarg.IntroIdentifier principle_id) princ_type); tclTHEN_i (observe_tac "functional_induction" ( @@ -948,7 +948,7 @@ let functional_inversion kn hid fconst f_correct : tactic = h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; thin [hid]; h_intro hid; - Inv.inv FullInversion Genarg.IntroAnonymous (Rawterm.NamedHyp hid); + Inv.inv FullInversion None (Rawterm.NamedHyp hid); (fun g -> let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in tclMAP (revert_graph kn pre_tac) (hid::new_ids) g diff --git a/contrib/funind/recdef.ml b/contrib/funind/recdef.ml index 13989f03b..6227f92d7 100644 --- a/contrib/funind/recdef.ml +++ b/contrib/funind/recdef.ml @@ -1157,7 +1157,7 @@ let rec introduce_all_values_eq cont_tac functional termine [] -> let heq2 = next_global_ident_away true heq_id ids in tclTHENLIST - [forward None (IntroIdentifier heq2) + [forward None (dummy_loc,IntroIdentifier heq2) (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|])); simpl_iter (onHyp heq2); unfold_in_hyp [((true,[1]), evaluable_of_global_reference diff --git a/contrib/interface/depends.ml b/contrib/interface/depends.ml index dd40c5cc3..bf1cf5e7b 100644 --- a/contrib/interface/depends.ml +++ b/contrib/interface/depends.ml @@ -57,8 +57,7 @@ let explore_tree pfs = and explain_prim = function | Refine c -> "Refine " ^ (string_of_ppcmds (Printer.prterm c)) | Intro identifier -> "Intro" - | Intro_replacing identifier -> "Intro_replacing" - | Cut (bool, identifier, types) -> "Cut" + | Cut (bool, _, identifier, types) -> "Cut" | FixRule (identifier, int, l) -> "FixRule" | Cofix (identifier, l) -> "Cofix" | Convert_concl (types, cast_kind) -> "Convert_concl" @@ -281,7 +280,8 @@ let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of | TacExact c | TacExactNoCheck c | TacVmCastNoCheck c -> depends_of_'constr c acc - | TacApply (_, _, cb) -> depends_of_'constr_with_bindings cb acc + | TacApply (_, _, [cb]) -> depends_of_'constr_with_bindings cb acc + | TacApply (_, _, _) -> failwith "TODO" | TacElim (_, cwb, cwbo) -> depends_of_'constr_with_bindings cwb (Option.fold_right depends_of_'constr_with_bindings cwbo acc) @@ -302,14 +302,13 @@ let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of | TacLetTac (_,c,_,_) -> depends_of_'constr c acc (* Derived basic tactics *) - | TacSimpleInduction _ - | TacSimpleDestruct _ + | TacSimpleInductionDestruct _ | TacDoubleInduction _ -> acc - | TacNewInduction (_, cwbial, cwbo, _, _) - | TacNewDestruct (_, cwbial, cwbo, _, _) -> + | TacInductionDestruct (_, _, [cwbial, cwbo, _, _]) -> list_union_map (depends_of_'a_induction_arg depends_of_'constr_with_bindings) cwbial (Option.fold_right depends_of_'constr_with_bindings cwbo acc) + | TacInductionDestruct (_, _, _) -> failwith "TODO" | TacDecomposeAnd c | TacDecomposeOr c -> depends_of_'constr c acc | TacDecompose (il, c) -> depends_of_'constr c (list_union_map depends_of_'ind il acc) @@ -410,8 +409,7 @@ let depends_of_compound_rule cr acc = match cr with and depends_of_prim_rule pr acc = match pr with | Refine c -> depends_of_constr c acc | Intro id -> acc - | Intro_replacing id -> acc - | Cut (_, _, t) -> depends_of_constr t acc (* TODO: check what 2nd argument contains *) + | Cut (_, _, _, t) -> depends_of_constr t acc (* TODO: check what 3nd argument contains *) | FixRule (_, _, l) -> list_union_map (o depends_of_constr trd_of_3) l acc (* TODO: check what the arguments contain *) | Cofix (_, l) -> list_union_map (o depends_of_constr snd) l acc (* TODO: check what the arguments contain *) | Convert_concl (t, _) -> depends_of_constr t acc diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml index 06b957d9c..65eadf13d 100644 --- a/contrib/interface/pbp.ml +++ b/contrib/interface/pbp.ml @@ -48,7 +48,7 @@ type pbp_atom = | PbpTryClear of identifier list | PbpGeneralize of identifier * identifier list | PbpLApply of identifier (* = CutAndApply *) - | PbpIntros of intro_pattern_expr list + | PbpIntros of intro_pattern_expr located list | PbpSplit (* Existential *) | PbpExists of identifier @@ -93,7 +93,7 @@ type pbp_rule = (identifier list * pbp_sequence option;; -let make_named_intro id = PbpIntros [IntroIdentifier id];; +let make_named_intro id = PbpIntros [zz,IntroIdentifier id];; let make_clears str_list = PbpThen [PbpTryClear str_list] @@ -171,7 +171,7 @@ let make_pbp_atomic_tactic = function | PbpRight -> TacAtom (zz, TacRight (false,NoBindings)) | PbpIntros l -> TacAtom (zz, TacIntroPattern l) | PbpLApply h -> TacAtom (zz, TacLApply (make_var h)) - | PbpApply h -> TacAtom (zz, TacApply (true,false,(make_var h,NoBindings))) + | PbpApply h -> TacAtom (zz, TacApply (true,false,[make_var h,NoBindings])) | PbpElim (hyp_name, names) -> let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in TacAtom @@ -255,9 +255,9 @@ fun avoid c path -> match kind_of_term c, path with or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in let patt_list = if a = 1 then - [cont_patt; IntroIdentifier id2] + [zz,cont_patt; zz,IntroIdentifier id2] else - [IntroIdentifier id2; cont_patt] in + [zz,IntroIdentifier id2; zz,cont_patt] in (IntroOrAndPattern[patt_list], avoid_names, id, c, path, rank, total_branches) | (App(oper, [|c1; c2|]), 2::3::path) @@ -268,7 +268,7 @@ fun avoid c path -> match kind_of_term c, path with let id1 = next_global_ident x avoid in let cont_patt, avoid_names, id, c, path, rank, total_branches = or_and_tree_to_intro_pattern (id1::avoid) body path in - (IntroOrAndPattern[[IntroIdentifier id1; cont_patt]], + (IntroOrAndPattern[[zz,IntroIdentifier id1; zz,cont_patt]], avoid_names, id, c, path, rank, total_branches) | _ -> assert false) | (App(oper, [|c1; c2|]), 2::a::path) @@ -282,9 +282,9 @@ fun avoid c path -> match kind_of_term c, path with let new_rank = if a = 1 then rank else rank+1 in let patt_list = if a = 1 then - [[cont_patt];[IntroIdentifier id2]] + [[zz,cont_patt];[zz,IntroIdentifier id2]] else - [[IntroIdentifier id2];[cont_patt]] in + [[zz,IntroIdentifier id2];[zz,cont_patt]] in (IntroOrAndPattern patt_list, avoid_names, id, c, path, new_rank, total_branches+1) | (_, path) -> let id = next_global_ident hyp_radix avoid in @@ -305,13 +305,13 @@ let (imply_intro3: pbp_rule) = function let intro_patt, avoid_names, id, c, p, rank, total_branches = or_and_tree_to_intro_pattern avoid prem path in if total_branches = 1 then - Some(chain_tactics [PbpIntros [intro_patt]] + Some(chain_tactics [PbpIntros [zz,intro_patt]] (f avoid_names clear_names clear_flag (Some id) (kind_of_term c) path)) else Some (PbpThens - ([PbpIntros [intro_patt]], + ([PbpIntros [zz,intro_patt]], auxiliary_goals clear_names clear_flag id (rank - 1) ((f avoid_names clear_names clear_flag (Some id) @@ -667,7 +667,7 @@ let rec cleanup_clears str_list = function let rec optim3_aux str_list = function (PbpGeneralize (h,l1)):: - (PbpIntros [IntroIdentifier s])::(PbpGeneralize (h',l2))::others + (PbpIntros [zz,IntroIdentifier s])::(PbpGeneralize (h',l2))::others when s=h' -> optim3_aux (s::str_list) (PbpGeneralize (h,l1@l2)::others) | (PbpTryClear names)::other -> diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml index 953fb5e79..4b9c1332a 100644 --- a/contrib/interface/showproof.ml +++ b/contrib/interface/showproof.ml @@ -1197,12 +1197,12 @@ let rec natural_ntree ig ntree = | TacAssumption -> natural_trivial ig lh g gs ltree | TacClear _ -> natural_clear ig lh g gs ltree (* Besoin de l'argument de la tactique *) - | TacSimpleInduction (NamedHyp id) -> + | TacSimpleInductionDestruct (true,NamedHyp id) -> natural_induction ig lh g gs ge id ltree false | TacExtend (_,"InductionIntro",[a]) -> let id=(out_gen wit_ident a) in natural_induction ig lh g gs ge id ltree true - | TacApply (_,false,(c,_)) -> natural_apply ig lh g gs (snd c) ltree + | TacApply (_,false,[c,_]) -> natural_apply ig lh g gs (snd c) ltree | TacExact c -> natural_exact ig lh g gs (snd c) ltree | TacCut c -> natural_cut ig lh g gs (snd c) ltree | TacExtend (_,"CutIntro",[a]) -> diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index 2e4ff80bb..716f6da3b 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -615,8 +615,7 @@ let get_flag r = (* Rem: EVAR flag obsolète *) conv_flags, red_ids -let rec xlate_intro_pattern = - function +let rec xlate_intro_pattern (loc,pat) = match pat with | IntroOrAndPattern [] -> assert false | IntroOrAndPattern (fp::ll) -> CT_disj_pattern @@ -625,7 +624,7 @@ let rec xlate_intro_pattern = (fun l -> CT_intro_patt_list(List.map xlate_intro_pattern l)) ll) - | IntroWildcard _ -> CT_coerce_ID_to_INTRO_PATT(CT_ident "_" ) + | IntroWildcard -> CT_coerce_ID_to_INTRO_PATT(CT_ident "_" ) | IntroIdentifier c -> CT_coerce_ID_to_INTRO_PATT(xlate_ident c) | IntroAnonymous -> xlate_error "TODO: IntroAnonymous" | IntroFresh _ -> xlate_error "TODO: IntroFresh" @@ -686,8 +685,8 @@ let xlate_one_unfold_block = function ;; let xlate_with_names = function - IntroAnonymous -> CT_coerce_ID_OPT_to_INTRO_PATT_OPT ctv_ID_OPT_NONE - | fp -> CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT (xlate_intro_pattern fp) + None -> CT_coerce_ID_OPT_to_INTRO_PATT_OPT ctv_ID_OPT_NONE + | Some fp -> CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT (xlate_intro_pattern fp) let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level @@ -972,19 +971,22 @@ and xlate_tac = CT_intros_until (CT_coerce_ID_to_ID_OR_INT (xlate_ident id)) | TacIntrosUntil (AnonHyp n) -> CT_intros_until (CT_coerce_INT_to_ID_OR_INT (CT_int n)) - | TacIntroMove (Some id1, Some (_,id2)) -> - CT_intro_after(CT_coerce_ID_to_ID_OPT (xlate_ident id1),xlate_ident id2) - | TacIntroMove (None, Some (_,id2)) -> - CT_intro_after(CT_coerce_NONE_to_ID_OPT CT_none, xlate_ident id2) - | TacMove (true, id1, id2) -> + | TacIntroMove (Some id1, MoveAfter id2) -> + CT_intro_after(CT_coerce_ID_to_ID_OPT (xlate_ident id1),xlate_hyp id2) + | TacIntroMove (None, MoveAfter id2) -> + CT_intro_after(CT_coerce_NONE_to_ID_OPT CT_none, xlate_hyp id2) + | TacMove (true, id1, MoveAfter id2) -> CT_move_after(xlate_hyp id1, xlate_hyp id2) | TacMove (false, id1, id2) -> xlate_error "Non dep Move is only internal" + | TacMove _ -> xlate_error "TODO: move before, at top, at bottom" | TacIntroPattern patt_list -> CT_intros (CT_intro_patt_list (List.map xlate_intro_pattern patt_list)) - | TacIntroMove (Some id, None) -> + | TacIntroMove (Some id, MoveToEnd true) -> CT_intros (CT_intro_patt_list[CT_coerce_ID_to_INTRO_PATT(xlate_ident id)]) - | TacIntroMove (None, None) -> CT_intro (CT_coerce_NONE_to_ID_OPT CT_none) + | TacIntroMove (None, MoveToEnd true) -> + CT_intro (CT_coerce_NONE_to_ID_OPT CT_none) + | TacIntroMove _ -> xlate_error "TODO" | TacLeft (false,bindl) -> CT_left (xlate_bindings bindl) | TacRight (false,bindl) -> CT_right (xlate_bindings bindl) | TacSplit (false,false,bindl) -> CT_split (xlate_bindings bindl) @@ -1155,11 +1157,12 @@ and xlate_tac = xlate_error "TODO: trivial using" | TacReduce (red, l) -> CT_reduce (xlate_red_tactic red, xlate_clause l) - | TacApply (true,false,(c,bindl)) -> + | TacApply (true,false,[c,bindl]) -> CT_apply (xlate_formula c, xlate_bindings bindl) - | TacApply (true,true,(c,bindl)) -> + | TacApply (true,true,[c,bindl]) -> CT_eapply (xlate_formula c, xlate_bindings bindl) - | TacApply (false,_,_) -> xlate_error "TODO: simple (e)apply" + | TacApply (_,_,_) -> + xlate_error "TODO: simple (e)apply and iterated apply" | TacConstructor (false,n_or_meta, bindl) -> let n = match n_or_meta with AI n -> n | MetaId _ -> xlate_error "" in CT_constructor (CT_int n, xlate_bindings bindl) @@ -1183,10 +1186,12 @@ and xlate_tac = | TacCase (false,(c1,sl)) -> CT_casetac (xlate_formula c1, xlate_bindings sl) | TacElim (true,_,_) | TacCase (true,_) - | TacNewDestruct (true,_,_,_,_) | TacNewInduction (true,_,_,_,_) -> + | TacInductionDestruct (_,true,_) -> xlate_error "TODO: eelim, ecase, edestruct, einduction" - | TacSimpleInduction h -> CT_induction (xlate_quantified_hypothesis h) - | TacSimpleDestruct h -> CT_destruct (xlate_quantified_hypothesis h) + | TacSimpleInductionDestruct (true,h) -> + CT_induction (xlate_quantified_hypothesis h) + | TacSimpleInductionDestruct (false,h) -> + CT_destruct (xlate_quantified_hypothesis h) | TacCut c -> CT_cut (xlate_formula c) | TacLApply c -> CT_use (xlate_formula c) | TacDecompose ([],c) -> @@ -1227,19 +1232,16 @@ and xlate_tac = CT_dauto(xlate_int_or_var_opt_to_int_opt a, xlate_int_opt b) | TacDAuto (a, b, _) -> xlate_error "TODO: dauto using" - | TacNewDestruct(false,a,b,c,None) -> + | TacInductionDestruct(true,false,[a,b,(None,c),None]) -> CT_new_destruct (List.map xlate_int_or_constr a, xlate_using b, xlate_with_names c) - | TacNewInduction(false,a,b,c,None) -> + | TacInductionDestruct(false,false,[a,b,(None,c),None]) -> CT_new_induction (List.map xlate_int_or_constr a, xlate_using b, xlate_with_names c) - | TacNewDestruct(false,a,b,c,_) -> xlate_error "TODO: destruct in" - | TacNewInduction(false,a,b,c,_) ->xlate_error "TODO: induction in" - (*| TacInstantiate (a, b, cl) -> - CT_instantiate(CT_int a, xlate_formula b, - assert false) *) + | TacInductionDestruct(_,false,_) -> + xlate_error "TODO: clause 'in' and full 'as' of destruct/induction" | TacLetTac (na, c, cl, true) when cl = nowhere -> CT_pose(xlate_id_opt_aux na, xlate_formula c) | TacLetTac (na, c, cl, true) -> @@ -1248,13 +1250,13 @@ and xlate_tac = but the structures are different *) xlate_clause cl) | TacLetTac (na, c, cl, false) -> xlate_error "TODO: remember" - | TacAssert (None, IntroIdentifier id, c) -> + | TacAssert (None, (_,IntroIdentifier id), c) -> CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (None, IntroAnonymous, c) -> + | TacAssert (None, (_,IntroAnonymous), c) -> CT_assert(xlate_id_opt ((0,0),Anonymous), xlate_formula c) - | TacAssert (Some (TacId []), IntroIdentifier id, c) -> + | TacAssert (Some (TacId []), (_,IntroIdentifier id), c) -> CT_truecut(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (Some (TacId []), IntroAnonymous, c) -> + | TacAssert (Some (TacId []), (_,IntroAnonymous), c) -> CT_truecut(xlate_id_opt ((0,0),Anonymous), xlate_formula c) | TacAssert _ -> xlate_error "TODO: assert with 'as' and 'by' and pose proof with 'as'" diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml index c36c6458d..baf565ab1 100644 --- a/contrib/subtac/subtac.ml +++ b/contrib/subtac/subtac.ml @@ -231,7 +231,8 @@ let subtac (loc, command) = debug 2 (Himsg.explain_pretype_error env exn); raise e - | (Stdpp.Exc_located (loc, e')) as e -> + | (Stdpp.Exc_located (loc, Proof_type.LtacLocated (_,e')) | + Stdpp.Exc_located (loc, e') as e) -> debug 2 (str "Parsing exception: "); (match e' with | Type_errors.TypeError (env, exn) -> diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml index 4e824921b..a393e2c9b 100644 --- a/contrib/subtac/subtac_obligations.ml +++ b/contrib/subtac/subtac_obligations.ml @@ -442,6 +442,7 @@ and solve_obligation_by_tac prg obls i tac = true else false with + | Stdpp.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s))) | Stdpp.Exc_located(_, Refiner.FailError (_, s)) | Refiner.FailError (_, s) -> user_err_loc (obl.obl_location, "solve_obligation", s) diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4 index 9afd07a61..05be01bc6 100644 --- a/contrib/xml/proofTree2Xml.ml4 +++ b/contrib/xml/proofTree2Xml.ml4 @@ -82,8 +82,7 @@ let first_word s = let string_of_prim_rule x = match x with | Proof_type.Intro _-> "Intro" - | Proof_type.Intro_replacing _-> "Intro_replacing" - | Proof_type.Cut (_,_,_) -> "Cut" + | Proof_type.Cut _ -> "Cut" | Proof_type.FixRule (_,_,_) -> "FixRule" | Proof_type.Cofix (_,_)-> "Cofix" | Proof_type.Refine _ -> "Refine" diff --git a/dev/doc/style.txt b/dev/doc/style.txt index 2e597dc45..a8924ba65 100644 --- a/dev/doc/style.txt +++ b/dev/doc/style.txt @@ -20,6 +20,32 @@ match expr with | A -> ... | B x -> ... +Remarque : à partir de la 8.2 environ, la tendance est à utiliser le +format suivant qui permet de limiter l'escalade d'indentation tout en +produisant un aspect visuel intéressant de bloc : + +type t = +| A +| B of machin + +match expr with +| A -> ... +| B x -> ... + +let f expr = match expr with +| A -> ... +| B x -> ... + +let f expr = function +| A -> ... +| B x -> ... + +Le deuxième cas est obtenu sous tuareg avec les réglages + + (setq tuareg-with-indent 0) + (setq tuareg-function-indent 0) + (setq tuareg-let-always-indent nil) /// notons que cette dernière est bien + /// pour les let mais pas pour les let-in Conditionnelles =============== diff --git a/doc/common/macros.tex b/doc/common/macros.tex index b464a9622..ef632371d 100755 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -190,6 +190,8 @@ \newcommand{\pattern}{\textrm{\textsl{pattern}}} \newcommand{\orpattern}{\textrm{\textsl{or\_pattern}}} \newcommand{\intropattern}{\textrm{\textsl{intro\_pattern}}} +\newcommand{\disjconjintropattern}{\textrm{\textsl{disj\_conj\_intro\_pattern}}} +\newcommand{\namingintropattern}{\textrm{\textsl{naming\_intro\_pattern}}} \newcommand{\pat}{\textrm{\textsl{pat}}} \newcommand{\pgs}{\textrm{\textsl{pgms}}} \newcommand{\pg}{\textrm{\textsl{pgm}}} diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 9f6fa8be1..54237d721 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -174,7 +174,8 @@ usable in the proof development. \end{ErrMsgs} \subsection{\tt move {\ident$_1$} after {\ident$_2$} -\tacindex{move}} +\tacindex{move} +\label{move}} This moves the hypothesis named {\ident$_1$} in the local context after the hypothesis named {\ident$_2$}. @@ -187,6 +188,32 @@ If {\ident$_1$} comes after {\ident$_2$} in the order of dependences, then all hypotheses between {\ident$_1$} and {\ident$_2$} which (possibly indirectly) occur in {\ident$_1$} are moved also. +\begin{Variants} + +\item {\tt move {\ident$_1$} before {\ident$_2$}} + +This moves {\ident$_1$} towards and just before the hypothesis named {\ident$_2$}. + +\item {\tt move {\ident} at top} + +This moves {\ident} at the top of the local context (at the beginning of the context). + +\item {\tt move {\ident} at bottom} + +This moves {\ident} at the bottom of the local context (at the end of the context). + +\item {\tt move dependent {\ident$_1$} after {\ident$_2$}}\\ + {\tt move dependent {\ident$_1$} before {\ident$_2$}}\\ + {\tt move dependent {\ident$_1$} at top}\\ + {\tt move dependent {\ident$_1$} at bottom} + +This moves {\ident$_1$} towards the specified place. All the +hypotheses that recursively depend on, for a downwards move, or +in, for an upwards move, the hypothesis {\ident$_1$} are moved +too so as to respect the order of dependencies between hypotheses. + +\end{Variants} + \begin{ErrMsgs} \item \errindex{{\ident$_i$} not found} @@ -316,22 +343,32 @@ the tactic {\tt intro} applies the tactic {\tt red} until the tactic Happens when {\num} is 0 or is greater than the number of non-dependent products of the goal. -\item {\tt intro after \ident} \tacindex{intro after} +\item {\tt intro after \ident} \tacindex{intro after}\\ + {\tt intro before \ident} \tacindex{intro before}\\ + {\tt intro at top} \tacindex{intro at top}\\ + {\tt intro at bottom} \tacindex{intro at bottom} - Applies {\tt intro} but puts the introduced - hypothesis after the hypothesis \ident{} in the hypotheses. + Applies {\tt intro} and moves the freshly introduced hypothesis + respectively after the hypothesis \ident{}, before the hypothesis + \ident{}, at the top of the local context, or at the bottom of the + local context. All hypotheses on which the new hypothesis depends + are moved too so as to respect the order of dependencies between + hypotheses. Note that {\tt intro as bottom} is is a synonym for {\tt + intro} with no argument. \begin{ErrMsgs} \item \errindex{No product even after head-reduction} \item \errindex{No such hypothesis} : {\ident} \end{ErrMsgs} -\item {\tt intro \ident$_1$ after \ident$_2$} - \tacindex{intro ... after} +\item {\tt intro \ident$_1$ after \ident$_2$}\\ + {\tt intro \ident$_1$ before \ident$_2$}\\ + {\tt intro \ident$_1$ at top}\\ + {\tt intro \ident$_1$ at bottom} - Behaves as previously but \ident$_1$ is the name of the introduced - hypothesis. It is equivalent to {\tt intro \ident$_1$; move - \ident$_1$ after \ident$_2$}. + Behaves as previously but naming the introduced hypothesis + \ident$_1$. It is equivalent to {\tt intro \ident$_1$} followed by + the appropriate call to {\tt move}~(see Section~\ref{move}). \begin{ErrMsgs} \item \errindex{No product even after head-reduction} @@ -404,6 +441,14 @@ Section~\ref{pattern} to transform the goal so that it gets the form premises. Here, variables are referred by names and non-dependent products by increasing numbers (see syntax in Section~\ref{Binding-list}). +\item {\tt apply} {\term$_1$} {\tt ,} \ldots {\tt ,} {\term$_n$} + + This is a shortcut for {\tt apply} {\term$_1$} {\tt ; [ ..~|} + \ldots~{\tt ; [ ..~| {\tt apply} {\term$_n$} ]} \ldots~{\tt ]}, i.e. for the + successive applications of {\term$_{i+1}$} on the last subgoal + generated by {\tt apply} {\term$_i$}, starting from the application + of {\term$_1$}. + \item {\tt eapply \term}\tacindex{eapply}\label{eapply} The tactic {\tt eapply} behaves as {\tt apply} but does not fail @@ -417,6 +462,29 @@ Section~\ref{pattern} to transform the goal so that it gets the form An example of use of {\tt eapply} is given in Section~\ref{eapply-example}. +\item {\tt simple apply {\term}} \tacindex{simple apply} + + This behaves like {\tt apply} but it reasons modulo conversion only + on subterms that contain no variables to instantiate. For instance, + if {\tt id := fun x:nat => x} and {\tt H : forall y, id y = y} then + {\tt simple apply H} on goal {\tt O = O} does not succeed because it + would require the conversion of {\tt f ?y} and {\tt O} where {\tt + ?y} is a variable to instantiate. Tactic {\tt simple apply} does not + either traverse tuples as {\tt apply} does. + + Because it reasons modulo a limited amount of conversion, {\tt + simple apply} fails quicker than {\tt apply} and it is then + well-suited for uses in used-defined tactics that backtrack often. + +\item \zeroone{{\tt simple}} {\tt apply} {\term$_1$} \zeroone{{\tt with} + {\bindinglist$_1$}} {\tt ,} \ldots {\tt ,} {\term$_n$} \zeroone{{\tt with} + {\bindinglist$_n$}}\\ + \zeroone{{\tt simple}} {\tt eapply} {\term$_1$} \zeroone{{\tt with} + {\bindinglist$_1$}} {\tt ,} \ldots {\tt ,} {\term$_n$} \zeroone{{\tt with} + {\bindinglist$_n$}} + + This summarizes the difference syntaxes for {\tt apply}. + \item {\tt lapply {\term}} \tacindex{lapply} This tactic applies to any goal, say {\tt G}. The argument {\term} @@ -911,7 +979,7 @@ $\!\!\!$\begin{tabular}{lcl} & | & {\tt *}\\ {\atoccurrences} & ::= & {\tt at} {\occlist}\\ -{\occlist} & ::= & \zeroone{\tt -} {\num$_1$} \dots\ {\num$_n$} +{\occlist} & ::= & \zeroone{{\tt -}} {\num$_1$} \dots\ {\num$_n$} \end{tabular} The role of an occurrence clause is to select a set of occurrences of @@ -1483,24 +1551,35 @@ induction n. \end{ErrMsgs} \begin{Variants} -\item{\tt induction {\term} as {\intropattern}} +\item{\tt induction {\term} as {\disjconjintropattern}} This behaves as {\tt induction {\term}} but uses the names in - {\intropattern} to name the variables introduced in the context. - The {\intropattern} must have the form {\tt [} $p_{11}$ \ldots + {\disjconjintropattern} to name the variables introduced in the context. + The {\disjconjintropattern} must typically be of the form + {\tt [} $p_{11}$ \ldots $p_{1n_1}$ {\tt |} {\ldots} {\tt |} $p_{m1}$ \ldots $p_{mn_m}$ {\tt ]} with $m$ being the number of constructors of the type of {\term}. Each variable introduced by {\tt induction} in the context of the $i^{th}$ goal gets its name from the list $p_{i1}$ \ldots $p_{in_i}$ in order. If there are not enough names, {\tt induction} invents names for the remaining variables to introduce. More - generally, the $p_{ij}$ can be any introduction patterns (see - Section~\ref{intros-pattern}). This provides a concise notation for - nested induction. + generally, the $p_{ij}$ can be any disjunctive/conjunctive + introduction pattern (see Section~\ref{intros-pattern}). For instance, + for an inductive type with one constructor, the pattern notation + {\tt ($p_{1}$,\ldots,$p_{n}$)} can be used instead of + {\tt [} $p_{1}$ \ldots $p_{n}$ {\tt ]}. + +\item{\tt induction {\term} as {\namingintropattern}} + + This behaves as {\tt induction {\term}} but adds an equation between + {\term} and the value that {\term} takes in each of the induction + case. The name of the equation is built according to + {\namingintropattern} which can be an identifier, a ``?'', etc, as + indicated in Section~\ref{intros-pattern}. -\Rem for an inductive type with one constructor, the pattern notation -{\tt ($p_{1}$,\ldots,$p_{n}$)} can be used instead of -{\tt [} $p_{1}$ \ldots $p_{n}$ {\tt ]}. +\item{\tt induction {\term} as {\namingintropattern} {\disjconjintropattern}} + + This combines the two previous forms. \item{\tt induction {\term} with \bindinglist} @@ -1533,11 +1612,6 @@ induction n. with complex predicates as the induction principles generated by {\tt Function} or {\tt Functional Scheme} may be. -\item \texttt{induction {\term} in *} - - This syntax tells to keep an equation between {\term} and the value - it gets in each case of the induction. - \item \texttt{induction {\term} in {\occgoalset}} This syntax is used for selecting which occurrences of {\term} the @@ -1547,12 +1621,13 @@ induction n. When an occurrence clause is given, an equation between {\term} and the value it gets in each case of the induction is added to the - context of the subgoals corresponding to the induction cases. + context of the subgoals corresponding to the induction cases (even + if no clause {\tt as {\namingintropattern}} is given. -\item{\tt induction {\term$_1$} with {\bindinglist$_1$} as {\intropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}}\\ - {\tt einduction {\term$_1$} with {\bindinglist$_1$} as {\intropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}} +\item {\tt induction {\term$_1$} with {\bindinglist$_1$} as {\namingintropattern} {\disjconjintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}}\\ + {\tt einduction {\term$_1$} with {\bindinglist$_1$} as {\namingintropattern} {\disjconjintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}} - This is the most general form of {\tt induction} and {\tt + These are the most general forms of {\tt induction} and {\tt einduction}. It combines the effects of the {\tt with}, {\tt as}, {\tt using}, and {\tt in} clauses. @@ -1598,7 +1673,7 @@ instantiate premises of the type of {\term$_2$}. \item{\tt elim {\term$_1$} with {\bindinglist$_1$} using {\term$_2$} with {\bindinglist$_2$}}\\ {\tt eelim {\term$_1$} with {\bindinglist$_1$} using {\term$_2$} with {\bindinglist$_2$}} - This is the most general form of {\tt elim} and {\tt eelim}. It + These are the most general forms of {\tt elim} and {\tt eelim}. It combines the effects of the {\tt using} clause and of the two uses of the {\tt with} clause. @@ -1663,7 +1738,7 @@ last introduced hypothesis. \end{itemize} \begin{Variants} -\item{\tt destruct {\term} as {\intropattern}} +\item{\tt destruct {\term} as {\disjconjintropattern}} This behaves as {\tt destruct {\term}} but uses the names in {\intropattern} to name the variables introduced in the context. @@ -1674,16 +1749,24 @@ last introduced hypothesis. of the $i^{th}$ goal gets its name from the list $p_{i1}$ \ldots $p_{in_i}$ in order. If there are not enough names, {\tt destruct} invents names for the remaining variables to introduce. More - generally, the $p_{ij}$ can be any introduction patterns (see - Section~\ref{intros-pattern}). This provides a concise notation for - nested destruction. + generally, the $p_{ij}$ can be any disjunctive/conjunctive + introduction pattern (see Section~\ref{intros-pattern}). This + provides a concise notation for nested destruction. % It is recommended to use this variant of {\tt destruct} for % robust proof scripts. -\Rem for an inductive type with one constructor, the pattern notation -{\tt ($p_{1}$,\ldots,$p_{n}$)} can be used instead of -{\tt [} $p_{1} $\ldots $p_{n}$ {\tt ]}. +\item{\tt destruct {\term} as {\namingintropattern}} + + This behaves as {\tt destruct {\term}} but adds an equation between + {\term} and the value that {\term} takes in each of the possible + cases. The name of the equation is built according to + {\namingintropattern} which can be an identifier, a ``?'', etc, as + indicated in Section~\ref{intros-pattern}. + +\item{\tt destruct {\term} as {\namingintropattern} {\disjconjintropattern}} + + This combines the two previous forms. \item{\tt destruct {\term} with \bindinglist} @@ -1709,11 +1792,6 @@ last introduced hypothesis. These are synonyms of {\tt induction {\term$_1$} using {\term$_2$}} and {\tt induction {\term$_1$} using {\term$_2$} with {\bindinglist}}. -\item \texttt{destruct {\term} in *} - - This syntax tells to keep an equation between {\term} and the value - it gets in each cases of the analysis. - \item \texttt{destruct {\term} in {\occgoalset}} This syntax is used for selecting which occurrences of {\term} the @@ -1723,12 +1801,13 @@ last introduced hypothesis. When an occurrence clause is given, an equation between {\term} and the value it gets in each cases of the analysis is added to the - context of the subgoals corresponding to the cases. + context of the subgoals corresponding to the cases (even + if no clause {\tt as {\namingintropattern}} is given. -\item{\tt destruct {\term$_1$} with {\bindinglist$_1$} as {\intropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}}\\ - {\tt edestruct {\term$_1$} with {\bindinglist$_1$} as {\intropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}} +\item{\tt destruct {\term$_1$} with {\bindinglist$_1$} as {\namingintropattern} {\disjconjintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}}\\ + {\tt edestruct {\term$_1$} with {\bindinglist$_1$} as {\namingintropattern} {\disjconjintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}} - This is the most general form of {\tt destruct} and {\tt edestruct}. + These are the general forms of {\tt destruct} and {\tt edestruct}. It combines the effects of the {\tt with}, {\tt as}, {\tt using}, and {\tt in} clauses. @@ -1781,18 +1860,24 @@ last introduced hypothesis. \tacindex{intros \intropattern}} This extension of the tactic {\tt intros} combines introduction of -variables or hypotheses and case analysis. An introduction pattern is +variables or hypotheses and case analysis. An {\em introduction pattern} is either: \begin{itemize} -\item the wildcard: {\tt \_} -\item the pattern \texttt{?} -\item the pattern \texttt{?\ident} -\item an identifier -\item a disjunction of lists of patterns: +\item A {\em naming introduction pattern}, i.e. either one of: + \begin{itemize} + \item the pattern \texttt{?} + \item the pattern \texttt{?\ident} + \item an identifier + \end{itemize} +\item A {\em disjunctive/conjunctive introduction pattern}, i.e. either one of: + \begin{itemize} + \item a disjunction of lists of patterns: {\tt [$p_{11}$ {\ldots} $p_{1m_1}$ | {\ldots} | $p_{11}$ {\ldots} $p_{nm_n}$]} -\item a conjunction of patterns: {\tt (} $p_1$ {\tt ,} {\ldots} {\tt ,} $p_n$ {\tt )} -\item a list of patterns {\tt (} $p_1$\ {\tt \&}\ {\ldots}\ {\tt \&}\ $p_n$ {\tt )} - for sequence of right-associative binary constructs + \item a conjunction of patterns: {\tt (} $p_1$ {\tt ,} {\ldots} {\tt ,} $p_n$ {\tt )} + \item a list of patterns {\tt (} $p_1$\ {\tt \&}\ {\ldots}\ {\tt \&}\ $p_n$ {\tt )} + for sequence of right-associative binary constructs + \end{itemize} +\item the wildcard: {\tt \_} \item the rewriting orientations: {\tt ->} or {\tt <-} \end{itemize} @@ -1801,13 +1886,6 @@ of type {\tt forall $x$:$T$, $P$} (dependent product), the behavior of {\tt intros $p$} is defined inductively over the structure of the introduction pattern $p$: \begin{itemize} -\item introduction on the wildcard depends on whether the product is - dependent or not: in the non dependent case, it erases the - corresponding hypothesis (i.e. it behaves as an {\tt intro} followed - by a {\tt clear}, cf Section~\ref{clear}) while in the dependent - case, it succeeds and erases the variable only if the wildcard is - part of a more complex list of introduction patterns that also - erases the hypotheses depending on this variable; \item introduction on \texttt{?} performs the introduction, and let {\Coq} choose a fresh name for the variable; \item introduction on \texttt{?\ident} performs the introduction, and @@ -1843,6 +1921,13 @@ introduction pattern $p$: constructors such as {\tt conj} or {\tt ex\_intro}; for instance, an hypothesis with type {\tt A\verb|/\|exists x, B\verb|/\|C\verb|/\|D} can be introduced via pattern {\tt (a \& x \& b \& c \& d)}; +\item introduction on the wildcard depends on whether the product is + dependent or not: in the non dependent case, it erases the + corresponding hypothesis (i.e. it behaves as an {\tt intro} followed + by a {\tt clear}, cf Section~\ref{clear}) while in the dependent + case, it succeeds and erases the variable only if the wildcard is + part of a more complex list of introduction patterns that also + erases the hypotheses depending on this variable; \item introduction over {\tt ->} (respectively {\tt <-}) expects the hypothesis to be an equality and the right-hand-side (respectively the left-hand-side) is replaced by the left-hand-side (respectively diff --git a/interp/genarg.ml b/interp/genarg.ml index b371582a1..e96288097 100644 --- a/interp/genarg.ml +++ b/interp/genarg.ml @@ -75,24 +75,24 @@ let create_arg s = let exists_argtype s = List.mem s !dyntab type intro_pattern_expr = - | IntroOrAndPattern of case_intro_pattern_expr - | IntroWildcard of loc - | IntroIdentifier of identifier - | IntroAnonymous + | IntroOrAndPattern of or_and_intro_pattern_expr + | IntroWildcard | IntroRewrite of bool + | IntroIdentifier of identifier | IntroFresh of identifier -and case_intro_pattern_expr = intro_pattern_expr list list + | IntroAnonymous +and or_and_intro_pattern_expr = (loc * intro_pattern_expr) list list -let rec pr_intro_pattern = function - | IntroOrAndPattern pll -> pr_case_intro_pattern pll - | IntroWildcard _ -> str "_" - | IntroIdentifier id -> pr_id id - | IntroAnonymous -> str "?" +let rec pr_intro_pattern (_,pat) = match pat with + | IntroOrAndPattern pll -> pr_or_and_intro_pattern pll + | IntroWildcard -> str "_" | IntroRewrite true -> str "->" | IntroRewrite false -> str "<-" + | IntroIdentifier id -> pr_id id | IntroFresh id -> str "?" ++ pr_id id + | IntroAnonymous -> str "?" -and pr_case_intro_pattern = function +and pr_or_and_intro_pattern = function | [pl] -> str "(" ++ hv 0 (prlist_with_sep pr_coma pr_intro_pattern pl) ++ str ")" | pll -> diff --git a/interp/genarg.mli b/interp/genarg.mli index da0371899..bbdc7f7f0 100644 --- a/interp/genarg.mli +++ b/interp/genarg.mli @@ -32,16 +32,16 @@ type open_rawconstr = unit * rawconstr_and_expr type 'a with_ebindings = 'a * open_constr bindings type intro_pattern_expr = - | IntroOrAndPattern of case_intro_pattern_expr - | IntroWildcard of loc - | IntroIdentifier of identifier - | IntroAnonymous + | IntroOrAndPattern of or_and_intro_pattern_expr + | IntroWildcard | IntroRewrite of bool + | IntroIdentifier of identifier | IntroFresh of identifier -and case_intro_pattern_expr = intro_pattern_expr list list + | IntroAnonymous +and or_and_intro_pattern_expr = (loc * intro_pattern_expr) list list -val pr_intro_pattern : intro_pattern_expr -> Pp.std_ppcmds -val pr_case_intro_pattern : case_intro_pattern_expr -> Pp.std_ppcmds +val pr_intro_pattern : intro_pattern_expr located -> Pp.std_ppcmds +val pr_or_and_intro_pattern : or_and_intro_pattern_expr -> Pp.std_ppcmds (* The route of a generic argument, from parsing to evaluation @@ -128,15 +128,16 @@ val wit_int_or_var : (int or_var,tlevel) abstract_argument_type val rawwit_string : (string,rlevel) abstract_argument_type val globwit_string : (string,glevel) abstract_argument_type + val wit_string : (string,tlevel) abstract_argument_type val rawwit_pre_ident : (string,rlevel) abstract_argument_type val globwit_pre_ident : (string,glevel) abstract_argument_type val wit_pre_ident : (string,tlevel) abstract_argument_type -val rawwit_intro_pattern : (intro_pattern_expr,rlevel) abstract_argument_type -val globwit_intro_pattern : (intro_pattern_expr,glevel) abstract_argument_type -val wit_intro_pattern : (intro_pattern_expr,tlevel) abstract_argument_type +val rawwit_intro_pattern : (intro_pattern_expr located,rlevel) abstract_argument_type +val globwit_intro_pattern : (intro_pattern_expr located,glevel) abstract_argument_type +val wit_intro_pattern : (intro_pattern_expr located,tlevel) abstract_argument_type val rawwit_ident : (identifier,rlevel) abstract_argument_type val globwit_ident : (identifier,glevel) abstract_argument_type diff --git a/kernel/environ.ml b/kernel/environ.ml index 30cec7ed9..80c24058e 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -379,17 +379,14 @@ let insert_after_hyp (ctxt,vals) id d check = (* To be used in Logic.clear_hyps *) let remove_hyps ids check_context check_value (ctxt, vals) = - let ctxt,vals,rmv = - List.fold_right2 (fun (id,_,_ as d) (id',v) (ctxt,vals,rmv) -> + List.fold_right2 (fun (id,_,_ as d) (id',v) (ctxt,vals) -> if List.mem id ids then - (ctxt,vals,id::rmv) + (ctxt,vals) else let nd = check_context d in let nv = check_value v in - (nd::ctxt,(id',nv)::vals,rmv)) - ctxt vals ([],[],[]) - in ((ctxt,vals),rmv) - + (nd::ctxt,(id',nv)::vals)) + ctxt vals ([],[]) diff --git a/kernel/environ.mli b/kernel/environ.mli index ca41c2d7d..b0dc2846f 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -222,7 +222,7 @@ val insert_after_hyp : named_context_val -> variable -> named_declaration -> (named_context -> unit) -> named_context_val -val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val * identifier list +val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val (* spiwack: functions manipulating the retroknowledge *) diff --git a/kernel/term.ml b/kernel/term.ml index a15510158..d274857af 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -370,16 +370,22 @@ let destProd c = match kind_of_term c with | Prod (x,t1,t2) -> (x,t1,t2) | _ -> invalid_arg "destProd" +let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false + (* Destructs the abstraction [x:t1]t2 *) let destLambda c = match kind_of_term c with | Lambda (x,t1,t2) -> (x,t1,t2) | _ -> invalid_arg "destLambda" +let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false + (* Destructs the let [x:=b:t1]t2 *) let destLetIn c = match kind_of_term c with | LetIn (x,b,t1,t2) -> (x,b,t1,t2) | _ -> invalid_arg "destProd" +let isLetIn c = match kind_of_term c with LetIn _ -> true | _ -> false + (* Destructs an application *) let destApp c = match kind_of_term c with | App (f,a) -> (f, a) @@ -389,10 +395,6 @@ let destApplication = destApp let isApp c = match kind_of_term c with App _ -> true | _ -> false -let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false - -let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false - (* Destructs a constant *) let destConst c = match kind_of_term c with | Const kn -> kn @@ -419,22 +421,27 @@ let destConstruct c = match kind_of_term c with | Construct (kn, a as r) -> r | _ -> invalid_arg "dest" -let isConstruct c = match kind_of_term c with - Construct _ -> true | _ -> false +let isConstruct c = match kind_of_term c with Construct _ -> true | _ -> false (* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) let destCase c = match kind_of_term c with | Case (ci,p,c,v) -> (ci,p,c,v) | _ -> anomaly "destCase" +let isCase c = match kind_of_term c with Case _ -> true | _ -> false + let destFix c = match kind_of_term c with | Fix fix -> fix | _ -> invalid_arg "destFix" - + +let isFix c = match kind_of_term c with Fix _ -> true | _ -> false + let destCoFix c = match kind_of_term c with | CoFix cofix -> cofix | _ -> invalid_arg "destCoFix" +let isCoFix c = match kind_of_term c with CoFix _ -> true | _ -> false + (******************************************************************) (* Cast management *) (******************************************************************) diff --git a/kernel/term.mli b/kernel/term.mli index 9254a6ff8..2ab03e50f 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -230,9 +230,13 @@ val isSort : constr -> bool val isCast : constr -> bool val isApp : constr -> bool val isLambda : constr -> bool +val isLetIn : constr -> bool val isProd : constr -> bool val isConst : constr -> bool val isConstruct : constr -> bool +val isFix : constr -> bool +val isCoFix : constr -> bool +val isCase : constr -> bool val is_Prop : constr -> bool val is_Set : constr -> bool diff --git a/lib/flags.ml b/lib/flags.ml index 0378e11fb..76ab9fe64 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -8,8 +8,6 @@ (*i $Id$ i*) -open Util - let with_option o f x = let old = !o in o:=true; try let r = f x in o := old; r @@ -78,6 +76,8 @@ let print_hyps_limit () = !print_hyps_limit (* A list of the areas of the system where "unsafe" operation * has been requested *) +module Stringset = Set.Make(struct type t = string let compare = compare end) + let unsafe_set = ref Stringset.empty let add_unsafe s = unsafe_set := Stringset.add s !unsafe_set let is_unsafe s = Stringset.mem s !unsafe_set diff --git a/lib/util.ml b/lib/util.ml index 549b79e78..94e812ff6 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -1210,6 +1210,8 @@ let pr_opt_no_spc pr = function None -> mt () | Some x -> pr x let nth n = str (ordinal n) +(* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *) + let rec prlist elem l = match l with | [] -> mt () | h::t -> Stream.lapp (fun () -> elem h) (prlist elem t) @@ -1221,6 +1223,9 @@ let rec prlist_strict elem l = match l with | [] -> mt () | h::t -> (elem h)++(prlist_strict elem t) +(* [prlist_with_sep sep pr [a ; ... ; c]] outputs + [pr a ++ sep() ++ ... ++ sep() ++ pr c] *) + let rec prlist_with_sep sep elem l = match l with | [] -> mt () | [h] -> elem h @@ -1228,6 +1233,23 @@ let rec prlist_with_sep sep elem l = match l with let e = elem h and s = sep() and r = prlist_with_sep sep elem t in e ++ s ++ r +(* Print sequence of objects separated by space (unless an element is empty) *) + +let rec pr_sequence elem = function + | [] -> mt () + | [h] -> elem h + | h::t -> + let e = elem h and r = pr_sequence elem t in + if e = mt () then r else e ++ spc () ++ r + +(* [pr_enum pr [a ; b ; ... ; c]] outputs + [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *) + +let pr_enum pr l = + let c,l' = list_sep_last l in + prlist_with_sep pr_coma pr l' ++ + (if l'<>[] then str " and" ++ spc () else mt()) ++ pr c + let pr_vertical_list pr = function | [] -> str "none" ++ fnl () | l -> fnl () ++ str " " ++ hov 0 (prlist_with_sep pr_fnl pr l) ++ fnl () @@ -1242,6 +1264,9 @@ let prvecti elem v = in if n = 0 then mt () else pr (n - 1) +(* [prvect_with_sep sep pr [|a ; ... ; c|]] outputs + [pr a ++ sep() ++ ... ++ sep() ++ pr c] *) + let prvect_with_sep sep elem v = let rec pr n = if n = 0 then @@ -1253,8 +1278,16 @@ let prvect_with_sep sep elem v = let n = Array.length v in if n = 0 then mt () else pr (n - 1) +(* [prvect pr [|a ; ... ; c|]] outputs [pr a ++ ... ++ pr c] *) + let prvect elem v = prvect_with_sep mt elem v +let pr_located pr (loc,x) = + if Flags.do_translate() && loc<>dummy_loc then + let (b,e) = unloc loc in + comment b ++ pr x ++ comment e + else pr x + let surround p = hov 1 (str"(" ++ p ++ str")") (*s Size of ocaml values. *) diff --git a/lib/util.mli b/lib/util.mli index d845dd2eb..40d6046d7 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -282,6 +282,9 @@ val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds val prvect_with_sep : (unit -> std_ppcmds) -> ('b -> std_ppcmds) -> 'b array -> std_ppcmds val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds +val pr_enum : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +val pr_located : ('a -> std_ppcmds) -> 'a located -> std_ppcmds +val pr_sequence : ('a -> std_ppcmds) -> 'a list -> std_ppcmds val surround : std_ppcmds -> std_ppcmds diff --git a/parsing/g_minicoq.ml4 b/parsing/g_minicoq.ml4 deleted file mode 100644 index fe7906f63..000000000 --- a/parsing/g_minicoq.ml4 +++ /dev/null @@ -1,177 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4use: "pa_extend.cmo" i*) - -(* $Id$ *) - -open Pp -open Util -open Names -open Univ -open Term -open Environ - -let lexer = - {Token.func = Lexer.func; Token.using = Lexer.add_token; - Token.removing = (fun _ -> ()); Token.tparse = Lexer.tparse; - Token.text = Lexer.token_text} -;; - -type command = - | Definition of identifier * constr option * constr - | Parameter of identifier * constr - | Variable of identifier * constr - | Inductive of - (identifier * constr) list * - (identifier * constr * (identifier * constr) list) list - | Check of constr - -let gram = Grammar.create lexer - -let term = Grammar.Entry.create gram "term" -let name = Grammar.Entry.create gram "name" -let nametype = Grammar.Entry.create gram "nametype" -let inductive = Grammar.Entry.create gram "inductive" -let constructor = Grammar.Entry.create gram "constructor" -let command = Grammar.Entry.create gram "command" - -let path_of_string s = make_path [] (id_of_string s) - -EXTEND - name: - [ [ id = IDENT -> Name (id_of_string id) - | "_" -> Anonymous - ] ]; - nametype: - [ [ id = IDENT; ":"; t = term -> (id_of_string id, t) - ] ]; - term: - [ [ id = IDENT -> - mkVar (id_of_string id) - | IDENT "Rel"; n = INT -> - mkRel (int_of_string n) - | "Set" -> - mkSet - | "Prop" -> - mkProp - | "Type" -> - mkType (new_univ()) - | "Const"; id = IDENT -> - mkConst (path_of_string id, [||]) - | "Ind"; id = IDENT; n = INT -> - let n = int_of_string n in - mkMutInd ((path_of_string id, n), [||]) - | "Construct"; id = IDENT; n = INT; i = INT -> - let n = int_of_string n and i = int_of_string i in - mkMutConstruct (((path_of_string id, n), i), [||]) - | "["; na = name; ":"; t = term; "]"; c = term -> - mkLambda (na,t,c) - | "("; na = name; ":"; t = term; ")"; c = term -> - mkProd (na,t,c) - | c1 = term; "->"; c2 = term -> - mkArrow c1 c2 - | "("; id = IDENT; cl = LIST1 term; ")" -> - let c = mkVar (id_of_string id) in - mkApp (c, Array.of_list cl) - | "("; cl = LIST1 term; ")" -> - begin match cl with - | [c] -> c - | c::cl -> mkApp (c, Array.of_list cl) - end - | "("; c = term; "::"; t = term; ")" -> - mkCast (c, t) - | "<"; p = term; ">"; - IDENT "Case"; c = term; ":"; "Ind"; id = IDENT; i = INT; - "of"; bl = LIST0 term; "end" -> - let ind = (path_of_string id,int_of_string i) in - let nc = List.length bl in - let dummy_pats = Array.create nc RegularPat in - let dummy_ci = [||],(ind,[||],nc,None,dummy_pats) in - mkMutCase (dummy_ci, p, c, Array.of_list bl) - ] ]; - command: - [ [ "Definition"; id = IDENT; ":="; c = term; "." -> - Definition (id_of_string id, None, c) - | "Definition"; id = IDENT; ":"; t = term; ":="; c = term; "." -> - Definition (id_of_string id, Some t, c) - | "Parameter"; id = IDENT; ":"; t = term; "." -> - Parameter (id_of_string id, t) - | "Variable"; id = IDENT; ":"; t = term; "." -> - Variable (id_of_string id, t) - | "Inductive"; "["; params = LIST0 nametype SEP ";"; "]"; - inds = LIST1 inductive SEP "with" -> - Inductive (params, inds) - | IDENT "Check"; c = term; "." -> - Check c - | EOI -> raise End_of_file - ] ]; - inductive: - [ [ id = IDENT; ":"; ar = term; ":="; constrs = LIST0 constructor SEP "|" -> - (id_of_string id,ar,constrs) - ] ]; - constructor: - [ [ id = IDENT; ":"; c = term -> (id_of_string id,c) ] ]; -END - -(* Pretty-print. *) - -let print_univers = ref false -let print_casts = ref false - -let print_type u = - if !print_univers then (str "Type" ++ pr_uni u) - else (str "Type") - -let print_name = function - | Anonymous -> (str "_") - | Name id -> pr_id id - -let print_rel bv n = print_name (List.nth bv (pred n)) - -let rename bv = function - | Anonymous -> Anonymous - | Name id as na -> - let idl = - List.fold_left - (fun l n -> match n with Name x -> x::l | _ -> l) [] bv - in - if List.mem na bv then Name (next_ident_away id idl) else na - -let rec pp bv t = - match kind_of_term t with - | Sort (Prop Pos) -> (str "Set") - | Sort (Prop Null) -> (str "Prop") - | Sort (Type u) -> print_type u - | Lambda (na, t, c) -> - (str"[" ++ print_name na ++ str":" ++ pp bv t ++ str"]" ++ pp (na::bv) c) - | Prod (Anonymous, t, c) -> - (pp bv t ++ str"->" ++ pp (Anonymous::bv) c) - | Prod (na, t, c) -> - (str"(" ++ print_name na ++ str":" ++ pp bv t ++ str")" ++ pp (na::bv) c) - | Cast (c, t) -> - if !print_casts then - (str"(" ++ pp bv c ++ str"::" ++ pp bv t ++ str")") - else - pp bv c - | App(h, v) -> - (str"(" ++ pp bv h ++ spc () ++ - prvect_with_sep (fun () -> (spc ())) (pp bv) v ++ str")") - | Const (sp, _) -> - (str"Const " ++ pr_id (basename sp)) - | Ind ((sp,i), _) -> - (str"Ind " ++ pr_id (basename sp) ++ str" " ++ int i) - | Construct (((sp,i),j), _) -> - (str"Construct " ++ pr_id (basename sp) ++ str" " ++ int i ++ - str" " ++ int j) - | Var id -> pr_id id - | Rel n -> print_rel bv n - | _ -> (str"<???>") - -let pr_term _ ctx = pp (fold_rel_context (fun _ (n,_,_) l -> n::l) ctx []) - diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 092dc9f88..ed8422b10 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -26,7 +26,7 @@ let _ = List.iter (fun s -> Lexer.add_token("",s)) tactic_kw (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) (* admissible notation "(x t)" *) -let lpar_id_coloneq = +let test_lpar_id_coloneq = Gram.Entry.of_parser "lpar_id_coloneq" (fun strm -> match Stream.npeek 1 strm with @@ -34,9 +34,7 @@ let lpar_id_coloneq = (match Stream.npeek 2 strm with | [_; ("IDENT",s)] -> (match Stream.npeek 3 strm with - | [_; _; ("", ":=")] -> - Stream.junk strm; Stream.junk strm; Stream.junk strm; - Names.id_of_string s + | [_; _; ("", ":=")] -> () | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) @@ -56,7 +54,7 @@ let test_lpar_idnum_coloneq = | _ -> raise Stream.Failure) (* idem for (x:t) *) -let lpar_id_colon = +let test_lpar_id_colon = Gram.Entry.of_parser "lpar_id_colon" (fun strm -> match Stream.npeek 1 strm with @@ -64,9 +62,7 @@ let lpar_id_colon = (match Stream.npeek 2 strm with | [_; ("IDENT",id)] -> (match Stream.npeek 3 strm with - | [_; _; ("", ":")] -> - Stream.junk strm; Stream.junk strm; Stream.junk strm; - Names.id_of_string id + | [_; _; ("", ":")] -> () | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) @@ -162,6 +158,8 @@ let mkCLambdaN_simple bl c = let loc = join_loc (fst (List.hd (pi1 (List.hd bl)))) (constr_loc c) in mkCLambdaN_simple_loc loc bl c +let loc_of_ne_list l = join_loc (fst (List.hd l)) (fst (list_last l)) + let map_int_or_var f = function | Rawterm.ArgArg x -> Rawterm.ArgArg (f x) | Rawterm.ArgVar _ as y -> y @@ -237,27 +235,32 @@ GEXTEND Gram intropatterns: [ [ l = LIST0 simple_intropattern -> l ]] ; - simple_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|" ; "]" -> IntroOrAndPattern tc - | "()" -> IntroOrAndPattern [[]] - | "("; si = simple_intropattern; ")" -> IntroOrAndPattern [[si]] + disjunctive_intropattern: + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> loc,IntroOrAndPattern tc + | "()" -> loc,IntroOrAndPattern [[]] + | "("; si = simple_intropattern; ")" -> loc,IntroOrAndPattern [[si]] | "("; si = simple_intropattern; ","; tc = LIST1 simple_intropattern SEP "," ; ")" -> - IntroOrAndPattern [si::tc] + loc,IntroOrAndPattern [si::tc] | "("; si = simple_intropattern; "&"; tc = LIST1 simple_intropattern SEP "&" ; ")" -> (* (A & B & C) is translated into (A,(B,C)) *) let rec pairify = function | ([]|[_]|[_;_]) as l -> IntroOrAndPattern [l] - | t::q -> IntroOrAndPattern [[t;pairify q]] - in pairify (si::tc) - | "_" -> IntroWildcard loc - | prefix = pattern_ident -> IntroFresh prefix - | "?" -> IntroAnonymous - | id = ident -> IntroIdentifier id - | "->" -> IntroRewrite true - | "<-" -> IntroRewrite false - ] ] + | t::q -> IntroOrAndPattern [[t;(loc_of_ne_list q,pairify q)]] + in loc,pairify (si::tc) ] ] + ; + naming_intropattern: + [ [ prefix = pattern_ident -> loc, IntroFresh prefix + | "?" -> loc, IntroAnonymous + | id = ident -> loc, IntroIdentifier id ] ] + ; + simple_intropattern: + [ [ pat = disjunctive_intropattern -> pat + | pat = naming_intropattern -> pat + | "_" -> loc, IntroWildcard + | "->" -> loc, IntroRewrite true + | "<-" -> loc, IntroRewrite false ] ] ; simple_binding: [ [ "("; id = ident; ":="; c = lconstr; ")" -> (loc, NamedHyp id, c) @@ -402,7 +405,18 @@ GEXTEND Gram [ [ "using"; el = constr_with_bindings -> el ] ] ; with_names: - [ [ "as"; ipat = simple_intropattern -> ipat | -> IntroAnonymous ] ] + [ [ "as"; ipat = simple_intropattern -> ipat + | -> dummy_loc,IntroAnonymous ] ] + ; + with_inversion_names: + [ [ "as"; ipat = disjunctive_intropattern -> Some ipat + | -> None ] ] + ; + with_induction_names: + [ [ "as"; eq = OPT naming_intropattern; ipat = disjunctive_intropattern + -> (eq,Some ipat) + | "as"; eq = naming_intropattern -> (Some eq,None) + | -> (None,None) ] ] ; as_name: [ [ "as"; id = ident -> Names.Name id | -> Names.Anonymous ] ] @@ -439,30 +453,40 @@ GEXTEND Gram oriented_rewriter : [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ] ; + induction_clause: + [ [ lc = LIST1 induction_arg; ipats = with_induction_names; + el = OPT eliminator; cl = opt_clause -> (lc,el,ipats,cl) ] ] + ; + move_location: + [ [ IDENT "after"; id = id_or_meta -> MoveAfter id + | IDENT "before"; id = id_or_meta -> MoveBefore id + | "at"; IDENT "bottom" -> MoveToEnd true + | "at"; IDENT "top" -> MoveToEnd false ] ] + ; simple_tactic: [ [ (* Basic tactics *) IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> TacIntrosUntil id | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl - | IDENT "intro"; id = ident; IDENT "after"; id2 = identref -> - TacIntroMove (Some id, Some id2) - | IDENT "intro"; IDENT "after"; id2 = identref -> - TacIntroMove (None, Some id2) - | IDENT "intro"; id = ident -> TacIntroMove (Some id, None) - | IDENT "intro" -> TacIntroMove (None, None) + | IDENT "intro"; id = ident; hto = move_location -> + TacIntroMove (Some id, hto) + | IDENT "intro"; hto = move_location -> TacIntroMove (None, hto) + | IDENT "intro"; id = ident -> TacIntroMove (Some id, no_move) + | IDENT "intro" -> TacIntroMove (None, no_move) | IDENT "assumption" -> TacAssumption | IDENT "exact"; c = constr -> TacExact c | IDENT "exact_no_check"; c = constr -> TacExactNoCheck c | IDENT "vm_cast_no_check"; c = constr -> TacVmCastNoCheck c - | IDENT "apply"; cl = constr_with_bindings -> TacApply (true,false,cl) - | IDENT "eapply"; cl = constr_with_bindings -> TacApply (true,true,cl) - | IDENT "simple"; IDENT "apply"; cl = constr_with_bindings -> - TacApply (false,false,cl) - | IDENT "simple"; IDENT "eapply"; cl = constr_with_bindings -> - TacApply (false, true,cl) + | IDENT "apply"; cl = LIST1 constr_with_bindings SEP "," -> + TacApply (true,false,cl) + | IDENT "eapply"; cl = LIST1 constr_with_bindings SEP "," -> + TacApply (true,true,cl) + | IDENT "simple"; IDENT "apply"; cl = LIST1 constr_with_bindings SEP "," + -> TacApply (false,false,cl) + | IDENT "simple"; IDENT "eapply"; cl = LIST1 constr_with_bindings SEP "," -> TacApply (false,true,cl) | IDENT "elim"; cl = constr_with_bindings; el = OPT eliminator -> TacElim (false,cl,el) | IDENT "eelim"; cl = constr_with_bindings; el = OPT eliminator -> @@ -492,10 +516,12 @@ GEXTEND Gram TacLetTac (na,c,p,false) (* Begin compatibility *) - | IDENT "assert"; id = lpar_id_coloneq; c = lconstr; ")" -> - TacAssert (None,IntroIdentifier id,c) - | IDENT "assert"; id = lpar_id_colon; c = lconstr; ")"; tac=by_tactic -> - TacAssert (Some tac,IntroIdentifier id,c) + | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; + c = lconstr; ")" -> + TacAssert (None,(loc,IntroIdentifier id),c) + | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + TacAssert (Some tac,(loc,IntroIdentifier id),c) (* End compatibility *) | IDENT "assert"; c = constr; ipat = with_names; tac = by_tactic -> @@ -521,23 +547,19 @@ GEXTEND Gram (* Derived basic tactics *) | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis -> - TacSimpleInduction h - | IDENT "induction"; lc = LIST1 induction_arg; ids = with_names; - el = OPT eliminator; cl = opt_clause -> - TacNewInduction (false,lc,el,ids,cl) - | IDENT "einduction"; lc = LIST1 induction_arg; ids = with_names; - el = OPT eliminator; cl = opt_clause -> - TacNewInduction (true,lc,el,ids,cl) + TacSimpleInductionDestruct (true,h) + | IDENT "induction"; ic = induction_clause -> + TacInductionDestruct (true,false,[ic]) + | IDENT "einduction"; ic = induction_clause -> + TacInductionDestruct(true,true,[ic]) | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis; h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2) | IDENT "simple"; IDENT "destruct"; h = quantified_hypothesis -> - TacSimpleDestruct h - | IDENT "destruct"; lc = LIST1 induction_arg; ids = with_names; - el = OPT eliminator; cl = opt_clause -> - TacNewDestruct (false,lc,el,ids,cl) - | IDENT "edestruct"; lc = LIST1 induction_arg; ids = with_names; - el = OPT eliminator; cl = opt_clause -> - TacNewDestruct (true,lc,el,ids,cl) + TacSimpleInductionDestruct (false,h) + | IDENT "destruct"; ic = induction_clause -> + TacInductionDestruct(false,false,[ic]) + | IDENT "edestruct"; ic = induction_clause -> + TacInductionDestruct(false,true,[ic]) | IDENT "decompose"; IDENT "record" ; c = constr -> TacDecomposeAnd c | IDENT "decompose"; IDENT "sum"; c = constr -> TacDecomposeOr c | IDENT "decompose"; "["; l = LIST1 smart_global; "]"; c = constr @@ -565,8 +587,8 @@ GEXTEND Gram | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacClear (true, l) | IDENT "clear"; l = LIST0 id_or_meta -> TacClear (l=[], l) | IDENT "clearbody"; l = LIST1 id_or_meta -> TacClearBody l - | IDENT "move"; id1 = id_or_meta; IDENT "after"; id2 = id_or_meta -> - TacMove (true,id1,id2) + | IDENT "move"; dep = [IDENT "dependent" -> true | -> false]; + hfrom = id_or_meta; hto = move_location -> TacMove (dep,hfrom,hto) | IDENT "rename"; l = LIST1 rename SEP "," -> TacRename l | IDENT "revert"; l = LIST1 id_or_meta -> TacRevert l @@ -601,16 +623,19 @@ GEXTEND Gram | IDENT "inversion" -> FullInversion | IDENT "inversion_clear" -> FullInversionClear ]; hyp = quantified_hypothesis; - ids = with_names; co = OPT ["with"; c = constr -> c] -> + ids = with_inversion_names; co = OPT ["with"; c = constr -> c] -> TacInversion (DepInversion (k,co,ids),hyp) | IDENT "simple"; IDENT "inversion"; - hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> + hyp = quantified_hypothesis; ids = with_inversion_names; + cl = simple_clause -> TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp) | IDENT "inversion"; - hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> + hyp = quantified_hypothesis; ids = with_inversion_names; + cl = simple_clause -> TacInversion (NonDepInversion (FullInversion, cl, ids), hyp) | IDENT "inversion_clear"; - hyp = quantified_hypothesis; ids = with_names; cl = simple_clause -> + hyp = quantified_hypothesis; ids = with_inversion_names; + cl = simple_clause -> TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp) | IDENT "inversion"; hyp = quantified_hypothesis; "using"; c = constr; cl = simple_clause -> diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 19b7dd17e..824ca640e 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -188,7 +188,7 @@ module Tactic : val int_or_var : int or_var Gram.Entry.e val red_expr : raw_red_expr Gram.Entry.e val simple_tactic : raw_atomic_tactic_expr Gram.Entry.e - val simple_intropattern : Genarg.intro_pattern_expr Gram.Entry.e + val simple_intropattern : Genarg.intro_pattern_expr located Gram.Entry.e val tactic_arg : raw_tactic_arg Gram.Entry.e val tactic_expr : raw_tactic_expr Gram.Entry.e val binder_tactic : raw_tactic_expr Gram.Entry.e diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml index ca8b97588..4f266f5ca 100644 --- a/parsing/ppconstr.ml +++ b/parsing/ppconstr.ml @@ -96,12 +96,6 @@ let pr_patnotation = pr_notation_gen decode_patlist_value let pr_delimiters key strm = strm ++ str ("%"^key) -let pr_located pr (loc,x) = - if Flags.do_translate() && loc<>dummy_loc then - let (b,e) = unloc loc in - comment b ++ pr x ++ comment e - else pr x - let pr_com_at n = if Flags.do_translate() && n <> 0 then comment n else mt() diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli index 83339ee2f..b9bf933eb 100644 --- a/parsing/ppconstr.mli +++ b/parsing/ppconstr.mli @@ -35,7 +35,6 @@ val prec_less : int -> int * Ppextend.parenRelation -> bool val pr_tight_coma : unit -> std_ppcmds -val pr_located : ('a -> std_ppcmds) -> 'a located -> std_ppcmds val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds val pr_metaid : identifier -> std_ppcmds diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml index 2a0e755ff..8d1dbf875 100644 --- a/parsing/pptactic.ml +++ b/parsing/pptactic.ml @@ -142,41 +142,40 @@ let out_bindings = function let rec pr_raw_generic prc prlc prtac prref (x:Genarg.rlevel Genarg.generic_argument) = match Genarg.genarg_tag x with - | BoolArgType -> pr_arg str (if out_gen rawwit_bool x then "true" else "false") - | IntArgType -> pr_arg int (out_gen rawwit_int x) - | IntOrVarArgType -> pr_arg (pr_or_var pr_int) (out_gen rawwit_int_or_var x) - | StringArgType -> spc () ++ str "\"" ++ str (out_gen rawwit_string x) ++ str "\"" - | PreIdentArgType -> pr_arg str (out_gen rawwit_pre_ident x) - | IntroPatternArgType -> pr_arg pr_intro_pattern - (out_gen rawwit_intro_pattern x) - | IdentArgType -> pr_arg pr_id (out_gen rawwit_ident x) - | VarArgType -> pr_arg (pr_located pr_id) (out_gen rawwit_var x) - | RefArgType -> pr_arg prref (out_gen rawwit_ref x) - | SortArgType -> pr_arg pr_rawsort (out_gen rawwit_sort x) - | ConstrArgType -> pr_arg prc (out_gen rawwit_constr x) + | BoolArgType -> str (if out_gen rawwit_bool x then "true" else "false") + | IntArgType -> int (out_gen rawwit_int x) + | IntOrVarArgType -> pr_or_var pr_int (out_gen rawwit_int_or_var x) + | StringArgType -> str "\"" ++ str (out_gen rawwit_string x) ++ str "\"" + | PreIdentArgType -> str (out_gen rawwit_pre_ident x) + | IntroPatternArgType -> pr_intro_pattern (out_gen rawwit_intro_pattern x) + | IdentArgType -> pr_id (out_gen rawwit_ident x) + | VarArgType -> pr_located pr_id (out_gen rawwit_var x) + | RefArgType -> prref (out_gen rawwit_ref x) + | SortArgType -> pr_rawsort (out_gen rawwit_sort x) + | ConstrArgType -> prc (out_gen rawwit_constr x) | ConstrMayEvalArgType -> - pr_arg (pr_may_eval prc prlc (pr_or_by_notation prref)) + pr_may_eval prc prlc (pr_or_by_notation prref) (out_gen rawwit_constr_may_eval x) - | QuantHypArgType -> - pr_arg pr_quantified_hypothesis (out_gen rawwit_quant_hyp x) + | QuantHypArgType -> pr_quantified_hypothesis (out_gen rawwit_quant_hyp x) | RedExprArgType -> - pr_arg (pr_red_expr (prc,prlc,pr_or_by_notation prref)) + pr_red_expr (prc,prlc,pr_or_by_notation prref) (out_gen rawwit_red_expr x) - | OpenConstrArgType b -> pr_arg prc (snd (out_gen (rawwit_open_constr_gen b) x)) + | OpenConstrArgType b -> prc (snd (out_gen (rawwit_open_constr_gen b) x)) | ConstrWithBindingsArgType -> - pr_arg (pr_with_bindings prc prlc) (out_gen rawwit_constr_with_bindings x) + pr_with_bindings prc prlc (out_gen rawwit_constr_with_bindings x) | BindingsArgType -> - pr_arg (pr_bindings_no_with prc prlc) (out_gen rawwit_bindings x) + pr_bindings_no_with prc prlc (out_gen rawwit_bindings x) | List0ArgType _ -> - hov 0 (fold_list0 (fun x a -> pr_raw_generic prc prlc prtac prref x ++ a) x (mt())) + hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prref) + (fold_list0 (fun a l -> a::l) x [])) | List1ArgType _ -> - hov 0 (fold_list1 (fun x a -> pr_raw_generic prc prlc prtac prref x ++ a) x (mt())) + hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prref) + (fold_list1 (fun a l -> a::l) x [])) | OptArgType _ -> hov 0 (fold_opt (pr_raw_generic prc prlc prtac prref) (mt()) x) | PairArgType _ -> hov 0 (fold_pair - (fun a b -> pr_raw_generic prc prlc prtac prref a ++ spc () ++ - pr_raw_generic prc prlc prtac prref b) + (fun a b -> pr_sequence (pr_raw_generic prc prlc prtac prref) [a;b]) x) | ExtraArgType s -> try pi1 (Stringmap.find s !genarg_pprule) prc prlc prtac x @@ -185,107 +184,105 @@ let rec pr_raw_generic prc prlc prtac prref (x:Genarg.rlevel Genarg.generic_argu let rec pr_glob_generic prc prlc prtac x = match Genarg.genarg_tag x with - | BoolArgType -> pr_arg str (if out_gen globwit_bool x then "true" else "false") - | IntArgType -> pr_arg int (out_gen globwit_int x) - | IntOrVarArgType -> pr_arg (pr_or_var pr_int) (out_gen globwit_int_or_var x) - | StringArgType -> spc () ++ str "\"" ++ str (out_gen globwit_string x) ++ str "\"" - | PreIdentArgType -> pr_arg str (out_gen globwit_pre_ident x) - | IntroPatternArgType -> - pr_arg pr_intro_pattern (out_gen globwit_intro_pattern x) - | IdentArgType -> pr_arg pr_id (out_gen globwit_ident x) - | VarArgType -> pr_arg (pr_located pr_id) (out_gen globwit_var x) - | RefArgType -> pr_arg (pr_or_var (pr_located pr_global)) (out_gen globwit_ref x) - | SortArgType -> pr_arg pr_rawsort (out_gen globwit_sort x) - | ConstrArgType -> pr_arg prc (out_gen globwit_constr x) + | BoolArgType -> str (if out_gen globwit_bool x then "true" else "false") + | IntArgType -> int (out_gen globwit_int x) + | IntOrVarArgType -> pr_or_var pr_int (out_gen globwit_int_or_var x) + | StringArgType -> str "\"" ++ str (out_gen globwit_string x) ++ str "\"" + | PreIdentArgType -> str (out_gen globwit_pre_ident x) + | IntroPatternArgType -> pr_intro_pattern (out_gen globwit_intro_pattern x) + | IdentArgType -> pr_id (out_gen globwit_ident x) + | VarArgType -> pr_located pr_id (out_gen globwit_var x) + | RefArgType -> pr_or_var (pr_located pr_global) (out_gen globwit_ref x) + | SortArgType -> pr_rawsort (out_gen globwit_sort x) + | ConstrArgType -> prc (out_gen globwit_constr x) | ConstrMayEvalArgType -> - pr_arg (pr_may_eval prc prlc - (pr_or_var (pr_and_short_name pr_evaluable_reference))) + pr_may_eval prc prlc + (pr_or_var (pr_and_short_name pr_evaluable_reference)) (out_gen globwit_constr_may_eval x) | QuantHypArgType -> - pr_arg pr_quantified_hypothesis (out_gen globwit_quant_hyp x) + pr_quantified_hypothesis (out_gen globwit_quant_hyp x) | RedExprArgType -> - pr_arg (pr_red_expr - (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference))) + pr_red_expr + (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference)) (out_gen globwit_red_expr x) - | OpenConstrArgType b -> pr_arg prc (snd (out_gen (globwit_open_constr_gen b) x)) + | OpenConstrArgType b -> prc (snd (out_gen (globwit_open_constr_gen b) x)) | ConstrWithBindingsArgType -> - pr_arg (pr_with_bindings prc prlc) (out_gen globwit_constr_with_bindings x) + pr_with_bindings prc prlc (out_gen globwit_constr_with_bindings x) | BindingsArgType -> - pr_arg (pr_bindings_no_with prc prlc) (out_gen globwit_bindings x) + pr_bindings_no_with prc prlc (out_gen globwit_bindings x) | List0ArgType _ -> - hov 0 (fold_list0 (fun x a -> pr_glob_generic prc prlc prtac x ++ a) x (mt())) + hov 0 (pr_sequence (pr_glob_generic prc prlc prtac) + (fold_list0 (fun a l -> a::l) x [])) | List1ArgType _ -> - hov 0 (fold_list1 (fun x a -> pr_glob_generic prc prlc prtac x ++ a) x (mt())) + hov 0 (pr_sequence (pr_glob_generic prc prlc prtac) + (fold_list1 (fun a l -> a::l) x [])) | OptArgType _ -> hov 0 (fold_opt (pr_glob_generic prc prlc prtac) (mt()) x) | PairArgType _ -> hov 0 (fold_pair - (fun a b -> pr_glob_generic prc prlc prtac a ++ spc () ++ - pr_glob_generic prc prlc prtac b) + (fun a b -> pr_sequence (pr_glob_generic prc prlc prtac) [a;b]) x) | ExtraArgType s -> try pi2 (Stringmap.find s !genarg_pprule) prc prlc prtac x - with Not_found -> str " [no printer for " ++ str s ++ str "] " + with Not_found -> str "[no printer for " ++ str s ++ str "] " open Closure let rec pr_generic prc prlc prtac x = match Genarg.genarg_tag x with - | BoolArgType -> pr_arg str (if out_gen wit_bool x then "true" else "false") - | IntArgType -> pr_arg int (out_gen wit_int x) - | IntOrVarArgType -> pr_arg (pr_or_var pr_int) (out_gen wit_int_or_var x) - | StringArgType -> spc () ++ str "\"" ++ str (out_gen wit_string x) ++ str "\"" - | PreIdentArgType -> pr_arg str (out_gen wit_pre_ident x) - | IntroPatternArgType -> - pr_arg pr_intro_pattern (out_gen wit_intro_pattern x) - | IdentArgType -> pr_arg pr_id (out_gen wit_ident x) - | VarArgType -> pr_arg pr_id (out_gen wit_var x) - | RefArgType -> pr_arg pr_global (out_gen wit_ref x) - | SortArgType -> pr_arg pr_sort (out_gen wit_sort x) - | ConstrArgType -> pr_arg prc (out_gen wit_constr x) - | ConstrMayEvalArgType -> - pr_arg prc (out_gen wit_constr_may_eval x) - | QuantHypArgType -> - pr_arg pr_quantified_hypothesis (out_gen wit_quant_hyp x) + | BoolArgType -> str (if out_gen wit_bool x then "true" else "false") + | IntArgType -> int (out_gen wit_int x) + | IntOrVarArgType -> pr_or_var pr_int (out_gen wit_int_or_var x) + | StringArgType -> str "\"" ++ str (out_gen wit_string x) ++ str "\"" + | PreIdentArgType -> str (out_gen wit_pre_ident x) + | IntroPatternArgType -> pr_intro_pattern (out_gen wit_intro_pattern x) + | IdentArgType -> pr_id (out_gen wit_ident x) + | VarArgType -> pr_id (out_gen wit_var x) + | RefArgType -> pr_global (out_gen wit_ref x) + | SortArgType -> pr_sort (out_gen wit_sort x) + | ConstrArgType -> prc (out_gen wit_constr x) + | ConstrMayEvalArgType -> prc (out_gen wit_constr_may_eval x) + | QuantHypArgType -> pr_quantified_hypothesis (out_gen wit_quant_hyp x) | RedExprArgType -> - pr_arg (pr_red_expr (prc,prlc,pr_evaluable_reference)) - (out_gen wit_red_expr x) - | OpenConstrArgType b -> pr_arg prc (snd (out_gen (wit_open_constr_gen b) x)) + pr_red_expr (prc,prlc,pr_evaluable_reference) (out_gen wit_red_expr x) + | OpenConstrArgType b -> prc (snd (out_gen (wit_open_constr_gen b) x)) | ConstrWithBindingsArgType -> let (c,b) = out_gen wit_constr_with_bindings x in - pr_arg (pr_with_bindings prc prlc) (c,out_bindings b) + pr_with_bindings prc prlc (c,out_bindings b) | BindingsArgType -> - pr_arg (pr_bindings_no_with prc prlc) - (out_bindings (out_gen wit_bindings x)) - | List0ArgType _ -> - hov 0 (fold_list0 (fun x a -> pr_generic prc prlc prtac x ++ a) x (mt())) + pr_bindings_no_with prc prlc (out_bindings (out_gen wit_bindings x)) + | List0ArgType _ -> + hov 0 (pr_sequence (pr_generic prc prlc prtac) + (fold_list0 (fun a l -> a::l) x [])) | List1ArgType _ -> - hov 0 (fold_list1 (fun x a -> pr_generic prc prlc prtac x ++ a) x (mt())) + hov 0 (pr_sequence (pr_generic prc prlc prtac) + (fold_list1 (fun a l -> a::l) x [])) | OptArgType _ -> hov 0 (fold_opt (pr_generic prc prlc prtac) (mt()) x) | PairArgType _ -> hov 0 - (fold_pair - (fun a b -> pr_generic prc prlc prtac a ++ spc () ++ - pr_generic prc prlc prtac b) + (fold_pair (fun a b -> pr_sequence (pr_generic prc prlc prtac) [a;b]) x) | ExtraArgType s -> try pi3 (Stringmap.find s !genarg_pprule) prc prlc prtac x - with Not_found -> str " [no printer for " ++ str s ++ str "]" + with Not_found -> str "[no printer for " ++ str s ++ str "]" -let rec pr_tacarg_using_rule pr_gen = function - | Some s :: l, al -> spc () ++ str s ++ pr_tacarg_using_rule pr_gen (l,al) - | None :: l, a :: al -> pr_gen a ++ pr_tacarg_using_rule pr_gen (l,al) - | [], [] -> mt () +let rec tacarg_using_rule_token pr_gen = function + | Some s :: l, al -> str s :: tacarg_using_rule_token pr_gen (l,al) + | None :: l, a :: al -> pr_gen a :: tacarg_using_rule_token pr_gen (l,al) + | [], [] -> [] | _ -> failwith "Inconsistent arguments of extended tactic" -let pr_extend_gen prgen lev s l = +let pr_tacarg_using_rule pr_gen l= + pr_sequence (fun x -> x) (tacarg_using_rule_token pr_gen l) + +let pr_extend_gen pr_gen lev s l = try let tags = List.map genarg_tag l in let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in - let p = pr_tacarg_using_rule prgen (pl,l) in + let p = pr_tacarg_using_rule pr_gen (pl,l) in if lev' > lev then surround p else p with Not_found -> - str s ++ prlist prgen l ++ str " (* Generic printer *)" + str s ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)" let pr_raw_extend prc prlc prtac = pr_extend_gen (pr_raw_generic prc prlc prtac pr_reference) @@ -366,9 +363,22 @@ let pr_with_constr prc = function | None -> mt () | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c) +let pr_with_induction_names = function + | None, None -> mt () + | eqpat, ipat -> + spc () ++ hov 1 (str "as" ++ pr_opt pr_intro_pattern eqpat ++ + pr_opt pr_intro_pattern ipat) + +let pr_as_intro_pattern ipat = + spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat) + +let pr_with_inversion_names = function + | None -> mt () + | Some ipat -> pr_as_intro_pattern ipat + let pr_with_names = function - | IntroAnonymous -> mt () - | ipat -> spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat) + | _,IntroAnonymous -> mt () + | ipat -> pr_as_intro_pattern ipat let pr_as_name = function | Anonymous -> mt () @@ -454,7 +464,7 @@ let pr_induction_kind = function | FullInversion -> str "inversion" | FullInversionClear -> str "inversion_clear" -let pr_lazy lz = if lz then str "lazy " else mt () +let pr_lazy lz = if lz then str "lazy" else mt () let pr_match_pattern pr_pat = function | Term a -> pr_pat a @@ -493,8 +503,9 @@ let pr_funvar = function | None -> spc () ++ str "_" | Some id -> spc () ++ pr_id id -let pr_let_clause k pr (id,t) = - hov 0 (str k ++ pr_lident id ++ str " :=" ++ brk (1,1) ++ pr (TacArg t)) +let pr_let_clause k pr (id,(bl,t)) = + hov 0 (str k ++ pr_lident id ++ prlist pr_funvar bl ++ + str " :=" ++ brk (1,1) ++ pr (TacArg t)) let pr_let_clauses recflag pr = function | hd::tl -> @@ -603,6 +614,10 @@ let pr_intarg n = spc () ++ int n in (* Some printing combinators *) let pr_eliminator cb = str "using" ++ pr_arg pr_with_bindings cb in +let extract_binders = function + | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body) + | body -> ([],body) in + let pr_binder_fix (nal,t) = (* match t with | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal @@ -648,7 +663,7 @@ let pr_cofix_tac (id,c) = (* Printing tactics as arguments *) let rec pr_atom0 = function | TacIntroPattern [] -> str "intros" - | TacIntroMove (None,None) -> str "intro" + | TacIntroMove (None,hto) when hto = no_move -> str "intro" | TacAssumption -> str "assumption" | TacAnyConstructor (false,None) -> str "constructor" | TacAnyConstructor (true,None) -> str "econstructor" @@ -676,12 +691,10 @@ and pr_atom1 = function hov 1 (str "intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p) | TacIntrosUntil h -> hv 1 (str "intros until" ++ pr_arg pr_quantified_hypothesis h) - | TacIntroMove (None,None) as t -> pr_atom0 t - | TacIntroMove (Some id1,None) -> str "intro " ++ pr_id id1 - | TacIntroMove (ido1,Some id2) -> - hov 1 - (str "intro" ++ pr_opt pr_id ido1 ++ spc () ++ str "after " ++ - pr_lident id2) + | TacIntroMove (None,hto) as t when hto = no_move -> pr_atom0 t + | TacIntroMove (Some id,hto) when hto = no_move -> str "intro " ++ pr_id id + | TacIntroMove (ido,hto) -> + hov 1 (str"intro" ++ pr_opt pr_id ido ++ pr_move_location pr_ident hto) | TacAssumption as t -> pr_atom0 t | TacExact c -> hov 1 (str "exact" ++ pr_constrarg c) | TacExactNoCheck c -> hov 1 (str "exact_no_check" ++ pr_constrarg c) @@ -689,7 +702,7 @@ and pr_atom1 = function | TacApply (a,ev,cb) -> hov 1 ((if a then mt() else str "simple ") ++ str (with_evars ev "apply") ++ spc () ++ - pr_with_bindings cb) + prlist_with_sep pr_coma pr_with_bindings cb) | TacElim (ev,cb,cbo) -> hov 1 (str (with_evars ev "elim") ++ pr_arg pr_with_bindings cb ++ pr_opt pr_eliminator cbo) @@ -741,22 +754,17 @@ and pr_atom1 = function ++ str "in" ++ pr_hyp_location pr_ident (id,[],(hloc,ref None))) *) (* Derived basic tactics *) - | TacSimpleInduction h -> - hov 1 (str "simple induction" ++ pr_arg pr_quantified_hypothesis h) - | TacNewInduction (ev,h,e,ids,cl) -> - hov 1 (str (with_evars ev "induction") ++ spc () ++ - prlist_with_sep spc (pr_induction_arg pr_lconstr pr_constr) h ++ - pr_with_names ids ++ - pr_opt pr_eliminator e ++ - pr_opt_no_spc (pr_clauses pr_ident) cl) - | TacSimpleDestruct h -> - hov 1 (str "simple destruct" ++ pr_arg pr_quantified_hypothesis h) - | TacNewDestruct (ev,h,e,ids,cl) -> - hov 1 (str (with_evars ev "destruct") ++ spc () ++ - prlist_with_sep spc (pr_induction_arg pr_lconstr pr_constr) h ++ - pr_with_names ids ++ - pr_opt pr_eliminator e ++ - pr_opt_no_spc (pr_clauses pr_ident) cl) + | TacSimpleInductionDestruct (isrec,h) -> + hov 1 (str "simple " ++ str (if isrec then "induction" else "destruct") + ++ pr_arg pr_quantified_hypothesis h) + | TacInductionDestruct (isrec,ev,l) -> + hov 1 (str (with_evars ev (if isrec then "induction" else "destruct")) ++ + spc () ++ + prlist_with_sep pr_coma (fun (h,e,ids,cl) -> + prlist_with_sep spc (pr_induction_arg pr_lconstr pr_constr) h ++ + pr_with_induction_names ids ++ + pr_opt pr_eliminator e ++ + pr_opt_no_spc (pr_clauses pr_ident) cl) l) | TacDoubleInduction (h1,h2) -> hov 1 (str "double induction" ++ @@ -800,8 +808,8 @@ and pr_atom1 = function (* Rem: only b = true is available for users *) assert b; hov 1 - (str "move" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ - str "after" ++ brk (1,1) ++ pr_ident id2) + (str "move" ++ brk (1,1) ++ pr_ident id1 ++ + pr_move_location pr_ident id2) | TacRename l -> hov 1 (str "rename" ++ brk (1,1) ++ @@ -856,11 +864,11 @@ and pr_atom1 = function | TacInversion (DepInversion (k,c,ids),hyp) -> hov 1 (str "dependent " ++ pr_induction_kind k ++ spc () ++ pr_quantified_hypothesis hyp ++ - pr_with_names ids ++ pr_with_constr pr_constr c) + pr_with_inversion_names ids ++ pr_with_constr pr_constr c) | TacInversion (NonDepInversion (k,cl,ids),hyp) -> hov 1 (pr_induction_kind k ++ spc () ++ pr_quantified_hypothesis hyp ++ - pr_with_names ids ++ pr_simple_clause pr_ident cl) + pr_with_inversion_names ids ++ pr_simple_clause pr_ident cl) | TacInversion (InversionUsing (c,cl),hyp) -> hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ spc () ++ str "using" ++ spc () ++ pr_constr c ++ @@ -878,6 +886,7 @@ let rec pr_tac inherited tac = str "using " ++ pr_id s), labstract | TacLetIn (recflag,llc,u) -> + let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in v 0 (hv 0 (pr_let_clauses recflag (pr_tac ltop) llc ++ str " in") ++ fnl () ++ pr_tac (llet,E) u), diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli index 31a626cea..b672e9c23 100644 --- a/parsing/pptactic.mli +++ b/parsing/pptactic.mli @@ -78,6 +78,8 @@ val pr_extend : (tolerability -> glob_tactic_expr -> std_ppcmds) -> int -> string -> typed_generic_argument list -> std_ppcmds +val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds + val pr_raw_tactic : env -> raw_tactic_expr -> std_ppcmds val pr_raw_tactic_level : env -> tolerability -> raw_tactic_expr -> std_ppcmds diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml index 1060928d1..99d8e3c4a 100644 --- a/parsing/ppvernac.ml +++ b/parsing/ppvernac.ml @@ -804,10 +804,7 @@ let rec pr_vernac = function (Global.env()) body in hov 1 - (((*if !Flags.p1 then - (if rc then str "Recursive " else mt()) ++ - str "Tactic Definition " else*) - (* Rec by default *) str "Ltac ") ++ + ((str "Ltac ") ++ prlist_with_sep (fun () -> fnl() ++ str"with ") pr_tac_body l) | VernacHints (local,dbnames,h) -> pr_hints local dbnames h pr_constr pr_pattern_expr diff --git a/parsing/printer.ml b/parsing/printer.ml index f59f9f2f3..561c85785 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -28,6 +28,7 @@ open Refiner open Pfedit open Ppconstr open Constrextern +open Tacexpr let emacs_str s alts = match !Flags.print_emacs, !Flags.print_emacs_safechar with @@ -421,14 +422,14 @@ let pr_prim_rule = function | Intro id -> str"intro " ++ pr_id id - | Intro_replacing id -> - (str"intro replacing " ++ pr_id id) - - | Cut (b,id,t) -> - if b then - (str"assert " ++ pr_constr t) - else - (str"cut " ++ pr_constr t ++ str ";[intro " ++ pr_id id ++ str "|idtac]") + | Cut (b,replace,id,t) -> + if b then + (* TODO: express "replace" *) + (str"assert " ++ str"(" ++ pr_id id ++ str":" ++ pr_lconstr t ++ str")") + else + let cl = if replace then str"clear " ++ pr_id id ++ str"; " else mt() in + (str"cut " ++ pr_constr t ++ + str ";[" ++ cl ++ str"intro " ++ pr_id id ++ str"|idtac]") | FixRule (f,n,[]) -> (str"fix " ++ pr_id f ++ str"/" ++ int n) @@ -472,7 +473,7 @@ let pr_prim_rule = function | Move (withdep,id1,id2) -> (str (if withdep then "dependent " else "") ++ - str"move " ++ pr_id id1 ++ str " after " ++ pr_id id2) + str"move " ++ pr_id id1 ++ pr_move_location pr_id id2) | Rename (id1,id2) -> (str "rename " ++ pr_id id1 ++ str " into " ++ pr_id id2) diff --git a/parsing/printer.mli b/parsing/printer.mli index a4e0cd570..32f051948 100644 --- a/parsing/printer.mli +++ b/parsing/printer.mli @@ -22,6 +22,7 @@ open Termops open Evd open Proof_type open Rawterm +open Tacexpr (*i*) (* These are the entry points for printing terms, context, tac, ... *) diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 index 66a74ad16..56afbc9be 100644 --- a/parsing/q_coqast.ml4 +++ b/parsing/q_coqast.ml4 @@ -71,7 +71,7 @@ let mlexpr_of_by_notation f = function | Genarg.ByNotation (loc,s) -> <:expr< Genarg.ByNotation $dloc$ $str:s$ >> let mlexpr_of_intro_pattern = function - | Genarg.IntroWildcard loc -> <:expr< Genarg.IntroWildcard $mlexpr_of_loc loc$ >> + | Genarg.IntroWildcard -> <:expr< Genarg.IntroWildcard >> | Genarg.IntroAnonymous -> <:expr< Genarg.IntroAnonymous >> | Genarg.IntroFresh id -> <:expr< Genarg.IntroFresh (mlexpr_of_ident $dloc$ id) >> | Genarg.IntroIdentifier id -> @@ -242,6 +242,11 @@ let mlexpr_of_binding = mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_constr let mlexpr_of_constr_with_binding = mlexpr_of_pair mlexpr_of_constr mlexpr_of_binding_kind +let mlexpr_of_move_location f = function + | Tacexpr.MoveAfter id -> <:expr< Tacexpr.MoveAfter $f id$ >> + | Tacexpr.MoveBefore id -> <:expr< Tacexpr.MoveBefore $f id$ >> + | Tacexpr.MoveToEnd b -> <:expr< Tacexpr.MoveToEnd $mlexpr_of_bool b$ >> + let mlexpr_of_induction_arg = function | Tacexpr.ElimOnConstr c -> <:expr< Tacexpr.ElimOnConstr $mlexpr_of_constr_with_binding c$ >> @@ -282,13 +287,13 @@ let mlexpr_of_message_token = function let rec mlexpr_of_atomic_tactic = function (* Basic tactics *) | Tacexpr.TacIntroPattern pl -> - let pl = mlexpr_of_list mlexpr_of_intro_pattern pl in + let pl = mlexpr_of_list (mlexpr_of_located mlexpr_of_intro_pattern) pl in <:expr< Tacexpr.TacIntroPattern $pl$ >> | Tacexpr.TacIntrosUntil h -> <:expr< Tacexpr.TacIntrosUntil $mlexpr_of_quantified_hypothesis h$ >> | Tacexpr.TacIntroMove (idopt,idopt') -> let idopt = mlexpr_of_ident_option idopt in - let idopt'=mlexpr_of_option (mlexpr_of_located mlexpr_of_ident) idopt' in + let idopt'= mlexpr_of_move_location mlexpr_of_hyp idopt' in <:expr< Tacexpr.TacIntroMove $idopt$ $idopt'$ >> | Tacexpr.TacAssumption -> <:expr< Tacexpr.TacAssumption >> @@ -299,7 +304,7 @@ let rec mlexpr_of_atomic_tactic = function | Tacexpr.TacVmCastNoCheck c -> <:expr< Tacexpr.TacVmCastNoCheck $mlexpr_of_constr c$ >> | Tacexpr.TacApply (b,false,cb) -> - <:expr< Tacexpr.TacApply $mlexpr_of_bool b$ False $mlexpr_of_constr_with_binding cb$ >> + <:expr< Tacexpr.TacApply $mlexpr_of_bool b$ False $mlexpr_of_list mlexpr_of_constr_with_binding cb$ >> | Tacexpr.TacElim (false,cb,cbo) -> let cb = mlexpr_of_constr_with_binding cb in let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in @@ -335,7 +340,7 @@ let rec mlexpr_of_atomic_tactic = function | Tacexpr.TacCut c -> <:expr< Tacexpr.TacCut $mlexpr_of_constr c$ >> | Tacexpr.TacAssert (t,ipat,c) -> - let ipat = mlexpr_of_intro_pattern ipat in + let ipat = mlexpr_of_located mlexpr_of_intro_pattern ipat in <:expr< Tacexpr.TacAssert $mlexpr_of_option mlexpr_of_tactic t$ $ipat$ $mlexpr_of_constr c$ >> | Tacexpr.TacGeneralize cl -> @@ -351,18 +356,18 @@ let rec mlexpr_of_atomic_tactic = function $mlexpr_of_bool b$ >> (* Derived basic tactics *) - | Tacexpr.TacSimpleInduction h -> - <:expr< Tacexpr.TacSimpleInduction ($mlexpr_of_quantified_hypothesis h$) >> - | Tacexpr.TacNewInduction (false,cl,cbo,ids,cls) -> - let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in - let ids = mlexpr_of_intro_pattern ids in - <:expr< Tacexpr.TacNewInduction False $mlexpr_of_list mlexpr_of_induction_arg cl$ $cbo$ $ids$ $mlexpr_of_option mlexpr_of_clause cls$ >> - | Tacexpr.TacSimpleDestruct h -> - <:expr< Tacexpr.TacSimpleDestruct $mlexpr_of_quantified_hypothesis h$ >> - | Tacexpr.TacNewDestruct (false,c,cbo,ids,cls) -> - let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in - let ids = mlexpr_of_intro_pattern ids in - <:expr< Tacexpr.TacNewDestruct False $mlexpr_of_list mlexpr_of_induction_arg c$ $cbo$ $ids$ $mlexpr_of_option mlexpr_of_clause cls$ >> + | Tacexpr.TacSimpleInductionDestruct (isrec,h) -> + <:expr< Tacexpr.TacSimpleInductionDestruct $mlexpr_of_bool isrec$ + $mlexpr_of_quantified_hypothesis h$ >> + | Tacexpr.TacInductionDestruct (isrec,ev,l) -> + <:expr< Tacexpr.TacInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_bool ev$ + $mlexpr_of_list (mlexpr_of_quadruple + (mlexpr_of_list mlexpr_of_induction_arg) + (mlexpr_of_option mlexpr_of_constr_with_binding) + (mlexpr_of_pair + (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern)) + (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern))) + (mlexpr_of_option mlexpr_of_clause)) l$ >> (* Context management *) | Tacexpr.TacClear (b,l) -> @@ -374,7 +379,7 @@ let rec mlexpr_of_atomic_tactic = function | Tacexpr.TacMove (dep,id1,id2) -> <:expr< Tacexpr.TacMove $mlexpr_of_bool dep$ $mlexpr_of_hyp id1$ - $mlexpr_of_hyp id2$ >> + $mlexpr_of_move_location mlexpr_of_hyp id2$ >> (* Constructors *) | Tacexpr.TacLeft (ev,l) -> diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4 index 513d345b5..9b59ba8e5 100644 --- a/parsing/q_util.ml4 +++ b/parsing/q_util.ml4 @@ -53,6 +53,11 @@ let mlexpr_of_triple m1 m2 m3 (a1,a2,a3)= let loc = join_loc (MLast.loc_of_expr e1) (MLast.loc_of_expr e3) in <:expr< ($e1$, $e2$, $e3$) >> +let mlexpr_of_quadruple m1 m2 m3 m4 (a1,a2,a3,a4)= + let e1 = m1 a1 and e2 = m2 a2 and e3 = m3 a3 and e4 = m4 a4 in + let loc = join_loc (MLast.loc_of_expr e1) (MLast.loc_of_expr e4) in + <:expr< ($e1$, $e2$, $e3$, $e4$) >> + (* We don't give location for tactic quotation! *) let loc = dummy_loc diff --git a/parsing/q_util.mli b/parsing/q_util.mli index f6660c9d5..a160310e4 100644 --- a/parsing/q_util.mli +++ b/parsing/q_util.mli @@ -20,6 +20,10 @@ val mlexpr_of_triple : ('a -> MLast.expr) -> ('b -> MLast.expr) -> ('c -> MLast.expr) -> 'a * 'b * 'c -> MLast.expr +val mlexpr_of_quadruple : + ('a -> MLast.expr) -> ('b -> MLast.expr) -> + ('c -> MLast.expr) -> ('d -> MLast.expr) -> 'a * 'b * 'c * 'd -> MLast.expr + val mlexpr_of_bool : bool -> MLast.expr val mlexpr_of_int : int -> MLast.expr diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index f0c020908..63a56f0d1 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -374,42 +374,41 @@ let restrict_upon_filter evd evi evk p args = else evd,evk,args -exception Dependency_error of identifier +let collect_vars c = + let rec collrec acc c = + match kind_of_term c with + | Var id -> list_add_set id acc + | _ -> fold_constr collrec acc c + in + collrec [] c -module EvkOrd = -struct - type t = Term.existential_key - let compare = Pervasives.compare -end +type clear_dependency_error = +| OccurHypInSimpleClause of identifier option +| EvarTypingBreak of existential -module EvkSet = Set.Make(EvkOrd) +exception ClearDependencyError of identifier * clear_dependency_error -let rec check_and_clear_in_constr evdref c ids hist = +let rec check_and_clear_in_constr evdref err ids c = (* returns a new constr where all the evars have been 'cleaned' (ie the hypotheses ids have been removed from the contexts of - evars *) + evars) *) let check id' = if List.mem id' ids then - raise (Dependency_error id') + raise (ClearDependencyError (id',err)) in match kind_of_term c with - | ( Rel _ | Meta _ | Sort _ ) -> c - - | ( Const _ | Ind _ | Construct _ ) -> - let vars = Environ.vars_of_global (Global.env()) c in - List.iter check vars; c + | Var id' -> + check id'; c - | Var id' -> - check id'; mkVar id' + | ( Const _ | Ind _ | Construct _ ) -> + let vars = Environ.vars_of_global (Global.env()) c in + List.iter check vars; c | Evar (evk,l as ev) -> if Evd.is_defined_evar !evdref ev then (* If evk is already defined we replace it by its definition *) - let nc = nf_evar (evars_of !evdref) c in - (check_and_clear_in_constr evdref nc ids hist) - else if EvkSet.mem evk hist then - (* Loop detection => do nothing *) - c + let nc = whd_evar (evars_of !evdref) c in + (check_and_clear_in_constr evdref err ids nc) else (* We check for dependencies to elements of ids in the evar_info corresponding to e and in the instance of @@ -418,16 +417,32 @@ let rec check_and_clear_in_constr evdref c ids hist = removed *) let evi = Evd.find (evars_of !evdref) evk in let ctxt = Evd.evar_filtered_context evi in - let (nhyps,nargs,rids) = + let (nhyps,nargs,rids) = List.fold_right2 (fun (rid,ob,c as h) a (hy,ar,ri) -> - match kind_of_term a with - | Var id -> if List.mem id ids then (hy,ar,id::ri) else (h::hy,a::ar,ri) - | _ -> (h::hy,a::ar,ri) - ) + (* Check if some id to clear occurs in the instance + a of rid in ev and remember the dependency *) + match + List.filter (fun id -> List.mem id ids) (collect_vars a) + with + | id :: _ -> (hy,ar,(rid,id)::ri) + | _ -> + (* Check if some rid to clear in the context of ev + has dependencies in another hyp of the context of ev + and transitively remember the dependency *) + match List.filter (fun (id,_) -> occur_var_in_decl (Global.env()) id h) ri with + | rid' :: _ -> (hy,ar,(rid,List.assoc rid ri)::ri) + | _ -> + (* No dependency at all, we can keep this ev's context hyp *) + (h::hy,a::ar,ri)) ctxt (Array.to_list l) ([],[],[]) in - (* nconcl must be computed ids (non instanciated hyps) *) - let nconcl = check_and_clear_in_constr evdref (evar_concl evi) rids (EvkSet.add evk hist) in + (* Check if some rid to clear in the context of ev has dependencies + in the type of ev and adjust the source of the dependency *) + let nconcl = + try check_and_clear_in_constr evdref (EvarTypingBreak ev) + (List.map fst rids) (evar_concl evi) + with ClearDependencyError (rid,err) -> + raise (ClearDependencyError (List.assoc rid rids,err)) in let env = Sign.fold_named_context push_named nhyps ~init:(empty_env) in let ev'= e_new_evar evdref env ~src:(evar_source evk !evdref) nconcl in @@ -435,25 +450,19 @@ let rec check_and_clear_in_constr evdref c ids hist = let (evk',_) = destEvar ev' in mkEvar(evk', Array.of_list nargs) - | _ -> map_constr (fun c -> check_and_clear_in_constr evdref c ids hist) c - -exception OccurHypInSimpleClause of identifier * identifier option + | _ -> map_constr (check_and_clear_in_constr evdref err ids) c let clear_hyps_in_evi evdref hyps concl ids = - (* clear_evar_hyps erases hypotheses ids in hyps, checking if some + (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some hypothesis does not depend on a element of ids, and erases ids in the contexts of the evars occuring in evi *) - let nconcl = try check_and_clear_in_constr evdref concl ids EvkSet.empty - with Dependency_error id' -> raise (OccurHypInSimpleClause (id',None)) in - let (nhyps,_) = - let check_context (id,ob,c) = - try - (id, - (match ob with - None -> None - | Some b -> Some (check_and_clear_in_constr evdref b ids EvkSet.empty)), - check_and_clear_in_constr evdref c ids EvkSet.empty) - with Dependency_error id' -> raise (OccurHypInSimpleClause (id',Some id)) + let nconcl = + check_and_clear_in_constr evdref (OccurHypInSimpleClause None) ids concl in + let nhyps = + let check_context (id,ob,c) = + let err = OccurHypInSimpleClause (Some id) in + (id, Option.map (check_and_clear_in_constr evdref err ids) ob, + check_and_clear_in_constr evdref err ids c) in let check_value vk = match !vk with @@ -470,6 +479,7 @@ let clear_hyps_in_evi evdref hyps concl ids = in (nhyps,nconcl) + (* Expand rels and vars that are bound to other rels or vars so that dependencies in variables are canonically associated to the most ancient variable in its family of aliased variables *) diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index c48c97910..d11e1fa2a 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -176,7 +176,11 @@ val pr_tycon : env -> type_constraint -> Pp.std_ppcmds (* Removing hyps in evars'context; *) (* raise OccurHypInSimpleClause if the removal breaks dependencies *) -exception OccurHypInSimpleClause of identifier * identifier option +type clear_dependency_error = +| OccurHypInSimpleClause of identifier option +| EvarTypingBreak of existential + +exception ClearDependencyError of identifier * clear_dependency_error val clear_hyps_in_evi : evar_defs ref -> named_context_val -> types -> identifier list -> named_context_val * types diff --git a/pretyping/evd.ml b/pretyping/evd.ml index ecc63ce94..270dac01a 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -523,6 +523,8 @@ let pr_sort_constraints (_,sm) = pr_sort_cstrs sm let meta_list evd = metamap_to_list evd.metas +let find_meta evd mv = Metamap.find mv evd.metas + let undefined_metas evd = List.sort Pervasives.compare (map_succeed (function | (n,Clval(_,_,typ)) -> failwith "" diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 6aa26aa43..cb7429002 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -100,6 +100,8 @@ val sig_sig : 'a sigma -> evar_map (*********************************************************************) (* Meta map *) +module Metamap : Map.S with type key = metavariable + module Metaset : Set.S with type elt = metavariable val meta_exists : (metavariable -> bool) -> Metaset.t -> bool @@ -197,6 +199,7 @@ val extract_all_conv_pbs : evar_defs -> evar_defs * evar_constraint list (* Metas *) +val find_meta : evar_defs -> metavariable -> clbinding val meta_list : evar_defs -> (metavariable * clbinding) list val meta_defined : evar_defs -> metavariable -> bool (* [meta_fvalue] raises [Not_found] if meta not in map or [Anomaly] if diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 6c029a161..422ee57d4 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -111,7 +111,6 @@ val whd_betadeltaiota_nolet_stack : contextual_stack_reduction_function val whd_betaetalet_stack : local_stack_reduction_function val whd_betalet_stack : local_stack_reduction_function -val whd_state : local_state_reduction_function val whd_beta_state : local_state_reduction_function val whd_betaiota_state : local_state_reduction_function val whd_betaiotazeta_state : local_state_reduction_function diff --git a/pretyping/unification.ml b/pretyping/unification.ml index a29dca57c..dbf7d6469 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -239,9 +239,9 @@ let unify_0_with_initial_metas subst conv_at_top env sigma cv_pb flags m n = | Some c -> unirec_rec curenv pb b substn cM (whd_betaiotazeta (mkApp(c,l2))) | None -> - error_cannot_unify env sigma (cM,cN) + error_cannot_unify curenv sigma (cM,cN) else - error_cannot_unify env sigma (cM,cN) + error_cannot_unify curenv sigma (cM,cN) in if (not(occur_meta m)) && diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 855d388c4..17f63933f 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -22,25 +22,28 @@ open Refiner (* w_tactic pour instantiate *) -let w_refine ev rawc evd = - if Evd.is_defined (evars_of evd) ev then +let w_refine evk rawc evd = + if Evd.is_defined (evars_of evd) evk then error "Instantiate called on already-defined evar"; - let e_info = Evd.find (evars_of evd) ev in + let e_info = Evd.find (evars_of evd) evk in let env = Evd.evar_env e_info in - let sigma,typed_c = + let sigma,typed_c = try Pretyping.Default.understand_tcc ~resolve_classes:false (evars_of evd) env ~expected_type:e_info.evar_concl rawc - with _ -> error ("The term is not well-typed in the environment of " ^ - string_of_existential ev) + with _ -> + let loc = Rawterm.loc_of_rawconstr rawc in + user_err_loc + (loc,"",Pp.str ("Instance is not well-typed in the environment of " ^ + string_of_existential evk)) in - evar_define ev typed_c (evars_reset_evd sigma evd) + evar_define evk typed_c (evars_reset_evd sigma evd) (* vernac command Existential *) let instantiate_pf_com n com pfts = let gls = top_goal_of_pftreestate pfts in let sigma = gls.sigma in - let (sp,evi) (* as evc *) = + let (evk,evi) = let evl = Evarutil.non_instantiated sigma in if (n <= 0) then error "incorrect existential variable index" @@ -52,5 +55,5 @@ let instantiate_pf_com n com pfts = let env = Evd.evar_env evi in let rawc = Constrintern.intern_constr sigma env com in let evd = create_goal_evar_defs sigma in - let evd' = w_refine sp rawc evd in + let evd' = w_refine evk rawc evd in change_constraints_pftreestate (evars_of evd') pfts diff --git a/proofs/logic.ml b/proofs/logic.ml index 74c2a4bef..818a32cea 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -27,6 +27,7 @@ open Typeops open Type_errors open Retyping open Evarutil +open Tacexpr type refiner_error = @@ -47,6 +48,7 @@ open Pretype_errors let rec catchable_exception = function | Stdpp.Exc_located(_,e) -> catchable_exception e + | LtacLocated(_,e) -> catchable_exception e | Util.UserError _ | TypeError _ | RefinerError _ | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ | PretypeError (_,VarNotFound _) @@ -71,11 +73,10 @@ let with_check = Flags.with_option check (instead of iterating on the list of identifier to be removed, which forces the user to give them in order). *) -let clear_hyps sigma ids gl = +let clear_hyps sigma ids sign cl = let evdref = ref (Evd.create_goal_evar_defs sigma) in - let (hyps,concl) = - Evarutil.clear_hyps_in_evi evdref gl.evar_hyps gl.evar_concl ids in - (mk_goal hyps concl gl.evar_extra, evars_of !evdref) + let (hyps,concl) = Evarutil.clear_hyps_in_evi evdref sign cl ids in + (hyps,concl,evars_of !evdref) (* The ClearBody tactic *) @@ -84,13 +85,13 @@ let clear_hyps sigma ids gl = let apply_to_hyp sign id f = try apply_to_hyp sign id f with Hyp_not_found -> - if !check then error "No such assumption" + if !check then error "No such assumption." else sign let apply_to_hyp_and_dependent_on sign id f g = try apply_to_hyp_and_dependent_on sign id f g with Hyp_not_found -> - if !check then error "No such assumption" + if !check then error "No such assumption." else sign let check_typability env sigma c = @@ -110,7 +111,7 @@ let remove_hyp_body env sigma id = apply_to_hyp_and_dependent_on (named_context_val env) id (fun (_,c,t) _ -> match c with - | None -> error ((string_of_id id)^" is not a local definition") + | None -> error ((string_of_id id)^" is not a local definition.") | Some c ->(id,None,t)) (fun (id',c,t as d) sign -> (if !check then @@ -127,24 +128,42 @@ let remove_hyp_body env sigma id = (* Auxiliary functions for primitive MOVE tactic * - * [move_after with_dep toleft (left,(hfrom,typfrom),right) hto] moves - * hyp [hfrom] just after the hyp [hto] which belongs to the hyps on the + * [move_hyp with_dep toleft (left,(hfrom,typfrom),right) hto] moves + * hyp [hfrom] at location [hto] which belongs to the hyps on the * left side [left] of the full signature if [toleft=true] or to the hyps * on the right side [right] if [toleft=false]. * If [with_dep] then dependent hypotheses are moved accordingly. *) +let error_no_such_hypothesis id = + error ("No such hypothesis: " ^ string_of_id id ^ ".") + +let rec get_hyp_after h = function + | [] -> error_no_such_hypothesis h + | (hyp,_,_) :: right -> + if hyp = h then + match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveToEnd false + else + get_hyp_after h right + let split_sign hfrom hto l = let rec splitrec left toleft = function - | [] -> error ("No such hypothesis : " ^ (string_of_id hfrom)) + | [] -> error_no_such_hypothesis hfrom | (hyp,c,typ) as d :: right -> if hyp = hfrom then - (left,right,d,toleft) - else - splitrec (d::left) (toleft or (hyp = hto)) right + (left,right,d, toleft or hto = MoveToEnd true) + else + splitrec (d::left) + (toleft or hto = MoveAfter hyp or hto = MoveBefore hyp) + right in splitrec [] false l -let move_after with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto = +let hyp_of_move_location = function + | MoveAfter id -> id + | MoveBefore id -> id + | _ -> assert false + +let move_hyp with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto = let env = Global.env() in let test_dep (hyp,c,typ as d) (hyp2,c,typ2 as d2) = if toleft @@ -152,23 +171,27 @@ let move_after with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto = else occur_var_in_decl env hyp d2 in let rec moverec first middle = function - | [] -> error ("No such hypothesis : " ^ (string_of_id hto)) + | [] -> + if match hto with MoveToEnd _ -> false | _ -> true then + error_no_such_hypothesis (hyp_of_move_location hto); + List.rev first @ List.rev middle + | (hyp,_,_) :: _ as right when hto = MoveBefore hyp -> + List.rev first @ List.rev middle @ right | (hyp,_,_) as d :: right -> let (first',middle') = if List.exists (test_dep d) middle then - if with_dep & (hyp <> hto) then + if with_dep & hto <> MoveAfter hyp then (first, d::middle) else - error - ("Cannot move "^(string_of_id idfrom)^" after " - ^(string_of_id hto) - ^(if toleft then ": it occurs in " else ": it depends on ") - ^(string_of_id hyp)) - else + errorlabstrm "" (str "Cannot move " ++ pr_id idfrom ++ + pr_move_location pr_id hto ++ + str (if toleft then ": it occurs in " else ": it depends on ") + ++ pr_id hyp ++ str ".") + else (d::first, middle) in - if hyp = hto then - (List.rev first')@(List.rev middle')@right + if hto = MoveAfter hyp then + List.rev first' @ List.rev middle' @ right else moverec first' middle' right in @@ -184,53 +207,11 @@ let move_after with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto = List.fold_left (fun sign d -> push_named_context_val d sign) right left -let check_backward_dependencies sign d = - if not (Idset.for_all - (fun id -> mem_named_context id sign) - (global_vars_set_of_decl (Global.env()) d)) - then - error "Can't introduce at that location: free variable conflict" - - -let check_forward_dependencies id tail = - let env = Global.env() in - List.iter - (function (id',_,_ as decl) -> - if occur_var_in_decl env id decl then - error ((string_of_id id) ^ " is used in hypothesis " - ^ (string_of_id id'))) - tail - -let check_goal_dependency id cl = - let env = Global.env() in - if Idset.mem id (global_vars_set env cl) then - error (string_of_id id^" is used in conclusion") - let rename_hyp id1 id2 sign = apply_to_hyp_and_dependent_on sign id1 (fun (_,b,t) _ -> (id2,b,t)) (fun d _ -> map_named_declaration (replace_vars [id1,mkVar id2]) d) -let replace_hyp sign id d cl = - if !check then - check_goal_dependency id cl; - apply_to_hyp sign id - (fun sign _ tail -> - if !check then - (check_backward_dependencies sign d; - check_forward_dependencies id tail); - d) - -(* why we dont check that id does not appear in tail ??? *) -let insert_after_hyp sign id d = - try - insert_after_hyp sign id d - (fun sign -> - if !check then check_backward_dependencies sign d) - with Hyp_not_found -> - if !check then error "No such assumption" - else sign - (************************************************************************) (************************************************************************) (* Implementation of the logical rules *) @@ -376,19 +357,14 @@ and mk_casegoals sigma goal goalacc p c = (acc'',lbrty,conclty) -let error_use_instantiate () = - errorlabstrm "Logic.prim_refiner" - (str"cannot intro when there are open metavars in the domain type" ++ - spc () ++ str"- use Instantiate") - let convert_hyp sign sigma (id,b,bt as d) = apply_to_hyp sign id (fun _ (_,c,ct) _ -> let env = Global.env_of_context sign in if !check && not (is_conv env sigma bt ct) then - error ("Incorrect change of the type of "^(string_of_id id)); + error ("Incorrect change of the type of "^(string_of_id id)^"."); if !check && not (Option.Misc.compare (is_conv env sigma) b c) then - error ("Incorrect change of the body of "^(string_of_id id)); + error ("Incorrect change of the body of "^(string_of_id id)^"."); d) (* Normalizing evars in a goal. Called by tactic Local_constraints @@ -421,12 +397,10 @@ let prim_refiner r sigma goal = error "New variable is already declared"; (match kind_of_term (strip_outer_cast cl) with | Prod (_,c1,b) -> - if occur_meta c1 then error_use_instantiate(); let sg = mk_goal (push_named_context_val (id,None,c1) sign) (subst1 (mkVar id) b) in ([sg], sigma) | LetIn (_,c1,t1,b) -> - if occur_meta c1 or occur_meta t1 then error_use_instantiate(); let sg = mk_goal (push_named_context_val (id,Some c1,t1) sign) (subst1 (mkVar id) b) in @@ -434,28 +408,19 @@ let prim_refiner r sigma goal = | _ -> raise (RefinerError IntroNeedsProduct)) - | Intro_replacing id -> - (match kind_of_term (strip_outer_cast cl) with - | Prod (_,c1,b) -> - if occur_meta c1 then error_use_instantiate(); - let sign' = replace_hyp sign id (id,None,c1) cl in - let sg = mk_goal sign' (subst1 (mkVar id) b) in - ([sg], sigma) - | LetIn (_,c1,t1,b) -> - if occur_meta c1 then error_use_instantiate(); - let sign' = replace_hyp sign id (id,Some c1,t1) cl in - let sg = mk_goal sign' (subst1 (mkVar id) b) in - ([sg], sigma) - | _ -> - raise (RefinerError IntroNeedsProduct)) - - | Cut (b,id,t) -> - if !check && mem_named_context id (named_context_of_val sign) then - error "New variable is already declared"; - if occur_meta t then error_use_instantiate(); + | Cut (b,replace,id,t) -> let sg1 = mk_goal sign (nf_betaiota t) in - let sg2 = mk_goal (push_named_context_val (id,None,t) sign) cl in - if b then ([sg1;sg2],sigma) else ([sg2;sg1], sigma) + let sign,cl,sigma = + if replace then + let nexthyp = get_hyp_after id (named_context_of_val sign) in + let sign,cl,sigma = clear_hyps sigma [id] sign cl in + move_hyp true false ([],(id,None,t),named_context_of_val sign) + nexthyp, + cl,sigma + else + (push_named_context_val (id,None,t) sign),cl,sigma in + let sg2 = mk_goal sign cl in + if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma) | FixRule (f,n,rest) -> let rec check_ind env k cl = @@ -465,10 +430,10 @@ let prim_refiner r sigma goal = try fst (find_inductive env sigma c1) with Not_found -> - error "cannot do a fixpoint on a non inductive type" + error "Cannot do a fixpoint on a non inductive type." else check_ind (push_rel (na,None,c1) env) (k-1) b - | _ -> error "not enough products" + | _ -> error "Not enough products." in let (sp,_) = check_ind env n cl in let all = (f,n,cl)::rest in @@ -476,10 +441,10 @@ let prim_refiner r sigma goal = | (f,n,ar)::oth -> let (sp',_) = check_ind env n ar in if not (sp=sp') then - error ("fixpoints should be on the same " ^ - "mutual inductive declaration"); + error ("Fixpoints should be on the same " ^ + "mutual inductive declaration."); if !check && mem_named_context f (named_context_of_val sign) then - error "name already used in the environment"; + error "Name already used in the environment"; mk_sign (push_named_context_val (f,None,ar) sign) oth | [] -> List.map (fun (_,_,c) -> mk_goal sign c) all @@ -496,8 +461,7 @@ let prim_refiner r sigma goal = let _ = find_coinductive env sigma b in () with Not_found -> error ("All methods must construct elements " ^ - "in coinductiv-> goal -e types") + "in coinductive types.") in let all = (f,cl)::others in List.iter (fun (_,c) -> check_is_coind env c) all; @@ -505,7 +469,7 @@ e types") | (f,ar)::oth -> (try (let _ = lookup_named_val f sign in - error "name already used in the environment") + error "Name already used in the environment.") with | Not_found -> mk_sign (push_named_context_val (f,None,ar) sign) oth) @@ -534,8 +498,8 @@ e types") (* And now the structural rules *) | Thin ids -> - let (ngl, nsigma) = clear_hyps sigma ids goal in - ([ngl], nsigma) + let (hyps,concl,nsigma) = clear_hyps sigma ids sign cl in + ([mk_goal hyps concl], nsigma) | ThinBody ids -> let clear_aux env id = @@ -551,13 +515,13 @@ e types") let (left,right,declfrom,toleft) = split_sign hfrom hto (named_context_of_val sign) in let hyps' = - move_after withdep toleft (left,declfrom,right) hto in + move_hyp withdep toleft (left,declfrom,right) hto in ([mk_goal hyps' cl], sigma) | Rename (id1,id2) -> if !check & id1 <> id2 && List.mem id2 (ids_of_named_context (named_context_of_val sign)) then - error ((string_of_id id2)^" is already used"); + error ((string_of_id id2)^" is already used."); let sign' = rename_hyp id1 id2 sign in let cl' = replace_vars [id1,mkVar id2] cl in ([mk_goal sign' cl'], sigma) @@ -618,20 +582,9 @@ let prim_extractor subfun vl pft = let cb = subst_proof_vars vl b in let cty = subst_proof_vars vl ty in mkLetIn (Name id, cb, cty, subfun (add_proof_var id vl) spf) - | _ -> error "incomplete proof!") + | _ -> error "Incomplete proof!") - | Some (Prim (Intro_replacing id),[spf]) -> - (match kind_of_term (strip_outer_cast cl) with - | Prod (_,ty,_) -> - let cty = subst_proof_vars vl ty in - mkLambda (Name id, cty, subfun (add_proof_var id vl) spf) - | LetIn (_,b,ty,_) -> - let cb = subst_proof_vars vl b in - let cty = subst_proof_vars vl ty in - mkLetIn (Name id, cb, cty, subfun (add_proof_var id vl) spf) - | _ -> error "incomplete proof!") - - | Some (Prim (Cut (b,id,t)),[spf1;spf2]) -> + | Some (Prim (Cut (b,_,id,t)),[spf1;spf2]) -> let spf1, spf2 = if b then spf1, spf2 else spf2, spf1 in mkLetIn (Name id,subfun vl spf1,subst_proof_vars vl t, subfun (add_proof_var id vl) spf2) diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml index dfe0ab76d..6f8aebf0e 100644 --- a/proofs/proof_type.ml +++ b/proofs/proof_type.ml @@ -28,8 +28,7 @@ open Pattern type prim_rule = | Intro of identifier - | Intro_replacing of identifier - | Cut of bool * identifier * types + | Cut of bool * bool * identifier * types | FixRule of identifier * int * (identifier * int * constr) list | Cofix of identifier * (identifier * constr) list | Refine of constr @@ -37,7 +36,7 @@ type prim_rule = | Convert_hyp of named_declaration | Thin of identifier list | ThinBody of identifier list - | Move of bool * identifier * identifier + | Move of bool * identifier * identifier move_location | Rename of identifier * identifier | Change_evars @@ -94,3 +93,16 @@ and tactic_arg = type hyp_location = identifier Tacexpr.raw_hyp_location +type ltac_call_kind = + | LtacNotationCall of string + | LtacNameCall of ltac_constant + | LtacAtomCall of glob_atomic_tactic_expr * atomic_tactic_expr option ref + | LtacVarCall of identifier * glob_tactic_expr + | LtacConstrInterp of rawconstr * + ((identifier * constr) list * (identifier * identifier option) list) + +type ltac_trace = (loc * ltac_call_kind) list + +exception LtacLocated of (ltac_call_kind * ltac_trace * loc) * exn + +let abstract_tactic_box = ref (ref None) diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index c06aff7e1..2af581a1c 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -28,8 +28,7 @@ open Pattern type prim_rule = | Intro of identifier - | Intro_replacing of identifier - | Cut of bool * identifier * types + | Cut of bool * bool * identifier * types | FixRule of identifier * int * (identifier * int * constr) list | Cofix of identifier * (identifier * constr) list | Refine of constr @@ -37,7 +36,7 @@ type prim_rule = | Convert_hyp of named_declaration | Thin of identifier list | ThinBody of identifier list - | Move of bool * identifier * identifier + | Move of bool * identifier * identifier move_location | Rename of identifier * identifier | Change_evars @@ -128,3 +127,17 @@ and tactic_arg = Tacexpr.gen_tactic_arg type hyp_location = identifier Tacexpr.raw_hyp_location + +type ltac_call_kind = + | LtacNotationCall of string + | LtacNameCall of ltac_constant + | LtacAtomCall of glob_atomic_tactic_expr * atomic_tactic_expr option ref + | LtacVarCall of identifier * glob_tactic_expr + | LtacConstrInterp of rawconstr * + ((identifier * constr) list * (identifier * identifier option) list) + +type ltac_trace = (loc * ltac_call_kind) list + +exception LtacLocated of (ltac_call_kind * ltac_trace * loc) * exn + +val abstract_tactic_box : atomic_tactic_expr option ref ref diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 1ad7dcd0a..0014e9f72 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -189,7 +189,6 @@ let leaf g = let check_subproof_connection gl spfl = list_for_all2eq (fun g pf -> Evd.eq_evar_info g pf.goal) gl spfl - let abstract_operation syntax semantics gls = let (sgl_sigma,validation) = semantics gls in let hidden_proof = validation (List.map leaf sgl_sigma.it) in @@ -204,6 +203,7 @@ let abstract_tactic_expr ?(dflt=false) te tacfun gls = abstract_operation (Tactic(te,dflt)) tacfun gls let abstract_tactic ?(dflt=false) te = + !abstract_tactic_box := Some te; abstract_tactic_expr ~dflt (Tacexpr.TacAtom (dummy_loc,te)) let abstract_extended_tactic ?(dflt=false) s args = @@ -491,13 +491,18 @@ let tclNOTSAMEGOAL (tac : tactic) goal = (str"Tactic generated a subgoal identical to the original goal.") else rslt -let catch_failerror = function - | e when catchable_exception e -> check_for_interrupt () - | FailError (0,_) | Stdpp.Exc_located(_, FailError (0,_)) -> +let catch_failerror e = + if catchable_exception e then check_for_interrupt () + else match e with + | FailError (0,_) | Stdpp.Exc_located(_, FailError (0,_)) + | Stdpp.Exc_located(_, LtacLocated (_,FailError (0,_))) -> check_for_interrupt () | FailError (lvl,s) -> raise (FailError (lvl - 1, s)) - | Stdpp.Exc_located (s,FailError (lvl,s')) -> - raise (Stdpp.Exc_located (s,FailError (lvl - 1, s'))) + | Stdpp.Exc_located(s,FailError (lvl,s')) -> + raise (Stdpp.Exc_located(s,FailError (lvl - 1, s'))) + | Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl,s'))) -> + raise + (Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl - 1,s')))) | e -> raise e (* ORELSE0 t1 t2 tries to apply t1 and if it fails, applies t2 *) @@ -548,14 +553,8 @@ let ite_gen tcal tac_if continue tac_else gl= try tcal tac_if0 continue gl with (* Breakpoint *) - | e when catchable_exception e -> - check_for_interrupt (); tac_else0 e gl - | (FailError (0,_) | Stdpp.Exc_located(_, FailError (0,_))) as e -> - check_for_interrupt (); tac_else0 e gl - | FailError (lvl,s) -> raise (FailError (lvl - 1, s)) - | Stdpp.Exc_located (s,FailError (lvl,s')) -> - raise (Stdpp.Exc_located (s,FailError (lvl - 1, s'))) - + | e -> catch_failerror e; tac_else0 e gl + (* Try the first tactic and, if it succeeds, continue with the second one, and if it fails, use the third one *) diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml index f3152f331..34ddbb189 100644 --- a/proofs/tacexpr.ml +++ b/proofs/tacexpr.ml @@ -65,6 +65,20 @@ type hyp_location_flag = (* To distinguish body and type of local defs *) type 'a raw_hyp_location = 'a with_occurrences * hyp_location_flag +type 'id move_location = + | MoveAfter of 'id + | MoveBefore of 'id + | MoveToEnd of bool + +let no_move = MoveToEnd true + +open Pp + +let pr_move_location pr_id = function + | MoveAfter id -> brk(1,1) ++ str "after " ++ pr_id id + | MoveBefore id -> brk(1,1) ++ str "before " ++ pr_id id + | MoveToEnd toleft -> str (if toleft then " at bottom" else " at top") + type 'a induction_arg = | ElimOnConstr of 'a | ElimOnIdent of identifier located @@ -76,8 +90,10 @@ type inversion_kind = | FullInversionClear type ('c,'id) inversion_strength = - | NonDepInversion of inversion_kind * 'id list * intro_pattern_expr - | DepInversion of inversion_kind * 'c option * intro_pattern_expr + | NonDepInversion of + inversion_kind * 'id list * intro_pattern_expr located option + | DepInversion of + inversion_kind * 'c option * intro_pattern_expr located option | InversionUsing of 'c * 'id list type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b @@ -106,6 +122,11 @@ let simple_clause_of = function | _ -> error "not a simple clause (one hypothesis or conclusion)" +type ('constr,'id) induction_clause = + ('constr with_bindings induction_arg list * 'constr with_bindings option * + (intro_pattern_expr located option * intro_pattern_expr located option) * + 'id gclause option) + type multi = | Precisely of int | UpTo of int @@ -131,14 +152,14 @@ type ('a,'t) match_rule = type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr = (* Basic tactics *) - | TacIntroPattern of intro_pattern_expr list + | TacIntroPattern of intro_pattern_expr located list | TacIntrosUntil of quantified_hypothesis - | TacIntroMove of identifier option * identifier located option + | TacIntroMove of identifier option * 'id move_location | TacAssumption | TacExact of 'constr | TacExactNoCheck of 'constr | TacVmCastNoCheck of 'constr - | TacApply of advanced_flag * evars_flag * 'constr with_bindings + | TacApply of advanced_flag * evars_flag * 'constr with_bindings list | TacElim of evars_flag * 'constr with_bindings * 'constr with_bindings option | TacElimType of 'constr @@ -150,19 +171,14 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr = | TacCofix of identifier option | TacMutualCofix of hidden_flag * identifier * (identifier * 'constr) list | TacCut of 'constr - | TacAssert of 'tac option * intro_pattern_expr * 'constr + | TacAssert of 'tac option * intro_pattern_expr located * 'constr | TacGeneralize of ('constr with_occurrences * name) list | TacGeneralizeDep of 'constr | TacLetTac of name * 'constr * 'id gclause * letin_flag (* Derived basic tactics *) - | TacSimpleInduction of quantified_hypothesis - | TacNewInduction of evars_flag * 'constr with_bindings induction_arg list * - 'constr with_bindings option * intro_pattern_expr * 'id gclause option - | TacSimpleDestruct of quantified_hypothesis - | TacNewDestruct of evars_flag * 'constr with_bindings induction_arg list * - 'constr with_bindings option * intro_pattern_expr * 'id gclause option - + | TacSimpleInductionDestruct of rec_flag * quantified_hypothesis + | TacInductionDestruct of rec_flag * evars_flag * ('constr,'id) induction_clause list | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis | TacDecomposeAnd of 'constr | TacDecomposeOr of 'constr @@ -182,7 +198,7 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr = (* Context management *) | TacClear of bool * 'id list | TacClearBody of 'id list - | TacMove of bool * 'id * 'id + | TacMove of bool * 'id * 'id move_location | TacRename of ('id *'id) list | TacRevert of 'id list @@ -250,7 +266,7 @@ and ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg = | TacVoid | MetaIdArg of loc * bool * string | ConstrMayEval of ('constr,'cst) may_eval - | IntroPattern of intro_pattern_expr + | IntroPattern of intro_pattern_expr located | Reference of 'ref | Integer of int | TacCall of loc * diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 8e3e48d4f..bc2cb2b42 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -59,7 +59,7 @@ let pf_get_hyp gls id = try Sign.lookup_named id (pf_hyps gls) with Not_found -> - error ("No such hypothesis : " ^ (string_of_id id)) + error ("No such hypothesis: " ^ (string_of_id id)) let pf_get_hyp_typ gls id = let (_,_,ty)= (pf_get_hyp gls id) in @@ -176,15 +176,11 @@ let refiner = refiner let introduction_no_check id = refiner (Prim (Intro id)) -(* This does not check that the dependencies are correct *) -let intro_replacing_no_check whereid gl = - refiner (Prim (Intro_replacing whereid)) gl +let internal_cut_no_check replace id t gl = + refiner (Prim (Cut (true,replace,id,t))) gl -let internal_cut_no_check id t gl = - refiner (Prim (Cut (true,id,t))) gl - -let internal_cut_rev_no_check id t gl = - refiner (Prim (Cut (false,id,t))) gl +let internal_cut_rev_no_check replace id t gl = + refiner (Prim (Cut (false,replace,id,t))) gl let refine_no_check c gl = refiner (Prim (Refine c)) gl @@ -221,27 +217,16 @@ let mutual_cofix f others gl = (* Versions with consistency checks *) let introduction id = with_check (introduction_no_check id) -let intro_replacing id = with_check (intro_replacing_no_check id) -let internal_cut d t = with_check (internal_cut_no_check d t) -let internal_cut_rev d t = with_check (internal_cut_rev_no_check d t) +let internal_cut b d t = with_check (internal_cut_no_check b d t) +let internal_cut_rev b d t = with_check (internal_cut_rev_no_check b d t) let refine c = with_check (refine_no_check c) let convert_concl d sty = with_check (convert_concl_no_check d sty) let convert_hyp d = with_check (convert_hyp_no_check d) +let thin c = with_check (thin_no_check c) let thin_body c = with_check (thin_body_no_check c) let move_hyp b id id' = with_check (move_hyp_no_check b id id') let rename_hyp l = with_check (rename_hyp_no_check l) -let thin l gl = - try with_check (thin_no_check l) gl - with Evarutil.OccurHypInSimpleClause (id,ido) -> - match ido with - | None -> - errorlabstrm "" (pr_id id ++ str " is used in conclusion.") - | Some id' -> - errorlabstrm "" - (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str ".") - - (* Pretty-printers *) open Pp diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 2b007112f..d9a89329a 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -123,15 +123,15 @@ val change_constraints_pftreestate : val refiner : rule -> tactic val introduction_no_check : identifier -> tactic -val intro_replacing_no_check : identifier -> tactic -val internal_cut_no_check : identifier -> types -> tactic -val internal_cut_rev_no_check : identifier -> types -> tactic +val internal_cut_no_check : bool -> identifier -> types -> tactic +val internal_cut_rev_no_check : bool -> identifier -> types -> tactic val refine_no_check : constr -> tactic val convert_concl_no_check : types -> cast_kind -> tactic val convert_hyp_no_check : named_declaration -> tactic val thin_no_check : identifier list -> tactic val thin_body_no_check : identifier list -> tactic -val move_hyp_no_check : bool -> identifier -> identifier -> tactic +val move_hyp_no_check : + bool -> identifier -> identifier move_location -> tactic val rename_hyp_no_check : (identifier*identifier) list -> tactic val mutual_fix : identifier -> int -> (identifier * int * constr) list -> tactic @@ -140,15 +140,14 @@ val mutual_cofix : identifier -> (identifier * constr) list -> tactic (*s The most primitive tactics with consistency and type checking *) val introduction : identifier -> tactic -val intro_replacing : identifier -> tactic -val internal_cut : identifier -> types -> tactic -val internal_cut_rev : identifier -> types -> tactic +val internal_cut : bool -> identifier -> types -> tactic +val internal_cut_rev : bool -> identifier -> types -> tactic val refine : constr -> tactic val convert_concl : types -> cast_kind -> tactic val convert_hyp : named_declaration -> tactic val thin : identifier list -> tactic val thin_body : identifier list -> tactic -val move_hyp : bool -> identifier -> identifier -> tactic +val move_hyp : bool -> identifier -> identifier move_location -> tactic val rename_hyp : (identifier*identifier) list -> tactic (*s Tactics handling a list of goals. *) diff --git a/tactics/auto.ml b/tactics/auto.ml index c7e2230fd..53e493d14 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -641,7 +641,7 @@ let unify_resolve_nodelta (c,clenv) gls = 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 + h_apply true false [c,NoBindings] gls (* builds a hint database from a constr signature *) diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index 16e8bce3a..68f9aa922 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -1075,7 +1075,7 @@ let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause g | None -> let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in tclTHENLAST - (Tacmach.internal_cut_no_check name newt) + (Tacmach.internal_cut_no_check false name newt) (tclTHEN (Tactics.revert [name]) (Tactics.refine p)) | Some (t, ty) -> Tactics.refine diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml index cbb8996f6..3b45573f8 100644 --- a/tactics/decl_proof_instr.ml +++ b/tactics/decl_proof_instr.ml @@ -106,6 +106,9 @@ let clean_tmp gls = in clean_all (tmp_ids gls) gls +let assert_postpone id t = + assert_as true (dummy_loc, Genarg.IntroIdentifier id) t + (* start a proof *) let start_proof_tac gls= @@ -524,7 +527,7 @@ let instr_cut mkstat _thus _then cut gls0 = if _thus then thus_tac (mkVar c_id) c_stat [] gls else tclIDTAC gls in - tclTHENS (internal_cut c_id c_stat) + tclTHENS (assert_postpone c_id c_stat) [tclTHEN tcl_erase_info (just_tac _then cut info); thus_tac] gls0 @@ -572,14 +575,14 @@ let instr_rew _thus rew_side cut gls0 = match rew_side with Lhs -> let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in - tclTHENS (internal_cut c_id new_eq) + tclTHENS (assert_postpone c_id new_eq) [tclTHEN tcl_erase_info (tclTHENS (transitivity lhs) [just_tac;exact_check (mkVar last_id)]); thus_tac new_eq] gls0 | Rhs -> let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in - tclTHENS (internal_cut c_id new_eq) + tclTHENS (assert_postpone c_id new_eq) [tclTHEN tcl_erase_info (tclTHENS (transitivity rhs) [exact_check (mkVar last_id);just_tac]); @@ -600,7 +603,7 @@ let instr_claim _thus st gls0 = else tclIDTAC gls in let ninfo1 = {pm_stack= (if _thus then Focus_claim else Claim)::info.pm_stack} in - tclTHENS (internal_cut id st.st_it) + tclTHENS (assert_postpone id st.st_it) [tcl_change_info ninfo1; thus_tac] gls0 @@ -691,7 +694,7 @@ let instr_suffices _then cut gls0 = let c_term = applist (mkVar c_id,List.map mkMeta metas) in let thus_tac gls= thus_tac c_term c_head c_ctx gls in - tclTHENS (internal_cut c_id c_stat) + tclTHENS (assert_postpone c_id c_stat) [tclTHENLIST [ assume_tac ctx; tcl_erase_info; @@ -777,7 +780,7 @@ let consider_tac c hyps gls = | _ -> let id = pf_get_new_id (id_of_string "_tmp") gls in tclTHEN - (forward None (Genarg.IntroIdentifier id) c) + (forward None (dummy_loc, Genarg.IntroIdentifier id) c) (consider_match false [] [id] hyps) gls @@ -955,7 +958,7 @@ let suppose_tac hyps gls0 = let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in let old_clauses,stack = register_nodep_subcase id info.pm_stack in let ninfo2 = {pm_stack=stack} in - tclTHENS (internal_cut id clause) + tclTHENS (assert_postpone id clause) [tclTHENLIST [tcl_change_info ninfo1; assume_tac hyps; clear old_clauses]; @@ -1161,7 +1164,7 @@ let case_tac params pat_info hyps gls0 = register_dep_subcase (id,List.length hyps) (pf_env gls0) per_info pat_info.pat_pat ek in let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in - tclTHENS (internal_cut id clause) + tclTHENS (assert_postpone id clause) [tclTHENLIST [tcl_change_info ninfo1; assume_st (params@pat_info.pat_vars); diff --git a/tactics/elim.ml b/tactics/elim.ml index f0cc50d49..2601cd4c5 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -49,8 +49,8 @@ let introCaseAssumsThen tac ba = else (ba.branchnames, []), if n1 > n2 then snd (list_chop n2 case_thin_sign) else [] in - let introCaseAssums = tclTHEN (intros_pattern None l1) (intros_clearing l3) - in + let introCaseAssums = + tclTHEN (intros_pattern no_move l1) (intros_clearing l3) in (tclTHEN introCaseAssums (case_on_ba (tac l2) ba)) (* The following tactic Decompose repeatedly applies the diff --git a/tactics/elim.mli b/tactics/elim.mli index 16066a732..1fd8a9c2b 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -23,7 +23,7 @@ val introElimAssumsThen : (branch_assumptions -> tactic) -> branch_args -> tactic val introCaseAssumsThen : - (intro_pattern_expr list -> branch_assumptions -> tactic) -> + (intro_pattern_expr Util.located list -> branch_assumptions -> tactic) -> branch_args -> tactic val general_decompose : (identifier * constr -> bool) -> constr -> tactic diff --git a/tactics/equality.ml b/tactics/equality.ml index 5212711ae..cceda72f9 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -930,7 +930,7 @@ let injEq ipats (eq,(t,t1,t2)) eq_clause = ) with _ -> tclTHEN (inject_at_positions env sigma (eq,(t,t1,t2)) eq_clause posns) - (intros_pattern None ipats) + (intros_pattern no_move ipats) let inj ipats with_evars = onEquality with_evars (injEq ipats) diff --git a/tactics/equality.mli b/tactics/equality.mli index 0f93784af..7aeb7af37 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -9,6 +9,7 @@ (*i $Id$ i*) (*i*) +open Util open Names open Term open Sign @@ -75,9 +76,9 @@ val discrHyp : identifier -> tactic val discrEverywhere : evars_flag -> tactic val discr_tac : evars_flag -> constr with_ebindings induction_arg option -> tactic -val inj : intro_pattern_expr list -> evars_flag -> +val inj : intro_pattern_expr located list -> evars_flag -> constr with_ebindings -> tactic -val injClause : intro_pattern_expr list -> evars_flag -> +val injClause : intro_pattern_expr located list -> evars_flag -> constr with_ebindings induction_arg option -> tactic val injHyp : identifier -> tactic val injConcl : tactic diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index a2dc8a505..37498b13f 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -486,16 +486,14 @@ END TACTIC EXTEND apply_in -| ["apply" constr_with_bindings(c) "in" hyp(id) ] -> [ apply_in false id [c] ] -| ["apply" constr_with_bindings(c) "," constr_with_bindings_list_sep(cl,",") - "in" hyp(id) ] -> [ apply_in false id (c::cl) ] +| ["apply" ne_constr_with_bindings_list_sep(cl,",") "in" hyp(id) ] -> + [ apply_in false id cl ] END TACTIC EXTEND eapply_in -| ["eapply" constr_with_bindings(c) "in" hyp(id) ] -> [ apply_in true id [c] ] -| ["epply" constr_with_bindings(c) "," constr_with_bindings_list_sep(cl,",") - "in" hyp(id) ] -> [ apply_in true id (c::cl) ] +| ["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 diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml index 11ace2abb..428372003 100644 --- a/tactics/hiddentac.ml +++ b/tactics/hiddentac.ml @@ -30,8 +30,8 @@ let inj_occ (occ,c) = (occ,inj_open c) (* Basic tactics *) let h_intro_move x y = - abstract_tactic (TacIntroMove (x, Option.map inj_id y)) (intro_move x y) -let h_intro x = h_intro_move (Some x) None + abstract_tactic (TacIntroMove (x, y)) (intro_move x y) +let h_intro x = h_intro_move (Some x) no_move let h_intros_until x = abstract_tactic (TacIntrosUntil x) (intros_until x) let h_assumption = abstract_tactic TacAssumption assumption let h_exact c = abstract_tactic (TacExact (inj_open c)) (exact_check c) @@ -40,7 +40,7 @@ let h_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,inj_open_wb cb)) + abstract_tactic (TacApply (simple,ev,List.map inj_open_wb cb)) (apply_with_ebindings_gen simple ev cb) let h_elim ev cb cbo = abstract_tactic (TacElim (ev,inj_open_wb cb,Option.map inj_open_wb cbo)) @@ -70,7 +70,7 @@ let h_generalize cl = 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 in + 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) let h_instantiate n c ido = (Evar_tactics.instantiate n c ido) @@ -78,16 +78,19 @@ let h_instantiate n c ido = (Evar_refiner.instantiate n c (simple_clause_of cls)) *) (* Derived basic tactics *) -let h_simple_induction h = - abstract_tactic (TacSimpleInduction h) (simple_induct h) -let h_simple_destruct h = - abstract_tactic (TacSimpleDestruct h) (simple_destruct h) -let h_new_induction ev c e idl cl = - abstract_tactic (TacNewInduction (ev,List.map inj_ia c,Option.map inj_open_wb e,idl,cl)) - (new_induct ev c e idl cl) -let h_new_destruct ev c e idl cl = - abstract_tactic (TacNewDestruct (ev,List.map inj_ia c,Option.map inj_open_wb e,idl,cl)) - (new_destruct ev c e idl cl) +let h_simple_induction_destruct isrec h = + abstract_tactic (TacSimpleInductionDestruct (isrec,h)) + (if isrec then (simple_induct h) else (simple_destruct h)) +let h_simple_induction = h_simple_induction_destruct true +let h_simple_destruct = h_simple_induction_destruct false + +let h_induction_destruct isrec ev l = + abstract_tactic (TacInductionDestruct (isrec,ev,List.map (fun (c,e,idl,cl) -> + List.map inj_ia c,Option.map inj_open_wb e,idl,cl) l)) + (induction_destruct ev isrec l) +let h_new_induction ev c e idl cl = h_induction_destruct ev true [c,e,idl,cl] +let h_new_destruct ev c e idl cl = h_induction_destruct ev false [c,e,idl,cl] + let h_specialize n d = abstract_tactic (TacSpecialize (n,inj_open_wb d)) (specialize n d) let h_lapply c = abstract_tactic (TacLApply (inj_open c)) (cut_and_apply c) @@ -128,8 +131,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 [c,NoBindings] +let h_simplest_eapply c = h_apply false true [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 bb88518c9..8d15f864c 100644 --- a/tactics/hiddentac.mli +++ b/tactics/hiddentac.mli @@ -10,6 +10,7 @@ (*i*) open Names +open Util open Term open Proof_type open Tacmach @@ -25,7 +26,7 @@ open Clenv (* Basic tactics *) -val h_intro_move : identifier option -> identifier option -> tactic +val h_intro_move : identifier option -> identifier move_location -> tactic val h_intro : identifier -> tactic val h_intros_until : quantified_hypothesis -> tactic @@ -35,7 +36,7 @@ val h_exact_no_check : constr -> tactic val h_vm_cast_no_check : constr -> tactic val h_apply : advanced_flag -> evars_flag -> - constr with_ebindings -> tactic + constr with_ebindings list -> tactic val h_elim : evars_flag -> constr with_ebindings -> constr with_ebindings option -> tactic @@ -63,14 +64,20 @@ val h_instantiate : int -> Rawterm.rawconstr -> val h_simple_induction : quantified_hypothesis -> tactic val h_simple_destruct : quantified_hypothesis -> tactic -val h_new_induction : - evars_flag -> constr with_ebindings induction_arg list -> - constr with_ebindings option -> intro_pattern_expr -> - Tacticals.clause option -> tactic -val h_new_destruct : - evars_flag -> constr with_ebindings induction_arg list -> - constr with_ebindings option -> intro_pattern_expr -> - Tacticals.clause option -> tactic +val h_simple_induction_destruct : rec_flag -> quantified_hypothesis -> tactic +val h_new_induction : evars_flag -> + constr with_ebindings induction_arg list -> constr with_ebindings option -> + intro_pattern_expr located option * intro_pattern_expr located option -> + Tacticals.clause option -> tactic +val h_new_destruct : evars_flag -> + constr with_ebindings induction_arg list -> constr with_ebindings option -> + intro_pattern_expr located option * intro_pattern_expr located option -> + Tacticals.clause option -> tactic +val h_induction_destruct : rec_flag -> evars_flag -> + (constr with_ebindings induction_arg list * constr with_ebindings option * + (intro_pattern_expr located option * intro_pattern_expr located option) * + Tacticals.clause option) list -> tactic + val h_specialize : int option -> constr with_ebindings -> tactic val h_lapply : constr -> tactic @@ -80,7 +87,7 @@ val h_lapply : constr -> tactic (* Context management *) val h_clear : bool -> identifier list -> tactic val h_clear_body : identifier list -> tactic -val h_move : bool -> identifier -> identifier -> tactic +val h_move : bool -> identifier -> identifier move_location -> tactic val h_rename : (identifier*identifier) list -> tactic val h_revert : identifier list -> tactic @@ -110,4 +117,4 @@ val h_simplest_eapply : constr -> tactic val h_simplest_elim : constr -> tactic val h_simplest_case : constr -> tactic -val h_intro_patterns : intro_pattern_expr list -> tactic +val h_intro_patterns : intro_pattern_expr located list -> tactic diff --git a/tactics/inv.ml b/tactics/inv.ml index 4e06fffb7..5d02e621d 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -294,7 +294,7 @@ let rec tclMAP_i n tacfun = function if n=0 then error "Too much names." else tclTHEN (tacfun (Some a)) (tclMAP_i (n-1) tacfun l) -let remember_first_eq id x = if !x = None then x := Some id +let remember_first_eq id x = if !x = no_move then x := MoveAfter id (* invariant: ProjectAndApply is responsible for erasing the clause which it is given as input @@ -321,7 +321,7 @@ let projectAndApply thin id eqname names depids gls = [(if names <> [] then clear [id] else tclIDTAC); (tclMAP_i neqns (fun idopt -> tclTHEN - (intro_move idopt None) + (intro_move idopt no_move) (* try again to substitute and if still not a variable after *) (* decomposition, arbitrarily try to rewrite RL !? *) (tclTRY (onLastHyp (substHypIfVariable (subst_hyp false))))) @@ -350,7 +350,7 @@ let rewrite_equations_gene othin neqns ba gl = (onLastHyp (fun id -> tclTRY - (projectAndApply thin id (ref None) + (projectAndApply thin id (ref no_move) [] depids)))); onHyps (compose List.rev (afterHyp last)) bring_hyps; onHyps (afterHyp last) @@ -375,12 +375,12 @@ let rewrite_equations_gene othin neqns ba gl = None: the equations are introduced, but not rewritten Some thin: the equations are rewritten, and cleared if thin is true *) -let rec get_names allow_conj = function - | IntroWildcard _ -> +let rec get_names allow_conj (loc,pat) = match pat with + | IntroWildcard -> error "Discarding pattern not allowed for inversion equations." | IntroAnonymous -> error "Anonymous pattern not allowed for inversion equations." - | IntroFresh _-> + | IntroFresh _ -> error "Fresh pattern not allowed for inversion equations." | IntroRewrite _-> error "Rewriting pattern not allowed for inversion equations." @@ -404,7 +404,7 @@ let rewrite_equations othin neqns names ba gl = let names = List.map (get_names true) names in let (depids,nodepids) = split_dep_and_nodep ba.assums gl in let rewrite_eqns = - let first_eq = ref None in + let first_eq = ref no_move in match othin with | Some thin -> tclTHENSEQ @@ -413,12 +413,12 @@ let rewrite_equations othin neqns names ba gl = tclMAP_i neqns (fun o -> let idopt,names = extract_eqn_names o in (tclTHEN - (intro_move idopt None) + (intro_move idopt no_move) (onLastHyp (fun id -> tclTRY (projectAndApply thin id first_eq names depids))))) names; tclMAP (fun (id,_,_) gl -> - intro_move None (if thin then None else !first_eq) gl) + intro_move None (if thin then no_move else !first_eq) gl) nodepids; tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids] | None -> tclIDTAC @@ -524,15 +524,15 @@ open Tacexpr let inv k = inv_gen false k NoDep -let half_inv_tac id = inv SimpleInversion IntroAnonymous (NamedHyp id) -let inv_tac id = inv FullInversion IntroAnonymous (NamedHyp id) -let inv_clear_tac id = inv FullInversionClear IntroAnonymous (NamedHyp id) +let half_inv_tac id = inv SimpleInversion None (NamedHyp id) +let inv_tac id = inv FullInversion None (NamedHyp id) +let inv_clear_tac id = inv FullInversionClear None (NamedHyp id) let dinv k c = inv_gen false k (Dep c) -let half_dinv_tac id = dinv SimpleInversion None IntroAnonymous (NamedHyp id) -let dinv_tac id = dinv FullInversion None IntroAnonymous (NamedHyp id) -let dinv_clear_tac id = dinv FullInversionClear None IntroAnonymous (NamedHyp id) +let half_dinv_tac id = dinv SimpleInversion None None (NamedHyp id) +let dinv_tac id = dinv FullInversion None None (NamedHyp id) +let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) (* InvIn will bring the specified clauses into the conclusion, and then * perform inversion on the named hypothesis. After, it will intro them diff --git a/tactics/inv.mli b/tactics/inv.mli index 086c9d7ce..322e139f0 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -9,6 +9,7 @@ (*i $Id$ i*) (*i*) +open Util open Names open Term open Tacmach @@ -21,20 +22,20 @@ type inversion_status = Dep of constr option | NoDep val inv_gen : bool -> inversion_kind -> inversion_status -> - intro_pattern_expr -> quantified_hypothesis -> tactic + intro_pattern_expr located option -> quantified_hypothesis -> tactic val invIn_gen : - inversion_kind -> intro_pattern_expr -> identifier list -> + inversion_kind -> intro_pattern_expr located option -> identifier list -> quantified_hypothesis -> tactic val inv_clause : - inversion_kind -> intro_pattern_expr -> identifier list -> + inversion_kind -> intro_pattern_expr located option -> identifier list -> quantified_hypothesis -> tactic -val inv : inversion_kind -> intro_pattern_expr -> +val inv : inversion_kind -> intro_pattern_expr located option -> quantified_hypothesis -> tactic -val dinv : inversion_kind -> constr option -> intro_pattern_expr -> - quantified_hypothesis -> tactic +val dinv : inversion_kind -> constr option -> + intro_pattern_expr located option -> quantified_hypothesis -> tactic val half_inv_tac : identifier -> tactic val inv_tac : identifier -> tactic diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index a50b79720..a2e6587ee 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -51,7 +51,7 @@ open Pcoq let safe_msgnl s = try msgnl s with e -> msgnl - (str "bug in the debugger : " ++ + (str "bug in the debugger: " ++ str "an exception is raised while printing debug information") let error_syntactic_metavariables_not_allowed loc = @@ -72,10 +72,10 @@ type ltac_type = (* Values for interpretation *) type value = - | VTactic of loc * tactic (* For mixed ML/Ltac tactics (e.g. Tauto) *) | VRTactic of (goal list sigma * validation) (* For Match results *) (* Not a true value *) - | VFun of (identifier*value) list * identifier option list * glob_tactic_expr + | VFun of ltac_trace * (identifier*value) list * + identifier option list * glob_tactic_expr | VVoid | VInteger of int | VIntroPattern of intro_pattern_expr (* includes idents which are not *) @@ -86,22 +86,20 @@ type value = | VList of value list | VRec of (identifier*value) list ref * glob_tactic_expr -let locate_tactic_call loc = function - | VTactic (_,t) -> VTactic (loc,t) - | v -> v - -let locate_error_in_file dir = function - | Stdpp.Exc_located (loc,e) -> Error_in_file ("",(true,dir,loc),e) - | e -> Error_in_file ("",(true,dir,dummy_loc),e) +let dloc = dummy_loc -let catch_error loc tac g = - try tac g - with e when loc <> dummy_loc -> - match e with - | Stdpp.Exc_located (loc',e') -> - if loc' = dummy_loc then raise (Stdpp.Exc_located (loc,e')) - else raise e - | e -> raise (Stdpp.Exc_located (loc,e)) +let catch_error call_trace tac g = + if call_trace = [] then tac g else try tac g with + | LtacLocated _ as e -> raise e + | Stdpp.Exc_located (_,LtacLocated _) as e -> raise e + | e -> + 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 + raise (Stdpp.Exc_located(loc,e')) + else + raise (Stdpp.Exc_located(loc',LtacLocated((c,tail,loc),e'))) (* Signature for interpretation: val_interp and interpretation functions *) type interp_sign = @@ -109,7 +107,7 @@ type interp_sign = avoid_ids : identifier list; (* ids inherited from the call context (needed to get fresh ids) *) debug : debug_info; - last_loc : loc } + trace : ltac_trace } let check_is_value = function | VRTactic _ -> (* These are goals produced by Match *) @@ -129,10 +127,10 @@ let constr_of_VConstr_context = function let rec pr_value env = function | VVoid -> str "()" | VInteger n -> int n - | VIntroPattern ipat -> pr_intro_pattern ipat + | VIntroPattern ipat -> pr_intro_pattern (dloc,ipat) | VConstr c | VConstr_context c -> (match env with Some env -> pr_lconstr_env env c | _ -> str "a term") - | (VTactic _ | VRTactic _ | VFun _ | VRec _) -> str "a tactic" + | (VRTactic _ | VFun _ | VRec _) -> str "a tactic" | VList [] -> str "an empty list" | VList (a::_) -> str "a list (first element is " ++ pr_value env a ++ str")" @@ -142,24 +140,13 @@ let constr_of_id env id = construct_reference (Environ.named_context env) id (* To embed tactics *) -let ((tactic_in : (interp_sign -> raw_tactic_expr) -> Dyn.t), - (tactic_out : Dyn.t -> (interp_sign -> raw_tactic_expr))) = +let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t), + (tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr))) = create "tactic" let ((value_in : value -> Dyn.t), (value_out : Dyn.t -> value)) = create "value" -let tacticIn t = TacArg (TacDynamic (dummy_loc,tactic_in t)) -let tacticOut = function - | TacArg (TacDynamic (_,d)) -> - if (tag d) = "tactic" then - tactic_out d - else - anomalylabstrm "tacticOut" (str "Dynamic tag should be tactic") - | ast -> - anomalylabstrm "tacticOut" - (str "Not a Dynamic ast: " (* ++ print_ast ast*) ) - let valueIn t = TacDynamic (dummy_loc,value_in t) let valueOut = function | TacDynamic (_,d) -> @@ -181,8 +168,6 @@ let constrOut = function | ast -> anomalylabstrm "constrOut" (str "Not a Dynamic ast") -let dloc = dummy_loc - (* Globalizes the identifier *) let find_reference env qid = (* We first look for a variable of the current proof *) @@ -210,7 +195,7 @@ let _ = "hnf", TacReduce(Hnf,nocl); "simpl", TacReduce(Simpl None,nocl); "compute", TacReduce(Cbv all_flags,nocl); - "intro", TacIntroMove(None,None); + "intro", TacIntroMove(None,no_move); "intros", TacIntroPattern []; "assumption", TacAssumption; "cofix", TacCofix None; @@ -310,9 +295,15 @@ let lookup_genarg_glob id = let (f,_,_) = lookup_genarg id in f let lookup_interp_genarg id = let (_,f,_) = lookup_genarg id in f let lookup_genarg_subst id = let (_,_,f) = lookup_genarg id in f -(* Dynamically check that an argument is a tactic, possibly unboxing VRec *) +let propagate_trace ist loc id = function + | VFun (_,lfun,it,b) -> + let t = if it=[] then b else TacFun (it,b) in + VFun ((loc,LtacVarCall (id,t))::ist.trace,lfun,it,b) + | x -> x + +(* Dynamically check that an argument is a tactic *) let coerce_to_tactic loc id = function - | VTactic _ | VFun _ | VRTactic _ as a -> a + | VFun _ | VRTactic _ as a -> a | _ -> user_err_loc (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") @@ -421,6 +412,11 @@ let intern_constr_reference strict ist = function let loc,_ as lqid = qualid_of_reference r in RRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r) +let intern_move_location ist = function + | MoveAfter id -> MoveAfter (intern_hyp_or_metaid ist id) + | MoveBefore id -> MoveBefore (intern_hyp_or_metaid ist id) + | MoveToEnd toleft as x -> x + (* Internalize an isolated reference in position of tactic *) let intern_isolated_global_tactic_reference r = @@ -474,7 +470,7 @@ let intern_non_tactic_reference strict ist r = with Not_found -> (* By convention, use IntroIdentifier for unbound ident, when not in a def *) match r with - | Ident (_,id) when not strict -> IntroPattern (IntroIdentifier id) + | Ident (loc,id) when not strict -> IntroPattern (loc,IntroIdentifier id) | _ -> (* Reference not found *) error_global_not_found_loc (qualid_of_reference r) @@ -486,13 +482,14 @@ let intern_message_token ist = function let intern_message ist = List.map (intern_message_token ist) let rec intern_intro_pattern lf ist = function - | IntroOrAndPattern l -> - IntroOrAndPattern (intern_case_intro_pattern lf ist l) - | IntroIdentifier id -> - IntroIdentifier (intern_ident lf ist id) - | IntroWildcard _ | IntroAnonymous | IntroFresh _ | IntroRewrite _ as x -> x - -and intern_case_intro_pattern lf ist = + | loc, IntroOrAndPattern l -> + loc, IntroOrAndPattern (intern_or_and_intro_pattern lf ist l) + | loc, IntroIdentifier id -> + loc, IntroIdentifier (intern_ident lf ist id) + | loc, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _) + as x -> x + +and intern_or_and_intro_pattern lf ist = List.map (List.map (intern_intro_pattern lf ist)) let intern_quantified_hypothesis ist = function @@ -601,10 +598,10 @@ let intern_red_expr ist = function let intern_inversion_strength lf ist = function | NonDepInversion (k,idl,ids) -> NonDepInversion (k,List.map (intern_hyp_or_metaid ist) idl, - intern_intro_pattern lf ist ids) + Option.map (intern_intro_pattern lf ist) ids) | DepInversion (k,copt,ids) -> DepInversion (k, Option.map (intern_constr ist) copt, - intern_intro_pattern lf ist ids) + Option.map (intern_intro_pattern lf ist) ids) | InversionUsing (c,idl) -> InversionUsing (intern_constr ist c, List.map (intern_hyp_or_metaid ist) idl) @@ -641,7 +638,7 @@ let internalise_tacarg ch = G_xml.parse_tactic_arg ch let extern_tacarg ch env sigma = function | VConstr c -> !print_xml_term ch env sigma c - | VTactic _ | VRTactic _ | VFun _ | VVoid | VInteger _ | VConstr_context _ + | VRTactic _ | VFun _ | VVoid | VInteger _ | VConstr_context _ | VIntroPattern _ | VRec _ | VList _ -> error "Only externing of terms is implemented." @@ -698,14 +695,15 @@ let rec intern_atomic lf ist x = | TacIntroPattern l -> TacIntroPattern (List.map (intern_intro_pattern lf ist) l) | TacIntrosUntil hyp -> TacIntrosUntil (intern_quantified_hypothesis ist hyp) - | TacIntroMove (ido,ido') -> + | TacIntroMove (ido,hto) -> TacIntroMove (Option.map (intern_ident lf ist) ido, - Option.map (intern_hyp ist) ido') + intern_move_location ist hto) | TacAssumption -> TacAssumption | 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,intern_constr_with_bindings ist cb) + | TacApply (a,ev,cb) -> + TacApply (a,ev,List.map (intern_constr_with_bindings ist) cb) | TacElim (ev,cb,cbo) -> TacElim (ev,intern_constr_with_bindings ist cb, Option.map (intern_constr_with_bindings ist) cbo) @@ -749,20 +747,15 @@ let rec intern_atomic lf ist x = List.map (intern_constr ist) lems) (* Derived basic tactics *) - | TacSimpleInduction h -> - TacSimpleInduction (intern_quantified_hypothesis ist h) - | TacNewInduction (ev,lc,cbo,ids,cls) -> - TacNewInduction (ev,List.map (intern_induction_arg ist) lc, - Option.map (intern_constr_with_bindings ist) cbo, - intern_intro_pattern lf ist ids, - Option.map (clause_app (intern_hyp_location ist)) cls) - | TacSimpleDestruct h -> - TacSimpleDestruct (intern_quantified_hypothesis ist h) - | TacNewDestruct (ev,c,cbo,ids,cls) -> - TacNewDestruct (ev,List.map (intern_induction_arg ist) c, + | TacSimpleInductionDestruct (isrec,h) -> + TacSimpleInductionDestruct (isrec,intern_quantified_hypothesis ist h) + | TacInductionDestruct (ev,isrec,l) -> + TacInductionDestruct (ev,isrec,List.map (fun (lc,cbo,(ipato,ipats),cls) -> + (List.map (intern_induction_arg ist) lc, Option.map (intern_constr_with_bindings ist) cbo, - intern_intro_pattern lf ist ids, - Option.map (clause_app (intern_hyp_location ist)) cls) + (Option.map (intern_intro_pattern lf ist) ipato, + Option.map (intern_intro_pattern lf ist) ipats), + Option.map (clause_app (intern_hyp_location ist)) cls)) l) | TacDoubleInduction (h1,h2) -> let h1 = intern_quantified_hypothesis ist h1 in let h2 = intern_quantified_hypothesis ist h2 in @@ -778,7 +771,7 @@ let rec intern_atomic lf ist x = | TacClear (b,l) -> TacClear (b,List.map (intern_hyp_or_metaid ist) l) | TacClearBody l -> TacClearBody (List.map (intern_hyp_or_metaid ist) l) | TacMove (dep,id1,id2) -> - TacMove (dep,intern_hyp_or_metaid ist id1,intern_hyp_or_metaid ist id2) + TacMove (dep,intern_hyp_or_metaid ist id1,intern_move_location ist id2) | TacRename l -> TacRename (List.map (fun (id1,id2) -> intern_hyp_or_metaid ist id1, @@ -826,8 +819,7 @@ let rec intern_atomic lf ist x = TacExtend (adjust_loc loc,opn,List.map (intern_genarg ist) l) | TacAlias (loc,s,l,(dir,body)) -> let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in - try TacAlias (loc,s,l,(dir,body)) - with e -> raise (locate_error_in_file (string_of_dirpath dir) e) + TacAlias (loc,s,l,(dir,body)) and intern_tactic ist tac = (snd (intern_tactic_seq ist tac) : glob_tactic_expr) @@ -1205,8 +1197,8 @@ let coerce_to_intro_pattern env = function IntroIdentifier (destVar c) | v -> raise (CannotCoerceTo "an introduction pattern") -let interp_intro_pattern_var ist env id = - try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some env)(dloc,id) +let interp_intro_pattern_var loc ist env id = + try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some env) (loc,id) with Not_found -> IntroIdentifier id let coerce_to_hint_base = function @@ -1225,7 +1217,7 @@ let interp_int ist locid = try try_interp_ltac_var coerce_to_int ist None locid with Not_found -> user_err_loc(fst locid,"interp_int", - str "Unbound variable" ++ pr_id (snd locid) ++ str".") + str "Unbound variable " ++ pr_id (snd locid) ++ str".") let interp_int_or_var ist = function | ArgVar locid -> interp_int ist locid @@ -1285,6 +1277,11 @@ let interp_clause_pattern ist gl (l,occl) = | [] -> [] in (l,check [] occl) +let interp_move_location ist gl = function + | MoveAfter id -> MoveAfter (interp_hyp ist gl id) + | MoveBefore id -> MoveBefore (interp_hyp ist gl id) + | MoveToEnd toleft as x -> x + (* Interprets a qualified name *) let coerce_to_reference env v = try match v with @@ -1362,15 +1359,15 @@ let rec constr_list_aux env = function let constr_list ist env = constr_list_aux env ist.lfun (* Extract the identifier list from lfun: join all branches (what to do else?)*) -let rec intropattern_ids = function +let rec intropattern_ids (loc,pat) = match pat with | IntroIdentifier id -> [id] | IntroOrAndPattern ll -> List.flatten (List.map intropattern_ids (List.flatten ll)) - | IntroWildcard _ | IntroAnonymous | IntroFresh _ | IntroRewrite _ -> [] + | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _ -> [] let rec extract_ids ids = function | (id,VIntroPattern ipat)::tl when not (List.mem id ids) -> - intropattern_ids ipat @ extract_ids ids tl + intropattern_ids (dloc,ipat) @ extract_ids ids tl | _::tl -> extract_ids ids tl | [] -> [] @@ -1441,7 +1438,7 @@ let solve_remaining_evars env initial_sigma evd c = proc_rec c let interp_gen kind ist sigma env (c,ce) = - let (ltacvars,unbndltacvars) = constr_list ist env in + let (ltacvars,unbndltacvars as vars) = constr_list ist env in let typs = retype_list sigma env ltacvars in let c = match ce with | None -> c @@ -1451,7 +1448,8 @@ let interp_gen kind ist sigma env (c,ce) = | Some c -> let ltacdata = (List.map fst ltacvars,unbndltacvars) in intern_gen (kind = IsType) ~ltacvars:ltacdata sigma env c in - understand_ltac sigma env (typs,unbndltacvars) kind c + let trace = (dloc,LtacConstrInterp (c,vars))::ist.trace in + catch_error trace (understand_ltac sigma env (typs,unbndltacvars) kind) c (* Interprets a constr and solve remaining evars with default tactic *) let interp_econstr kind ist sigma env cc = @@ -1618,31 +1616,38 @@ let inj_may_eval = function let message_of_value = function | VVoid -> str "()" | VInteger n -> int n - | VIntroPattern ipat -> pr_intro_pattern ipat + | VIntroPattern ipat -> pr_intro_pattern (dloc,ipat) | VConstr_context c | VConstr c -> pr_constr c - | VRec _ | VTactic _ | VRTactic _ | VFun _ -> str "<tactic>" + | VRec _ | VRTactic _ | VFun _ -> str "<tactic>" | VList _ -> str "<list>" -let rec interp_message ist = function - | [] -> mt() - | MsgString s :: l -> pr_arg str s ++ interp_message ist l - | MsgInt n :: l -> pr_arg int n ++ interp_message ist l - | MsgIdent (loc,id) :: l -> +let rec interp_message_token ist = function + | MsgString s -> str s + | MsgInt n -> int n + | MsgIdent (loc,id) -> let v = try List.assoc id ist.lfun with Not_found -> user_err_loc (loc,"",pr_id id ++ str" not found.") in - pr_arg message_of_value v ++ interp_message ist l + message_of_value v let rec interp_message_nl ist = function | [] -> mt() - | l -> interp_message ist l ++ fnl() + | l -> prlist_with_sep spc (interp_message_token ist) l ++ fnl() -let rec interp_intro_pattern ist gl = function - | IntroOrAndPattern l -> IntroOrAndPattern (interp_case_intro_pattern ist gl l) - | IntroIdentifier id -> interp_intro_pattern_var ist (pf_env gl) id - | IntroWildcard _ | IntroAnonymous | IntroFresh _ | IntroRewrite _ as x -> x +let interp_message ist l = + (* Force evaluation of interp_message_token so that potential errors + are raised now and not at printing time *) + prlist (fun x -> spc () ++ x) (List.map (interp_message_token ist) l) -and interp_case_intro_pattern ist gl = +let rec interp_intro_pattern ist gl = function + | loc, IntroOrAndPattern l -> + loc, IntroOrAndPattern (interp_or_and_intro_pattern ist gl l) + | loc, IntroIdentifier id -> + loc, interp_intro_pattern_var loc ist (pf_env gl) id + | loc, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _) + as x -> x + +and interp_or_and_intro_pattern ist gl = List.map (List.map (interp_intro_pattern ist gl)) (* Quantified named or numbered hypothesis or hypothesis in context *) @@ -1716,14 +1721,14 @@ let rec val_interp ist gl (tac:glob_tactic_expr) = let value_interp ist = match tac with (* Immediate evaluation *) - | TacFun (it,body) -> VFun (ist.lfun,it,body) + | TacFun (it,body) -> VFun (ist.trace,ist.lfun,it,body) | TacLetIn (true,l,u) -> interp_letrec ist gl l u | TacLetIn (false,l,u) -> interp_letin ist gl l u | TacMatchContext (lz,lr,lmr) -> interp_match_context ist gl lz lr lmr | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr | TacArg a -> interp_tacarg ist gl a (* Delayed evaluation *) - | t -> VTactic (ist.last_loc,eval_tactic ist t) + | t -> VFun (ist.trace,ist.lfun,[],t) in check_for_interrupt (); match ist.debug with @@ -1732,7 +1737,14 @@ let rec val_interp ist gl (tac:glob_tactic_expr) = | _ -> value_interp ist and eval_tactic ist = function - | TacAtom (loc,t) -> fun gl -> catch_error loc (interp_atomic ist gl t) gl + | TacAtom (loc,t) -> + fun gl -> + let box = ref None in abstract_tactic_box := box; + let call = LtacAtomCall (t,box) in + let tac = (* catch error in the interpretation *) + catch_error ((dloc,call)::ist.trace) (interp_atomic ist gl) t in + (* catch error in the evaluation *) + catch_error ((loc,call)::ist.trace) tac gl | TacFun _ | TacLetIn _ -> assert false | TacMatchContext _ | TacMatch _ -> assert false | TacId s -> tclIDTAC_MESSAGE (interp_message_nl ist s) @@ -1767,31 +1779,33 @@ and force_vrec ist gl = function | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} gl body | v -> v -and interp_ltac_reference isapplied mustbetac ist gl = function +and interp_ltac_reference loc' mustbetac ist gl = function | ArgVar (loc,id) -> let v = List.assoc id ist.lfun in let v = force_vrec ist gl v in + let v = propagate_trace ist loc id v in if mustbetac then coerce_to_tactic loc id v else v | ArgArg (loc,r) -> let ids = extract_ids [] ist.lfun in + let loc_info = ((if loc' = dloc then loc else loc'),LtacNameCall r) in let ist = { lfun=[]; debug=ist.debug; avoid_ids=ids; - last_loc = if isapplied then ist.last_loc else loc } in + trace = loc_info::ist.trace } in val_interp ist gl (lookup r) and interp_tacarg ist gl = function | TacVoid -> VVoid - | Reference r -> interp_ltac_reference false false ist gl r + | Reference r -> interp_ltac_reference dloc false ist gl r | Integer n -> VInteger n - | IntroPattern ipat -> VIntroPattern (interp_intro_pattern ist gl ipat) + | IntroPattern ipat -> VIntroPattern (snd (interp_intro_pattern ist gl ipat)) | ConstrMayEval c -> VConstr (interp_constr_may_eval ist gl c) | MetaIdArg (loc,_,id) -> assert false - | TacCall (loc,r,[]) -> interp_ltac_reference false true ist gl r + | TacCall (loc,r,[]) -> interp_ltac_reference loc true ist gl r | TacCall (loc,f,l) -> - let fv = interp_ltac_reference true true ist gl f + let fv = interp_ltac_reference loc true ist gl f and largs = List.map (interp_tacarg ist gl) l in List.iter check_is_value largs; - interp_app ist gl fv largs loc + interp_app loc ist gl fv largs | TacExternal (loc,com,req,la) -> interp_external loc ist gl com req (List.map (interp_tacarg ist gl) la) | TacFreshId l -> @@ -1801,12 +1815,7 @@ and interp_tacarg ist gl = function | TacDynamic(_,t) -> let tg = (tag t) in if tg = "tactic" then - let f = (tactic_out t) in - val_interp ist gl - (intern_tactic { - ltacvars = (List.map fst ist.lfun,[]); ltacrecvars = []; - gsigma = project gl; genv = pf_env gl } - (f ist)) + val_interp ist gl (tactic_out t ist) else if tg = "value" then value_out t else if tg = "constr" then @@ -1816,32 +1825,34 @@ and interp_tacarg ist gl = function (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">")) (* Interprets an application node *) -and interp_app ist gl fv largs loc = +and interp_app loc ist gl fv largs = match fv with - | VFun(olfun,var,body) -> + | VFun(trace,olfun,var,body) -> let (newlfun,lvar,lval)=head_with_value (var,largs) in if lvar=[] then let v = try - let lloc = if lval=[] then loc else ist.last_loc in - val_interp { ist with lfun=newlfun@olfun; last_loc=lloc } gl body + catch_error trace + (val_interp { ist with lfun=newlfun@olfun; trace=trace } gl) body with e -> debugging_exception_step ist false e (fun () -> str "evaluation"); raise e in debugging_step ist (fun () -> str "evaluation returns" ++ fnl() ++ pr_value (Some (pf_env gl)) v); - if lval=[] then v else interp_app ist gl v lval loc + if lval=[] then v else interp_app loc ist gl v lval else - VFun(newlfun@olfun,lvar,body) + VFun(trace,newlfun@olfun,lvar,body) | _ -> user_err_loc (loc, "Tacinterp.interp_app", (str"Illegal tactic application.")) (* Gives the tactic corresponding to the tactic value *) -and tactic_of_value vle g = +and tactic_of_value ist vle g = match vle with | VRTactic res -> res - | VTactic (loc,tac) -> catch_error loc tac g + | VFun (trace,lfun,[],t) -> + let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in + catch_error trace tac g | VFun _ -> error "A fully applied tactic is expected." | _ -> raise NotTactic @@ -1849,15 +1860,19 @@ and tactic_of_value vle g = and eval_with_fail ist is_lazy goal tac = try (match val_interp ist goal tac with - | VTactic (loc,tac) when not is_lazy -> VRTactic (catch_error loc tac goal) + | VFun (trace,lfun,[],t) when not is_lazy -> + let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in + VRTactic (catch_error trace tac goal) | a -> a) with - | Stdpp.Exc_located (_,FailError (0,s)) | FailError (0,s) -> + | FailError (0,s) | Stdpp.Exc_located(_, FailError (0,s)) + | Stdpp.Exc_located(_,LtacLocated (_,FailError (0,s))) -> raise (Eval_fail s) - | Stdpp.Exc_located (s',FailError (lvl,s)) -> - raise (Stdpp.Exc_located (s',FailError (lvl - 1, s))) - | FailError (lvl,s) -> - raise (FailError (lvl - 1, s)) + | FailError (lvl,s) -> raise (FailError (lvl - 1, s)) + | Stdpp.Exc_located(s,FailError (lvl,s')) -> + raise (Stdpp.Exc_located(s,FailError (lvl - 1, s'))) + | Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl,s'))) -> + raise (Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl - 1, s')))) (* Interprets the clauses of a recursive LetIn *) and interp_letrec ist gl llc u = @@ -2119,9 +2134,8 @@ and interp_ltac_constr ist gl e = str "offending expression: " ++ fnl() ++ Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++ str "this is a " ++ (match result with - VTactic _ -> str "VTactic" | VRTactic _ -> str "VRTactic" - | VFun (il,ul,b) -> + | VFun (_,il,ul,b) -> (str "VFun with body " ++ fnl() ++ Pptactic.pr_glob_tactic (pf_env gl) b ++ fnl() ++ str "instantiated arguments " ++ fnl() ++ @@ -2135,7 +2149,7 @@ and interp_ltac_constr ist gl e = (match opt_id with Some id -> str (string_of_id id) | None -> str "_") ++ str ", " ++ s) - ul (str "")) + ul (mt())) | VVoid -> str "VVoid" | VInteger _ -> str "VInteger" | VConstr _ -> str "VConstr" @@ -2146,9 +2160,8 @@ and interp_ltac_constr ist gl e = (* Interprets tactic expressions : returns a "tactic" *) and interp_tactic ist tac gl = - try tactic_of_value (val_interp ist gl tac) gl - with NotTactic -> - errorlabstrm "" (str "Must be a command or must give a tactic value.") + try tactic_of_value ist (val_interp ist gl tac) gl + with NotTactic -> errorlabstrm "" (str "Not a tactic.") (* Interprets a primitive tactic *) and interp_atomic ist gl = function @@ -2157,14 +2170,15 @@ and interp_atomic ist gl = function h_intro_patterns (List.map (interp_intro_pattern ist gl) l) | TacIntrosUntil hyp -> h_intros_until (interp_quantified_hypothesis ist hyp) - | TacIntroMove (ido,ido') -> + | TacIntroMove (ido,hto) -> h_intro_move (Option.map (interp_fresh_ident ist gl) ido) - (Option.map (interp_hyp ist gl) ido') + (interp_move_location ist gl hto) | TacAssumption -> h_assumption | TacExact c -> h_exact (pf_interp_casted_constr ist gl c) | TacExactNoCheck c -> h_exact_no_check (pf_interp_constr ist gl c) | TacVmCastNoCheck c -> h_vm_cast_no_check (pf_interp_constr ist gl c) - | TacApply (a,ev,cb) -> h_apply a ev (interp_constr_with_bindings ist gl cb) + | TacApply (a,ev,cb) -> + h_apply a ev (List.map (interp_constr_with_bindings ist gl) cb) | TacElim (ev,cb,cbo) -> h_elim ev (interp_constr_with_bindings ist gl cb) (Option.map (interp_constr_with_bindings ist gl) cbo) @@ -2210,20 +2224,16 @@ and interp_atomic ist gl = function (pf_interp_constr_list ist gl lems) (* Derived basic tactics *) - | TacSimpleInduction h -> - h_simple_induction (interp_quantified_hypothesis ist h) - | TacNewInduction (ev,lc,cbo,ids,cls) -> - h_new_induction ev (List.map (interp_induction_arg ist gl) lc) - (Option.map (interp_constr_with_bindings ist gl) cbo) - (interp_intro_pattern ist gl ids) - (Option.map (interp_clause ist gl) cls) - | TacSimpleDestruct h -> - h_simple_destruct (interp_quantified_hypothesis ist h) - | TacNewDestruct (ev,c,cbo,ids,cls) -> - h_new_destruct ev (List.map (interp_induction_arg ist gl) c) - (Option.map (interp_constr_with_bindings ist gl) cbo) - (interp_intro_pattern ist gl ids) - (Option.map (interp_clause ist gl) cls) + | TacSimpleInductionDestruct (isrec,h) -> + h_simple_induction_destruct isrec (interp_quantified_hypothesis ist h) + | TacInductionDestruct (isrec,ev,l) -> + h_induction_destruct ev isrec + (List.map (fun (lc,cbo,(ipato,ipats),cls) -> + (List.map (interp_induction_arg ist gl) lc, + Option.map (interp_constr_with_bindings ist gl) cbo, + (Option.map (interp_intro_pattern ist gl) ipato, + Option.map (interp_intro_pattern ist gl) ipats), + Option.map (interp_clause ist gl) cls)) l) | TacDoubleInduction (h1,h2) -> let h1 = interp_quantified_hypothesis ist h1 in let h2 = interp_quantified_hypothesis ist h2 in @@ -2241,7 +2251,7 @@ and interp_atomic ist gl = function | TacClear (b,l) -> h_clear b (interp_hyp_list ist gl l) | TacClearBody l -> h_clear_body (interp_hyp_list ist gl l) | TacMove (dep,id1,id2) -> - h_move dep (interp_hyp ist gl id1) (interp_hyp ist gl id2) + h_move dep (interp_hyp ist gl id1) (interp_move_location ist gl id2) | TacRename l -> h_rename (List.map (fun (id1,id2) -> interp_hyp ist gl id1, @@ -2283,11 +2293,11 @@ and interp_atomic ist gl = function (Option.map (interp_tactic ist) by) | TacInversion (DepInversion (k,c,ids),hyp) -> Inv.dinv k (Option.map (pf_interp_constr ist gl) c) - (interp_intro_pattern ist gl ids) + (Option.map (interp_intro_pattern ist gl) ids) (interp_declared_or_quantified_hypothesis ist gl hyp) | TacInversion (NonDepInversion (k,idl,ids),hyp) -> Inv.inv_clause k - (interp_intro_pattern ist gl ids) + (Option.map (interp_intro_pattern ist gl) ids) (interp_hyp_list ist gl idl) (interp_declared_or_quantified_hypothesis ist gl hyp) | TacInversion (InversionUsing (c,idl),hyp) -> @@ -2298,10 +2308,9 @@ and interp_atomic ist gl = function (* For extensions *) | TacExtend (loc,opn,l) -> let tac = lookup_tactic opn in - fun gl -> - let args = List.map (interp_genarg ist gl) l in - abstract_extended_tactic opn args (tac args) gl - | TacAlias (loc,_,l,(_,body)) -> fun gl -> + let args = List.map (interp_genarg ist gl) l in + abstract_extended_tactic opn args (tac args) + | TacAlias (loc,s,l,(_,body)) -> fun gl -> let rec f x = match genarg_tag x with | IntArgType -> VInteger (out_gen globwit_int x) @@ -2311,7 +2320,7 @@ and interp_atomic ist gl = function failwith "pre-identifiers cannot be bound" | IntroPatternArgType -> VIntroPattern - (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x)) + (snd (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))) | IdentArgType -> VIntroPattern (IntroIdentifier @@ -2366,10 +2375,8 @@ and interp_atomic ist gl = function in let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in - let v = locate_tactic_call loc (val_interp { ist with lfun=lfun } gl body) - in - try tactic_of_value v gl - with NotTactic -> user_err_loc (loc,"",str "Not a tactic.") + let trace = (loc,LtacNotationCall s)::ist.trace in + interp_tactic { ist with lfun=lfun; trace=trace } body gl let make_empty_glob_sign () = { ltacvars = ([],[]); ltacrecvars = []; @@ -2377,20 +2384,20 @@ let make_empty_glob_sign () = (* Initial call for interpretation *) let interp_tac_gen lfun avoid_ids debug t gl = - interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; last_loc=dloc } + interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] } (intern_tactic { ltacvars = (List.map fst lfun, []); ltacrecvars = []; gsigma = project gl; genv = pf_env gl } t) gl let eval_tactic t gls = - interp_tactic { lfun=[]; avoid_ids=[]; debug=get_debug(); last_loc=dloc } + interp_tactic { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] } t gls let interp t = interp_tac_gen [] [] (get_debug()) t let eval_ltac_constr gl t = interp_ltac_constr - { lfun=[]; avoid_ids=[]; debug=get_debug(); last_loc=dloc } gl + { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] } gl (intern_tactic (make_empty_glob_sign ()) t ) (* Hides interpretation for pretty-print *) @@ -2453,7 +2460,7 @@ let subst_global_reference subst = let subst_global ref = let ref',t' = subst_global subst ref in if not (eq_constr (constr_of_global ref') t') then - ppnl (str "Warning: the reference " ++ pr_global ref ++ str " is not " ++ + ppnl (str "Warning: The reference " ++ pr_global ref ++ str " is not " ++ str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ pr_global ref') ; ref' @@ -2507,7 +2514,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,subst_raw_with_bindings subst cb) + | TacApply (a,ev,cb) -> + TacApply (a,ev,List.map (subst_raw_with_bindings subst) cb) | TacElim (ev,cb,cbo) -> TacElim (ev,subst_raw_with_bindings subst cb, Option.map (subst_raw_with_bindings subst) cbo) @@ -2538,14 +2546,11 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacDAuto (n,p,lems) -> TacDAuto (n,p,List.map (subst_rawconstr subst) lems) (* Derived basic tactics *) - | TacSimpleInduction h as x -> x - | TacNewInduction (ev,lc,cbo,ids,cls) -> - TacNewInduction (ev,List.map (subst_induction_arg subst) lc, - Option.map (subst_raw_with_bindings subst) cbo, ids, cls) - | TacSimpleDestruct h as x -> x - | TacNewDestruct (ev,c,cbo,ids,cls) -> - TacNewDestruct (ev,List.map (subst_induction_arg subst) c, - Option.map (subst_raw_with_bindings subst) cbo, ids, cls) + | TacSimpleInductionDestruct (isrec,h) as x -> x + | TacInductionDestruct (isrec,ev,l) -> + TacInductionDestruct (isrec,ev,List.map (fun (lc,cbo,ids,cls) -> + List.map (subst_induction_arg subst) lc, + Option.map (subst_raw_with_bindings subst) cbo, ids, cls) l) | TacDoubleInduction (h1,h2) as x -> x | TacDecomposeAnd c -> TacDecomposeAnd (subst_rawconstr subst c) | TacDecomposeOr c -> TacDecomposeOr (subst_rawconstr subst c) @@ -2771,7 +2776,7 @@ let print_ltac id = try let kn = Nametab.locate_tactic id in let t = lookup kn in - str "Ltac" ++ spc() ++ pr_qualid id ++ str ":=" ++ spc() ++ + str "Ltac" ++ spc() ++ pr_qualid id ++ str " :=" ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t with Not_found -> @@ -2846,17 +2851,33 @@ let glob_tactic_env l env x = x let interp_redexp env sigma r = - let ist = { lfun=[]; avoid_ids=[]; debug=get_debug (); last_loc=dloc } in + let ist = { lfun=[]; avoid_ids=[]; debug=get_debug (); trace=[] } in let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = sigma } in interp_red_expr ist sigma env (intern_red_expr gist r) (***************************************************************************) +(* Embed tactics in raw or glob tactic expr *) + +let globTacticIn t = TacArg (TacDynamic (dummy_loc,tactic_in t)) +let tacticIn t = globTacticIn (fun ist -> glob_tactic (t ist)) + +let tacticOut = function + | TacArg (TacDynamic (_,d)) -> + if (tag d) = "tactic" then + tactic_out d + else + anomalylabstrm "tacticOut" (str "Dynamic tag should be tactic") + | ast -> + anomalylabstrm "tacticOut" + (str "Not a Dynamic ast: " (* ++ print_ast ast*) ) + +(***************************************************************************) (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = Auto.set_extern_interp (fun l -> let l = List.map (fun (id,c) -> (id,VConstr c)) l in - interp_tactic {lfun=l;avoid_ids=[];debug=get_debug(); last_loc=dloc}) + interp_tactic {lfun=l;avoid_ids=[];debug=get_debug(); trace=[]}) let _ = Auto.set_extern_intern_tac (fun l -> Flags.with_option strict_check diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 2a490fdac..5c040821b 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -26,9 +26,9 @@ open Redexpr (* Values for interpretation *) type value = - | VTactic of Util.loc * tactic (* For mixed ML/Ltac tactics (e.g. Tauto) *) | VRTactic of (goal list sigma * validation) - | VFun of (identifier * value) list * identifier option list * glob_tactic_expr + | VFun of ltac_trace * (identifier*value) list * + identifier option list * glob_tactic_expr | VVoid | VInteger of int | VIntroPattern of intro_pattern_expr @@ -42,18 +42,16 @@ and interp_sign = { lfun : (identifier * value) list; avoid_ids : identifier list; debug : debug_info; - last_loc : loc } + trace : ltac_trace } (* Transforms an id into a constr if possible *) val constr_of_id : Environ.env -> identifier -> constr (* To embed several objects in Coqast.t *) val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr -val tacticOut : raw_tactic_expr -> (interp_sign -> raw_tactic_expr) +val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr val valueIn : value -> raw_tactic_arg -val valueOut: raw_tactic_arg -> value val constrIn : constr -> constr_expr -val constrOut : constr_expr -> constr (* Sets the debugger mode *) val set_debug : debug_info -> unit diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 13ce33444..bbd9112d4 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -270,19 +270,28 @@ type branch_args = { nassums : int; (* the number of assumptions to be introduced *) branchsign : bool list; (* the signature of the branch. true=recursive argument, false=constant *) - branchnames : intro_pattern_expr list} + branchnames : intro_pattern_expr located list} type branch_assumptions = { ba : branch_args; (* the branch args *) assums : named_context} (* the list of assumptions introduced *) +let check_or_and_pattern_size loc names n = + if List.length names <> n then + if n = 1 then + user_err_loc (loc,"",str "Expects a conjunctive pattern.") + else + user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n + ++ str " branches.") + let compute_induction_names n = function - | IntroAnonymous -> + | None -> Array.make n [] - | IntroOrAndPattern names when List.length names = n -> + | Some (loc,IntroOrAndPattern names) -> + check_or_and_pattern_size loc names n; Array.of_list names | _ -> - errorlabstrm "" (str "Expects " ++ int n ++ str " lists of names.") + error "Unexpected introduction pattern." let compute_construtor_signatures isrec (_,k as ity) = let rec analrec c recargs = @@ -393,7 +402,7 @@ let elimination_then_using tac predicate bindings c gl = let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let indclause = mk_clenv_from gl (c,t) in general_elim_then_using gl_make_elim - true IntroAnonymous tac predicate bindings ind indclause gl + true None tac predicate bindings ind indclause gl let case_then_using = general_elim_then_using gl_make_case_dep false diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index d7620acf2..8cc556c62 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -10,6 +10,7 @@ (*i*) open Pp +open Util open Names open Term open Sign @@ -124,23 +125,30 @@ type branch_args = { nassums : int; (* the number of assumptions to be introduced *) branchsign : bool list; (* the signature of the branch. true=recursive argument, false=constant *) - branchnames : intro_pattern_expr list} + branchnames : intro_pattern_expr located list} type branch_assumptions = { ba : branch_args; (* the branch args *) assums : named_context} (* the list of assumptions introduced *) +(* [check_disjunctive_pattern_size loc pats n] returns an appropriate *) +(* error message if |pats| <> n *) +val check_or_and_pattern_size : + Util.loc -> or_and_intro_pattern_expr -> int -> unit + (* Useful for [as intro_pattern] modifier *) val compute_induction_names : - int -> intro_pattern_expr -> intro_pattern_expr list array + int -> intro_pattern_expr located option -> + intro_pattern_expr located list array val elimination_sort_of_goal : goal sigma -> sorts_family val elimination_sort_of_hyp : identifier -> goal sigma -> sorts_family val general_elim_then_using : - (inductive -> goal sigma -> constr) -> rec_flag -> intro_pattern_expr -> - (branch_args -> tactic) -> constr option -> - (arg_bindings * arg_bindings) -> inductive -> clausenv -> tactic + (inductive -> goal sigma -> constr) -> rec_flag -> + intro_pattern_expr located option -> (branch_args -> tactic) -> + constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv -> + tactic val elimination_then_using : (branch_args -> tactic) -> constr option -> @@ -151,12 +159,12 @@ val elimination_then : (arg_bindings * arg_bindings) -> constr -> tactic val case_then_using : - intro_pattern_expr -> (branch_args -> tactic) -> + intro_pattern_expr located option -> (branch_args -> tactic) -> constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv -> tactic val case_nodep_then_using : - intro_pattern_expr -> (branch_args -> tactic) -> + intro_pattern_expr located option -> (branch_args -> tactic) -> constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv -> tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index cb2acc9bd..23524e850 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -75,6 +75,8 @@ let inj_ebindings = function | ExplicitBindings l -> ExplicitBindings (List.map (fun (l,id,c) -> (l,id,inj_open c)) l) +let dloc = dummy_loc + (*********************************************) (* Tactics *) (*********************************************) @@ -126,15 +128,44 @@ let bad_tactic_args s l = (******************************************) let introduction = Tacmach.introduction -let intro_replacing = Tacmach.intro_replacing -let internal_cut = Tacmach.internal_cut -let internal_cut_rev = Tacmach.internal_cut_rev let refine = Tacmach.refine let convert_concl = Tacmach.convert_concl let convert_hyp = Tacmach.convert_hyp -let thin = Tacmach.thin let thin_body = Tacmach.thin_body +let error_clear_dependency env id = function + | Evarutil.OccurHypInSimpleClause None -> + errorlabstrm "" (pr_id id ++ str " is used in conclusion.") + | Evarutil.OccurHypInSimpleClause (Some id') -> + errorlabstrm "" + (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str".") + | Evarutil.EvarTypingBreak ev -> + errorlabstrm "" + (str "Cannot remove " ++ pr_id id ++ + strbrk " without breaking the typing of " ++ + Printer.pr_existential env ev ++ str".") + +let thin l gl = + try thin l gl + with Evarutil.ClearDependencyError (id,err) -> + error_clear_dependency (pf_env gl) id err + +let internal_cut_gen b d t gl = + try internal_cut b d t gl + with Evarutil.ClearDependencyError (id,err) -> + error_clear_dependency (pf_env gl) id err + +let internal_cut = internal_cut_gen false +let internal_cut_replace = internal_cut_gen true + +let internal_cut_rev_gen b d t gl = + try internal_cut_rev b d t gl + with Evarutil.ClearDependencyError (id,err) -> + error_clear_dependency (pf_env gl) id err + +let internal_cut_rev = internal_cut_rev_gen false +let internal_cut_rev_replace = internal_cut_rev_gen true + (* Moving hypotheses *) let move_hyp = Tacmach.move_hyp @@ -273,15 +304,19 @@ let fresh_id_avoid avoid id = let fresh_id avoid id gl = fresh_id_avoid (avoid@(pf_ids_of_hyps gl)) id -let id_of_name_with_default s = function - | Anonymous -> id_of_string s +let id_of_name_with_default id = function + | Anonymous -> id | Name id -> id +let hid = id_of_string "H" +let xid = id_of_string "X" + +let default_id_of_sort = function Prop _ -> hid | Type _ -> xid + let default_id env sigma = function | (name,None,t) -> - (match Typing.sort_of env sigma t with - | Prop _ -> (id_of_name_with_default "H" name) - | Type _ -> (id_of_name_with_default "X" name)) + let dft = default_id_of_sort (Typing.sort_of env sigma t) in + id_of_name_with_default dft name | (name,Some b,_) -> id_of_name_using_hdchar env b name (* Non primitive introduction tactics are treated by central_intro @@ -293,14 +328,14 @@ type intro_name_flag = | IntroBasedOn of identifier * identifier list | IntroMustBe of identifier -let find_name decl gl = function +let find_name loc decl gl = function | IntroAvoid idl -> (* this case must be compatible with [find_intro_names] below. *) let id = fresh_id idl (default_id (pf_env gl) gl.sigma decl) gl in id | IntroBasedOn (id,idl) -> fresh_id idl id gl - | IntroMustBe id -> + | IntroMustBe id -> let id' = fresh_id [] id gl in - if id' <> id then error ((string_of_id id)^" is already used."); + if id'<>id then user_err_loc (loc,"",pr_id id ++ str" is already used."); id' (* Returns the names that would be created by intros, without doing @@ -319,65 +354,72 @@ let find_intro_names ctxt gl = ctxt (pf_env gl , []) in List.rev res - let build_intro_tac id = function - | None -> introduction id - | Some dest -> tclTHEN (introduction id) (move_hyp true id dest) + | MoveToEnd true -> introduction id + | dest -> tclTHEN (introduction id) (move_hyp true id dest) -let rec intro_gen name_flag move_flag force_flag gl = +let rec intro_gen loc name_flag move_flag force_flag gl = match kind_of_term (pf_concl gl) with | Prod (name,t,_) -> - build_intro_tac (find_name (name,None,t) gl name_flag) move_flag gl + build_intro_tac (find_name loc (name,None,t) gl name_flag) move_flag gl | LetIn (name,b,t,_) -> - build_intro_tac (find_name (name,Some b,t) gl name_flag) move_flag gl + build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag + gl | _ -> if not force_flag then raise (RefinerError IntroNeedsProduct); try tclTHEN (reduce (Red true) onConcl) - (intro_gen name_flag move_flag force_flag) gl + (intro_gen loc name_flag move_flag force_flag) gl with Redelimination -> - errorlabstrm "Intro" (str "No product even after head-reduction.") + user_err_loc(loc,"Intro",str "No product even after head-reduction.") -let intro_mustbe_force id = intro_gen (IntroMustBe id) None true -let intro_using id = intro_gen (IntroBasedOn (id,[])) None false -let intro_force force_flag = intro_gen (IntroAvoid []) None force_flag +let intro_mustbe_force id = intro_gen dloc (IntroMustBe id) no_move true +let intro_using id = intro_gen dloc (IntroBasedOn (id,[])) no_move false +let intro_force force_flag = intro_gen dloc (IntroAvoid []) no_move force_flag let intro = intro_force false let introf = intro_force true -let intro_avoiding l = intro_gen (IntroAvoid l) None false - -let introf_move_name destopt = intro_gen (IntroAvoid []) destopt true +let intro_avoiding l = intro_gen dloc (IntroAvoid l) no_move false -(* For backwards compatibility *) -let central_intro = intro_gen +let introf_move_name destopt = intro_gen dloc (IntroAvoid []) destopt true (**** Multiple introduction tactics ****) let rec intros_using = function - [] -> tclIDTAC - | str::l -> tclTHEN (intro_using str) (intros_using l) + | [] -> tclIDTAC + | str::l -> tclTHEN (intro_using str) (intros_using l) let intros = tclREPEAT (intro_force false) let intro_erasing id = tclTHEN (thin [id]) (introduction id) +let rec get_next_hyp_position id = function + | [] -> error ("No such hypothesis: " ^ string_of_id id) + | (hyp,_,_) :: right -> + if hyp = id then + match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveToEnd true + else + get_next_hyp_position id right + +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 + let intros_replacing ids gl = let rec introrec = function | [] -> tclIDTAC | id::tl -> - (tclTHEN (tclORELSE (intro_replacing id) - (tclORELSE (intro_erasing id) (* ?? *) - (intro_using id))) - (introrec tl)) + tclTHEN (tclORELSE (intro_replacing id) (intro_using id)) + (introrec tl) in introrec ids gl (* User-level introduction tactics *) -let intro_move idopt idopt' = match idopt with - | None -> intro_gen (IntroAvoid []) idopt' true - | Some id -> intro_gen (IntroMustBe id) idopt' true +let intro_move idopt hto = match idopt with + | None -> intro_gen dloc (IntroAvoid []) hto true + | Some id -> intro_gen dloc (IntroMustBe id) hto true let pf_lookup_hypothesis_as_renamed env ccl = function | AnonHyp n -> pf_lookup_index_as_renamed env ccl n @@ -435,7 +477,7 @@ let try_intros_until tac = function let rec intros_move = function | [] -> tclIDTAC | (hyp,destopt) :: rest -> - tclTHEN (intro_gen (IntroMustBe hyp) destopt false) + tclTHEN (intro_gen dloc (IntroMustBe hyp) destopt false) (intros_move rest) let dependent_in_decl a (_,c,t) = @@ -443,33 +485,6 @@ let dependent_in_decl a (_,c,t) = | None -> dependent a t | Some body -> dependent a body || dependent a t -let move_to_rhyp rhyp gl = - let rec get_lhyp lastfixed depdecls = function - | [] -> - (match rhyp with - | None -> lastfixed - | Some h -> anomaly ("Hypothesis should occur: "^ (string_of_id h))) - | (hyp,c,typ) as ht :: rest -> - if Some hyp = rhyp then - lastfixed - else if List.exists (occur_var_in_decl (pf_env gl) hyp) depdecls then - get_lhyp lastfixed (ht::depdecls) rest - else - get_lhyp (Some hyp) depdecls rest - in - let sign = pf_hyps gl in - let (hyp,c,typ as decl) = List.hd sign in - match get_lhyp None [decl] (List.tl sign) with - | None -> tclIDTAC gl - | Some hypto -> move_hyp true hyp hypto gl - -let rec intros_rmove = function - | [] -> tclIDTAC - | (hyp,destopt) :: rest -> - tclTHENLIST [ introduction hyp; - move_to_rhyp destopt; - intros_rmove rest ] - (* Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) @@ -530,9 +545,7 @@ let cut_intro t = tclTHENFIRST (cut t) intro (* 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) [ - tclORELSE (intro_replacing id) (intro_erasing id); - tac (refine_no_check (mkVar id)) ] + tclTHENS (cut t) [ intro_replacing id; tac (refine_no_check (mkVar id)) ] let cut_in_parallel l = let rec prec = function @@ -644,6 +657,12 @@ let simplest_elim c = default_elim false (c,NoBindings) (e.g. it could replace id:A->B->C by id:C, knowing A/\B) *) +let clenv_fchain_in id elim_flags mv elimclause hypclause = + try clenv_fchain ~allow_K:false ~flags:elim_flags mv elimclause hypclause + with PretypeError (env,NoOccurrenceFound (op,_)) -> + (* Set the hypothesis name in the message *) + raise (PretypeError (env,NoOccurrenceFound (op,Some id))) + let elimination_in_clause_scheme with_evars id elimclause indclause gl = let (hypmv,indmv) = match clenv_independent elimclause with @@ -654,8 +673,8 @@ let elimination_in_clause_scheme with_evars id elimclause indclause gl = let hyp = mkVar id in let hyp_typ = pf_type_of gl hyp in let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in - let elimclause'' = - clenv_fchain ~allow_K:false ~flags:elim_flags hypmv elimclause' hypclause in + let elimclause'' = + clenv_fchain_in id elim_flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in if eq_constr hyp_typ new_hyp_typ then errorlabstrm "general_rewrite_in" @@ -752,16 +771,22 @@ let general_apply with_delta with_destruct with_evars (c,lbind) gl = try_red_apply thm_ty0 in try_main_apply c gl -let apply_with_ebindings_gen b = general_apply b b +let rec apply_with_ebindings_gen b e = function + | [] -> + tclIDTAC + | [cb] -> + general_apply b b e cb + | cb::cbl -> + tclTHENLAST (general_apply b b e cb) (apply_with_ebindings_gen b e cbl) -let apply_with_ebindings = apply_with_ebindings_gen false false -let eapply_with_ebindings = apply_with_ebindings_gen false true +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) let eapply_with_bindings (c,bl) = - apply_with_ebindings_gen false true (c,inj_ebindings bl) + apply_with_ebindings_gen false true [c,inj_ebindings bl] let apply c = apply_with_ebindings (c,NoBindings) @@ -897,14 +922,10 @@ let clear_body = thin_body let clear_wildcards ids = tclMAP (fun (loc,id) gl -> try with_check (Tacmach.thin_no_check [id]) gl - with OccurHypInSimpleClause (id,ido) -> + with ClearDependencyError (id,err) -> (* Intercept standard [thin] error message *) - match ido with - | None -> - user_err_loc (loc,"",str "_ is used in conclusion.") - | Some id -> - user_err_loc - (loc,"",str "_ is used in hypothesis " ++ pr_id id ++ str ".")) + Stdpp.raise_with_loc loc + (error_clear_dependency (pf_env gl) (id_of_string "_") err)) ids (* Takes a list of booleans, and introduces all the variables @@ -946,12 +967,11 @@ let specialize mopt (c,lbind) g = in tclTHEN (match evars with Some e -> tclEVARS e | _ -> tclIDTAC) - (match kind_of_term (fst (decompose_app c)) with - | Var id when List.exists (fun (i,_,_)-> i=id) (pf_hyps g) -> - let id' = fresh_id [] id g in - tclTHENS (fun g -> internal_cut id' (pf_type_of g term) g) - [ exact_no_check term; - tclTHEN (clear [id]) (rename_hyp [id',id]) ] + (match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with + | Var id when List.mem id (pf_ids_of_hyps g) -> + tclTHENFIRST + (fun g -> internal_cut_replace id (pf_type_of g term) g) + (exact_no_check term) | _ -> tclTHENLAST (fun g -> cut (pf_type_of g term) g) (exact_no_check term)) @@ -1047,22 +1067,33 @@ let fix_empty_case nv l = and "[ ]" for no clause at all; so we are a bit liberal here *) if Array.length nv = 0 & l = [[]] then [] else l -let intro_or_and_pattern ll l' tac = +let error_unexpected_extra_pattern loc nb pat = + let s1,s2,s3 = match pat with + | IntroIdentifier _ -> "name", (plural nb " introduction pattern"), "no" + | _ -> "introduction pattern", "", "none" in + user_err_loc (loc,"",str "Unexpected " ++ str s1 ++ str " (" ++ + (if nb = 0 then (str s3 ++ str s2) else + (str "at most " ++ int nb ++ str s2)) ++ spc () ++ + str (if nb = 1 then "was" else "were") ++ + strbrk " expected in the branch).") + +let intro_or_and_pattern loc b ll l' tac = tclLAST_HYP (fun c gl -> let ind,_ = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let nv = mis_constr_nargs ind in - let rec adjust_names_length tail n = function - | [] when n = 0 or tail -> [] - | [] -> IntroAnonymous :: adjust_names_length tail (n-1) [] - | _ :: _ as l when n = 0 -> - if tail then l else error "Too many names in some branch." - | ip :: l -> ip :: adjust_names_length tail (n-1) l in + let bracketed = b or not (l'=[]) in + let rec adjust_names_length nb n = function + | [] when n = 0 or not bracketed -> [] + | [] -> (dloc,IntroAnonymous) :: adjust_names_length nb (n-1) [] + | (loc',pat) :: _ as l when n = 0 -> + 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 - if List.length ll <> Array.length nv then - error "Not the right number of patterns."; + check_or_and_pattern_size loc ll (Array.length nv); tclTHENLASTn (tclTHEN case_last clear_last) - (array_map2 (fun n l -> tac ((adjust_names_length (l'=[]) n l)@l')) + (array_map2 (fun n l -> tac ((adjust_names_length n n l)@l')) nv (Array.of_list ll)) gl) @@ -1074,11 +1105,11 @@ let clear_if_atomic l2r id gl = else tclIDTAC gl let rec explicit_intro_names = function -| IntroIdentifier id :: l -> +| (_, IntroIdentifier id) :: l -> id :: explicit_intro_names l -| (IntroWildcard _ | IntroAnonymous | IntroFresh _ | IntroRewrite _) :: l -> +| (_, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _)) :: l -> explicit_intro_names l -| IntroOrAndPattern ll :: l' -> +| (_, IntroOrAndPattern ll) :: l' -> List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll) | [] -> [] @@ -1087,84 +1118,90 @@ let rec explicit_intro_names = function to ensure that dependent hypotheses are cleared in the right dependency order (see bug #1000); we use fresh names, not used in the tactic, for the hyps to clear *) -let rec intros_patterns avoid thin destopt = function - | IntroWildcard loc :: l -> +let rec intros_patterns b avoid thin destopt = function + | (loc, IntroWildcard) :: l -> tclTHEN - (intro_gen (IntroAvoid (avoid@explicit_intro_names l)) None true) + (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true) (onLastHyp (fun id -> tclORELSE - (tclTHEN (clear [id]) (intros_patterns avoid thin destopt l)) - (intros_patterns avoid ((loc,id)::thin) destopt l))) - | IntroIdentifier id :: l -> + (tclTHEN (clear [id]) (intros_patterns b avoid thin destopt l)) + (intros_patterns b avoid ((loc,id)::thin) destopt l))) + | (loc, IntroIdentifier id) :: l -> tclTHEN - (intro_gen (IntroMustBe id) destopt true) - (intros_patterns avoid thin destopt l) - | IntroAnonymous :: l -> + (intro_gen loc (IntroMustBe id) destopt true) + (intros_patterns b avoid thin destopt l) + | (loc, IntroAnonymous) :: l -> tclTHEN - (intro_gen (IntroAvoid (avoid@explicit_intro_names l)) destopt true) - (intros_patterns avoid thin destopt l) - | IntroFresh id :: l -> + (intro_gen loc (IntroAvoid (avoid@explicit_intro_names l)) + destopt true) + (intros_patterns b avoid thin destopt l) + | (loc, IntroFresh id) :: l -> tclTHEN - (intro_gen (IntroBasedOn (id, avoid@explicit_intro_names l)) destopt true) - (intros_patterns avoid thin destopt l) - | IntroOrAndPattern ll :: l' -> + (intro_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l)) + destopt true) + (intros_patterns b avoid thin destopt l) + | (loc, IntroOrAndPattern ll) :: l' -> tclTHEN introf - (intro_or_and_pattern ll l' (intros_patterns avoid thin destopt)) - | IntroRewrite l2r :: l -> + (intro_or_and_pattern loc b ll l' + (intros_patterns b avoid thin destopt)) + | (loc, IntroRewrite l2r) :: l -> tclTHEN - (intro_gen (IntroAvoid (avoid@explicit_intro_names l)) None true) + (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 avoid thin destopt l ])) + intros_patterns b avoid thin destopt l ])) | [] -> clear_wildcards thin -let intros_pattern = intros_patterns [] [] +let intros_pattern = intros_patterns false [] [] -let intro_pattern destopt pat = intros_patterns [] [] destopt [pat] +let intro_pattern destopt pat = intros_patterns false [] [] destopt [dloc,pat] let intro_patterns = function | [] -> tclREPEAT intro - | l -> intros_pattern None l + | l -> intros_pattern no_move l (**************************) (* Other cut tactics *) (**************************) -let hid = id_of_string "H" -let xid = id_of_string "X" - -let make_id s = fresh_id [] (match s with Prop _ -> hid | Type _ -> xid) +let make_id s = fresh_id [] (default_id_of_sort s) -let prepare_intros s ipat gl = match ipat with +let prepare_intros s (loc,ipat) gl = match ipat with + | IntroIdentifier id -> id, tclIDTAC | IntroAnonymous -> make_id s gl, tclIDTAC | IntroFresh id -> fresh_id [] id gl, tclIDTAC - | IntroWildcard loc -> let id = make_id s gl in id, clear_wildcards [loc,id] - | IntroIdentifier id -> id, 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 | IntroOrAndPattern ll -> make_id s gl, - (tclTHENS - (tclTHEN case_last clear_last) - (List.map (intros_pattern None) ll)) + intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move) let ipat_of_name = function | Anonymous -> IntroAnonymous | Name id -> IntroIdentifier id +let allow_replace c gl = function (* A rather arbitrary condition... *) + | _, IntroIdentifier id -> + fst (decompose_app (snd (decompose_lam_assum c))) = mkVar id + | _ -> + false + let assert_as first ipat c gl = match kind_of_term (hnf_type_of gl c) with | Sort s -> let id,tac = prepare_intros s ipat gl in - tclTHENS ((if first then internal_cut else internal_cut_rev) id c) + let repl = allow_replace c gl ipat in + tclTHENS + ((if first then internal_cut_gen else internal_cut_rev_gen) repl id c) (if first then [tclIDTAC; tac] else [tac; tclIDTAC]) gl | _ -> error "Not a proposition or a type." -let assert_tac first na = assert_as first (ipat_of_name na) +let assert_tac first na = assert_as first (dloc,ipat_of_name na) let true_cut = assert_tac true (**************************) @@ -1363,7 +1400,8 @@ let letin_abstract id c occs gl = let ccl = match occurrences_of_goal occs with | None -> pf_concl gl | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl)) in - let lastlhyp = if depdecls = [] then None else Some(pi1(list_last depdecls)) in + let lastlhyp = + if depdecls = [] then no_move else MoveAfter(pi1(list_last depdecls)) in (depdecls,lastlhyp,ccl) let letin_tac with_eq name c occs gl = @@ -1375,19 +1413,25 @@ let letin_tac with_eq name c occs gl = let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in let t = pf_type_of gl c in let newcl,eq_tac = match with_eq with - | Some lr -> - let heq = fresh_id [] (add_prefix "Heq" id) gl in + | Some (lr,(loc,ido)) -> + let heq = match ido with + | IntroAnonymous -> fresh_id [id] (add_prefix "Heq" id) gl + | IntroFresh heq_base -> fresh_id [id] heq_base gl + | IntroIdentifier id -> id + | _ -> error"Expect an introduction pattern naming one hypothesis." in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in let eq = applist (eqdata.eq,args) in let refl = applist (eqdata.refl, [t;mkVar id]) in mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)), - tclTHEN (intro_gen (IntroMustBe heq) lastlhyp true) (thin_body [heq;id]) + tclTHEN + (intro_gen loc (IntroMustBe heq) lastlhyp true) + (thin_body [heq;id]) | None -> mkNamedLetIn id c t ccl, tclIDTAC in tclTHENLIST [ convert_concl_no_check newcl DEFAULTcast; - intro_gen (IntroMustBe id) lastlhyp true; + intro_gen dloc (IntroMustBe id) lastlhyp true; eq_tac; tclMAP convert_hyp_no_check depdecls ] gl @@ -1467,76 +1511,85 @@ let unfold_all x gl = let check_unused_names names = if names <> [] & Flags.is_verbose () then - let s = if List.tl names = [] then " " else "s " in msg_warning - (str"Unused introduction pattern" ++ str s ++ - str": " ++ prlist_with_sep spc pr_intro_pattern names) - -let rec first_name_buggy = function - | IntroOrAndPattern [] -> None - | IntroOrAndPattern ([]::l) -> first_name_buggy (IntroOrAndPattern l) - | IntroOrAndPattern ((p::_)::_) -> first_name_buggy p - | IntroWildcard _ -> None - | IntroRewrite _ -> None - | IntroIdentifier id -> Some id + (str"Unused introduction " ++ str (plural (List.length names) "pattern") + ++ str": " ++ prlist_with_sep spc pr_intro_pattern names) + +let rec first_name_buggy avoid gl (loc,pat) = match pat with + | IntroOrAndPattern [] -> no_move + | IntroOrAndPattern ([]::l) -> + first_name_buggy avoid gl (loc,IntroOrAndPattern l) + | IntroOrAndPattern ((p::_)::_) -> first_name_buggy avoid gl p + | IntroWildcard -> no_move + | IntroRewrite _ -> no_move + | IntroIdentifier id -> MoveAfter id | IntroAnonymous | IntroFresh _ -> assert false let consume_pattern avoid id gl = function - | [] -> (IntroIdentifier (fresh_id avoid id gl), []) - | IntroAnonymous::names -> + | [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), []) + | (loc,IntroAnonymous)::names -> let avoid = avoid@explicit_intro_names names in - (IntroIdentifier (fresh_id avoid id gl), names) + ((loc,IntroIdentifier (fresh_id avoid id gl)), names) + | (loc,IntroFresh id')::names -> + let avoid = avoid@explicit_intro_names names in + ((loc,IntroIdentifier (fresh_id avoid id' gl)), names) | pat::names -> (pat,names) let re_intro_dependent_hypotheses tophyp (lstatus,rstatus) = let newlstatus = (* if some IH has taken place at the top of hyps *) - List.map (function (hyp,None) -> (hyp,tophyp) | x -> x) lstatus in + List.map (function (hyp,MoveToEnd true) -> (hyp,tophyp) | x -> x) lstatus + in tclTHEN - (intros_rmove rstatus) + (intros_move rstatus) (intros_move newlstatus) +let update destopt tophyp = if destopt = no_move then tophyp else destopt + type elim_arg_kind = RecArg | IndArg | OtherArg let induct_discharge statuslists destopt avoid' (avoid,ra) names gl = let avoid = avoid @ avoid' in - let rec peel_tac ra names tophyp gl = match ra with + let rec peel_tac ra names tophyp gl = + match ra with | (RecArg,recvarname) :: (IndArg,hyprecname) :: ra' -> let recpat,names = match names with - | [IntroIdentifier id as pat] -> - let id = next_ident_away (add_prefix "IH" id) avoid in - (pat, [IntroIdentifier id]) + | [loc,IntroIdentifier id as pat] -> + let id' = next_ident_away (add_prefix "IH" id) avoid in + (pat, [dloc, IntroIdentifier id']) | _ -> consume_pattern avoid recvarname gl names in let hyprec,names = consume_pattern avoid hyprecname gl names in (* IH stays at top: we need to update tophyp *) (* This is buggy for intro-or-patterns with different first hypnames *) (* Would need to pass peel_tac as a continuation of intros_patterns *) (* (or to have hypotheses classified by blocks...) *) - let tophyp = if tophyp=None then first_name_buggy hyprec else tophyp in + let newtophyp = + if tophyp=no_move then first_name_buggy avoid gl hyprec else tophyp + in tclTHENLIST - [ intros_patterns avoid [] destopt [recpat]; - intros_patterns avoid [] None [hyprec]; - peel_tac ra' names tophyp] gl + [ intros_patterns true avoid [] (update destopt tophyp) [recpat]; + intros_patterns true avoid [] no_move [hyprec]; + peel_tac ra' names newtophyp] gl | (IndArg,hyprecname) :: ra' -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = consume_pattern avoid hyprecname gl names in - tclTHEN (intros_patterns avoid [] destopt [pat]) + tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat]) (peel_tac ra' names tophyp) gl | (RecArg,recvarname) :: ra' -> let pat,names = consume_pattern avoid recvarname gl names in - tclTHEN (intros_patterns avoid [] destopt [pat]) + tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat]) (peel_tac ra' names tophyp) gl | (OtherArg,_) :: ra' -> let pat,names = match names with - | [] -> IntroAnonymous, [] + | [] -> (dloc, IntroAnonymous), [] | pat::names -> pat,names in - tclTHEN (intros_patterns avoid [] destopt [pat]) + tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat]) (peel_tac ra' names tophyp) gl | [] -> check_unused_names names; re_intro_dependent_hypotheses tophyp statuslists gl in - peel_tac ra names None gl + peel_tac ra names no_move gl (* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas s'embêter à regarder si un letin_tac ne fait pas des @@ -1594,7 +1647,7 @@ let find_atomic_param_of_ind nparams indtyp = Idset.elements !indvars; - (* [cook_sign] builds the lists [indhyps] of hyps that must be +(* [cook_sign] builds the lists [indhyps] of hyps that must be erased, the lists of hyps to be generalize [(hdeps,tdeps)] on the goal together with the places [(lstatus,rstatus)] where to re-intro them after induction. To know where to re-intro the dep hyp, we @@ -1605,7 +1658,7 @@ let find_atomic_param_of_ind nparams indtyp = more ancient (on the right) to more recent hyp (on the left) but the computation of [lhyp] progresses from the other way, [cook_hyp] is in two passes (an alternative would have been to write an - higher-order algorithm). We strongly use references to reduce + higher-order algorithm). We use references to reduce the accumulation of arguments. To summarize, the situation looks like this @@ -1657,7 +1710,7 @@ let find_atomic_param_of_ind nparams indtyp = *) -exception Shunt of identifier option +exception Shunt of identifier move_location let cook_sign hyp0_opt indvars_init env = let hyp0,indvars = @@ -1679,7 +1732,7 @@ let cook_sign hyp0_opt indvars_init env = (* If there was no main induction hypotheses, then hyp is one of indvars too, so add it to indhyps. *) (if hyp0_opt=None then indhyps := hyp::!indhyps); - None (* fake value *) + MoveToEnd false (* fake value *) end else if List.mem hyp indvars then begin (* warning: hyp can still occur after induction *) (* e.g. if the goal (t hyp hyp0) with other occs of hyp in t *) @@ -1695,11 +1748,11 @@ let cook_sign hyp0_opt indvars_init env = rstatus := (hyp,rhyp)::!rstatus else ldeps := hyp::!ldeps; (* status computed in 2nd phase *) - Some hyp end + MoveBefore hyp end else - Some hyp + MoveBefore hyp in - let _ = fold_named_context seek_deps env ~init:None in + let _ = fold_named_context seek_deps env ~init:(MoveToEnd false) in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) let compute_lstatus lhyp (hyp,_,_) = if hyp = hyp0 then raise (Shunt lhyp); @@ -1707,15 +1760,16 @@ let cook_sign hyp0_opt indvars_init env = lstatus := (hyp,lhyp)::!lstatus; lhyp end else - if List.mem hyp !indhyps then lhyp else (Some hyp) + if List.mem hyp !indhyps then lhyp else MoveAfter hyp in try - let _ = fold_named_context_reverse compute_lstatus ~init:None env in -(* anomaly "hyp0 not found" *) - raise (Shunt (None)) (* ?? FIXME *) + let _ = + fold_named_context_reverse compute_lstatus ~init:(MoveToEnd true) env in + raise (Shunt (MoveToEnd true)) (* ?? FIXME *) with Shunt lhyp0 -> let statuslists = (!lstatus,List.rev !rstatus) in - (statuslists, (if hyp0_opt=None then None else lhyp0) , !indhyps, !decldeps) + (statuslists, (if hyp0_opt=None then MoveToEnd true else lhyp0), + !indhyps, !decldeps) (* @@ -1801,9 +1855,9 @@ let make_base n id = (* digits *) id_of_string (atompart_of_id (make_ident (string_of_id id) (Some 0))) -(* Builds tw different names from an optional inductive type and a +(* Builds two different names from an optional inductive type and a number, also deals with a list of names to avoid. If the inductive - type is None, then hyprecname is HIi where i is a number. *) + type is None, then hyprecname is IHi where i is a number. *) let make_up_names n ind_opt cname = let is_hyp = atompart_of_id cname = "H" in let base = string_of_id (make_base n cname) in @@ -2032,11 +2086,11 @@ let cut_list n l = res -(* This functions splits the products of the induction scheme [elimt] in three +(* This function splits the products of the induction scheme [elimt] into four parts: - - branches, easily detectable (they are not referred by rels in the subterm) - - what was found before branches (acc1) that is: parameters and predicates - - what was found after branches (acc3) that is: args and indarg if any + - branches, easily detectable (they are not referred by rels in the subterm) + - what was found before branches (acc1) that is: parameters and predicates + - what was found after branches (acc3) that is: args and indarg if any if there is no branch, we try to fill in acc3 with args/indargs. We also return the conclusion. *) @@ -2079,7 +2133,7 @@ let exchange_hd_app subst_hd t = (* [rebuild_elimtype_from_scheme scheme] rebuilds the type of an eliminator from its [scheme_info]. The idea is to build variants of - eliminator by modifying there scheme_info, then rebuild the + eliminator by modifying their scheme_info, then rebuild the eliminator type, then prove it (with tactics). *) let rebuild_elimtype_from_scheme (scheme:elim_scheme): types = let hiconcl = @@ -2096,7 +2150,7 @@ let rebuild_elimtype_from_scheme (scheme:elim_scheme): types = exception NoLastArg exception NoLastArgCcl -(* Builds an elim_scheme frome its type and calling form (const+binding) We +(* Builds an elim_scheme from its type and calling form (const+binding). We first separate branches. We obtain branches, hyps before (params + preds), hyps after (args <+ indarg if present>) and conclusion. Then we proceed as follows: @@ -2184,17 +2238,17 @@ let compute_elim_sig ?elimc elimt = extra final argument of the form (f x y ...) in the conclusion. In the non standard case, naming of generated hypos is slightly different. *) -let compute_elim_signature elimc elimt names_info = +let compute_elim_signature elimc elimt names_info ind_type_guess = let scheme = compute_elim_sig ~elimc:elimc elimt in let f,l = decompose_app scheme.concl in (* Vérifier que les arguments de Qi sont bien les xi. *) match scheme.indarg with | Some (_,Some _,_) -> error "Strange letin, cannot recognize an induction scheme." | None -> (* Non standard scheme *) - let npred = List.length scheme.predicates in let is_pred n c = let hd = fst (decompose_app c) in match kind_of_term hd with - | Rel q when n < q & q <= n+npred -> IndArg + | Rel q when n < q & q <= n+scheme.npredicates -> IndArg + | _ when hd = ind_type_guess & not scheme.farg_in_concl -> RecArg | _ -> OtherArg in let rec check_branch p c = match kind_of_term c with @@ -2223,10 +2277,9 @@ let compute_elim_signature elimc elimt names_info = | Some ( _,None,ind) -> (* Standard scheme from an inductive type *) let indhd,indargs = decompose_app ind in - let npred = List.length scheme.predicates in let is_pred n c = let hd = fst (decompose_app c) in match kind_of_term hd with - | Rel q when n < q & q <= n+npred -> IndArg + | Rel q when n < q & q <= n+scheme.npredicates -> IndArg | _ when hd = indhd -> RecArg | _ -> OtherArg in let rec check_branch p c = match kind_of_term c with @@ -2266,7 +2319,7 @@ let compute_elim_signature elimc elimt names_info = let find_elim_signature isrec elim hyp0 gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in - let (elimc,elimt) = match elim with + let (elimc,elimt),ind = match elim with | None -> let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in let s = elimination_sort_of_goal gl in @@ -2274,21 +2327,15 @@ let find_elim_signature isrec elim hyp0 gl = if isrec then lookup_eliminator mind s else pf_apply make_case_gen gl mind s in let elimt = pf_type_of gl elimc in - ((elimc, NoBindings), elimt) - | Some (elimc,lbind as e) -> - (e, pf_type_of gl elimc) in - let indsign,elim_scheme = compute_elim_signature elimc elimt hyp0 in + ((elimc, NoBindings), elimt), mkInd mind + | Some (elimc,lbind as e) -> + let ind_type_guess,_ = decompose_app (snd (decompose_prod tmptyp0)) in + (e, pf_type_of gl elimc), ind_type_guess in + let indsign,elim_scheme = + compute_elim_signature elimc elimt hyp0 ind in (indsign,elim_scheme) -let mapi f l = - let rec mapi_aux f i l = - match l with - | [] -> [] - | e::l' -> f e i :: mapi_aux f (i+1) l' in - mapi_aux f 0 l - - (* Instantiate all meta variables of elimclause using lid, some elts of lid are parameters (first ones), the other are arguments. Returns the clause obtained. *) @@ -2307,12 +2354,13 @@ let recolle_clenv scheme lid elimclause gl = let nidargs = List.length lidargs in (* parameters correspond to first elts of lid. *) let clauses_params = - mapi (fun id i -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i)) lidparams in + list_map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i)) + 0 lidparams in (* arguments correspond to last elts of lid. *) let clauses_args = - mapi - (fun id i -> mkVar id , pf_get_hyp_typ gl id , lindmv.(nmv-nidargs+i)) - lidargs in + list_map_i + (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(nmv-nidargs+i)) + 0 lidargs in let clause_indarg = match scheme.indarg with | None -> [] @@ -2336,7 +2384,7 @@ let recolle_clenv scheme lid elimclause gl = (elimc ?i ?j ?k...?l). This solves partly meta variables (and may produce new ones). Then refine with the resulting term with holes. *) -let induction_tac_felim with_evars indvars (* (elimc,lbindelimc) elimt *) scheme gl = +let induction_tac_felim with_evars indvars scheme gl = let elimt = scheme.elimt in let elimc,lbindelimc = match scheme.elimc with | Some x -> x | None -> error "No definition of the principle." in @@ -2349,6 +2397,29 @@ let induction_tac_felim with_evars indvars (* (elimc,lbindelimc) elimt *) scheme let resolved = clenv_unique_resolver true elimclause' gl in clenv_refine with_evars resolved gl +let apply_induction_in_context isrec hyp0 indsign indvars names induct_tac gl = + let env = pf_env gl in + let statlists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in + let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in + let names = compute_induction_names (Array.length indsign) names in + let dephyps = List.map (fun (id,_,_) -> id) deps in + let deps_cstr = + List.fold_left + (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in + tclTHENLIST + [ + (* Generalize dependent hyps (but not args) *) + if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr; + (* clear dependent hyps *) + thin dephyps; + (* side-conditions in elim (resp case) schemes come last (resp first) *) + (if isrec then tclTHENFIRSTn else tclTHENLASTn) + (tclTHEN induct_tac (tclTRY (thin (List.rev indhyps)))) + (array_map2 + (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names) + ] + gl + (* Induction with several induction arguments, main differences with induction_from_context is that there is no main induction argument, so we chose one to be the positioning reference. On the other hand, @@ -2364,7 +2435,6 @@ let induction_from_context_l isrec with_evars elim_info lid names gl = (* Number of given induction args must be exact. *) if List.length lid <> nargs_indarg_farg + scheme.nparams then error "Not the right number of arguments given to induction scheme."; - let env = pf_env gl in (* hyp0 is used for re-introducing hyps at the right place afterward. We chose the first element of the list of variables on which to induct. It is probably the first of them appearing in the @@ -2376,12 +2446,6 @@ let induction_from_context_l isrec with_evars elim_info lid names gl = let nargs_without_first = nargs_indarg_farg - 1 in let ivs,lp = cut_list nargs_without_first l in e, ivs, lp in - let statlists,lhyp0,indhyps,deps = cook_sign None (hyp0::indvars) env in - let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in - let names = compute_induction_names (Array.length indsign) names in - let dephyps = List.map (fun (id,_,_) -> id) deps in - let deps_cstr = - List.fold_left (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in (* terms to patternify we must patternify indarg or farg if present in concl *) let lid_in_pattern = if scheme.indarg <> None & not scheme.indarg_in_concl then List.rev indvars @@ -2390,68 +2454,32 @@ let induction_from_context_l isrec with_evars elim_info lid names gl = let realindvars = (* hyp0 is a real induction arg if it is not the farg in the conclusion of the induction scheme *) List.rev ((if scheme.farg_in_concl then indvars else hyp0::indvars) @ lid_params) in - (* Magistral effet de bord: comme dans induction_from_context. *) - tclTHENLIST - [ - (* Generalize dependent hyps (but not args) *) - if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr; - thin dephyps; (* clear dependent hyps *) - (* pattern to make the predicate appear. *) - reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl; - (* FIXME: Tester ca avec un principe dependant et non-dependant *) - (if isrec then tclTHENFIRSTn else tclTHENLASTn) - (tclTHENLIST [ - (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all - possible holes using arguments given by the user (but the - functional one). *) - induction_tac_felim with_evars realindvars scheme; - tclTRY (thin (List.rev (indhyps))); - ]) - (array_map2 - (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names) - ] - gl - - + let induct_tac = tclTHENLIST [ + (* pattern to make the predicate appear. *) + reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl; + (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all + possible holes using arguments given by the user (but the + functional one). *) + (* FIXME: Tester ca avec un principe dependant et non-dependant *) + induction_tac_felim with_evars realindvars scheme + ] in + 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 indsign,scheme = elim_info in let indref = match scheme.indref with | None -> assert false | Some x -> x in let tmptyp0 = pf_get_hyp_typ gl hyp0 in let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in - - let env = pf_env gl in - let indvars = find_atomic_param_of_ind scheme.nparams (snd (decompose_prod typ0)) in - (* induction_from_context_l isrec elim_info (hyp0::List.rev indvars) names gl *) - let statlists,lhyp0,indhyps,deps = cook_sign (Some hyp0) indvars env in - let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in - let names = compute_induction_names (Array.length indsign) names in - let dephyps = List.map (fun (id,_,_) -> id) deps in - let deps_cstr = - List.fold_left - (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in - - (* Magistral effet de bord: si hyp0 a des arguments, ceux d'entre - eux qui ouvrent de nouveaux buts arrivent en premier dans la - liste des sous-buts du fait qu'ils sont le plus à gauche dans le - combinateur engendré par make_case_gen (un "Cases (hyp0 ?) of - ...") et il faut alors appliquer tclTHENLASTn; en revanche, - comme lookup_eliminator renvoie un combinateur de la forme - "ind_rec ... (hyp0 ?)", les buts correspondant à des arguments de - hyp0 sont maintenant à la fin et c'est tclTHENFIRSTn qui marche !!! *) - tclTHENLIST - [ if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr; - thin dephyps; - (if isrec then tclTHENFIRSTn else tclTHENLASTn) - (tclTHENLIST - [ induction_tac with_evars (hyp0,lbind) typ0 scheme; - tclTHEN (tclTRY (unfold_body hyp0)) (thin [hyp0]); - tclTRY (thin indhyps) ]) - (array_map2 - (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names) - ] - gl - + let indvars = + find_atomic_param_of_ind scheme.nparams (snd (decompose_prod typ0)) in + let induct_tac = tclTHENLIST [ + induction_tac with_evars (hyp0,lbind) typ0 scheme; + tclTRY (unfold_body hyp0); + thin [hyp0] + ] in + apply_induction_in_context isrec + (Some hyp0) indsign indvars names induct_tac gl exception TryNewInduct of exn @@ -2484,17 +2512,22 @@ 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 new_induct_gen isrec with_evars elim names (c,lbind) cls gl = +let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl = match kind_of_term c with | Var id when not (mem_named_context id (Global.named_context())) - & lbind = NoBindings & not with_evars & cls = None -> + & lbind = NoBindings & not with_evars & cls = None + & eqname = None -> induction_with_atomization_of_ind_arg isrec with_evars elim names (id,lbind) 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 = if cls <> None then Some (not (isVar c)) else None in + let with_eq = + match eqname with + | Some eq -> Some (false,eq) + | _ -> + if cls <> None then Some (false,(dloc,IntroAnonymous)) else None in tclTHEN (letin_tac with_eq (Name id) c (Option.default allClauses cls)) (induction_with_atomization_of_ind_arg @@ -2505,7 +2538,10 @@ let new_induct_gen isrec with_evars elim names (c,lbind) cls gl = that all arguments and parameters of the scheme are given (mandatory for the moment), so we don't need to deal with parameters of the inductive type as in new_induct_gen. *) -let new_induct_gen_l isrec with_evars elim names lc gl = +let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl = + if eqname <> None then + errorlabstrm "" (str "Do not know what to do with " ++ + pr_intro_pattern (Option.get eqname)); let newlc = ref [] in let letids = ref [] in let rec atomize_list l gl = @@ -2566,7 +2602,7 @@ let induct_destruct_l isrec with_evars lc elim names cls = principles). TODO: really unify induction with one and induction with several args *) -let induct_destruct isrec with_evars lc elim names cls = +let induct_destruct isrec with_evars (lc,elim,names,cls) = assert (List.length lc > 0); (* ensured by syntax, but if called inside caml? *) if List.length lc = 1 then (* induction on one arg: use old mechanism *) try @@ -2580,11 +2616,16 @@ let induct_destruct isrec with_evars lc elim names cls = with _ -> raise x) else induct_destruct_l isrec with_evars lc elim names cls +let induction_destruct isrec with_evars = function + | [] -> tclIDTAC + | [a] -> induct_destruct isrec with_evars a + | a::l -> + tclTHEN + (induct_destruct isrec with_evars a) + (tclMAP (induct_destruct false with_evars) l) - - -let new_induct = induct_destruct true -let new_destruct = induct_destruct false +let new_induct ev lc e idl cls = induct_destruct true ev (lc,e,idl,cls) +let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls) (* The registered tactic, which calls the default elimination * if no elimination constant is provided. *) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 9070e2617..56597f58e 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -9,6 +9,7 @@ (*i $Id$ i*) (*i*) +open Util open Names open Term open Environ @@ -68,7 +69,8 @@ val find_intro_names : rel_context -> goal sigma -> identifier list val intro : tactic val introf : tactic val intro_force : bool -> tactic -val intro_move : identifier option -> identifier option -> tactic +val intro_move : identifier option -> identifier move_location -> tactic + (* [intro_avoiding idl] acts as intro but prevents the new identifier to belong to [idl] *) val intro_avoiding : identifier list -> tactic @@ -110,9 +112,10 @@ val onInductionArg : (*s Introduction tactics with eliminations. *) -val intro_pattern : identifier option -> intro_pattern_expr -> tactic -val intro_patterns : intro_pattern_expr list -> tactic -val intros_pattern : identifier option -> intro_pattern_expr list -> tactic +val intro_pattern : identifier move_location -> intro_pattern_expr -> tactic +val intro_patterns : intro_pattern_expr located list -> tactic +val intros_pattern : + identifier move_location -> intro_pattern_expr located list -> tactic (*s Exact tactics. *) @@ -167,7 +170,7 @@ val keep : identifier list -> tactic val specialize : int option -> constr with_ebindings -> tactic -val move_hyp : bool -> identifier -> identifier -> tactic +val move_hyp : bool -> identifier -> identifier move_location -> tactic val rename_hyp : (identifier * identifier) list -> tactic val revert : identifier list -> tactic @@ -183,7 +186,7 @@ val apply_without_reduce : constr -> tactic val apply_list : constr list -> tactic val apply_with_ebindings_gen : - advanced_flag -> evars_flag -> constr with_ebindings -> tactic + advanced_flag -> evars_flag -> constr with_ebindings list -> tactic val apply_with_bindings : constr with_bindings -> tactic val eapply_with_bindings : constr with_bindings -> tactic @@ -260,7 +263,9 @@ val elim : val simple_induct : quantified_hypothesis -> tactic val new_induct : evars_flag -> constr with_ebindings induction_arg list -> - constr with_ebindings option -> intro_pattern_expr -> clause option -> tactic + constr with_ebindings option -> + intro_pattern_expr located option * intro_pattern_expr located option -> + clause option -> tactic (*s Case analysis tactics. *) @@ -269,7 +274,18 @@ val simplest_case : constr -> tactic val simple_destruct : quantified_hypothesis -> tactic val new_destruct : evars_flag -> constr with_ebindings induction_arg list -> - constr with_ebindings option -> intro_pattern_expr -> clause option -> tactic + constr with_ebindings option -> + intro_pattern_expr located option * intro_pattern_expr located option -> + clause option -> tactic + +(*s Generic case analysis / induction tactics. *) + +val induction_destruct : evars_flag -> rec_flag -> + (constr with_ebindings induction_arg list * + constr with_ebindings option * + (intro_pattern_expr located option * intro_pattern_expr located option) * + clause option) list -> + tactic (*s Eliminations giving the type instead of the proof. *) @@ -330,9 +346,10 @@ val cut_replacing : identifier -> constr -> (tactic -> tactic) -> tactic val cut_in_parallel : constr list -> tactic -val assert_as : bool -> intro_pattern_expr -> constr -> tactic -val forward : tactic option -> intro_pattern_expr -> constr -> tactic -val letin_tac : bool option -> name -> constr -> clause -> tactic +val assert_as : bool -> intro_pattern_expr located -> constr -> tactic +val forward : tactic option -> intro_pattern_expr located -> 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 val generalize : constr list -> tactic diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 90705c8c9..d3dd2959c 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -142,7 +142,7 @@ let rec tauto_intuit t_reduce solver ist = and t_simplif = tacticIn simplif and t_is_disj = tacticIn is_disj and t_tauto_intuit = tacticIn (tauto_intuit t_reduce solver) in - let t_solver = Tacexpr.TacArg (valueIn (VTactic (dummy_loc,solver))) in + let t_solver = globTacticIn (fun _ist -> solver) in <:tactic< ($t_simplif;$t_axioms || match reverse goal with @@ -165,16 +165,14 @@ let rec tauto_intuit t_reduce solver ist = $t_solver ) >> -let reduction_not_iff=interp +let reduction_not_iff _ist = <:tactic<repeat match goal with | |- _ => progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff | H:_ |- _ => progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in H end >> - -let t_reduction_not_iff = - Tacexpr.TacArg (valueIn (VTactic (dummy_loc,reduction_not_iff))) +let t_reduction_not_iff = tacticIn reduction_not_iff let intuition_gen tac = interp (tacticIn (tauto_intuit t_reduction_not_iff tac)) @@ -182,12 +180,12 @@ let intuition_gen tac = let simplif_gen = interp (tacticIn simplif) let tauto g = - try intuition_gen (interp <:tactic<fail>>) g + try intuition_gen <:tactic<fail>> g with Refiner.FailError _ | UserError _ -> errorlabstrm "tauto" (str "tauto failed.") -let default_intuition_tac = interp <:tactic< auto with * >> +let default_intuition_tac = <:tactic< auto with * >> TACTIC EXTEND tauto | [ "tauto" ] -> [ tauto ] @@ -195,5 +193,5 @@ END TACTIC EXTEND intuition | [ "intuition" ] -> [ intuition_gen default_intuition_tac ] -| [ "intuition" tactic(t) ] -> [ intuition_gen (snd t) ] +| [ "intuition" tactic(t) ] -> [ intuition_gen (fst t) ] END diff --git a/test-suite/failure/evarclear1.v b/test-suite/failure/evarclear1.v new file mode 100644 index 000000000..2e9fa0f35 --- /dev/null +++ b/test-suite/failure/evarclear1.v @@ -0,0 +1,10 @@ +Set Printing Existential Instances. +Set Printing All. +Goal forall y, let z := S y in exists x, x = 0. +intros. +eexists. +unfold z. +clear y z. +(* should fail because the evar should no longer be allowed to depend on z *) +instantiate (1:=z). + diff --git a/test-suite/failure/evarclear2.v b/test-suite/failure/evarclear2.v new file mode 100644 index 000000000..e606a06f1 --- /dev/null +++ b/test-suite/failure/evarclear2.v @@ -0,0 +1,9 @@ +Set Printing Existential Instances. +Set Printing All. +Goal let y:=0 in exists x:y=y, x = x. +intros. +eexists. +rename y into z. +unfold z at 1 2. +(* should fail because the evar type depends on z *) +clear z. diff --git a/test-suite/output/Fixpoint.out b/test-suite/output/Fixpoint.out index 09bc00886..c69d31f40 100644 --- a/test-suite/output/Fixpoint.out +++ b/test-suite/output/Fixpoint.out @@ -13,13 +13,13 @@ fix even_pos_odd_pos 2 with (odd_pos_even_pos (n:_) (H:odd n) {struct H} : n >= 1). intros. destruct H. - omega. + omega. - apply odd_pos_even_pos in H. - omega. + apply odd_pos_even_pos in H. + omega. intros. destruct H. - apply even_pos_odd_pos in H. - omega. + apply even_pos_odd_pos in H. + omega. diff --git a/test-suite/output/Tactics.out b/test-suite/output/Tactics.out index 287e84883..ac5eedc17 100644 --- a/test-suite/output/Tactics.out +++ b/test-suite/output/Tactics.out @@ -1,4 +1,4 @@ -intro H; split; [ a H | e H ]. +intro H; split; [ a H | e H ]. intros; match goal with | |- context [if ?X then _ else _] => case X diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 705fb3bdf..f0a17d7a4 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -115,7 +115,7 @@ lazymatch T with evar (a : t); pose proof (H a) as H1; unfold a in H1; clear a; clear H; rename H1 into H; find_equiv H | ?A <-> ?B => idtac -| _ => fail "The given statement does not seem to end with an equivalence" +| _ => fail "The given statement does not seem to end with an equivalence." end. Ltac bapply lemma todo := @@ -141,7 +141,7 @@ t; match goal with | H : _ |- _ => solve [inversion H] | _ => solve [trivial | reflexivity | symmetry; trivial | discriminate | split] -| _ => fail 1 "Cannot solve this goal" +| _ => fail 1 "Cannot solve this goal." end. (** A tactic to document or check what is proved at some point of a script *) diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 9192db722..b3d76b89b 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -55,6 +55,8 @@ let subst_in_constr (_,subst,(ind,const)) = exception EqNotFound of string exception EqUnknown of string +let dl = dummy_loc + (* Some pre declaration of constant we are going to use *) let bb = constr_of_global Coqlib.glob_bool @@ -514,13 +516,13 @@ let compute_bl_tact ind lnamesparrec nparrec = new_induct false [ (Tacexpr.ElimOnConstr ((mkVar freshn), Rawterm.NoBindings))] None - Genarg.IntroAnonymous + (None,None) None; intro_using freshm; new_destruct false [ (Tacexpr.ElimOnConstr ((mkVar freshm), Rawterm.NoBindings))] None - Genarg.IntroAnonymous + (None,None) None; intro_using freshz; intros; @@ -542,9 +544,9 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). (new_destruct false [Tacexpr.ElimOnConstr ((mkVar freshz,Rawterm.NoBindings))] None - ( Genarg.IntroOrAndPattern [[ - Genarg.IntroIdentifier fresht; - Genarg.IntroIdentifier freshz]]) None) gl + (None, Some (dl,Genarg.IntroOrAndPattern [[ + dl,Genarg.IntroIdentifier fresht; + dl,Genarg.IntroIdentifier freshz]])) None) gl ]); (* Ci a1 ... an = Ci b1 ... bn @@ -632,13 +634,13 @@ let compute_lb_tact ind lnamesparrec nparrec = new_induct false [Tacexpr.ElimOnConstr ((mkVar freshn),Rawterm.NoBindings)] None - Genarg.IntroAnonymous + (None,None) None; intro_using freshm; new_destruct false [Tacexpr.ElimOnConstr ((mkVar freshm),Rawterm.NoBindings)] None - Genarg.IntroAnonymous + (None,None) None; intro_using freshz; intros; @@ -746,7 +748,7 @@ let compute_dec_tact ind lnamesparrec nparrec = Pfedit.by ( tclTHENSEQ [ intros_using fresh_first_intros; intros_using [freshn;freshm]; - assert_as true (Genarg.IntroIdentifier freshH) ( + assert_as true (dl,Genarg.IntroIdentifier freshH) ( mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) ) ]); (*we do this so we don't have to prove the same goal twice *) @@ -754,7 +756,7 @@ let compute_dec_tact ind lnamesparrec nparrec = (new_destruct false [Tacexpr.ElimOnConstr (eqbnm,Rawterm.NoBindings)] None - Genarg.IntroAnonymous + (None,None) None) Auto.default_auto ); @@ -764,9 +766,9 @@ let compute_dec_tact ind lnamesparrec nparrec = new_destruct false [Tacexpr.ElimOnConstr ((mkVar freshH),Rawterm.NoBindings)] None - (Genarg.IntroOrAndPattern [ - [Genarg.IntroAnonymous]; - [Genarg.IntroIdentifier freshH2]]) None + (None,Some (dl,Genarg.IntroOrAndPattern [ + [dl,Genarg.IntroAnonymous]; + [dl,Genarg.IntroIdentifier freshH2]])) None ); let arfresh = Array.of_list fresh_first_intros in let xargs = Array.sub arfresh 0 (2*nparrec) in @@ -793,7 +795,7 @@ let compute_dec_tact ind lnamesparrec nparrec = unfold_constr (Lazy.force Coqlib.coq_not_ref); intro; Equality.subst_all; - assert_as true (Genarg.IntroIdentifier freshH3) + assert_as true (dl,Genarg.IntroIdentifier freshH3) (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|])) ]); Pfedit.by diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index b11592ba4..488c39834 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -40,15 +40,15 @@ let rec explain_exn_default_aux anomaly_string report_fn = function | Sys_error msg -> hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report_fn ()) | UserError(s,pps) -> - hov 1 (str "User error: " ++ where s ++ pps) + hov 0 (str "Error: " ++ where s ++ pps) | Out_of_memory -> hov 0 (str "Out of memory.") | Stack_overflow -> hov 0 (str "Stack overflow.") | Anomaly (s,pps) -> - hov 1 (anomaly_string () ++ where s ++ pps ++ report_fn ()) + hov 0 (anomaly_string () ++ where s ++ pps ++ report_fn ()) | Match_failure(filename,pos1,pos2) -> - hov 1 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ + hov 0 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ if Sys.ocaml_version = "3.06" then (str " from character " ++ int pos1 ++ str " to " ++ int pos2) @@ -83,6 +83,11 @@ let rec explain_exn_default_aux anomaly_string report_fn = function hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error e) | RecursionSchemeError e -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_recursion_scheme_error e) + | Proof_type.LtacLocated (_,(Refiner.FailError (i,s) as exc)) when s <> mt () -> + explain_exn_default_aux anomaly_string report_fn exc + | Proof_type.LtacLocated (s,exc) -> + hov 0 (Himsg.explain_ltac_call_trace s ++ fnl () + ++ explain_exn_default_aux anomaly_string report_fn exc) | Cases.PatternMatchingError (env,e) -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_pattern_matching_error env e) @@ -100,7 +105,7 @@ let rec explain_exn_default_aux anomaly_string report_fn = function str "No constant of this name:" ++ spc () ++ Libnames.pr_qualid q ++ str ".") | Refiner.FailError (i,s) -> - hov 0 (str "Error: Tactic failure" ++ s ++ + hov 0 (str "Error: Tactic failure:" ++ s ++ if i=0 then mt () else str " (level " ++ int i ++ str").") | Stdpp.Exc_located (loc,exc) -> hov 0 ((if loc = dummy_loc then (mt ()) diff --git a/toplevel/fhimsg.ml b/toplevel/fhimsg.ml deleted file mode 100644 index 91e77f495..000000000 --- a/toplevel/fhimsg.ml +++ /dev/null @@ -1,355 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id$ *) - -open Pp -open Util -open Names -open Term -open Sign -open Environ -open Type_errors -open Reduction -open G_minicoq - -module type Printer = sig - val pr_term : path_kind -> env -> constr -> std_ppcmds -end - -module Make = functor (P : Printer) -> struct - - let print_decl k env (s,typ) = - let ptyp = P.pr_term k env typ in - (spc () ++ pr_id s ++ str" : " ++ ptyp) - - let print_binding k env = function - | Anonymous,ty -> - (spc () ++ str"_" ++ str" : " ++ P.pr_term k env ty) - | Name id,ty -> - (spc () ++ pr_id id ++ str" : " ++ P.pr_term k env ty) - -(**** - let sign_it_with f sign e = - snd (fold_named_context - (fun (id,v,t) (sign,e) -> (add_named_decl (id,v,t) sign, f id t sign e)) - sign (empty_named_context,e)) - - let dbenv_it_with f env e = - snd (dbenv_it - (fun na t (env,e) -> (add_rel_decl (na,t) env, f na t env e)) - env (gLOB(get_globals env),e)) -****) - - let pr_env k env = - let sign_env = - fold_named_context - (fun env (id,_,t) pps -> - let pidt = print_decl k env (id,t) in (pps ++ fnl () ++ pidt)) - env (mt ()) - in - let db_env = - fold_rel_context - (fun env (na,_,t) pps -> - let pnat = print_binding k env (na,t) in (pps ++ fnl () ++ pnat)) - env (mt ()) - in - (sign_env ++ db_env) - - let pr_ne_ctx header k env = - if rel_context env = [] && named_context env = [] then - (mt ()) - else - (header ++ pr_env k env) - - -let explain_unbound_rel k ctx n = - let pe = pr_ne_ctx (str"in environment") k ctx in - (str"Unbound reference: " ++ pe ++ fnl () ++ - str"The reference " ++ int n ++ str" is free") - -let explain_not_type k ctx c = - let pe = pr_ne_ctx (str"In environment") k ctx in - let pc = P.pr_term k ctx c in - (pe ++ cut () ++ str "the term" ++ brk(1,1) ++ pc ++ spc () ++ - str"should be typed by Set, Prop or Type.");; - -let explain_bad_assumption k ctx c = - let pc = P.pr_term k ctx c in - (str "Cannot declare a variable or hypothesis over the term" ++ - brk(1,1) ++ pc ++ spc () ++ str "because this term is not a type.");; - -let explain_reference_variables id = - (str "the constant" ++ spc () ++ pr_id id ++ spc () ++ - str "refers to variables which are not in the context") - -let msg_bad_elimination ctx k = function - | Some(ki,kp,explanation) -> - let pki = P.pr_term k ctx ki in - let pkp = P.pr_term k ctx kp in - (hov 0 - (fnl () ++ str "Elimination of an inductive object of sort : " ++ - pki ++ brk(1,0) ++ - str "is not allowed on a predicate in sort : " ++ pkp ++fnl () ++ - str "because" ++ spc () ++ str explanation)) - | None -> - (mt ()) - -let explain_elim_arity k ctx ind aritylst c pj okinds = - let pi = P.pr_term k ctx ind in - let ppar = prlist_with_sep pr_coma (P.pr_term k ctx) aritylst in - let pc = P.pr_term k ctx c in - let pp = P.pr_term k ctx pj.uj_val in - let ppt = P.pr_term k ctx pj.uj_type in - (str "Incorrect elimination of" ++ brk(1,1) ++ pc ++ spc () ++ - str "in the inductive type" ++ brk(1,1) ++ pi ++ fnl () ++ - str "The elimination predicate" ++ brk(1,1) ++ pp ++ spc () ++ - str "has type" ++ brk(1,1) ++ ppt ++ fnl () ++ - str "It should be one of :" ++ brk(1,1) ++ hov 0 ppar ++ fnl () ++ - msg_bad_elimination ctx k okinds) - -let explain_case_not_inductive k ctx cj = - let pc = P.pr_term k ctx cj.uj_val in - let pct = P.pr_term k ctx cj.uj_type in - (str "In Cases expression" ++ brk(1,1) ++ pc ++ spc () ++ - str "has type" ++ brk(1,1) ++ pct ++ spc () ++ - str "which is not an inductive definition") - -let explain_number_branches k ctx cj expn = - let pc = P.pr_term k ctx cj.uj_val in - let pct = P.pr_term k ctx cj.uj_val in - (str "Cases on term" ++ brk(1,1) ++ pc ++ spc () ++ - str "of type" ++ brk(1,1) ++ pct ++ spc () ++ - str "expects " ++ int expn ++ str " branches") - -let explain_ill_formed_branch k ctx c i actty expty = - let pc = P.pr_term k ctx c in - let pa = P.pr_term k ctx actty in - let pe = P.pr_term k ctx expty in - (str "In Cases expression on term" ++ brk(1,1) ++ pc ++ - spc () ++ str "the branch " ++ int (i+1) ++ - str " has type" ++ brk(1,1) ++ pa ++ spc () ++ - str "which should be:" ++ brk(1,1) ++ pe) - -let explain_generalization k ctx (name,var) c = - let pe = pr_ne_ctx (str"in environment") k ctx in - let pv = P.pr_term k ctx var in - let pc = P.pr_term k (push_rel (name,None,var) ctx) c in - (str"Illegal generalization: " ++ pe ++ fnl () ++ - str"Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++ - str"over" ++ brk(1,1) ++ pc ++ spc () ++ - str"which should be typed by Set, Prop or Type.") - -let explain_actual_type k ctx c ct pt = - let pe = pr_ne_ctx (str"In environment") k ctx in - let pc = P.pr_term k ctx c in - let pct = P.pr_term k ctx ct in - let pt = P.pr_term k ctx pt in - (pe ++ fnl () ++ - str"The term" ++ brk(1,1) ++ pc ++ spc () ++ - str"does not have type" ++ brk(1,1) ++ pt ++ fnl () ++ - str"Actually, it has type" ++ brk(1,1) ++ pct) - -let explain_cant_apply_bad_type k ctx (n,exptyp,actualtyp) rator randl = - let ctx = make_all_name_different ctx in - let pe = pr_ne_ctx (str"in environment") k ctx in - let pr = pr_term k ctx rator.uj_val in - let prt = pr_term k ctx rator.uj_type in - let term_string = if List.length randl > 1 then "terms" else "term" in - let many = match n mod 10 with 1 -> "st" | 2 -> "nd" | _ -> "th" in - let appl = prlist_with_sep pr_fnl - (fun c -> - let pc = pr_term k ctx c.uj_val in - let pct = pr_term k ctx c.uj_type in - hov 2 (pc ++ spc () ++ str": " ++ pct)) randl - in - (str"Illegal application (Type Error): " ++ pe ++ fnl () ++ - str"The term" ++ brk(1,1) ++ pr ++ spc () ++ - str"of type" ++ brk(1,1) ++ prt ++ spc () ++ - str("cannot be applied to the "^term_string) ++ fnl () ++ - str" " ++ v 0 appl ++ fnl () ++ - str"The " ++int n ++ str (many^" term of type ") ++ - pr_term k ctx actualtyp ++ - str" should be of type " ++ pr_term k ctx exptyp) - -let explain_cant_apply_not_functional k ctx rator randl = - let ctx = make_all_name_different ctx in - let pe = pr_ne_ctx (str"in environment") k ctx in - let pr = pr_term k ctx rator.uj_val in - let prt = pr_term k ctx rator.uj_type in - let term_string = if List.length randl > 1 then "terms" else "term" in - let appl = prlist_with_sep pr_fnl - (fun c -> - let pc = pr_term k ctx c.uj_val in - let pct = pr_term k ctx c.uj_type in - hov 2 (pc ++ spc () ++ str": " ++ pct)) randl - in - (str"Illegal application (Non-functional construction): " ++ pe ++ fnl () ++ - str"The term" ++ brk(1,1) ++ pr ++ spc () ++ - str"of type" ++ brk(1,1) ++ prt ++ spc () ++ - str("cannot be applied to the "^term_string) ++ fnl () ++ - str" " ++ v 0 appl ++ fnl ()) - -(* (co)fixpoints *) -let explain_ill_formed_rec_body k ctx err names i vdefs = - let str = match err with - - (* Fixpoint guard errors *) - | NotEnoughAbstractionInFixBody -> - (str "Not enough abstractions in the definition") - | RecursionNotOnInductiveType -> - (str "Recursive definition on a non inductive type") - | RecursionOnIllegalTerm -> - (str "Recursive call applied to an illegal term") - | NotEnoughArgumentsForFixCall -> - (str "Not enough arguments for the recursive call") - - (* CoFixpoint guard errors *) - (* TODO : récupérer le contexte des termes pour pouvoir les afficher *) - | CodomainNotInductiveType c -> - (str "The codomain is" ++ spc () ++ P.pr_term k ctx c ++ spc () ++ - str "which should be a coinductive type") - | NestedRecursiveOccurrences -> - (str "Nested recursive occurrences") - | UnguardedRecursiveCall c -> - (str "Unguarded recursive call") - | RecCallInTypeOfAbstraction c -> - (str "Not allowed recursive call in the domain of an abstraction") - | RecCallInNonRecArgOfConstructor c -> - (str "Not allowed recursive call in a non-recursive argument of constructor") - | RecCallInTypeOfDef c -> - (str "Not allowed recursive call in the type of a recursive definition") - | RecCallInCaseFun c -> - (str "Not allowed recursive call in a branch of cases") - | RecCallInCaseArg c -> - (str "Not allowed recursive call in the argument of cases") - | RecCallInCasePred c -> - (str "Not allowed recursive call in the type of cases in") - | NotGuardedForm c -> - str "Sub-expression " ++ pr_lconstr_env ctx c ++ spc() ++ - str "not in guarded form (should be a constructor, Cases or CoFix)" -in - let pvd = P.pr_term k ctx vdefs.(i) in - let s = - match names.(i) with Name id -> string_of_id id | Anonymous -> "_" in - (str ++ fnl () ++ str"The " ++ - if Array.length vdefs = 1 then (mt ()) else (int (i+1) ++ str "-th ") ++ - str"recursive definition" ++ spc () ++ str s ++ - spc () ++ str":=" ++ spc () ++ pvd ++ spc () ++ - str "is not well-formed") - -let explain_ill_typed_rec_body k ctx i lna vdefj vargs = - let pvd = P.pr_term k ctx (vdefj.(i)).uj_val in - let pvdt = P.pr_term k ctx (vdefj.(i)).uj_type in - let pv = P.pr_term k ctx vargs.(i) in - (str"The " ++ - if Array.length vdefj = 1 then (mt ()) else (int (i+1) ++ str "-th") ++ - str"recursive definition" ++ spc () ++ pvd ++ spc () ++ - str "has type" ++ spc () ++ pvdt ++spc () ++ str "it should be" ++ spc () ++ pv) - -let explain_not_inductive k ctx c = - let pc = P.pr_term k ctx c in - (str"The term" ++ brk(1,1) ++ pc ++ spc () ++ - str "is not an inductive definition") - -let explain_ml_case k ctx mes c ct br brt = - let pc = P.pr_term k ctx c in - let pct = P.pr_term k ctx ct in - let expln = - match mes with - | "Inductive" -> (pct ++ str "is not an inductive definition") - | "Predicate" -> (str "ML case not allowed on a predicate") - | "Absurd" -> (str "Ill-formed case expression on an empty type") - | "Decomp" -> - let plf = P.pr_term k ctx br in - let pft = P.pr_term k ctx brt in - (str "The branch " ++ plf ++ ws 1 ++ cut () ++ str "has type " ++ pft ++ - ws 1 ++ cut () ++ - str "does not correspond to the inductive definition") - | "Dependent" -> - (str "ML case not allowed for a dependent case elimination") - | _ -> (mt ()) - in - hov 0 (str "In ML case expression on " ++ pc ++ ws 1 ++ cut () ++ - str "of type" ++ ws 1 ++ pct ++ ws 1 ++ cut () ++ - str "which is an inductive predicate." ++ fnl () ++ expln) - -let explain_type_error k ctx = function - | UnboundRel n -> - explain_unbound_rel k ctx n - | NotAType c -> - explain_not_type k ctx c.uj_val - | BadAssumption c -> - explain_bad_assumption k ctx c - | ReferenceVariables id -> - explain_reference_variables id - | ElimArity (ind, aritylst, c, pj, okinds) -> - explain_elim_arity k ctx (mkMutInd ind) aritylst c pj okinds - | CaseNotInductive cj -> - explain_case_not_inductive k ctx cj - | NumberBranches (cj, n) -> - explain_number_branches k ctx cj n - | IllFormedBranch (c, i, actty, expty) -> - explain_ill_formed_branch k ctx c i actty expty - | Generalization (nvar, c) -> - explain_generalization k ctx nvar c.uj_val - | ActualType (c, ct, pt) -> - explain_actual_type k ctx c ct pt - | CantApplyBadType (s, rator, randl) -> - explain_cant_apply_bad_type k ctx s rator randl - | CantApplyNonFunctional (rator, randl) -> - explain_cant_apply_not_functional k ctx rator randl - | IllFormedRecBody (i, lna, vdefj, vargs) -> - explain_ill_formed_rec_body k ctx i lna vdefj vargs - | IllTypedRecBody (i, lna, vdefj, vargs) -> - explain_ill_typed_rec_body k ctx i lna vdefj vargs -(* - | NotInductive c -> - explain_not_inductive k ctx c - | MLCase (mes,c,ct,br,brt) -> - explain_ml_case k ctx mes c ct br brt -*) - | _ -> - (str "Unknown type error (TODO)") - -let explain_refiner_bad_type k ctx arg ty conclty = - errorlabstrm "Logic.conv_leq_goal" - (str"refiner was given an argument" ++ brk(1,1) ++ - P.pr_term k ctx arg ++ spc () ++ - str"of type" ++ brk(1,1) ++ P.pr_term k ctx ty ++ spc () ++ - str"instead of" ++ brk(1,1) ++ P.pr_term k ctx conclty) - -let explain_refiner_occur_meta k ctx t = - errorlabstrm "Logic.mk_refgoals" - (str"cannot refine with term" ++ brk(1,1) ++ P.pr_term k ctx t ++ - spc () ++ str"because there are metavariables, and it is" ++ - spc () ++ str"neither an application nor a Case") - -let explain_refiner_cannot_applt k ctx t harg = - errorlabstrm "Logic.mkARGGOALS" - (str"in refiner, a term of type " ++ brk(1,1) ++ - P.pr_term k ctx t ++ spc () ++ str"could not be applied to" ++ brk(1,1) ++ - P.pr_term k ctx harg) - -let explain_occur_check k ctx ev rhs = - let id = "?" ^ string_of_int ev in - let pt = P.pr_term k ctx rhs in - errorlabstrm "Trad.occur_check" - (str"Occur check failed: tried to define " ++ str id ++ - str" with term" ++ brk(1,1) ++ pt) - -let explain_not_clean k ctx sp t = - let c = mkRel (Intset.choose (free_rels t)) in - let id = string_of_id (Names.basename sp) in - let var = P.pr_term k ctx c in - errorlabstrm "Trad.not_clean" - (str"Tried to define " ++ str id ++ - str" with a term using variable " ++ var ++ spc () ++ - str"which is not in its scope.") - -end diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 10f8e39c3..422555d04 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -424,12 +424,9 @@ let explain_cannot_unify_binding_type env m n = str "which should be unifiable with" ++ brk(1,1) ++ pn ++ str "." let explain_cannot_find_well_typed_abstraction env p l = - let la,lc = list_chop (List.length l - 1) l in str "Abstracting over the " ++ str (plural (List.length l) "term") ++ spc () ++ - hov 0 (prlist_with_sep pr_coma (pr_lconstr_env env) la ++ - (if la<>[] then str " and" ++ spc () else mt()) ++ - pr_lconstr_env env (List.hd lc)) ++ spc () ++ + hov 0 (pr_enum (pr_lconstr_env env) l) ++ spc () ++ str "leads to a term" ++ spc () ++ pr_lconstr_env env p ++ spc () ++ str "which is ill-typed." @@ -561,7 +558,7 @@ let explain_refiner_unresolved_bindings l = prlist_with_sep pr_coma pr_name l ++ str"." let explain_refiner_cannot_apply t harg = - str "In refiner, a term of type " ++ brk(1,1) ++ + str "In refiner, a term of type" ++ brk(1,1) ++ pr_lconstr t ++ spc () ++ str "could not be applied to" ++ brk(1,1) ++ pr_lconstr harg ++ str "." @@ -784,3 +781,40 @@ let explain_reduction_tactic_error = function str "The abstracted term" ++ spc () ++ pr_lconstr_env_at_top env c ++ spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' e + +let explain_ltac_call_trace (last,trace,loc) = + let calls = last :: List.rev (List.map snd trace) in + let pr_call = function + | Proof_type.LtacNotationCall s -> quote (str s) + | Proof_type.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) + | Proof_type.LtacVarCall (id,t) -> + quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ + Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" + | Proof_type.LtacAtomCall (te,otac) -> quote + (Pptactic.pr_glob_tactic (Global.env()) + (Tacexpr.TacAtom (dummy_loc,te))) + ++ (match !otac with + | Some te' when (Obj.magic te' <> te) -> + strbrk " (expanded to " ++ quote + (Pptactic.pr_tactic (Global.env()) + (Tacexpr.TacAtom (dummy_loc,te'))) + ++ str ")" + | _ -> mt ()) + | Proof_type.LtacConstrInterp (c,(vars,unboundvars)) -> + let filter = + function (id,None) -> None | (id,Some id') -> Some(id,mkVar id') in + let unboundvars = list_map_filter filter unboundvars in + quote (pr_rawconstr_env (Global.env()) c) ++ + (if unboundvars <> [] or vars <> [] then + strbrk " (with " ++ prlist_with_sep pr_coma (fun (id,c) -> + pr_id id ++ str ":=" ++ Printer.pr_lconstr c) + (List.rev vars @ unboundvars) + else mt()) ++ str ")" in + if calls <> [] then + let kind_of_last_call = match list_last calls with + | Proof_type.LtacConstrInterp _ -> ", last term evaluation failed." + | _ -> ", last call failed." in + hov 0 (str "In nested Ltac calls to " ++ + pr_enum pr_call calls ++ strbrk kind_of_last_call) + else + mt () diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli index d7a72bede..053bf16a3 100644 --- a/toplevel/himsg.mli +++ b/toplevel/himsg.mli @@ -40,3 +40,6 @@ val explain_pattern_matching_error : val explain_reduction_tactic_error : Tacred.reduction_tactic_error -> std_ppcmds + +val explain_ltac_call_trace : + Proof_type.ltac_call_kind * Proof_type.ltac_trace * Util.loc -> std_ppcmds diff --git a/toplevel/minicoq.ml b/toplevel/minicoq.ml deleted file mode 100644 index e22b33e24..000000000 --- a/toplevel/minicoq.ml +++ /dev/null @@ -1,149 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id$ *) - -open Pp -open Util -open Names -open Term -open Sign -open Declarations -open Inductive -open Type_errors -open Safe_typing -open G_minicoq - -let (env : safe_environment ref) = ref empty_environment - -let locals () = - List.map (fun (id,b,t) -> (id, make_path [] id CCI)) - (named_context !env) - -let lookup_named id = - let rec look n = function - | [] -> mkVar id - | (Name id')::_ when id = id' -> mkRel n - | _::r -> look (succ n) r - in - look 1 - -let args sign = Array.of_list (instance_from_section_context sign) - -let rec globalize bv c = match kind_of_term c with - | Var id -> lookup_named id bv - | Const (sp, _) -> - let cb = lookup_constant sp !env in mkConst (sp, args cb.const_hyps) - | Ind (sp,_ as spi, _) -> - let mib = lookup_mind sp !env in mkMutInd (spi, args mib.mind_hyps) - | Construct ((sp,_),_ as spc, _) -> - let mib = lookup_mind sp !env in mkMutConstruct (spc, args mib.mind_hyps) - | _ -> map_constr_with_named_binders (fun na l -> na::l) globalize bv c - -let check c = - let c = globalize [] c in - let (j,u) = safe_infer !env c in - let ty = j_type j in - let pty = pr_term CCI (env_of_safe_env !env) ty in - mSGNL (hov 0 (str" :" ++ spc () ++ hov 0 pty ++ fnl ())) - -let definition id ty c = - let c = globalize [] c in - let ty = Option.map (globalize []) ty in - let ce = { const_entry_body = c; const_entry_type = ty } in - let sp = make_path [] id CCI in - env := add_constant sp ce (locals()) !env; - mSGNL (hov 0 (pr_id id ++ spc () ++ str"is defined" ++ fnl ())) - -let parameter id t = - let t = globalize [] t in - let sp = make_path [] id CCI in - env := add_parameter sp t (locals()) !env; - mSGNL (hov 0 (str"parameter" ++ spc () ++ pr_id id ++ - spc () ++ str"is declared" ++ fnl ())) - -let variable id t = - let t = globalize [] t in - env := push_named_assum (id,t) !env; - mSGNL (hov 0 (str"variable" ++ spc () ++ pr_id id ++ - spc () ++ str"is declared" ++ fnl ())) - -let inductive par inds = - let nparams = List.length par in - let bvpar = List.rev (List.map (fun (id,_) -> Name id) par) in - let name_inds = List.map (fun (id,_,_) -> Name id) inds in - let bv = bvpar @ List.rev name_inds in - let npar = List.map (fun (id,c) -> (Name id, globalize [] c)) par in - let one_inductive (id,ar,cl) = - let cv = List.map (fun (_,c) -> prod_it (globalize bv c) npar) cl in - { mind_entry_nparams = nparams; - mind_entry_params = List.map (fun (id,c) -> (id, LocalAssum c)) par; - mind_entry_typename = id; - mind_entry_arity = prod_it (globalize bvpar ar) npar; - mind_entry_consnames = List.map fst cl; - mind_entry_lc = cv } - in - let inds = List.map one_inductive inds in - let mie = { - mind_entry_finite = true; - mind_entry_inds = inds } - in - let sp = - let mi1 = List.hd inds in - make_path [] mi1.mind_entry_typename CCI in - env := add_mind sp mie (locals()) !env; - mSGNL (hov 0 (str"inductive type(s) are declared" ++ fnl ())) - - -let execute = function - | Check c -> check c - | Definition (id, ty, c) -> definition id ty c - | Parameter (id, t) -> parameter id t - | Variable (id, t) -> variable id t - | Inductive (par,inds) -> inductive par inds - -let parse_file f = - let c = open_in f in - let cs = Stream.of_channel c in - try - while true do - let c = Grammar.Entry.parse command cs in execute c - done - with - | End_of_file | Stdpp.Exc_located (_, End_of_file) -> close_in c; exit 0 - | exn -> close_in c; raise exn - -module Explain = Fhimsg.Make(struct let pr_term = pr_term end) - -let rec explain_exn = function - | TypeError (k,ctx,te) -> - mSGNL (hov 0 (str "type error:" ++ spc () ++ - Explain.explain_type_error k ctx te ++ fnl ())) - | Stdpp.Exc_located (_,exn) -> - explain_exn exn - | exn -> - mSGNL (hov 0 (str"error: " ++ str (Printexc.to_string exn) ++ fnl ())) - -let top () = - let cs = Stream.of_channel stdin in - while true do - try - let c = Grammar.Entry.parse command cs in execute c - with - | End_of_file | Stdpp.Exc_located (_, End_of_file) -> exit 0 - | exn -> explain_exn exn - done - -let main () = - if Array.length Sys.argv = 1 then - parse_file "test" - else - if Sys.argv.(1) = "-top" then top () else parse_file (Sys.argv.(1)) - -let _ = Printexc.print main () - diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index ae9162860..399c18c92 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1256,7 +1256,7 @@ let vernac_check_guard () = pfterm; (str "The condition holds up to here") with UserError(_,s) -> - (str ("Condition violated : ") ++s) + (str ("Condition violated: ") ++s) in msgnl message |