Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

more API support @no-tc! #553

Merged
merged 1 commit into from
Nov 27, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions Changelog.md
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@
- New `tc-priority`, contains the priority of an instance and if the priority
has been given by the user or computed by `coq`
- Change `tc-instance`, now the type is `gref -> tc-priority -> tc-instance` i.e. the priority is not an integer anymore
- New `@no-tc!` attribute supported by `coq.ltac.call-ltac1`

### Apps
- New `tc` app providing an implementation of a type class solver written in elpi.
Expand Down
2 changes: 2 additions & 0 deletions coq-builtin.elpi
Original file line number Diff line number Diff line change
Expand Up @@ -1561,6 +1561,8 @@ external pred coq.ltac.collect-goals i:term, o:list sealed-goal,
% of type ltac1-tactic, see the tac argument constructor
% and the ltac_tactic:(...) syntax to pass arguments to
% an elpi tactic.
% Supported attributes:
% - @no-tc! (default false, do not infer typeclasses)
external pred coq.ltac.call-ltac1 i:any, i:goal, o:list sealed-goal.

% [coq.ltac.id-free? ID G]
Expand Down
53 changes: 36 additions & 17 deletions src/coq_elpi_builtins.ml
Original file line number Diff line number Diff line change
Expand Up @@ -90,6 +90,18 @@ let with_pp_options o f =
Detyping.print_evar_arguments := print_evar_arguments;
raise reraise

let with_no_tc ~no_tc f sigma =
if no_tc then
let typeclass_evars = Evd.get_typeclass_evars sigma in
let sigma = Evd.set_typeclass_evars sigma Evar.Set.empty in
let sigma, rc = f sigma in
let typeclass_evars = Evar.Set.filter (fun x ->
try ignore (Evd.find_undefined sigma x); true
with Not_found -> false) typeclass_evars in
let sigma = Evd.set_typeclass_evars sigma typeclass_evars in
sigma, rc
else f sigma

let pr_econstr_env options env sigma t =
with_pp_options options.pp (fun () ->
let expr = Constrextern.extern_constr env sigma t in
Expand Down Expand Up @@ -3718,10 +3730,14 @@ fold_left over the terms, letin body comes before the type).
Tac can either be a string (the tactic name), or a value
of type ltac1-tactic, see the tac argument constructor
and the ltac_tactic:(...) syntax to pass arguments to
an elpi tactic.|})))),
an elpi tactic.
Supported attributes:
- @no-tc! (default false, do not infer typeclasses)|})))),
(fun tac (proof_context,goal,tac_args) _ ~depth _ _ -> abstract__grab_global_env_keep_sigma "coq.ltac.call-ltac1" (fun state ->
let no_tc = if proof_context.options.no_tc = Some true then true else false in
let open Ltac_plugin in
let sigma = get_sigma state in

let tac_args = tac_args |> List.map (function
| Coq_elpi_arg_HOAS.Ctrm t -> Tacinterp.Value.of_constr t
| Coq_elpi_arg_HOAS.Cstr s -> Geninterp.(Val.inject (val_tag (Genarg.topwit Stdarg.wit_string))) s
Expand All @@ -3748,25 +3764,28 @@ an elpi tactic.|})))),
| _ -> U.type_error ("coq.ltac.call-ltac1: string or ltac1-tactic are expected as the tactic to call")
in
Tacinterp.Value.apply tac tac_args in
let subgoals, sigma =
let sigma, subgoals =
let open Proofview in let open Notations in
let focused_tac =
Unsafe.tclSETGOALS [with_empty_state goal] <*> tactic in
let _, pv = init sigma [] in
let (), pv, _, _ =
let vernac_state = Vernacstate.freeze_full_state () in
try
let rc = apply ~name:(Id.of_string "elpi") ~poly:false proof_context.env focused_tac pv in
let pstate = Vernacstate.Stm.pstate (Vernacstate.freeze_full_state ()) in
let vernac_state = Vernacstate.Stm.set_pstate vernac_state pstate in
Vernacstate.unfreeze_full_state vernac_state;
rc
with e when CErrors.noncritical e ->
Vernacstate.unfreeze_full_state vernac_state;
Feedback.msg_debug (CErrors.print e);
raise Pred.No_clause
in
proofview pv in
with_no_tc ~no_tc (fun sigma ->
let _, pv = init sigma [] in
let (), pv, _, _ =
let vernac_state = Vernacstate.freeze_full_state () in
try
let rc = apply ~name:(Id.of_string "elpi") ~poly:false proof_context.env focused_tac pv in
let pstate = Vernacstate.Stm.pstate (Vernacstate.freeze_full_state ()) in
let vernac_state = Vernacstate.Stm.set_pstate vernac_state pstate in
Vernacstate.unfreeze_full_state vernac_state;
rc
with e when CErrors.noncritical e ->
Vernacstate.unfreeze_full_state vernac_state;
Feedback.msg_debug (CErrors.print e);
raise Pred.No_clause
in
let subgoals, sigma = proofview pv in
sigma, subgoals)
sigma in

Declare.Internal.export_side_effects (Evd.eval_side_effects sigma);

Expand Down
Loading