diff options
Diffstat (limited to 'plugins/ltac')
41 files changed, 2399 insertions, 1989 deletions
diff --git a/plugins/ltac/coretactics.mlg b/plugins/ltac/coretactics.mlg index 6388906f5e..d9338f0421 100644 --- a/plugins/ltac/coretactics.mlg +++ b/plugins/ltac/coretactics.mlg @@ -333,7 +333,7 @@ open Tacexpr let initial_atomic () = let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in let iter (s, t) = - let body = TacAtom (Loc.tag t) in + let body = TacAtom (CAst.make t) in Tacenv.register_ltac false false (Names.Id.of_string s) body in let () = List.iter iter @@ -348,7 +348,7 @@ let initial_atomic () = List.iter iter [ "idtac",TacId []; "fail", TacFail(TacLocal,ArgArg 0,[]); - "fresh", TacArg(Loc.tag @@ TacFreshId []) + "fresh", TacArg(CAst.make @@ TacFreshId []) ] let () = Mltop.declare_cache_obj initial_atomic "ltac_plugin" @@ -379,8 +379,8 @@ let initial_tacticals () = let varn n = Reference (ArgVar (CAst.make (idn n))) in let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in List.iter iter [ - "first", TacFun ([Name (idn 0)], TacML (None, (initial_entry "first", [varn 0]))); - "solve", TacFun ([Name (idn 0)], TacML (None, (initial_entry "solve", [varn 0]))); + "first", TacFun ([Name (idn 0)], TacML (CAst.make (initial_entry "first", [varn 0]))); + "solve", TacFun ([Name (idn 0)], TacML (CAst.make (initial_entry "solve", [varn 0]))); ] let () = Mltop.declare_cache_obj initial_tacticals "ltac_plugin" diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index b0277e9cc2..050fdcb608 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -11,6 +11,7 @@ open Util open Names open Constr +open Context open CErrors open Evar_refiner open Tacmach @@ -62,7 +63,7 @@ let instantiate_tac n c ido = evar_list sigma (EConstr.of_constr (NamedDecl.get_type decl)) | InHypValueOnly -> (match decl with - | LocalDef (_,body,_) -> evar_list sigma (EConstr.of_constr body) + | LocalDef (_,body,_) -> evar_list sigma (EConstr.of_constr body) | _ -> user_err Pp.(str "Not a defined hypothesis.")) in if List.length evl < n then user_err Pp.(str "Not enough uninstantiated existential variables."); @@ -108,5 +109,6 @@ let hget_evar n = if n <= 0 then user_err Pp.(str "Incorrect existential variable index."); let ev = List.nth evl (n-1) in let ev_type = EConstr.existential_type sigma ev in - Tactics.change_concl (mkLetIn (Name.Anonymous,mkEvar ev,ev_type,concl)) + let r = Retyping.relevance_of_type (Proofview.Goal.env gl) sigma ev_type in + Tactics.change_concl (mkLetIn (make_annot Name.Anonymous r,mkEvar ev,ev_type,concl)) end diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.mlg index f4555509cc..eb9cacb975 100644 --- a/plugins/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.mlg @@ -8,8 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Pp -open Genarg open Stdarg open Tacarg open Pcoq.Prim @@ -62,22 +63,29 @@ let pr_orient _prc _prlc _prt = function | true -> Pp.mt () | false -> Pp.str " <-" -ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient -| [ "->" ] -> [ true ] -| [ "<-" ] -> [ false ] -| [ ] -> [ true ] +} + +ARGUMENT EXTEND orient TYPED AS bool PRINTED BY { pr_orient } +| [ "->" ] -> { true } +| [ "<-" ] -> { false } +| [ ] -> { true } END +{ + let pr_int _ _ _ i = Pp.int i let _natural = Pcoq.Prim.natural -ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int -| [ _natural(i) ] -> [ i ] +} + +ARGUMENT EXTEND natural TYPED AS int PRINTED BY { pr_int } +| [ _natural(i) ] -> { i } END -let pr_orient = pr_orient () () () +{ +let pr_orient = pr_orient () () () let pr_int_list = Pp.pr_sequence Pp.int let pr_int_list_full _prc _prlc _prt l = pr_int_list l @@ -116,80 +124,95 @@ let glob_occs ist l = l let subst_occs evm l = l +} + ARGUMENT EXTEND occurrences TYPED AS int list - PRINTED BY pr_int_list_full + PRINTED BY { pr_int_list_full } - INTERPRETED BY interp_occs - GLOBALIZED BY glob_occs - SUBSTITUTED BY subst_occs + INTERPRETED BY { interp_occs } + GLOBALIZED BY { glob_occs } + SUBSTITUTED BY { subst_occs } - RAW_PRINTED BY pr_occurrences - GLOB_PRINTED BY pr_occurrences + RAW_PRINTED BY { pr_occurrences } + GLOB_PRINTED BY { pr_occurrences } -| [ ne_integer_list(l) ] -> [ ArgArg l ] -| [ var(id) ] -> [ ArgVar id ] +| [ ne_integer_list(l) ] -> { ArgArg l } +| [ var(id) ] -> { ArgVar id } END +{ + let pr_occurrences = pr_occurrences () () () -let pr_gen prc _prlc _prtac c = prc c +let pr_gen env sigma prc _prlc _prtac x = prc env sigma x -let pr_globc _prc _prlc _prtac (_,glob) = - let _, env = Pfedit.get_current_context () in +let pr_globc env sigma _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr_env env glob let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) let glob_glob = Tacintern.intern_constr -let pr_lconstr _ prc _ c = prc c +let pr_lconstr env sigma _ prc _ c = prc env sigma c let subst_glob = Tacsubst.subst_glob_constr_and_expr +} + ARGUMENT EXTEND glob - PRINTED BY pr_globc + PRINTED BY { pr_globc env sigma } - INTERPRETED BY interp_glob - GLOBALIZED BY glob_glob - SUBSTITUTED BY subst_glob + INTERPRETED BY { interp_glob } + GLOBALIZED BY { glob_glob } + SUBSTITUTED BY { subst_glob } - RAW_PRINTED BY pr_gen - GLOB_PRINTED BY pr_gen - [ constr(c) ] -> [ c ] + RAW_PRINTED BY { pr_gen env sigma } + GLOB_PRINTED BY { pr_gen env sigma } +| [ constr(c) ] -> { c } END +{ + let l_constr = Pcoq.Constr.lconstr +} + ARGUMENT EXTEND lconstr TYPED AS constr - PRINTED BY pr_lconstr - [ l_constr(c) ] -> [ c ] + PRINTED BY { pr_lconstr env sigma } +| [ l_constr(c) ] -> { c } END ARGUMENT EXTEND lglob TYPED AS glob - PRINTED BY pr_globc + PRINTED BY { pr_globc env sigma } - INTERPRETED BY interp_glob - GLOBALIZED BY glob_glob - SUBSTITUTED BY subst_glob + INTERPRETED BY { interp_glob } + GLOBALIZED BY { glob_glob } + SUBSTITUTED BY { subst_glob } - RAW_PRINTED BY pr_gen - GLOB_PRINTED BY pr_gen - [ lconstr(c) ] -> [ c ] + RAW_PRINTED BY { pr_gen env sigma } + GLOB_PRINTED BY { pr_gen env sigma } +| [ lconstr(c) ] -> { c } END +{ + let interp_casted_constr ist gl c = interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c +} + ARGUMENT EXTEND casted_constr TYPED AS constr - PRINTED BY pr_gen - INTERPRETED BY interp_casted_constr - [ constr(c) ] -> [ c ] + PRINTED BY { pr_gen env sigma } + INTERPRETED BY { interp_casted_constr } +| [ constr(c) ] -> { c } END +{ + type 'id gen_place= ('id * hyp_location_flag,unit) location type loc_place = lident gen_place @@ -228,73 +251,87 @@ let warn_deprecated_instantiate_syntax = ("Syntax \"in (" ^ v ^ " of " ^ s ^ ")\" is deprecated; use \"in (" ^ v' ^ " of " ^ s ^ ")\".") ) +} + ARGUMENT EXTEND hloc - PRINTED BY pr_place - INTERPRETED BY interp_place - GLOBALIZED BY intern_place - SUBSTITUTED BY subst_place - RAW_PRINTED BY pr_loc_place - GLOB_PRINTED BY pr_loc_place - [ ] -> - [ ConclLocation () ] + PRINTED BY { pr_place } + INTERPRETED BY { interp_place } + GLOBALIZED BY { intern_place } + SUBSTITUTED BY { subst_place } + RAW_PRINTED BY { pr_loc_place } + GLOB_PRINTED BY { pr_loc_place } +| [ ] -> + { ConclLocation () } | [ "in" "|-" "*" ] -> - [ ConclLocation () ] + { ConclLocation () } | [ "in" ident(id) ] -> - [ HypLocation ((CAst.make id),InHyp) ] + { HypLocation ((CAst.make id),InHyp) } | [ "in" "(" "Type" "of" ident(id) ")" ] -> - [ warn_deprecated_instantiate_syntax ("Type","type",id); - HypLocation ((CAst.make id),InHypTypeOnly) ] + { warn_deprecated_instantiate_syntax ("Type","type",id); + HypLocation ((CAst.make id),InHypTypeOnly) } | [ "in" "(" "Value" "of" ident(id) ")" ] -> - [ warn_deprecated_instantiate_syntax ("Value","value",id); - HypLocation ((CAst.make id),InHypValueOnly) ] + { warn_deprecated_instantiate_syntax ("Value","value",id); + HypLocation ((CAst.make id),InHypValueOnly) } | [ "in" "(" "type" "of" ident(id) ")" ] -> - [ HypLocation ((CAst.make id),InHypTypeOnly) ] + { HypLocation ((CAst.make id),InHypTypeOnly) } | [ "in" "(" "value" "of" ident(id) ")" ] -> - [ HypLocation ((CAst.make id),InHypValueOnly) ] + { HypLocation ((CAst.make id),InHypValueOnly) } END +{ + let pr_rename _ _ _ (n, m) = Id.print n ++ str " into " ++ Id.print m +} + ARGUMENT EXTEND rename - TYPED AS ident * ident - PRINTED BY pr_rename -| [ ident(n) "into" ident(m) ] -> [ (n, m) ] + TYPED AS (ident * ident) + PRINTED BY { pr_rename } +| [ ident(n) "into" ident(m) ] -> { (n, m) } END (* Julien: Mise en commun des differentes version de replace with in by *) -let pr_by_arg_tac _prc _prlc prtac opt_c = +{ + +let pr_by_arg_tac env sigma _prc _prlc prtac opt_c = match opt_c with | None -> mt () - | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Notation_gram.E) t) + | Some t -> hov 2 (str "by" ++ spc () ++ prtac env sigma (3,Notation_gram.E) t) + +} ARGUMENT EXTEND by_arg_tac - TYPED AS tactic_opt - PRINTED BY pr_by_arg_tac -| [ "by" tactic3(c) ] -> [ Some c ] -| [ ] -> [ None ] + TYPED AS tactic option + PRINTED BY { pr_by_arg_tac env sigma } +| [ "by" tactic3(c) ] -> { Some c } +| [ ] -> { None } END -let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c +{ + +let pr_by_arg_tac env sigma prtac opt_c = pr_by_arg_tac env sigma () () prtac opt_c -let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl +let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Pputils.pr_lident cl let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl let in_clause' = Pltac.in_clause +} + ARGUMENT EXTEND in_clause TYPED AS clause_dft_concl - PRINTED BY pr_in_top_clause - RAW_TYPED AS clause_dft_concl - RAW_PRINTED BY pr_in_clause - GLOB_TYPED AS clause_dft_concl - GLOB_PRINTED BY pr_in_clause -| [ in_clause'(cl) ] -> [ cl ] + PRINTED BY { pr_in_top_clause } + RAW_PRINTED BY { pr_in_clause } + GLOB_PRINTED BY { pr_in_clause } +| [ in_clause'(cl) ] -> { cl } END +{ + let local_test_lpar_id_colon = let err () = raise Stream.Failure in - Pcoq.Gram.Entry.of_parser "lpar_id_colon" + Pcoq.Entry.of_parser "lpar_id_colon" (fun strm -> match Util.stream_nth 0 strm with | Tok.KEYWORD "(" -> @@ -308,6 +345,8 @@ let local_test_lpar_id_colon = let pr_lpar_id_colon _ _ _ _ = mt () -ARGUMENT EXTEND test_lpar_id_colon TYPED AS unit PRINTED BY pr_lpar_id_colon -| [ local_test_lpar_id_colon(x) ] -> [ () ] +} + +ARGUMENT EXTEND test_lpar_id_colon TYPED AS unit PRINTED BY { pr_lpar_id_colon } +| [ local_test_lpar_id_colon(x) ] -> { () } END diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index fa70235975..7f9eecbef5 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Genintern open Tacexpr open Names open Constrexpr @@ -28,22 +29,22 @@ val wit_natural : int Genarg.uniform_genarg_type val wit_glob : (constr_expr, - Tacexpr.glob_constr_and_expr, + glob_constr_and_expr, Tacinterp.interp_sign * glob_constr) Genarg.genarg_type val wit_lglob : (constr_expr, - Tacexpr.glob_constr_and_expr, + glob_constr_and_expr, Tacinterp.interp_sign * glob_constr) Genarg.genarg_type val wit_lconstr : (constr_expr, - Tacexpr.glob_constr_and_expr, + glob_constr_and_expr, EConstr.t) Genarg.genarg_type val wit_casted_constr : (constr_expr, - Tacexpr.glob_constr_and_expr, + glob_constr_and_expr, EConstr.t) Genarg.genarg_type val glob : constr_expr Pcoq.Entry.t @@ -64,8 +65,9 @@ val wit_by_arg_tac : glob_tactic_expr option, Geninterp.Val.t option) Genarg.genarg_type -val pr_by_arg_tac : - (int * Notation_gram.parenRelation -> raw_tactic_expr -> Pp.t) -> +val pr_by_arg_tac : + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> int * Notation_gram.parenRelation -> raw_tactic_expr -> Pp.t) -> raw_tactic_expr option -> Pp.t val test_lpar_id_colon : unit Pcoq.Entry.t diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.mlg index e5b032e638..f5098d2a34 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.mlg @@ -8,8 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Pp open Constr +open Context open Genarg open Stdarg open Tacarg @@ -28,10 +31,17 @@ open Namegen open Tactypes open Tactics open Proofview.Notations -open Vernacinterp +open Attributes +open Vernacextend + +let wit_hyp = wit_var + +} DECLARE PLUGIN "ltac_plugin" +{ + (**********************************************************************) (* replace, discriminate, injection, simplify_eq *) (* cutrewrite, dependent rewrite *) @@ -40,10 +50,11 @@ let with_delayed_uconstr ist c tac = let flags = { Pretyping.use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; - expand_evars = true - } in + expand_evars = true; + program_mode = false; + polymorphic = false; + } in let c = Tacinterp.type_uconstr ~flags ist c in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -54,26 +65,30 @@ let replace_in_clause_maybe_by ist c1 c2 cl tac = let replace_term ist dir_opt c cl = with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) +} + TACTIC EXTEND replace - ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] --> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] +| ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] +-> { replace_in_clause_maybe_by ist c1 c2 cl tac } END TACTIC EXTEND replace_term_left - [ "replace" "->" uconstr(c) clause(cl) ] - -> [ replace_term ist (Some true) c cl ] +| [ "replace" "->" uconstr(c) clause(cl) ] + -> { replace_term ist (Some true) c cl } END TACTIC EXTEND replace_term_right - [ "replace" "<-" uconstr(c) clause(cl) ] - -> [ replace_term ist (Some false) c cl ] +| [ "replace" "<-" uconstr(c) clause(cl) ] + -> { replace_term ist (Some false) c cl } END TACTIC EXTEND replace_term - [ "replace" uconstr(c) clause(cl) ] - -> [ replace_term ist None c cl ] +| [ "replace" uconstr(c) clause(cl) ] + -> { replace_term ist None c cl } END +{ + let induction_arg_of_quantified_hyp = function | AnonHyp n -> None,ElimOnAnonHyp n | NamedHyp id -> None,ElimOnIdent (CAst.make id) @@ -94,28 +109,36 @@ let elimOnConstrWithHoles tac with_evars c = Tacticals.New.tclDELAYEDWITHHOLES with_evars c (fun c -> tac with_evars (Some (None,ElimOnConstr c))) +} + TACTIC EXTEND simplify_eq - [ "simplify_eq" ] -> [ dEq ~keep_proofs:None false None ] -| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles (dEq ~keep_proofs:None) false c ] +| [ "simplify_eq" ] -> { dEq ~keep_proofs:None false None } +| [ "simplify_eq" destruction_arg(c) ] -> { mytclWithHoles (dEq ~keep_proofs:None) false c } END TACTIC EXTEND esimplify_eq -| [ "esimplify_eq" ] -> [ dEq ~keep_proofs:None true None ] -| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles (dEq ~keep_proofs:None) true c ] +| [ "esimplify_eq" ] -> { dEq ~keep_proofs:None true None } +| [ "esimplify_eq" destruction_arg(c) ] -> { mytclWithHoles (dEq ~keep_proofs:None) true c } END +{ + let discr_main c = elimOnConstrWithHoles discr_tac false c +} + TACTIC EXTEND discriminate -| [ "discriminate" ] -> [ discr_tac false None ] +| [ "discriminate" ] -> { discr_tac false None } | [ "discriminate" destruction_arg(c) ] -> - [ mytclWithHoles discr_tac false c ] + { mytclWithHoles discr_tac false c } END TACTIC EXTEND ediscriminate -| [ "ediscriminate" ] -> [ discr_tac true None ] +| [ "ediscriminate" ] -> { discr_tac true None } | [ "ediscriminate" destruction_arg(c) ] -> - [ mytclWithHoles discr_tac true c ] + { mytclWithHoles discr_tac true c } END +{ + let discrHyp id = Proofview.tclEVARMAP >>= fun sigma -> discr_main (fun env sigma -> (sigma, (EConstr.mkVar id, NoBindings))) @@ -123,39 +146,45 @@ let discrHyp id = let injection_main with_evars c = elimOnConstrWithHoles (injClause None None) with_evars c +} + TACTIC EXTEND injection -| [ "injection" ] -> [ injClause None None false None ] -| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None None) false c ] +| [ "injection" ] -> { injClause None None false None } +| [ "injection" destruction_arg(c) ] -> { mytclWithHoles (injClause None None) false c } END TACTIC EXTEND einjection -| [ "einjection" ] -> [ injClause None None true None ] -| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None None) true c ] +| [ "einjection" ] -> { injClause None None true None } +| [ "einjection" destruction_arg(c) ] -> { mytclWithHoles (injClause None None) true c } END TACTIC EXTEND injection_as | [ "injection" "as" intropattern_list(ipat)] -> - [ injClause None (Some ipat) false None ] + { injClause None (Some ipat) false None } | [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause None (Some ipat)) false c ] + { mytclWithHoles (injClause None (Some ipat)) false c } END TACTIC EXTEND einjection_as | [ "einjection" "as" intropattern_list(ipat)] -> - [ injClause None (Some ipat) true None ] + { injClause None (Some ipat) true None } | [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause None (Some ipat)) true c ] + { mytclWithHoles (injClause None (Some ipat)) true c } END TACTIC EXTEND simple_injection -| [ "simple" "injection" ] -> [ simpleInjClause None false None ] -| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles (simpleInjClause None) false c ] +| [ "simple" "injection" ] -> { simpleInjClause None false None } +| [ "simple" "injection" destruction_arg(c) ] -> { mytclWithHoles (simpleInjClause None) false c } END +{ + let injHyp id = Proofview.tclEVARMAP >>= fun sigma -> injection_main false (fun env sigma -> (sigma, (EConstr.mkVar id, NoBindings))) +} + TACTIC EXTEND dependent_rewrite -| [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] +| [ "dependent" "rewrite" orient(b) constr(c) ] -> { rewriteInConcl b c } | [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ] - -> [ rewriteInHyp b c id ] + -> { rewriteInHyp b c id } END (** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to @@ -163,43 +192,53 @@ END "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *) TACTIC EXTEND cut_rewrite -| [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] +| [ "cutrewrite" orient(b) constr(eqn) ] -> { cutRewriteInConcl b eqn } | [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] - -> [ cutRewriteInHyp b eqn id ] + -> { cutRewriteInHyp b eqn id } END (**********************************************************************) (* Decompose *) TACTIC EXTEND decompose_sum -| [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ] +| [ "decompose" "sum" constr(c) ] -> { Elim.h_decompose_or c } END TACTIC EXTEND decompose_record -| [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ] +| [ "decompose" "record" constr(c) ] -> { Elim.h_decompose_and c } END (**********************************************************************) (* Contradiction *) +{ + open Contradiction +} + TACTIC EXTEND absurd - [ "absurd" constr(c) ] -> [ absurd c ] +| [ "absurd" constr(c) ] -> { absurd c } END +{ + let onSomeWithHoles tac = function | None -> tac None | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c)) +} + TACTIC EXTEND contradiction - [ "contradiction" constr_with_bindings_opt(c) ] -> - [ onSomeWithHoles contradiction c ] +| [ "contradiction" constr_with_bindings_opt(c) ] -> + { onSomeWithHoles contradiction c } END (**********************************************************************) (* AutoRewrite *) +{ + open Autorewrite let pr_orient _prc _prlc _prt = function @@ -209,50 +248,58 @@ let pr_orient _prc _prlc _prt = function let pr_orient_string _prc _prlc _prt (orient, s) = pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s -ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string -| [ orient(r) preident(i) ] -> [ r, i ] +} + +ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY { pr_orient_string } +| [ orient(r) preident(i) ] -> { r, i } END TACTIC EXTEND autorewrite | [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] -> - [ auto_multi_rewrite l ( cl) ] + { auto_multi_rewrite l ( cl) } | [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> - [ + { auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl - ] + } END TACTIC EXTEND autorewrite_star | [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] -> - [ auto_multi_rewrite ~conds:AllMatches l cl ] + { auto_multi_rewrite ~conds:AllMatches l cl } | [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> - [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ] + { auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl } END (**********************************************************************) (* Rewrite star *) +{ + let rewrite_star ist clause orient occs c (tac : Geninterp.Val.t option) = let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in with_delayed_uconstr ist c (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) +} + TACTIC EXTEND rewrite_star | [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] + { rewrite_star ist (Some id) o (occurrences_of occ) c tac } | [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] + { rewrite_star ist (Some id) o (occurrences_of occ) c tac } | [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ] + { rewrite_star ist (Some id) o Locus.AllOccurrences c tac } | [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star ist None o (occurrences_of occ) c tac ] + { rewrite_star ist None o (occurrences_of occ) c tac } | [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] -> - [ rewrite_star ist None o Locus.AllOccurrences c tac ] + { rewrite_star ist None o Locus.AllOccurrences c tac } END (**********************************************************************) (* Hint Rewrite *) +{ + let add_rewrite_hint ~poly bases ort t lcsr = let env = Global.env() in let sigma = Evd.from_env env in @@ -262,8 +309,8 @@ let add_rewrite_hint ~poly bases ort t lcsr = let ctx = let ctx = UState.context_set ctx in if poly then ctx - else (** This is a global universe context that shouldn't be - refreshed at every use of the hint, declare it globally. *) + else (* This is a global universe context that shouldn't be + refreshed at every use of the hint, declare it globally. *) (Declare.declare_universe_context false ctx; Univ.ContextSet.empty) in @@ -272,39 +319,45 @@ let add_rewrite_hint ~poly bases ort t lcsr = let add_hints base = add_rew_rules base eqs in List.iter add_hints bases -let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater +let classify_hint _ = VtSideff [], VtLater -VERNAC COMMAND FUNCTIONAL EXTEND HintRewrite CLASSIFIED BY classify_hint - [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> - [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic bl o None l; st ] -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) +} + +VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY { classify_hint } +| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> + { add_rewrite_hint ~poly:polymorphic bl o None l } +| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ":" preident_list(bl) ] -> - [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic bl o (Some t) l; st ] -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> - [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic ["core"] o None l; st ] -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> - [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic ["core"] o (Some t) l; st ] + { add_rewrite_hint ~poly:polymorphic bl o (Some t) l } +| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> + { add_rewrite_hint ~poly:polymorphic ["core"] o None l } +| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> + { add_rewrite_hint ~poly:polymorphic ["core"] o (Some t) l } END (**********************************************************************) (* Refine *) +{ + open EConstr open Vars let constr_flags () = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = Pfedit.use_unification_heuristics (); - Pretyping.use_hook = Pfedit.solve_by_implicit_tactic (); Pretyping.fail_evar = false; - Pretyping.expand_evars = true } + Pretyping.expand_evars = true; + Pretyping.program_mode = false; + Pretyping.polymorphic = false; +} let refine_tac ist simple with_classes c = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let flags = - { constr_flags () with Pretyping.use_typeclasses = with_classes } in + { (constr_flags ()) with Pretyping.use_typeclasses = with_classes } in let expected_type = Pretyping.OfType concl in let c = Tacinterp.type_uconstr ~flags ~expected_type ist c in let update = begin fun sigma -> @@ -317,125 +370,135 @@ let refine_tac ist simple with_classes c = Proofview.shelve_unifiable end +} + TACTIC EXTEND refine | [ "refine" uconstr(c) ] -> - [ refine_tac ist false true c ] + { refine_tac ist false true c } END TACTIC EXTEND simple_refine | [ "simple" "refine" uconstr(c) ] -> - [ refine_tac ist true true c ] + { refine_tac ist true true c } END TACTIC EXTEND notcs_refine | [ "notypeclasses" "refine" uconstr(c) ] -> - [ refine_tac ist false false c ] + { refine_tac ist false false c } END TACTIC EXTEND notcs_simple_refine | [ "simple" "notypeclasses" "refine" uconstr(c) ] -> - [ refine_tac ist true false c ] + { refine_tac ist true false c } END (* Solve unification constraints using heuristics or fail if any remain *) TACTIC EXTEND solve_constraints -[ "solve_constraints" ] -> [ Refine.solve_constraints ] +| [ "solve_constraints" ] -> { Refine.solve_constraints } END (**********************************************************************) (* Inversion lemmas (Leminv) *) +{ + open Inv open Leminv -let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater +let seff id = VtSideff [id], VtLater + +} (*VERNAC ARGUMENT EXTEND sort_family -| [ "Set" ] -> [ InSet ] -| [ "Prop" ] -> [ InProp ] -| [ "Type" ] -> [ InType ] +| [ "Set" ] -> { InSet } +| [ "Prop" ] -> { InProp } +| [ "Type" ] -> { InType } END*) -VERNAC COMMAND FUNCTIONAL EXTEND DeriveInversionClear -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] - => [ seff na ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_clear_tac; st ] +VERNAC COMMAND EXTEND DeriveInversionClear +| #[ polymorphic; ] [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] + => { seff na } + -> { + add_inversion_lemma_exn ~poly:polymorphic na c s false inv_clear_tac } -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_clear_tac; st ] +| #[ polymorphic; ] [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => { seff na } + -> { + add_inversion_lemma_exn ~poly:polymorphic na c Sorts.InProp false inv_clear_tac } END -VERNAC COMMAND FUNCTIONAL EXTEND DeriveInversion -| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] - => [ seff na ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_tac; st ] +VERNAC COMMAND EXTEND DeriveInversion +| #[ polymorphic; ] [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] + => { seff na } + -> { + add_inversion_lemma_exn ~poly:polymorphic na c s false inv_tac } -| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_tac; st ] +| #[ polymorphic; ] [ "Derive" "Inversion" ident(na) "with" constr(c) ] => { seff na } + -> { + add_inversion_lemma_exn ~poly:polymorphic na c Sorts.InProp false inv_tac } END -VERNAC COMMAND FUNCTIONAL EXTEND DeriveDependentInversion -| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] - => [ seff na ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_tac; st ] +VERNAC COMMAND EXTEND DeriveDependentInversion +| #[ polymorphic; ] [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] + => { seff na } + -> { + add_inversion_lemma_exn ~poly:polymorphic na c s true dinv_tac } END -VERNAC COMMAND FUNCTIONAL EXTEND DeriveDependentInversionClear -| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] - => [ seff na ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_clear_tac; st ] +VERNAC COMMAND EXTEND DeriveDependentInversionClear +| #[ polymorphic; ] [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] + => { seff na } + -> { + add_inversion_lemma_exn ~poly:polymorphic na c s true dinv_clear_tac } END (**********************************************************************) (* Subst *) TACTIC EXTEND subst -| [ "subst" ne_var_list(l) ] -> [ subst l ] -| [ "subst" ] -> [ subst_all () ] +| [ "subst" ne_var_list(l) ] -> { subst l } +| [ "subst" ] -> { subst_all () } END +{ + let simple_subst_tactic_flags = { only_leibniz = true; rewrite_dependent_proof = false } +} + TACTIC EXTEND simple_subst -| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ] +| [ "simple" "subst" ] -> { subst_all ~flags:simple_subst_tactic_flags () } END +{ + open Evar_tactics +} + (**********************************************************************) (* Evar creation *) (* TODO: add support for some test similar to g_constr.name_colon so that expressions like "evar (list A)" do not raise a syntax error *) TACTIC EXTEND evar - [ "evar" test_lpar_id_colon "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name.Name id) typ ] -| [ "evar" constr(typ) ] -> [ let_evar Name.Anonymous typ ] +| [ "evar" test_lpar_id_colon "(" ident(id) ":" lconstr(typ) ")" ] -> { let_evar (Name.Name id) typ } +| [ "evar" constr(typ) ] -> { let_evar Name.Anonymous typ } END TACTIC EXTEND instantiate - [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> - [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ] +| [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> + { Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals } | [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] -> - [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ] -| [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ] + { Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals } +| [ "instantiate" ] -> { Proofview.V82.nf_evar_goals } END (**********************************************************************) (** Nijmegen "step" tactic for setoid rewriting *) +{ + open Tactics open Glob_term open Libobject @@ -474,11 +537,9 @@ let cache_transitivity_lemma (_,(left,lem)) = let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) let inTransitivity : bool * Constr.t -> obj = - declare_object {(default_object "TRANSITIVITY-STEPS") with - cache_function = cache_transitivity_lemma; - open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o); - subst_function = subst_transitivity_lemma; - classify_function = (fun o -> Substitute o) } + declare_object @@ global_object_nodischarge "TRANSITIVITY-STEPS" + ~cache:cache_transitivity_lemma + ~subst:(Some subst_transitivity_lemma) (* Main entry points *) @@ -489,76 +550,44 @@ let add_transitivity_lemma left lem = let lem' = EConstr.to_constr sigma lem' in add_anonymous_leaf (inTransitivity (left,lem')) +} + (* Vernacular syntax *) TACTIC EXTEND stepl -| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ] -| ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ] +| ["stepl" constr(c) "by" tactic(tac) ] -> { step true c (Tacinterp.tactic_of_value ist tac) } +| ["stepl" constr(c) ] -> { step true c (Proofview.tclUNIT ()) } END TACTIC EXTEND stepr -| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ] -| ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ] +| ["stepr" constr(c) "by" tactic(tac) ] -> { step false c (Tacinterp.tactic_of_value ist tac) } +| ["stepr" constr(c) ] -> { step false c (Proofview.tclUNIT ()) } END VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF | [ "Declare" "Left" "Step" constr(t) ] -> - [ add_transitivity_lemma true t ] + { add_transitivity_lemma true t } END VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF | [ "Declare" "Right" "Step" constr(t) ] -> - [ add_transitivity_lemma false t ] -END - -let cache_implicit_tactic (_,tac) = match tac with - | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac) - | None -> Pfedit.clear_implicit_tactic () - -let subst_implicit_tactic (subst,tac) = - Option.map (Tacsubst.subst_tactic subst) tac - -let inImplicitTactic : glob_tactic_expr option -> obj = - declare_object {(default_object "IMPLICIT-TACTIC") with - open_function = (fun i o -> if Int.equal i 1 then cache_implicit_tactic o); - cache_function = cache_implicit_tactic; - subst_function = subst_implicit_tactic; - classify_function = (fun o -> Dispose)} - -let warn_deprecated_implicit_tactic = - CWarnings.create ~name:"deprecated-implicit-tactic" ~category:"deprecated" - (fun () -> strbrk "Implicit tactics are deprecated") - -let declare_implicit_tactic tac = - let () = warn_deprecated_implicit_tactic () in - Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac))) - -let clear_implicit_tactic () = - let () = warn_deprecated_implicit_tactic () in - Lib.add_anonymous_leaf (inImplicitTactic None) - -VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF -| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ declare_implicit_tactic tac ] -| [ "Clear" "Implicit" "Tactic" ] -> [ clear_implicit_tactic () ] + { add_transitivity_lemma false t } END - - - (**********************************************************************) (* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as defined by Conor McBride *) TACTIC EXTEND generalize_eqs -| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false id ] +| ["generalize_eqs" hyp(id) ] -> { abstract_generalize ~generalize_vars:false id } END TACTIC EXTEND dep_generalize_eqs -| ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ] +| ["dependent" "generalize_eqs" hyp(id) ] -> { abstract_generalize ~generalize_vars:false ~force_dep:true id } END TACTIC EXTEND generalize_eqs_vars -| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ] +| ["generalize_eqs_vars" hyp(id) ] -> { abstract_generalize ~generalize_vars:true id } END TACTIC EXTEND dep_generalize_eqs_vars -| ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ] +| ["dependent" "generalize_eqs_vars" hyp(id) ] -> { abstract_generalize ~force_dep:true ~generalize_vars:true id } END (** Tactic to automatically simplify hypotheses of the form [ΠΔ, x_i = t_i -> T] @@ -566,7 +595,7 @@ END during dependent induction. For internal use. *) TACTIC EXTEND specialize_eqs -[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ] +| [ "specialize_eqs" hyp(id) ] -> { specialize_eqs id } END (**********************************************************************) @@ -577,6 +606,8 @@ END (* Contributed by Chung-Kil Hur (Winter 2009) *) (**********************************************************************) +{ + let subst_var_with_hole occ tid t = let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in let locref = ref 0 in @@ -593,7 +624,7 @@ let subst_var_with_hole occ tid t = Evar_kinds.qm_obligation=Evar_kinds.Define true; Evar_kinds.qm_name=Anonymous; Evar_kinds.qm_record_field=None; - }, IntroAnonymous, None))) + }, IntroAnonymous, None))) else x | _ -> map_glob_constr_left_to_right substrec x in let t' = substrec t @@ -608,7 +639,7 @@ let subst_hole_with_term occ tc t = Evar_kinds.qm_obligation=Evar_kinds.Define true; Evar_kinds.qm_name=Anonymous; Evar_kinds.qm_record_field=None; - }, IntroAnonymous, s) -> + }, IntroAnonymous, s) -> decr occref; if Int.equal !occref 0 then tc else @@ -618,7 +649,7 @@ let subst_hole_with_term occ tc t = Evar_kinds.qm_obligation=Evar_kinds.Define true; Evar_kinds.qm_name=Anonymous; Evar_kinds.qm_record_field=None; - },IntroAnonymous,s)) + },IntroAnonymous,s)) | _ -> map_glob_constr_left_to_right substrec c in substrec t @@ -646,7 +677,7 @@ let hResolve id c occ t = let sigma = Evd.merge_universe_context sigma ctx in let t_constr_type = Retyping.get_type_of env sigma t_constr in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (change_concl (mkLetIn (Name.Anonymous,t_constr,t_constr_type,concl))) + (change_concl (mkLetIn (make_annot Name.Anonymous Sorts.Relevant,t_constr,t_constr_type,concl))) end let hResolve_auto id c t = @@ -659,9 +690,11 @@ let hResolve_auto id c t = in resolve_auto 1 +} + TACTIC EXTEND hresolve_core -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ] -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> { hResolve id c occ t } +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> { hResolve_auto id c t } END (** @@ -669,7 +702,7 @@ END *) TACTIC EXTEND hget_evar -| [ "hget_evar" int_or_var(n) ] -> [ Evar_tactics.hget_evar n ] +| [ "hget_evar" int_or_var(n) ] -> { Evar_tactics.hget_evar n } END (**********************************************************************) @@ -682,6 +715,8 @@ END (* Contributed by Julien Forest and Pierre Courtieu (july 2010) *) (**********************************************************************) +{ + exception Found of unit Proofview.tactic let rewrite_except h = @@ -707,7 +742,8 @@ let mkCaseEq a : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in - (** FIXME: this looks really wrong. Does anybody really use this tactic? *) + (* FIXME: this looks really wrong. Does anybody really use + this tactic? *) let (_, c) = Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env (Evd.from_env env) concl in change_concl c end; @@ -737,7 +773,7 @@ let case_eq_intros_rewrite x = let rec find_a_destructable_match sigma t = let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in let cl = [cl, (None, None), None], None in - let dest = TacAtom (Loc.tag @@ TacInductionDestruct(false, false, cl)) in + let dest = TacAtom (CAst.make @@ TacInductionDestruct(false, false, cl)) in match EConstr.kind sigma t with | Case (_,_,x,_) when closed0 sigma x -> if isVar sigma x then @@ -763,9 +799,11 @@ let destauto_in id = destauto ctype end +} + TACTIC EXTEND destauto -| [ "destauto" ] -> [ Proofview.Goal.enter begin fun gl -> destauto (Proofview.Goal.concl gl) end ] -| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] +| [ "destauto" ] -> { Proofview.Goal.enter begin fun gl -> destauto (Proofview.Goal.concl gl) end } +| [ "destauto" "in" hyp(id) ] -> { destauto_in id } END (**********************************************************************) @@ -776,116 +814,116 @@ END (**********************************************************************) TACTIC EXTEND transparent_abstract -| [ "transparent_abstract" tactic3(t) ] -> [ Proofview.Goal.enter begin fun gl -> - Tactics.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end ] -| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> [ Proofview.Goal.enter begin fun gl -> - Tactics.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end ] +| [ "transparent_abstract" tactic3(t) ] -> { Proofview.Goal.enter begin fun gl -> + Abstract.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end; } +| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> { Proofview.Goal.enter begin fun gl -> + Abstract.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end; } END (* ********************************************************************* *) TACTIC EXTEND constr_eq -| [ "constr_eq" constr(x) constr(y) ] -> [ Tactics.constr_eq ~strict:false x y ] +| [ "constr_eq" constr(x) constr(y) ] -> { Tactics.constr_eq ~strict:false x y } END TACTIC EXTEND constr_eq_strict -| [ "constr_eq_strict" constr(x) constr(y) ] -> [ Tactics.constr_eq ~strict:true x y ] +| [ "constr_eq_strict" constr(x) constr(y) ] -> { Tactics.constr_eq ~strict:true x y } END TACTIC EXTEND constr_eq_nounivs -| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ +| [ "constr_eq_nounivs" constr(x) constr(y) ] -> { Proofview.tclEVARMAP >>= fun sigma -> - if eq_constr_nounivs sigma x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] + if eq_constr_nounivs sigma x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") } END TACTIC EXTEND is_evar -| [ "is_evar" constr(x) ] -> [ +| [ "is_evar" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Evar _ -> Proofview.tclUNIT () | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar") - ] + } END TACTIC EXTEND has_evar -| [ "has_evar" constr(x) ] -> [ +| [ "has_evar" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> if Evarutil.has_undefined_evars sigma x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") -] +} END TACTIC EXTEND is_hyp -| [ "is_var" constr(x) ] -> [ +| [ "is_var" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Var _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ] + | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") } END TACTIC EXTEND is_fix -| [ "is_fix" constr(x) ] -> [ +| [ "is_fix" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Fix _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") } +END TACTIC EXTEND is_cofix -| [ "is_cofix" constr(x) ] -> [ +| [ "is_cofix" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | CoFix _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") } +END TACTIC EXTEND is_ind -| [ "is_ind" constr(x) ] -> [ +| [ "is_ind" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Ind _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") } +END TACTIC EXTEND is_constructor -| [ "is_constructor" constr(x) ] -> [ +| [ "is_constructor" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Construct _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") } +END TACTIC EXTEND is_proj -| [ "is_proj" constr(x) ] -> [ +| [ "is_proj" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Proj _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") } +END TACTIC EXTEND is_const -| [ "is_const" constr(x) ] -> [ +| [ "is_const" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Const _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") } +END (* Command to grab the evars left unresolved at the end of a proof. *) (* spiwack: I put it in extratactics because it is somewhat tied with the semantics of the LCF-style tactics, hence with the classic tactic mode. *) VERNAC COMMAND EXTEND GrabEvars -[ "Grab" "Existential" "Variables" ] - => [ Vernac_classifier.classify_as_proofstep ] - -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) ] +| ![ proof ] [ "Grab" "Existential" "Variables" ] + => { classify_as_proofstep } + -> { fun ~pstate -> Option.map (Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p)) pstate } END (* Shelves all the goals under focus. *) TACTIC EXTEND shelve | [ "shelve" ] -> - [ Proofview.shelve ] + { Proofview.shelve } END (* Shelves the unifiable goals under focus, i.e. the goals which @@ -893,25 +931,25 @@ END considered). *) TACTIC EXTEND shelve_unifiable | [ "shelve_unifiable" ] -> - [ Proofview.shelve_unifiable ] + { Proofview.shelve_unifiable } END (* Unshelves the goal shelved by the tactic. *) TACTIC EXTEND unshelve | [ "unshelve" tactic1(t) ] -> - [ + { Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) -> let gls = List.map Proofview.with_empty_state gls in Proofview.Unsafe.tclGETGOALS >>= fun ogls -> Proofview.Unsafe.tclSETGOALS (gls @ ogls) - ] + } END (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve -[ "Unshelve" ] - => [ Vernac_classifier.classify_as_proofstep ] - -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) ] +| ![ proof ] [ "Unshelve" ] + => { classify_as_proofstep } + -> { fun ~pstate -> Option.map (Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p)) pstate } END (* Gives up on the goals under focus: the goals are considered solved, @@ -919,24 +957,26 @@ END these goals. *) TACTIC EXTEND give_up | [ "give_up" ] -> - [ Proofview.give_up ] + { Proofview.give_up } END (* cycles [n] goals *) TACTIC EXTEND cycle -| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ] +| [ "cycle" int_or_var(n) ] -> { Proofview.cycle n } END (* swaps goals number [i] and [j] *) TACTIC EXTEND swap -| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ] +| [ "swap" int_or_var(i) int_or_var(j) ] -> { Proofview.swap i j } END (* reverses the list of focused goals *) TACTIC EXTEND revgoals -| [ "revgoals" ] -> [ Proofview.revgoals ] +| [ "revgoals" ] -> { Proofview.revgoals } END +{ + type cmp = | Eq | Lt | Le @@ -965,29 +1005,35 @@ let pr_itest = pr_test_gen Pp.int let pr_itest' _prc _prlc _prt = pr_itest +} - -ARGUMENT EXTEND comparison PRINTED BY pr_cmp' -| [ "=" ] -> [ Eq ] -| [ "<" ] -> [ Lt ] -| [ "<=" ] -> [ Le ] -| [ ">" ] -> [ Gt ] -| [ ">=" ] -> [ Ge ] +ARGUMENT EXTEND comparison PRINTED BY { pr_cmp' } +| [ "=" ] -> { Eq } +| [ "<" ] -> { Lt } +| [ "<=" ] -> { Le } +| [ ">" ] -> { Gt } +| [ ">=" ] -> { Ge } END +{ + let interp_test ist gls = function | Test (c,x,y) -> project gls , Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y) +} + ARGUMENT EXTEND test - PRINTED BY pr_itest' - INTERPRETED BY interp_test - RAW_PRINTED BY pr_test' - GLOB_PRINTED BY pr_test' -| [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ] + PRINTED BY { pr_itest' } + INTERPRETED BY { interp_test } + RAW_PRINTED BY { pr_test' } + GLOB_PRINTED BY { pr_test' } +| [ int_or_var(x) comparison(c) int_or_var(y) ] -> { Test(c,x,y) } END +{ + let interp_cmp = function | Eq -> Int.equal | Lt -> ((<):int->int->bool) @@ -1005,11 +1051,14 @@ let guard tst = let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in Tacticals.New.tclZEROMSG msg +} TACTIC EXTEND guard -| [ "guard" test(tst) ] -> [ guard tst ] +| [ "guard" test(tst) ] -> { guard tst } END +{ + let decompose l c = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in @@ -1021,14 +1070,16 @@ let decompose l c = Elim.h_decompose l c end +} + TACTIC EXTEND decompose -| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] +| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> { decompose l c } END (** library/keys *) VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF -| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ +| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> { let get_key c = let env = Global.env () in let evd = Evd.from_env env in @@ -1040,26 +1091,30 @@ VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF let k2 = get_key c' in match k1, k2 with | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2 - | _ -> () ] + | _ -> () } END VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY -| [ "Print" "Equivalent" "Keys" ] -> [ Feedback.msg_info (Keys.pr_keys Printer.pr_global) ] +| [ "Print" "Equivalent" "Keys" ] -> { Feedback.msg_info (Keys.pr_keys Printer.pr_global) } END VERNAC COMMAND EXTEND OptimizeProof -| [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] -> - [ Proof_global.compact_the_proof () ] -| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] -> - [ Gc.compact () ] +| ![ proof ] [ "Optimize" "Proof" ] => { classify_as_proofstep } -> + { fun ~pstate -> Option.map Proof_global.compact_the_proof pstate } +| [ "Optimize" "Heap" ] => { classify_as_proofstep } -> + { Gc.compact () } END (** tactic analogous to "OPTIMIZE HEAP" *) +{ + let tclOPTIMIZE_HEAP = Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> Gc.compact ())) +} + TACTIC EXTEND optimize_heap -| [ "optimize_heap" ] -> [ tclOPTIMIZE_HEAP ] +| [ "optimize_heap" ] -> { tclOPTIMIZE_HEAP } END diff --git a/plugins/ltac/extratactics.mli b/plugins/ltac/extratactics.mli index 7fb9a19a0c..4576562634 100644 --- a/plugins/ltac/extratactics.mli +++ b/plugins/ltac/extratactics.mli @@ -14,4 +14,4 @@ val injHyp : Names.Id.t -> unit Proofview.tactic (* val refine_tac : Evd.open_constr -> unit Proofview.tactic *) -val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic +val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tactypes.delayed_open option -> unit Proofview.tactic diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.mlg index 35ed14fc18..523c7c8305 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.mlg @@ -8,155 +8,169 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Pp open Constr -open Genarg open Stdarg open Pcoq.Prim open Pcoq.Constr open Pltac open Hints +let wit_hyp = wit_var + +} + DECLARE PLUGIN "ltac_plugin" (* Hint bases *) TACTIC EXTEND eassumption -| [ "eassumption" ] -> [ Eauto.e_assumption ] +| [ "eassumption" ] -> { Eauto.e_assumption } END TACTIC EXTEND eexact -| [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ] +| [ "eexact" constr(c) ] -> { Eauto.e_give_exact c } END +{ + let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases +} + ARGUMENT EXTEND hintbases - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ "with" "*" ] -> [ None ] -| [ "with" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ Some [] ] + TYPED AS preident list option + PRINTED BY { pr_hintbases } +| [ "with" "*" ] -> { None } +| [ "with" ne_preident_list(l) ] -> { Some l } +| [ ] -> { Some [] } END +{ + let eval_uconstrs ist cs = let flags = { Pretyping.use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; - expand_evars = true + expand_evars = true; + program_mode = false; + polymorphic = false; } in let map c env sigma = c env sigma in List.map (fun c -> map (Tacinterp.type_uconstr ~flags ist c)) cs -let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr -let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> - let _, env = Pfedit.get_current_context () in +let pr_auto_using_raw env sigma _ _ _ = Pptactic.pr_auto_using @@ Ppconstr.pr_constr_expr env sigma +let pr_auto_using_glob env sigma _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr_env env c) -let pr_auto_using _ _ _ = Pptactic.pr_auto_using - (let sigma, env = Pfedit.get_current_context () in - Printer.pr_closed_glob_env env sigma) +let pr_auto_using env sigma _ _ _ = Pptactic.pr_auto_using @@ + Printer.pr_closed_glob_env env sigma + +} ARGUMENT EXTEND auto_using - TYPED AS uconstr_list - PRINTED BY pr_auto_using - RAW_TYPED AS uconstr_list - RAW_PRINTED BY pr_auto_using_raw - GLOB_TYPED AS uconstr_list - GLOB_PRINTED BY pr_auto_using_glob -| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] -| [ ] -> [ [] ] + TYPED AS uconstr list + PRINTED BY { pr_auto_using env sigma } + RAW_PRINTED BY { pr_auto_using_raw env sigma } + GLOB_PRINTED BY { pr_auto_using_glob env sigma } +| [ "using" ne_uconstr_list_sep(l, ",") ] -> { l } +| [ ] -> { [] } END (** Auto *) TACTIC EXTEND trivial | [ "trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial (eval_uconstrs ist lems) db ] + { Auto.h_trivial (eval_uconstrs ist lems) db } END TACTIC EXTEND info_trivial | [ "info_trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ] + { Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db } END TACTIC EXTEND debug_trivial | [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ] + { Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db } END TACTIC EXTEND auto | [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto n (eval_uconstrs ist lems) db ] + { Auto.h_auto n (eval_uconstrs ist lems) db } END TACTIC EXTEND info_auto | [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ] + { Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db } END TACTIC EXTEND debug_auto | [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] + { Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db } END (** Eauto *) TACTIC EXTEND prolog | [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> - [ Eauto.prolog_tac (eval_uconstrs ist l) n ] + { Eauto.prolog_tac (eval_uconstrs ist l) n } END +{ + let make_depth n = snd (Eauto.make_dimension n None) +} + TACTIC EXTEND eauto | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] + { Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END TACTIC EXTEND new_eauto | [ "new" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ match db with + { match db with | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) - | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ] + | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l } END TACTIC EXTEND debug_eauto | [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] + { Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END TACTIC EXTEND info_eauto | [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] + { Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END TACTIC EXTEND dfs_eauto | [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ] + { Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db } END TACTIC EXTEND autounfold -| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ] +| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> { Eauto.autounfold_tac db cl } END TACTIC EXTEND autounfold_one | [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> - [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ] + { Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) } | [ "autounfold_one" hintbases(db) ] -> - [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] + { Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None } END TACTIC EXTEND unify -| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ] -| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ +| ["unify" constr(x) constr(y) ] -> { Tactics.unify x y } +| ["unify" constr(x) constr(y) "with" preident(base) ] -> { let table = try Some (Hints.searchtable_map base) with Not_found -> None in match table with | None -> @@ -165,65 +179,69 @@ TACTIC EXTEND unify | Some t -> let state = Hints.Hint_db.transparent_state t in Tactics.unify ~state x y - ] + } END TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x DEFAULTcast ] +| ["convert_concl_no_check" constr(x) ] -> { Tactics.convert_concl_no_check x DEFAULTcast } END +{ + let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_qualid let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global let glob_hints_path_atom ist = Hints.glob_hints_path_atom +} + ARGUMENT EXTEND hints_path_atom - PRINTED BY pr_hints_path_atom + PRINTED BY { pr_hints_path_atom } - GLOBALIZED BY glob_hints_path_atom + GLOBALIZED BY { glob_hints_path_atom } - RAW_PRINTED BY pr_pre_hints_path_atom - GLOB_PRINTED BY pr_hints_path_atom -| [ ne_global_list(g) ] -> [ Hints.PathHints g ] -| [ "_" ] -> [ Hints.PathAny ] + RAW_PRINTED BY { pr_pre_hints_path_atom } + GLOB_PRINTED BY { pr_hints_path_atom } +| [ ne_global_list(g) ] -> { Hints.PathHints g } +| [ "_" ] -> { Hints.PathAny } END +{ + let pr_hints_path prc prx pry c = Hints.pp_hints_path c let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_qualid c let glob_hints_path ist = Hints.glob_hints_path +} + ARGUMENT EXTEND hints_path -PRINTED BY pr_hints_path +PRINTED BY { pr_hints_path } -GLOBALIZED BY glob_hints_path -RAW_PRINTED BY pr_pre_hints_path -GLOB_PRINTED BY pr_hints_path +GLOBALIZED BY { glob_hints_path } +RAW_PRINTED BY { pr_pre_hints_path } +GLOB_PRINTED BY { pr_hints_path } -| [ "(" hints_path(p) ")" ] -> [ p ] -| [ hints_path(p) "*" ] -> [ Hints.PathStar p ] -| [ "emp" ] -> [ Hints.PathEmpty ] -| [ "eps" ] -> [ Hints.PathEpsilon ] -| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] -| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] -| [ hints_path(p) hints_path(q) ] -> [ Hints.PathSeq (p, q) ] +| [ "(" hints_path(p) ")" ] -> { p } +| [ hints_path(p) "*" ] -> { Hints.PathStar p } +| [ "emp" ] -> { Hints.PathEmpty } +| [ "eps" ] -> { Hints.PathEpsilon } +| [ hints_path(p) "|" hints_path(q) ] -> { Hints.PathOr (p, q) } +| [ hints_path_atom(a) ] -> { Hints.PathAtom a } +| [ hints_path(p) hints_path(q) ] -> { Hints.PathSeq (p, q) } END ARGUMENT EXTEND opthints - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ ":" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ None ] + TYPED AS preident list option + PRINTED BY { pr_hintbases } +| [ ":" ne_preident_list(l) ] -> { Some l } +| [ ] -> { None } END -VERNAC COMMAND FUNCTIONAL EXTEND HintCut CLASSIFIED AS SIDEFF -| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ - fun ~atts ~st -> begin - let open Vernacinterp in +VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF +| #[ locality = Attributes.locality; ] [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> { let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in - Hints.add_hints ~local:(Locality.make_section_locality atts.locality) + Hints.add_hints ~local:(Locality.make_section_locality locality) (match dbnames with None -> ["core"] | Some l -> l) entry; - st - end - ] + } END diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.mlg index 1c2f90b670..3f2fabeeee 100644 --- a/plugins/ltac/g_class.ml4 +++ b/plugins/ltac/g_class.mlg @@ -8,87 +8,114 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Class_tactics open Stdarg open Tacarg +} + DECLARE PLUGIN "ltac_plugin" (** Options: depth, debug and transparency settings. *) +{ + let set_transparency cl b = List.iter (fun r -> let gr = Smartlocate.global_with_alias r in let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in Classes.set_typeclass_transparency ev (Locality.make_section_locality None) b) cl +} + VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF -| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ - set_transparency cl true ] +| [ "Typeclasses" "Transparent" reference_list(cl) ] -> { + set_transparency cl true } END VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF -| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ - set_transparency cl false ] +| [ "Typeclasses" "Opaque" reference_list(cl) ] -> { + set_transparency cl false } END -open Genarg +{ let pr_debug _prc _prlc _prt b = if b then Pp.str "debug" else Pp.mt() -ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug -| [ "debug" ] -> [ true ] -| [ ] -> [ false ] +} + +ARGUMENT EXTEND debug TYPED AS bool PRINTED BY { pr_debug } +| [ "debug" ] -> { true } +| [ ] -> { false } END +{ + let pr_search_strategy _prc _prlc _prt = function | Some Dfs -> Pp.str "dfs" | Some Bfs -> Pp.str "bfs" | None -> Pp.mt () -ARGUMENT EXTEND eauto_search_strategy PRINTED BY pr_search_strategy -| [ "(bfs)" ] -> [ Some Bfs ] -| [ "(dfs)" ] -> [ Some Dfs ] -| [ ] -> [ None ] +} + +ARGUMENT EXTEND eauto_search_strategy PRINTED BY { pr_search_strategy } +| [ "(bfs)" ] -> { Some Bfs } +| [ "(dfs)" ] -> { Some Dfs } +| [ ] -> { None } END (* true = All transparent, false = Opaque if possible *) VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF - | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> [ + | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> { set_typeclasses_debug d; Option.iter set_typeclasses_strategy s; set_typeclasses_depth depth - ] + } END (** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *) TACTIC EXTEND typeclasses_eauto | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] -> - [ typeclasses_eauto ~strategy:Bfs ~depth:d l ] + { typeclasses_eauto ~strategy:Bfs ~depth:d l } | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> - [ typeclasses_eauto ~depth:d l ] - | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> [ - typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] ] + { typeclasses_eauto ~depth:d l } + | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> { + typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] } END TACTIC EXTEND head_of_constr - [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ] +| [ "head_of_constr" ident(h) constr(c) ] -> { head_of_constr h c } END TACTIC EXTEND not_evar - [ "not_evar" constr(ty) ] -> [ not_evar ty ] +| [ "not_evar" constr(ty) ] -> { not_evar ty } END TACTIC EXTEND is_ground - [ "is_ground" constr(ty) ] -> [ is_ground ty ] +| [ "is_ground" constr(ty) ] -> { is_ground ty } END +{ +let deprecated_autoapply_using = + CWarnings.create + ~name:"autoapply-using" ~category:"deprecated" + (fun () -> Pp.str "The syntax [autoapply ... using] is deprecated. Use [autoapply ... with] instead.") +} + TACTIC EXTEND autoapply - [ "autoapply" constr(c) "using" preident(i) ] -> [ autoapply c i ] +| [ "autoapply" constr(c) "using" preident(i) ] -> { + deprecated_autoapply_using (); + autoapply c i + } +| [ "autoapply" constr(c) "with" preident(i) ] -> { autoapply c i } END +{ + (** TODO: DEPRECATE *) (* A progress test that allows to see if the evars have changed *) open Constr @@ -114,6 +141,8 @@ let progress_evars t = in t <*> check end +} + TACTIC EXTEND progress_evars - [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] +| [ "progress_evars" tactic(t) ] -> { progress_evars (Tacinterp.tactic_of_value ist t) } END diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 deleted file mode 100644 index 929390b1c4..0000000000 --- a/plugins/ltac/g_ltac.ml4 +++ /dev/null @@ -1,528 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -DECLARE PLUGIN "ltac_plugin" - -open Util -open Pp -open Glob_term -open Constrexpr -open Tacexpr -open Namegen -open Genarg -open Genredexpr -open Tok (* necessary for camlp5 *) -open Names - -open Pcoq -open Pcoq.Prim -open Pcoq.Constr -open Pvernac.Vernac_ -open Pltac - -let fail_default_value = Locus.ArgArg 0 - -let arg_of_expr = function - TacArg (loc,a) -> a - | e -> Tacexp (e:raw_tactic_expr) - -let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () -let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n -let genarg_of_ipattern pat = in_gen (rawwit Tacarg.wit_intro_pattern) pat -let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c -let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac - -let reference_to_id qid = - if Libnames.qualid_is_ident qid then - CAst.make ?loc:qid.CAst.loc @@ Libnames.qualid_basename qid - else - CErrors.user_err ?loc:qid.CAst.loc - (str "This expression should be a simple identifier.") - -let tactic_mode = Entry.create "vernac:tactic_command" - -let new_entry name = - let e = Entry.create name in - e - -let toplevel_selector = new_entry "vernac:toplevel_selector" -let tacdef_body = new_entry "tactic:tacdef_body" - -(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for - proof editing and changes nothing else). Then sets it as the default proof mode. *) -let _ = - let mode = { - Proof_global.name = "Classic"; - set = (fun () -> Pvernac.set_command_entry tactic_mode); - reset = (fun () -> Pvernac.(set_command_entry noedit_mode)); - } in - Proof_global.register_proof_mode mode - -(* Hack to parse "[ id" without dropping [ *) -let test_bracket_ident = - Gram.Entry.of_parser "test_bracket_ident" - (fun strm -> - match stream_nth 0 strm with - | KEYWORD "[" -> - (match stream_nth 1 strm with - | IDENT _ -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - -(* Tactics grammar rules *) - -let hint = G_proofs.hint - -GEXTEND Gram - GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint - tactic_mode constr_may_eval constr_eval toplevel_selector - operconstr; - - tactic_then_last: - [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> - Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) - | -> [||] - ] ] - ; - tactic_then_gen: - [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) - | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) - | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) - | ta = tactic_expr -> ([ta], None) - | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) - | -> ([TacId []], None) - ] ] - ; - tactic_then_locality: (* [true] for the local variant [TacThens] and [false] - for [TacExtend] *) - [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] - ; - tactic_expr: - [ "5" RIGHTA - [ te = binder_tactic -> te ] - | "4" LEFTA - [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1) - | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1) - | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" -> - match l , tail with - | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) - | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) - | false , None -> TacThen (ta0,TacDispatch first) - | true , None -> TacThens (ta0,first) ] - | "3" RIGHTA - [ IDENT "try"; ta = tactic_expr -> TacTry ta - | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) - | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) - | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta) - | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta - | IDENT "progress"; ta = tactic_expr -> TacProgress ta - | IDENT "once"; ta = tactic_expr -> TacOnce ta - | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta - | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta -(*To do: put Abstract in Refiner*) - | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) - | IDENT "abstract"; tc = NEXT; "using"; s = ident -> - TacAbstract (tc,Some s) - | sel = selector; ta = tactic_expr -> TacSelect (sel, ta) ] -(*End of To do*) - | "2" RIGHTA - [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1) - | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) - | IDENT "tryif" ; ta = tactic_expr ; - "then" ; tat = tactic_expr ; - "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae) - | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) - | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] - | "1" RIGHTA - [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> - TacMatchGoal (b,false,mrl) - | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; - mrl = match_context_list; "end" -> - TacMatchGoal (b,true,mrl) - | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> - TacMatch (b,c,mrl) - | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacFirst l - | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacSolve l - | IDENT "idtac"; l = LIST0 message_token -> TacId l - | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; - l = LIST0 message_token -> TacFail (g,n,l) - | st = simple_tactic -> st - | a = tactic_arg -> TacArg(Loc.tag ~loc:!@loc a) - | r = reference; la = LIST0 tactic_arg_compat -> - TacArg(Loc.tag ~loc:!@loc @@ TacCall (Loc.tag ~loc:!@loc (r,la))) ] - | "0" - [ "("; a = tactic_expr; ")" -> a - | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> - begin match tail with - | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) - | None -> TacDispatch tf - end - | a = tactic_atom -> TacArg (Loc.tag ~loc:!@loc a) ] ] - ; - failkw: - [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] - ; - (* binder_tactic: level 5 of tactic_expr *) - binder_tactic: - [ RIGHTA - [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> - TacFun (it,body) - | "let"; isrec = [IDENT "rec" -> true | -> false]; - llc = LIST1 let_clause SEP "with"; "in"; - body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) - | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] - ; - (* Tactic arguments to the right of an application *) - tactic_arg_compat: - [ [ a = tactic_arg -> a - | c = Constr.constr -> (match c with { CAst.v = CRef (r,None) } -> Reference r | c -> ConstrMayEval (ConstrTerm c)) - (* Unambiguous entries: tolerated w/o "ltac:" modifier *) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] - ; - (* Can be used as argument and at toplevel in tactic expressions. *) - tactic_arg: - [ [ c = constr_eval -> ConstrMayEval c - | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l - | IDENT "type_term"; c=uconstr -> TacPretype c - | IDENT "numgoals" -> TacNumgoals ] ] - ; - (* If a qualid is given, use its short name. TODO: have the shortest - non ambiguous name where dots are replaced by "_"? Probably too - verbose most of the time. *) - fresh_id: - [ [ s = STRING -> Locus.ArgArg s (*| id = ident -> Locus.ArgVar (!@loc,id)*) - | qid = qualid -> Locus.ArgVar (CAst.make ~loc:!@loc @@ Libnames.qualid_basename qid) ] ] - ; - constr_eval: - [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> - ConstrEval (rtc,c) - | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> - ConstrContext (id,c) - | IDENT "type"; IDENT "of"; c = Constr.constr -> - ConstrTypeOf c ] ] - ; - constr_may_eval: (* For extensions *) - [ [ c = constr_eval -> c - | c = Constr.constr -> ConstrTerm c ] ] - ; - tactic_atom: - [ [ n = integer -> TacGeneric (genarg_of_int n) - | r = reference -> TacCall (Loc.tag ~loc:!@loc (r,[])) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] - ; - match_key: - [ [ "match" -> Once - | "lazymatch" -> Select - | "multimatch" -> General ] ] - ; - input_fun: - [ [ "_" -> Name.Anonymous - | l = ident -> Name.Name l ] ] - ; - let_clause: - [ [ idr = identref; ":="; te = tactic_expr -> - (CAst.map (fun id -> Name id) idr, arg_of_expr te) - | na = ["_" -> CAst.make ~loc:!@loc Anonymous]; ":="; te = tactic_expr -> - (na, arg_of_expr te) - | idr = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> - (CAst.map (fun id -> Name id) idr, arg_of_expr (TacFun(args,te))) ] ] - ; - match_pattern: - [ [ IDENT "context"; oid = OPT Constr.ident; - "["; pc = Constr.lconstr_pattern; "]" -> - Subterm (oid, pc) - | pc = Constr.lconstr_pattern -> Term pc ] ] - ; - match_hyps: - [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) - | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) - | na = name; ":="; mpv = match_pattern -> - let t, ty = - match mpv with - | Term t -> (match t with - | { CAst.v = CCast (t, (CastConv ty | CastVM ty | CastNative ty)) } -> Term t, Some (Term ty) - | _ -> mpv, None) - | _ -> mpv, None - in Def (na, t, Option.default (Term (CAst.make @@ CHole (None, IntroAnonymous, None))) ty) - ] ] - ; - match_context_rule: - [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "_"; "=>"; te = tactic_expr -> All te ] ] - ; - match_context_list: - [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] - ; - match_rule: - [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) - | "_"; "=>"; te = tactic_expr -> All te ] ] - ; - match_list: - [ [ mrl = LIST1 match_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] - ; - message_token: - [ [ id = identref -> MsgIdent id - | s = STRING -> MsgString s - | n = integer -> MsgInt n ] ] - ; - - ltac_def_kind: - [ [ ":=" -> false - | "::=" -> true ] ] - ; - - (* Definitions for tactics *) - tacdef_body: - [ [ name = Constr.global; it=LIST1 input_fun; - redef = ltac_def_kind; body = tactic_expr -> - if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) - else - let id = reference_to_id name in - Tacexpr.TacticDefinition (id, TacFun (it, body)) - | name = Constr.global; redef = ltac_def_kind; - body = tactic_expr -> - if redef then Tacexpr.TacticRedefinition (name, body) - else - let id = reference_to_id name in - Tacexpr.TacticDefinition (id, body) - ] ] - ; - tactic: - [ [ tac = tactic_expr -> tac ] ] - ; - - range_selector: - [ [ n = natural ; "-" ; m = natural -> (n, m) - | n = natural -> (n, n) ] ] - ; - (* We unfold a range selectors list once so that we can make a special case - * for a unique SelectNth selector. *) - range_selector_or_nth: - [ [ n = natural ; "-" ; m = natural; - l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - Goal_select.SelectList ((n, m) :: Option.default [] l) - | n = natural; - l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - let open Goal_select in - Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ] - ; - selector_body: - [ [ l = range_selector_or_nth -> l - | test_bracket_ident; "["; id = ident; "]" -> Goal_select.SelectId id ] ] - ; - selector: - [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] - ; - toplevel_selector: - [ [ sel = selector_body; ":" -> sel - | "!"; ":" -> Goal_select.SelectAlreadyFocused - | IDENT "all"; ":" -> Goal_select.SelectAll ] ] - ; - tactic_mode: - [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> tac g - | g = OPT toplevel_selector; "{" -> Vernacexpr.VernacSubproof g ] ] - ; - command: - [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; - l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> - Vernacexpr.VernacProof (Some (in_tac ta), l) - | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; - ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] -> - Vernacexpr.VernacProof (ta,Some l) ] ] - ; - hint: - [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; - tac = Pltac.tactic -> - Hints.HintsExtern (n,c, in_tac tac) ] ] - ; - operconstr: LEVEL "0" - [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> - let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in - CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, Some arg) ] ] - ; - END - -open Stdarg -open Tacarg -open Vernacexpr -open Vernac_classifier -open Goptions -open Libnames - -let print_info_trace = ref None - -let _ = declare_int_option { - optdepr = false; - optname = "print info trace"; - optkey = ["Info" ; "Level"]; - optread = (fun () -> !print_info_trace); - optwrite = fun n -> print_info_trace := n; -} - -let vernac_solve n info tcom b = - let open Goal_select in - let status = Proof_global.with_current_proof (fun etac p -> - let with_end_tac = if b then Some etac else None in - let global = match n with SelectAll | SelectList _ -> true | _ -> false in - let info = Option.append info !print_info_trace in - let (p,status) = - Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p - in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p,status) in - if not status then Feedback.feedback Feedback.AddedAxiom - -let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s - -VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector -| [ toplevel_selector(s) ] -> [ s ] -END - -let pr_ltac_info n = str "Info" ++ spc () ++ int n - -VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info -| [ "Info" natural(n) ] -> [ n ] -END - -let pr_ltac_use_default b = - if b then (* Bug: a space is inserted before "..." *) str ".." else mt () - -VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default -| [ "." ] -> [ false ] -| [ "..." ] -> [ true ] -END - -let is_anonymous_abstract = function - | TacAbstract (_,None) -> true - | TacSolve [TacAbstract (_,None)] -> true - | _ -> false -let rm_abstract = function - | TacAbstract (t,_) -> t - | TacSolve [TacAbstract (t,_)] -> TacSolve [t] - | x -> x -let is_explicit_terminator = function TacSolve _ -> true | _ -> false - -VERNAC tactic_mode EXTEND VernacSolve -| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ classify_as_proofstep ] -> [ - let g = Option.default (Goal_select.get_default_goal_selector ()) g in - vernac_solve g n t def - ] -| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ - let anon_abstracting_tac = is_anonymous_abstract t in - let solving_tac = is_explicit_terminator t in - let parallel = `Yes (solving_tac,anon_abstracting_tac) in - let pbr = if solving_tac then Some "par" else None in - VtProofStep{ parallel = parallel; proof_block_detection = pbr }, - VtLater - ] -> [ - let t = rm_abstract t in - vernac_solve Goal_select.SelectAll n t def - ] -END - -let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" - -VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level -| [ "(" "at" "level" natural(n) ")" ] -> [ n ] -END - -VERNAC ARGUMENT EXTEND ltac_production_sep -| [ "," string(sep) ] -> [ sep ] -END - -let pr_ltac_production_item = function -| Tacentries.TacTerm s -> quote (str s) -| Tacentries.TacNonTerm (_, ((arg, None), None)) -> str arg -| Tacentries.TacNonTerm (_, ((arg, Some _), None)) -> assert false -| Tacentries.TacNonTerm (_, ((arg, sep), Some id)) -> - let sep = match sep with - | None -> mt () - | Some sep -> str "," ++ spc () ++ quote (str sep) - in - str arg ++ str "(" ++ Id.print id ++ sep ++ str ")" - -VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item -| [ string(s) ] -> [ Tacentries.TacTerm s ] -| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> - [ Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, sep), Some p)) ] -| [ ident(nt) ] -> - [ Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, None), None)) ] -END - -VERNAC COMMAND FUNCTIONAL EXTEND VernacTacticNotation -| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => - [ VtSideff [], VtNow ] -> - [ fun ~atts ~st -> let open Vernacinterp in - let n = Option.default 0 n in - let deprecation = atts.deprecated in - Tacentries.add_tactic_notation (Locality.make_module_locality atts.locality) n ?deprecation r e; - st - ] -END - -VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY -| [ "Print" "Ltac" reference(r) ] -> - [ Feedback.msg_notice (Tacintern.print_ltac r) ] -END - -VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY -| [ "Locate" "Ltac" reference(r) ] -> - [ Tacentries.print_located_tactic r ] -END - -let pr_ltac_ref = Libnames.pr_qualid - -let pr_tacdef_body tacdef_body = - let id, redef, body = - match tacdef_body with - | TacticDefinition ({CAst.v=id}, body) -> Id.print id, false, body - | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body - in - let idl, body = - match body with - | Tacexpr.TacFun (idl,b) -> idl,b - | _ -> [], body in - id ++ - prlist (function Name.Anonymous -> str " _" - | Name.Name id -> spc () ++ Id.print id) idl - ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) - ++ Pptactic.pr_raw_tactic body - -VERNAC ARGUMENT EXTEND ltac_tacdef_body -PRINTED BY pr_tacdef_body -| [ tacdef_body(t) ] -> [ t ] -END - -VERNAC COMMAND FUNCTIONAL EXTEND VernacDeclareTacticDefinition -| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ - VtSideff (List.map (function - | TacticDefinition ({CAst.v=r},_) -> r - | TacticRedefinition (qid,_) -> qualid_basename qid) l), VtLater - ] -> [ fun ~atts ~st -> let open Vernacinterp in - let deprecation = atts.deprecated in - Tacentries.register_ltac (Locality.make_module_locality atts.locality) ?deprecation l; - st - ] -END - -VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY -| [ "Print" "Ltac" "Signatures" ] -> [ Tacentries.print_ltacs () ] -END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg new file mode 100644 index 0000000000..7eb34158e8 --- /dev/null +++ b/plugins/ltac/g_ltac.mlg @@ -0,0 +1,553 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +DECLARE PLUGIN "ltac_plugin" + +{ + +open Util +open Pp +open Glob_term +open Constrexpr +open Tacexpr +open Namegen +open Genarg +open Genredexpr +open Tok (* necessary for camlp5 *) +open Names +open Attributes + +open Pcoq +open Pcoq.Prim +open Pcoq.Constr +open Pvernac.Vernac_ +open Pltac + +let fail_default_value = Locus.ArgArg 0 + +let arg_of_expr = function + TacArg { CAst.v } -> v + | e -> Tacexp (e:raw_tactic_expr) + +let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () +let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n +let genarg_of_ipattern pat = in_gen (rawwit Tacarg.wit_intro_pattern) pat +let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c +let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac + +let reference_to_id qid = + if Libnames.qualid_is_ident qid then + CAst.make ?loc:qid.CAst.loc @@ Libnames.qualid_basename qid + else + CErrors.user_err ?loc:qid.CAst.loc + (str "This expression should be a simple identifier.") + +let tactic_mode = Entry.create "vernac:tactic_command" + +let new_entry name = + let e = Entry.create name in + e + +let toplevel_selector = new_entry "vernac:toplevel_selector" +let tacdef_body = new_entry "tactic:tacdef_body" + +(* Registers [tactic_mode] as a parser for proof editing *) +let classic_proof_mode = Pvernac.register_proof_mode "Classic" tactic_mode + +(* Hack to parse "[ id" without dropping [ *) +let test_bracket_ident = + Pcoq.Entry.of_parser "test_bracket_ident" + (fun strm -> + match stream_nth 0 strm with + | KEYWORD "[" -> + (match stream_nth 1 strm with + | IDENT _ -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + +(* Tactics grammar rules *) + +let hint = G_proofs.hint + +} + +GRAMMAR EXTEND Gram + GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint + tactic_mode constr_may_eval constr_eval toplevel_selector + operconstr; + + tactic_then_last: + [ [ "|"; lta = LIST0 (OPT tactic_expr) SEP "|" -> + { Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) } + | -> { [||] } + ] ] + ; + tactic_then_gen: + [ [ ta = tactic_expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (ta::first, last) } + | ta = tactic_expr; ".."; l = tactic_then_last -> { ([], Some (ta, l)) } + | ".."; l = tactic_then_last -> { ([], Some (TacId [], l)) } + | ta = tactic_expr -> { ([ta], None) } + | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (TacId [] :: first, last) } + | -> { ([TacId []], None) } + ] ] + ; + tactic_then_locality: (* [true] for the local variant [TacThens] and [false] + for [TacExtend] *) + [ [ "[" ; l = OPT">" -> { if Option.is_empty l then true else false } ] ] + ; + tactic_expr: + [ "5" RIGHTA + [ te = binder_tactic -> { te } ] + | "4" LEFTA + [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> { TacThen (ta0, ta1) } + | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> { TacThen (ta0,ta1) } + | ta0 = tactic_expr; ";"; l = tactic_then_locality; tg = tactic_then_gen; "]" -> { + let (first,tail) = tg in + match l , tail with + | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) + | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) + | false , None -> TacThen (ta0,TacDispatch first) + | true , None -> TacThens (ta0,first) } ] + | "3" RIGHTA + [ IDENT "try"; ta = tactic_expr -> { TacTry ta } + | IDENT "do"; n = int_or_var; ta = tactic_expr -> { TacDo (n,ta) } + | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> { TacTimeout (n,ta) } + | IDENT "time"; s = OPT string; ta = tactic_expr -> { TacTime (s,ta) } + | IDENT "repeat"; ta = tactic_expr -> { TacRepeat ta } + | IDENT "progress"; ta = tactic_expr -> { TacProgress ta } + | IDENT "once"; ta = tactic_expr -> { TacOnce ta } + | IDENT "exactly_once"; ta = tactic_expr -> { TacExactlyOnce ta } + | IDENT "infoH"; ta = tactic_expr -> { TacShowHyps ta } +(*To do: put Abstract in Refiner*) + | IDENT "abstract"; tc = NEXT -> { TacAbstract (tc,None) } + | IDENT "abstract"; tc = NEXT; "using"; s = ident -> + { TacAbstract (tc,Some s) } + | sel = selector; ta = tactic_expr -> { TacSelect (sel, ta) } ] +(*End of To do*) + | "2" RIGHTA + [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> { TacOr (ta0,ta1) } + | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> { TacOr (ta0,ta1) } + | IDENT "tryif" ; ta = tactic_expr ; + "then" ; tat = tactic_expr ; + "else" ; tae = tactic_expr -> { TacIfThenCatch(ta,tat,tae) } + | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> { TacOrelse (ta0,ta1) } + | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> { TacOrelse (ta0,ta1) } ] + | "1" RIGHTA + [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> + { TacMatchGoal (b,false,mrl) } + | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; + mrl = match_context_list; "end" -> + { TacMatchGoal (b,true,mrl) } + | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> + { TacMatch (b,c,mrl) } + | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + { TacFirst l } + | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + { TacSolve l } + | IDENT "idtac"; l = LIST0 message_token -> { TacId l } + | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; + l = LIST0 message_token -> { TacFail (g,n,l) } + | st = simple_tactic -> { st } + | a = tactic_arg -> { TacArg(CAst.make ~loc a) } + | r = reference; la = LIST0 tactic_arg_compat -> + { TacArg(CAst.make ~loc @@ TacCall (CAst.make ~loc (r,la))) } ] + | "0" + [ "("; a = tactic_expr; ")" -> { a } + | "["; ">"; tg = tactic_then_gen; "]" -> { + let (tf,tail) = tg in + begin match tail with + | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) + | None -> TacDispatch tf + end } + | a = tactic_atom -> { TacArg (CAst.make ~loc a) } ] ] + ; + failkw: + [ [ IDENT "fail" -> { TacLocal } | IDENT "gfail" -> { TacGlobal } ] ] + ; + (* binder_tactic: level 5 of tactic_expr *) + binder_tactic: + [ RIGHTA + [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> + { TacFun (it,body) } + | "let"; isrec = [IDENT "rec" -> { true } | -> { false } ]; + llc = LIST1 let_clause SEP "with"; "in"; + body = tactic_expr LEVEL "5" -> { TacLetIn (isrec,llc,body) } + | IDENT "info"; tc = tactic_expr LEVEL "5" -> { TacInfo tc } ] ] + ; + (* Tactic arguments to the right of an application *) + tactic_arg_compat: + [ [ a = tactic_arg -> { a } + | c = Constr.constr -> { (match c with { CAst.v = CRef (r,None) } -> Reference r | c -> ConstrMayEval (ConstrTerm c)) } + (* Unambiguous entries: tolerated w/o "ltac:" modifier *) + | "()" -> { TacGeneric (genarg_of_unit ()) } ] ] + ; + (* Can be used as argument and at toplevel in tactic expressions. *) + tactic_arg: + [ [ c = constr_eval -> { ConstrMayEval c } + | IDENT "fresh"; l = LIST0 fresh_id -> { TacFreshId l } + | IDENT "type_term"; c=uconstr -> { TacPretype c } + | IDENT "numgoals" -> { TacNumgoals } ] ] + ; + (* If a qualid is given, use its short name. TODO: have the shortest + non ambiguous name where dots are replaced by "_"? Probably too + verbose most of the time. *) + fresh_id: + [ [ s = STRING -> { Locus.ArgArg s (*| id = ident -> Locus.ArgVar (!@loc,id)*) } + | qid = qualid -> { Locus.ArgVar (CAst.make ~loc @@ Libnames.qualid_basename qid) } ] ] + ; + constr_eval: + [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> + { ConstrEval (rtc,c) } + | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> + { ConstrContext (id,c) } + | IDENT "type"; IDENT "of"; c = Constr.constr -> + { ConstrTypeOf c } ] ] + ; + constr_may_eval: (* For extensions *) + [ [ c = constr_eval -> { c } + | c = Constr.constr -> { ConstrTerm c } ] ] + ; + tactic_atom: + [ [ n = integer -> { TacGeneric (genarg_of_int n) } + | r = reference -> { TacCall (CAst.make ~loc (r,[])) } + | "()" -> { TacGeneric (genarg_of_unit ()) } ] ] + ; + match_key: + [ [ "match" -> { Once } + | "lazymatch" -> { Select } + | "multimatch" -> { General } ] ] + ; + input_fun: + [ [ "_" -> { Name.Anonymous } + | l = ident -> { Name.Name l } ] ] + ; + let_clause: + [ [ idr = identref; ":="; te = tactic_expr -> + { (CAst.map (fun id -> Name id) idr, arg_of_expr te) } + | na = ["_" -> { CAst.make ~loc Anonymous } ]; ":="; te = tactic_expr -> + { (na, arg_of_expr te) } + | idr = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> + { (CAst.map (fun id -> Name id) idr, arg_of_expr (TacFun(args,te))) } ] ] + ; + match_pattern: + [ [ IDENT "context"; oid = OPT Constr.ident; + "["; pc = Constr.lconstr_pattern; "]" -> + { Subterm (oid, pc) } + | pc = Constr.lconstr_pattern -> { Term pc } ] ] + ; + match_hyps: + [ [ na = name; ":"; mp = match_pattern -> { Hyp (na, mp) } + | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> { Def (na, mpv, mpt) } + | na = name; ":="; mpv = match_pattern -> + { let t, ty = + match mpv with + | Term t -> (match t with + | { CAst.v = CCast (t, (CastConv ty | CastVM ty | CastNative ty)) } -> Term t, Some (Term ty) + | _ -> mpv, None) + | _ -> mpv, None + in Def (na, t, Option.default (Term (CAst.make @@ CHole (None, IntroAnonymous, None))) ty) } + ] ] + ; + match_context_rule: + [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "=>"; te = tactic_expr -> { Pat (largs, mp, te) } + | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "]"; "=>"; te = tactic_expr -> { Pat (largs, mp, te) } + | "_"; "=>"; te = tactic_expr -> { All te } ] ] + ; + match_context_list: + [ [ mrl = LIST1 match_context_rule SEP "|" -> { mrl } + | "|"; mrl = LIST1 match_context_rule SEP "|" -> { mrl } ] ] + ; + match_rule: + [ [ mp = match_pattern; "=>"; te = tactic_expr -> { Pat ([],mp,te) } + | "_"; "=>"; te = tactic_expr -> { All te } ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> { mrl } + | "|"; mrl = LIST1 match_rule SEP "|" -> { mrl } ] ] + ; + message_token: + [ [ id = identref -> { MsgIdent id } + | s = STRING -> { MsgString s } + | n = integer -> { MsgInt n } ] ] + ; + + ltac_def_kind: + [ [ ":=" -> { false } + | "::=" -> { true } ] ] + ; + + (* Definitions for tactics *) + tacdef_body: + [ [ name = Constr.global; it=LIST1 input_fun; + redef = ltac_def_kind; body = tactic_expr -> + { if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) + else + let id = reference_to_id name in + Tacexpr.TacticDefinition (id, TacFun (it, body)) } + | name = Constr.global; redef = ltac_def_kind; + body = tactic_expr -> + { if redef then Tacexpr.TacticRedefinition (name, body) + else + let id = reference_to_id name in + Tacexpr.TacticDefinition (id, body) } + ] ] + ; + tactic: + [ [ tac = tactic_expr -> { tac } ] ] + ; + + range_selector: + [ [ n = natural ; "-" ; m = natural -> { (n, m) } + | n = natural -> { (n, n) } ] ] + ; + (* We unfold a range selectors list once so that we can make a special case + * for a unique SelectNth selector. *) + range_selector_or_nth: + [ [ n = natural ; "-" ; m = natural; + l = OPT [","; l = LIST1 range_selector SEP "," -> { l } ] -> + { Goal_select.SelectList ((n, m) :: Option.default [] l) } + | n = natural; + l = OPT [","; l = LIST1 range_selector SEP "," -> { l } ] -> + { let open Goal_select in + Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l } ] ] + ; + selector_body: + [ [ l = range_selector_or_nth -> { l } + | test_bracket_ident; "["; id = ident; "]" -> { Goal_select.SelectId id } ] ] + ; + selector: + [ [ IDENT "only"; sel = selector_body; ":" -> { sel } ] ] + ; + toplevel_selector: + [ [ sel = selector_body; ":" -> { sel } + | "!"; ":" -> { Goal_select.SelectAlreadyFocused } + | IDENT "all"; ":" -> { Goal_select.SelectAll } ] ] + ; + tactic_mode: + [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> { tac g } + | g = OPT toplevel_selector; "{" -> { Vernacexpr.VernacSubproof g } ] ] + ; + command: + [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; + l = OPT [ "using"; l = G_vernac.section_subset_expr -> { l } ] -> + { Vernacexpr.VernacProof (Some (in_tac ta), l) } + | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; + ta = OPT [ "with"; ta = Pltac.tactic -> { in_tac ta } ] -> + { Vernacexpr.VernacProof (ta,Some l) } ] ] + ; + hint: + [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; + tac = Pltac.tactic -> + { Hints.HintsExtern (n,c, in_tac tac) } ] ] + ; + operconstr: LEVEL "0" + [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> + { let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in + CAst.make ~loc @@ CHole (None, IntroAnonymous, Some arg) } ] ] + ; + END + +{ + +open Stdarg +open Tacarg +open Vernacextend +open Goptions +open Libnames + +let print_info_trace = ref None + +let () = declare_int_option { + optdepr = false; + optname = "print info trace"; + optkey = ["Info" ; "Level"]; + optread = (fun () -> !print_info_trace); + optwrite = fun n -> print_info_trace := n; +} + +let vernac_solve ~pstate n info tcom b = + let open Goal_select in + let pstate, status = Proof_global.with_current_proof (fun etac p -> + let with_end_tac = if b then Some etac else None in + let global = match n with SelectAll | SelectList _ -> true | _ -> false in + let info = Option.append info !print_info_trace in + let (p,status) = + Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) pstate in + if not status then Feedback.feedback Feedback.AddedAxiom; + Some pstate + +let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s + +} + +VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY { pr_ltac_selector } +| [ toplevel_selector(s) ] -> { s } +END + +{ + +let pr_ltac_info n = str "Info" ++ spc () ++ int n + +} + +VERNAC ARGUMENT EXTEND ltac_info PRINTED BY { pr_ltac_info } +| [ "Info" natural(n) ] -> { n } +END + +{ + +let pr_ltac_use_default b = + if b then (* Bug: a space is inserted before "..." *) str ".." else mt () + +} + +VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY { pr_ltac_use_default } +| [ "." ] -> { false } +| [ "..." ] -> { true } +END + +{ + +let is_anonymous_abstract = function + | TacAbstract (_,None) -> true + | TacSolve [TacAbstract (_,None)] -> true + | _ -> false +let rm_abstract = function + | TacAbstract (t,_) -> t + | TacSolve [TacAbstract (t,_)] -> TacSolve [t] + | x -> x +let is_explicit_terminator = function TacSolve _ -> true | _ -> false + +} + +VERNAC { tactic_mode } EXTEND VernacSolve +| ![ proof ] [ ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + { classify_as_proofstep } -> { + let g = Option.default (Goal_select.get_default_goal_selector ()) g in + Vernacentries.vernac_require_open_proof vernac_solve g n t def + } +| ![ proof ] [ "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + { + let anon_abstracting_tac = is_anonymous_abstract t in + let solving_tac = is_explicit_terminator t in + let parallel = `Yes (solving_tac,anon_abstracting_tac) in + let pbr = if solving_tac then Some "par" else None in + VtProofStep{ parallel = parallel; proof_block_detection = pbr }, + VtLater + } -> { + let t = rm_abstract t in + Vernacentries.vernac_require_open_proof vernac_solve Goal_select.SelectAll n t def + } +END + +{ + +let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" + +} + +VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY { pr_ltac_tactic_level } +| [ "(" "at" "level" natural(n) ")" ] -> { n } +END + +VERNAC ARGUMENT EXTEND ltac_production_sep +| [ "," string(sep) ] -> { sep } +END + +{ + +let pr_ltac_production_item = function +| Tacentries.TacTerm s -> quote (str s) +| Tacentries.TacNonTerm (_, ((arg, None), None)) -> str arg +| Tacentries.TacNonTerm (_, ((arg, Some _), None)) -> assert false +| Tacentries.TacNonTerm (_, ((arg, sep), Some id)) -> + let sep = match sep with + | None -> mt () + | Some sep -> str "," ++ spc () ++ quote (str sep) + in + str arg ++ str "(" ++ Id.print id ++ sep ++ str ")" + +} + +VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY { pr_ltac_production_item } +| [ string(s) ] -> { Tacentries.TacTerm s } +| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> + { Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, sep), Some p)) } +| [ ident(nt) ] -> + { Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, None), None)) } +END + +VERNAC COMMAND EXTEND VernacTacticNotation +| #[ deprecation; locality; ] + [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => + { VtSideff [], VtNow } -> + { + let n = Option.default 0 n in + Tacentries.add_tactic_notation (Locality.make_module_locality locality) n ?deprecation r e; + } +END + +VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY +| [ "Print" "Ltac" reference(r) ] -> + { Feedback.msg_notice (Tacintern.print_ltac r) } +END + +VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY +| [ "Locate" "Ltac" reference(r) ] -> + { Tacentries.print_located_tactic r } +END + +{ + +let pr_ltac_ref = Libnames.pr_qualid + +let pr_tacdef_body env sigma tacdef_body = + let id, redef, body = + match tacdef_body with + | TacticDefinition ({CAst.v=id}, body) -> Id.print id, false, body + | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body + in + let idl, body = + match body with + | Tacexpr.TacFun (idl,b) -> idl,b + | _ -> [], body in + id ++ + prlist (function Name.Anonymous -> str " _" + | Name.Name id -> spc () ++ Id.print id) idl + ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) + ++ Pptactic.pr_raw_tactic env sigma body + +} + +VERNAC ARGUMENT EXTEND ltac_tacdef_body +PRINTED BY { pr_tacdef_body env sigma } +| [ tacdef_body(t) ] -> { t } +END + +VERNAC COMMAND EXTEND VernacDeclareTacticDefinition +| #[ deprecation; locality; ] [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => { + VtSideff (List.map (function + | TacticDefinition ({CAst.v=r},_) -> r + | TacticRedefinition (qid,_) -> qualid_basename qid) l), VtLater + } -> { + Tacentries.register_ltac (Locality.make_module_locality locality) ?deprecation l; + } +END + +VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY +| [ "Print" "Ltac" "Signatures" ] -> { Tacentries.print_ltacs () } +END diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.mlg index 1f56244c75..de3a9c9fa9 100644 --- a/plugins/ltac/g_obligations.ml4 +++ b/plugins/ltac/g_obligations.mlg @@ -12,6 +12,8 @@ Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) +{ + open Constrexpr open Constrexpr_ops open Stdarg @@ -22,7 +24,7 @@ let (set_default_tactic, get_default_tactic, print_default_tactic) = Tactic_option.declare_tactic_option "Program tactic" let () = - (** Delay to recover the tactic imperatively *) + (* Delay to recover the tactic imperatively *) let tac = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> snd (get_default_tactic ()) end in @@ -43,7 +45,6 @@ let with_tac f tac = * Subtac. These entries are named Subtac.<foo> *) -module Gram = Pcoq.Gram module Tactic = Pltac open Pcoq @@ -57,105 +58,114 @@ let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: withtac; withtac: - [ [ "with"; t = Tactic.tactic -> Some t - | -> None ] ] + [ [ "with"; t = Tactic.tactic -> { Some t } + | -> { None } ] ] ; Constr.closed_binder: - [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> - let typ = mkAppC (sigref !@loc, [mkLambdaC ([id], default_binder_kind, t, c)]) in - [CLocalAssum ([id], default_binder_kind, typ)] + [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> { + let typ = mkAppC (sigref loc, [mkLambdaC ([id], default_binder_kind, t, c)]) in + [CLocalAssum ([id], default_binder_kind, typ)] } ] ]; END +{ + open Obligations -let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac -let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac - -let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) - -VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl -| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> - [ obligation (num, Some name, Some t) tac ] -| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> - [ obligation (num, Some name, None) tac ] -| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> - [ obligation (num, None, Some t) tac ] -| [ "Obligation" integer(num) withtac(tac) ] -> - [ obligation (num, None, None) tac ] -| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> - [ next_obligation (Some name) tac ] -| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] +let obligation ~pstate obl tac = Some (with_tac (fun t -> Obligations.obligation ~ontop:pstate obl t) tac) +let next_obligation ~pstate obl tac = Some (with_tac (fun t -> Obligations.next_obligation ~ontop:pstate obl t) tac) + +let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]), VtLater) + +} + +VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } +| ![ proof ] [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> + { obligation (num, Some name, Some t) tac } +| ![ proof ] [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> + { obligation (num, Some name, None) tac } +| ![ proof ] [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> + { obligation (num, None, Some t) tac } +| ![ proof ] [ "Obligation" integer(num) withtac(tac) ] -> + { obligation (num, None, None) tac } +| ![ proof ] [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> + { next_obligation (Some name) tac } +| ![ proof ] [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } END VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF | [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> - [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] + { try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) } | [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> - [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] + { try_solve_obligation num None (Some (Tacinterp.interp t)) } END VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF | [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> - [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] + { try_solve_obligations (Some name) (Some (Tacinterp.interp t)) } | [ "Solve" "Obligations" "with" tactic(t) ] -> - [ try_solve_obligations None (Some (Tacinterp.interp t)) ] + { try_solve_obligations None (Some (Tacinterp.interp t)) } | [ "Solve" "Obligations" ] -> - [ try_solve_obligations None None ] + { try_solve_obligations None None } END VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF | [ "Solve" "All" "Obligations" "with" tactic(t) ] -> - [ solve_all_obligations (Some (Tacinterp.interp t)) ] + { solve_all_obligations (Some (Tacinterp.interp t)) } | [ "Solve" "All" "Obligations" ] -> - [ solve_all_obligations None ] + { solve_all_obligations None } END VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF -| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] -| [ "Admit" "Obligations" ] -> [ admit_obligations None ] +| [ "Admit" "Obligations" "of" ident(name) ] -> { admit_obligations (Some name) } +| [ "Admit" "Obligations" ] -> { admit_obligations None } END -VERNAC COMMAND FUNCTIONAL EXTEND Set_Solver CLASSIFIED AS SIDEFF -| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ - fun ~atts ~st -> begin - let open Vernacinterp in +VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF +| #[ locality = Attributes.locality; ] [ "Obligation" "Tactic" ":=" tactic(t) ] -> { set_default_tactic - (Locality.make_section_locality atts.locality) + (Locality.make_section_locality locality) (Tacintern.glob_tactic t); - st - end] + } END +{ + open Pp +} + VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY -| [ "Show" "Obligation" "Tactic" ] -> [ - Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] +| [ "Show" "Obligation" "Tactic" ] -> { + Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) } END VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY -| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] -| [ "Obligations" ] -> [ show_obligations None ] +| [ "Obligations" "of" ident(name) ] -> { show_obligations (Some name) } +| [ "Obligations" ] -> { show_obligations None } END VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY -| [ "Preterm" "of" ident(name) ] -> [ Feedback.msg_info (show_term (Some name)) ] -| [ "Preterm" ] -> [ Feedback.msg_info (show_term None) ] +| [ "Preterm" "of" ident(name) ] -> { Feedback.msg_info (show_term (Some name)) } +| [ "Preterm" ] -> { Feedback.msg_info (show_term None) } END -open Pp +{ (* Declare a printer for the content of Program tactics *) let () = - let printer _ _ _ = function + let printer env sigma _ _ _ = function | None -> mt () - | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac + | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic env sigma tac in Pptactic.declare_extra_vernac_genarg_pprule wit_withtac printer + +} diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 deleted file mode 100644 index f1634f1561..0000000000 --- a/plugins/ltac/g_rewrite.ml4 +++ /dev/null @@ -1,297 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* Syntax for rewriting with strategies *) - -open Names -open Locus -open Constrexpr -open Glob_term -open Geninterp -open Extraargs -open Tacmach -open Rewrite -open Stdarg -open Tactypes -open Pcoq.Prim -open Pcoq.Constr -open Pvernac.Vernac_ -open Pltac - -DECLARE PLUGIN "ltac_plugin" - -type constr_expr_with_bindings = constr_expr with_bindings -type glob_constr_with_bindings = Tacexpr.glob_constr_and_expr with_bindings -type glob_constr_with_bindings_sign = interp_sign * Tacexpr.glob_constr_and_expr with_bindings - -let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = - let _, env = Pfedit.get_current_context () in - Printer.pr_glob_constr_env env (fst (fst (snd ge))) -let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = - let _, env = Pfedit.get_current_context () in - Printer.pr_glob_constr_env env (fst (fst ge)) -let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge) -let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) -let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l -let subst_glob_constr_with_bindings s c = - Tacsubst.subst_glob_with_bindings s c - -ARGUMENT EXTEND glob_constr_with_bindings - PRINTED BY pr_glob_constr_with_bindings_sign - - INTERPRETED BY interp_glob_constr_with_bindings - GLOBALIZED BY glob_glob_constr_with_bindings - SUBSTITUTED BY subst_glob_constr_with_bindings - - RAW_PRINTED BY pr_constr_expr_with_bindings - GLOB_PRINTED BY pr_glob_constr_with_bindings - - [ constr_with_bindings(bl) ] -> [ bl ] -END - -type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast -type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast - -let interp_strategy ist gl s = - let sigma = project gl in - sigma, strategy_of_ast s -let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s -let subst_strategy s str = str - -let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" -let pr_raw_strategy prc prlc _ (s : raw_strategy) = - let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_qualid, prc) in - Rewrite.pr_strategy prc prr s -let pr_glob_strategy prc prlc _ (s : glob_strategy) = - let prr = Pptactic.pr_red_expr - (Ppconstr.pr_constr_expr, - Ppconstr.pr_lconstr_expr, - Pputils.pr_or_by_notation Libnames.pr_qualid, - Ppconstr.pr_constr_expr) - in - Rewrite.pr_strategy prc prr s - -ARGUMENT EXTEND rewstrategy - PRINTED BY pr_strategy - - INTERPRETED BY interp_strategy - GLOBALIZED BY glob_strategy - SUBSTITUTED BY subst_strategy - - RAW_PRINTED BY pr_raw_strategy - GLOB_PRINTED BY pr_glob_strategy - - [ glob(c) ] -> [ StratConstr (c, true) ] - | [ "<-" constr(c) ] -> [ StratConstr (c, false) ] - | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ] - | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ] - | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ] - | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ] - | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ] - | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ] - | [ "id" ] -> [ StratId ] - | [ "fail" ] -> [ StratFail ] - | [ "refl" ] -> [ StratRefl ] - | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ] - | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ] - | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ] - | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ] - | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ] - | [ "(" rewstrategy(h) ")" ] -> [ h ] - | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ] - | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ] - | [ "hints" preident(h) ] -> [ StratHints (false, h) ] - | [ "terms" constr_list(h) ] -> [ StratTerms h ] - | [ "eval" red_expr(r) ] -> [ StratEval r ] - | [ "fold" constr(c) ] -> [ StratFold c ] -END - -(* By default the strategy for "rewrite_db" is top-down *) - -let db_strat db = StratUnary (Topdown, StratHints (false, db)) -let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) - -TACTIC EXTEND rewrite_strat -| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] -| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] -| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ] -| [ "rewrite_db" preident(db) ] -> [ cl_rewrite_clause_db db None ] -END - -let clsubstitute o c = - Proofview.Goal.enter begin fun gl -> - let is_tac id = match DAst.get (fst (fst (snd c))) with GVar id' when Id.equal id' id -> true | _ -> false in - let hyps = Tacmach.New.pf_ids_of_hyps gl in - Tacticals.New.tclMAP - (fun cl -> - match cl with - | Some id when is_tac id -> Tacticals.New.tclIDTAC - | _ -> cl_rewrite_clause c o AllOccurrences cl) - (None :: List.map (fun id -> Some id) hyps) - end - -TACTIC EXTEND substitute -| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ] -END - - -(* Compatibility with old Setoids *) - -TACTIC EXTEND setoid_rewrite - [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] - -> [ cl_rewrite_clause c o AllOccurrences None ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> - [ cl_rewrite_clause c o AllOccurrences (Some id) ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> - [ cl_rewrite_clause c o (occurrences_of occ) None ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> - [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> - [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] -END - -VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ] - - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) None None ] - | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> - [ declare_relation a aeq n None None None ] -END - -VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF - [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) - "as" ident(n) ] -> - [ declare_relation a aeq n None (Some lemma2) None ] - | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ] -END - -VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF - [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ] - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] - | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation a aeq n None None (Some lemma3) ] -END - -type binders_argtype = local_binder_expr list - -let wit_binders = - (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) - -let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) - -let () = - let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in - Pptactic.declare_extra_vernac_genarg_pprule wit_binders raw_printer - -open Pcoq - -GEXTEND Gram - GLOBAL: binders; - binders: - [ [ b = Pcoq.Constr.binders -> b ] ]; -END - -VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) - "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) - "reflexivity" "proved" "by" constr(lemma1) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None None None ] -END - -VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF - [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ] -END - -VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF - [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] -END - -VERNAC COMMAND FUNCTIONAL EXTEND AddSetoid1 CLASSIFIED AS SIDEFF - [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ fun ~atts ~st -> let open Vernacinterp in - add_setoid (not (Locality.make_section_locality atts.locality)) [] a aeq t n; - st - ] - | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ fun ~atts ~st -> let open Vernacinterp in - add_setoid (not (Locality.make_section_locality atts.locality)) binders a aeq t n; - st - ] - | [ "Add" "Morphism" constr(m) ":" ident(n) ] - (* This command may or may not open a goal *) - => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ] - -> [ fun ~atts ~st -> let open Vernacinterp in - add_morphism_infer (not (Locality.make_section_locality atts.locality)) m n; - st - ] - | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] - -> [ fun ~atts ~st -> let open Vernacinterp in - add_morphism (not (Locality.make_section_locality atts.locality)) [] m s n; - st - ] - | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) - "with" "signature" lconstr(s) "as" ident(n) ] - => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] - -> [ fun ~atts ~st -> let open Vernacinterp in - add_morphism (not (Locality.make_section_locality atts.locality)) binders m s n; - st - ] -END - -TACTIC EXTEND setoid_symmetry - [ "setoid_symmetry" ] -> [ setoid_symmetry ] - | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] -END - -TACTIC EXTEND setoid_reflexivity -[ "setoid_reflexivity" ] -> [ setoid_reflexivity ] -END - -TACTIC EXTEND setoid_transitivity - [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] -| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] -END - -VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY - [ "Print" "Rewrite" "HintDb" preident(s) ] -> - [ let sigma, env = Pfedit.get_current_context () in - Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s) ] -END diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg new file mode 100644 index 0000000000..469551809c --- /dev/null +++ b/plugins/ltac/g_rewrite.mlg @@ -0,0 +1,321 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Syntax for rewriting with strategies *) + +{ + +open Names +open Locus +open Constrexpr +open Glob_term +open Genintern +open Geninterp +open Extraargs +open Tacmach +open Rewrite +open Stdarg +open Tactypes +open Pcoq.Prim +open Pcoq.Constr +open Pvernac.Vernac_ +open Pltac +open Vernacextend + +let wit_hyp = wit_var + +} + +DECLARE PLUGIN "ltac_plugin" + +{ + +type constr_expr_with_bindings = constr_expr with_bindings +type glob_constr_with_bindings = glob_constr_and_expr with_bindings +type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings + +let pr_glob_constr_with_bindings_sign env sigma _ _ _ (ge : glob_constr_with_bindings_sign) = + Printer.pr_glob_constr_env env (fst (fst (snd ge))) +let pr_glob_constr_with_bindings env sigma _ _ _ (ge : glob_constr_with_bindings) = + Printer.pr_glob_constr_env env (fst (fst ge)) +let pr_constr_expr_with_bindings env sigma prc _ _ (ge : constr_expr_with_bindings) = prc env sigma (fst ge) +let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) +let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l +let subst_glob_constr_with_bindings s c = + Tacsubst.subst_glob_with_bindings s c + +} + +ARGUMENT EXTEND glob_constr_with_bindings + PRINTED BY { pr_glob_constr_with_bindings_sign env sigma } + + INTERPRETED BY { interp_glob_constr_with_bindings } + GLOBALIZED BY { glob_glob_constr_with_bindings } + SUBSTITUTED BY { subst_glob_constr_with_bindings } + + RAW_PRINTED BY { pr_constr_expr_with_bindings env sigma } + GLOB_PRINTED BY { pr_glob_constr_with_bindings env sigma } + +| [ constr_with_bindings(bl) ] -> { bl } +END + +{ + +type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast +type glob_strategy = (glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast + +let interp_strategy ist gl s = + let sigma = project gl in + sigma, strategy_of_ast s +let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s +let subst_strategy s str = str + +let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" +let pr_raw_strategy env sigma prc prlc _ (s : raw_strategy) = + let prr = Pptactic.pr_red_expr env sigma (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_qualid, prc) in + Rewrite.pr_strategy (prc env sigma) prr s +let pr_glob_strategy env sigma prc prlc _ (s : glob_strategy) = + let prr = Pptactic.pr_red_expr env sigma + (Ppconstr.pr_constr_expr, + Ppconstr.pr_lconstr_expr, + Pputils.pr_or_by_notation Libnames.pr_qualid, + Ppconstr.pr_constr_expr) + in + Rewrite.pr_strategy (prc env sigma) prr s + +} + +ARGUMENT EXTEND rewstrategy + PRINTED BY { pr_strategy } + + INTERPRETED BY { interp_strategy } + GLOBALIZED BY { glob_strategy } + SUBSTITUTED BY { subst_strategy } + + RAW_PRINTED BY { pr_raw_strategy env sigma } + GLOB_PRINTED BY { pr_glob_strategy env sigma } + + | [ glob(c) ] -> { StratConstr (c, true) } + | [ "<-" constr(c) ] -> { StratConstr (c, false) } + | [ "subterms" rewstrategy(h) ] -> { StratUnary (Subterms, h) } + | [ "subterm" rewstrategy(h) ] -> { StratUnary (Subterm, h) } + | [ "innermost" rewstrategy(h) ] -> { StratUnary(Innermost, h) } + | [ "outermost" rewstrategy(h) ] -> { StratUnary(Outermost, h) } + | [ "bottomup" rewstrategy(h) ] -> { StratUnary(Bottomup, h) } + | [ "topdown" rewstrategy(h) ] -> { StratUnary(Topdown, h) } + | [ "id" ] -> { StratId } + | [ "fail" ] -> { StratFail } + | [ "refl" ] -> { StratRefl } + | [ "progress" rewstrategy(h) ] -> { StratUnary (Progress, h) } + | [ "try" rewstrategy(h) ] -> { StratUnary (Try, h) } + | [ "any" rewstrategy(h) ] -> { StratUnary (Any, h) } + | [ "repeat" rewstrategy(h) ] -> { StratUnary (Repeat, h) } + | [ rewstrategy(h) ";" rewstrategy(h') ] -> { StratBinary (Compose, h, h') } + | [ "(" rewstrategy(h) ")" ] -> { h } + | [ "choice" rewstrategy(h) rewstrategy(h') ] -> { StratBinary (Choice, h, h') } + | [ "old_hints" preident(h) ] -> { StratHints (true, h) } + | [ "hints" preident(h) ] -> { StratHints (false, h) } + | [ "terms" constr_list(h) ] -> { StratTerms h } + | [ "eval" red_expr(r) ] -> { StratEval r } + | [ "fold" constr(c) ] -> { StratFold c } +END + +(* By default the strategy for "rewrite_db" is top-down *) + +{ + +let db_strat db = StratUnary (Topdown, StratHints (false, db)) +let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) + +} + +TACTIC EXTEND rewrite_strat +| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> { cl_rewrite_clause_strat s (Some id) } +| [ "rewrite_strat" rewstrategy(s) ] -> { cl_rewrite_clause_strat s None } +| [ "rewrite_db" preident(db) "in" hyp(id) ] -> { cl_rewrite_clause_db db (Some id) } +| [ "rewrite_db" preident(db) ] -> { cl_rewrite_clause_db db None } +END + +{ + +let clsubstitute o c = + Proofview.Goal.enter begin fun gl -> + let is_tac id = match DAst.get (fst (fst (snd c))) with GVar id' when Id.equal id' id -> true | _ -> false in + let hyps = Tacmach.New.pf_ids_of_hyps gl in + Tacticals.New.tclMAP + (fun cl -> + match cl with + | Some id when is_tac id -> Tacticals.New.tclIDTAC + | _ -> cl_rewrite_clause c o AllOccurrences cl) + (None :: List.map (fun id -> Some id) hyps) + end + +} + +TACTIC EXTEND substitute +| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> { clsubstitute o c } +END + + +(* Compatibility with old Setoids *) + +TACTIC EXTEND setoid_rewrite + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] + -> { cl_rewrite_clause c o AllOccurrences None } + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> + { cl_rewrite_clause c o AllOccurrences (Some id) } + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> + { cl_rewrite_clause c o (occurrences_of occ) None } + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> + { cl_rewrite_clause c o (occurrences_of occ) (Some id) } + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> + { cl_rewrite_clause c o (occurrences_of occ) (Some id) } +END + +VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> + { declare_relation atts a aeq n (Some lemma1) (Some lemma2) None } + + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "as" ident(n) ] -> + { declare_relation atts a aeq n (Some lemma1) None None } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + { declare_relation atts a aeq n None None None } +END + +VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + "as" ident(n) ] -> + { declare_relation atts a aeq n None (Some lemma2) None } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + { declare_relation atts a aeq n None (Some lemma2) (Some lemma3) } +END + +VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + { declare_relation atts a aeq n (Some lemma1) None (Some lemma3) } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + { declare_relation atts a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + { declare_relation atts a aeq n None None (Some lemma3) } +END + +{ + +type binders_argtype = local_binder_expr list + +let wit_binders = + (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) + +let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) + +let () = + let raw_printer env sigma _ _ _ l = Pp.pr_non_empty_arg (Ppconstr.pr_binders env sigma) l in + Pptactic.declare_extra_vernac_genarg_pprule wit_binders raw_printer + +} + +GRAMMAR EXTEND Gram + GLOBAL: binders; + binders: + [ [ b = Pcoq.Constr.binders -> { b } ] ]; +END + +VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) None } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + "reflexivity" "proved" "by" constr(lemma1) + "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n (Some lemma1) None None } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n None None None } +END + +VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n None (Some lemma2) None } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n None (Some lemma2) (Some lemma3) } +END + +VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n (Some lemma1) None (Some lemma3) } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n None None (Some lemma3) } +END + +VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + { + add_setoid atts [] a aeq t n + } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + { + add_setoid atts binders a aeq t n + } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) ":" ident(n) ] + (* This command may or may not open a goal *) + => { VtUnknown, VtNow } + -> { + add_morphism_infer atts m n + } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] + => { VtStartProof(GuaranteesOpacity,[n]), VtLater } + -> { + add_morphism atts [] m s n + } + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) + "with" "signature" lconstr(s) "as" ident(n) ] + => { VtStartProof(GuaranteesOpacity,[n]), VtLater } + -> { + add_morphism atts binders m s n + } +END + +TACTIC EXTEND setoid_symmetry + | [ "setoid_symmetry" ] -> { setoid_symmetry } + | [ "setoid_symmetry" "in" hyp(n) ] -> { setoid_symmetry_in n } +END + +TACTIC EXTEND setoid_reflexivity +| [ "setoid_reflexivity" ] -> { setoid_reflexivity } +END + +TACTIC EXTEND setoid_transitivity +| [ "setoid_transitivity" constr(t) ] -> { setoid_transitivity (Some t) } +| [ "setoid_etransitivity" ] -> { setoid_transitivity None } +END + +VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY +| ![ proof ] [ "Print" "Rewrite" "HintDb" preident(s) ] -> + { (* This command should not use the proof env, keeping previous + behavior as requested in review. *) + fun ~pstate -> + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in + Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s); + pstate } +END diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 571595be70..7bf705ffeb 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -39,7 +39,7 @@ let err () = raise Stream.Failure (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) (* admissible notation "(x t)" *) let test_lpar_id_coloneq = - Gram.Entry.of_parser "lpar_id_coloneq" + Pcoq.Entry.of_parser "lpar_id_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -53,7 +53,7 @@ let test_lpar_id_coloneq = (* Hack to recognize "(x)" *) let test_lpar_id_rpar = - Gram.Entry.of_parser "lpar_id_coloneq" + Pcoq.Entry.of_parser "lpar_id_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -67,7 +67,7 @@ let test_lpar_id_rpar = (* idem for (x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = - Gram.Entry.of_parser "test_lpar_idnum_coloneq" + Pcoq.Entry.of_parser "test_lpar_idnum_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -84,7 +84,7 @@ open Extraargs (* idem for (x1..xn:t) [n^2 complexity but exceptional use] *) let check_for_coloneq = - Gram.Entry.of_parser "lpar_id_colon" + Pcoq.Entry.of_parser "lpar_id_colon" (fun strm -> let rec skip_to_rpar p n = match List.last (Stream.npeek n strm) with @@ -108,7 +108,7 @@ let check_for_coloneq = | _ -> err ()) let lookup_at_as_comma = - Gram.Entry.of_parser "lookup_at_as_comma" + Pcoq.Entry.of_parser "lookup_at_as_comma" (fun strm -> match stream_nth 0 strm with | KEYWORD (","|"at"|"as") -> () @@ -287,10 +287,10 @@ GRAMMAR EXTEND Gram [ [ c = smart_global; nl = occs -> { (nl,c) } ] ] ; intropatterns: - [ [ l = LIST0 nonsimple_intropattern -> { l } ] ] + [ [ l = LIST0 intropattern -> { l } ] ] ; ne_intropatterns: - [ [ l = LIST1 nonsimple_intropattern -> { l } ] ] + [ [ l = LIST1 intropattern -> { l } ] ] ; or_and_intropattern: [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> { IntroOrPattern tc } @@ -317,7 +317,7 @@ GRAMMAR EXTEND Gram | "?" -> { IntroAnonymous } | id = ident -> { IntroIdentifier id } ] ] ; - nonsimple_intropattern: + intropattern: [ [ l = simple_intropattern -> { l } | "*" -> { CAst.make ~loc @@ IntroForthcoming true } | "**" -> { CAst.make ~loc @@ IntroForthcoming false } ] ] @@ -529,178 +529,180 @@ GRAMMAR EXTEND Gram [ [ (* Basic tactics *) IDENT "intros"; pl = ne_intropatterns -> - { TacAtom (Loc.tag ~loc @@ TacIntroPattern (false,pl)) } + { TacAtom (CAst.make ~loc @@ TacIntroPattern (false,pl)) } | IDENT "intros" -> - { TacAtom (Loc.tag ~loc @@ TacIntroPattern (false,[CAst.make ~loc @@IntroForthcoming false])) } + { TacAtom (CAst.make ~loc @@ TacIntroPattern (false,[CAst.make ~loc @@IntroForthcoming false])) } | IDENT "eintros"; pl = ne_intropatterns -> - { TacAtom (Loc.tag ~loc @@ TacIntroPattern (true,pl)) } + { TacAtom (CAst.make ~loc @@ TacIntroPattern (true,pl)) } + | IDENT "eintros" -> + { TacAtom (CAst.make ~loc @@ TacIntroPattern (true,[CAst.make ~loc @@IntroForthcoming false])) } | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (true,false,cl,inhyp)) } + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (true,false,cl,inhyp)) } | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (true,true,cl,inhyp)) } + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (true,true,cl,inhyp)) } | IDENT "simple"; IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (false,false,cl,inhyp)) } + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (false,false,cl,inhyp)) } | IDENT "simple"; IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP","; - inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (false,true,cl,inhyp)) } + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (false,true,cl,inhyp)) } | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - { TacAtom (Loc.tag ~loc @@ TacElim (false,cl,el)) } + { TacAtom (CAst.make ~loc @@ TacElim (false,cl,el)) } | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - { TacAtom (Loc.tag ~loc @@ TacElim (true,cl,el)) } - | IDENT "case"; icl = induction_clause_list -> { TacAtom (Loc.tag ~loc @@ mkTacCase false icl) } - | IDENT "ecase"; icl = induction_clause_list -> { TacAtom (Loc.tag ~loc @@ mkTacCase true icl) } + { TacAtom (CAst.make ~loc @@ TacElim (true,cl,el)) } + | IDENT "case"; icl = induction_clause_list -> { TacAtom (CAst.make ~loc @@ mkTacCase false icl) } + | IDENT "ecase"; icl = induction_clause_list -> { TacAtom (CAst.make ~loc @@ mkTacCase true icl) } | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> - { TacAtom (Loc.tag ~loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) } + { TacAtom (CAst.make ~loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) } | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> - { TacAtom (Loc.tag ~loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) } + { TacAtom (CAst.make ~loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) } | IDENT "pose"; bl = bindings_with_parameters -> - { let (id,b) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (false,Names.Name.Name id,b,Locusops.nowhere,true,None)) } + { let (id,b) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (false,Names.Name.Name id,b,Locusops.nowhere,true,None)) } | IDENT "pose"; b = constr; na = as_name -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) } | IDENT "epose"; bl = bindings_with_parameters -> - { let (id,b) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) } + { let (id,b) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) } | IDENT "epose"; b = constr; na = as_name -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) } | IDENT "set"; bl = bindings_with_parameters; p = clause_dft_concl -> - { let (id,c) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (false,Names.Name.Name id,c,p,true,None)) } + { let (id,c) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (false,Names.Name.Name id,c,p,true,None)) } | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (false,na,c,p,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,c,p,true,None)) } | IDENT "eset"; bl = bindings_with_parameters; p = clause_dft_concl -> - { let (id,c) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) } + { let (id,c) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) } | IDENT "eset"; c = constr; na = as_name; p = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (true,na,c,p,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,c,p,true,None)) } | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; p = clause_dft_all -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (false,na,c,p,false,e)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,c,p,false,e)) } | IDENT "eremember"; c = constr; na = as_name; e = eqn_ipat; p = clause_dft_all -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (true,na,c,p,false,e)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,c,p,false,e)) } (* Alternative syntax for "pose proof c as id" *) | IDENT "assert"; test_lpar_id_coloneq; "("; lid = identref; ":="; c = lconstr; ")" -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eassert"; test_lpar_id_coloneq; "("; lid = identref; ":="; c = lconstr; ")" -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } (* Alternative syntax for "assert c as id by tac" *) | IDENT "assert"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (false,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eassert"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (true,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } (* Alternative syntax for "enough c as id by tac" *) | IDENT "enough"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (false,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eenough"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (true,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (Loc.tag ~loc @@ TacAssert (false,true,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (false,true,Some tac,ipat,c)) } | IDENT "eassert"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (Loc.tag ~loc @@ TacAssert (true,true,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (true,true,Some tac,ipat,c)) } | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - { TacAtom (Loc.tag ~loc @@ TacAssert (false,true,None,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (false,true,None,ipat,c)) } | IDENT "epose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - { TacAtom (Loc.tag ~loc @@ TacAssert (true,true,None,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (true,true,None,ipat,c)) } | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (Loc.tag ~loc @@ TacAssert (false,false,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (false,false,Some tac,ipat,c)) } | IDENT "eenough"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (Loc.tag ~loc @@ TacAssert (true,false,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (true,false,Some tac,ipat,c)) } | IDENT "generalize"; c = constr -> - { TacAtom (Loc.tag ~loc @@ TacGeneralize [((AllOccurrences,c),Names.Name.Anonymous)]) } + { TacAtom (CAst.make ~loc @@ TacGeneralize [((AllOccurrences,c),Names.Name.Anonymous)]) } | IDENT "generalize"; c = constr; l = LIST1 constr -> { let gen_everywhere c = ((AllOccurrences,c),Names.Name.Anonymous) in - TacAtom (Loc.tag ~loc @@ TacGeneralize (List.map gen_everywhere (c::l))) } + TacAtom (CAst.make ~loc @@ TacGeneralize (List.map gen_everywhere (c::l))) } | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs; na = as_name; l = LIST0 [","; c = pattern_occ; na = as_name -> { (c,na) } ] -> - { TacAtom (Loc.tag ~loc @@ TacGeneralize (((nl,c),na)::l)) } + { TacAtom (CAst.make ~loc @@ TacGeneralize (((nl,c),na)::l)) } (* Derived basic tactics *) | IDENT "induction"; ic = induction_clause_list -> - { TacAtom (Loc.tag ~loc @@ TacInductionDestruct (true,false,ic)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct (true,false,ic)) } | IDENT "einduction"; ic = induction_clause_list -> - { TacAtom (Loc.tag ~loc @@ TacInductionDestruct(true,true,ic)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(true,true,ic)) } | IDENT "destruct"; icl = induction_clause_list -> - { TacAtom (Loc.tag ~loc @@ TacInductionDestruct(false,false,icl)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(false,false,icl)) } | IDENT "edestruct"; icl = induction_clause_list -> - { TacAtom (Loc.tag ~loc @@ TacInductionDestruct(false,true,icl)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(false,true,icl)) } (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> { TacAtom (Loc.tag ~loc @@ TacRewrite (false,l,cl,t)) } + cl = clause_dft_concl; t=by_tactic -> { TacAtom (CAst.make ~loc @@ TacRewrite (false,l,cl,t)) } | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> { TacAtom (Loc.tag ~loc @@ TacRewrite (true,l,cl,t)) } + cl = clause_dft_concl; t=by_tactic -> { TacAtom (CAst.make ~loc @@ TacRewrite (true,l,cl,t)) } | IDENT "dependent"; k = [ IDENT "simple"; IDENT "inversion" -> { SimpleInversion } | IDENT "inversion" -> { FullInversion } | IDENT "inversion_clear" -> { FullInversionClear } ]; hyp = quantified_hypothesis; ids = as_or_and_ipat; co = OPT ["with"; c = constr -> { c } ] -> - { TacAtom (Loc.tag ~loc @@ TacInversion (DepInversion (k,co,ids),hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (DepInversion (k,co,ids),hyp)) } | IDENT "simple"; IDENT "inversion"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - { TacAtom (Loc.tag ~loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) } | IDENT "inversion"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - { TacAtom (Loc.tag ~loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) } | IDENT "inversion_clear"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - { TacAtom (Loc.tag ~loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) } | IDENT "inversion"; hyp = quantified_hypothesis; "using"; c = constr; cl = in_hyp_list -> - { TacAtom (Loc.tag ~loc @@ TacInversion (InversionUsing (c,cl), hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (InversionUsing (c,cl), hyp)) } (* Conversion *) | IDENT "red"; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Red false, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Red false, cl)) } | IDENT "hnf"; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Hnf, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Hnf, cl)) } | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Simpl (all_with d, po), cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Simpl (all_with d, po), cl)) } | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Cbv s, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Cbv s, cl)) } | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Cbn s, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Cbn s, cl)) } | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Lazy s, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Lazy s, cl)) } | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Cbv (all_with delta), cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Cbv (all_with delta), cl)) } | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (CbvVm po, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (CbvVm po, cl)) } | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (CbvNative po, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (CbvNative po, cl)) } | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Unfold ul, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Unfold ul, cl)) } | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Fold l, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Fold l, cl)) } | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Pattern pl, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Pattern pl, cl)) } (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) | IDENT "change"; c = conversion; cl = clause_dft_concl -> { let (oc, c) = c in let p,cl = merge_occurrences loc cl oc in - TacAtom (Loc.tag ~loc @@ TacChange (p,c,cl)) } + TacAtom (CAst.make ~loc @@ TacChange (p,c,cl)) } ] ] ; END diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index ec96e1bbdd..e83eab20dc 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -7,10 +7,10 @@ Pltac Taccoerce Tactic_debug Tacintern -Tacentries Profile_ltac Tactic_matching Tacinterp +Tacentries Evar_tactics Tactic_option Extraargs diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index b219ee25ca..80070a7493 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -22,10 +22,11 @@ open Tactypes open Locus open Decl_kinds open Genredexpr -open Pputils open Ppconstr +open Pputils open Printer +open Genintern open Tacexpr open Tacarg open Tactics @@ -70,40 +71,46 @@ let declare_notation_tactic_pprule kn pt = prnotation_tab := KNmap.add kn pt !prnotation_tab type 'a raw_extra_genarg_printer = - (constr_expr -> Pp.t) -> - (constr_expr -> Pp.t) -> - (tolerability -> raw_tactic_expr -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> Pp.t) -> - (glob_constr_and_expr -> Pp.t) -> - (tolerability -> glob_tactic_expr -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> glob_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a extra_genarg_printer = - (EConstr.constr -> Pp.t) -> - (EConstr.constr -> Pp.t) -> - (tolerability -> Val.t -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> Val.t -> Pp.t) -> + 'a -> Pp.t type 'a raw_extra_genarg_printer_with_level = - (constr_expr -> Pp.t) -> - (constr_expr -> Pp.t) -> - (tolerability -> raw_tactic_expr -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t type 'a glob_extra_genarg_printer_with_level = - (glob_constr_and_expr -> Pp.t) -> - (glob_constr_and_expr -> Pp.t) -> - (tolerability -> glob_tactic_expr -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> glob_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t type 'a extra_genarg_printer_with_level = - (EConstr.constr -> Pp.t) -> - (EConstr.constr -> Pp.t) -> - (tolerability -> Val.t -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> Val.t -> Pp.t) -> + tolerability -> 'a -> Pp.t let string_of_genarg_arg (ArgumentType arg) = let rec aux : type a b c. (a, b, c) genarg_type -> string = function @@ -158,39 +165,33 @@ let string_of_genarg_arg (ArgumentType arg) = end | _ -> default - let pr_with_occurrences pr c = pr_with_occurrences pr keyword c - let pr_red_expr pr c = pr_red_expr pr keyword c + let pr_with_occurrences pr c = Ppred.pr_with_occurrences pr keyword c + let pr_red_expr env sigma pr c = Ppred.pr_red_expr_env env sigma pr keyword c - let pr_may_eval test prc prlc pr2 pr3 = function + let pr_may_eval env sigma test prc prlc pr2 pr3 = function | ConstrEval (r,c) -> hov 0 (keyword "eval" ++ brk (1,1) ++ - pr_red_expr (prc,prlc,pr2,pr3) r ++ spc () ++ - keyword "in" ++ spc() ++ prc c) + pr_red_expr env sigma (prc,prlc,pr2,pr3) r ++ spc () ++ + keyword "in" ++ spc() ++ prc env sigma c) | ConstrContext ({CAst.v=id},c) -> hov 0 (keyword "context" ++ spc () ++ pr_id id ++ spc () ++ - str "[ " ++ prlc c ++ str " ]") + str "[ " ++ prlc env sigma c ++ str " ]") | ConstrTypeOf c -> - hov 1 (keyword "type of" ++ spc() ++ prc c) + hov 1 (keyword "type of" ++ spc() ++ prc env sigma c) | ConstrTerm c when test c -> - h 0 (str "(" ++ prc c ++ str ")") + h 0 (str "(" ++ prc env sigma c ++ str ")") | ConstrTerm c -> - prc c + prc env sigma c - let pr_may_eval a = - pr_may_eval (fun _ -> false) a + let pr_may_eval env sigma a = + pr_may_eval env sigma (fun _ -> false) a let pr_arg pr x = spc () ++ pr x let pr_and_short_name pr (c,_) = pr c - let pr_or_by_notation f = CAst.with_val (function - | AN v -> f v - | ByNotation (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc) - - let pr_located pr (_,x) = pr x - let pr_evaluable_reference = function | EvalVarRef id -> pr_id id | EvalConstRef sp -> pr_global (Globnames.ConstRef sp) @@ -234,8 +235,8 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_tacarg_using_rule pr_gen l = let l = match l with | TacTerm s :: l -> - (** First terminal token should be considered as the name of the tactic, - so we tag it differently than the other terminal tokens. *) + (* First terminal token should be considered as the name of the tactic, + so we tag it differently than the other terminal tokens. *) primitive s :: tacarg_using_rule_token pr_gen l | _ -> tacarg_using_rule_token pr_gen l in @@ -294,7 +295,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr _ = str "_" in KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)" - let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.tag arg)) + let pr_farg prtac arg = prtac (1, Any) (TacArg (CAst.make arg)) let is_genarg tag wit = let ArgT.Any tag = tag in @@ -350,9 +351,9 @@ let string_of_genarg_arg (ArgumentType arg) = pr_extend_gen (pr_farg prtac) let pr_raw_alias prtac lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.tag a)))) lev key args + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (CAst.make a)))) lev key args let pr_glob_alias prtac lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.tag a)))) lev key args + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (CAst.make a)))) lev key args (**********************************************************************) (* The tactic printer *) @@ -579,7 +580,7 @@ let pr_goal_selector ~toplevel s = pr_gen arg else str name ++ str ":" ++ surround (pr_gen arg) - | _ -> pr_arg (TacArg (Loc.tag t)) in + | _ -> pr_arg (TacArg (CAst.make t)) in hov 0 (keyword k ++ spc () ++ pr_lname na ++ prlist pr_funvar bl ++ str " :=" ++ brk (1,1) ++ pr t) @@ -652,15 +653,15 @@ let pr_goal_selector ~toplevel s = type 'a printer = { pr_tactic : tolerability -> 'tacexpr -> Pp.t; - pr_constr : 'trm -> Pp.t; - pr_lconstr : 'trm -> Pp.t; - pr_dconstr : 'dtrm -> Pp.t; - pr_pattern : 'pat -> Pp.t; - pr_lpattern : 'pat -> Pp.t; + pr_constr : Environ.env -> Evd.evar_map -> 'trm -> Pp.t; + pr_lconstr : Environ.env -> Evd.evar_map -> 'trm -> Pp.t; + pr_dconstr : Environ.env -> Evd.evar_map -> 'dtrm -> Pp.t; + pr_pattern : Environ.env -> Evd.evar_map -> 'pat -> Pp.t; + pr_lpattern : Environ.env -> Evd.evar_map -> 'pat -> Pp.t; pr_constant : 'cst -> Pp.t; pr_reference : 'ref -> Pp.t; pr_name : 'nam -> Pp.t; - pr_generic : 'lev generic_argument -> Pp.t; + pr_generic : Environ.env -> Evd.evar_map -> 'lev generic_argument -> Pp.t; pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> Pp.t; pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> Pp.t; } @@ -676,14 +677,14 @@ let pr_goal_selector ~toplevel s = level :'lev > - let pr_atom pr strip_prod_binders tag_atom = - let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in + let pr_atom env sigma pr strip_prod_binders tag_atom = + let pr_with_bindings = pr_with_bindings (pr.pr_constr env sigma) (pr.pr_lconstr env sigma) in let pr_with_bindings_arg_full = pr_with_bindings_arg in - let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in - let pr_red_expr = pr_red_expr (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in + let pr_with_bindings_arg = pr_with_bindings_arg (pr.pr_constr env sigma) (pr.pr_lconstr env sigma) in + let pr_red_expr = pr_red_expr env sigma (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in - let _pr_constrarg c = spc () ++ pr.pr_constr c in - let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in + let _pr_constrarg c = spc () ++ pr.pr_constr env sigma c in + let pr_lconstrarg c = spc () ++ pr.pr_lconstr env sigma c in let pr_intarg n = spc () ++ int n in (* Some printing combinators *) @@ -693,7 +694,7 @@ let pr_goal_selector ~toplevel s = (* match t with | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal | _ ->*) - let s = prlist_with_sep spc Ppconstr.pr_lname nal ++ str ":" ++ pr.pr_lconstr t in + let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr env sigma t in spc() ++ hov 1 (str"(" ++ s ++ str")") in let pr_fix_tac (id,n,c) = @@ -728,7 +729,7 @@ let pr_goal_selector ~toplevel s = in hov 1 (str"(" ++ pr_id id ++ prlist pr_binder_fix bll ++ annot ++ str" :" ++ - pr_lconstrarg ty ++ str")") in + (pr_lconstrarg ty) ++ str")") in (* spc() ++ hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ _pr_constrarg c) @@ -752,13 +753,13 @@ let pr_goal_selector ~toplevel s = hov 1 (primitive (if ev then "eintros" else "intros") ++ (match p with | [{CAst.v=IntroForthcoming false}] -> mt () - | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)) + | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern @@ pr.pr_dconstr env sigma) p)) | TacApply (a,ev,cb,inhyp) -> hov 1 ( (if a then mt() else primitive "simple ") ++ primitive (with_evars ev "apply") ++ spc () ++ prlist_with_sep pr_comma pr_with_bindings_arg cb ++ - pr_non_empty_arg (pr_in_hyp_as pr.pr_dconstr pr.pr_name) inhyp + pr_non_empty_arg (pr_in_hyp_as (pr.pr_dconstr env sigma) pr.pr_name) inhyp ) | TacElim (ev,cb,cbo) -> hov 1 ( @@ -779,28 +780,28 @@ let pr_goal_selector ~toplevel s = | TacAssert (ev,b,Some tac,ipat,c) -> hov 1 ( primitive (if b then if ev then "eassert" else "assert" else if ev then "eenough" else "enough") ++ - pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++ + pr_assumption (pr.pr_constr env sigma) (pr.pr_dconstr env sigma) (pr.pr_lconstr env sigma) ipat c ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac ) | TacAssert (ev,_,None,ipat,c) -> hov 1 ( primitive (if ev then "epose proof" else "pose proof") - ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c + ++ pr_assertion (pr.pr_constr env sigma) (pr.pr_dconstr env sigma) (pr.pr_lconstr env sigma) ipat c ) | TacGeneralize l -> hov 1 ( primitive "generalize" ++ spc () ++ prlist_with_sep pr_comma (fun (cl,na) -> - pr_with_occurrences pr.pr_constr cl ++ pr_as_name na) + pr_with_occurrences (pr.pr_constr env sigma) cl ++ pr_as_name na) l ) | TacLetTac (ev,na,c,cl,true,_) when Locusops.is_nowhere cl -> - hov 1 (primitive (if ev then "epose" else "pose") ++ pr_pose pr.pr_constr pr.pr_lconstr na c) + hov 1 (primitive (if ev then "epose" else "pose") ++ pr_pose (pr.pr_constr env sigma) (pr.pr_lconstr env sigma) na c) | TacLetTac (ev,na,c,cl,b,e) -> hov 1 ( primitive (if b then if ev then "eset" else "set" else if ev then "eremember" else "remember") ++ - (if b then pr_pose pr.pr_constr pr.pr_lconstr na c - else pr_pose_as_style pr.pr_constr na c) ++ + (if b then pr_pose (pr.pr_constr env sigma) (pr.pr_lconstr env sigma) na c + else pr_pose_as_style (pr.pr_constr env sigma) na c) ++ pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ pr_non_empty_arg (pr_clauses (Some b) pr.pr_name) cl) (* | TacInstantiate (n,c,ConclLocation ()) -> @@ -820,8 +821,8 @@ let pr_goal_selector ~toplevel s = primitive (with_evars ev (if isrec then "induction" else "destruct")) ++ spc () ++ prlist_with_sep pr_comma (fun (h,ids,cl) -> - pr_destruction_arg pr.pr_dconstr pr.pr_dconstr h ++ - pr_non_empty_arg (pr_with_induction_names pr.pr_dconstr) ids ++ + pr_destruction_arg (pr.pr_dconstr env sigma) (pr.pr_dconstr env sigma) h ++ + pr_non_empty_arg (pr_with_induction_names (pr.pr_dconstr env sigma)) ids ++ pr_opt (pr_clauses None pr.pr_name) cl) l ++ pr_opt pr_eliminator el ) @@ -840,9 +841,9 @@ let pr_goal_selector ~toplevel s = None -> mt () | Some p -> - pr.pr_pattern p ++ spc () + pr.pr_pattern env sigma p ++ spc () ++ keyword "with" ++ spc () - ) ++ pr.pr_dconstr c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h + ) ++ pr.pr_dconstr env sigma c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h ) (* Equality and inversion *) @@ -853,7 +854,7 @@ let pr_goal_selector ~toplevel s = (fun () -> str ","++spc()) (fun (b,m,c) -> pr_orient b ++ pr_multi m ++ - pr_with_bindings_arg_full pr.pr_dconstr pr.pr_dconstr c) + pr_with_bindings_arg_full (pr.pr_dconstr env sigma) (pr.pr_dconstr env sigma) c) l ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) cl ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac @@ -862,28 +863,28 @@ let pr_goal_selector ~toplevel s = hov 1 ( primitive "dependent " ++ pr_inversion_kind k ++ spc () ++ pr_quantified_hypothesis hyp - ++ pr_with_inversion_names pr.pr_dconstr ids - ++ pr_with_constr pr.pr_constr c + ++ pr_with_inversion_names (pr.pr_dconstr env sigma) ids + ++ pr_with_constr (pr.pr_constr env sigma) c ) | TacInversion (NonDepInversion (k,cl,ids),hyp) -> hov 1 ( pr_inversion_kind k ++ spc () ++ pr_quantified_hypothesis hyp - ++ pr_non_empty_arg (pr_with_inversion_names pr.pr_dconstr) ids + ++ pr_non_empty_arg (pr_with_inversion_names @@ pr.pr_dconstr env sigma) ids ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl ) | TacInversion (InversionUsing (c,cl),hyp) -> hov 1 ( primitive "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ spc () - ++ keyword "using" ++ spc () ++ pr.pr_constr c + ++ keyword "using" ++ spc () ++ pr.pr_constr env sigma c ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl ) ) in pr_atom1 - let make_pr_tac pr strip_prod_binders tag_atom tag = + let make_pr_tac env sigma pr strip_prod_binders tag_atom tag = let extract_binders = function | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body) @@ -903,7 +904,7 @@ let pr_goal_selector ~toplevel s = let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in v 0 (hv 0 ( - pr_let_clauses recflag pr.pr_generic (pr_tac ltop) llc + pr_let_clauses recflag (pr.pr_generic env sigma) (pr_tac ltop) llc ++ spc () ++ keyword "in" ) ++ fnl () ++ pr_tac (llet,E) u), llet @@ -913,7 +914,7 @@ let pr_goal_selector ~toplevel s = ++ pr_tac ltop t ++ spc () ++ keyword "with" ++ prlist (fun r -> fnl () ++ str "| " - ++ pr_match_rule true (pr_tac ltop) pr.pr_lpattern r + ++ pr_match_rule true (pr_tac ltop) (pr.pr_lpattern env sigma) r ) lrul ++ fnl() ++ keyword "end"), lmatch @@ -923,7 +924,7 @@ let pr_goal_selector ~toplevel s = ++ keyword (if lr then "match reverse goal with" else "match goal with") ++ prlist (fun r -> fnl () ++ str "| " - ++ pr_match_rule false (pr_tac ltop) pr.pr_lpattern r + ++ pr_match_rule false (pr_tac ltop) (pr.pr_lpattern env sigma) r ) lrul ++ fnl() ++ keyword "end"), lmatch | TacFun (lvar,body) -> @@ -1045,30 +1046,30 @@ let pr_goal_selector ~toplevel s = | TacSelect (s, tac) -> pr_goal_selector ~toplevel:false s ++ spc () ++ pr_tac ltop tac, latom | TacId l -> keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom - | TacAtom (loc,t) -> - pr_with_comments ?loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom - | TacArg(_,Tacexp e) -> + | TacAtom { CAst.loc; v=t } -> + pr_with_comments ?loc (hov 1 (pr_atom env sigma pr strip_prod_binders tag_atom t)), ltatom + | TacArg { CAst.v=Tacexp e } -> pr_tac inherited e, latom - | TacArg(_,ConstrMayEval (ConstrTerm c)) -> - keyword "constr:" ++ pr.pr_constr c, latom - | TacArg(_,ConstrMayEval c) -> - pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval - | TacArg(_,TacFreshId l) -> + | TacArg { CAst.v=ConstrMayEval (ConstrTerm c) } -> + keyword "constr:" ++ pr.pr_constr env sigma c, latom + | TacArg { CAst.v=ConstrMayEval c } -> + pr_may_eval env sigma pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval + | TacArg { CAst.v=TacFreshId l } -> primitive "fresh" ++ pr_fresh_ids l, latom - | TacArg(_,TacGeneric arg) -> - pr.pr_generic arg, latom - | TacArg(_,TacCall(_,(f,[]))) -> + | TacArg { CAst.v=TacGeneric arg } -> + pr.pr_generic env sigma arg, latom + | TacArg { CAst.v=TacCall {CAst.v=(f,[])} } -> pr.pr_reference f, latom - | TacArg(_,TacCall(loc,(f,l))) -> + | TacArg { CAst.v=TacCall {CAst.loc; v=(f,l)} } -> pr_with_comments ?loc (hov 1 ( pr.pr_reference f ++ spc () ++ prlist_with_sep spc pr_tacarg l)), lcall - | TacArg (_,a) -> + | TacArg { CAst.v=a } -> pr_tacarg a, latom - | TacML (loc,(s,l)) -> + | TacML { CAst.loc; v=(s,l) } -> pr_with_comments ?loc (pr.pr_extend 1 s l), lcall - | TacAlias (loc,(kn,l)) -> + | TacAlias { CAst.loc; v=(kn,l) } -> pr_with_comments ?loc (pr.pr_alias (level_of inherited) kn l), latom ) in @@ -1079,15 +1080,15 @@ let pr_goal_selector ~toplevel s = | Reference r -> pr.pr_reference r | ConstrMayEval c -> - pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c + pr_may_eval env sigma pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c | TacFreshId l -> keyword "fresh" ++ pr_fresh_ids l | TacPretype c -> - keyword "type_term" ++ pr.pr_constr c + keyword "type_term" ++ pr.pr_constr env sigma c | TacNumgoals -> keyword "numgoals" | (TacCall _|Tacexp _ | TacGeneric _) as a -> - hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.tag a)))) + hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (CAst.make a)))) in pr_tac @@ -1103,9 +1104,9 @@ let pr_goal_selector ~toplevel s = let raw_printers = (strip_prod_binders_expr) - let rec pr_raw_tactic_level n (t:raw_tactic_expr) = + let rec pr_raw_tactic_level env sigma n (t:raw_tactic_expr) = let pr = { - pr_tactic = pr_raw_tactic_level; + pr_tactic = pr_raw_tactic_level env sigma; pr_constr = pr_constr_expr; pr_dconstr = pr_constr_expr; pr_lconstr = pr_lconstr_expr; @@ -1114,16 +1115,16 @@ let pr_goal_selector ~toplevel s = pr_constant = pr_or_by_notation pr_qualid; pr_reference = pr_qualid; pr_name = pr_lident; - pr_generic = (fun arg -> Pputils.pr_raw_generic (Global.env ()) arg); - pr_extend = pr_raw_extend_rec pr_raw_tactic_level; - pr_alias = pr_raw_alias pr_raw_tactic_level; + pr_generic = Pputils.pr_raw_generic; + pr_extend = pr_raw_extend_rec @@ pr_raw_tactic_level env sigma; + pr_alias = pr_raw_alias @@ pr_raw_tactic_level env sigma; } in - make_pr_tac + make_pr_tac env sigma pr raw_printers tag_raw_atomic_tactic_expr tag_raw_tactic_expr n t - let pr_raw_tactic = pr_raw_tactic_level ltop + let pr_raw_tactic env sigma = pr_raw_tactic_level env sigma ltop let pr_and_constr_expr pr (c,_) = pr c @@ -1136,19 +1137,19 @@ let pr_goal_selector ~toplevel s = let rec prtac n (t:glob_tactic_expr) = let pr = { pr_tactic = prtac; - pr_constr = pr_and_constr_expr (pr_glob_constr_env env); - pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); - pr_lconstr = pr_and_constr_expr (pr_lglob_constr_env env); - pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env); - pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env); + pr_constr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); + pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); + pr_lconstr = (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)); + pr_pattern = (fun env sigma -> pr_pat_and_constr_expr (pr_glob_constr_env env)); + pr_lpattern = (fun env sigma -> pr_pat_and_constr_expr (pr_lglob_constr_env env)); pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env)); pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); pr_name = pr_lident; - pr_generic = (fun arg -> Pputils.pr_glb_generic (Global.env ()) arg); + pr_generic = Pputils.pr_glb_generic; pr_extend = pr_glob_extend_rec prtac; pr_alias = pr_glob_alias prtac; } in - make_pr_tac + make_pr_tac env (Evd.from_env env) pr glob_printers tag_glob_atomic_tactic_expr tag_glob_tactic_expr n t @@ -1163,7 +1164,7 @@ let pr_goal_selector ~toplevel s = if n=0 then (List.rev acc, EConstr.of_constr ty) else match Constr.kind ty with | Constr.Prod(na,a,b) -> - strip_ty (([CAst.make na],EConstr.of_constr a)::acc) (n-1) b + strip_ty (([CAst.make na.Context.binder_name],EConstr.of_constr a)::acc) (n-1) b | _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in strip_ty [] n ty @@ -1171,21 +1172,21 @@ let pr_goal_selector ~toplevel s = let prtac (t:atomic_tactic_expr) = let pr = { pr_tactic = (fun _ _ -> str "<tactic>"); - pr_constr = (fun c -> pr_econstr_env env sigma c); - pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); - pr_lconstr = (fun c -> pr_leconstr_env env sigma c); - pr_pattern = pr_constr_pattern_env env sigma; - pr_lpattern = pr_lconstr_pattern_env env sigma; + pr_constr = pr_econstr_env; + pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); + pr_lconstr = pr_leconstr_env; + pr_pattern = pr_constr_pattern_env; + pr_lpattern = pr_lconstr_pattern_env; pr_constant = pr_evaluable_reference_env env; pr_reference = pr_located pr_ltac_constant; pr_name = pr_id; - (** Those are not used by the atomic printer *) + (* Those are not used by the atomic printer *) pr_generic = (fun _ -> assert false); pr_extend = (fun _ _ _ -> assert false); pr_alias = (fun _ _ _ -> assert false); } in - pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t + pr_atom env sigma pr strip_prod_binders_constr tag_atomic_tactic_expr t in prtac t @@ -1193,9 +1194,9 @@ let pr_goal_selector ~toplevel s = let pr_glb_generic = Pputils.pr_glb_generic - let pr_raw_extend _ = pr_raw_extend_rec pr_raw_tactic_level + let pr_raw_extend env sigma = pr_raw_extend_rec @@ pr_raw_tactic_level env sigma - let pr_glob_extend env = pr_glob_extend_rec (pr_glob_tactic_level env) + let pr_glob_extend env sigma = pr_glob_extend_rec (pr_glob_tactic_level env) let pr_alias pr lev key args = pr_alias_gen (fun _ arg -> pr arg) lev key args @@ -1214,16 +1215,17 @@ let declare_extra_genarg_pprule wit | _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.") end; let f x = - Genprint.PrinterBasic (fun () -> - f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in + Genprint.PrinterBasic (fun env sigma -> + f env sigma pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in let g x = - Genprint.PrinterBasic (fun () -> - let env = Global.env () in - g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x) + Genprint.PrinterBasic (fun env sigma -> + g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)) + (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)) + (fun env sigma -> pr_glob_tactic_level env) x) in let h x = Genprint.TopPrinterNeedsContext (fun env sigma -> - h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") x) + h env sigma pr_econstr_env pr_leconstr_env (fun _env _sigma _ _ -> str "<tactic>") x) in Genprint.register_print0 wit f g h @@ -1240,27 +1242,28 @@ let declare_extra_genarg_pprule_with_level wit PrinterNeedsLevel { default_already_surrounded = default_surrounded; default_ensure_surrounded = default_non_surrounded; - printer = (fun n -> - f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level n x) } in + printer = (fun env sigma n -> + f env sigma pr_constr_expr pr_lconstr_expr pr_raw_tactic_level n x) } in let g x = - let env = Global.env () in PrinterNeedsLevel { default_already_surrounded = default_surrounded; default_ensure_surrounded = default_non_surrounded; - printer = (fun n -> - g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) n x) } + printer = (fun env sigma n -> + g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)) + (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)) + (fun env sigma -> pr_glob_tactic_level env) n x) } in let h x = TopPrinterNeedsContextAndLevel { default_already_surrounded = default_surrounded; default_ensure_surrounded = default_non_surrounded; printer = (fun env sigma n -> - h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") n x) } + h env sigma pr_econstr_env pr_leconstr_env (fun _env _sigma _ _ -> str "<tactic>") n x) } in Genprint.register_print0 wit f g h let declare_extra_vernac_genarg_pprule wit f = - let f x = Genprint.PrinterBasic (fun () -> f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in + let f x = Genprint.PrinterBasic (fun env sigma -> f env sigma pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in Genprint.register_vernac_print0 wit f (** Registering *) @@ -1270,8 +1273,8 @@ let pr_intro_pattern_env p = Genprint.TopPrinterNeedsContext (fun env sigma -> Miscprint.pr_intro_pattern print_constr p) let pr_red_expr_env r = Genprint.TopPrinterNeedsContext (fun env sigma -> - pr_red_expr (pr_econstr_env env sigma, pr_leconstr_env env sigma, - pr_evaluable_reference_env env, pr_constr_pattern_env env sigma) r) + pr_red_expr env sigma (pr_econstr_env, pr_leconstr_env, + pr_evaluable_reference_env env, pr_constr_pattern_env) r) let pr_bindings_env bl = Genprint.TopPrinterNeedsContext (fun env sigma -> let sigma, bl = bl env sigma in @@ -1297,19 +1300,17 @@ let make_constr_printer f c = Genprint.default_ensure_surrounded = Ppconstr.lsimpleconstr; Genprint.printer = (fun env sigma n -> f env sigma n c)} -let lift f a = Genprint.PrinterBasic (fun () -> f a) +let lift f a = Genprint.PrinterBasic (fun env sigma -> f a) +let lift_env f a = Genprint.PrinterBasic (fun env sigma -> f env sigma a) let lift_top f a = Genprint.TopPrinterBasic (fun () -> f a) let register_basic_print0 wit f g h = Genprint.register_print0 wit (lift f) (lift g) (lift_top h) - -let pr_glob_constr_pptac c = - let _, env = Pfedit.get_current_context () in +let pr_glob_constr_pptac env sigma c = pr_glob_constr_env env c -let pr_lglob_constr_pptac c = - let _, env = Pfedit.get_current_context () in +let pr_lglob_constr_pptac env sigma c = pr_lglob_constr_env env c let () = @@ -1323,8 +1324,8 @@ let () = register_basic_print0 wit_var pr_lident pr_lident pr_id; register_print0 wit_intro_pattern - (lift (Miscprint.pr_intro_pattern pr_constr_expr)) - (lift (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr_pptac c))) + (lift_env (fun env sigma -> Miscprint.pr_intro_pattern @@ pr_constr_expr env sigma)) + (lift_env (fun env sigma -> Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr_pptac env sigma c))) pr_intro_pattern_env; Genprint.register_print0 wit_clause_dft_concl @@ -1334,47 +1335,55 @@ let () = ; Genprint.register_print0 wit_constr - (lift Ppconstr.pr_lconstr_expr) - (lift (fun (c, _) -> pr_lglob_constr_pptac c)) + (lift_env Ppconstr.pr_lconstr_expr) + (lift_env (fun env sigma (c, _) -> pr_lglob_constr_pptac env sigma c)) (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 wit_uconstr - (lift Ppconstr.pr_constr_expr) - (lift (fun (c,_) -> pr_glob_constr_pptac c)) + (lift_env Ppconstr.pr_constr_expr) + (lift_env (fun env sigma (c,_) -> pr_glob_constr_pptac env sigma c)) (make_constr_printer Printer.pr_closed_glob_n_env) ; Genprint.register_print0 wit_open_constr - (lift Ppconstr.pr_constr_expr) - (lift (fun (c, _) -> pr_glob_constr_pptac c)) + (lift_env Ppconstr.pr_constr_expr) + (lift_env (fun env sigma (c, _) -> pr_glob_constr_pptac env sigma c)) (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 wit_red_expr - (lift (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_qualid, pr_constr_pattern_expr))) - (lift (pr_red_expr (pr_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac))) + (lift_env (fun env sigma -> pr_red_expr env sigma (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_qualid, pr_constr_pattern_expr))) + (lift_env (fun env sigma -> pr_red_expr env sigma + ((fun env sigma -> pr_and_constr_expr @@ pr_glob_constr_pptac env sigma), + (fun env sigma -> pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma), + pr_or_var (pr_and_short_name pr_evaluable_reference), + (fun env sigma -> pr_pat_and_constr_expr @@ pr_glob_constr_pptac env sigma)))) pr_red_expr_env ; register_basic_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; register_print0 wit_bindings - (lift (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr)) - (lift (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) + (lift_env (fun env sigma -> Miscprint.pr_bindings_no_with (pr_constr_expr env sigma) + (pr_lconstr_expr env sigma))) + (lift_env (fun env sigma -> Miscprint.pr_bindings_no_with (pr_and_constr_expr @@ pr_glob_constr_pptac env sigma) (pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma))) pr_bindings_env ; register_print0 wit_constr_with_bindings - (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr)) - (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) + (lift_env (fun env sigma -> pr_with_bindings (pr_constr_expr env sigma) (pr_lconstr_expr env sigma))) + (lift_env (fun env sigma -> pr_with_bindings (pr_and_constr_expr @@ pr_glob_constr_pptac env sigma) + (pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma))) pr_with_bindings_env ; register_print0 wit_open_constr_with_bindings - (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr)) - (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) + (lift_env (fun env sigma -> pr_with_bindings (pr_constr_expr env sigma) (pr_lconstr_expr env sigma))) + (lift_env (fun env sigma -> pr_with_bindings (pr_and_constr_expr @@ pr_glob_constr_pptac env sigma) + (pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma))) pr_with_bindings_env ; register_print0 Tacarg.wit_destruction_arg - (lift (pr_destruction_arg pr_constr_expr pr_lconstr_expr)) - (lift (pr_destruction_arg (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) + (lift_env (fun env sigma -> pr_destruction_arg (pr_constr_expr env sigma) (pr_lconstr_expr env sigma))) + (lift_env (fun env sigma -> pr_destruction_arg (pr_and_constr_expr @@ pr_glob_constr_pptac env sigma) + (pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma))) pr_destruction_arg_env ; register_basic_print0 Stdarg.wit_int int int int; @@ -1384,12 +1393,12 @@ let () = register_basic_print0 Stdarg.wit_string qstring qstring qstring let () = - let printer _ _ prtac = prtac in + let printer env sigma _ _ prtac = prtac env sigma in declare_extra_genarg_pprule_with_level wit_tactic printer printer printer ltop (0,E) let () = - let pr_unit _ _ _ _ () = str "()" in - let printer _ _ prtac = prtac in + let pr_unit _env _sigma _ _ _ _ () = str "()" in + let printer env sigma _ _ prtac = prtac env sigma in declare_extra_genarg_pprule_with_level wit_ltac printer printer pr_unit ltop (0,E) diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 6c09e447a5..70af09833d 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -17,6 +17,7 @@ open Names open Environ open Constrexpr open Notation_gram +open Genintern open Tacexpr open Tactypes @@ -25,40 +26,46 @@ type 'a grammar_tactic_prod_item_expr = | TacNonTerm of ('a * Names.Id.t option) Loc.located type 'a raw_extra_genarg_printer = - (constr_expr -> Pp.t) -> - (constr_expr -> Pp.t) -> - (tolerability -> raw_tactic_expr -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> Pp.t) -> - (glob_constr_and_expr -> Pp.t) -> - (tolerability -> glob_tactic_expr -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> glob_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a extra_genarg_printer = - (EConstr.t -> Pp.t) -> - (EConstr.t -> Pp.t) -> - (tolerability -> Val.t -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> Val.t -> Pp.t) -> + 'a -> Pp.t type 'a raw_extra_genarg_printer_with_level = - (constr_expr -> Pp.t) -> - (constr_expr -> Pp.t) -> - (tolerability -> raw_tactic_expr -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t type 'a glob_extra_genarg_printer_with_level = - (glob_constr_and_expr -> Pp.t) -> - (glob_constr_and_expr -> Pp.t) -> - (tolerability -> glob_tactic_expr -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> glob_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t type 'a extra_genarg_printer_with_level = - (EConstr.constr -> Pp.t) -> - (EConstr.constr -> Pp.t) -> - (tolerability -> Val.t -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> Val.t -> Pp.t) -> + tolerability -> 'a -> Pp.t val declare_extra_genarg_pprule : ('a, 'b, 'c) genarg_type -> @@ -90,15 +97,15 @@ val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit val pr_with_occurrences : ('a -> Pp.t) -> 'a Locus.with_occurrences -> Pp.t -val pr_red_expr : - ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> +val pr_red_expr : env -> Evd.evar_map -> + (env -> Evd.evar_map -> 'a -> Pp.t) * (env -> Evd.evar_map -> 'a -> Pp.t) * ('b -> Pp.t) * (env -> Evd.evar_map -> 'c -> Pp.t) -> ('a,'b,'c) Genredexpr.red_expr_gen -> Pp.t val pr_may_eval : - ('a -> Pp.t) -> ('a -> Pp.t) -> ('b -> Pp.t) -> - ('c -> Pp.t) -> ('a,'b,'c) Genredexpr.may_eval -> Pp.t + env -> Evd.evar_map -> + (env -> Evd.evar_map -> 'a -> Pp.t) -> (env -> Evd.evar_map -> 'a -> Pp.t) -> ('b -> Pp.t) -> + (env -> Evd.evar_map -> 'c -> Pp.t) -> ('a,'b,'c) Genredexpr.may_eval -> Pp.t -val pr_and_short_name : ('a -> Pp.t) -> 'a Stdarg.and_short_name -> Pp.t -val pr_or_by_notation : ('a -> Pp.t) -> 'a or_by_notation -> Pp.t +val pr_and_short_name : ('a -> Pp.t) -> 'a Genredexpr.and_short_name -> Pp.t val pr_evaluable_reference_env : env -> evaluable_global_reference -> Pp.t @@ -111,14 +118,14 @@ val pr_clauses : (* default: *) bool option -> ('a -> Pp.t) -> 'a Locus.clause_expr -> Pp.t (* Some true = default is concl; Some false = default is all; None = no default *) -val pr_raw_generic : env -> rlevel generic_argument -> Pp.t +val pr_raw_generic : env -> Evd.evar_map -> rlevel generic_argument -> Pp.t -val pr_glb_generic : env -> glevel generic_argument -> Pp.t +val pr_glb_generic : env -> Evd.evar_map -> glevel generic_argument -> Pp.t -val pr_raw_extend: env -> int -> +val pr_raw_extend: env -> Evd.evar_map -> int -> ml_tactic_entry -> raw_tactic_arg list -> Pp.t -val pr_glob_extend: env -> int -> +val pr_glob_extend: env -> Evd.evar_map -> int -> ml_tactic_entry -> glob_tactic_arg list -> Pp.t val pr_extend : @@ -131,9 +138,9 @@ val pr_alias : (Val.t -> Pp.t) -> val pr_ltac_constant : ltac_constant -> Pp.t -val pr_raw_tactic : raw_tactic_expr -> Pp.t +val pr_raw_tactic : env -> Evd.evar_map -> raw_tactic_expr -> Pp.t -val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> Pp.t +val pr_raw_tactic_level : env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t val pr_glob_tactic : env -> glob_tactic_expr -> Pp.t diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index d22bd4967a..ae4b53325f 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -251,7 +251,7 @@ let string_of_call ck = | Tacexpr.LtacVarCall (id, t) -> Names.Id.print id | Tacexpr.LtacAtomCall te -> (Pptactic.pr_glob_tactic (Global.env ()) - (Tacexpr.TacAtom (Loc.tag te))) + (Tacexpr.TacAtom (CAst.make te))) | Tacexpr.LtacConstrInterp (c, _) -> pr_glob_constr_env (Global.env ()) c | Tacexpr.LtacMLCall te -> @@ -260,7 +260,7 @@ let string_of_call ck = ) in let s = String.map (fun c -> if c = '\n' then ' ' else c) s in let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in - CString.strip s + String.trim s let rec merge_sub_tree name tree acc = try @@ -446,7 +446,7 @@ let do_print_results_at_close () = let _ = Declaremods.append_end_library_hook do_print_results_at_close -let _ = +let () = let open Goptions in declare_bool_option { optdepr = false; diff --git a/plugins/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.mlg index 983e1578be..2713819c7b 100644 --- a/plugins/ltac/profile_ltac_tactics.ml4 +++ b/plugins/ltac/profile_ltac_tactics.mlg @@ -8,13 +8,19 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + (** Ltac profiling entrypoints *) open Profile_ltac open Stdarg +} + DECLARE PLUGIN "ltac_plugin" +{ + let tclSET_PROFILING b = Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> set_profiling b)) @@ -33,42 +39,44 @@ let tclRESTART_TIMER s = let tclFINISH_TIMING ?(prefix="Timer") (s : string option) = Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> finish_timing ~prefix s)) +} + TACTIC EXTEND start_ltac_profiling -| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ] +| [ "start" "ltac" "profiling" ] -> { tclSET_PROFILING true } END TACTIC EXTEND stop_ltac_profiling -| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ] +| [ "stop" "ltac" "profiling" ] -> { tclSET_PROFILING false } END TACTIC EXTEND reset_ltac_profile -| [ "reset" "ltac" "profile" ] -> [ tclRESET_PROFILE ] +| [ "reset" "ltac" "profile" ] -> { tclRESET_PROFILE } END TACTIC EXTEND show_ltac_profile -| [ "show" "ltac" "profile" ] -> [ tclSHOW_PROFILE ~cutoff:!Flags.profile_ltac_cutoff ] -| [ "show" "ltac" "profile" "cutoff" int(n) ] -> [ tclSHOW_PROFILE ~cutoff:(float_of_int n) ] -| [ "show" "ltac" "profile" string(s) ] -> [ tclSHOW_PROFILE_TACTIC s ] +| [ "show" "ltac" "profile" ] -> { tclSHOW_PROFILE ~cutoff:!Flags.profile_ltac_cutoff } +| [ "show" "ltac" "profile" "cutoff" int(n) ] -> { tclSHOW_PROFILE ~cutoff:(float_of_int n) } +| [ "show" "ltac" "profile" string(s) ] -> { tclSHOW_PROFILE_TACTIC s } END TACTIC EXTEND restart_timer -| [ "restart_timer" string_opt(s) ] -> [ tclRESTART_TIMER s ] +| [ "restart_timer" string_opt(s) ] -> { tclRESTART_TIMER s } END TACTIC EXTEND finish_timing -| [ "finish_timing" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix:"Timer" s ] -| [ "finish_timing" "(" string(prefix) ")" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix s ] +| [ "finish_timing" string_opt(s) ] -> { tclFINISH_TIMING ~prefix:"Timer" s } +| [ "finish_timing" "(" string(prefix) ")" string_opt(s) ] -> { tclFINISH_TIMING ~prefix s } END VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF - [ "Reset" "Ltac" "Profile" ] -> [ reset_profile () ] +| [ "Reset" "Ltac" "Profile" ] -> { reset_profile () } END VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY -| [ "Show" "Ltac" "Profile" ] -> [ print_results ~cutoff:!Flags.profile_ltac_cutoff ] -| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> [ print_results ~cutoff:(float_of_int n) ] +| [ "Show" "Ltac" "Profile" ] -> { print_results ~cutoff:!Flags.profile_ltac_cutoff } +| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> { print_results ~cutoff:(float_of_int n) } END VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY - [ "Show" "Ltac" "Profile" string(s) ] -> [ print_results_tactic s ] +| [ "Show" "Ltac" "Profile" string(s) ] -> { print_results_tactic s } END diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 9dd98a4ab7..75565c1a34 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -15,6 +15,7 @@ open Names open Nameops open Namegen open Constr +open Context open EConstr open Vars open Reduction @@ -43,6 +44,14 @@ module NamedDecl = Context.Named.Declaration (** Typeclass-based generalized rewriting. *) +type rewrite_attributes = { polymorphic : bool; program : bool; global : bool } + +let rewrite_attributes = + let open Attributes.Notations in + Attributes.(polymorphic ++ program ++ locality) >>= fun ((polymorphic, program), locality) -> + let global = not (Locality.make_section_locality locality) in + Attributes.Notations.return { polymorphic; program; global } + (** Constants used by the tactic. *) let classes_dirpath = @@ -89,8 +98,8 @@ let goalevars evars = fst evars let cstrevars evars = snd evars let new_cstr_evar (evd,cstrs) env t = - let s = Typeclasses.set_resolvable Evd.Store.empty false in - let (evd', t) = Evarutil.new_evar ~store:s env evd t in + (* We handle the typeclass resolution of constraints ourselves *) + let (evd', t) = Evarutil.new_evar env evd ~typeclass_candidate:false t in let ev, _ = destEvar evd' t in (evd', Evar.Set.add ev cstrs), t @@ -212,23 +221,23 @@ end) = struct let rec aux env evars ty l = let t = Reductionops.whd_all env (goalevars evars) ty in match EConstr.kind (goalevars evars) t, l with - | Prod (na, ty, b), obj :: cstrs -> + | Prod (na, ty, b), obj :: cstrs -> let b = Reductionops.nf_betaiota env (goalevars evars) b in - if noccurn (goalevars evars) 1 b (* non-dependent product *) then + if noccurn (goalevars evars) 1 b (* non-dependent product *) then let ty = Reductionops.nf_betaiota env (goalevars evars) ty in let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in let evars, relty = mk_relty evars env ty obj in let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in - evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs + evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs else let (evars, b, arg, cstrs) = - aux (push_rel (LocalAssum (na, ty)) env) evars b cstrs + aux (push_rel (LocalAssum (na, ty)) env) evars b cstrs in let ty = Reductionops.nf_betaiota env (goalevars evars) ty in - let pred = mkLambda (na, ty, b) in - let liftarg = mkLambda (na, ty, arg) in - let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in - if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs + let pred = mkLambda (na, ty, b) in + let liftarg = mkLambda (na, ty, arg) in + let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in + if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs else user_err Pp.(str "build_signature: no constraint can apply on a dependent argument") | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products.") | _, [] -> @@ -245,7 +254,7 @@ end) = struct let unfold_impl sigma t = match EConstr.kind sigma t with | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> - mkProd (Anonymous, a, lift 1 b) + mkProd (make_annot Anonymous Sorts.Relevant, a, lift 1 b) | _ -> assert false let unfold_all sigma t = @@ -271,7 +280,7 @@ end) = struct (app_poly env evd arrow [| a; b |]), unfold_impl (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) else if bp then (* Dummy forall *) - (app_poly env evd coq_all [| a; mkLambda (Anonymous, a, lift 1 b) |]), unfold_forall + (app_poly env evd coq_all [| a; mkLambda (make_annot Anonymous Sorts.Relevant, a, lift 1 b) |]), unfold_forall else (* None in Prop, use arrow *) (app_poly env evd arrow [| a; b |]), unfold_impl @@ -300,7 +309,8 @@ end) = struct app_poly env evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |] else app_poly env evd forall_relation - [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |] + [| t; mkLambda (make_annot n Sorts.Relevant, t, car); + mkLambda (make_annot n Sorts.Relevant, t, rel) |] let lift_cstr env evars (args : constr list) c ty cstr = let start evars env car = @@ -315,15 +325,15 @@ end) = struct else let sigma = goalevars evars in match EConstr.kind sigma (Reductionops.whd_all env sigma prod) with - | Prod (na, ty, b) -> + | Prod (na, ty, b) -> if noccurn sigma 1 b then let b' = lift (-1) b in let evars, rb = aux evars env b' (pred n) in app_poly env evars pointwise_relation [| ty; b'; rb |] else - let evars, rb = aux evars (push_rel (LocalAssum (na, ty)) env) b (pred n) in + let evars, rb = aux evars (push_rel (LocalAssum (na, ty)) env) b (pred n) in app_poly env evars forall_relation - [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] + [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] | _ -> raise Not_found in let rec find env c ty = function @@ -441,7 +451,7 @@ let evd_convertible env evd x y = unsolvable constraints remain, so we check that this unification does not introduce any new problem. *) let _, pbs = Evd.extract_all_conv_pbs evd in - let evd' = Evarconv.the_conv_x env x y evd in + let evd' = Evarconv.unify_delay env evd x y in let _, pbs' = Evd.extract_all_conv_pbs evd' in if evd' == evd || problem_inclusion pbs' pbs then Some evd' else None @@ -466,15 +476,16 @@ let get_symmetric_proof b = let error_no_relation () = user_err Pp.(str "Cannot find a relation to rewrite.") let rec decompose_app_rel env evd t = - (** Head normalize for compatibility with the old meta mechanism *) + (* Head normalize for compatibility with the old meta mechanism *) let t = Reductionops.whd_betaiota evd t in match EConstr.kind evd t with | App (f, [||]) -> assert false | App (f, [|arg|]) -> let (f', argl, argr) = decompose_app_rel env evd arg in let ty = Typing.unsafe_type_of env evd argl in - let f'' = mkLambda (Name default_dependent_ident, ty, - mkLambda (Name (Id.of_string "y"), lift 1 ty, + let r = Retyping.relevance_of_type env evd ty in + let f'' = mkLambda (make_annot (Name default_dependent_ident) r, ty, + mkLambda (make_annot (Name (Id.of_string "y")) r, lift 1 ty, mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) in (f'', argl, argr) | App (f, args) -> @@ -514,13 +525,13 @@ let decompose_applied_relation env sigma (c,l) = | Some c -> c | None -> let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with + match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with | Some c -> c | None -> user_err Pp.(str "Cannot find an homogeneous relation to rewrite.") let rewrite_db = "rewrite" -let conv_transparent_state = (Id.Pred.empty, Cpred.full) +let conv_transparent_state = TransparentState.cst_full let rewrite_transparent_state () = Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db) @@ -529,8 +540,8 @@ let rewrite_core_unif_flags = { Unification.modulo_conv_on_closed_terms = None; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.use_evars_eagerly_in_conv_on_closed_terms = true; - Unification.modulo_delta = empty_transparent_state; - Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_delta = TransparentState.empty; + Unification.modulo_delta_types = TransparentState.full; Unification.check_applied_meta_types = true; Unification.use_pattern_unification = true; Unification.use_meta_bound_pattern_unification = true; @@ -577,12 +588,12 @@ let general_rewrite_unif_flags () = Unification.modulo_conv_on_closed_terms = Some ts; Unification.use_evars_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = ts; - Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_delta_types = TransparentState.full; Unification.modulo_betaiota = true } in { Unification.core_unify_flags = core_flags; Unification.merge_unify_flags = core_flags; - Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state }; + Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = TransparentState.empty }; Unification.allow_K_in_toplevel_higher_order_unification = true; Unification.resolve_evars = true } @@ -605,9 +616,11 @@ let solve_remaining_by env sigma holes by = Some evk | _ -> None in - (** Only solve independent holes *) + (* Only solve independent holes *) let indep = List.map_filter map holes in - let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + let ist = { Geninterp.lfun = Id.Map.empty + ; poly = false + ; extra = Geninterp.TacStore.empty } in let solve_tac = match tac with | Genarg.GenArg (Genarg.Glbwit tag, tac) -> Ftactic.run (Geninterp.interp tag ist tac) (fun _ -> Proofview.tclUNIT ()) @@ -620,11 +633,12 @@ let solve_remaining_by env sigma holes by = in match evi with | None -> sigma - (** Evar should not be defined, but just in case *) + (* Evar should not be defined, but just in case *) | Some evi -> let env = Environ.reset_with_named_context evi.evar_hyps env in let ty = evi.evar_concl in - let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in + let name, poly = Id.of_string "rewrite", false in + let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma ty solve_tac in Evd.define evk (EConstr.of_constr c) sigma in List.fold_left solve sigma indep @@ -632,15 +646,13 @@ let solve_remaining_by env sigma holes by = let no_constraints cstrs = fun ev _ -> not (Evar.Set.mem ev cstrs) -let all_constraints cstrs = - fun ev _ -> Evar.Set.mem ev cstrs - let poly_inverse sort = if sort then PropGlobal.inverse else TypeGlobal.inverse type rewrite_proof = | RewPrf of constr * constr (** A Relation (R : rew_car -> rew_car -> Prop) and a proof of R rew_from rew_to *) + | RewCast of cast_kind (** A proof of convertibility (with casts) *) @@ -796,7 +808,7 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation in EConstr.push_named - (LocalDef (Id.of_string "do_subrelation", + (LocalDef (make_annot (Id.of_string "do_subrelation") Sorts.Relevant, snd (app_poly_sort b env evars dosub [||]), snd (app_poly_nocheck env evars appsub [||]))) env @@ -899,7 +911,7 @@ let make_leibniz_proof env c ty r = let prf = e_app_poly env evars coq_f_equal [| r.rew_car; ty; - mkLambda (Anonymous, r.rew_car, c); + mkLambda (make_annot Anonymous Sorts.Relevant, r.rew_car, c); r.rew_from; r.rew_to; prf |] in RewPrf (rel, prf) | RewCast k -> r.rew_prf @@ -1096,7 +1108,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = (* else *) | Prod (n, dom, codom) -> - let lam = mkLambda (n, dom, codom) in + let lam = mkLambda (n, dom, codom) in let (evars', app), unfold = if eq_constr (fst evars) ty mkProp then (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all @@ -1142,9 +1154,9 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = (* | _ -> b') *) | Lambda (n, t, b) when flags.under_lambdas -> - let n' = Nameops.Name.map (fun id -> Tactics.fresh_id_in_env unfresh id env) n in + let n' = map_annot (Nameops.Name.map (fun id -> Tactics.fresh_id_in_env unfresh id env)) n in let open Context.Rel.Declaration in - let env' = EConstr.push_rel (LocalAssum (n', t)) env in + let env' = EConstr.push_rel (LocalAssum (n', t)) env in let bty = Retyping.get_type_of env' (goalevars evars) b in let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in let state, b' = s.strategy { state ; env = env' ; unfresh ; @@ -1159,15 +1171,15 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let point = if prop then PropGlobal.pointwise_or_dep_relation else TypeGlobal.pointwise_or_dep_relation in - let evars, rel = point env r.rew_evars n' t r.rew_car rel in - let prf = mkLambda (n', t, prf) in + let evars, rel = point env r.rew_evars n'.binder_name t r.rew_car rel in + let prf = mkLambda (n', t, prf) in { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } | x -> r in Success { r with - rew_car = mkProd (n, t, r.rew_car); - rew_from = mkLambda(n, t, r.rew_from); - rew_to = mkLambda (n, t, r.rew_to) } + rew_car = mkProd (n, t, r.rew_car); + rew_from = mkLambda(n, t, r.rew_from); + rew_to = mkLambda (n, t, r.rew_to) } | Fail | Identity -> b' in state, res @@ -1453,10 +1465,11 @@ let apply_strategy (s : strategy) env unfresh concl (prop, cstr) evars = res let solve_constraints env (evars,cstrs) = - let filter = all_constraints cstrs in - Typeclasses.resolve_typeclasses env ~filter ~split:false ~fail:true - (Typeclasses.mark_resolvables ~filter evars) - + let oldtcs = Evd.get_typeclass_evars evars in + let evars' = Evd.set_typeclass_evars evars cstrs in + let evars' = Typeclasses.resolve_typeclasses env ~filter:all_evars ~split:false ~fail:true evars' in + Evd.set_typeclass_evars evars' oldtcs + let nf_zeta = Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) @@ -1494,7 +1507,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul if not (Evd.is_defined acc ev) then user_err ~hdr:"rewrite" (str "Unsolved constraint remaining: " ++ spc () ++ - Termops.pr_evar_info (Evd.find acc ev)) + Termops.pr_evar_info env acc (Evd.find acc ev)) else Evd.remove acc ev) cstrs evars' in @@ -1508,7 +1521,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul | Some (t, ty) -> let t = Reductionops.nf_evar evars' t in let ty = Reductionops.nf_evar evars' ty in - mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) + mkApp (mkLambda (make_annot (Name (Id.of_string "lemma")) Sorts.Relevant, ty, p), [| t |]) in let proof = match is_hyp with | None -> term @@ -1534,7 +1547,8 @@ let assert_replacing id newt tac = let after, before = List.split_when (NamedDecl.get_id %> Id.equal id) ctx in let nc = match before with | [] -> assert false - | d :: rem -> insert_dependent env sigma (LocalAssum (NamedDecl.get_id d, newt)) [] after @ rem + | d :: rem -> insert_dependent env sigma + (LocalAssum (make_annot (NamedDecl.get_id d) Sorts.Relevant, newt)) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in Refine.refine ~typecheck:true begin fun sigma -> @@ -1555,7 +1569,7 @@ let newfail n s = let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in - (** For compatibility *) + (* For compatibility *) let beta = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in let beta_hyp id = Tactics.reduct_in_hyp Reductionops.nf_betaiota (id, InHyp) in let treat sigma res = @@ -1578,7 +1592,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_hyp_no_check (LocalAssum (id, newt)) <*> + convert_hyp_no_check (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> beta_hyp id | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> @@ -1605,7 +1619,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let env = match clause with | None -> env | Some id -> - (** Only consider variables not depending on [id] *) + (* Only consider variables not depending on [id] *) let ctx = named_context env in let filter decl = not (occur_var_in_decl env sigma id decl) in let nctx = List.filter filter ctx in @@ -1617,7 +1631,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = in let sigma = match origsigma with None -> sigma | Some sigma -> sigma in treat sigma res <*> - (** For compatibility *) + (* For compatibility *) beta <*> Proofview.shelve_unifiable with | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) -> @@ -1778,70 +1792,65 @@ let declare_an_instance n s args = let declare_instance a aeq n s = declare_an_instance n s [a;aeq] -let anew_instance global binders instance fields = - let program_mode = Flags.is_program_mode () in - let poly = Flags.is_universe_polymorphism () in - new_instance ~program_mode poly +let anew_instance ~pstate atts binders instance fields = + let program_mode = atts.program in + new_instance ~pstate ~program_mode atts.polymorphic binders instance (Some (true, CAst.make @@ CRecord (fields))) - ~global ~generalize:false ~refine:false Hints.empty_hint_info + ~global:atts.global ~generalize:false ~refine:false Hints.empty_hint_info -let declare_instance_refl global binders a aeq n lemma = +let declare_instance_refl ~pstate atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" - in anew_instance global binders instance + in anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "reflexivity"),lemma)] -let declare_instance_sym global binders a aeq n lemma = +let declare_instance_sym atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" - in anew_instance global binders instance + in anew_instance atts binders instance [(qualid_of_ident (Id.of_string "symmetry"),lemma)] -let declare_instance_trans global binders a aeq n lemma = +let declare_instance_trans atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" - in anew_instance global binders instance + in anew_instance atts binders instance [(qualid_of_ident (Id.of_string "transitivity"),lemma)] -let declare_relation ?locality ?(binders=[]) a aeq n refl symm trans = +let declare_relation ~pstate atts ?(binders=[]) a aeq n refl symm trans = init_setoid (); - let global = not (Locality.make_section_locality locality) in - let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" - in ignore(anew_instance global binders instance []); + let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" in + let _, pstate = anew_instance ~pstate atts binders instance [] in match (refl,symm,trans) with - (None, None, None) -> () + (None, None, None) -> pstate | (Some lemma1, None, None) -> - ignore (declare_instance_refl global binders a aeq n lemma1) + snd @@ declare_instance_refl ~pstate atts binders a aeq n lemma1 | (None, Some lemma2, None) -> - ignore (declare_instance_sym global binders a aeq n lemma2) + snd @@ declare_instance_sym ~pstate atts binders a aeq n lemma2 | (None, None, Some lemma3) -> - ignore (declare_instance_trans global binders a aeq n lemma3) + snd @@ declare_instance_trans ~pstate atts binders a aeq n lemma3 | (Some lemma1, Some lemma2, None) -> - ignore (declare_instance_refl global binders a aeq n lemma1); - ignore (declare_instance_sym global binders a aeq n lemma2) + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + snd @@ declare_instance_sym ~pstate atts binders a aeq n lemma2 | (Some lemma1, None, Some lemma3) -> - let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" - in ignore( - anew_instance global binders instance + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "PreOrder_Reflexive"), lemma1); - (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)]) + (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)] | (None, Some lemma2, Some lemma3) -> - let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" - in ignore( - anew_instance global binders instance + let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "PER_Symmetric"), lemma2); - (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)]) + (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)] | (Some lemma1, Some lemma2, Some lemma3) -> - let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in - let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance global binders instance + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), lemma1); (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), lemma2); - (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)]) + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)] let cHole = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) @@ -1883,7 +1892,7 @@ let declare_projection n instance_id r = in it_mkProd_or_LetIn ccl ctx in let typ = it_mkProd_or_LetIn typ ctx in - let univs = Evd.const_univ_entry ~poly sigma in + let univs = Evd.univ_entry ~poly sigma in let typ = EConstr.to_constr sigma typ in let term = EConstr.to_constr sigma term in let cst = @@ -1899,7 +1908,7 @@ let build_morphism_signature env sigma m = let cstrs = let rec aux t = match EConstr.kind sigma t with - | Prod (na, a, b) -> + | Prod (na, a, b) -> None :: aux b | _ -> [] in aux t @@ -1937,81 +1946,81 @@ let warn_add_setoid_deprecated = CWarnings.create ~name:"add-setoid" ~category:"deprecated" (fun () -> Pp.(str "Add Setoid is deprecated, please use Add Parametric Relation.")) -let add_setoid global binders a aeq t n = +let add_setoid ~pstate atts binders a aeq t n = warn_add_setoid_deprecated ?loc:a.CAst.loc (); init_setoid (); - let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in - let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in - let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance global binders instance + in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])] let make_tactic name = let open Tacexpr in let tacqid = Libnames.qualid_of_string name in - TacArg (Loc.tag @@ (TacCall (Loc.tag (tacqid, [])))) + TacArg (CAst.make @@ (TacCall (CAst.make (tacqid, [])))) let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> Pp.(str "Add Morphism f : id is deprecated, please use Add Morphism f with signature (...) as id")) -let add_morphism_infer glob m n = +let add_morphism_infer ~pstate atts m n : Proof_global.t option = warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); - let poly = Flags.is_universe_polymorphism () in + (* NB: atts.program is ignored, program mode automatically set by vernacentries *) let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in let uctx, instance = build_morphism_signature env evd m in if Lib.is_modtype () then - let uctx = UState.const_univ_entry ~poly uctx in + let uctx = UState.univ_entry ~poly:atts.polymorphic uctx in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id - (Entries.ParameterEntry - (None,(instance,uctx),None), - Decl_kinds.IsAssumption Decl_kinds.Logical) + (Entries.ParameterEntry + (None,(instance,uctx),None), + Decl_kinds.IsAssumption Decl_kinds.Logical) in - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info atts.global (ConstRef cst)); + declare_projection n instance_id (ConstRef cst); + pstate else - let kind = Decl_kinds.Global, poly, - Decl_kinds.DefinitionBody Decl_kinds.Instance + let kind = Decl_kinds.Global, atts.polymorphic, + Decl_kinds.DefinitionBody Decl_kinds.Instance in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in - let hook _ = function - | Globnames.ConstRef cst -> - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info - glob (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) - | _ -> assert false + let hook _ _ _ = function + | Globnames.ConstRef cst -> + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info + atts.global (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + | _ -> assert false in let hook = Lemmas.mk_hook hook in - Flags.silently - (fun () -> - Lemmas.start_proof instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) hook; - ignore (Pfedit.by (Tacinterp.interp tac))) () + Flags.silently + (fun () -> + let pstate = Lemmas.start_proof ~ontop:pstate ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in + Some (fst Pfedit.(by (Tacinterp.interp tac) pstate))) () -let add_morphism glob binders m s n = +let add_morphism ~pstate atts binders m s n = init_setoid (); - let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = (((CAst.make @@ Name instance_id),None), Explicit, CAst.make @@ CAppExpl ( (None, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper",None), - [cHole; s; m])) + [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - let program_mode = Flags.is_program_mode () in - ignore(new_instance ~program_mode ~global:glob poly binders instance - (Some (true, CAst.make @@ CRecord [])) - ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) + let _, pstate = new_instance ~pstate ~program_mode:atts.program ~global:atts.global atts.polymorphic binders instance + None + ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info in + pstate (** Bind to "rewrite" too *) diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 0d014a0bf3..a200cb5ced 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -13,12 +13,16 @@ open Environ open EConstr open Constrexpr open Evd +open Genintern open Tactypes open Tacexpr open Tacinterp (** TODO: document and clean me! *) +type rewrite_attributes +val rewrite_attributes : rewrite_attributes Attributes.attribute + type unary_strategy = Subterms | Subterm | Innermost | Outermost | Bottomup | Topdown | Progress | Try | Any | Repeat @@ -77,18 +81,18 @@ val cl_rewrite_clause : val is_applied_rewrite_relation : env -> evar_map -> rel_context -> constr -> types option -val declare_relation : ?locality:bool -> +val declare_relation : pstate:Proof_global.t option -> rewrite_attributes -> ?binders:local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> - constr_expr option -> constr_expr option -> constr_expr option -> unit + constr_expr option -> constr_expr option -> constr_expr option -> Proof_global.t option -val add_setoid : - bool -> local_binder_expr list -> constr_expr -> constr_expr -> constr_expr -> - Id.t -> unit +val add_setoid : pstate:Proof_global.t option -> + rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> constr_expr -> + Id.t -> Proof_global.t option -val add_morphism_infer : bool -> constr_expr -> Id.t -> unit +val add_morphism_infer : pstate:Proof_global.t option -> rewrite_attributes -> constr_expr -> Id.t -> Proof_global.t option -val add_morphism : - bool -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> unit +val add_morphism : pstate:Proof_global.t option -> + rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> Proof_global.t option val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr diff --git a/plugins/ltac/tacarg.mli b/plugins/ltac/tacarg.mli index bdb0be03cf..0c7096a4de 100644 --- a/plugins/ltac/tacarg.mli +++ b/plugins/ltac/tacarg.mli @@ -11,6 +11,7 @@ open Genarg open EConstr open Constrexpr +open Genintern open Tactypes open Tacexpr diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 026c00b849..fcab98c7e8 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -199,7 +199,8 @@ let id_of_name = function basename | Sort s -> begin - match ESorts.kind sigma s with + match ESorts.kind sigma s with + | Sorts.SProp -> Label.to_id (Label.make "SProp") | Sorts.Prop -> Label.to_id (Label.make "Prop") | Sorts.Set -> Label.to_id (Label.make "Set") | Sorts.Type _ -> Label.to_id (Label.make "Type") diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index d2ae92f6ce..b04c3b9f4e 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -53,7 +53,7 @@ val coerce_var_to_ident : bool -> Environ.env -> Evd.evar_map -> Value.t -> Id.t val coerce_to_ident_not_fresh : Evd.evar_map -> Value.t -> Id.t -val coerce_to_intro_pattern : Evd.evar_map -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr +val coerce_to_intro_pattern : Evd.evar_map -> Value.t -> delayed_open_constr intro_pattern_expr val coerce_to_intro_pattern_naming : Evd.evar_map -> Value.t -> Namegen.intro_pattern_naming_expr diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index a77a9c2f45..b770b97384 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -119,7 +119,7 @@ let get_tactic_entry n = else if Int.equal n 5 then Pltac.binder_tactic, None else if 1<=n && n<5 then - Pltac.tactic_expr, Some (Extend.Level (string_of_int n)) + Pltac.tactic_expr, Some (Gramlib.Gramext.Level (string_of_int n)) else user_err Pp.(str ("Invalid Tactic Notation level: "^(string_of_int n)^".")) @@ -169,7 +169,7 @@ let add_tactic_entry (kn, ml, tg) state = let entry, pos = get_tactic_entry tg.tacgram_level in let mkact loc l = let map arg = - (** HACK to handle especially the tactic(...) entry *) + (* HACK to handle especially the tactic(...) entry *) let wit = Genarg.rawwit Tacarg.wit_tactic in if Genarg.has_type arg wit && not ml then Tacexp (Genarg.out_gen wit arg) @@ -177,7 +177,7 @@ let add_tactic_entry (kn, ml, tg) state = TacGeneric arg in let l = List.map map l in - (TacAlias (Loc.tag ~loc (kn,l)):raw_tactic_expr) + (TacAlias (CAst.make ~loc (kn,l)):raw_tactic_expr) in let () = if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then @@ -223,7 +223,7 @@ let interp_prod_item = function | Some arg -> arg end | Some n -> - (** FIXME: do better someday *) + (* FIXME: do better someday *) assert (String.equal s "tactic"); begin match Tacarg.wit_tactic with | ExtraArg tag -> ArgT.Any tag @@ -241,9 +241,9 @@ let make_fresh_key = | TacNonTerm _ -> "#" in let prods = String.concat "_" (List.map map prods) in - (** We embed the hash of the kernel name in the label so that the identifier - should be mostly unique. This ensures that including two modules - together won't confuse the corresponding labels. *) + (* We embed the hash of the kernel name in the label so that the identifier + should be mostly unique. This ensures that including two modules + together won't confuse the corresponding labels. *) let hash = (cur lxor (ModPath.hash (Lib.current_mp ()))) land 0x7FFFFFFF in let lbl = Id.of_string_soft (Printf.sprintf "%s_%08X" prods hash) in Lib.make_kn lbl @@ -281,7 +281,7 @@ let open_tactic_notation i (_, tobj) = let load_tactic_notation i (_, tobj) = let key = tobj.tacobj_key in let () = check_key key in - (** Only add the printing and interpretation rules. *) + (* Only add the printing and interpretation rules. *) Tacenv.register_alias key tobj.tacobj_body; Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram); if Int.equal i 1 && not tobj.tacobj_local then @@ -342,18 +342,18 @@ let extend_atomic_tactic name entries = let map_prod prods = let (hd, rem) = match prods with | TacTerm s :: rem -> (s, rem) - | _ -> assert false (** Not handled by the ML extension syntax *) + | _ -> assert false (* Not handled by the ML extension syntax *) in let empty_value = function | TacTerm s -> raise NonEmptyArgument | TacNonTerm (_, (symb, _)) -> let EntryName (typ, e) = prod_item_of_symbol 0 symb in let Genarg.Rawwit wit = typ in - let inj x = TacArg (Loc.tag @@ TacGeneric (Genarg.in_gen typ x)) in + let inj x = TacArg (CAst.make @@ TacGeneric (Genarg.in_gen typ x)) in let default = epsilon_value inj e in match default with | None -> raise NonEmptyArgument - | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def + | Some def -> Tacintern.intern_tactic_or_tacarg (Genintern.empty_glob_sign Environ.empty_env) def in try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None in @@ -363,7 +363,7 @@ let extend_atomic_tactic name entries = | Some (id, args) -> let args = List.map (fun a -> Tacexp a) args in let entry = { mltac_name = name; mltac_index = i } in - let body = TacML (Loc.tag (entry, args)) in + let body = TacML (CAst.make (entry, args)) in Tacenv.register_ltac false false (Names.Id.of_string id) body in List.iteri add_atomic entries @@ -379,12 +379,12 @@ let add_ml_tactic_notation name ~level ?deprecation prods = let ids = List.map_filter get_id prods in let entry = { mltac_name = name; mltac_index = len - i - 1 } in let map id = Reference (Locus.ArgVar (CAst.make id)) in - let tac = TacML (Loc.tag (entry, List.map map ids)) in + let tac = TacML (CAst.make (entry, List.map map ids)) in add_glob_tactic_notation false ~level ?deprecation prods true ids tac in List.iteri iter (List.rev prods); - (** We call [extend_atomic_tactic] only for "basic tactics" (the ones at - tactic_expr level 0) *) + (* We call [extend_atomic_tactic] only for "basic tactics" (the ones + at tactic_expr level 0) *) if Int.equal level 0 then extend_atomic_tactic name prods (**********************************************************************) @@ -474,8 +474,9 @@ let register_ltac local ?deprecation tacl = (name, body) in let defs () = - (** Register locally the tactic to handle recursivity. This function affects - the whole environment, so that we transactify it afterwards. *) + (* Register locally the tactic to handle recursivity. This + function affects the whole environment, so that we transactify + it afterwards. *) let iter_rec (sp, kn) = Tacenv.push_tactic (Nametab.Until 1) sp kn in let () = List.iter iter_rec recvars in List.map map rfun @@ -557,7 +558,7 @@ let () = register_grammars_by_name "tactic" entries let get_identifier i = - (** Workaround for badly-designed generic arguments lacking a closure *) + (* Workaround for badly-designed generic arguments lacking a closure *) Names.Id.of_string_soft (Printf.sprintf "$%i" i) type _ ty_sig = @@ -650,21 +651,23 @@ let tactic_extend plugin_name tacname ~level ?deprecation sign = in match sign with | [TyML (TyIdent (name, s),tac) as ml_tac] when only_constr s -> - (** The extension is only made of a name followed by constr entries: we do not - add any grammar nor printing rule and add it as a true Ltac definition. *) + (* The extension is only made of a name followed by constr + entries: we do not add any grammar nor printing rule and add it + as a true Ltac definition. *) let vars = mk_sign_vars 1 s in let ml = { Tacexpr.mltac_name = ml_tactic_name; Tacexpr.mltac_index = 0 } in let tac = match s with | TyNil -> eval ml_tac - (** Special handling of tactics without arguments: such tactics do not do - a Proofview.Goal.nf_enter to compute their arguments. It matters for some - whole-prof tactics like [shelve_unifiable]. *) + (* Special handling of tactics without arguments: such tactics do + not do a Proofview.Goal.nf_enter to compute their arguments. It + matters for some whole-prof tactics like [shelve_unifiable]. *) | _ -> lift_constr_tac_to_ml_tac vars (eval ml_tac) in - (** Arguments are not passed directly to the ML tactic in the TacML node, - the ML tactic retrieves its arguments in the [ist] environment instead. - This is the rôle of the [lift_constr_tac_to_ml_tac] function. *) - let body = Tacexpr.TacFun (vars, Tacexpr.TacML (Loc.tag (ml, [])))in + (* Arguments are not passed directly to the ML tactic in the TacML + node, the ML tactic retrieves its arguments in the [ist] + environment instead. This is the rôle of the + [lift_constr_tac_to_ml_tac] function. *) + let body = Tacexpr.TacFun (vars, Tacexpr.TacML (CAst.make (ml, [])))in let id = Names.Id.of_string name in let obj () = Tacenv.register_ltac true false id body ?deprecation in let () = Tacenv.register_ml_tactic ml_tactic_name [|tac|] in @@ -673,3 +676,96 @@ let tactic_extend plugin_name tacname ~level ?deprecation sign = let obj () = add_ml_tactic_notation ml_tactic_name ~level ?deprecation (List.map clause_of_ty_ml sign) in Tacenv.register_ml_tactic ml_tactic_name @@ Array.of_list (List.map eval sign); Mltop.declare_cache_obj obj plugin_name + + +(** ARGUMENT EXTEND *) + +open Geninterp + +type ('a, 'b, 'c) argument_printer = + 'a Pptactic.raw_extra_genarg_printer * + 'b Pptactic.glob_extra_genarg_printer * + 'c Pptactic.extra_genarg_printer + +type ('a, 'b) argument_intern = +| ArgInternFun : ('a, 'b) Genintern.intern_fun -> ('a, 'b) argument_intern +| ArgInternWit : ('a, 'b, 'c) Genarg.genarg_type -> ('a, 'b) argument_intern + +type 'b argument_subst = +| ArgSubstFun : 'b Genintern.subst_fun -> 'b argument_subst +| ArgSubstWit : ('a, 'b, 'c) Genarg.genarg_type -> 'b argument_subst + +type ('b, 'c) argument_interp = +| ArgInterpRet : ('c, 'c) argument_interp +| ArgInterpFun : ('b, Val.t) interp_fun -> ('b, 'c) argument_interp +| ArgInterpWit : ('a, 'b, 'r) Genarg.genarg_type -> ('b, 'c) argument_interp +| ArgInterpLegacy : + (Geninterp.interp_sign -> Goal.goal Evd.sigma -> 'b -> Evd.evar_map * 'c) -> ('b, 'c) argument_interp + +type ('a, 'b, 'c) tactic_argument = { + arg_parsing : 'a Vernacextend.argument_rule; + arg_tag : 'c Val.tag option; + arg_intern : ('a, 'b) argument_intern; + arg_subst : 'b argument_subst; + arg_interp : ('b, 'c) argument_interp; + arg_printer : ('a, 'b, 'c) argument_printer; +} + +let intern_fun (type a b c) name (arg : (a, b, c) tactic_argument) : (a, b) Genintern.intern_fun = +match arg.arg_intern with +| ArgInternFun f -> f +| ArgInternWit wit -> + fun ist v -> + let ans = Genarg.out_gen (glbwit wit) (Tacintern.intern_genarg ist (Genarg.in_gen (rawwit wit) v)) in + (ist, ans) + +let subst_fun (type a b c) (arg : (a, b, c) tactic_argument) : b Genintern.subst_fun = +match arg.arg_subst with +| ArgSubstFun f -> f +| ArgSubstWit wit -> + fun s v -> + let ans = Genarg.out_gen (glbwit wit) (Tacsubst.subst_genarg s (Genarg.in_gen (glbwit wit) v)) in + ans + +let interp_fun (type a b c) name (arg : (a, b, c) tactic_argument) (tag : c Val.tag) : (b, Val.t) interp_fun = +match arg.arg_interp with +| ArgInterpRet -> (fun ist v -> Ftactic.return (Geninterp.Val.inject tag v)) +| ArgInterpFun f -> f +| ArgInterpWit wit -> + (fun ist x -> Tacinterp.interp_genarg ist (Genarg.in_gen (glbwit wit) x)) +| ArgInterpLegacy f -> + (fun ist v -> Ftactic.enter (fun gl -> + let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in + let v = Geninterp.Val.inject tag v in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Ftactic.return v) + )) + +let argument_extend (type a b c) ~name (arg : (a, b, c) tactic_argument) = + let wit = Genarg.create_arg name in + let () = Genintern.register_intern0 wit (intern_fun name arg) in + let () = Genintern.register_subst0 wit (subst_fun arg) in + let tag = match arg.arg_tag with + | None -> + let () = register_val0 wit None in + val_tag (topwit wit) + | Some tag -> + let () = register_val0 wit (Some tag) in + tag + in + let () = register_interp0 wit (interp_fun name arg tag) in + let entry = match arg.arg_parsing with + | Vernacextend.Arg_alias e -> + let () = Pcoq.register_grammar wit e in + e + | Vernacextend.Arg_rules rules -> + let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in + let () = Pcoq.grammar_extend e None (None, [(None, None, rules)]) in + e + in + let (rpr, gpr, tpr) = arg.arg_printer in + let () = Pptactic.declare_extra_genarg_pprule wit rpr gpr tpr in + let () = create_ltac_quotation name + (fun (loc, v) -> Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v)) + (entry, None) + in + (wit, entry) diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 0b2b426018..309db539d0 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -12,7 +12,7 @@ open Vernacexpr open Tacexpr -open Vernacinterp +open Attributes (** {5 Tactic Definitions} *) @@ -70,6 +70,8 @@ val print_ltacs : unit -> unit val print_located_tactic : Libnames.qualid -> unit (** Display the absolute name of a tactic. *) +(** {5 TACTIC EXTEND} *) + type _ ty_sig = | TyNil : (Geninterp.interp_sign -> unit Proofview.tactic) ty_sig | TyIdent : string * 'r ty_sig -> 'r ty_sig @@ -79,3 +81,60 @@ type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml val tactic_extend : string -> string -> level:Int.t -> ?deprecation:deprecation -> ty_ml list -> unit + +(** {5 ARGUMENT EXTEND} *) + +(** + + This is the main entry point for the ARGUMENT EXTEND macro that allows to + easily create user-made Ltac arguments. + + + Each argument has three type parameters. See {!Genarg} for more details. + There are two kinds of Ltac arguments, uniform and non-uniform. The former + have the same type at each level (raw, glob, top) while the latter may vary. + + When declaring an argument one must provide the following data: + - Internalization : raw -> glob + - Substitution : glob -> glob + - Interpretation : glob -> Ltac dynamic value + - Printing for every level + - An optional toplevel tag of type top (with the proviso that the + interpretation function only produces values with this tag) + + This data can be either given explicitly with the [Fun] constructors, or it + can be inherited from another argument with the [Wit] constructors. + +*) + +type ('a, 'b, 'c) argument_printer = + 'a Pptactic.raw_extra_genarg_printer * + 'b Pptactic.glob_extra_genarg_printer * + 'c Pptactic.extra_genarg_printer + +type ('a, 'b) argument_intern = +| ArgInternFun : ('a, 'b) Genintern.intern_fun -> ('a, 'b) argument_intern +| ArgInternWit : ('a, 'b, 'c) Genarg.genarg_type -> ('a, 'b) argument_intern + +type 'b argument_subst = +| ArgSubstFun : 'b Genintern.subst_fun -> 'b argument_subst +| ArgSubstWit : ('a, 'b, 'c) Genarg.genarg_type -> 'b argument_subst + +type ('b, 'c) argument_interp = +| ArgInterpRet : ('c, 'c) argument_interp +| ArgInterpFun : ('b, Geninterp.Val.t) Geninterp.interp_fun -> ('b, 'c) argument_interp +| ArgInterpWit : ('a, 'b, 'r) Genarg.genarg_type -> ('b, 'c) argument_interp +| ArgInterpLegacy : + (Geninterp.interp_sign -> Goal.goal Evd.sigma -> 'b -> Evd.evar_map * 'c) -> ('b, 'c) argument_interp + +type ('a, 'b, 'c) tactic_argument = { + arg_parsing : 'a Vernacextend.argument_rule; + arg_tag : 'c Geninterp.Val.tag option; + arg_intern : ('a, 'b) argument_intern; + arg_subst : 'b argument_subst; + arg_interp : ('b, 'c) argument_interp; + arg_printer : ('a, 'b, 'c) argument_printer; +} + +val argument_extend : name:string -> ('a, 'b, 'c) tactic_argument -> + ('a, 'b, 'c) Genarg.genarg_type * 'a Pcoq.Entry.t diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index 1f2c722b34..d5f22b2c72 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -55,7 +55,7 @@ type alias = KerName.t type alias_tactic = { alias_args: Id.t list; alias_body: glob_tactic_expr; - alias_deprecation: Vernacinterp.deprecation option; + alias_deprecation: Attributes.deprecation option; } let alias_map = Summary.ref ~name:"tactic-alias" @@ -115,14 +115,13 @@ let interp_ml_tactic { mltac_name = s; mltac_index = i } = (* Summary and Object declaration *) -open Nametab open Libobject type ltac_entry = { tac_for_ml : bool; tac_body : glob_tactic_expr; tac_redef : ModPath.t list; - tac_deprecation : Vernacinterp.deprecation option + tac_deprecation : Attributes.deprecation option } let mactab = @@ -153,19 +152,19 @@ let tac_deprecation kn = let load_md i ((sp, kn), (local, id, b, t, deprecation)) = match id with | None -> - let () = if not local then push_tactic (Until i) sp kn in + let () = if not local then push_tactic (Nametab.Until i) sp kn in add ~deprecation kn b t | Some kn0 -> replace kn0 kn t let open_md i ((sp, kn), (local, id, b, t, deprecation)) = match id with | None -> - let () = if not local then push_tactic (Exactly i) sp kn in + let () = if not local then push_tactic (Nametab.Exactly i) sp kn in add ~deprecation kn b t | Some kn0 -> replace kn0 kn t let cache_md ((sp, kn), (local, id ,b, t, deprecation)) = match id with | None -> - let () = push_tactic (Until 1) sp kn in + let () = push_tactic (Nametab.Until 1) sp kn in add ~deprecation kn b t | Some kn0 -> replace kn0 kn t @@ -179,7 +178,7 @@ let subst_md (subst, (local, id, b, t, deprecation)) = let classify_md (local, _, _, _, _ as o) = Substitute o let inMD : bool * ltac_constant option * bool * glob_tactic_expr * - Vernacinterp.deprecation option -> obj = + Attributes.deprecation option -> obj = declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli index d5d36c97fa..5b98daf383 100644 --- a/plugins/ltac/tacenv.mli +++ b/plugins/ltac/tacenv.mli @@ -12,7 +12,7 @@ open Names open Libnames open Tacexpr open Geninterp -open Vernacinterp +open Attributes (** This module centralizes the various ways of registering tactics. *) @@ -33,7 +33,7 @@ type alias = KerName.t type alias_tactic = { alias_args: Id.t list; alias_body: glob_tactic_expr; - alias_deprecation: Vernacinterp.deprecation option; + alias_deprecation: deprecation option; } (** Contents of a tactic notation *) diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 8731cbf60d..30e316b36d 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -78,12 +78,12 @@ type ('a,'t) match_rule = (** Extension indentifiers for the TACTIC EXTEND mechanism. *) type ml_tactic_name = { + mltac_plugin : string; (** Name of the plugin where the tactic is defined, typically coming from a DECLARE PLUGIN statement in the source. *) - mltac_plugin : string; + mltac_tactic : string; (** Name of the tactic entry where the tactic is defined, typically found after the TACTIC EXTEND statement in the source. *) - mltac_tactic : string; } type ml_tactic_entry = { @@ -93,19 +93,8 @@ type ml_tactic_entry = { (** Composite types *) -type glob_constr_and_expr = Genintern.glob_constr_and_expr - type open_constr_expr = unit * constr_expr -type open_glob_constr = unit * glob_constr_and_expr - -type binding_bound_vars = Constr_matching.binding_bound_vars -type glob_constr_pattern_and_expr = binding_bound_vars * glob_constr_and_expr * constr_pattern - -type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a - -type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open - -type delayed_open_constr = EConstr.constr delayed_open +type open_glob_constr = unit * Genintern.glob_constr_and_expr type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list @@ -167,7 +156,7 @@ type 'a gen_tactic_arg = | TacGeneric of 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval | Reference of 'ref - | TacCall of ('ref * 'a gen_tactic_arg list) Loc.located + | TacCall of ('ref * 'a gen_tactic_arg list) CAst.t | TacFreshId of string or_var list | Tacexp of 'tacexpr | TacPretype of 'trm @@ -189,7 +178,7 @@ constraint 'a = < 'r : ltac refs, 'n : idents, 'l : levels *) and 'a gen_tactic_expr = - | TacAtom of ('a gen_atomic_tactic_expr) Loc.located + | TacAtom of ('a gen_atomic_tactic_expr) CAst.t | TacThen of 'a gen_tactic_expr * 'a gen_tactic_expr @@ -245,12 +234,12 @@ and 'a gen_tactic_expr = | TacMatchGoal of lazy_flag * direction_flag * ('p,'a gen_tactic_expr) match_rule list | TacFun of 'a gen_tactic_fun_ast - | TacArg of 'a gen_tactic_arg located + | TacArg of 'a gen_tactic_arg CAst.t | TacSelect of Goal_select.t * 'a gen_tactic_expr (* For ML extensions *) - | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located + | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) CAst.t (* For syntax extensions *) - | TacAlias of (KerName.t * 'a gen_tactic_arg list) Loc.located + | TacAlias of (KerName.t * 'a gen_tactic_arg list) CAst.t constraint 'a = < term:'t; @@ -279,9 +268,9 @@ constraint 'a = < (** Globalized tactics *) -type g_trm = glob_constr_and_expr -type g_pat = glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference Stdarg.and_short_name or_var +type g_trm = Genintern.glob_constr_and_expr +type g_pat = Genintern.glob_constr_pattern_and_expr +type g_cst = evaluable_global_reference Genredexpr.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -307,9 +296,6 @@ type glob_tactic_arg = (** Raw tactics *) -type r_trm = constr_expr -type r_pat = constr_pattern_expr -type r_cst = qualid or_by_notation type r_ref = qualid type r_nam = lident type r_lev = rlevel diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 9958d6dcda..8b6b14322b 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -78,12 +78,12 @@ type ('a,'t) match_rule = (** Extension indentifiers for the TACTIC EXTEND mechanism. *) type ml_tactic_name = { + mltac_plugin : string; (** Name of the plugin where the tactic is defined, typically coming from a DECLARE PLUGIN statement in the source. *) - mltac_plugin : string; + mltac_tactic : string; (** Name of the tactic entry where the tactic is defined, typically found after the TACTIC EXTEND statement in the source. *) - mltac_tactic : string; } type ml_tactic_entry = { @@ -92,20 +92,8 @@ type ml_tactic_entry = { } (** Composite types *) - -type glob_constr_and_expr = Genintern.glob_constr_and_expr - type open_constr_expr = unit * constr_expr -type open_glob_constr = unit * glob_constr_and_expr - -type binding_bound_vars = Constr_matching.binding_bound_vars -type glob_constr_pattern_and_expr = binding_bound_vars * glob_constr_and_expr * constr_pattern - -type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a - -type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open - -type delayed_open_constr = EConstr.constr delayed_open +type open_glob_constr = unit * Genintern.glob_constr_and_expr type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list @@ -167,7 +155,7 @@ type 'a gen_tactic_arg = | TacGeneric of 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval | Reference of 'ref - | TacCall of ('ref * 'a gen_tactic_arg list) Loc.located + | TacCall of ('ref * 'a gen_tactic_arg list) CAst.t | TacFreshId of string or_var list | Tacexp of 'tacexpr | TacPretype of 'trm @@ -189,7 +177,7 @@ constraint 'a = < 'r : ltac refs, 'n : idents, 'l : levels *) and 'a gen_tactic_expr = - | TacAtom of ('a gen_atomic_tactic_expr) Loc.located + | TacAtom of ('a gen_atomic_tactic_expr) CAst.t | TacThen of 'a gen_tactic_expr * 'a gen_tactic_expr @@ -245,12 +233,12 @@ and 'a gen_tactic_expr = | TacMatchGoal of lazy_flag * direction_flag * ('p,'a gen_tactic_expr) match_rule list | TacFun of 'a gen_tactic_fun_ast - | TacArg of 'a gen_tactic_arg located + | TacArg of 'a gen_tactic_arg CAst.t | TacSelect of Goal_select.t * 'a gen_tactic_expr (* For ML extensions *) - | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located + | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) CAst.t (* For syntax extensions *) - | TacAlias of (KerName.t * 'a gen_tactic_arg list) Loc.located + | TacAlias of (KerName.t * 'a gen_tactic_arg list) CAst.t constraint 'a = < term:'t; @@ -279,9 +267,9 @@ constraint 'a = < (** Globalized tactics *) -type g_trm = glob_constr_and_expr -type g_pat = glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference Stdarg.and_short_name or_var +type g_trm = Genintern.glob_constr_and_expr +type g_pat = Genintern.glob_constr_pattern_and_expr +type g_cst = evaluable_global_reference Genredexpr.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -307,9 +295,6 @@ type glob_tactic_arg = (** Raw tactics *) -type r_trm = constr_expr -type r_pat = constr_pattern_expr -type r_cst = qualid or_by_notation type r_ref = qualid type r_nam = lident type r_lev = rlevel diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 5501cf92a5..543d4de0fe 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -19,7 +19,6 @@ open Util open Names open Libnames open Globnames -open Nametab open Smartlocate open Constrexpr open Termops @@ -45,9 +44,9 @@ type glob_sign = Genintern.glob_sign = { (* ltac variables and the subset of vars introduced by Intro/Let/... *) genv : Environ.env; extra : Genintern.Store.t; + intern_sign : Genintern.intern_variable_status; } -let fully_empty_glob_sign = Genintern.empty_glob_sign Environ.empty_env let make_empty_glob_sign () = Genintern.empty_glob_sign (Global.env ()) (* We have identifier <| global_reference <| constr *) @@ -84,7 +83,8 @@ let intern_hyp ist ({loc;v=id} as locid) = else if find_ident id ist then make id else - Pretype_errors.error_var_not_found ?loc id + CErrors.user_err ?loc Pp.(str "Hypothesis" ++ spc () ++ Id.print id ++ spc() ++ + str "was not found in the current environment.") let intern_or_var f ist = function | ArgVar locid -> ArgVar (intern_hyp ist locid) @@ -98,7 +98,7 @@ let intern_global_reference ist qid = ArgVar (make ?loc:qid.CAst.loc @@ qualid_basename qid) else try ArgArg (qid.CAst.loc,locate_global_with_alias qid) - with Not_found -> error_global_not_found qid + with Not_found -> Nametab.error_global_not_found qid let intern_ltac_variable ist qid = if qualid_is_ident qid && find_var (qualid_basename qid) ist then @@ -122,22 +122,22 @@ let warn_deprecated_tactic = CWarnings.create ~name:"deprecated-tactic" ~category:"deprecated" (fun (qid,depr) -> str "Tactic " ++ pr_qualid qid ++ strbrk " is deprecated" ++ - pr_opt (fun since -> str "since " ++ str since) depr.Vernacinterp.since ++ - str "." ++ pr_opt (fun note -> str note) depr.Vernacinterp.note) + pr_opt (fun since -> str "since " ++ str since) depr.Attributes.since ++ + str "." ++ pr_opt (fun note -> str note) depr.Attributes.note) let warn_deprecated_alias = CWarnings.create ~name:"deprecated-tactic-notation" ~category:"deprecated" (fun (kn,depr) -> str "Tactic Notation " ++ Pptactic.pr_alias_key kn ++ strbrk " is deprecated since" ++ - pr_opt (fun since -> str "since " ++ str since) depr.Vernacinterp.since ++ - str "." ++ pr_opt (fun note -> str note) depr.Vernacinterp.note) + pr_opt (fun since -> str "since " ++ str since) depr.Attributes.since ++ + str "." ++ pr_opt (fun note -> str note) depr.Attributes.note) let intern_isolated_global_tactic_reference qid = let loc = qid.CAst.loc in let kn = Tacenv.locate_tactic qid in Option.iter (fun depr -> warn_deprecated_tactic ?loc (qid,depr)) @@ Tacenv.tac_deprecation kn; - TacCall (Loc.tag ?loc (ArgArg (loc,kn),[])) + TacCall (CAst.make ?loc (ArgArg (loc,kn),[])) let intern_isolated_tactic_reference strict ist qid = (* An ltac reference *) @@ -150,7 +150,7 @@ let intern_isolated_tactic_reference strict ist qid = try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist qid)) with Not_found -> (* Reference not found *) - error_global_not_found qid + Nametab.error_global_not_found qid (* Internalize an applied tactic reference *) @@ -169,7 +169,7 @@ let intern_applied_tactic_reference ist qid = try intern_applied_global_tactic_reference qid with Not_found -> (* Reference not found *) - error_global_not_found qid + Nametab.error_global_not_found qid (* Intern a reference parsed in a non-tactic entry *) @@ -190,7 +190,7 @@ let intern_non_tactic_reference strict ist qid = TacGeneric ipat else (* Reference not found *) - error_global_not_found qid + Nametab.error_global_not_found qid let intern_message_token ist = function | (MsgString _ | MsgInt _ as x) -> x @@ -210,7 +210,7 @@ let intern_binding_name ist x = and if a term w/o ltac vars, check the name is indeed quantified *) x -let intern_constr_gen pattern_mode isarity {ltacvars=lfun; genv=env; extra} c = +let intern_constr_gen pattern_mode isarity {ltacvars=lfun; genv=env; extra; intern_sign} c = let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in let ltacvars = { @@ -219,7 +219,7 @@ let intern_constr_gen pattern_mode isarity {ltacvars=lfun; genv=env; extra} c = ltac_extra = extra; } in let c' = - warn (Constrintern.intern_gen scope ~pattern_mode ~ltacvars env Evd.(from_env env)) c + warn (Constrintern.intern_core scope ~pattern_mode ~ltacvars env Evd.(from_env env) intern_sign) c in (c',if !strict_check then None else Some c) @@ -302,7 +302,7 @@ let intern_evaluable_global_reference ist qid = try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true qid) with Not_found -> if qualid_is_ident qid && not !strict_check then EvalVarRef (qualid_basename qid) - else error_global_not_found qid + else Nametab.error_global_not_found qid let intern_evaluable_reference_or_by_notation ist = function | {v=AN r} -> intern_evaluable_global_reference ist r @@ -377,7 +377,7 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = subterm matched when a pattern *) let r = match r with | {v=AN r} -> r - | {loc} -> (qualid_of_path ?loc (path_of_global (smart_global r))) in + | {loc} -> (qualid_of_path ?loc (Nametab.path_of_global (smart_global r))) in let sign = { Constrintern.ltac_vars = ist.ltacvars; ltac_bound = Id.Set.empty; @@ -557,7 +557,7 @@ let rec intern_atomic lf ist x = | _ -> false in let is_onconcl = match cl.concl_occs with - | AllOccurrences | NoOccurrences -> true + | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in TacChange (None, @@ -587,10 +587,10 @@ let rec intern_atomic lf ist x = and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac) and intern_tactic_seq onlytac ist = function - | TacAtom (loc,t) -> + | TacAtom { loc; v=t } -> let lf = ref ist.ltacvars in let t = intern_atomic lf ist t in - !lf, TacAtom (Loc.tag ?loc:(adjust_loc loc) t) + !lf, TacAtom (CAst.make ?loc:(adjust_loc loc) t) | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun) | TacLetIn (isrec,l,u) -> let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in @@ -659,27 +659,27 @@ and intern_tactic_seq onlytac ist = function | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l) | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l) | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac) - | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a + | TacArg { loc; v=a } -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a | TacSelect (sel, tac) -> ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac) (* For extensions *) - | TacAlias (loc,(s,l)) -> + | TacAlias { loc; v=(s,l) } -> let alias = Tacenv.interp_alias s in Option.iter (fun o -> warn_deprecated_alias ?loc (s,o)) @@ alias.Tacenv.alias_deprecation; let l = List.map (intern_tacarg !strict_check false ist) l in - ist.ltacvars, TacAlias (Loc.tag ?loc (s,l)) - | TacML (loc,(opn,l)) -> + ist.ltacvars, TacAlias (CAst.make ?loc (s,l)) + | TacML { loc; v=(opn,l) } -> let _ignore = Tacenv.interp_ml_tactic opn in - ist.ltacvars, TacML (loc, (opn,List.map (intern_tacarg !strict_check false ist) l)) + ist.ltacvars, TacML CAst.(make ?loc (opn,List.map (intern_tacarg !strict_check false ist) l)) and intern_tactic_as_arg loc onlytac ist a = match intern_tacarg !strict_check onlytac ist a with | TacCall _ | Reference _ - | TacGeneric _ as a -> TacArg (loc,a) + | TacGeneric _ as a -> TacArg CAst.(make ?loc a) | Tacexp a -> a | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> - if onlytac then error_tactic_expected ?loc else TacArg (loc,a) + if onlytac then error_tactic_expected ?loc else TacArg CAst.(make ?loc a) and intern_tactic_or_tacarg ist = intern_tactic false ist @@ -692,9 +692,9 @@ and intern_tactic_fun ist (var,body) = and intern_tacarg strict onlytac ist = function | Reference r -> intern_non_tactic_reference strict ist r | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) - | TacCall (loc,(f,[])) -> intern_isolated_tactic_reference strict ist f - | TacCall (loc,(f,l)) -> - TacCall (Loc.tag ?loc ( + | TacCall { loc; v=(f,[]) } -> intern_isolated_tactic_reference strict ist f + | TacCall { loc; v=(f,l) } -> + TacCall (CAst.make ?loc ( intern_applied_tactic_reference ist f, List.map (intern_tacarg !strict_check false ist) l)) | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x) @@ -843,8 +843,9 @@ let notation_subst bindings tac = (make ?loc @@ Name id, c) :: accu in let bindings = Id.Map.fold fold bindings [] in - (** This is theoretically not correct due to potential variable capture, but - Ltac has no true variables so one cannot simply substitute *) + (* This is theoretically not correct due to potential variable + capture, but Ltac has no true variables so one cannot simply + substitute *) TacLetIn (false, bindings, tac) let () = Genintern.register_ntn_subst0 wit_tactic notation_subst diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli index 9146fced2d..978ad4dd24 100644 --- a/plugins/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli @@ -12,6 +12,7 @@ open Names open Tacexpr open Genarg open Constrexpr +open Genintern open Tactypes (** Globalization of tactic expressions : @@ -21,12 +22,11 @@ type glob_sign = Genintern.glob_sign = { ltacvars : Id.Set.t; genv : Environ.env; extra : Genintern.Store.t; + intern_sign : Genintern.intern_variable_status; } -val fully_empty_glob_sign : glob_sign - val make_empty_glob_sign : unit -> glob_sign - (** same as [fully_empty_glob_sign], but with [Global.env()] as + (** build an empty [glob_sign] using [Global.env()] as environment *) (** Main globalization functions *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index f90e889678..4398fb14ab 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -23,7 +23,6 @@ open Names open Nameops open Libnames open Globnames -open Nametab open Refiner open Tacmach.New open Tactic_debug @@ -51,7 +50,7 @@ let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v w let Val.Dyn (t, _) = v in let t' = match val_tag wit with | Val.Base t' -> t' - | _ -> assert false (** not used in this module *) + | _ -> assert false (* not used in this module *) in match Val.eq t t' with | None -> false @@ -69,13 +68,13 @@ let in_list tag v = let in_gen wit v = let t = match val_tag wit with | Val.Base t -> t - | _ -> assert false (** not used in this module *) + | _ -> assert false (* not used in this module *) in Val.Dyn (t, v) let out_gen wit v = let t = match val_tag wit with | Val.Base t -> t - | _ -> assert false (** not used in this module *) + | _ -> assert false (* not used in this module *) in match prj t v with None -> assert false | Some x -> x @@ -105,7 +104,7 @@ let pr_appl h vs = let rec name_with_list appl t = match appl with | [] -> t - | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t) + | (h,vs)::l -> Proofview.Trace.name_tactic (fun _ _ -> pr_appl h vs) (name_with_list l t) let name_if_glob appl t = match appl with | UnnamedAppl -> t @@ -118,9 +117,14 @@ let combine_appl appl1 appl2 = let of_tacvalue v = in_gen (topwit wit_tacvalue) v let to_tacvalue v = out_gen (topwit wit_tacvalue) v +let log_trace = ref false + +let is_traced () = + !log_trace || !Flags.profile_ltac + (** More naming applications *) let name_vfun appl vle = - if has_type vle (topwit wit_tacvalue) then + if is_traced () && has_type vle (topwit wit_tacvalue) then match to_tacvalue vle with | VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t)) | _ -> vle @@ -134,13 +138,16 @@ let f_debug : debug_info TacStore.field = TacStore.field () let f_trace : ltac_trace TacStore.field = TacStore.field () (* Signature for interpretation: val_interp and interpretation functions *) -type interp_sign = Geninterp.interp_sign = { - lfun : value Id.Map.t; - extra : TacStore.t } - -let extract_trace ist = match TacStore.get ist.extra f_trace with -| None -> [] -| Some l -> l +type interp_sign = Geninterp.interp_sign = + { lfun : value Id.Map.t + ; poly : bool + ; extra : TacStore.t } + +let extract_trace ist = + if is_traced () then match TacStore.get ist.extra f_trace with + | None -> [] + | Some l -> l + else [] let print_top_val env v = Pptactic.pr_value Pptactic.ltop v @@ -162,8 +169,11 @@ let catch_error call_trace f x = let e = CErrors.push e in catching_error call_trace iraise e +let wrap_error tac k = + if is_traced () then Proofview.tclORELSE tac k else tac + let catch_error_tac call_trace tac = - Proofview.tclORELSE + wrap_error tac (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) @@ -204,9 +214,11 @@ let constr_of_id env id = (** Generic arguments : table of interpretation functions *) (* Some of the code further down depends on the fact that push_trace does not modify sigma (the evar map) *) -let push_trace call ist = match TacStore.get ist.extra f_trace with -| None -> Proofview.tclUNIT [call] -| Some trace -> Proofview.tclUNIT (call :: trace) +let push_trace call ist = + if is_traced () then match TacStore.get ist.extra f_trace with + | None -> Proofview.tclUNIT [call] + | Some trace -> Proofview.tclUNIT (call :: trace) + else Proofview.tclUNIT [] let propagate_trace ist loc id v = if has_type v (topwit wit_tacvalue) then @@ -358,7 +370,7 @@ let interp_reference ist env sigma = function with Not_found -> try VarRef (get_id (Environ.lookup_named id env)) - with Not_found -> error_global_not_found (qualid_of_ident ?loc id) + with Not_found -> Nametab.error_global_not_found (qualid_of_ident ?loc id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in @@ -374,14 +386,14 @@ let interp_evaluable ist env sigma = function with Not_found -> match r with | EvalConstRef _ -> r - | _ -> error_global_not_found (qualid_of_ident ?loc id) + | _ -> Nametab.error_global_not_found (qualid_of_ident ?loc id) end | ArgArg (r,None) -> r | ArgVar {loc;v=id} -> try try_interp_ltac_var (coerce_to_evaluable_ref env sigma) ist (Some (env,sigma)) (make ?loc id) with Not_found -> try try_interp_evaluable env (loc, id) - with Not_found -> error_global_not_found (qualid_of_ident ?loc id) + with Not_found -> Nametab.error_global_not_found (qualid_of_ident ?loc id) (* Interprets an hypothesis name *) let interp_occurrences ist occs = @@ -531,7 +543,10 @@ let interp_gen kind ist pattern_mode flags env sigma c = invariant that running the tactic returned by push_trace does not modify sigma. *) let (_, dummy_proofview) = Proofview.init sigma [] in - let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr term,LtacConstrInterp (term,vars)) ist) dummy_proofview in + + (* Again this is called at times with no open proof! *) + let name, poly = Id.of_string "tacinterp", ist.poly in + let (trace,_,_,_) = Proofview.apply ~name ~poly env (push_trace (loc_of_glob_constr term,LtacConstrInterp (term,vars)) ist) dummy_proofview in let (evd,c) = catch_error trace (understand_ltac flags env sigma vars kind) term in @@ -544,13 +559,16 @@ let interp_gen kind ist pattern_mode flags env sigma c = let constr_flags () = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = true; - expand_evars = true } + expand_evars = true; + program_mode = false; + polymorphic = false; +} (* Interprets a constr; expects evars to be solved *) let interp_constr_gen kind ist env sigma c = - interp_gen kind ist false (constr_flags ()) env sigma c + let flags = { (constr_flags ()) with polymorphic = ist.Geninterp.poly } in + interp_gen kind ist false flags env sigma c let interp_constr = interp_constr_gen WithoutTypeConstraint @@ -559,23 +577,29 @@ let interp_type = interp_constr_gen IsType let open_constr_use_classes_flags () = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; - expand_evars = true } + expand_evars = true; + program_mode = false; + polymorphic = false; +} let open_constr_no_classes_flags () = { use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; - expand_evars = true } + expand_evars = true; + program_mode = false; + polymorphic = false; +} let pure_open_constr_flags = { use_typeclasses = false; solve_unification_constraints = true; - use_hook = None; fail_evar = false; - expand_evars = false } + expand_evars = false; + program_mode = false; + polymorphic = false; +} (* Interprets an open constr *) let interp_open_constr ?(expected_type=WithoutTypeConstraint) ?(flags=open_constr_no_classes_flags ()) ist env sigma c = @@ -590,8 +614,8 @@ let interp_pure_open_constr ist = let interp_typed_pattern ist env sigma (_,c,_) = let sigma, c = interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in - (** FIXME: it is necessary to be unsafe here because of the way we handle - evars in the pretyper. Sometimes they get solved eagerly. *) + (* FIXME: it is necessary to be unsafe here because of the way we handle + evars in the pretyper. Sometimes they get solved eagerly. *) pattern_of_constr env sigma (EConstr.Unsafe.to_constr c) (* Interprets a constr expression *) @@ -640,7 +664,7 @@ let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = Inr (pattern_of_constr env sigma (EConstr.to_constr sigma c)) in (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (make ?loc id) with Not_found -> - error_global_not_found (qualid_of_ident ?loc id)) + Nametab.error_global_not_found (qualid_of_ident ?loc id)) | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) | Inr c -> Inr (interp_typed_pattern ist env sigma c) in interp_occurrences ist occs, p @@ -687,7 +711,7 @@ let interp_may_eval f ist env sigma = function | ConstrContext ({loc;v=s},c) -> (try let (sigma,ic) = f ist env sigma c in - let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in + let ctxt = try_interp_ltac_var coerce_to_constr_context ist (Some (env, sigma)) (make ?loc s) in let ctxt = EConstr.Unsafe.to_constr ctxt in let ic = EConstr.Unsafe.to_constr ic in let c = subst_meta [Constr_matching.special_meta,ic] ctxt in @@ -902,7 +926,7 @@ let interp_destruction_arg ist gl arg = end) in try - (** FIXME: should be moved to taccoerce *) + (* FIXME: should be moved to taccoerce *) let v = Id.Map.find id ist.lfun in if has_type v (topwit wit_intro_pattern) then let v = out_gen (topwit wit_intro_pattern) v in @@ -988,7 +1012,7 @@ let rec read_match_rule lfun ist env sigma = function | [] -> [] (* Fully evaluate an untyped constr *) -let type_uconstr ?(flags = {(constr_flags ()) with use_hook = None }) +let type_uconstr ?(flags = (constr_flags ())) ?(expected_type = WithoutTypeConstraint) ist c = begin fun env sigma -> let { closure; term } = c in @@ -998,6 +1022,7 @@ let type_uconstr ?(flags = {(constr_flags ()) with use_hook = None }) ltac_idents = closure.idents; ltac_genargs = Id.Map.empty; } in + let flags = { flags with polymorphic = ist.Geninterp.poly } in understand_ltac flags env sigma vars expected_type term end @@ -1023,9 +1048,9 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti | TacLetIn (false,l,u) -> interp_letin ist l u | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr - | TacArg (loc,a) -> interp_tacarg ist a + | TacArg {loc;v} -> interp_tacarg ist v | t -> - (** Delayed evaluation *) + (* Delayed evaluation *) Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) in let open Ftactic in @@ -1041,7 +1066,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti and eval_tactic ist tac : unit Proofview.tactic = match tac with - | TacAtom (loc,t) -> + | TacAtom {loc;v=t} -> let call = LtacAtomCall t in push_trace(loc,call) ist >>= fun trace -> Profile_ltac.do_profile "eval_tactic:2" trace @@ -1055,7 +1080,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with return (hov 0 msg , hov 0 msg) in let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in - let log (msg,_) = Proofview.Trace.log (fun () -> msg) in + let log (msg,_) = Proofview.Trace.log (fun _ _ -> msg) in let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in Ftactic.run msgnl begin fun msgnl -> print msgnl <*> log msgnl <*> break @@ -1079,7 +1104,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with push_trace(None,call) ist >>= fun trace -> Profile_ltac.do_profile "eval_tactic:TacAbstract" trace (catch_error_tac trace begin - Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT + Proofview.Goal.enter begin fun gl -> Abstract.tclABSTRACT (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist t) end end) | TacThen (t1,t) -> @@ -1121,8 +1146,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with eval_tactic ist tac | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) (* For extensions *) - | TacAlias (loc,(s,l)) -> + | TacAlias {loc; v=(s,l)} -> let alias = Tacenv.interp_alias s in + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in let tac l = @@ -1130,14 +1156,15 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let lfun = List.fold_right2 addvar alias.Tacenv.alias_args l ist.lfun in Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace trace; } in + lfun + ; poly + ; extra = TacStore.set ist.extra f_trace trace } in val_interp ist alias.Tacenv.alias_body >>= fun v -> Ftactic.lift (tactic_of_value ist v) in let tac = Ftactic.with_env interp_vars >>= fun (env, lr) -> - let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in + let name _ _ = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in Proofview.Trace.name_tactic name (tac lr) (* spiwack: this use of name_tactic is not robust to a change of implementation of [Ftactic]. In such a situation, @@ -1152,13 +1179,13 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with in Ftactic.run tac (fun () -> Proofview.tclUNIT ()) - | TacML (loc,(opn,l)) -> + | TacML {loc; v=(opn,l)} -> push_trace (Loc.tag ?loc @@ LtacMLCall tac) ist >>= fun trace -> let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in let tac = Tacenv.interp_ml_tactic opn in let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in let tac args = - let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in + let name _ _ = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) in Ftactic.run args tac @@ -1184,12 +1211,13 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v end | ArgArg (loc,r) -> + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let ids = extract_ids [] ist.lfun Id.Set.empty in let loc_info = (Option.default loc loc',LtacNameCall r) in let extra = TacStore.set ist.extra f_avoid_ids ids in push_trace loc_info ist >>= fun trace -> let extra = TacStore.set extra f_trace trace in - let ist = { lfun = Id.Map.empty; extra = extra; } in + let ist = { lfun = Id.Map.empty; poly; extra } in let appl = GlbAppl[r,[]] in Profile_ltac.do_profile "interp_ltac_reference" trace ~count_call:false (val_interp ~appl ist (Tacenv.interp_ltac r)) @@ -1206,9 +1234,9 @@ and interp_tacarg ist arg : Val.t Ftactic.t = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Ftactic.return (Value.of_constr c_interp)) end - | TacCall (loc,(r,[])) -> + | TacCall { v=(r,[]) } -> interp_ltac_reference true ist r - | TacCall (loc,(f,l)) -> + | TacCall { loc; v=(f,l) } -> let (>>=) = Ftactic.bind in interp_ltac_reference true ist f >>= fun fv -> Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> @@ -1237,6 +1265,7 @@ and interp_tacarg ist arg : Val.t Ftactic.t = (* Interprets an application node *) and interp_app loc ist fv largs : Val.t Ftactic.t = + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in if has_type fv (topwit wit_tacvalue) then @@ -1252,11 +1281,13 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = let fold accu (id, v) = Id.Map.add id v accu in let newlfun = List.fold_left fold olfun extfun in if List.is_empty lvar then - begin Proofview.tclORELSE + begin wrap_error begin - let ist = { - lfun = newlfun; - extra = TacStore.set ist.extra f_trace []; } in + let ist = + { lfun = newlfun + ; poly + ; extra = TacStore.set ist.extra f_trace [] + } in Profile_ltac.do_profile "interp_app" trace ~count_call:false (catch_error_tac trace (val_interp ist body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) @@ -1294,8 +1325,10 @@ and tactic_of_value ist vle = if has_type vle (topwit wit_tacvalue) then match to_tacvalue vle with | VFun (appl,trace,lfun,[],t) -> + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let ist = { lfun = lfun; + poly; extra = TacStore.set ist.extra f_trace []; } in let tac = name_if_glob appl (eval_tactic ist t) in Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) @@ -1342,7 +1375,7 @@ and interp_letrec ist llc u = Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *) let lref = ref ist.lfun in let fold accu ({v=na}, b) = - let v = of_tacvalue (VRec (lref, TacArg (Loc.tag b))) in + let v = of_tacvalue (VRec (lref, TacArg (CAst.make b))) in Name.fold_right (fun id -> Id.Map.add id v) na accu in let lfun = List.fold_left fold ist.lfun llc in @@ -1365,6 +1398,7 @@ and interp_letin ist llc u = (** [interp_match_success lz ist succ] interprets a single matching success (of type {!Tactic_matching.t}). *) and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in let lctxt = Id.Map.map interp_context context in let hyp_subst = Id.Map.map Value.of_constr terms in @@ -1373,9 +1407,11 @@ and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = val_interp ist lhs >>= fun v -> if has_type v (topwit wit_tacvalue) then match to_tacvalue v with | VFun (appl,trace,lfun,[],t) -> - let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace trace; } in + let ist = + { lfun = lfun + ; poly + ; extra = TacStore.set ist.extra f_trace trace + } in let tac = eval_tactic ist t in let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy)) @@ -1401,18 +1437,18 @@ and interp_match_successes lz ist s = general | Select -> begin - (** Only keep the first matching result, we don't backtrack on it *) + (* Only keep the first matching result, we don't backtrack on it *) let s = Proofview.tclONCE s in s >>= fun ans -> interp_match_success ist ans end | Once -> - (** Once a tactic has succeeded, do not backtrack anymore *) + (* Once a tactic has succeeded, do not backtrack anymore *) Proofview.tclONCE general (* Interprets the Match expressions *) and interp_match ist lz constr lmr = let (>>=) = Ftactic.bind in - begin Proofview.tclORELSE + begin wrap_error (interp_ltac_constr ist constr) begin function | (e, info) -> @@ -1443,7 +1479,7 @@ and interp_match_goal ist lz lr lmr = (* Interprets extended tactic generic arguments *) and interp_genarg ist x : Val.t Ftactic.t = let open Ftactic.Notations in - (** Ad-hoc handling of some types. *) + (* Ad-hoc handling of some types. *) let tag = genarg_tag x in if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then interp_genarg_var_list ist x @@ -1498,7 +1534,7 @@ and interp_genarg_var_list ist x = (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist e : EConstr.t Ftactic.t = let (>>=) = Ftactic.bind in - begin Proofview.tclORELSE + begin wrap_error (val_interp ist e) begin function (err, info) -> match err with | Not_found -> @@ -1544,7 +1580,7 @@ and name_atomic ?env tacexpr tac : unit Proofview.tactic = | None -> Proofview.tclENV end >>= fun env -> Proofview.tclEVARMAP >>= fun sigma -> - let name () = Pptactic.pr_atomic_tactic env sigma tacexpr in + let name _ _ = Pptactic.pr_atomic_tactic env sigma tacexpr in Proofview.Trace.name_tactic name tac (* Interprets a primitive tactic *) @@ -1565,7 +1601,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacApply (a,ev,cb,cl) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<apply>") begin Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in @@ -1606,7 +1642,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<mutual fix>") begin Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = @@ -1621,7 +1657,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<mutual cofix>") begin Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,c) = @@ -1736,14 +1772,14 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacChange (None,c,cl) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> let is_onhyps = match cl.onhyps with | None | Some [] -> true | _ -> false in let is_onconcl = match cl.concl_occs with - | AllOccurrences | NoOccurrences -> true + | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in let c_interp patvars env sigma = @@ -1761,7 +1797,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacChange (Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in @@ -1849,7 +1885,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let default_ist () = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in - { lfun = Id.Map.empty; extra = extra } + { lfun = Id.Map.empty; poly = false; extra = extra } let eval_tactic t = Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *) @@ -1880,7 +1916,7 @@ module Value = struct let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in let lfun = Id.Map.add (Id.of_string "F") f lfun in let ist = { (default_ist ()) with lfun = lfun; } in - let tac = TacArg(Loc.tag @@ TacCall (Loc.tag (ArgVar CAst.(make @@ Id.of_string "F"),args))) in + let tac = TacArg(CAst.make @@ TacCall (CAst.make (ArgVar CAst.(make @@ Id.of_string "F"),args))) in eval_tactic_ist ist tac end @@ -1889,11 +1925,12 @@ end let interp_tac_gen lfun avoid_ids debug t = + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let extra = TacStore.set TacStore.empty f_debug debug in let extra = TacStore.set extra f_avoid_ids avoid_ids in - let ist = { lfun = lfun; extra = extra } in + let ist = { lfun; poly; extra } in let ltacvars = Id.Map.domain lfun in interp_tactic ist (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars } t) @@ -1962,7 +1999,9 @@ let lifts f = (); fun ist x -> Ftactic.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let (sigma, v) = f ist env sigma x in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (Ftactic.return v) + (* FIXME once we don't need to catch side effects *) + (Proofview.tclTHEN (Proofview.Unsafe.tclSETENV (Global.env())) + (Ftactic.return v)) end let interp_bindings' ist bl = Ftactic.return begin fun env sigma -> @@ -2025,18 +2064,23 @@ let interp_ltac_constr ist c k = Ftactic.run (interp_ltac_constr ist c) k let interp_redexp env sigma r = let ist = default_ist () in - let gist = { fully_empty_glob_sign with genv = env; } in + let gist = Genintern.empty_glob_sign env in interp_red_expr ist env sigma (intern_red_expr gist r) (***************************************************************************) (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = - let eval lfun env sigma ty tac = + let eval lfun poly env sigma ty tac = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in - let ist = { lfun = lfun; extra; } in + let ist = { lfun; poly; extra; } in let tac = interp_tactic ist tac in - let (c, sigma) = Pfedit.refine_by_tactic env sigma ty tac in + (* EJGA: We sould also pass the proof name if desired, for now + poly seems like enough to get reasonable behavior in practice + *) + let name, poly = Id.of_string "ltac_gen", poly in + let name, poly = Id.of_string "ltac_gen", poly in + let (c, sigma) = Pfedit.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in GlobEnv.register_constr_interp0 wit_tactic eval @@ -2044,7 +2088,7 @@ let _ = let vernac_debug b = set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) -let _ = +let () = let open Goptions in declare_bool_option { optdepr = false; @@ -2053,13 +2097,13 @@ let _ = optread = (fun () -> get_debug () != Tactic_debug.DebugOff); optwrite = vernac_debug } -let _ = +let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "Ltac debug"; - optkey = ["Debug";"Ltac"]; - optread = (fun () -> get_debug () != Tactic_debug.DebugOff); - optwrite = vernac_debug } + optname = "Ltac Backtrace"; + optkey = ["Ltac"; "Backtrace"]; + optread = (fun () -> !log_trace); + optwrite = (fun b -> log_trace := b) } let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index f9883e4441..22a092fa8b 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -39,9 +39,12 @@ module TacStore : Store.S with and type 'a field = 'a Geninterp.TacStore.field (** Signature for interpretation: val\_interp and interpretation functions *) -type interp_sign = Geninterp.interp_sign = { - lfun : value Id.Map.t; - extra : TacStore.t } +type interp_sign = Geninterp.interp_sign = + { lfun : value Id.Map.t + ; poly : bool + ; extra : TacStore.t } + +open Genintern val f_avoid_ids : Id.Set.t TacStore.field val f_debug : debug_info TacStore.field diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 4626378db6..caaa547a07 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -88,20 +88,9 @@ let subst_reference subst = (*CSC: subst_global_reference is used "only" for RefArgType, that propagates to the syntactic non-terminals "global", used in commands such as Print. It is also used for non-evaluable references. *) -open Pp -open Printer let subst_global_reference subst = - let subst_global ref = - let ref',t' = subst_global subst ref in - if not (is_global ref' t') then - (let sigma, env = Pfedit.get_current_context () in - Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ - str " expanded to \"" ++ pr_lconstr_env env sigma t' ++ str "\", but to " ++ - pr_global ref')); - ref' - in - subst_or_var (subst_located subst_global) + subst_or_var (subst_located (subst_global_reference subst)) let subst_evaluable subst = let subst_eval_ref = subst_evaluable_reference subst in @@ -184,7 +173,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp) and subst_tactic subst (t:glob_tactic_expr) = match t with - | TacAtom (_loc,t) -> TacAtom (Loc.tag @@ subst_atomic subst t) + | TacAtom { CAst.v=t } -> TacAtom (CAst.make @@ subst_atomic subst t) | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun) | TacLetIn (r,l,u) -> let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in @@ -231,22 +220,22 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) | TacComplete tac -> TacComplete (subst_tactic subst tac) - | TacArg (_,a) -> TacArg (Loc.tag @@ subst_tacarg subst a) + | TacArg { CAst.v=a } -> TacArg (CAst.make @@ subst_tacarg subst a) | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac) (* For extensions *) - | TacAlias (_,(s,l)) -> + | TacAlias { CAst.v=(s,l) } -> let s = subst_kn subst s in - TacAlias (Loc.tag (s,List.map (subst_tacarg subst) l)) - | TacML (loc,(opn,l)) -> TacML (loc, (opn,List.map (subst_tacarg subst) l)) + TacAlias (CAst.make (s,List.map (subst_tacarg subst) l)) + | TacML { CAst.loc; v=(opn,l)} -> TacML CAst.(make ?loc (opn,List.map (subst_tacarg subst) l)) and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) and subst_tacarg subst = function | Reference r -> Reference (subst_reference subst r) | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) - | TacCall (loc,(f,l)) -> - TacCall (Loc.tag ?loc (subst_reference subst f, List.map (subst_tacarg subst) l)) + | TacCall { CAst.loc; v=(f,l) } -> + TacCall CAst.(make ?loc (subst_reference subst f, List.map (subst_tacarg subst) l)) | TacFreshId _ as x -> x | TacPretype c -> TacPretype (subst_glob_constr subst c) | TacNumgoals -> TacNumgoals diff --git a/plugins/ltac/tacsubst.mli b/plugins/ltac/tacsubst.mli index d406686c56..4487604dca 100644 --- a/plugins/ltac/tacsubst.mli +++ b/plugins/ltac/tacsubst.mli @@ -11,6 +11,7 @@ open Tacexpr open Mod_subst open Genarg +open Genintern open Tactypes (** Substitution of tactics at module closing time *) diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 6bab8d0353..04f3116664 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -19,11 +19,9 @@ let prtac x = Pptactic.pr_glob_tactic (Global.env()) x let prmatchpatt env sigma hyp = Pptactic.pr_match_pattern (Printer.pr_constr_pattern_env env sigma) hyp -let prmatchrl rl = +let prmatchrl env sigma rl = Pptactic.pr_match_rule false (Pptactic.pr_glob_tactic (Global.env())) - (fun (_,p) -> - let sigma, env = Pfedit.get_current_context () in - Printer.pr_constr_pattern_env env sigma p) rl + (fun (_,p) -> Printer.pr_constr_pattern_env env sigma p) rl (* This module intends to be a beginning of debugger for tactic expressions. Currently, it is quite simple and we can hope to have, in the future, a more @@ -89,7 +87,7 @@ let batch = ref false open Goptions -let _ = +let () = declare_bool_option { optdepr = false; optname = "Ltac batch debug"; @@ -246,13 +244,13 @@ let db_constr debug env sigma c = else return () (* Prints the pattern rule *) -let db_pattern_rule debug num r = +let db_pattern_rule debug env sigma num r = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then begin msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ - str "|" ++ spc () ++ prmatchrl r) + str "|" ++ spc () ++ prmatchrl env sigma r) end else return () @@ -365,14 +363,17 @@ let explain_ltac_call_trace last trace loc = Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" | Tacexpr.LtacAtomCall te -> quote (Pptactic.pr_glob_tactic (Global.env()) - (Tacexpr.TacAtom (Loc.tag te))) + (Tacexpr.TacAtom (CAst.make te))) | Tacexpr.LtacConstrInterp (c, { Ltac_pretype.ltac_constrs = vars }) -> quote (Printer.pr_glob_constr_env (Global.env()) c) ++ (if not (Id.Map.is_empty vars) then strbrk " (with " ++ prlist_with_sep pr_comma (fun (id,c) -> - let sigma, env = Pfedit.get_current_context () in + (* XXX: This hooks into the ExplainErr extension API + so it is tricky to provide the right env for now. *) + let env = Global.env () in + let sigma = Evd.from_env env in Id.print id ++ str ":=" ++ Printer.pr_lconstr_under_binders_env env sigma c) (List.rev (Id.Map.bindings vars)) ++ str ")" else mt()) diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli index 175341df09..74ea4e6b74 100644 --- a/plugins/ltac/tactic_debug.mli +++ b/plugins/ltac/tactic_debug.mli @@ -40,7 +40,7 @@ val db_constr : debug_info -> env -> evar_map -> constr -> unit Proofview.NonLog (** Prints the pattern rule *) val db_pattern_rule : - debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t + debug_info -> env -> evar_map -> int -> (Genintern.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t (** Prints a matched hypothesis *) val db_matched_hyp : diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index c949589e22..2b5e496168 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -12,6 +12,7 @@ (lazy)match and (lazy)match goal. *) open Names +open Context open Tacexpr open Context.Named.Declaration @@ -59,7 +60,7 @@ let id_map_try_add_name id x m = the binding of the right-hand argument shadows that of the left-hand argument. *) let id_map_right_biased_union m1 m2 = - if Id.Map.is_empty m1 then m2 (** Don't reconstruct the whole map *) + if Id.Map.is_empty m1 then m2 (* Don't reconstruct the whole map *) else Id.Map.fold Id.Map.add m2 m1 (** Tests whether the substitution [s] is empty. *) @@ -102,7 +103,7 @@ let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) = else raise Not_coherent_metas in let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 in - (** ppedrot: Is that even correct? *) + (* ppedrot: Is that even correct? *) let merged = ln +++ ln1 in (merged, Id.Map.merge merge lcm lm) @@ -263,8 +264,8 @@ module PatternMatching (E:StaticEnvironment) = struct | All lhs -> wildcard_match_term lhs | Pat ([],pat,lhs) -> pattern_match_term false pat term lhs | Pat _ -> - (** Rules with hypotheses, only work in match goal. *) - fail + (* Rules with hypotheses, only work in match goal. *) + fail (** [match_term term rules] matches the term [term] with the set of matching rules [rules].*) @@ -299,8 +300,8 @@ module PatternMatching (E:StaticEnvironment) = struct | LocalDef (id,body,hyp) -> pattern_match_term false bodypat body () <*> pattern_match_term true typepat hyp () <*> - put_terms (id_map_try_add_name hypname (EConstr.mkVar id) empty_term_subst) <*> - return id + put_terms (id_map_try_add_name hypname (EConstr.mkVar id.binder_name) empty_term_subst) <*> + return id.binder_name | LocalAssum (id,hyp) -> fail (** [hyp_match pat hyps] dispatches to diff --git a/plugins/ltac/tactic_matching.mli b/plugins/ltac/tactic_matching.mli index 0722c68783..457c4e0b9a 100644 --- a/plugins/ltac/tactic_matching.mli +++ b/plugins/ltac/tactic_matching.mli @@ -35,7 +35,7 @@ val match_term : Environ.env -> Evd.evar_map -> EConstr.constr -> - (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> + (Constr_matching.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic (** [match_goal env sigma hyps concl rules] matches the goal @@ -48,5 +48,5 @@ val match_goal: Evd.evar_map -> EConstr.named_context -> EConstr.constr -> - (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> + (Constr_matching.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 299bc7ea4d..4c65445b89 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -65,7 +65,7 @@ let assoc_flags ist : tauto_flags = let negation_unfolding = ref true open Goptions -let _ = +let () = declare_bool_option { optdepr = false; optname = "unfolding of not in intuition"; @@ -142,7 +142,7 @@ let flatten_contravariant_conj _ ist = ~onlybinary:flags.binary_mode typ with | Some (_,args) -> - let newtyp = List.fold_right mkArrow args c in + let newtyp = List.fold_right (fun a b -> mkArrow a Sorts.Relevant b) args c in let intros = tclMAP (fun _ -> intro) args in let by = tclTHENLIST [intros; apply hyp; split; assumption] in tclTHENLIST [assert_ ~by newtyp; clear (destVar sigma hyp)] @@ -173,7 +173,7 @@ let flatten_contravariant_disj _ ist = typ with | Some (_,args) -> let map i arg = - let typ = mkArrow arg c in + let typ = mkArrow arg Sorts.Relevant c in let ci = Tactics.constructor_tac false None (succ i) Tactypes.NoBindings in let by = tclTHENLIST [intro; apply hyp; ci; assumption] in assert_ ~by typ @@ -191,7 +191,7 @@ let make_unfold name = let u_not = make_unfold "not" let reduction_not_iff _ ist = - let make_reduce c = TacAtom (Loc.tag @@ TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in + let make_reduce c = TacAtom (CAst.make @@ TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in let tac = match !negation_unfolding with | true -> make_reduce [u_not] | false -> TacId [] @@ -244,7 +244,7 @@ let with_flags flags _ ist = let x = CAst.make @@ Id.of_string "x" in let arg = Val.Dyn (tag_tauto_flags, flags) in let ist = { ist with lfun = Id.Map.add x.CAst.v arg ist.lfun } in - eval_tactic_ist ist (TacArg (Loc.tag @@ TacCall (Loc.tag (Locus.ArgVar f, [Reference (Locus.ArgVar x)])))) + eval_tactic_ist ist (TacArg (CAst.make @@ TacCall (CAst.make (Locus.ArgVar f, [Reference (Locus.ArgVar x)])))) let register_tauto_tactic tac name0 args = let ids = List.map (fun id -> Id.of_string id) args in @@ -252,7 +252,7 @@ let register_tauto_tactic tac name0 args = let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in let entry = { mltac_name = name; mltac_index = 0 } in let () = Tacenv.register_ml_tactic name [| tac |] in - let tac = TacFun (ids, TacML (Loc.tag (entry, []))) in + let tac = TacFun (ids, TacML (CAst.make (entry, []))) in let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in Mltop.declare_cache_obj obj tauto_plugin |