>
- | s -> Errors.error ("No Omega knowledge base for type "^s))
+ | "nat" -> eval_tactic "zify_nat"
+ | "positive" -> eval_tactic "zify_positive"
+ | "N" -> eval_tactic "zify_N"
+ | "Z" -> eval_tactic "zify_op"
+ | s -> CErrors.error ("No Omega knowledge base for type "^s))
(Util.List.sort_uniquize String.compare l)
in
Tacticals.New.tclTHEN
diff --git a/plugins/omega/omega_plugin.mllib b/plugins/omega/omega_plugin.mllib
deleted file mode 100644
index 2b387fdc..00000000
--- a/plugins/omega/omega_plugin.mllib
+++ /dev/null
@@ -1,4 +0,0 @@
-Omega
-Coq_omega
-G_omega
-Omega_plugin_mod
diff --git a/plugins/omega/omega_plugin.mlpack b/plugins/omega/omega_plugin.mlpack
new file mode 100644
index 00000000..df7f1047
--- /dev/null
+++ b/plugins/omega/omega_plugin.mlpack
@@ -0,0 +1,3 @@
+Omega
+Coq_omega
+G_omega
diff --git a/plugins/plugins.itarget b/plugins/plugins.itarget
deleted file mode 100644
index 56aa42b0..00000000
--- a/plugins/plugins.itarget
+++ /dev/null
@@ -1,3 +0,0 @@
-pluginsopt.otarget
-pluginsbyte.otarget
-pluginsvo.otarget
\ No newline at end of file
diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget
deleted file mode 100644
index d8752f8b..00000000
--- a/plugins/pluginsbyte.itarget
+++ /dev/null
@@ -1,21 +0,0 @@
-btauto/btauto_plugin.cma
-setoid_ring/newring_plugin.cma
-extraction/extraction_plugin.cma
-decl_mode/decl_mode_plugin.cma
-firstorder/ground_plugin.cma
-rtauto/rtauto_plugin.cma
-fourier/fourier_plugin.cma
-romega/romega_plugin.cma
-omega/omega_plugin.cma
-micromega/micromega_plugin.cma
-cc/cc_plugin.cma
-nsatz/nsatz_plugin.cma
-funind/recdef_plugin.cma
-syntax/ascii_syntax_plugin.cma
-syntax/nat_syntax_plugin.cma
-syntax/numbers_syntax_plugin.cma
-syntax/r_syntax_plugin.cma
-syntax/string_syntax_plugin.cma
-syntax/z_syntax_plugin.cma
-quote/quote_plugin.cma
-derive/derive_plugin.cma
\ No newline at end of file
diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget
deleted file mode 100644
index 220e5182..00000000
--- a/plugins/pluginsdyn.itarget
+++ /dev/null
@@ -1,24 +0,0 @@
-btauto/btauto_plugin.cmxs
-field/field_plugin.cmxs
-setoid_ring/newring_plugin.cmxs
-extraction/extraction_plugin.cmxs
-decl_mode/decl_mode_plugin.cmxs
-firstorder/ground_plugin.cmxs
-rtauto/rtauto_plugin.cmxs
-fourier/fourier_plugin.cmxs
-romega/romega_plugin.cmxs
-omega/omega_plugin.cmxs
-micromega/micromega_plugin.cmxs
-subtac/subtac_plugin.cmxs
-ring/ring_plugin.cmxs
-cc/cc_plugin.cmxs
-nsatz/nsatz_plugin.cmxs
-funind/recdef_plugin.cmxs
-syntax/ascii_syntax_plugin.cmxs
-syntax/nat_syntax_plugin.cmxs
-syntax/numbers_syntax_plugin.cmxs
-syntax/r_syntax_plugin.cmxs
-syntax/string_syntax_plugin.cmxs
-syntax/z_syntax_plugin.cmxs
-quote/quote_plugin.cmxs
-derive/derive_plugin.cmxs
diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget
deleted file mode 100644
index 04a1e711..00000000
--- a/plugins/pluginsopt.itarget
+++ /dev/null
@@ -1,21 +0,0 @@
-btauto/btauto_plugin.cmxa
-setoid_ring/newring_plugin.cmxa
-extraction/extraction_plugin.cmxa
-decl_mode/decl_mode_plugin.cmxa
-firstorder/ground_plugin.cmxa
-rtauto/rtauto_plugin.cmxa
-fourier/fourier_plugin.cmxa
-romega/romega_plugin.cmxa
-omega/omega_plugin.cmxa
-micromega/micromega_plugin.cmxa
-cc/cc_plugin.cmxa
-nsatz/nsatz_plugin.cmxa
-funind/recdef_plugin.cmxa
-syntax/ascii_syntax_plugin.cmxa
-syntax/nat_syntax_plugin.cmxa
-syntax/numbers_syntax_plugin.cmxa
-syntax/r_syntax_plugin.cmxa
-syntax/string_syntax_plugin.cmxa
-syntax/z_syntax_plugin.cmxa
-quote/quote_plugin.cmxa
-derive/derive_plugin.cmxa
diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget
deleted file mode 100644
index a59bf29c..00000000
--- a/plugins/pluginsvo.itarget
+++ /dev/null
@@ -1,12 +0,0 @@
-btauto/vo.otarget
-fourier/vo.otarget
-funind/vo.otarget
-nsatz/vo.otarget
-micromega/vo.otarget
-omega/vo.otarget
-quote/vo.otarget
-romega/vo.otarget
-rtauto/vo.otarget
-setoid_ring/vo.otarget
-extraction/vo.otarget
-derive/vo.otarget
\ No newline at end of file
diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4
index fdc5c2bb..fd87d5b7 100644
--- a/plugins/quote/g_quote.ml4
+++ b/plugins/quote/g_quote.ml4
@@ -13,19 +13,19 @@ open Misctypes
open Tacexpr
open Geninterp
open Quote
+open Constrarg
DECLARE PLUGIN "quote_plugin"
let loc = Loc.ghost
-let cont = (loc, Id.of_string "cont")
-let x = (loc, Id.of_string "x")
+let cont = Id.of_string "cont"
+let x = Id.of_string "x"
-let make_cont (k : glob_tactic_expr) (c : Constr.t) =
+let make_cont (k : Val.t) (c : Constr.t) =
let c = Tacinterp.Value.of_constr c in
- let tac = TacCall (loc, ArgVar cont, [Reference (ArgVar x)]) in
- let tac = TacLetIn (false, [(cont, Tacexp k)], TacArg (loc, tac)) in
- let ist = { lfun = Id.Map.singleton (snd x) c; extra = TacStore.empty; } in
- Tacinterp.eval_tactic_ist ist tac
+ let tac = TacCall (loc, ArgVar (loc, cont), [Reference (ArgVar (loc, x))]) in
+ let ist = { lfun = Id.Map.add cont k (Id.Map.singleton x c); extra = TacStore.empty; } in
+ Tacinterp.eval_tactic_ist ist (TacArg (loc, tac))
TACTIC EXTEND quote
[ "quote" ident(f) ] -> [ quote f [] ]
diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml
index ff6acf13..b3ea4335 100644
--- a/plugins/quote/quote.ml
+++ b/plugins/quote/quote.ml
@@ -101,7 +101,7 @@
(*i*)
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -109,6 +109,7 @@ open Pattern
open Patternops
open Constr_matching
open Tacmach
+open Proofview.Notations
(*i*)
(*s First, we need to access some Coq constants
@@ -227,7 +228,7 @@ let compute_ivs f cs gl =
let (args3, body3) = decompose_lam body2 in
let nargs3 = List.length args3 in
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let is_conv = Reductionops.is_conv env sigma in
begin match decomp_term body3 with
| Case(_,p,c,lci) -> (* Case c of c1 ... cn end *)
@@ -446,7 +447,7 @@ let quote_terms ivs lc =
yet. *)
let quote f lid =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let f = Tacmach.New.pf_global f gl in
let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in
let ivs = compute_ivs f cl gl in
@@ -459,10 +460,10 @@ let quote f lid =
match ivs.variable_lhs with
| None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast
| Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast
- end
+ end }
let gen_quote cont c f lid =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let f = Tacmach.New.pf_global f gl in
let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in
let ivs = compute_ivs f cl gl in
@@ -474,7 +475,7 @@ let gen_quote cont c f lid =
match ivs.variable_lhs with
| None -> cont (mkApp (f, [| p |]))
| Some _ -> cont (mkApp (f, [| vm; p |]))
- end
+ end }
(*i
diff --git a/plugins/quote/quote_plugin.mllib b/plugins/quote/quote_plugin.mllib
deleted file mode 100644
index d1b3ccbe..00000000
--- a/plugins/quote/quote_plugin.mllib
+++ /dev/null
@@ -1,3 +0,0 @@
-Quote
-G_quote
-Quote_plugin_mod
diff --git a/plugins/quote/quote_plugin.mlpack b/plugins/quote/quote_plugin.mlpack
new file mode 100644
index 00000000..2e9be09d
--- /dev/null
+++ b/plugins/quote/quote_plugin.mlpack
@@ -0,0 +1,2 @@
+Quote
+G_quote
diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v
index b84cf254..187601fc 100644
--- a/plugins/romega/ReflOmegaCore.v
+++ b/plugins/romega/ReflOmegaCore.v
@@ -1074,16 +1074,19 @@ Qed.
avait utilisé le test précédent et fait une elimination dessus. *)
Ltac elim_eq_term t1 t2 :=
+ let Aux := fresh "Aux" in
pattern (eq_term t1 t2); apply bool_eq_ind; intro Aux;
[ generalize (eq_term_true t1 t2 Aux); clear Aux
| generalize (eq_term_false t1 t2 Aux); clear Aux ].
Ltac elim_beq t1 t2 :=
+ let Aux := fresh "Aux" in
pattern (beq t1 t2); apply bool_eq_ind; intro Aux;
[ generalize (beq_true t1 t2 Aux); clear Aux
| generalize (beq_false t1 t2 Aux); clear Aux ].
Ltac elim_bgt t1 t2 :=
+ let Aux := fresh "Aux" in
pattern (bgt t1 t2); apply bool_eq_ind; intro Aux;
[ generalize (bgt_true t1 t2 Aux); clear Aux
| generalize (bgt_false t1 t2 Aux); clear Aux ].
@@ -1448,27 +1451,27 @@ Ltac loop t :=
| (Tint ?X1) => loop X1
(* Eliminations *)
| match ?X1 with
- | EqTerm x x0 => _
- | LeqTerm x x0 => _
+ | EqTerm _ _ => _
+ | LeqTerm _ _ => _
| TrueTerm => _
| FalseTerm => _
- | Tnot x => _
- | GeqTerm x x0 => _
- | GtTerm x x0 => _
- | LtTerm x x0 => _
- | NeqTerm x x0 => _
- | Tor x x0 => _
- | Tand x x0 => _
- | Timp x x0 => _
- | Tprop x => _
+ | Tnot _ => _
+ | GeqTerm _ _ => _
+ | GtTerm _ _ => _
+ | LtTerm _ _ => _
+ | NeqTerm _ _ => _
+ | Tor _ _ => _
+ | Tand _ _ => _
+ | Timp _ _ => _
+ | Tprop _ => _
end => destruct X1; auto; Simplify
| match ?X1 with
- | Tint x => _
- | (x + x0)%term => _
- | (x * x0)%term => _
- | (x - x0)%term => _
- | (- x)%term => _
- | [x]%term => _
+ | Tint _ => _
+ | (_ + _)%term => _
+ | (_ * _)%term => _
+ | (_ - _)%term => _
+ | (- _)%term => _
+ | [_]%term => _
end => destruct X1; auto; Simplify
| (if beq ?X1 ?X2 then _ else _) =>
let H := fresh "H" in
@@ -1492,7 +1495,7 @@ with Simplify := match goal with
end.
Ltac prove_stable x th :=
- match constr:x with
+ match constr:(x) with
| ?X1 =>
unfold term_stable, X1; intros; Simplify; simpl;
apply th
diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml
index 21b0f78b..4935fe4b 100644
--- a/plugins/romega/const_omega.ml
+++ b/plugins/romega/const_omega.ml
@@ -39,7 +39,7 @@ let destructurate t =
| Term.Var id,[] -> Kvar(Names.Id.to_string id)
| Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body)
| Term.Prod (Names.Name _,_,_),[] ->
- Errors.error "Omega: Not a quantifier-free goal"
+ CErrors.error "Omega: Not a quantifier-free goal"
| _ -> Kufo
exception Destruct
@@ -346,7 +346,7 @@ let parse_term t =
| Kapp("Z.succ",[t]) -> Tsucc t
| Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one))
| Kapp(("Zpos"|"Zneg"|"Z0"),_) ->
- (try Tnum (recognize t) with e when Errors.noncritical e -> Tother)
+ (try Tnum (recognize t) with e when CErrors.noncritical e -> Tother)
| _ -> Tother
with e when Logic.catchable_exception e -> Tother
@@ -368,6 +368,6 @@ let is_scalar t =
| Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t
| Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true
| _ -> false in
- try aux t with e when Errors.noncritical e -> false
+ try aux t with e when CErrors.noncritical e -> false
end
diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4
index 0a99a26b..830dc54d 100644
--- a/plugins/romega/g_romega.ml4
+++ b/plugins/romega/g_romega.ml4
@@ -10,16 +10,24 @@
DECLARE PLUGIN "romega_plugin"
+open Names
open Refl_omega
+open Constrarg
+
+let eval_tactic name =
+ let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in
+ let kn = KerName.make2 (MPfile dp) (Label.make name) in
+ let tac = Tacenv.interp_ltac kn in
+ Tacinterp.eval_tactic tac
let romega_tactic l =
let tacs = List.map
(function
- | "nat" -> Tacinterp.interp <:tactic>
- | "positive" -> Tacinterp.interp <:tactic>
- | "N" -> Tacinterp.interp <:tactic>
- | "Z" -> Tacinterp.interp <:tactic>
- | s -> Errors.error ("No ROmega knowledge base for type "^s))
+ | "nat" -> eval_tactic "zify_nat"
+ | "positive" -> eval_tactic "zify_positive"
+ | "N" -> eval_tactic "zify_N"
+ | "Z" -> eval_tactic "zify_op"
+ | s -> CErrors.error ("No ROmega knowledge base for type "^s))
(Util.List.sort_uniquize String.compare l)
in
Tacticals.New.tclTHEN
diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml
index 560e6a89..ba882e39 100644
--- a/plugins/romega/refl_omega.ml
+++ b/plugins/romega/refl_omega.ml
@@ -9,7 +9,7 @@
open Pp
open Util
open Const_omega
-module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
+module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint)
open OmegaSolver
(* \section{Useful functions and flags} *)
@@ -172,7 +172,7 @@ let print_env_reification env =
in
let prop_info = str "ENVIRONMENT OF PROPOSITIONS :" ++ fnl () ++ loop 'P' 0 env.props in
let term_info = str "ENVIRONMENT OF TERMS :" ++ fnl () ++ loop 'V' 0 env.terms in
- msg_debug (prop_info ++ fnl () ++ term_info)
+ Feedback.msg_debug (prop_info ++ fnl () ++ term_info)
(* \subsection{Gestion des environnements de variable pour Omega} *)
(* generation d'identifiant d'equation pour Omega *)
@@ -454,7 +454,7 @@ let rec scalar n = function
| Omult(t1,Oint x) ->
do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x))
| Omult(t1,t2) ->
- Errors.error "Omega: Can't solve a goal with non-linear products"
+ CErrors.error "Omega: Can't solve a goal with non-linear products"
| (Oatom _ as t) -> do_list [], Omult(t,Oint n)
| Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i)
| (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n))
@@ -473,7 +473,7 @@ let rec negate = function
| Omult(t1,Oint x) ->
do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x))
| Omult(t1,t2) ->
- Errors.error "Omega: Can't solve a goal with non-linear products"
+ CErrors.error "Omega: Can't solve a goal with non-linear products"
| (Oatom _ as t) ->
do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone))
| Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i)
@@ -545,7 +545,7 @@ let shrink_pair f1 f2 =
Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2))
| t1,t2 ->
oprint stdout t1; print_newline (); oprint stdout t2; print_newline ();
- flush Pervasives.stdout; Errors.error "shrink.1"
+ flush Pervasives.stdout; CErrors.error "shrink.1"
end
(* \subsection{Calcul d'une sous formule constante} *)
@@ -559,9 +559,9 @@ let reduce_factor = function
let rec compute = function
Oint n -> n
| Oplus(t1,t2) -> compute t1 + compute t2
- | _ -> Errors.error "condense.1" in
+ | _ -> CErrors.error "condense.1" in
[Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c))
- | t -> Errors.error "reduce_factor.1"
+ | t -> CErrors.error "reduce_factor.1"
(* \subsection{Réordonnancement} *)
@@ -1280,12 +1280,12 @@ let resolution env full_reified_goal systems_list =
CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in
let decompose_tactic = decompose_tree env context solution_tree in
- Tactics.generalize
- (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >>
+ Proofview.V82.of_tactic (Tactics.generalize
+ (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps))) >>
Proofview.V82.of_tactic (Tactics.change_concl reified) >>
Proofview.V82.of_tactic (Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|])) >>
show_goal >>
- Tactics.normalise_vm_in_concl >>
+ Proofview.V82.of_tactic (Tactics.normalise_vm_in_concl) >>
(*i Alternatives to the previous line:
- Normalisation without VM:
Tactics.normalise_in_concl
@@ -1304,7 +1304,7 @@ let total_reflexive_omega_tactic gl =
let systems_list = destructurate_hyps full_reified_goal in
if !debug then display_systems systems_list;
resolution env full_reified_goal systems_list gl
- with NO_CONTRADICTION -> Errors.error "ROmega can't solve this system"
+ with NO_CONTRADICTION -> CErrors.error "ROmega can't solve this system"
(*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*)
diff --git a/plugins/romega/romega_plugin.mllib b/plugins/romega/romega_plugin.mllib
deleted file mode 100644
index 1625009d..00000000
--- a/plugins/romega/romega_plugin.mllib
+++ /dev/null
@@ -1,4 +0,0 @@
-Const_omega
-Refl_omega
-G_romega
-Romega_plugin_mod
diff --git a/plugins/romega/romega_plugin.mlpack b/plugins/romega/romega_plugin.mlpack
new file mode 100644
index 00000000..38d0e941
--- /dev/null
+++ b/plugins/romega/romega_plugin.mlpack
@@ -0,0 +1,3 @@
+Const_omega
+Refl_omega
+G_romega
diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v
index 7394cebd..36460187 100644
--- a/plugins/rtauto/Bintree.v
+++ b/plugins/rtauto/Bintree.v
@@ -266,7 +266,7 @@ Qed.
Lemma push_not_empty: forall a S, (push a S) <> empty.
intros a [ind cont];unfold push,empty.
-simpl;intro H;injection H; intros _ ; apply Pos.succ_not_1.
+intros [= H%Pos.succ_not_1]. assumption.
Qed.
Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop :=
diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
index 3ba92b9f..8b926111 100644
--- a/plugins/rtauto/proof_search.ml
+++ b/plugins/rtauto/proof_search.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Goptions
@@ -547,7 +547,7 @@ let pp_info () =
int s_info.created_branches ++ str " created" ++ fnl () ++
str "Hypotheses : " ++
int s_info.created_hyps ++ str " created" ++ fnl () in
- msg_info
+ Feedback.msg_info
( str "Proof-search statistics :" ++ fnl () ++
count_info ++
str "Branch ends: " ++
diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
index 9c22b5ad..4ed90795 100644
--- a/plugins/rtauto/refl_tauto.ml
+++ b/plugins/rtauto/refl_tauto.ml
@@ -8,11 +8,12 @@
module Search = Explore.Make(Proof_search)
-open Errors
+open CErrors
open Util
open Term
open Tacmach
open Proof_search
+open Context.Named.Declaration
let force count lazc = incr count;Lazy.force lazc
@@ -66,12 +67,12 @@ let l_D_Or = lazy (constant "D_Or")
let special_whd gl=
- let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
- (fun t -> Closure.whd_val infos (Closure.inject t))
+ let infos=CClosure.create_clos_infos CClosure.all (pf_env gl) in
+ (fun t -> CClosure.whd_val infos (CClosure.inject t))
let special_nf gl=
- let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in
- (fun t -> Closure.norm_val infos (Closure.inject t))
+ let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in
+ (fun t -> CClosure.norm_val infos (CClosure.inject t))
type atom_env=
{mutable next:int;
@@ -128,9 +129,9 @@ let rec make_form atom_env gls term =
let rec make_hyps atom_env gls lenv = function
[] -> []
- | (_,Some body,typ)::rest ->
+ | LocalDef (_,body,typ)::rest ->
make_hyps atom_env gls (typ::body::lenv) rest
- | (id,None,typ)::rest ->
+ | LocalAssum (id,typ)::rest ->
let hrec=
make_hyps atom_env gls (typ::lenv) rest in
if List.exists (Termops.dependent (mkVar id)) lenv ||
@@ -275,7 +276,7 @@ let rtauto_tac gls=
begin
reset_info ();
if !verbose then
- msg_info (str "Starting proof-search ...");
+ Feedback.msg_info (str "Starting proof-search ...");
end in
let search_start_time = System.get_time () in
let prf =
@@ -285,10 +286,10 @@ let rtauto_tac gls=
let search_end_time = System.get_time () in
let _ = if !verbose then
begin
- msg_info (str "Proof tree found in " ++
+ Feedback.msg_info (str "Proof tree found in " ++
System.fmt_time_difference search_start_time search_end_time);
pp_info ();
- msg_info (str "Building proof term ... ")
+ Feedback.msg_info (str "Building proof term ... ")
end in
let build_start_time=System.get_time () in
let _ = step_count := 0; node_count := 0 in
@@ -301,7 +302,7 @@ let rtauto_tac gls=
let build_end_time=System.get_time () in
let _ = if !verbose then
begin
- msg_info (str "Proof term built in " ++
+ Feedback.msg_info (str "Proof term built in " ++
System.fmt_time_difference build_start_time build_end_time ++
fnl () ++
str "Proof size : " ++ int !step_count ++
@@ -315,12 +316,12 @@ let rtauto_tac gls=
if !check then
Proofview.V82.of_tactic (Tactics.exact_check term) gls
else
- Tactics.exact_no_check term gls in
+ Proofview.V82.of_tactic (Tactics.exact_no_check term) gls in
let tac_end_time = System.get_time () in
let _ =
- if !check then msg_info (str "Proof term type-checking is on");
+ if !check then Feedback.msg_info (str "Proof term type-checking is on");
if !verbose then
- msg_info (str "Internal tactic executed in " ++
+ Feedback.msg_info (str "Internal tactic executed in " ++
System.fmt_time_difference tac_start_time tac_end_time) in
result
diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli
index c9e591bb..9a14ac6c 100644
--- a/plugins/rtauto/refl_tauto.mli
+++ b/plugins/rtauto/refl_tauto.mli
@@ -18,7 +18,7 @@ val make_hyps :
atom_env ->
Proof_type.goal Tacmach.sigma ->
Term.types list ->
- (Names.Id.t * Term.types option * Term.types) list ->
+ Context.Named.t ->
(Names.Id.t * Proof_search.form) list
val rtauto_tac : Proof_type.tactic
diff --git a/plugins/rtauto/rtauto_plugin.mllib b/plugins/rtauto/rtauto_plugin.mllib
deleted file mode 100644
index 0e346044..00000000
--- a/plugins/rtauto/rtauto_plugin.mllib
+++ /dev/null
@@ -1,4 +0,0 @@
-Proof_search
-Refl_tauto
-G_rtauto
-Rtauto_plugin_mod
diff --git a/plugins/rtauto/rtauto_plugin.mlpack b/plugins/rtauto/rtauto_plugin.mlpack
new file mode 100644
index 00000000..61c5e945
--- /dev/null
+++ b/plugins/rtauto/rtauto_plugin.mlpack
@@ -0,0 +1,3 @@
+Proof_search
+Refl_tauto
+G_rtauto
diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v
index 04decbce..5f5b9792 100644
--- a/plugins/setoid_ring/ArithRing.v
+++ b/plugins/setoid_ring/ArithRing.v
@@ -32,13 +32,13 @@ Qed.
Ltac natcst t :=
match isnatcst t with
true => constr:(N.of_nat t)
- | _ => constr:InitialRing.NotConstant
+ | _ => constr:(InitialRing.NotConstant)
end.
Ltac Ss_to_add f acc :=
match f with
| S ?f1 => Ss_to_add f1 (S acc)
- | _ => constr:(acc + f)%nat
+ | _ => constr:((acc + f)%nat)
end.
Ltac natprering :=
diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v
index 8362c8c2..9c690e2b 100644
--- a/plugins/setoid_ring/InitialRing.v
+++ b/plugins/setoid_ring/InitialRing.v
@@ -96,7 +96,7 @@ Section ZMORPHISM.
Proof.
constructor.
destruct c;intros;try discriminate.
- injection H;clear H;intros H1;subst c'.
+ injection H as <-.
simpl. unfold Zeq_bool. rewrite Z.compare_refl. trivial.
Qed.
@@ -612,32 +612,32 @@ End GEN_DIV.
Ltac inv_gen_phi_pos rI add mul t :=
let rec inv_cst t :=
match t with
- rI => constr:1%positive
- | (add rI rI) => constr:2%positive
- | (add rI (add rI rI)) => constr:3%positive
+ rI => constr:(1%positive)
+ | (add rI rI) => constr:(2%positive)
+ | (add rI (add rI rI)) => constr:(3%positive)
| (mul (add rI rI) ?p) => (* 2p *)
match inv_cst p with
- NotConstant => constr:NotConstant
- | 1%positive => constr:NotConstant (* 2*1 is not convertible to 2 *)
+ NotConstant => constr:(NotConstant)
+ | 1%positive => constr:(NotConstant) (* 2*1 is not convertible to 2 *)
| ?p => constr:(xO p)
end
| (add rI (mul (add rI rI) ?p)) => (* 1+2p *)
match inv_cst p with
- NotConstant => constr:NotConstant
- | 1%positive => constr:NotConstant
+ NotConstant => constr:(NotConstant)
+ | 1%positive => constr:(NotConstant)
| ?p => constr:(xI p)
end
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
end in
inv_cst t.
(* The (partial) inverse of gen_phiNword *)
Ltac inv_gen_phiNword rO rI add mul opp t :=
match t with
- rO => constr:NwO
+ rO => constr:(NwO)
| _ =>
match inv_gen_phi_pos rI add mul t with
- NotConstant => constr:NotConstant
+ NotConstant => constr:(NotConstant)
| ?p => constr:(Npos p::nil)
end
end.
@@ -646,10 +646,10 @@ End GEN_DIV.
(* The inverse of gen_phiN *)
Ltac inv_gen_phiN rO rI add mul t :=
match t with
- rO => constr:0%N
+ rO => constr:(0%N)
| _ =>
match inv_gen_phi_pos rI add mul t with
- NotConstant => constr:NotConstant
+ NotConstant => constr:(NotConstant)
| ?p => constr:(Npos p)
end
end.
@@ -657,15 +657,15 @@ End GEN_DIV.
(* The inverse of gen_phiZ *)
Ltac inv_gen_phiZ rO rI add mul opp t :=
match t with
- rO => constr:0%Z
+ rO => constr:(0%Z)
| (opp ?p) =>
match inv_gen_phi_pos rI add mul p with
- NotConstant => constr:NotConstant
+ NotConstant => constr:(NotConstant)
| ?p => constr:(Zneg p)
end
| _ =>
match inv_gen_phi_pos rI add mul t with
- NotConstant => constr:NotConstant
+ NotConstant => constr:(NotConstant)
| ?p => constr:(Zpos p)
end
end.
@@ -681,7 +681,7 @@ Ltac inv_gen_phi rO rI cO cI t :=
end.
(* A simple tactic recognizing no constant *)
- Ltac inv_morph_nothing t := constr:NotConstant.
+ Ltac inv_morph_nothing t := constr:(NotConstant).
Ltac coerce_to_almost_ring set ext rspec :=
match type of rspec with
@@ -825,31 +825,31 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk :=
(* Tactic for constant *)
Ltac isnatcst t :=
match t with
- O => constr:true
+ O => constr:(true)
| S ?p => isnatcst p
- | _ => constr:false
+ | _ => constr:(false)
end.
Ltac isPcst t :=
match t with
| xI ?p => isPcst p
| xO ?p => isPcst p
- | xH => constr:true
+ | xH => constr:(true)
(* nat -> positive *)
| Pos.of_succ_nat ?n => isnatcst n
- | _ => constr:false
+ | _ => constr:(false)
end.
Ltac isNcst t :=
match t with
- N0 => constr:true
+ N0 => constr:(true)
| Npos ?p => isPcst p
- | _ => constr:false
+ | _ => constr:(false)
end.
Ltac isZcst t :=
match t with
- Z0 => constr:true
+ Z0 => constr:(true)
| Zpos ?p => isPcst p
| Zneg ?p => isPcst p
(* injection nat -> Z *)
@@ -857,7 +857,7 @@ Ltac isZcst t :=
(* injection N -> Z *)
| Z.of_N ?n => isNcst n
(* *)
- | _ => constr:false
+ | _ => constr:(false)
end.
diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v
index 6c1a79e4..54e2789b 100644
--- a/plugins/setoid_ring/NArithRing.v
+++ b/plugins/setoid_ring/NArithRing.v
@@ -15,7 +15,7 @@ Set Implicit Arguments.
Ltac Ncst t :=
match isNcst t with
true => t
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
end.
Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]).
diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v
index 96885d2f..20022c00 100644
--- a/plugins/setoid_ring/Ncring_initial.v
+++ b/plugins/setoid_ring/Ncring_initial.v
@@ -18,7 +18,6 @@ Require Import BinInt.
Require Import Setoid.
Require Export Ncring.
Require Export Ncring_polynom.
-Import List.
Set Implicit Arguments.
@@ -78,7 +77,8 @@ Context {R:Type}`{Ring R}.
| Z0 => 0
| Zneg p => -(gen_phiPOS p)
end.
- Notation "[ x ]" := (gen_phiZ x).
+ Local Notation "[ x ]" := (gen_phiZ x) : ZMORPHISM.
+ Local Open Scope ZMORPHISM.
Definition get_signZ z :=
match z with
diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v
index a0844100..77576cb9 100644
--- a/plugins/setoid_ring/Ring.v
+++ b/plugins/setoid_ring/Ring.v
@@ -36,9 +36,9 @@ Qed.
Ltac bool_cst t :=
let t := eval hnf in t in
match t with
- true => constr:true
- | false => constr:false
- | _ => constr:NotConstant
+ true => constr:(true)
+ | false => constr:(false)
+ | _ => constr:(NotConstant)
end.
Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]).
diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v
index 760ad4da..b6919667 100644
--- a/plugins/setoid_ring/Ring_polynom.v
+++ b/plugins/setoid_ring/Ring_polynom.v
@@ -883,7 +883,7 @@ Section MakeRingPol.
revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros.
- discriminate.
- assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst.
- * injection H; intros <-. rewrite <- PSubstL1_ok; intuition.
+ * injection H as <-. rewrite <- PSubstL1_ok; intuition.
* now apply IH.
Qed.
diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v
index 77863edc..fc02cef1 100644
--- a/plugins/setoid_ring/Ring_tac.v
+++ b/plugins/setoid_ring/Ring_tac.v
@@ -422,8 +422,6 @@ Tactic Notation (at level 0)
let G := Get_goal in
ring_lookup (PackRing Ring_simplify) [lH] rl G.
-(* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *)
-
Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):=
let G := Get_goal in
let t := type of H in
diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v
index 7fcd6c08..f7757a18 100644
--- a/plugins/setoid_ring/Ring_theory.v
+++ b/plugins/setoid_ring/Ring_theory.v
@@ -238,7 +238,6 @@ Section ALMOST_RING.
Variable req : R -> R -> Prop.
Notation "0" := rO. Notation "1" := rI.
Infix "==" := req. Infix "+" := radd. Infix "* " := rmul.
- Infix "-" := rsub. Notation "- x" := (ropp x).
(** Leibniz equality leads to a setoid theory and is extensional*)
Lemma Eqsth : Equivalence (@eq R).
@@ -263,7 +262,7 @@ Section ALMOST_RING.
-x = x and x - y = x + y *)
Definition SRopp (x:R) := x. Notation "- x" := (SRopp x).
- Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y).
+ Definition SRsub x y := x + -y. Infix "-" := SRsub.
Lemma SRopp_ext : forall x y, x == y -> -x == -y.
Proof. intros x y H; exact H. Qed.
@@ -320,6 +319,8 @@ Section ALMOST_RING.
Qed.
End SEMI_RING.
+ Infix "-" := rsub.
+ Notation "- x" := (ropp x).
Variable Reqe : ring_eq_ext radd rmul ropp req.
Add Morphism radd : radd_ext2. exact (Radd_ext Reqe). Qed.
diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v
index 91484372..23784cf3 100644
--- a/plugins/setoid_ring/ZArithRing.v
+++ b/plugins/setoid_ring/ZArithRing.v
@@ -17,14 +17,14 @@ Set Implicit Arguments.
Ltac Zcst t :=
match isZcst t with
true => t
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
end.
Ltac isZpow_coef t :=
match t with
| Zpos ?p => isPcst p
- | Z0 => constr:true
- | _ => constr:false
+ | Z0 => constr:(true)
+ | _ => constr:(false)
end.
Notation N_of_Z := Z.to_N (only parsing).
@@ -32,7 +32,7 @@ Notation N_of_Z := Z.to_N (only parsing).
Ltac Zpow_tac t :=
match isZpow_coef t with
| true => constr:(N_of_Z t)
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
end.
Ltac Zpower_neg :=
diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4
new file mode 100644
index 00000000..216eb8b3
--- /dev/null
+++ b/plugins/setoid_ring/g_newring.ml4
@@ -0,0 +1,133 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(*
+ [ protect_tac_in map id ]
+| [ "protect_fv" string(map) ] ->
+ [ protect_tac map ]
+END
+
+TACTIC EXTEND closed_term
+ [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
+ [ closed_term t l ]
+END
+
+open Pptactic
+open Ppconstr
+
+let pr_ring_mod = function
+ | Ring_kind (Computational eq_test) -> str "decidable" ++ pr_arg pr_constr_expr eq_test
+ | Ring_kind Abstract -> str "abstract"
+ | Ring_kind (Morphism morph) -> str "morphism" ++ pr_arg pr_constr_expr morph
+ | Const_tac (CstTac cst_tac) -> str "constants" ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]"
+ | Const_tac (Closed l) -> str "closed" ++ spc () ++ str "[" ++ prlist_with_sep spc pr_reference l ++ str "]"
+ | Pre_tac t -> str "preprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]"
+ | Post_tac t -> str "postprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]"
+ | Setoid(sth,ext) -> str "setoid" ++ pr_arg pr_constr_expr sth ++ pr_arg pr_constr_expr ext
+ | Pow_spec(Closed l,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ prlist_with_sep spc pr_reference l ++ str "]"
+ | Pow_spec(CstTac cst_tac,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]"
+ | Sign_spec t -> str "sign" ++ pr_arg pr_constr_expr t
+ | Div_spec t -> str "div" ++ pr_arg pr_constr_expr t
+
+VERNAC ARGUMENT EXTEND ring_mod
+ PRINTED BY pr_ring_mod
+ | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ]
+ | [ "abstract" ] -> [ Ring_kind Abstract ]
+ | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism morph) ]
+ | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ]
+ | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ]
+ | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
+ | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
+ | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
+ | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ]
+ | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] ->
+ [ Pow_spec (Closed l, pow_spec) ]
+ | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
+ [ Pow_spec (CstTac cst_tac, pow_spec) ]
+ | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ]
+END
+
+let pr_ring_mods l = surround (prlist_with_sep pr_comma pr_ring_mod l)
+
+VERNAC ARGUMENT EXTEND ring_mods
+ PRINTED BY pr_ring_mods
+ | [ "(" ne_ring_mod_list_sep(mods, ",") ")" ] -> [ mods ]
+END
+
+VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF
+ | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] ->
+ [ let l = match l with None -> [] | Some l -> l in
+ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in
+ add_theory id (ic t) set k cst (pre,post) power sign div]
+ | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [
+ Feedback.msg_notice (strbrk "The following ring structures have been declared:");
+ Spmap.iter (fun fn fi ->
+ Feedback.msg_notice (hov 2
+ (Ppconstr.pr_id (Libnames.basename fn)++spc()++
+ str"with carrier "++ pr_constr fi.ring_carrier++spc()++
+ str"and equivalence relation "++ pr_constr fi.ring_req))
+ ) !from_name ]
+END
+
+TACTIC EXTEND ring_lookup
+| [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] ->
+ [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t]
+END
+
+let pr_field_mod = function
+ | Ring_mod m -> pr_ring_mod m
+ | Inject inj -> str "completeness" ++ pr_arg pr_constr_expr inj
+
+VERNAC ARGUMENT EXTEND field_mod
+ PRINTED BY pr_field_mod
+ | [ ring_mod(m) ] -> [ Ring_mod m ]
+ | [ "completeness" constr(inj) ] -> [ Inject inj ]
+END
+
+let pr_field_mods l = surround (prlist_with_sep pr_comma pr_field_mod l)
+
+VERNAC ARGUMENT EXTEND field_mods
+ PRINTED BY pr_field_mods
+ | [ "(" ne_field_mod_list_sep(mods, ",") ")" ] -> [ mods ]
+END
+
+VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF
+| [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] ->
+ [ let l = match l with None -> [] | Some l -> l in
+ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in
+ add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div]
+| [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [
+ Feedback.msg_notice (strbrk "The following field structures have been declared:");
+ Spmap.iter (fun fn fi ->
+ Feedback.msg_notice (hov 2
+ (Ppconstr.pr_id (Libnames.basename fn)++spc()++
+ str"with carrier "++ pr_constr fi.field_carrier++spc()++
+ str"and equivalence relation "++ pr_constr fi.field_req))
+ ) !field_from_name ]
+END
+
+TACTIC EXTEND field_lookup
+| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] ->
+ [ let (t,l) = List.sep_last lt in field_lookup f lH l t ]
+END
diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml
new file mode 100644
index 00000000..90f5f8e6
--- /dev/null
+++ b/plugins/setoid_ring/newring.ml
@@ -0,0 +1,1015 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* mk_clos subs c
+ | Prot -> mk_atom c
+ | Rec -> if Int.equal i (-1) then mk_clos subs c else tag_rec c
+
+let global_head_of_constr c =
+ let f, args = decompose_app c in
+ try global_of_constr f
+ with Not_found -> anomaly (str "global_head_of_constr")
+
+let global_of_constr_nofail c =
+ try global_of_constr c
+ with Not_found -> VarRef (Id.of_string "dummy")
+
+let rec mk_clos_but f_map subs t =
+ match f_map (global_of_constr_nofail t) with
+ | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t
+ | None ->
+ (match kind_of_term t with
+ App(f,args) -> mk_clos_app_but f_map subs f args 0
+ | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t
+ | _ -> mk_atom t)
+
+and mk_clos_app_but f_map subs f args n =
+ if n >= Array.length args then mk_atom(mkApp(f, args))
+ else
+ let fargs, args' = Array.chop n args in
+ let f' = mkApp(f,fargs) in
+ match f_map (global_of_constr_nofail f') with
+ | Some map ->
+ let f i t = tag_arg (mk_clos_but f_map subs) map subs i t in
+ mk_red (FApp (f (-1) f', Array.mapi f args'))
+ | None -> mk_atom (mkApp (f, args))
+
+let interp_map l t =
+ try Some(List.assoc_f eq_gr t l) with Not_found -> None
+
+let protect_maps = ref String.Map.empty
+let add_map s m = protect_maps := String.Map.add s m !protect_maps
+let lookup_map map =
+ try String.Map.find map !protect_maps
+ with Not_found ->
+ errorlabstrm"lookup_map"(str"map "++qs map++str"not found")
+
+let protect_red map env sigma c =
+ kl (create_clos_infos all env)
+ (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);;
+
+let protect_tac map =
+ Tactics.reduct_option (protect_red map,DEFAULTcast) None
+
+let protect_tac_in map id =
+ Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp))
+
+
+(****************************************************************************)
+
+let closed_term t l =
+ let open Quote_plugin in
+ let l = List.map Universes.constr_of_global l in
+ let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in
+ if Quote.closed_under cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt())
+
+(* TACTIC EXTEND echo
+| [ "echo" constr(t) ] ->
+ [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ]
+END;;*)
+
+(*
+let closed_term_ast l =
+ TacFun([Some(Id.of_string"t")],
+ TacAtom(Loc.ghost,TacExtend(Loc.ghost,"closed_term",
+ [Genarg.in_gen Constrarg.wit_constr (mkVar(Id.of_string"t"));
+ Genarg.in_gen (Genarg.wit_list Constrarg.wit_ref) l])))
+*)
+let closed_term_ast l =
+ let tacname = {
+ mltac_plugin = "newring_plugin";
+ mltac_tactic = "closed_term";
+ } in
+ let tacname = {
+ mltac_name = tacname;
+ mltac_index = 0;
+ } in
+ let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in
+ TacFun([Some(Id.of_string"t")],
+ TacML(Loc.ghost,tacname,
+ [TacGeneric (Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None));
+ TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l)]))
+(*
+let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term"
+*)
+
+(****************************************************************************)
+
+let ic c =
+ let env = Global.env() in
+ let sigma = Evd.from_env env in
+ Constrintern.interp_open_constr env sigma c
+
+let ic_unsafe c = (*FIXME remove *)
+ let env = Global.env() in
+ let sigma = Evd.from_env env in
+ fst (Constrintern.interp_constr env sigma c)
+
+let decl_constant na ctx c =
+ let vars = Universes.universes_of_constr c in
+ let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in
+ mkConst(declare_constant (Id.of_string na)
+ (DefinitionEntry (definition_entry ~opaque:true
+ ~univs:(Univ.ContextSet.to_context ctx) c),
+ IsProof Lemma))
+
+(* Calling a global tactic *)
+let ltac_call tac (args:glob_tactic_arg list) =
+ TacArg(Loc.ghost,TacCall(Loc.ghost, ArgArg(Loc.ghost, Lazy.force tac),args))
+
+(* Calling a locally bound tactic *)
+let ltac_lcall tac args =
+ TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args))
+
+let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) =
+ let fold arg (i, vars, lfun) =
+ let id = Id.of_string ("x" ^ string_of_int i) in
+ let x = Reference (ArgVar (Loc.ghost, id)) in
+ (succ i, x :: vars, Id.Map.add id arg lfun)
+ in
+ 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 = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in
+ Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args)
+
+let dummy_goal env sigma =
+ let (gl,_,sigma) =
+ Goal.V82.mk_goal sigma (named_context_val env) mkProp Evd.Store.empty in
+ {Evd.it = gl; Evd.sigma = sigma}
+
+let constr_of v = match Value.to_constr v with
+ | Some c -> c
+ | None -> failwith "Ring.exec_tactic: anomaly"
+
+let tactic_res = ref [||]
+
+let get_res =
+ let open Tacexpr in
+ let name = { mltac_plugin = "newring_plugin"; mltac_tactic = "get_res"; } in
+ let entry = { mltac_name = name; mltac_index = 0 } in
+ let tac args ist =
+ let n = Tacinterp.Value.cast (Genarg.topwit Stdarg.wit_int) (List.hd args) in
+ let init i = Id.Map.find (Id.of_string ("x" ^ string_of_int i)) ist.lfun in
+ tactic_res := Array.init n init;
+ Proofview.tclUNIT ()
+ in
+ Tacenv.register_ml_tactic name [| tac |];
+ entry
+
+let exec_tactic env evd n f args =
+ let fold arg (i, vars, lfun) =
+ let id = Id.of_string ("x" ^ string_of_int i) in
+ let x = Reference (ArgVar (Loc.ghost, id)) in
+ (succ i, x :: vars, Id.Map.add id (Value.of_constr arg) lfun)
+ in
+ let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in
+ let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in
+ (** Build the getter *)
+ let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in
+ let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in
+ let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in
+ let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in
+ (** Evaluate the whole result *)
+ let gl = dummy_goal env evd in
+ let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in
+ let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in
+ Array.map (fun x -> nf (constr_of x)) !tactic_res, snd (Evd.universe_context evd)
+
+let stdlib_modules =
+ [["Coq";"Setoids";"Setoid"];
+ ["Coq";"Lists";"List"];
+ ["Coq";"Init";"Datatypes"];
+ ["Coq";"Init";"Logic"];
+ ]
+
+let coq_constant c =
+ lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c)
+let coq_reference c =
+ lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c)
+
+let coq_mk_Setoid = coq_constant "Build_Setoid_Theory"
+let coq_None = coq_reference "None"
+let coq_Some = coq_reference "Some"
+let coq_eq = coq_constant "eq"
+
+let coq_cons = coq_reference "cons"
+let coq_nil = coq_reference "nil"
+
+let lapp f args = mkApp(Lazy.force f,args)
+
+let plapp evd f args =
+ let fc = Evarutil.e_new_global evd (Lazy.force f) in
+ mkApp(fc,args)
+
+let dest_rel0 t =
+ match kind_of_term t with
+ | App(f,args) when Array.length args >= 2 ->
+ let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in
+ if closed0 rel then
+ (rel,args.(Array.length args - 2),args.(Array.length args - 1))
+ else error "ring: cannot find relation (not closed)"
+ | _ -> error "ring: cannot find relation"
+
+let rec dest_rel t =
+ match kind_of_term t with
+ | Prod(_,_,c) -> dest_rel c
+ | _ -> dest_rel0 t
+
+(****************************************************************************)
+(* Library linking *)
+
+let plugin_dir = "setoid_ring"
+
+let cdir = ["Coq";plugin_dir]
+let plugin_modules =
+ List.map (fun d -> cdir@d)
+ [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"];
+ ["Field_tac"]; ["Field_theory"]
+ ]
+
+let my_constant c =
+ lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c)
+let my_reference c =
+ lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c)
+
+let new_ring_path =
+ DirPath.make (List.map Id.of_string ["Ring_tac";plugin_dir;"Coq"])
+let znew_ring_path =
+ DirPath.make (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"])
+let zltac s =
+ lazy(make_kn (MPfile znew_ring_path) DirPath.empty (Label.make s))
+
+let mk_cst l s = lazy (Coqlib.gen_reference "newring" l s);;
+let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;;
+
+(* Ring theory *)
+
+(* almost_ring defs *)
+let coq_almost_ring_theory = my_constant "almost_ring_theory"
+
+(* setoid and morphism utilities *)
+let coq_eq_setoid = my_reference "Eqsth"
+let coq_eq_morph = my_reference "Eq_ext"
+let coq_eq_smorph = my_reference "Eq_s_ext"
+
+(* ring -> almost_ring utilities *)
+let coq_ring_theory = my_constant "ring_theory"
+let coq_mk_reqe = my_constant "mk_reqe"
+
+(* semi_ring -> almost_ring utilities *)
+let coq_semi_ring_theory = my_constant "semi_ring_theory"
+let coq_mk_seqe = my_constant "mk_seqe"
+
+let coq_abstract = my_constant"Abstract"
+let coq_comp = my_constant"Computational"
+let coq_morph = my_constant"Morphism"
+
+(* power function *)
+let ltac_inv_morph_nothing = zltac"inv_morph_nothing"
+
+(* hypothesis *)
+let coq_mkhypo = my_reference "mkhypo"
+let coq_hypo = my_reference "hypo"
+
+(* Equality: do not evaluate but make recursive call on both sides *)
+let map_with_eq arg_map c =
+ let (req,_,_) = dest_rel c in
+ interp_map
+ ((global_head_of_constr req,(function -1->Prot|_->Rec))::
+ List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
+
+let map_without_eq arg_map _ =
+ interp_map (List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
+
+let _ = add_map "ring"
+ (map_with_eq
+ [coq_cons,(function -1->Eval|2->Rec|_->Prot);
+ coq_nil, (function -1->Eval|_ -> Prot);
+ (* Pphi_dev: evaluate polynomial and coef operations, protect
+ ring operations and make recursive call on the var map *)
+ pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
+ pol_cst "Pphi_pow",
+ (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
+ (* PEeval: evaluate morphism and polynomial, protect ring
+ operations and make recursive call on the var map *)
+ pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)])
+
+(****************************************************************************)
+(* Ring database *)
+
+module Cmap = Map.Make(Constr)
+
+let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table"
+let from_name = Summary.ref Spmap.empty ~name:"ring-tac-name-table"
+
+let ring_for_carrier r = Cmap.find r !from_carrier
+
+let find_ring_structure env sigma l =
+ match l with
+ | t::cl' ->
+ let ty = Retyping.get_type_of env sigma t in
+ let check c =
+ let ty' = Retyping.get_type_of env sigma c in
+ if not (Reductionops.is_conv env sigma ty ty') then
+ errorlabstrm "ring"
+ (str"arguments of ring_simplify do not have all the same type")
+ in
+ List.iter check cl';
+ (try ring_for_carrier ty
+ with Not_found ->
+ errorlabstrm "ring"
+ (str"cannot find a declared ring structure over"++
+ spc()++str"\""++pr_constr ty++str"\""))
+ | [] -> assert false
+
+let add_entry (sp,_kn) e =
+ from_carrier := Cmap.add e.ring_carrier e !from_carrier;
+ from_name := Spmap.add sp e !from_name
+
+
+let subst_th (subst,th) =
+ let c' = subst_mps subst th.ring_carrier in
+ let eq' = subst_mps subst th.ring_req in
+ let set' = subst_mps subst th.ring_setoid in
+ let ext' = subst_mps subst th.ring_ext in
+ let morph' = subst_mps subst th.ring_morph in
+ let th' = subst_mps subst th.ring_th in
+ let thm1' = subst_mps subst th.ring_lemma1 in
+ let thm2' = subst_mps subst th.ring_lemma2 in
+ let tac'= Tacsubst.subst_tactic subst th.ring_cst_tac in
+ let pow_tac'= Tacsubst.subst_tactic subst th.ring_pow_tac in
+ let pretac'= Tacsubst.subst_tactic subst th.ring_pre_tac in
+ let posttac'= Tacsubst.subst_tactic subst th.ring_post_tac in
+ if c' == th.ring_carrier &&
+ eq' == th.ring_req &&
+ eq_constr set' th.ring_setoid &&
+ ext' == th.ring_ext &&
+ morph' == th.ring_morph &&
+ th' == th.ring_th &&
+ thm1' == th.ring_lemma1 &&
+ thm2' == th.ring_lemma2 &&
+ tac' == th.ring_cst_tac &&
+ pow_tac' == th.ring_pow_tac &&
+ pretac' == th.ring_pre_tac &&
+ posttac' == th.ring_post_tac then th
+ else
+ { ring_carrier = c';
+ ring_req = eq';
+ ring_setoid = set';
+ ring_ext = ext';
+ ring_morph = morph';
+ ring_th = th';
+ ring_cst_tac = tac';
+ ring_pow_tac = pow_tac';
+ ring_lemma1 = thm1';
+ ring_lemma2 = thm2';
+ ring_pre_tac = pretac';
+ ring_post_tac = posttac' }
+
+
+let theory_to_obj : ring_info -> obj =
+ let cache_th (name,th) = add_entry name th in
+ declare_object
+ {(default_object "tactic-new-ring-theory") with
+ open_function = (fun i o -> if Int.equal i 1 then cache_th o);
+ cache_function = cache_th;
+ subst_function = subst_th;
+ classify_function = (fun x -> Substitute x)}
+
+
+let setoid_of_relation env evd a r =
+ try
+ let evm = !evd in
+ let evm, refl = Rewrite.get_reflexive_proof env evm a r in
+ let evm, sym = Rewrite.get_symmetric_proof env evm a r in
+ let evm, trans = Rewrite.get_transitive_proof env evm a r in
+ evd := evm;
+ lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |]
+ with Not_found ->
+ error "cannot find setoid relation"
+
+let op_morph r add mul opp req m1 m2 m3 =
+ lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |]
+
+let op_smorph r add mul req m1 m2 =
+ lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |]
+
+(* let default_ring_equality (r,add,mul,opp,req) = *)
+(* let is_setoid = function *)
+(* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *)
+(* eq_constr_nounivs req rel (\* Qu: use conversion ? *\) *)
+(* | _ -> false in *)
+(* match default_relation_for_carrier ~filter:is_setoid r with *)
+(* Leibniz _ -> *)
+(* let setoid = lapp coq_eq_setoid [|r|] in *)
+(* let op_morph = *)
+(* match opp with *)
+(* Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] *)
+(* | None -> lapp coq_eq_smorph [|r;add;mul|] in *)
+(* (setoid,op_morph) *)
+(* | Relation rel -> *)
+(* let setoid = setoid_of_relation rel in *)
+(* let is_endomorphism = function *)
+(* { args=args } -> List.for_all *)
+(* (function (var,Relation rel) -> *)
+(* var=None && eq_constr_nounivs req rel *)
+(* | _ -> false) args in *)
+(* let add_m = *)
+(* try default_morphism ~filter:is_endomorphism add *)
+(* with Not_found -> *)
+(* error "ring addition should be declared as a morphism" in *)
+(* let mul_m = *)
+(* try default_morphism ~filter:is_endomorphism mul *)
+(* with Not_found -> *)
+(* error "ring multiplication should be declared as a morphism" in *)
+(* let op_morph = *)
+(* match opp with *)
+(* | Some opp -> *)
+(* (let opp_m = *)
+(* try default_morphism ~filter:is_endomorphism opp *)
+(* with Not_found -> *)
+(* error "ring opposite should be declared as a morphism" in *)
+(* let op_morph = *)
+(* op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in *)
+(* msgnl *)
+(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++ *)
+(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *)
+(* str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ *)
+(* str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ *)
+(* str"\""); *)
+(* op_morph) *)
+(* | None -> *)
+(* (msgnl *)
+(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ *)
+(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *)
+(* str"\""++spc()++str"and \""++ *)
+(* pr_constr mul_m.morphism_theory++str"\""); *)
+(* op_smorph r add mul req add_m.lem mul_m.lem) in *)
+(* (setoid,op_morph) *)
+
+let ring_equality env evd (r,add,mul,opp,req) =
+ match kind_of_term req with
+ | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) ->
+ let setoid = plapp evd coq_eq_setoid [|r|] in
+ let op_morph =
+ match opp with
+ Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|]
+ | None -> plapp evd coq_eq_smorph [|r;add;mul|] in
+ let setoid = Typing.e_solve_evars env evd setoid in
+ let op_morph = Typing.e_solve_evars env evd op_morph in
+ (setoid,op_morph)
+ | _ ->
+ let setoid = setoid_of_relation (Global.env ()) evd r req in
+ let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in
+ let add_m, add_m_lem =
+ try Rewrite.default_morphism signature add
+ with Not_found ->
+ error "ring addition should be declared as a morphism" in
+ let mul_m, mul_m_lem =
+ try Rewrite.default_morphism signature mul
+ with Not_found ->
+ error "ring multiplication should be declared as a morphism" in
+ let op_morph =
+ match opp with
+ | Some opp ->
+ (let opp_m,opp_m_lem =
+ try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp
+ with Not_found ->
+ error "ring opposite should be declared as a morphism" in
+ let op_morph =
+ op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in
+ Flags.if_verbose
+ Feedback.msg_info
+ (str"Using setoid \""++pr_constr req++str"\""++spc()++
+ str"and morphisms \""++pr_constr add_m_lem ++
+ str"\","++spc()++ str"\""++pr_constr mul_m_lem++
+ str"\""++spc()++str"and \""++pr_constr opp_m_lem++
+ str"\"");
+ op_morph)
+ | None ->
+ (Flags.if_verbose
+ Feedback.msg_info
+ (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++
+ str"and morphisms \""++pr_constr add_m_lem ++
+ str"\""++spc()++str"and \""++
+ pr_constr mul_m_lem++str"\"");
+ op_smorph r add mul req add_m_lem mul_m_lem) in
+ (setoid,op_morph)
+
+let build_setoid_params env evd r add mul opp req eqth =
+ match eqth with
+ Some th -> th
+ | None -> ring_equality env evd (r,add,mul,opp,req)
+
+let dest_ring env sigma th_spec =
+ let th_typ = Retyping.get_type_of env sigma th_spec in
+ match kind_of_term th_typ with
+ App(f,[|r;zero;one;add;mul;sub;opp;req|])
+ when eq_constr_nounivs f (Lazy.force coq_almost_ring_theory) ->
+ (None,r,zero,one,add,mul,Some sub,Some opp,req)
+ | App(f,[|r;zero;one;add;mul;req|])
+ when eq_constr_nounivs f (Lazy.force coq_semi_ring_theory) ->
+ (Some true,r,zero,one,add,mul,None,None,req)
+ | App(f,[|r;zero;one;add;mul;sub;opp;req|])
+ when eq_constr_nounivs f (Lazy.force coq_ring_theory) ->
+ (Some false,r,zero,one,add,mul,Some sub,Some opp,req)
+ | _ -> error "bad ring structure"
+
+
+let reflect_coeff rkind =
+ (* We build an ill-typed terms on purpose... *)
+ match rkind with
+ Abstract -> Lazy.force coq_abstract
+ | Computational c -> lapp coq_comp [|c|]
+ | Morphism m -> lapp coq_morph [|m|]
+
+let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac =
+ match cst_tac with
+ Some (CstTac t) -> Tacintern.glob_tactic t
+ | Some (Closed lc) ->
+ closed_term_ast (List.map Smartlocate.global_with_alias lc)
+ | None ->
+ let t = ArgArg(Loc.ghost,Lazy.force ltac_inv_morph_nothing) in
+ TacArg(Loc.ghost,TacCall(Loc.ghost,t,[]))
+
+let make_hyp env evd c =
+ let t = Retyping.get_type_of env !evd c in
+ plapp evd coq_mkhypo [|t;c|]
+
+let make_hyp_list env evd lH =
+ let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
+ let l =
+ List.fold_right
+ (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH
+ (plapp evd coq_nil [|carrier|])
+ in
+ let l' = Typing.e_solve_evars env evd l in
+ Evarutil.nf_evars_universes !evd l'
+
+let interp_power env evd pow =
+ let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
+ match pow with
+ | None ->
+ let t = ArgArg(Loc.ghost, Lazy.force ltac_inv_morph_nothing) in
+ (TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])), plapp evd coq_None [|carrier|])
+ | Some (tac, spec) ->
+ let tac =
+ match tac with
+ | CstTac t -> Tacintern.glob_tactic t
+ | Closed lc ->
+ closed_term_ast (List.map Smartlocate.global_with_alias lc) in
+ let spec = make_hyp env evd (ic_unsafe spec) in
+ (tac, plapp evd coq_Some [|carrier; spec|])
+
+let interp_sign env evd sign =
+ let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
+ match sign with
+ | None -> plapp evd coq_None [|carrier|]
+ | Some spec ->
+ let spec = make_hyp env evd (ic_unsafe spec) in
+ plapp evd coq_Some [|carrier;spec|]
+ (* Same remark on ill-typed terms ... *)
+
+let interp_div env evd div =
+ let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
+ match div with
+ | None -> plapp evd coq_None [|carrier|]
+ | Some spec ->
+ let spec = make_hyp env evd (ic_unsafe spec) in
+ plapp evd coq_Some [|carrier;spec|]
+ (* Same remark on ill-typed terms ... *)
+
+let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div =
+ check_required_library (cdir@["Ring_base"]);
+ let env = Global.env() in
+ let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in
+ let evd = ref sigma in
+ let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in
+ let (pow_tac, pspec) = interp_power env evd power in
+ let sspec = interp_sign env evd sign in
+ let dspec = interp_div env evd div in
+ let rk = reflect_coeff morphth in
+ let params,ctx =
+ exec_tactic env !evd 5 (zltac "ring_lemmas")
+ [sth;ext;rth;pspec;sspec;dspec;rk] in
+ let lemma1 = params.(3) in
+ let lemma2 = params.(4) in
+
+ let lemma1 =
+ decl_constant (Id.to_string name^"_ring_lemma1") ctx lemma1 in
+ let lemma2 =
+ decl_constant (Id.to_string name^"_ring_lemma2") ctx lemma2 in
+ let cst_tac =
+ interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in
+ let pretac =
+ match pre with
+ Some t -> Tacintern.glob_tactic t
+ | _ -> TacId [] in
+ let posttac =
+ match post with
+ Some t -> Tacintern.glob_tactic t
+ | _ -> TacId [] in
+ let _ =
+ Lib.add_leaf name
+ (theory_to_obj
+ { ring_carrier = r;
+ ring_req = req;
+ ring_setoid = sth;
+ ring_ext = params.(1);
+ ring_morph = params.(2);
+ ring_th = params.(0);
+ ring_cst_tac = cst_tac;
+ ring_pow_tac = pow_tac;
+ ring_lemma1 = lemma1;
+ ring_lemma2 = lemma2;
+ ring_pre_tac = pretac;
+ ring_post_tac = posttac }) in
+ ()
+
+let ic_coeff_spec = function
+ | Computational t -> Computational (ic_unsafe t)
+ | Morphism t -> Morphism (ic_unsafe t)
+ | Abstract -> Abstract
+
+
+let set_once s r v =
+ if Option.is_empty !r then r := Some v else error (s^" cannot be set twice")
+
+let process_ring_mods l =
+ let kind = ref None in
+ let set = ref None in
+ let cst_tac = ref None in
+ let pre = ref None in
+ let post = ref None in
+ let sign = ref None in
+ let power = ref None in
+ let div = ref None in
+ List.iter(function
+ Ring_kind k -> set_once "ring kind" kind (ic_coeff_spec k)
+ | Const_tac t -> set_once "tactic recognizing constants" cst_tac t
+ | Pre_tac t -> set_once "preprocess tactic" pre t
+ | Post_tac t -> set_once "postprocess tactic" post t
+ | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext)
+ | Pow_spec(t,spec) -> set_once "power" power (t,spec)
+ | Sign_spec t -> set_once "sign" sign t
+ | Div_spec t -> set_once "div" div t) l;
+ let k = match !kind with Some k -> k | None -> Abstract in
+ (k, !set, !cst_tac, !pre, !post, !power, !sign, !div)
+
+(*****************************************************************************)
+(* The tactics consist then only in a lookup in the ring database and
+ call the appropriate ltac. *)
+
+let make_args_list rl t =
+ match rl with
+ | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2]
+ | _ -> rl
+
+let make_term_list env evd carrier rl =
+ let l = List.fold_right
+ (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl
+ (plapp evd coq_nil [|carrier|])
+ in Typing.e_solve_evars env evd l
+
+let carg = Tacinterp.Value.of_constr
+let tacarg expr =
+ Tacinterp.Value.of_closure (Tacinterp.default_ist ()) expr
+
+let ltac_ring_structure e =
+ let req = carg e.ring_req in
+ let sth = carg e.ring_setoid in
+ let ext = carg e.ring_ext in
+ let morph = carg e.ring_morph in
+ let th = carg e.ring_th in
+ let cst_tac = tacarg e.ring_cst_tac in
+ let pow_tac = tacarg e.ring_pow_tac in
+ let lemma1 = carg e.ring_lemma1 in
+ let lemma2 = carg e.ring_lemma2 in
+ let pretac = tacarg (TacFun([None],e.ring_pre_tac)) in
+ let posttac = tacarg (TacFun([None],e.ring_post_tac)) in
+ [req;sth;ext;morph;th;cst_tac;pow_tac;
+ lemma1;lemma2;pretac;posttac]
+
+let ring_lookup (f : Value.t) lH rl t =
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
+ let env = Proofview.Goal.env gl in
+ try (* find_ring_strucure can raise an exception *)
+ let evdref = ref sigma in
+ let rl = make_args_list rl t in
+ let e = find_ring_structure env sigma rl in
+ let rl = carg (make_term_list env evdref e.ring_carrier rl) in
+ let lH = carg (make_hyp_list env evdref lH) in
+ let ring = ltac_ring_structure e in
+ Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl]))
+ with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
+ end }
+
+(***********************************************************************)
+
+let new_field_path =
+ DirPath.make (List.map Id.of_string ["Field_tac";plugin_dir;"Coq"])
+
+let field_ltac s =
+ lazy(make_kn (MPfile new_field_path) DirPath.empty (Label.make s))
+
+
+let _ = add_map "field"
+ (map_with_eq
+ [coq_cons,(function -1->Eval|2->Rec|_->Prot);
+ coq_nil, (function -1->Eval|_ -> Prot);
+ (* display_linear: evaluate polynomials and coef operations, protect
+ field operations and make recursive call on the var map *)
+ my_reference "display_linear",
+ (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot);
+ my_reference "display_pow_linear",
+ (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot);
+ (* Pphi_dev: evaluate polynomial and coef operations, protect
+ ring operations and make recursive call on the var map *)
+ pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
+ pol_cst "Pphi_pow",
+ (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
+ (* PEeval: evaluate morphism and polynomial, protect ring
+ operations and make recursive call on the var map *)
+ pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot);
+ (* FEeval: evaluate morphism, protect field
+ operations and make recursive call on the var map *)
+ my_reference "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
+
+let _ = add_map "field_cond"
+ (map_without_eq
+ [coq_cons,(function -1->Eval|2->Rec|_->Prot);
+ coq_nil, (function -1->Eval|_ -> Prot);
+ (* PCond: evaluate morphism and denum list, protect ring
+ operations and make recursive call on the var map *)
+ my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);;
+(* (function -1|9|11->Eval|10->Rec|_->Prot)]);;*)
+
+
+let _ = Redexpr.declare_reduction "simpl_field_expr"
+ (protect_red "field")
+
+
+
+let afield_theory = my_reference "almost_field_theory"
+let field_theory = my_reference "field_theory"
+let sfield_theory = my_reference "semi_field_theory"
+let af_ar = my_reference"AF_AR"
+let f_r = my_reference"F_R"
+let sf_sr = my_reference"SF_SR"
+let dest_field env evd th_spec =
+ let th_typ = Retyping.get_type_of env !evd th_spec in
+ match kind_of_term th_typ with
+ | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
+ when is_global (Lazy.force afield_theory) f ->
+ let rth = plapp evd af_ar
+ [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
+ (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
+ | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
+ when is_global (Lazy.force field_theory) f ->
+ let rth =
+ plapp evd f_r
+ [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
+ (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
+ | App(f,[|r;zero;one;add;mul;div;inv;req|])
+ when is_global (Lazy.force sfield_theory) f ->
+ let rth = plapp evd sf_sr
+ [|r;zero;one;add;mul;div;inv;req;th_spec|] in
+ (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
+ | _ -> error "bad field structure"
+
+let field_from_carrier = Summary.ref Cmap.empty ~name:"field-tac-carrier-table"
+let field_from_name = Summary.ref Spmap.empty ~name:"field-tac-name-table"
+
+let field_for_carrier r = Cmap.find r !field_from_carrier
+
+let find_field_structure env sigma l =
+ check_required_library (cdir@["Field_tac"]);
+ match l with
+ | t::cl' ->
+ let ty = Retyping.get_type_of env sigma t in
+ let check c =
+ let ty' = Retyping.get_type_of env sigma c in
+ if not (Reductionops.is_conv env sigma ty ty') then
+ errorlabstrm "field"
+ (str"arguments of field_simplify do not have all the same type")
+ in
+ List.iter check cl';
+ (try field_for_carrier ty
+ with Not_found ->
+ errorlabstrm "field"
+ (str"cannot find a declared field structure over"++
+ spc()++str"\""++pr_constr ty++str"\""))
+ | [] -> assert false
+
+let add_field_entry (sp,_kn) e =
+ field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier;
+ field_from_name := Spmap.add sp e !field_from_name
+
+let subst_th (subst,th) =
+ let c' = subst_mps subst th.field_carrier in
+ let eq' = subst_mps subst th.field_req in
+ let thm1' = subst_mps subst th.field_ok in
+ let thm2' = subst_mps subst th.field_simpl_eq_ok in
+ let thm3' = subst_mps subst th.field_simpl_ok in
+ let thm4' = subst_mps subst th.field_simpl_eq_in_ok in
+ let thm5' = subst_mps subst th.field_cond in
+ let tac'= Tacsubst.subst_tactic subst th.field_cst_tac in
+ let pow_tac' = Tacsubst.subst_tactic subst th.field_pow_tac in
+ let pretac'= Tacsubst.subst_tactic subst th.field_pre_tac in
+ let posttac'= Tacsubst.subst_tactic subst th.field_post_tac in
+ if c' == th.field_carrier &&
+ eq' == th.field_req &&
+ thm1' == th.field_ok &&
+ thm2' == th.field_simpl_eq_ok &&
+ thm3' == th.field_simpl_ok &&
+ thm4' == th.field_simpl_eq_in_ok &&
+ thm5' == th.field_cond &&
+ tac' == th.field_cst_tac &&
+ pow_tac' == th.field_pow_tac &&
+ pretac' == th.field_pre_tac &&
+ posttac' == th.field_post_tac then th
+ else
+ { field_carrier = c';
+ field_req = eq';
+ field_cst_tac = tac';
+ field_pow_tac = pow_tac';
+ field_ok = thm1';
+ field_simpl_eq_ok = thm2';
+ field_simpl_ok = thm3';
+ field_simpl_eq_in_ok = thm4';
+ field_cond = thm5';
+ field_pre_tac = pretac';
+ field_post_tac = posttac' }
+
+let ftheory_to_obj : field_info -> obj =
+ let cache_th (name,th) = add_field_entry name th in
+ declare_object
+ {(default_object "tactic-new-field-theory") with
+ open_function = (fun i o -> if Int.equal i 1 then cache_th o);
+ cache_function = cache_th;
+ subst_function = subst_th;
+ classify_function = (fun x -> Substitute x) }
+
+let field_equality evd r inv req =
+ match kind_of_term req with
+ | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) ->
+ mkApp(Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr,[|r;r;inv|])
+ | _ ->
+ let _setoid = setoid_of_relation (Global.env ()) evd r req in
+ let signature = [Some (r,Some req)],Some(r,Some req) in
+ let inv_m, inv_m_lem =
+ try Rewrite.default_morphism signature inv
+ with Not_found ->
+ error "field inverse should be declared as a morphism" in
+ inv_m_lem
+
+let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power sign odiv =
+ check_required_library (cdir@["Field_tac"]);
+ let env = Global.env() in
+ let evd = ref sigma in
+ let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) =
+ dest_field env evd fth in
+ let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in
+ let eqth = Some(sth,ext) in
+ let _ = add_theory name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in
+ let (pow_tac, pspec) = interp_power env evd power in
+ let sspec = interp_sign env evd sign in
+ let dspec = interp_div env evd odiv in
+ let inv_m = field_equality evd r inv req in
+ let rk = reflect_coeff morphth in
+ let params,ctx =
+ exec_tactic env !evd 9 (field_ltac"field_lemmas")
+ [sth;ext;inv_m;fth;pspec;sspec;dspec;rk] in
+ let lemma1 = params.(3) in
+ let lemma2 = params.(4) in
+ let lemma3 = params.(5) in
+ let lemma4 = params.(6) in
+ let cond_lemma =
+ match inj with
+ | Some thm -> mkApp(params.(8),[|thm|])
+ | None -> params.(7) in
+ let lemma1 = decl_constant (Id.to_string name^"_field_lemma1")
+ ctx lemma1 in
+ let lemma2 = decl_constant (Id.to_string name^"_field_lemma2")
+ ctx lemma2 in
+ let lemma3 = decl_constant (Id.to_string name^"_field_lemma3")
+ ctx lemma3 in
+ let lemma4 = decl_constant (Id.to_string name^"_field_lemma4")
+ ctx lemma4 in
+ let cond_lemma = decl_constant (Id.to_string name^"_lemma5")
+ ctx cond_lemma in
+ let cst_tac =
+ interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in
+ let pretac =
+ match pre with
+ Some t -> Tacintern.glob_tactic t
+ | _ -> TacId [] in
+ let posttac =
+ match post with
+ Some t -> Tacintern.glob_tactic t
+ | _ -> TacId [] in
+ let _ =
+ Lib.add_leaf name
+ (ftheory_to_obj
+ { field_carrier = r;
+ field_req = req;
+ field_cst_tac = cst_tac;
+ field_pow_tac = pow_tac;
+ field_ok = lemma1;
+ field_simpl_eq_ok = lemma2;
+ field_simpl_ok = lemma3;
+ field_simpl_eq_in_ok = lemma4;
+ field_cond = cond_lemma;
+ field_pre_tac = pretac;
+ field_post_tac = posttac }) in ()
+
+let process_field_mods l =
+ let kind = ref None in
+ let set = ref None in
+ let cst_tac = ref None in
+ let pre = ref None in
+ let post = ref None in
+ let inj = ref None in
+ let sign = ref None in
+ let power = ref None in
+ let div = ref None in
+ List.iter(function
+ Ring_mod(Ring_kind k) -> set_once "field kind" kind (ic_coeff_spec k)
+ | Ring_mod(Const_tac t) ->
+ set_once "tactic recognizing constants" cst_tac t
+ | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t
+ | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t
+ | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext)
+ | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec)
+ | Ring_mod(Sign_spec t) -> set_once "sign" sign t
+ | Ring_mod(Div_spec t) -> set_once "div" div t
+ | Inject i -> set_once "infinite property" inj (ic_unsafe i)) l;
+ let k = match !kind with Some k -> k | None -> Abstract in
+ (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div)
+
+let ltac_field_structure e =
+ let req = carg e.field_req in
+ let cst_tac = tacarg e.field_cst_tac in
+ let pow_tac = tacarg e.field_pow_tac in
+ let field_ok = carg e.field_ok in
+ let field_simpl_ok = carg e.field_simpl_ok in
+ let field_simpl_eq_ok = carg e.field_simpl_eq_ok in
+ let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in
+ let cond_ok = carg e.field_cond in
+ let pretac = tacarg (TacFun([None],e.field_pre_tac)) in
+ let posttac = tacarg (TacFun([None],e.field_post_tac)) in
+ [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
+ field_simpl_eq_in_ok;cond_ok;pretac;posttac]
+
+let field_lookup (f : Value.t) lH rl t =
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
+ let env = Proofview.Goal.env gl in
+ try
+ let evdref = ref sigma in
+ let rl = make_args_list rl t in
+ let e = find_field_structure env sigma rl in
+ let rl = carg (make_term_list env evdref e.field_carrier rl) in
+ let lH = carg (make_hyp_list env evdref lH) in
+ let field = ltac_field_structure e in
+ Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl]))
+ with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
+ end }
diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4
deleted file mode 100644
index e704c466..00000000
--- a/plugins/setoid_ring/newring.ml4
+++ /dev/null
@@ -1,1162 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* f (Evar.repr i) c
- | _ -> assert false
-
-type protect_flag = Eval|Prot|Rec
-
-let tag_arg tag_rec map subs i c =
- match map i with
- Eval -> mk_clos subs c
- | Prot -> mk_atom c
- | Rec -> if Int.equal i (-1) then mk_clos subs c else tag_rec c
-
-let global_head_of_constr c =
- let f, args = decompose_app c in
- try global_of_constr f
- with Not_found -> anomaly (str "global_head_of_constr")
-
-let global_of_constr_nofail c =
- try global_of_constr c
- with Not_found -> VarRef (Id.of_string "dummy")
-
-let rec mk_clos_but f_map subs t =
- match f_map (global_of_constr_nofail t) with
- | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t
- | None ->
- (match kind_of_term t with
- App(f,args) -> mk_clos_app_but f_map subs f args 0
- | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t
- | _ -> mk_atom t)
-
-and mk_clos_app_but f_map subs f args n =
- if n >= Array.length args then mk_atom(mkApp(f, args))
- else
- let fargs, args' = Array.chop n args in
- let f' = mkApp(f,fargs) in
- match f_map (global_of_constr_nofail f') with
- Some map ->
- mk_clos_deep
- (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s'))
- subs
- (mkApp (mark_arg (-1) f', Array.mapi mark_arg args'))
- | None -> mk_clos_app_but f_map subs f args (n+1)
-
-let interp_map l t =
- try Some(List.assoc_f eq_gr t l) with Not_found -> None
-
-let protect_maps = ref String.Map.empty
-let add_map s m = protect_maps := String.Map.add s m !protect_maps
-let lookup_map map =
- try String.Map.find map !protect_maps
- with Not_found ->
- errorlabstrm"lookup_map"(str"map "++qs map++str"not found")
-
-let protect_red map env sigma c =
- kl (create_clos_infos betadeltaiota env)
- (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);;
-
-let protect_tac map =
- Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
-
-let protect_tac_in map id =
- Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp));;
-
-
-TACTIC EXTEND protect_fv
- [ "protect_fv" string(map) "in" ident(id) ] ->
- [ Proofview.V82.tactic (protect_tac_in map id) ]
-| [ "protect_fv" string(map) ] ->
- [ Proofview.V82.tactic (protect_tac map) ]
-END;;
-
-(****************************************************************************)
-
-let closed_term t l =
- let l = List.map Universes.constr_of_global l in
- let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in
- if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt())
-;;
-
-TACTIC EXTEND closed_term
- [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
- [ Proofview.V82.tactic (closed_term t l) ]
-END
-;;
-
-(* TACTIC EXTEND echo
-| [ "echo" constr(t) ] ->
- [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ]
-END;;*)
-
-(*
-let closed_term_ast l =
- TacFun([Some(Id.of_string"t")],
- TacAtom(Loc.ghost,TacExtend(Loc.ghost,"closed_term",
- [Genarg.in_gen Constrarg.wit_constr (mkVar(Id.of_string"t"));
- Genarg.in_gen (Genarg.wit_list Constrarg.wit_ref) l])))
-*)
-let closed_term_ast l =
- let tacname = {
- mltac_plugin = "newring_plugin";
- mltac_tactic = "closed_term";
- } in
- let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in
- TacFun([Some(Id.of_string"t")],
- TacML(Loc.ghost,tacname,
- [Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None);
- Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l]))
-(*
-let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term"
-*)
-
-(****************************************************************************)
-
-let ic c =
- let env = Global.env() in
- let sigma = Evd.from_env env in
- Constrintern.interp_open_constr env sigma c
-
-let ic_unsafe c = (*FIXME remove *)
- let env = Global.env() in
- let sigma = Evd.from_env env in
- fst (Constrintern.interp_constr env sigma c)
-
-let ty c =
- let env = Global.env() in
- let sigma = Evd.from_env env in
- Typing.unsafe_type_of env sigma c
-
-let decl_constant na ctx c =
- let vars = Universes.universes_of_constr c in
- let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in
- mkConst(declare_constant (Id.of_string na)
- (DefinitionEntry (definition_entry ~opaque:true
- ~univs:(Univ.ContextSet.to_context ctx) c),
- IsProof Lemma))
-
-(* Calling a global tactic *)
-let ltac_call tac (args:glob_tactic_arg list) =
- TacArg(Loc.ghost,TacCall(Loc.ghost, ArgArg(Loc.ghost, Lazy.force tac),args))
-
-(* Calling a locally bound tactic *)
-let ltac_lcall tac args =
- TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args))
-
-let ltac_letin (x, e1) e2 =
- TacLetIn(false,[(Loc.ghost,Id.of_string x),e1],e2)
-
-let ltac_apply (f:glob_tactic_expr) (args:glob_tactic_arg list) =
- Tacinterp.eval_tactic
- (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args))
-
-let ltac_record flds =
- TacFun([Some(Id.of_string"proj")], ltac_lcall "proj" flds)
-
-
-let carg c = TacDynamic(Loc.ghost,Pretyping.constr_in c)
-
-let dummy_goal env sigma =
- let (gl,_,sigma) =
- Goal.V82.mk_goal sigma (named_context_val env) mkProp Evd.Store.empty in
- {Evd.it = gl; Evd.sigma = sigma}
-
-let constr_of v = match Value.to_constr v with
- | Some c -> c
- | None -> failwith "Ring.exec_tactic: anomaly"
-
-let exec_tactic env evd n f args =
- let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in
- let res = ref [||] in
- let get_res ist =
- let l = List.map (fun id -> Id.Map.find id ist.lfun) lid in
- res := Array.of_list l;
- TacId[] in
- let getter =
- Tacexp(TacFun(List.map(fun id -> Some id) lid,
- Tacintern.glob_tactic(tacticIn get_res))) in
- let gl = dummy_goal env evd in
- let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) gl in
- let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in
- Array.map (fun x -> nf (constr_of x)) !res, snd (Evd.universe_context evd)
-
-let stdlib_modules =
- [["Coq";"Setoids";"Setoid"];
- ["Coq";"Lists";"List"];
- ["Coq";"Init";"Datatypes"];
- ["Coq";"Init";"Logic"];
- ]
-
-let coq_constant c =
- lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c)
-let coq_reference c =
- lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c)
-
-let coq_mk_Setoid = coq_constant "Build_Setoid_Theory"
-let coq_None = coq_reference "None"
-let coq_Some = coq_reference "Some"
-let coq_eq = coq_constant "eq"
-
-let coq_cons = coq_reference "cons"
-let coq_nil = coq_reference "nil"
-
-let lapp f args = mkApp(Lazy.force f,args)
-
-let plapp evd f args =
- let fc = Evarutil.e_new_global evd (Lazy.force f) in
- mkApp(fc,args)
-
-let dest_rel0 t =
- match kind_of_term t with
- | App(f,args) when Array.length args >= 2 ->
- let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in
- if closed0 rel then
- (rel,args.(Array.length args - 2),args.(Array.length args - 1))
- else error "ring: cannot find relation (not closed)"
- | _ -> error "ring: cannot find relation"
-
-let rec dest_rel t =
- match kind_of_term t with
- | Prod(_,_,c) -> dest_rel c
- | _ -> dest_rel0 t
-
-(****************************************************************************)
-(* Library linking *)
-
-let plugin_dir = "setoid_ring"
-
-let cdir = ["Coq";plugin_dir]
-let plugin_modules =
- List.map (fun d -> cdir@d)
- [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"];
- ["Field_tac"]; ["Field_theory"]
- ]
-
-let my_constant c =
- lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c)
-let my_reference c =
- lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c)
-
-let new_ring_path =
- DirPath.make (List.map Id.of_string ["Ring_tac";plugin_dir;"Coq"])
-let ltac s =
- lazy(make_kn (MPfile new_ring_path) DirPath.empty (Label.make s))
-let znew_ring_path =
- DirPath.make (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"])
-let zltac s =
- lazy(make_kn (MPfile znew_ring_path) DirPath.empty (Label.make s))
-
-let mk_cst l s = lazy (Coqlib.gen_reference "newring" l s);;
-let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;;
-
-(* Ring theory *)
-
-(* almost_ring defs *)
-let coq_almost_ring_theory = my_constant "almost_ring_theory"
-
-(* setoid and morphism utilities *)
-let coq_eq_setoid = my_reference "Eqsth"
-let coq_eq_morph = my_reference "Eq_ext"
-let coq_eq_smorph = my_reference "Eq_s_ext"
-
-(* ring -> almost_ring utilities *)
-let coq_ring_theory = my_constant "ring_theory"
-let coq_mk_reqe = my_constant "mk_reqe"
-
-(* semi_ring -> almost_ring utilities *)
-let coq_semi_ring_theory = my_constant "semi_ring_theory"
-let coq_mk_seqe = my_constant "mk_seqe"
-
-let ltac_inv_morph_gen = zltac"inv_gen_phi"
-let ltac_inv_morphZ = zltac"inv_gen_phiZ"
-let ltac_inv_morphN = zltac"inv_gen_phiN"
-let ltac_inv_morphNword = zltac"inv_gen_phiNword"
-let coq_abstract = my_constant"Abstract"
-let coq_comp = my_constant"Computational"
-let coq_morph = my_constant"Morphism"
-
-(* morphism *)
-let coq_ring_morph = my_constant "ring_morph"
-let coq_semi_morph = my_constant "semi_morph"
-
-(* power function *)
-let ltac_inv_morph_nothing = zltac"inv_morph_nothing"
-let coq_pow_N_pow_N = my_constant "pow_N_pow_N"
-
-(* hypothesis *)
-let coq_mkhypo = my_reference "mkhypo"
-let coq_hypo = my_reference "hypo"
-
-(* Equality: do not evaluate but make recursive call on both sides *)
-let map_with_eq arg_map c =
- let (req,_,_) = dest_rel c in
- interp_map
- ((global_head_of_constr req,(function -1->Prot|_->Rec))::
- List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
-
-let map_without_eq arg_map _ =
- interp_map (List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
-
-let _ = add_map "ring"
- (map_with_eq
- [coq_cons,(function -1->Eval|2->Rec|_->Prot);
- coq_nil, (function -1->Eval|_ -> Prot);
- (* Pphi_dev: evaluate polynomial and coef operations, protect
- ring operations and make recursive call on the var map *)
- pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
- pol_cst "Pphi_pow",
- (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
- (* PEeval: evaluate morphism and polynomial, protect ring
- operations and make recursive call on the var map *)
- pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)])
-
-(****************************************************************************)
-(* Ring database *)
-
-type ring_info =
- { ring_carrier : types;
- ring_req : constr;
- ring_setoid : constr;
- ring_ext : constr;
- ring_morph : constr;
- ring_th : constr;
- ring_cst_tac : glob_tactic_expr;
- ring_pow_tac : glob_tactic_expr;
- ring_lemma1 : constr;
- ring_lemma2 : constr;
- ring_pre_tac : glob_tactic_expr;
- ring_post_tac : glob_tactic_expr }
-
-module Cmap = Map.Make(Constr)
-
-let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table"
-let from_name = Summary.ref Spmap.empty ~name:"ring-tac-name-table"
-
-let ring_for_carrier r = Cmap.find r !from_carrier
-
-let find_ring_structure env sigma l =
- match l with
- | t::cl' ->
- let ty = Retyping.get_type_of env sigma t in
- let check c =
- let ty' = Retyping.get_type_of env sigma c in
- if not (Reductionops.is_conv env sigma ty ty') then
- errorlabstrm "ring"
- (str"arguments of ring_simplify do not have all the same type")
- in
- List.iter check cl';
- (try ring_for_carrier ty
- with Not_found ->
- errorlabstrm "ring"
- (str"cannot find a declared ring structure over"++
- spc()++str"\""++pr_constr ty++str"\""))
- | [] -> assert false
-
-let add_entry (sp,_kn) e =
- from_carrier := Cmap.add e.ring_carrier e !from_carrier;
- from_name := Spmap.add sp e !from_name
-
-
-let subst_th (subst,th) =
- let c' = subst_mps subst th.ring_carrier in
- let eq' = subst_mps subst th.ring_req in
- let set' = subst_mps subst th.ring_setoid in
- let ext' = subst_mps subst th.ring_ext in
- let morph' = subst_mps subst th.ring_morph in
- let th' = subst_mps subst th.ring_th in
- let thm1' = subst_mps subst th.ring_lemma1 in
- let thm2' = subst_mps subst th.ring_lemma2 in
- let tac'= Tacsubst.subst_tactic subst th.ring_cst_tac in
- let pow_tac'= Tacsubst.subst_tactic subst th.ring_pow_tac in
- let pretac'= Tacsubst.subst_tactic subst th.ring_pre_tac in
- let posttac'= Tacsubst.subst_tactic subst th.ring_post_tac in
- if c' == th.ring_carrier &&
- eq' == th.ring_req &&
- eq_constr set' th.ring_setoid &&
- ext' == th.ring_ext &&
- morph' == th.ring_morph &&
- th' == th.ring_th &&
- thm1' == th.ring_lemma1 &&
- thm2' == th.ring_lemma2 &&
- tac' == th.ring_cst_tac &&
- pow_tac' == th.ring_pow_tac &&
- pretac' == th.ring_pre_tac &&
- posttac' == th.ring_post_tac then th
- else
- { ring_carrier = c';
- ring_req = eq';
- ring_setoid = set';
- ring_ext = ext';
- ring_morph = morph';
- ring_th = th';
- ring_cst_tac = tac';
- ring_pow_tac = pow_tac';
- ring_lemma1 = thm1';
- ring_lemma2 = thm2';
- ring_pre_tac = pretac';
- ring_post_tac = posttac' }
-
-
-let theory_to_obj : ring_info -> obj =
- let cache_th (name,th) = add_entry name th in
- declare_object
- {(default_object "tactic-new-ring-theory") with
- open_function = (fun i o -> if Int.equal i 1 then cache_th o);
- cache_function = cache_th;
- subst_function = subst_th;
- classify_function = (fun x -> Substitute x)}
-
-
-let setoid_of_relation env evd a r =
- try
- let evm = !evd in
- let evm, refl = Rewrite.get_reflexive_proof env evm a r in
- let evm, sym = Rewrite.get_symmetric_proof env evm a r in
- let evm, trans = Rewrite.get_transitive_proof env evm a r in
- evd := evm;
- lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |]
- with Not_found ->
- error "cannot find setoid relation"
-
-let op_morph r add mul opp req m1 m2 m3 =
- lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |]
-
-let op_smorph r add mul req m1 m2 =
- lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |]
-
-(* let default_ring_equality (r,add,mul,opp,req) = *)
-(* let is_setoid = function *)
-(* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *)
-(* eq_constr_nounivs req rel (\* Qu: use conversion ? *\) *)
-(* | _ -> false in *)
-(* match default_relation_for_carrier ~filter:is_setoid r with *)
-(* Leibniz _ -> *)
-(* let setoid = lapp coq_eq_setoid [|r|] in *)
-(* let op_morph = *)
-(* match opp with *)
-(* Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] *)
-(* | None -> lapp coq_eq_smorph [|r;add;mul|] in *)
-(* (setoid,op_morph) *)
-(* | Relation rel -> *)
-(* let setoid = setoid_of_relation rel in *)
-(* let is_endomorphism = function *)
-(* { args=args } -> List.for_all *)
-(* (function (var,Relation rel) -> *)
-(* var=None && eq_constr_nounivs req rel *)
-(* | _ -> false) args in *)
-(* let add_m = *)
-(* try default_morphism ~filter:is_endomorphism add *)
-(* with Not_found -> *)
-(* error "ring addition should be declared as a morphism" in *)
-(* let mul_m = *)
-(* try default_morphism ~filter:is_endomorphism mul *)
-(* with Not_found -> *)
-(* error "ring multiplication should be declared as a morphism" in *)
-(* let op_morph = *)
-(* match opp with *)
-(* | Some opp -> *)
-(* (let opp_m = *)
-(* try default_morphism ~filter:is_endomorphism opp *)
-(* with Not_found -> *)
-(* error "ring opposite should be declared as a morphism" in *)
-(* let op_morph = *)
-(* op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in *)
-(* msgnl *)
-(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++ *)
-(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *)
-(* str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ *)
-(* str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ *)
-(* str"\""); *)
-(* op_morph) *)
-(* | None -> *)
-(* (msgnl *)
-(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ *)
-(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *)
-(* str"\""++spc()++str"and \""++ *)
-(* pr_constr mul_m.morphism_theory++str"\""); *)
-(* op_smorph r add mul req add_m.lem mul_m.lem) in *)
-(* (setoid,op_morph) *)
-
-let ring_equality env evd (r,add,mul,opp,req) =
- match kind_of_term req with
- | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) ->
- let setoid = plapp evd coq_eq_setoid [|r|] in
- let op_morph =
- match opp with
- Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|]
- | None -> plapp evd coq_eq_smorph [|r;add;mul|] in
- let setoid = Typing.solve_evars env evd setoid in
- let op_morph = Typing.solve_evars env evd op_morph in
- (setoid,op_morph)
- | _ ->
- let setoid = setoid_of_relation (Global.env ()) evd r req in
- let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in
- let add_m, add_m_lem =
- try Rewrite.default_morphism signature add
- with Not_found ->
- error "ring addition should be declared as a morphism" in
- let mul_m, mul_m_lem =
- try Rewrite.default_morphism signature mul
- with Not_found ->
- error "ring multiplication should be declared as a morphism" in
- let op_morph =
- match opp with
- | Some opp ->
- (let opp_m,opp_m_lem =
- try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp
- with Not_found ->
- error "ring opposite should be declared as a morphism" in
- let op_morph =
- op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in
- Flags.if_verbose
- msg_info
- (str"Using setoid \""++pr_constr req++str"\""++spc()++
- str"and morphisms \""++pr_constr add_m_lem ++
- str"\","++spc()++ str"\""++pr_constr mul_m_lem++
- str"\""++spc()++str"and \""++pr_constr opp_m_lem++
- str"\"");
- op_morph)
- | None ->
- (Flags.if_verbose
- msg_info
- (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++
- str"and morphisms \""++pr_constr add_m_lem ++
- str"\""++spc()++str"and \""++
- pr_constr mul_m_lem++str"\"");
- op_smorph r add mul req add_m_lem mul_m_lem) in
- (setoid,op_morph)
-
-let build_setoid_params env evd r add mul opp req eqth =
- match eqth with
- Some th -> th
- | None -> ring_equality env evd (r,add,mul,opp,req)
-
-let dest_ring env sigma th_spec =
- let th_typ = Retyping.get_type_of env sigma th_spec in
- match kind_of_term th_typ with
- App(f,[|r;zero;one;add;mul;sub;opp;req|])
- when eq_constr_nounivs f (Lazy.force coq_almost_ring_theory) ->
- (None,r,zero,one,add,mul,Some sub,Some opp,req)
- | App(f,[|r;zero;one;add;mul;req|])
- when eq_constr_nounivs f (Lazy.force coq_semi_ring_theory) ->
- (Some true,r,zero,one,add,mul,None,None,req)
- | App(f,[|r;zero;one;add;mul;sub;opp;req|])
- when eq_constr_nounivs f (Lazy.force coq_ring_theory) ->
- (Some false,r,zero,one,add,mul,Some sub,Some opp,req)
- | _ -> error "bad ring structure"
-
-
-let dest_morph env sigma m_spec =
- let m_typ = Retyping.get_type_of env sigma m_spec in
- match kind_of_term m_typ with
- App(f,[|r;zero;one;add;mul;sub;opp;req;
- c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|])
- when eq_constr_nounivs f (Lazy.force coq_ring_morph) ->
- (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi)
- | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|])
- when eq_constr_nounivs f (Lazy.force coq_semi_morph) ->
- (c,czero,cone,cadd,cmul,None,None,ceqb,phi)
- | _ -> error "bad morphism structure"
-
-
-type 'constr coeff_spec =
- Computational of 'constr (* equality test *)
- | Abstract (* coeffs = Z *)
- | Morphism of 'constr (* general morphism *)
-
-
-let reflect_coeff rkind =
- (* We build an ill-typed terms on purpose... *)
- match rkind with
- Abstract -> Lazy.force coq_abstract
- | Computational c -> lapp coq_comp [|c|]
- | Morphism m -> lapp coq_morph [|m|]
-
-type cst_tac_spec =
- CstTac of raw_tactic_expr
- | Closed of reference list
-
-let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac =
- match cst_tac with
- Some (CstTac t) -> Tacintern.glob_tactic t
- | Some (Closed lc) ->
- closed_term_ast (List.map Smartlocate.global_with_alias lc)
- | None ->
- let t = ArgArg(Loc.ghost,Lazy.force ltac_inv_morph_nothing) in
- TacArg(Loc.ghost,TacCall(Loc.ghost,t,[]))
-
-let make_hyp env evd c =
- let t = Retyping.get_type_of env !evd c in
- plapp evd coq_mkhypo [|t;c|]
-
-let make_hyp_list env evd lH =
- let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
- let l =
- List.fold_right
- (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH
- (plapp evd coq_nil [|carrier|])
- in
- let l' = Typing.solve_evars env evd l in
- Evarutil.nf_evars_universes !evd l'
-
-let interp_power env evd pow =
- let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
- match pow with
- | None ->
- let t = ArgArg(Loc.ghost, Lazy.force ltac_inv_morph_nothing) in
- (TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])), plapp evd coq_None [|carrier|])
- | Some (tac, spec) ->
- let tac =
- match tac with
- | CstTac t -> Tacintern.glob_tactic t
- | Closed lc ->
- closed_term_ast (List.map Smartlocate.global_with_alias lc) in
- let spec = make_hyp env evd (ic_unsafe spec) in
- (tac, plapp evd coq_Some [|carrier; spec|])
-
-let interp_sign env evd sign =
- let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
- match sign with
- | None -> plapp evd coq_None [|carrier|]
- | Some spec ->
- let spec = make_hyp env evd (ic_unsafe spec) in
- plapp evd coq_Some [|carrier;spec|]
- (* Same remark on ill-typed terms ... *)
-
-let interp_div env evd div =
- let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
- match div with
- | None -> plapp evd coq_None [|carrier|]
- | Some spec ->
- let spec = make_hyp env evd (ic_unsafe spec) in
- plapp evd coq_Some [|carrier;spec|]
- (* Same remark on ill-typed terms ... *)
-
-let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div =
- check_required_library (cdir@["Ring_base"]);
- let env = Global.env() in
- let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in
- let evd = ref sigma in
- let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in
- let (pow_tac, pspec) = interp_power env evd power in
- let sspec = interp_sign env evd sign in
- let dspec = interp_div env evd div in
- let rk = reflect_coeff morphth in
- let params,ctx =
- exec_tactic env !evd 5 (zltac "ring_lemmas")
- (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in
- let lemma1 = params.(3) in
- let lemma2 = params.(4) in
-
- let lemma1 =
- decl_constant (Id.to_string name^"_ring_lemma1") ctx lemma1 in
- let lemma2 =
- decl_constant (Id.to_string name^"_ring_lemma2") ctx lemma2 in
- let cst_tac =
- interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in
- let pretac =
- match pre with
- Some t -> Tacintern.glob_tactic t
- | _ -> TacId [] in
- let posttac =
- match post with
- Some t -> Tacintern.glob_tactic t
- | _ -> TacId [] in
- let _ =
- Lib.add_leaf name
- (theory_to_obj
- { ring_carrier = r;
- ring_req = req;
- ring_setoid = sth;
- ring_ext = params.(1);
- ring_morph = params.(2);
- ring_th = params.(0);
- ring_cst_tac = cst_tac;
- ring_pow_tac = pow_tac;
- ring_lemma1 = lemma1;
- ring_lemma2 = lemma2;
- ring_pre_tac = pretac;
- ring_post_tac = posttac }) in
- ()
-
-type 'constr ring_mod =
- Ring_kind of 'constr coeff_spec
- | Const_tac of cst_tac_spec
- | Pre_tac of raw_tactic_expr
- | Post_tac of raw_tactic_expr
- | Setoid of Constrexpr.constr_expr * Constrexpr.constr_expr
- | Pow_spec of cst_tac_spec * Constrexpr.constr_expr
- (* Syntaxification tactic , correctness lemma *)
- | Sign_spec of Constrexpr.constr_expr
- | Div_spec of Constrexpr.constr_expr
-
-
-let ic_coeff_spec = function
- | Computational t -> Computational (ic_unsafe t)
- | Morphism t -> Morphism (ic_unsafe t)
- | Abstract -> Abstract
-
-
-VERNAC ARGUMENT EXTEND ring_mod
- | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ]
- | [ "abstract" ] -> [ Ring_kind Abstract ]
- | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism morph) ]
- | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ]
- | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ]
- | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
- | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
- | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
- | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ]
- | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] ->
- [ Pow_spec (Closed l, pow_spec) ]
- | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
- [ Pow_spec (CstTac cst_tac, pow_spec) ]
- | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ]
-END
-
-let set_once s r v =
- if Option.is_empty !r then r := Some v else error (s^" cannot be set twice")
-
-let process_ring_mods l =
- let kind = ref None in
- let set = ref None in
- let cst_tac = ref None in
- let pre = ref None in
- let post = ref None in
- let sign = ref None in
- let power = ref None in
- let div = ref None in
- List.iter(function
- Ring_kind k -> set_once "ring kind" kind (ic_coeff_spec k)
- | Const_tac t -> set_once "tactic recognizing constants" cst_tac t
- | Pre_tac t -> set_once "preprocess tactic" pre t
- | Post_tac t -> set_once "postprocess tactic" post t
- | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext)
- | Pow_spec(t,spec) -> set_once "power" power (t,spec)
- | Sign_spec t -> set_once "sign" sign t
- | Div_spec t -> set_once "div" div t) l;
- let k = match !kind with Some k -> k | None -> Abstract in
- (k, !set, !cst_tac, !pre, !post, !power, !sign, !div)
-
-VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF
- | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] ->
- [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in
- add_theory id (ic t) set k cst (pre,post) power sign div]
- | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [
- msg_notice (strbrk "The following ring structures have been declared:");
- Spmap.iter (fun fn fi ->
- msg_notice (hov 2
- (Ppconstr.pr_id (Libnames.basename fn)++spc()++
- str"with carrier "++ pr_constr fi.ring_carrier++spc()++
- str"and equivalence relation "++ pr_constr fi.ring_req))
- ) !from_name ]
-END
-
-(*****************************************************************************)
-(* The tactics consist then only in a lookup in the ring database and
- call the appropriate ltac. *)
-
-let make_args_list rl t =
- match rl with
- | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2]
- | _ -> rl
-
-let make_term_list env evd carrier rl =
- let l = List.fold_right
- (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl
- (plapp evd coq_nil [|carrier|])
- in Typing.solve_evars env evd l
-
-let ltac_ring_structure e =
- let req = carg e.ring_req in
- let sth = carg e.ring_setoid in
- let ext = carg e.ring_ext in
- let morph = carg e.ring_morph in
- let th = carg e.ring_th in
- let cst_tac = Tacexp e.ring_cst_tac in
- let pow_tac = Tacexp e.ring_pow_tac in
- let lemma1 = carg e.ring_lemma1 in
- let lemma2 = carg e.ring_lemma2 in
- let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in
- let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in
- [req;sth;ext;morph;th;cst_tac;pow_tac;
- lemma1;lemma2;pretac;posttac]
-
-let ring_lookup (f:glob_tactic_expr) lH rl t =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
- let env = Proofview.Goal.env gl in
- try (* find_ring_strucure can raise an exception *)
- let evdref = ref sigma in
- let rl = make_args_list rl t in
- let e = find_ring_structure env sigma rl in
- let rl = carg (make_term_list env evdref e.ring_carrier rl) in
- let lH = carg (make_hyp_list env evdref lH) in
- let ring = ltac_ring_structure e in
- Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl]))
- with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
- end
-
-TACTIC EXTEND ring_lookup
-| [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] ->
- [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t]
-END
-
-
-
-(***********************************************************************)
-
-let new_field_path =
- DirPath.make (List.map Id.of_string ["Field_tac";plugin_dir;"Coq"])
-
-let field_ltac s =
- lazy(make_kn (MPfile new_field_path) DirPath.empty (Label.make s))
-
-
-let _ = add_map "field"
- (map_with_eq
- [coq_cons,(function -1->Eval|2->Rec|_->Prot);
- coq_nil, (function -1->Eval|_ -> Prot);
- (* display_linear: evaluate polynomials and coef operations, protect
- field operations and make recursive call on the var map *)
- my_reference "display_linear",
- (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot);
- my_reference "display_pow_linear",
- (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot);
- (* Pphi_dev: evaluate polynomial and coef operations, protect
- ring operations and make recursive call on the var map *)
- pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
- pol_cst "Pphi_pow",
- (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
- (* PEeval: evaluate morphism and polynomial, protect ring
- operations and make recursive call on the var map *)
- pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot);
- (* FEeval: evaluate morphism, protect field
- operations and make recursive call on the var map *)
- my_reference "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
-
-let _ = add_map "field_cond"
- (map_without_eq
- [coq_cons,(function -1->Eval|2->Rec|_->Prot);
- coq_nil, (function -1->Eval|_ -> Prot);
- (* PCond: evaluate morphism and denum list, protect ring
- operations and make recursive call on the var map *)
- my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);;
-(* (function -1|9|11->Eval|10->Rec|_->Prot)]);;*)
-
-
-let _ = Redexpr.declare_reduction "simpl_field_expr"
- (protect_red "field")
-
-
-
-let afield_theory = my_reference "almost_field_theory"
-let field_theory = my_reference "field_theory"
-let sfield_theory = my_reference "semi_field_theory"
-let af_ar = my_reference"AF_AR"
-let f_r = my_reference"F_R"
-let sf_sr = my_reference"SF_SR"
-let dest_field env evd th_spec =
- let th_typ = Retyping.get_type_of env !evd th_spec in
- match kind_of_term th_typ with
- | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
- when is_global (Lazy.force afield_theory) f ->
- let rth = plapp evd af_ar
- [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
- (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
- | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
- when is_global (Lazy.force field_theory) f ->
- let rth =
- plapp evd f_r
- [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
- (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
- | App(f,[|r;zero;one;add;mul;div;inv;req|])
- when is_global (Lazy.force sfield_theory) f ->
- let rth = plapp evd sf_sr
- [|r;zero;one;add;mul;div;inv;req;th_spec|] in
- (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
- | _ -> error "bad field structure"
-
-type field_info =
- { field_carrier : types;
- field_req : constr;
- field_cst_tac : glob_tactic_expr;
- field_pow_tac : glob_tactic_expr;
- field_ok : constr;
- field_simpl_eq_ok : constr;
- field_simpl_ok : constr;
- field_simpl_eq_in_ok : constr;
- field_cond : constr;
- field_pre_tac : glob_tactic_expr;
- field_post_tac : glob_tactic_expr }
-
-let field_from_carrier = Summary.ref Cmap.empty ~name:"field-tac-carrier-table"
-let field_from_name = Summary.ref Spmap.empty ~name:"field-tac-name-table"
-
-let field_for_carrier r = Cmap.find r !field_from_carrier
-
-let find_field_structure env sigma l =
- check_required_library (cdir@["Field_tac"]);
- match l with
- | t::cl' ->
- let ty = Retyping.get_type_of env sigma t in
- let check c =
- let ty' = Retyping.get_type_of env sigma c in
- if not (Reductionops.is_conv env sigma ty ty') then
- errorlabstrm "field"
- (str"arguments of field_simplify do not have all the same type")
- in
- List.iter check cl';
- (try field_for_carrier ty
- with Not_found ->
- errorlabstrm "field"
- (str"cannot find a declared field structure over"++
- spc()++str"\""++pr_constr ty++str"\""))
- | [] -> assert false
-
-let add_field_entry (sp,_kn) e =
- field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier;
- field_from_name := Spmap.add sp e !field_from_name
-
-let subst_th (subst,th) =
- let c' = subst_mps subst th.field_carrier in
- let eq' = subst_mps subst th.field_req in
- let thm1' = subst_mps subst th.field_ok in
- let thm2' = subst_mps subst th.field_simpl_eq_ok in
- let thm3' = subst_mps subst th.field_simpl_ok in
- let thm4' = subst_mps subst th.field_simpl_eq_in_ok in
- let thm5' = subst_mps subst th.field_cond in
- let tac'= Tacsubst.subst_tactic subst th.field_cst_tac in
- let pow_tac' = Tacsubst.subst_tactic subst th.field_pow_tac in
- let pretac'= Tacsubst.subst_tactic subst th.field_pre_tac in
- let posttac'= Tacsubst.subst_tactic subst th.field_post_tac in
- if c' == th.field_carrier &&
- eq' == th.field_req &&
- thm1' == th.field_ok &&
- thm2' == th.field_simpl_eq_ok &&
- thm3' == th.field_simpl_ok &&
- thm4' == th.field_simpl_eq_in_ok &&
- thm5' == th.field_cond &&
- tac' == th.field_cst_tac &&
- pow_tac' == th.field_pow_tac &&
- pretac' == th.field_pre_tac &&
- posttac' == th.field_post_tac then th
- else
- { field_carrier = c';
- field_req = eq';
- field_cst_tac = tac';
- field_pow_tac = pow_tac';
- field_ok = thm1';
- field_simpl_eq_ok = thm2';
- field_simpl_ok = thm3';
- field_simpl_eq_in_ok = thm4';
- field_cond = thm5';
- field_pre_tac = pretac';
- field_post_tac = posttac' }
-
-let ftheory_to_obj : field_info -> obj =
- let cache_th (name,th) = add_field_entry name th in
- declare_object
- {(default_object "tactic-new-field-theory") with
- open_function = (fun i o -> if Int.equal i 1 then cache_th o);
- cache_function = cache_th;
- subst_function = subst_th;
- classify_function = (fun x -> Substitute x) }
-
-let field_equality evd r inv req =
- match kind_of_term req with
- | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) ->
- mkApp(Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr,[|r;r;inv|])
- | _ ->
- let _setoid = setoid_of_relation (Global.env ()) evd r req in
- let signature = [Some (r,Some req)],Some(r,Some req) in
- let inv_m, inv_m_lem =
- try Rewrite.default_morphism signature inv
- with Not_found ->
- error "field inverse should be declared as a morphism" in
- inv_m_lem
-
-let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power sign odiv =
- check_required_library (cdir@["Field_tac"]);
- let env = Global.env() in
- let evd = ref sigma in
- let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) =
- dest_field env evd fth in
- let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in
- let eqth = Some(sth,ext) in
- let _ = add_theory name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in
- let (pow_tac, pspec) = interp_power env evd power in
- let sspec = interp_sign env evd sign in
- let dspec = interp_div env evd odiv in
- let inv_m = field_equality evd r inv req in
- let rk = reflect_coeff morphth in
- let params,ctx =
- exec_tactic env !evd 9 (field_ltac"field_lemmas")
- (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in
- let lemma1 = params.(3) in
- let lemma2 = params.(4) in
- let lemma3 = params.(5) in
- let lemma4 = params.(6) in
- let cond_lemma =
- match inj with
- | Some thm -> mkApp(params.(8),[|thm|])
- | None -> params.(7) in
- let lemma1 = decl_constant (Id.to_string name^"_field_lemma1")
- ctx lemma1 in
- let lemma2 = decl_constant (Id.to_string name^"_field_lemma2")
- ctx lemma2 in
- let lemma3 = decl_constant (Id.to_string name^"_field_lemma3")
- ctx lemma3 in
- let lemma4 = decl_constant (Id.to_string name^"_field_lemma4")
- ctx lemma4 in
- let cond_lemma = decl_constant (Id.to_string name^"_lemma5")
- ctx cond_lemma in
- let cst_tac =
- interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in
- let pretac =
- match pre with
- Some t -> Tacintern.glob_tactic t
- | _ -> TacId [] in
- let posttac =
- match post with
- Some t -> Tacintern.glob_tactic t
- | _ -> TacId [] in
- let _ =
- Lib.add_leaf name
- (ftheory_to_obj
- { field_carrier = r;
- field_req = req;
- field_cst_tac = cst_tac;
- field_pow_tac = pow_tac;
- field_ok = lemma1;
- field_simpl_eq_ok = lemma2;
- field_simpl_ok = lemma3;
- field_simpl_eq_in_ok = lemma4;
- field_cond = cond_lemma;
- field_pre_tac = pretac;
- field_post_tac = posttac }) in ()
-
-type 'constr field_mod =
- Ring_mod of 'constr ring_mod
- | Inject of Constrexpr.constr_expr
-
-VERNAC ARGUMENT EXTEND field_mod
- | [ ring_mod(m) ] -> [ Ring_mod m ]
- | [ "completeness" constr(inj) ] -> [ Inject inj ]
-END
-
-let process_field_mods l =
- let kind = ref None in
- let set = ref None in
- let cst_tac = ref None in
- let pre = ref None in
- let post = ref None in
- let inj = ref None in
- let sign = ref None in
- let power = ref None in
- let div = ref None in
- List.iter(function
- Ring_mod(Ring_kind k) -> set_once "field kind" kind (ic_coeff_spec k)
- | Ring_mod(Const_tac t) ->
- set_once "tactic recognizing constants" cst_tac t
- | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t
- | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t
- | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext)
- | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec)
- | Ring_mod(Sign_spec t) -> set_once "sign" sign t
- | Ring_mod(Div_spec t) -> set_once "div" div t
- | Inject i -> set_once "infinite property" inj (ic_unsafe i)) l;
- let k = match !kind with Some k -> k | None -> Abstract in
- (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div)
-
-VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF
-| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] ->
- [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in
- add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div]
-| [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [
- msg_notice (strbrk "The following field structures have been declared:");
- Spmap.iter (fun fn fi ->
- msg_notice (hov 2
- (Ppconstr.pr_id (Libnames.basename fn)++spc()++
- str"with carrier "++ pr_constr fi.field_carrier++spc()++
- str"and equivalence relation "++ pr_constr fi.field_req))
- ) !field_from_name ]
-END
-
-
-let ltac_field_structure e =
- let req = carg e.field_req in
- let cst_tac = Tacexp e.field_cst_tac in
- let pow_tac = Tacexp e.field_pow_tac in
- let field_ok = carg e.field_ok in
- let field_simpl_ok = carg e.field_simpl_ok in
- let field_simpl_eq_ok = carg e.field_simpl_eq_ok in
- let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in
- let cond_ok = carg e.field_cond in
- let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in
- let posttac = Tacexp(TacFun([None],e.field_post_tac)) in
- [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
- field_simpl_eq_in_ok;cond_ok;pretac;posttac]
-
-let field_lookup (f:glob_tactic_expr) lH rl t =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
- let env = Proofview.Goal.env gl in
- try
- let evdref = ref sigma in
- let rl = make_args_list rl t in
- let e = find_field_structure env sigma rl in
- let rl = carg (make_term_list env evdref e.field_carrier rl) in
- let lH = carg (make_hyp_list env evdref lH) in
- let field = ltac_field_structure e in
- Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl]))
- with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
- end
-
-
-TACTIC EXTEND field_lookup
-| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] ->
- [ let (t,l) = List.sep_last lt in field_lookup f lH l t ]
-END
diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli
new file mode 100644
index 00000000..f417c87c
--- /dev/null
+++ b/plugins/setoid_ring/newring.mli
@@ -0,0 +1,78 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* Id.t -> unit Proofview.tactic
+
+val protect_tac : string -> unit Proofview.tactic
+
+val closed_term : constr -> global_reference list -> unit Proofview.tactic
+
+val process_ring_mods :
+ constr_expr ring_mod list ->
+ constr coeff_spec * (constr * constr) option *
+ cst_tac_spec option * raw_tactic_expr option *
+ raw_tactic_expr option *
+ (cst_tac_spec * constr_expr) option *
+ constr_expr option * constr_expr option
+
+val add_theory :
+ Id.t ->
+ Evd.evar_map * constr ->
+ (constr * constr) option ->
+ constr coeff_spec ->
+ cst_tac_spec option ->
+ raw_tactic_expr option * raw_tactic_expr option ->
+ (cst_tac_spec * constr_expr) option ->
+ constr_expr option ->
+ constr_expr option -> unit
+
+val ic : constr_expr -> Evd.evar_map * constr
+
+val from_name : ring_info Spmap.t ref
+
+val ring_lookup :
+ Geninterp.Val.t ->
+ constr list ->
+ constr list -> constr -> unit Proofview.tactic
+
+val process_field_mods :
+ constr_expr field_mod list ->
+ constr coeff_spec *
+ (constr * constr) option * constr option *
+ cst_tac_spec option * raw_tactic_expr option *
+ raw_tactic_expr option *
+ (cst_tac_spec * constr_expr) option *
+ constr_expr option * constr_expr option
+
+val add_field_theory :
+ Id.t ->
+ Evd.evar_map * constr ->
+ (constr * constr) option ->
+ constr coeff_spec ->
+ cst_tac_spec option ->
+ constr option ->
+ raw_tactic_expr option * raw_tactic_expr option ->
+ (cst_tac_spec * constr_expr) option ->
+ constr_expr option ->
+ constr_expr option -> unit
+
+val field_from_name : field_info Spmap.t ref
+
+val field_lookup :
+ Geninterp.Val.t ->
+ constr list ->
+ constr list -> constr -> unit Proofview.tactic
diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/setoid_ring/newring_ast.mli
new file mode 100644
index 00000000..c26fcc8d
--- /dev/null
+++ b/plugins/setoid_ring/newring_ast.mli
@@ -0,0 +1,63 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* ())
+let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s)
+let _ =
+ try ignore(Sys.getenv "SSRMATCHINGDEBUG"); pp_ref := ssr_pp
+ with Not_found -> ()
+let debug b =
+ if b then pp_ref := ssr_pp else pp_ref := fun _ -> ()
+let _ =
+ Goptions.declare_bool_option
+ { Goptions.optsync = false;
+ Goptions.optname = "ssrmatching debugging";
+ Goptions.optkey = ["Debug";"SsrMatching"];
+ Goptions.optdepr = false;
+ Goptions.optread = (fun _ -> !pp_ref == ssr_pp);
+ Goptions.optwrite = debug }
+let pp s = !pp_ref s
+
+(** Utils {{{ *****************************************************************)
+let env_size env = List.length (Environ.named_context env)
+let safeDestApp c =
+ match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |]
+let get_index = function ArgArg i -> i | _ ->
+ CErrors.anomaly (str"Uninterpreted index")
+(* Toplevel constr must be globalized twice ! *)
+let glob_constr ist genv = function
+ | _, Some ce ->
+ let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.lfun Id.Set.empty in
+ let ltacvars = { Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in
+ Constrintern.intern_gen WithoutTypeConstraint ~ltacvars:ltacvars genv ce
+ | rc, None -> rc
+
+(* Term printing utilities functions for deciding bracketing. *)
+let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")")
+(* String lexing utilities *)
+let skip_wschars s =
+ let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop
+(* We also guard characters that might interfere with the ssreflect *)
+(* tactic syntax. *)
+let guard_term ch1 s i = match s.[i] with
+ | '(' -> false
+ | '{' | '/' | '=' -> true
+ | _ -> ch1 = '('
+(* The call 'guard s i' should return true if the contents of s *)
+(* starting at i need bracketing to avoid ambiguities. *)
+let pr_guarded guard prc c =
+ let s = Pp.string_of_ppcmds (prc c) ^ "$" in
+ if guard s (skip_wschars s 0) then pr_paren prc c else prc c
+(* More sensible names for constr printers *)
+let pr_constr = pr_constr
+let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c
+let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c
+let prl_constr_expr = pr_lconstr_expr
+let pr_constr_expr = pr_constr_expr
+let prl_glob_constr_and_expr = function
+ | _, Some c -> prl_constr_expr c
+ | c, None -> prl_glob_constr c
+let pr_glob_constr_and_expr = function
+ | _, Some c -> pr_constr_expr c
+ | c, None -> pr_glob_constr c
+let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c
+let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c
+
+(** Adding a new uninterpreted generic argument type *)
+let add_genarg tag pr =
+ let wit = Genarg.make0 tag in
+ let tag = Geninterp.Val.create tag in
+ let glob ist x = (ist, x) in
+ let subst _ x = x in
+ let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in
+ let gen_pr _ _ _ = pr in
+ let () = Genintern.register_intern0 wit glob in
+ let () = Genintern.register_subst0 wit subst in
+ let () = Geninterp.register_interp0 wit interp in
+ let () = Geninterp.register_val0 wit (Some (Geninterp.Val.Base tag)) in
+ Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr;
+ wit
+
+(** Constructors for cast type *)
+let dC t = CastConv t
+(** Constructors for constr_expr *)
+let isCVar = function CRef (Ident _, _) -> true | _ -> false
+let destCVar = function CRef (Ident (_, id), _) -> id | _ ->
+ CErrors.anomaly (str"not a CRef")
+let mkCHole loc = CHole (loc, None, IntroAnonymous, None)
+let mkCLambda loc name ty t =
+ CLambdaN (loc, [[loc, name], Default Explicit, ty], t)
+let mkCLetIn loc name bo t =
+ CLetIn (loc, (loc, name), bo, t)
+let mkCCast loc t ty = CCast (loc,t, dC ty)
+(** Constructors for rawconstr *)
+let mkRHole = GHole (dummy_loc, InternalHole, IntroAnonymous, None)
+let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args)
+let mkRCast rc rt = GCast (dummy_loc, rc, dC rt)
+let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t)
+
+(* ssrterm conbinators *)
+let combineCG t1 t2 f g = match t1, t2 with
+ | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None)
+ | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2))
+ | _, (_, (_, None)) -> CErrors.anomaly (str"have: mixed C-G constr")
+ | _ -> CErrors.anomaly (str"have: mixed G-C constr")
+let loc_ofCG = function
+ | (_, (s, None)) -> Glob_ops.loc_of_glob_constr s
+ | (_, (_, Some s)) -> Constrexpr_ops.constr_loc s
+
+let mk_term k c = k, (mkRHole, Some c)
+let mk_lterm = mk_term ' '
+
+let pf_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty
+
+(* }}} *)
+
+(** Profiling {{{ *************************************************************)
+type profiler = {
+ profile : 'a 'b. ('a -> 'b) -> 'a -> 'b;
+ reset : unit -> unit;
+ print : unit -> unit }
+let profile_now = ref false
+let something_profiled = ref false
+let profilers = ref []
+let add_profiler f = profilers := f :: !profilers;;
+let profile b =
+ profile_now := b;
+ if b then List.iter (fun f -> f.reset ()) !profilers;
+ if not b then List.iter (fun f -> f.print ()) !profilers
+;;
+let _ =
+ Goptions.declare_bool_option
+ { Goptions.optsync = false;
+ Goptions.optname = "ssrmatching profiling";
+ Goptions.optkey = ["SsrMatchingProfiling"];
+ Goptions.optread = (fun _ -> !profile_now);
+ Goptions.optdepr = false;
+ Goptions.optwrite = profile }
+let () =
+ let prof_total =
+ let init = ref 0.0 in {
+ profile = (fun f x -> assert false);
+ reset = (fun () -> init := Unix.gettimeofday ());
+ print = (fun () -> if !something_profiled then
+ prerr_endline
+ (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f"
+ "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in
+ let prof_legenda = {
+ profile = (fun f x -> assert false);
+ reset = (fun () -> ());
+ print = (fun () -> if !something_profiled then begin
+ prerr_endline
+ (Printf.sprintf "!! %39s ---------- --------- --------- ---------"
+ (String.make 39 '-'));
+ prerr_endline
+ (Printf.sprintf "!! %-39s %10s %9s %9s %9s"
+ "function" "#calls" "total" "max" "average") end) } in
+ add_profiler prof_legenda;
+ add_profiler prof_total
+;;
+
+let mk_profiler s =
+ let total, calls, max = ref 0.0, ref 0, ref 0.0 in
+ let reset () = total := 0.0; calls := 0; max := 0.0 in
+ let profile f x =
+ if not !profile_now then f x else
+ let before = Unix.gettimeofday () in
+ try
+ incr calls;
+ let res = f x in
+ let after = Unix.gettimeofday () in
+ let delta = after -. before in
+ total := !total +. delta;
+ if delta > !max then max := delta;
+ res
+ with exc ->
+ let after = Unix.gettimeofday () in
+ let delta = after -. before in
+ total := !total +. delta;
+ if delta > !max then max := delta;
+ raise exc in
+ let print () =
+ if !calls <> 0 then begin
+ something_profiled := true;
+ prerr_endline
+ (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f"
+ s !calls !total !max (!total /. (float_of_int !calls))) end in
+ let prof = { profile = profile; reset = reset; print = print } in
+ add_profiler prof;
+ prof
+;;
+(* }}} *)
+
+exception NoProgress
+
+(** Unification procedures. *)
+
+(* To enforce the rigidity of the rooted match we always split *)
+(* top applications, so the unification procedures operate on *)
+(* arrays of patterns and terms. *)
+(* We perform three kinds of unification: *)
+(* EQ: exact conversion check *)
+(* FO: first-order unification of evars, without conversion *)
+(* HO: higher-order unification with conversion *)
+(* The subterm unification strategy is to find the first FO *)
+(* match, if possible, and the first HO match otherwise, then *)
+(* compute all the occurrences that are EQ matches for the *)
+(* relevant subterm. *)
+(* Additional twists: *)
+(* - If FO/HO fails then we attempt to fill evars using *)
+(* typeclasses before raising an outright error. We also *)
+(* fill typeclasses even after a successful match, since *)
+(* beta-reduction and canonical instances may leave *)
+(* undefined evars. *)
+(* - We do postchecks to rule out matches that are not *)
+(* closed or that assign to a global evar; these can be *)
+(* disabled for rewrite or dependent family matches. *)
+(* - We do a full FO scan before turning to HO, as the FO *)
+(* comparison can be much faster than the HO one. *)
+
+let unif_EQ env sigma p c =
+ let evars = existential_opt_value sigma, Evd.universes sigma in
+ try let _ = Reduction.conv env p ~evars c in true with _ -> false
+
+let unif_EQ_args env sigma pa a =
+ let n = Array.length pa in
+ let rec loop i = (i = n) || unif_EQ env sigma pa.(i) a.(i) && loop (i + 1) in
+ loop 0
+
+let prof_unif_eq_args = mk_profiler "unif_EQ_args";;
+let unif_EQ_args env sigma pa a =
+ prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a
+;;
+
+let unif_HO env ise p c = Evarconv.the_conv_x env p c ise
+
+let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env p c ise
+
+let unif_HO_args env ise0 pa i ca =
+ let n = Array.length pa in
+ let rec loop ise j =
+ if j = n then ise else loop (unif_HO env ise pa.(j) ca.(i + j)) (j + 1) in
+ loop ise0 0
+
+(* FO unification should boil down to calling w_unify with no_delta, but *)
+(* alas things are not so simple: w_unify does partial type-checking, *)
+(* which breaks down when the no-delta flag is on (as the Coq type system *)
+(* requires full convertibility. The workaround here is to convert all *)
+(* evars into metas, since 8.2 does not TC metas. This means some lossage *)
+(* for HO evars, though hopefully Miller patterns can pick up some of *)
+(* those cases, and HO matching will mop up the rest. *)
+let flags_FO =
+ let flags =
+ { (Unification.default_no_delta_unify_flags ()).Unification.core_unify_flags
+ with
+ Unification.modulo_conv_on_closed_terms = None;
+ Unification.modulo_eta = true;
+ Unification.modulo_betaiota = true;
+ Unification.modulo_delta_types = full_transparent_state}
+ in
+ { Unification.core_unify_flags = flags;
+ Unification.merge_unify_flags = flags;
+ Unification.subterm_unify_flags = flags;
+ Unification.allow_K_in_toplevel_higher_order_unification = false;
+ Unification.resolve_evars =
+ (Unification.default_no_delta_unify_flags ()).Unification.resolve_evars
+ }
+let unif_FO env ise p c =
+ Unification.w_unify env ise Reduction.CONV ~flags:flags_FO p c
+
+(* Perform evar substitution in main term and prune substitution. *)
+let nf_open_term sigma0 ise c =
+ let s = ise and s' = ref sigma0 in
+ let rec nf c' = match kind_of_term c' with
+ | Evar ex ->
+ begin try nf (existential_value s ex) with _ ->
+ let k, a = ex in let a' = Array.map nf a in
+ if not (Evd.mem !s' k) then
+ s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k));
+ mkEvar (k, a')
+ end
+ | _ -> map_constr nf c' in
+ let copy_def k evi () =
+ if evar_body evi != Evd.Evar_empty then () else
+ match Evd.evar_body (Evd.find s k) with
+ | Evar_defined c' -> s' := Evd.define k (nf c') !s'
+ | _ -> () in
+ let c' = nf c in let _ = Evd.fold copy_def sigma0 () in
+ !s', Evd.evar_universe_context s, c'
+
+let unif_end env sigma0 ise0 pt ok =
+ let ise = Evarconv.solve_unif_constraints_with_heuristics env ise0 in
+ let s, uc, t = nf_open_term sigma0 ise pt in
+ let ise1 = create_evar_defs s in
+ let ise1 = Evd.set_universe_context ise1 uc in
+ let ise2 = Typeclasses.resolve_typeclasses ~fail:true env ise1 in
+ if not (ok ise) then raise NoProgress else
+ if ise2 == ise1 then (s, uc, t)
+ else
+ let s, uc', t = nf_open_term sigma0 ise2 t in
+ s, Evd.union_evar_universe_context uc uc', t
+
+let pf_unif_HO gl sigma pt p c =
+ let env = pf_env gl in
+ let ise = unif_HO env (create_evar_defs sigma) p c in
+ unif_end env (project gl) ise pt (fun _ -> true)
+
+let unify_HO env sigma0 t1 t2 =
+ let sigma = unif_HO env sigma0 t1 t2 in
+ let sigma, uc, _ = unif_end env sigma0 sigma t2 (fun _ -> true) in
+ Evd.set_universe_context sigma uc
+
+let pf_unify_HO gl t1 t2 =
+ let env, sigma0, si = pf_env gl, project gl, sig_it gl in
+ let sigma = unify_HO env sigma0 t1 t2 in
+ re_sig si sigma
+
+(* This is what the definition of iter_constr should be... *)
+let iter_constr_LR f c = match kind_of_term c with
+ | Evar (k, a) -> Array.iter f a
+ | Cast (cc, _, t) -> f cc; f t
+ | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b
+ | LetIn (_, v, t, b) -> f v; f t; f b
+ | App (cf, a) -> f cf; Array.iter f a
+ | Case (_, p, v, b) -> f v; f p; Array.iter f b
+ | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) ->
+ for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done
+ | Proj(_,a) -> f a
+ | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> ()
+
+(* The comparison used to determine which subterms matches is KEYED *)
+(* CONVERSION. This looks for convertible terms that either have the same *)
+(* same head constant as pat if pat is an application (after beta-iota), *)
+(* or start with the same constr constructor (esp. for LetIn); this is *)
+(* disregarded if the head term is let x := ... in x, and casts are always *)
+(* ignored and removed). *)
+(* Record projections get special treatment: in addition to the projection *)
+(* constant itself, ssreflect also recognizes head constants of canonical *)
+(* projections. *)
+
+exception NoMatch
+type ssrdir = L2R | R2L
+let pr_dir_side = function L2R -> str "LHS" | R2L -> str "RHS"
+let inv_dir = function L2R -> R2L | R2L -> L2R
+
+
+type pattern_class =
+ | KpatFixed
+ | KpatConst
+ | KpatEvar of existential_key
+ | KpatLet
+ | KpatLam
+ | KpatRigid
+ | KpatFlex
+ | KpatProj of constant
+
+type tpattern = {
+ up_k : pattern_class;
+ up_FO : constr;
+ up_f : constr;
+ up_a : constr array;
+ up_t : constr; (* equation proof term or matched term *)
+ up_dir : ssrdir; (* direction of the rule *)
+ up_ok : constr -> evar_map -> bool; (* progess test for rewrite *)
+ }
+
+let all_ok _ _ = true
+
+let proj_nparams c =
+ try 1 + Recordops.find_projection_nparams (ConstRef c) with _ -> 0
+
+let isFixed c = match kind_of_term c with
+ | Var _ | Ind _ | Construct _ | Const _ | Proj _ -> true
+ | _ -> false
+
+let isRigid c = match kind_of_term c with
+ | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true
+ | _ -> false
+
+exception UndefPat
+
+let hole_var = mkVar (id_of_string "_")
+let pr_constr_pat c0 =
+ let rec wipe_evar c =
+ if isEvar c then hole_var else map_constr wipe_evar c in
+ pr_constr (wipe_evar c0)
+
+(* Turn (new) evars into metas *)
+let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 =
+ let ise = ref ise0 in
+ let sigma = ref ise0 in
+ let nenv = env_size env + if hack then 1 else 0 in
+ let rec put c = match kind_of_term c with
+ | Evar (k, a as ex) ->
+ begin try put (existential_value !sigma ex)
+ with NotInstantiatedEvar ->
+ if Evd.mem sigma0 k then map_constr put c else
+ let evi = Evd.find !sigma k in
+ let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in
+ let abs_dc (d, c) = function
+ | Context.Named.Declaration.LocalDef (x, b, t) ->
+ d, mkNamedLetIn x (put b) (put t) c
+ | Context.Named.Declaration.LocalAssum (x, t) ->
+ mkVar x :: d, mkNamedProd x (put t) c in
+ let a, t =
+ Context.Named.fold_inside abs_dc ~init:([], (put evi.evar_concl)) dc in
+ let m = Evarutil.new_meta () in
+ ise := meta_declare m t !ise;
+ sigma := Evd.define k (applist (mkMeta m, a)) !sigma;
+ put (existential_value !sigma ex)
+ end
+ | _ -> map_constr put c in
+ let c1 = put c0 in !ise, c1
+
+(* Compile a match pattern from a term; t is the term to fill. *)
+(* p_origin can be passed to obtain a better error message *)
+let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p =
+ let k, f, a =
+ let f, a = Reductionops.whd_betaiota_stack ise p in
+ match kind_of_term f with
+ | Const (p,_) ->
+ let np = proj_nparams p in
+ if np = 0 || np > List.length a then KpatConst, f, a else
+ let a1, a2 = List.chop np a in KpatProj p, applist(f, a1), a2
+ | Proj (p,arg) -> KpatProj (Projection.constant p), f, a
+ | Var _ | Ind _ | Construct _ -> KpatFixed, f, a
+ | Evar (k, _) ->
+ if Evd.mem sigma0 k then KpatEvar k, f, a else
+ if a <> [] then KpatFlex, f, a else
+ (match p_origin with None -> CErrors.error "indeterminate pattern"
+ | Some (dir, rule) ->
+ errorstrm (str "indeterminate " ++ pr_dir_side dir
+ ++ str " in " ++ pr_constr_pat rule))
+ | LetIn (_, v, _, b) ->
+ if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a
+ | Lambda _ -> KpatLam, f, a
+ | _ -> KpatRigid, f, a in
+ let aa = Array.of_list a in
+ let ise', p' = evars_for_FO ~hack env sigma0 ise (mkApp (f, aa)) in
+ ise',
+ { up_k = k; up_FO = p'; up_f = f;
+ up_a = aa; up_ok = ok; up_dir = dir; up_t = t}
+
+(* Specialize a pattern after a successful match: assign a precise head *)
+(* kind and arity for Proj and Flex patterns. *)
+let ungen_upat lhs (sigma, uc, t) u =
+ let f, a = safeDestApp lhs in
+ let k = match kind_of_term f with
+ | Var _ | Ind _ | Construct _ -> KpatFixed
+ | Const _ -> KpatConst
+ | Evar (k, _) -> if is_defined sigma k then raise NoMatch else KpatEvar k
+ | LetIn _ -> KpatLet
+ | Lambda _ -> KpatLam
+ | _ -> KpatRigid in
+ sigma, uc, {u with up_k = k; up_FO = lhs; up_f = f; up_a = a; up_t = t}
+
+let nb_cs_proj_args pc f u =
+ let na k =
+ List.length (snd (lookup_canonical_conversion (ConstRef pc, k))).o_TCOMPS in
+ try match kind_of_term f with
+ | Prod _ -> na Prod_cs
+ | Sort s -> na (Sort_cs (family_of_sort s))
+ | Const (c',_) when Constant.equal c' pc ->
+ begin match kind_of_term u.up_f with
+ | App(_,args) -> Array.length args
+ | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be
+ the number of arguments including the projected *)
+ | _ -> assert false
+ end
+ | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f))
+ | _ -> -1
+ with Not_found -> -1
+
+let isEvar_k k f =
+ match kind_of_term f with Evar (k', _) -> k = k' | _ -> false
+
+let nb_args c =
+ match kind_of_term c with App (_, a) -> Array.length a | _ -> 0
+
+let mkSubArg i a = if i = Array.length a then a else Array.sub a 0 i
+let mkSubApp f i a = if i = 0 then f else mkApp (f, mkSubArg i a)
+
+let splay_app ise =
+ let rec loop c a = match kind_of_term c with
+ | App (f, a') -> loop f (Array.append a' a)
+ | Cast (c', _, _) -> loop c' a
+ | Evar ex ->
+ (try loop (existential_value ise ex) a with _ -> c, a)
+ | _ -> c, a in
+ fun c -> match kind_of_term c with
+ | App (f, a) -> loop f a
+ | Cast _ | Evar _ -> loop c [| |]
+ | _ -> c, [| |]
+
+let filter_upat i0 f n u fpats =
+ let na = Array.length u.up_a in
+ if n < na then fpats else
+ let np = match u.up_k with
+ | KpatConst when Term.eq_constr u.up_f f -> na
+ | KpatFixed when Term.eq_constr u.up_f f -> na
+ | KpatEvar k when isEvar_k k f -> na
+ | KpatLet when isLetIn f -> na
+ | KpatLam when isLambda f -> na
+ | KpatRigid when isRigid f -> na
+ | KpatFlex -> na
+ | KpatProj pc ->
+ let np = na + nb_cs_proj_args pc f u in if n < np then -1 else np
+ | _ -> -1 in
+ if np < na then fpats else
+ let () = if !i0 < np then i0 := n in (u, np) :: fpats
+
+let eq_prim_proj c t = match kind_of_term t with
+ | Proj(p,_) -> Constant.equal (Projection.constant p) c
+ | _ -> false
+
+let filter_upat_FO i0 f n u fpats =
+ let np = nb_args u.up_FO in
+ if n < np then fpats else
+ let ok = match u.up_k with
+ | KpatConst -> Term.eq_constr u.up_f f
+ | KpatFixed -> Term.eq_constr u.up_f f
+ | KpatEvar k -> isEvar_k k f
+ | KpatLet -> isLetIn f
+ | KpatLam -> isLambda f
+ | KpatRigid -> isRigid f
+ | KpatProj pc -> Term.eq_constr f (mkConst pc) || eq_prim_proj pc f
+ | KpatFlex -> i0 := n; true in
+ if ok then begin if !i0 < np then i0 := np; (u, np) :: fpats end else fpats
+
+exception FoundUnif of (evar_map * evar_universe_context * tpattern)
+(* Note: we don't update env as we descend into the term, as the primitive *)
+(* unification procedure always rejects subterms with bound variables. *)
+
+let dont_impact_evars_in cl =
+ let evs_in_cl = Evd.evars_of_term cl in
+ fun sigma -> Evar.Set.for_all (fun k ->
+ try let _ = Evd.find_undefined sigma k in true
+ with Not_found -> false) evs_in_cl
+
+(* We are forced to duplicate code between the FO/HO matching because we *)
+(* have to work around several kludges in unify.ml: *)
+(* - w_unify drops into second-order unification when the pattern is an *)
+(* application whose head is a meta. *)
+(* - w_unify tries to unify types without subsumption when the pattern *)
+(* head is an evar or meta (e.g., it fails on ?1 = nat when ?1 : Type). *)
+(* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *)
+(* match a head let rigidly. *)
+let match_upats_FO upats env sigma0 ise orig_c =
+ let dont_impact_evars = dont_impact_evars_in orig_c in
+ let rec loop c =
+ let f, a = splay_app ise c in let i0 = ref (-1) in
+ let fpats =
+ List.fold_right (filter_upat_FO i0 f (Array.length a)) upats [] in
+ while !i0 >= 0 do
+ let i = !i0 in i0 := -1;
+ let c' = mkSubApp f i a in
+ let one_match (u, np) =
+ let skip =
+ if i <= np then i < np else
+ if u.up_k == KpatFlex then begin i0 := i - 1; false end else
+ begin if !i0 < np then i0 := np; true end in
+ if skip || not (closed0 c') then () else try
+ let _ = match u.up_k with
+ | KpatFlex ->
+ let kludge v = mkLambda (Anonymous, mkProp, v) in
+ unif_FO env ise (kludge u.up_FO) (kludge c')
+ | KpatLet ->
+ let kludge vla =
+ let vl, a = safeDestApp vla in
+ let x, v, t, b = destLetIn vl in
+ mkApp (mkLambda (x, t, b), Array.cons v a) in
+ unif_FO env ise (kludge u.up_FO) (kludge c')
+ | _ -> unif_FO env ise u.up_FO c' in
+ let ise' = (* Unify again using HO to assign evars *)
+ let p = mkApp (u.up_f, u.up_a) in
+ try unif_HO env ise p c' with _ -> raise NoMatch in
+ let lhs = mkSubApp f i a in
+ let pt' = unif_end env sigma0 ise' u.up_t (u.up_ok lhs) in
+ raise (FoundUnif (ungen_upat lhs pt' u))
+ with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u
+ | Not_found -> CErrors.anomaly (str"incomplete ise in match_upats_FO")
+ | _ -> () in
+ List.iter one_match fpats
+ done;
+ iter_constr_LR loop f; Array.iter loop a in
+ try loop orig_c with Invalid_argument _ -> CErrors.anomaly (str"IN FO")
+
+let prof_FO = mk_profiler "match_upats_FO";;
+let match_upats_FO upats env sigma0 ise c =
+ prof_FO.profile (match_upats_FO upats env sigma0) ise c
+;;
+
+
+let match_upats_HO ~on_instance upats env sigma0 ise c =
+ let dont_impact_evars = dont_impact_evars_in c in
+ let it_did_match = ref false in
+ let failed_because_of_TC = ref false in
+ let rec aux upats env sigma0 ise c =
+ let f, a = splay_app ise c in let i0 = ref (-1) in
+ let fpats = List.fold_right (filter_upat i0 f (Array.length a)) upats [] in
+ while !i0 >= 0 do
+ let i = !i0 in i0 := -1;
+ let one_match (u, np) =
+ let skip =
+ if i <= np then i < np else
+ if u.up_k == KpatFlex then begin i0 := i - 1; false end else
+ begin if !i0 < np then i0 := np; true end in
+ if skip then () else try
+ let ise' = match u.up_k with
+ | KpatFixed | KpatConst -> ise
+ | KpatEvar _ ->
+ let _, pka = destEvar u.up_f and _, ka = destEvar f in
+ unif_HO_args env ise pka 0 ka
+ | KpatLet ->
+ let x, v, t, b = destLetIn f in
+ let _, pv, _, pb = destLetIn u.up_f in
+ let ise' = unif_HO env ise pv v in
+ unif_HO
+ (Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env)
+ ise' pb b
+ | KpatFlex | KpatProj _ ->
+ unif_HO env ise u.up_f (mkSubApp f (i - Array.length u.up_a) a)
+ | _ -> unif_HO env ise u.up_f f in
+ let ise'' = unif_HO_args env ise' u.up_a (i - Array.length u.up_a) a in
+ let lhs = mkSubApp f i a in
+ let pt' = unif_end env sigma0 ise'' u.up_t (u.up_ok lhs) in
+ on_instance (ungen_upat lhs pt' u)
+ with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u
+ | NoProgress -> it_did_match := true
+ | Pretype_errors.PretypeError
+ (_,_,Pretype_errors.UnsatisfiableConstraints _) ->
+ failed_because_of_TC:=true
+ | e when CErrors.noncritical e -> () in
+ List.iter one_match fpats
+ done;
+ iter_constr_LR (aux upats env sigma0 ise) f;
+ Array.iter (aux upats env sigma0 ise) a
+ in
+ aux upats env sigma0 ise c;
+ if !it_did_match then raise NoProgress;
+ !failed_because_of_TC
+
+let prof_HO = mk_profiler "match_upats_HO";;
+let match_upats_HO ~on_instance upats env sigma0 ise c =
+ prof_HO.profile (match_upats_HO ~on_instance upats env sigma0) ise c
+;;
+
+
+let fixed_upat = function
+| {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false
+| {up_t = t} -> not (occur_existential t)
+
+let do_once r f = match !r with Some _ -> () | None -> r := Some (f ())
+
+let assert_done r =
+ match !r with Some x -> x | None -> CErrors.anomaly (str"do_once never called")
+
+let assert_done_multires r =
+ match !r with
+ | None -> CErrors.anomaly (str"do_once never called")
+ | Some (n, xs) ->
+ r := Some (n+1,xs);
+ try List.nth xs n with Failure _ -> raise NoMatch
+
+type subst = Environ.env -> Term.constr -> Term.constr -> int -> Term.constr
+type find_P =
+ Environ.env -> Term.constr -> int ->
+ k:subst ->
+ Term.constr
+type conclude = unit ->
+ Term.constr * ssrdir * (Evd.evar_map * Evd.evar_universe_context * Term.constr)
+
+(* upats_origin makes a better error message only *)
+let mk_tpattern_matcher ?(all_instances=false)
+ ?(raise_NoMatch=false) ?upats_origin sigma0 occ (ise, upats)
+=
+ let nocc = ref 0 and skip_occ = ref false in
+ let use_occ, occ_list = match occ with
+ | Some (true, ol) -> ol = [], ol
+ | Some (false, ol) -> ol <> [], ol
+ | None -> false, [] in
+ let max_occ = List.fold_right max occ_list 0 in
+ let subst_occ =
+ let occ_set = Array.make max_occ (not use_occ) in
+ let _ = List.iter (fun i -> occ_set.(i - 1) <- use_occ) occ_list in
+ let _ = if max_occ = 0 then skip_occ := use_occ in
+ fun () -> incr nocc;
+ if !nocc = max_occ then skip_occ := use_occ;
+ if !nocc <= max_occ then occ_set.(!nocc - 1) else not use_occ in
+ let upat_that_matched = ref None in
+ let match_EQ env sigma u =
+ match u.up_k with
+ | KpatLet ->
+ let x, pv, t, pb = destLetIn u.up_f in
+ let env' =
+ Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env in
+ let match_let f = match kind_of_term f with
+ | LetIn (_, v, _, b) -> unif_EQ env sigma pv v && unif_EQ env' sigma pb b
+ | _ -> false in match_let
+ | KpatFixed -> Term.eq_constr u.up_f
+ | KpatConst -> Term.eq_constr u.up_f
+ | KpatLam -> fun c ->
+ (match kind_of_term c with
+ | Lambda _ -> unif_EQ env sigma u.up_f c
+ | _ -> false)
+ | _ -> unif_EQ env sigma u.up_f in
+let p2t p = mkApp(p.up_f,p.up_a) in
+let source () = match upats_origin, upats with
+ | None, [p] ->
+ (if fixed_upat p then str"term " else str"partial term ") ++
+ pr_constr_pat (p2t p) ++ spc()
+ | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++
+ pr_constr_pat rule ++ fnl() ++ ws 4 ++ pr_constr_pat (p2t p) ++ fnl()
+ | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++
+ pr_constr_pat rule ++ spc()
+ | _, [] | None, _::_::_ ->
+ CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin") in
+let on_instance, instances =
+ let instances = ref [] in
+ (fun x ->
+ if all_instances then instances := !instances @ [x]
+ else raise (FoundUnif x)),
+ (fun () -> !instances) in
+let rec uniquize = function
+ | [] -> []
+ | (sigma,_,{ up_f = f; up_a = a; up_t = t } as x) :: xs ->
+ let t = Reductionops.nf_evar sigma t in
+ let f = Reductionops.nf_evar sigma f in
+ let a = Array.map (Reductionops.nf_evar sigma) a in
+ let neq (sigma1,_,{ up_f = f1; up_a = a1; up_t = t1 }) =
+ let t1 = Reductionops.nf_evar sigma1 t1 in
+ let f1 = Reductionops.nf_evar sigma1 f1 in
+ let a1 = Array.map (Reductionops.nf_evar sigma1) a1 in
+ not (Term.eq_constr t t1 &&
+ Term.eq_constr f f1 && CArray.for_all2 Term.eq_constr a a1) in
+ x :: uniquize (List.filter neq xs) in
+
+((fun env c h ~k ->
+ do_once upat_that_matched (fun () ->
+ let failed_because_of_TC = ref false in
+ try
+ if not all_instances then match_upats_FO upats env sigma0 ise c;
+ failed_because_of_TC:=match_upats_HO ~on_instance upats env sigma0 ise c;
+ raise NoMatch
+ with FoundUnif sigma_u -> 0,[sigma_u]
+ | (NoMatch|NoProgress) when all_instances && instances () <> [] ->
+ 0, uniquize (instances ())
+ | NoMatch when (not raise_NoMatch) ->
+ if !failed_because_of_TC then
+ errorstrm (source ()++strbrk"matches but type classes inference fails")
+ else
+ errorstrm (source () ++ str "does not match any subterm of the goal")
+ | NoProgress when (not raise_NoMatch) ->
+ let dir = match upats_origin with Some (d,_) -> d | _ ->
+ CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin") in
+ errorstrm (str"all matches of "++source()++
+ str"are equal to the " ++ pr_dir_side (inv_dir dir))
+ | NoProgress -> raise NoMatch);
+ let sigma, _, ({up_f = pf; up_a = pa} as u) =
+ if all_instances then assert_done_multires upat_that_matched
+ else List.hd (snd(assert_done upat_that_matched)) in
+(* pp(lazy(str"sigma@tmatch=" ++ pr_evar_map None sigma)); *)
+ if !skip_occ then ((*ignore(k env u.up_t 0);*) c) else
+ let match_EQ = match_EQ env sigma u in
+ let pn = Array.length pa in
+ let rec subst_loop (env,h as acc) c' =
+ if !skip_occ then c' else
+ let f, a = splay_app sigma c' in
+ if Array.length a >= pn && match_EQ f && unif_EQ_args env sigma pa a then
+ let a1, a2 = Array.chop (Array.length pa) a in
+ let fa1 = mkApp (f, a1) in
+ let f' = if subst_occ () then k env u.up_t fa1 h else fa1 in
+ mkApp (f', Array.map_left (subst_loop acc) a2)
+ else
+ (* TASSI: clear letin values to avoid unfolding *)
+ let inc_h rd (env,h') =
+ let ctx_item =
+ match rd with
+ | Context.Rel.Declaration.LocalAssum _ as x -> x
+ | Context.Rel.Declaration.LocalDef (x,_,y) ->
+ Context.Rel.Declaration.LocalAssum(x,y) in
+ Environ.push_rel ctx_item env, h' + 1 in
+ let f' = map_constr_with_binders_left_to_right inc_h subst_loop acc f in
+ mkApp (f', Array.map_left (subst_loop acc) a) in
+ subst_loop (env,h) c) : find_P),
+((fun () ->
+ let sigma, uc, ({up_f = pf; up_a = pa} as u) =
+ match !upat_that_matched with
+ | Some (_,x) -> List.hd x | None when raise_NoMatch -> raise NoMatch
+ | None -> CErrors.anomaly (str"companion function never called") in
+ let p' = mkApp (pf, pa) in
+ if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t)
+ else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++
+ str(String.plural !nocc " occurence") ++ match upats_origin with
+ | None -> str" of" ++ spc() ++ pr_constr_pat p'
+ | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++
+ ws 4 ++ pr_constr_pat p' ++ fnl () ++
+ str"of " ++ pr_constr_pat rule)) : conclude)
+
+type ('ident, 'term) ssrpattern =
+ | T of 'term
+ | In_T of 'term
+ | X_In_T of 'ident * 'term
+ | In_X_In_T of 'ident * 'term
+ | E_In_X_In_T of 'term * 'ident * 'term
+ | E_As_X_In_T of 'term * 'ident * 'term
+
+let pr_pattern = function
+ | T t -> prl_term t
+ | In_T t -> str "in " ++ prl_term t
+ | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t
+ | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t
+ | E_In_X_In_T (e,x,t) ->
+ prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t
+ | E_As_X_In_T (e,x,t) ->
+ prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t
+
+let pr_pattern_w_ids = function
+ | T t -> prl_term t
+ | In_T t -> str "in " ++ prl_term t
+ | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t
+ | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t
+ | E_In_X_In_T (e,x,t) ->
+ prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t
+ | E_As_X_In_T (e,x,t) ->
+ prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t
+
+let pr_pattern_aux pr_constr = function
+ | T t -> pr_constr t
+ | In_T t -> str "in " ++ pr_constr t
+ | X_In_T (x,t) -> pr_constr x ++ str " in " ++ pr_constr t
+ | In_X_In_T (x,t) -> str "in " ++ pr_constr x ++ str " in " ++ pr_constr t
+ | E_In_X_In_T (e,x,t) ->
+ pr_constr e ++ str " in " ++ pr_constr x ++ str " in " ++ pr_constr t
+ | E_As_X_In_T (e,x,t) ->
+ pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t
+let pp_pattern (sigma, p) =
+ pr_pattern_aux (fun t -> pr_constr_pat (pi3 (nf_open_term sigma sigma t))) p
+let pr_cpattern = pr_term
+let pr_rpattern _ _ _ = pr_pattern
+
+let pr_option f = function None -> mt() | Some x -> f x
+let pr_ssrpattern _ _ _ = pr_option pr_pattern
+let pr_pattern_squarep = pr_option (fun r -> str "[" ++ pr_pattern r ++ str "]")
+let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep
+let pr_pattern_roundp = pr_option (fun r -> str "(" ++ pr_pattern r ++ str ")")
+let pr_ssrpattern_roundp _ _ _ = pr_pattern_roundp
+
+let wit_rpatternty = add_genarg "rpatternty" pr_pattern
+
+let glob_ssrterm gs = function
+ | k, (_, Some c) -> k,
+ let x = Tacintern.intern_constr gs c in
+ fst x, Some c
+ | ct -> ct
+
+(* This piece of code asserts the following notations are reserved *)
+(* Reserved Notation "( a 'in' b )" (at level 0). *)
+(* Reserved Notation "( a 'as' b )" (at level 0). *)
+(* Reserved Notation "( a 'in' b 'in' c )" (at level 0). *)
+(* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *)
+let glob_cpattern gs p =
+ pp(lazy(str"globbing pattern: " ++ pr_term p));
+ let glob x = snd (glob_ssrterm gs (mk_lterm x)) in
+ let encode k s l =
+ let name = Name (id_of_string ("_ssrpat_" ^ s)) in
+ k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None) in
+ let bind_in t1 t2 =
+ let d = dummy_loc in let n = Name (destCVar t1) in
+ fst (glob (mkCCast d (mkCHole d) (mkCLambda d n (mkCHole d) t2))) in
+ let check_var t2 = if not (isCVar t2) then
+ loc_error (constr_loc t2) "Only identifiers are allowed here" in
+ match p with
+ | _, (_, None) as x -> x
+ | k, (v, Some t) as orig ->
+ if k = 'x' then glob_ssrterm gs ('(', (v, Some t)) else
+ match t with
+ | CNotation(_, "( _ in _ )", ([t1; t2], [], [])) ->
+ (try match glob t1, glob t2 with
+ | (r1, None), (r2, None) -> encode k "In" [r1;r2]
+ | (r1, Some _), (r2, Some _) when isCVar t1 ->
+ encode k "In" [r1; r2; bind_in t1 t2]
+ | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2]
+ | _ -> CErrors.anomaly (str"where are we?")
+ with _ when isCVar t1 -> encode k "In" [bind_in t1 t2])
+ | CNotation(_, "( _ in _ in _ )", ([t1; t2; t3], [], [])) ->
+ check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3]
+ | CNotation(_, "( _ as _ )", ([t1; t2], [], [])) ->
+ encode k "As" [fst (glob t1); fst (glob t2)]
+ | CNotation(_, "( _ as _ in _ )", ([t1; t2; t3], [], [])) ->
+ check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3]
+ | _ -> glob_ssrterm gs orig
+;;
+
+let glob_rpattern s p =
+ match p with
+ | T t -> T (glob_cpattern s t)
+ | In_T t -> In_T (glob_ssrterm s t)
+ | X_In_T(x,t) -> X_In_T (x,glob_ssrterm s t)
+ | In_X_In_T(x,t) -> In_X_In_T (x,glob_ssrterm s t)
+ | E_In_X_In_T(e,x,t) -> E_In_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t)
+ | E_As_X_In_T(e,x,t) -> E_As_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t)
+
+let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c
+
+let subst_rpattern s = function
+ | T t -> T (subst_ssrterm s t)
+ | In_T t -> In_T (subst_ssrterm s t)
+ | X_In_T(x,t) -> X_In_T (x,subst_ssrterm s t)
+ | In_X_In_T(x,t) -> In_X_In_T (x,subst_ssrterm s t)
+ | E_In_X_In_T(e,x,t) -> E_In_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t)
+ | E_As_X_In_T(e,x,t) -> E_As_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t)
+
+ARGUMENT EXTEND rpattern
+ TYPED AS rpatternty
+ PRINTED BY pr_rpattern
+ GLOBALIZED BY glob_rpattern
+ SUBSTITUTED BY subst_rpattern
+ | [ lconstr(c) ] -> [ T (mk_lterm c) ]
+ | [ "in" lconstr(c) ] -> [ In_T (mk_lterm c) ]
+ | [ lconstr(x) "in" lconstr(c) ] ->
+ [ X_In_T (mk_lterm x, mk_lterm c) ]
+ | [ "in" lconstr(x) "in" lconstr(c) ] ->
+ [ In_X_In_T (mk_lterm x, mk_lterm c) ]
+ | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] ->
+ [ E_In_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ]
+ | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] ->
+ [ E_As_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ]
+END
+
+
+
+type cpattern = char * glob_constr_and_expr
+let tag_of_cpattern = fst
+let loc_of_cpattern = loc_ofCG
+let cpattern_of_term t = t
+type occ = (bool * int list) option
+
+type rpattern = (cpattern, cpattern) ssrpattern
+let pr_rpattern = pr_pattern
+
+type pattern = Evd.evar_map * (Term.constr, Term.constr) ssrpattern
+
+
+let id_of_cpattern = function
+ | _,(_,Some (CRef (Ident (_, x), _))) -> Some x
+ | _,(_,Some (CAppExpl (_, (_, Ident (_, x), _), []))) -> Some x
+ | _,(GRef (_, VarRef x, _) ,None) -> Some x
+ | _ -> None
+let id_of_Cterm t = match id_of_cpattern t with
+ | Some x -> x
+ | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here"
+
+let of_ftactic ftac gl =
+ let r = ref None in
+ let tac = Ftactic.run ftac (fun ans -> r := Some ans; Proofview.tclUNIT ()) in
+ let tac = Proofview.V82.of_tactic tac in
+ let { sigma = sigma } = tac gl in
+ let ans = match !r with
+ | None -> assert false (** If the tactic failed we should not reach this point *)
+ | Some ans -> ans
+ in
+ (sigma, ans)
+
+let interp_wit wit ist gl x =
+ let globarg = in_gen (glbwit wit) x in
+ let arg = interp_genarg ist globarg in
+ let (sigma, arg) = of_ftactic arg gl in
+ sigma, Value.cast (topwit wit) arg
+let interp_constr = interp_wit wit_constr
+let interp_open_constr ist gl gc =
+ interp_wit wit_open_constr ist gl gc
+let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c
+let interp_term ist gl (_, c) = (interp_open_constr ist gl c)
+let pr_ssrterm _ _ _ = pr_term
+let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with
+ | Tok.KEYWORD "(" -> '('
+ | Tok.KEYWORD "@" -> '@'
+ | _ -> ' '
+let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind
+
+let interp_ssrterm _ gl t = Tacmach.project gl, t
+
+ARGUMENT EXTEND cpattern
+ PRINTED BY pr_ssrterm
+ INTERPRETED BY interp_ssrterm
+ GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm
+ RAW_PRINTED BY pr_ssrterm
+ GLOB_PRINTED BY pr_ssrterm
+| [ "Qed" constr(c) ] -> [ mk_lterm c ]
+END
+
+let (!@) = Compat.to_coqloc
+
+GEXTEND Gram
+ GLOBAL: cpattern;
+ cpattern: [[ k = ssrtermkind; c = constr ->
+ let pattern = mk_term k c in
+ if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]];
+END
+
+ARGUMENT EXTEND lcpattern
+ TYPED AS cpattern
+ PRINTED BY pr_ssrterm
+ INTERPRETED BY interp_ssrterm
+ GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm
+ RAW_PRINTED BY pr_ssrterm
+ GLOB_PRINTED BY pr_ssrterm
+| [ "Qed" lconstr(c) ] -> [ mk_lterm c ]
+END
+
+GEXTEND Gram
+ GLOBAL: lcpattern;
+ lcpattern: [[ k = ssrtermkind; c = lconstr ->
+ let pattern = mk_term k c in
+ if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]];
+END
+
+let thin id sigma goal =
+ let ids = Id.Set.singleton id in
+ let env = Goal.V82.env sigma goal in
+ let cl = Goal.V82.concl sigma goal in
+ let evdref = ref (Evd.clear_metas sigma) in
+ let ans =
+ try Some (Evarutil.clear_hyps_in_evi env evdref (Environ.named_context_val env) cl ids)
+ with Evarutil.ClearDependencyError _ -> None
+ in
+ match ans with
+ | None -> sigma
+ | Some (hyps, concl) ->
+ let sigma = !evdref in
+ let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in
+ let sigma = Goal.V82.partial_solution_to sigma goal gl ev in
+ sigma
+
+let pr_ist { lfun= lfun } =
+ prlist_with_sep spc
+ (fun (id, Geninterp.Val.Dyn(ty,_)) ->
+ pr_id id ++ str":" ++ Geninterp.Val.pr ty) (Id.Map.bindings lfun)
+
+let interp_pattern ?wit_ssrpatternarg ist gl red redty =
+ pp(lazy(str"interpreting: " ++ pr_pattern red));
+ pp(lazy(str" in ist: " ++ pr_ist ist));
+ let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in
+ let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in
+ let eAsXInT e x t = E_As_X_In_T(e,x,t) in
+ let mkG ?(k=' ') x = k,(x,None) in
+ let decode ist t ?reccall f g =
+ try match (pf_intern_term ist gl t) with
+ | GCast(_,GHole _,CastConv(GLambda(_,Name x,_,_,c))) -> f x (' ',(c,None))
+ | GVar(_,id)
+ when Id.Map.mem id ist.lfun &&
+ not(Option.is_empty reccall) &&
+ not(Option.is_empty wit_ssrpatternarg) ->
+ let v = Id.Map.find id ist.lfun in
+ Option.get reccall
+ (Value.cast (topwit (Option.get wit_ssrpatternarg)) v)
+ | it -> g t with e when CErrors.noncritical e -> g t in
+ let decodeG t f g = decode ist (mkG t) f g in
+ let bad_enc id _ = CErrors.anomaly (str"bad encoding for pattern "++str id) in
+ let cleanup_XinE h x rp sigma =
+ let h_k = match kind_of_term h with Evar (k,_) -> k | _ -> assert false in
+ let to_clean, update = (* handle rename if x is already used *)
+ let ctx = pf_hyps gl in
+ let len = Context.Named.length ctx in
+ let name = ref None in
+ try ignore(Context.Named.lookup x ctx); (name, fun k ->
+ if !name = None then
+ let nctx = Evd.evar_context (Evd.find sigma k) in
+ let nlen = Context.Named.length nctx in
+ if nlen > len then begin
+ name := Some (Context.Named.Declaration.get_id (List.nth nctx (nlen - len - 1)))
+ end)
+ with Not_found -> ref (Some x), fun _ -> () in
+ let sigma0 = project gl in
+ let new_evars =
+ let rec aux acc t = match kind_of_term t with
+ | Evar (k,_) ->
+ if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else
+ (update k; k::acc)
+ | _ -> fold_constr aux acc t in
+ aux [] (Evarutil.nf_evar sigma rp) in
+ let sigma =
+ List.fold_left (fun sigma e ->
+ if Evd.is_defined sigma e then sigma else (* clear may be recursive *)
+ if Option.is_empty !to_clean then sigma else
+ let name = Option.get !to_clean in
+ pp(lazy(pr_id name));
+ thin name sigma e)
+ sigma new_evars in
+ sigma in
+ let red = let rec decode_red (ist,red) = match red with
+ | T(k,(GCast (_,GHole _,(CastConv(GLambda (_,Name id,_,_,t)))),None))
+ when let id = string_of_id id in let len = String.length id in
+ (len > 8 && String.sub id 0 8 = "_ssrpat_") ->
+ let id = string_of_id id in let len = String.length id in
+ (match String.sub id 8 (len - 8), t with
+ | "In", GApp(_, _, [t]) -> decodeG t xInT (fun x -> T x)
+ | "In", GApp(_, _, [e; t]) -> decodeG t (eInXInT (mkG e)) (bad_enc id)
+ | "In", GApp(_, _, [e; t; e_in_t]) ->
+ decodeG t (eInXInT (mkG e))
+ (fun _ -> decodeG e_in_t xInT (fun _ -> assert false))
+ | "As", GApp(_, _, [e; t]) -> decodeG t (eAsXInT (mkG e)) (bad_enc id)
+ | _ -> bad_enc id ())
+ | T t -> decode ist ~reccall:decode_red t xInT (fun x -> T x)
+ | In_T t -> decode ist t inXInT inT
+ | X_In_T (e,t) -> decode ist t (eInXInT e) (fun x -> xInT (id_of_Cterm e) x)
+ | In_X_In_T (e,t) -> inXInT (id_of_Cterm e) t
+ | E_In_X_In_T (e,x,rp) -> eInXInT e (id_of_Cterm x) rp
+ | E_As_X_In_T (e,x,rp) -> eAsXInT e (id_of_Cterm x) rp in
+ decode_red (ist,red) in
+ pp(lazy(str"decoded as: " ++ pr_pattern_w_ids red));
+ let red = match redty with None -> red | Some ty -> let ty = ' ', ty in
+ match red with
+ | T t -> T (combineCG t ty (mkCCast (loc_ofCG t)) mkRCast)
+ | X_In_T (x,t) ->
+ let ty = pf_intern_term ist gl ty in
+ E_As_X_In_T (mkG (mkRCast mkRHole ty), x, t)
+ | E_In_X_In_T (e,x,t) ->
+ let ty = mkG (pf_intern_term ist gl ty) in
+ E_In_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t)
+ | E_As_X_In_T (e,x,t) ->
+ let ty = mkG (pf_intern_term ist gl ty) in
+ E_As_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t)
+ | red -> red in
+ pp(lazy(str"typed as: " ++ pr_pattern_w_ids red));
+ let mkXLetIn loc x (a,(g,c)) = match c with
+ | Some b -> a,(g,Some (mkCLetIn loc x (mkCHole loc) b))
+ | None -> a,(GLetIn (loc,x,(GHole (loc, BinderType x, IntroAnonymous, None)), g), None) in
+ match red with
+ | T t -> let sigma, t = interp_term ist gl t in sigma, T t
+ | In_T t -> let sigma, t = interp_term ist gl t in sigma, In_T t
+ | X_In_T (x, rp) | In_X_In_T (x, rp) ->
+ let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in
+ let rp = mkXLetIn dummy_loc (Name x) rp in
+ let sigma, rp = interp_term ist gl rp in
+ let _, h, _, rp = destLetIn rp in
+ let sigma = cleanup_XinE h x rp sigma in
+ let rp = subst1 h (Evarutil.nf_evar sigma rp) in
+ sigma, mk h rp
+ | E_In_X_In_T(e, x, rp) | E_As_X_In_T (e, x, rp) ->
+ let mk e x p =
+ match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in
+ let rp = mkXLetIn dummy_loc (Name x) rp in
+ let sigma, rp = interp_term ist gl rp in
+ let _, h, _, rp = destLetIn rp in
+ let sigma = cleanup_XinE h x rp sigma in
+ let rp = subst1 h (Evarutil.nf_evar sigma rp) in
+ let sigma, e = interp_term ist (re_sig (sig_it gl) sigma) e in
+ sigma, mk e h rp
+;;
+let interp_cpattern ist gl red redty = interp_pattern ist gl (T red) redty;;
+let interp_rpattern ~wit_ssrpatternarg ist gl red = interp_pattern ~wit_ssrpatternarg ist gl red None;;
+
+let id_of_pattern = function
+ | _, T t -> (match kind_of_term t with Var id -> Some id | _ -> None)
+ | _ -> None
+
+(* The full occurrence set *)
+let noindex = Some(false,[])
+
+(* calls do_subst on every sub-term identified by (pattern,occ) *)
+let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst =
+ let fs sigma x = Reductionops.nf_evar sigma x in
+ let pop_evar sigma e p =
+ let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in
+ let e_body = match e_body with Evar_defined c -> c
+ | _ -> errorstrm (str "Matching the pattern " ++ pr_constr p ++
+ str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++
+ str "Does the variable bound by the \"in\" construct occur "++
+ str "in the pattern?") in
+ let sigma =
+ Evd.add (Evd.remove sigma e) e {e_def with Evd.evar_body = Evar_empty} in
+ sigma, e_body in
+ let ex_value hole =
+ match kind_of_term hole with Evar (e,_) -> e | _ -> assert false in
+ let mk_upat_for ?hack env sigma0 (sigma, t) ?(p=t) ok =
+ let sigma,pat= mk_tpattern ?hack env sigma0 (sigma,p) ok L2R (fs sigma t) in
+ sigma, [pat] in
+ match pattern with
+ | None -> do_subst env0 concl0 concl0 1
+ | Some (sigma, (T rp | In_T rp)) ->
+ let rp = fs sigma rp in
+ let ise = create_evar_defs sigma in
+ let occ = match pattern with Some (_, T _) -> occ | _ -> noindex in
+ let rp = mk_upat_for env0 sigma0 (ise, rp) all_ok in
+ let find_T, end_T = mk_tpattern_matcher ?raise_NoMatch sigma0 occ rp in
+ let concl = find_T env0 concl0 1 do_subst in
+ let _ = end_T () in
+ concl
+ | Some (sigma, (X_In_T (hole, p) | In_X_In_T (hole, p))) ->
+ let p = fs sigma p in
+ let occ = match pattern with Some (_, X_In_T _) -> occ | _ -> noindex in
+ let ex = ex_value hole in
+ let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in
+ let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in
+ (* we start from sigma, so hole is considered a rigid head *)
+ let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in
+ let find_X, end_X = mk_tpattern_matcher ?raise_NoMatch sigma occ holep in
+ let concl = find_T env0 concl0 1 (fun env c _ h ->
+ let p_sigma = unify_HO env (create_evar_defs sigma) c p in
+ let sigma, e_body = pop_evar p_sigma ex p in
+ fs p_sigma (find_X env (fs sigma p) h
+ (fun env _ -> do_subst env e_body))) in
+ let _ = end_X () in let _ = end_T () in
+ concl
+ | Some (sigma, E_In_X_In_T (e, hole, p)) ->
+ let p, e = fs sigma p, fs sigma e in
+ let ex = ex_value hole in
+ let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in
+ let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in
+ let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in
+ let find_X, end_X = mk_tpattern_matcher sigma noindex holep in
+ let re = mk_upat_for env0 sigma0 (sigma, e) all_ok in
+ let find_E, end_E = mk_tpattern_matcher ?raise_NoMatch sigma0 occ re in
+ let concl = find_T env0 concl0 1 (fun env c _ h ->
+ let p_sigma = unify_HO env (create_evar_defs sigma) c p in
+ let sigma, e_body = pop_evar p_sigma ex p in
+ fs p_sigma (find_X env (fs sigma p) h (fun env c _ h ->
+ find_E env e_body h do_subst))) in
+ let _ = end_E () in let _ = end_X () in let _ = end_T () in
+ concl
+ | Some (sigma, E_As_X_In_T (e, hole, p)) ->
+ let p, e = fs sigma p, fs sigma e in
+ let ex = ex_value hole in
+ let rp =
+ let e_sigma = unify_HO env0 sigma hole e in
+ e_sigma, fs e_sigma p in
+ let rp = mk_upat_for ~hack:true env0 sigma0 rp all_ok in
+ let find_TE, end_TE = mk_tpattern_matcher sigma0 noindex rp in
+ let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in
+ let find_X, end_X = mk_tpattern_matcher sigma occ holep in
+ let concl = find_TE env0 concl0 1 (fun env c _ h ->
+ let p_sigma = unify_HO env (create_evar_defs sigma) c p in
+ let sigma, e_body = pop_evar p_sigma ex p in
+ fs p_sigma (find_X env (fs sigma p) h (fun env c _ h ->
+ let e_sigma = unify_HO env sigma e_body e in
+ let e_body = fs e_sigma e in
+ do_subst env e_body e_body h))) in
+ let _ = end_X () in let _ = end_TE () in
+ concl
+;;
+
+let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) =
+ let e = match p with
+ | In_T _ | In_X_In_T _ -> CErrors.anomaly (str"pattern without redex")
+ | T e | X_In_T (e, _) | E_As_X_In_T (e, _, _) | E_In_X_In_T (e, _, _) -> e in
+ let sigma =
+ if not resolve_typeclasses then sigma
+ else Typeclasses.resolve_typeclasses ~fail:false env sigma in
+ Reductionops.nf_evar sigma e, Evd.evar_universe_context sigma
+
+let fill_occ_pattern ?raise_NoMatch env sigma cl pat occ h =
+ let do_make_rel, occ =
+ if occ = Some(true,[]) then false, Some(false,[1]) else true, occ in
+ let find_R, conclude =
+ let r = ref None in
+ (fun env c _ h' ->
+ do_once r (fun () -> c, Evd.empty_evar_universe_context);
+ if do_make_rel then mkRel (h'+h-1) else c),
+ (fun _ -> if !r = None then redex_of_pattern env pat else assert_done r) in
+ let cl = eval_pattern ?raise_NoMatch env sigma cl (Some pat) occ find_R in
+ let e = conclude cl in
+ e, cl
+;;
+
+(* clenup interface for external use *)
+let mk_tpattern ?p_origin env sigma0 sigma_t f dir c =
+ mk_tpattern ?p_origin env sigma0 sigma_t f dir c
+;;
+
+let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h =
+ let ise = create_evar_defs sigma in
+ let ise, u = mk_tpattern env sigma0 (ise,t) ok L2R p in
+ let find_U, end_U =
+ mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in
+ let concl = find_U env concl h (fun _ _ _ -> mkRel) in
+ let rdx, _, (sigma, uc, p) = end_U () in
+ sigma, uc, p, concl, rdx
+
+let fill_occ_term env cl occ sigma0 (sigma, t) =
+ try
+ let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in
+ if sigma' != sigma0 then CErrors.error "matching impacts evars"
+ else cl, (Evd.merge_universe_context sigma' uc, t')
+ with NoMatch -> try
+ let sigma', uc, t' =
+ unif_end env sigma0 (create_evar_defs sigma) t (fun _ -> true) in
+ if sigma' != sigma0 then raise NoMatch
+ else cl, (Evd.merge_universe_context sigma' uc, t')
+ with _ ->
+ errorstrm (str "partial term " ++ pr_constr_pat t
+ ++ str " does not match any subterm of the goal")
+
+let pf_fill_occ_term gl occ t =
+ let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in
+ let cl,(_,t) = fill_occ_term env concl occ sigma0 t in
+ cl, t
+
+let cpattern_of_id id = ' ', (GRef (dummy_loc, VarRef id, None), None)
+
+let is_wildcard = function
+ | _,(_,Some (CHole _)|GHole _,None) -> true
+ | _ -> false
+
+(* "ssrpattern" *)
+let pr_ssrpatternarg _ _ _ (_,cpat) = pr_rpattern cpat
+let pr_ssrpatternarg_glob _ _ _ cpat = pr_rpattern cpat
+let interp_ssrpatternarg ist gl p = project gl, (ist, p)
+
+ARGUMENT EXTEND ssrpatternarg
+ PRINTED BY pr_ssrpatternarg
+ INTERPRETED BY interp_ssrpatternarg
+ GLOBALIZED BY glob_rpattern
+ RAW_PRINTED BY pr_ssrpatternarg_glob
+ GLOB_PRINTED BY pr_ssrpatternarg_glob
+| [ rpattern(pat) ] -> [ pat ]
+END
+
+let pf_merge_uc uc gl =
+ re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc)
+
+let pf_unsafe_merge_uc uc gl =
+ re_sig (sig_it gl) (Evd.set_universe_context (project gl) uc)
+
+let interp_rpattern ist gl red = interp_rpattern ~wit_ssrpatternarg ist gl red
+
+let ssrpatterntac _ist (arg_ist,arg) gl =
+ let pat = interp_rpattern arg_ist gl arg in
+ let sigma0 = project gl in
+ let concl0 = pf_concl gl in
+ let (t, uc), concl_x =
+ fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in
+ let gl, tty = pf_type_of gl t in
+ let concl = mkLetIn (Name (id_of_string "selected"), t, tty, concl_x) in
+ Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl
+
+(* Register "ssrpattern" tactic *)
+let () =
+ let mltac _ ist =
+ let arg =
+ let v = Id.Map.find (Names.Id.of_string "pattern") ist.lfun in
+ Value.cast (topwit wit_ssrpatternarg) v in
+ Proofview.V82.tactic (ssrpatterntac ist arg) in
+ let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in
+ let () = Tacenv.register_ml_tactic name [|mltac|] in
+ let tac =
+ TacFun ([Some (Id.of_string "pattern")],
+ TacML (Loc.ghost, { mltac_name = name; mltac_index = 0 }, [])) in
+ let obj () =
+ Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in
+ Mltop.declare_cache_obj obj "ssrmatching_plugin"
+
+let ssrinstancesof ist arg gl =
+ let ok rhs lhs ise = true in
+(* not (Term.eq_constr lhs (Evarutil.nf_evar ise rhs)) in *)
+ let env, sigma, concl = pf_env gl, project gl, pf_concl gl in
+ let sigma0, cpat = interp_cpattern ist gl arg None in
+ let pat = match cpat with T x -> x | _ -> errorstrm (str"Not supported") in
+ let etpat, tpat = mk_tpattern env sigma (sigma0,pat) (ok pat) L2R pat in
+ let find, conclude =
+ mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true
+ sigma None (etpat,[tpat]) in
+ let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in
+ ppnl (str"BEGIN INSTANCES");
+ try
+ while true do
+ ignore(find env concl 1 ~k:print)
+ done; raise NoMatch
+ with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl
+
+TACTIC EXTEND ssrinstoftpat
+| [ "ssrinstancesoftpat" cpattern(arg) ] -> [ Proofview.V82.tactic (ssrinstancesof ist arg) ]
+END
+
+(* We wipe out all the keywords generated by the grammar rules we defined. *)
+(* The user is supposed to Require Import ssreflect or Require ssreflect *)
+(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *)
+(* consequence the extended ssreflect grammar. *)
+let () = CLexer.unfreeze frozen_lexer ;;
+
+(* vim: set filetype=ocaml foldmethod=marker: *)
diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli
new file mode 100644
index 00000000..288a04e6
--- /dev/null
+++ b/plugins/ssrmatching/ssrmatching.mli
@@ -0,0 +1,241 @@
+(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *)
+(* Distributed under the terms of CeCILL-B. *)
+
+open Genarg
+open Tacexpr
+open Environ
+open Tacmach
+open Evd
+open Proof_type
+open Term
+
+(** ******** Small Scale Reflection pattern matching facilities ************* *)
+
+(** Pattern parsing *)
+
+(** The type of context patterns, the patterns of the [set] tactic and
+ [:] tactical. These are patterns that identify a precise subterm. *)
+type cpattern
+val pr_cpattern : cpattern -> Pp.std_ppcmds
+
+(** CS cpattern: (f _), (X in t), (t in X in t), (t as X in t) *)
+val cpattern : cpattern Pcoq.Gram.entry
+val wit_cpattern : cpattern uniform_genarg_type
+
+(** OS cpattern: f _, (X in t), (t in X in t), (t as X in t) *)
+val lcpattern : cpattern Pcoq.Gram.entry
+val wit_lcpattern : cpattern uniform_genarg_type
+
+(** The type of rewrite patterns, the patterns of the [rewrite] tactic.
+ These patterns also include patterns that identify all the subterms
+ of a context (i.e. "in" prefix) *)
+type rpattern
+val pr_rpattern : rpattern -> Pp.std_ppcmds
+
+(** OS rpattern: f _, in t, X in t, in X in t, t in X in t, t as X in t *)
+val rpattern : rpattern Pcoq.Gram.entry
+val wit_rpattern : rpattern uniform_genarg_type
+
+(** Pattern interpretation and matching *)
+
+exception NoMatch
+exception NoProgress
+
+(** AST for [rpattern] (and consequently [cpattern]) *)
+type ('ident, 'term) ssrpattern =
+ | T of 'term
+ | In_T of 'term
+ | X_In_T of 'ident * 'term
+ | In_X_In_T of 'ident * 'term
+ | E_In_X_In_T of 'term * 'ident * 'term
+ | E_As_X_In_T of 'term * 'ident * 'term
+
+type pattern = evar_map * (constr, constr) ssrpattern
+val pp_pattern : pattern -> Pp.std_ppcmds
+
+(** Extracts the redex and applies to it the substitution part of the pattern.
+ @raise Anomaly if called on [In_T] or [In_X_In_T] *)
+val redex_of_pattern :
+ ?resolve_typeclasses:bool -> env -> pattern ->
+ constr Evd.in_evar_universe_context
+
+(** [interp_rpattern ise gl rpat] "internalizes" and "interprets" [rpat]
+ in the current [Ltac] interpretation signature [ise] and tactic input [gl]*)
+val interp_rpattern :
+ Tacinterp.interp_sign -> goal sigma ->
+ rpattern ->
+ pattern
+
+(** [interp_cpattern ise gl cpat ty] "internalizes" and "interprets" [cpat]
+ in the current [Ltac] interpretation signature [ise] and tactic input [gl].
+ [ty] is an optional type for the redex of [cpat] *)
+val interp_cpattern :
+ Tacinterp.interp_sign -> goal sigma ->
+ cpattern -> glob_constr_and_expr option ->
+ pattern
+
+(** The set of occurrences to be matched. The boolean is set to true
+ * to signal the complement of this set (i.e. {-1 3}) *)
+type occ = (bool * int list) option
+
+(** [subst e p t i]. [i] is the number of binders
+ traversed so far, [p] the term from the pattern, [t] the matched one *)
+type subst = env -> constr -> constr -> int -> constr
+
+(** [eval_pattern b env sigma t pat occ subst] maps [t] calling [subst] on every
+ [occ] occurrence of [pat]. The [int] argument is the number of
+ binders traversed. If [pat] is [None] then then subst is called on [t].
+ [t] must live in [env] and [sigma], [pat] must have been interpreted in
+ (an extension of) [sigma].
+ @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false])
+ @return [t] where all [occ] occurrences of [pat] have been mapped using
+ [subst] *)
+val eval_pattern :
+ ?raise_NoMatch:bool ->
+ env -> evar_map -> constr ->
+ pattern option -> occ -> subst ->
+ constr
+
+(** [fill_occ_pattern b env sigma t pat occ h] is a simplified version of
+ [eval_pattern].
+ It replaces all [occ] occurrences of [pat] in [t] with Rel [h].
+ [t] must live in [env] and [sigma], [pat] must have been interpreted in
+ (an extension of) [sigma].
+ @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false])
+ @return the instance of the redex of [pat] that was matched and [t]
+ transformed as described above. *)
+val fill_occ_pattern :
+ ?raise_NoMatch:bool ->
+ env -> evar_map -> constr ->
+ pattern -> occ -> int ->
+ constr Evd.in_evar_universe_context * constr
+
+(** *************************** Low level APIs ****************************** *)
+
+(* The primitive matching facility. It matches of a term with holes, like
+ the T pattern above, and calls a continuation on its occurrences. *)
+
+type ssrdir = L2R | R2L
+val pr_dir_side : ssrdir -> Pp.std_ppcmds
+
+(** a pattern for a term with wildcards *)
+type tpattern
+
+(** [mk_tpattern env sigma0 sigma_p ok p_origin dir t] compiles a term [t]
+ living in [env] [sigma] (an extension of [sigma0]) intro a [tpattern].
+ The [tpattern] can hold a (proof) term [p] and a diction [dir]. The [ok]
+ callback is used to filter occurrences.
+ @return the compiled [tpattern] and its [evar_map]
+ @raise UserEerror is the pattern is a wildcard *)
+val mk_tpattern :
+ ?p_origin:ssrdir * constr ->
+ env -> evar_map ->
+ evar_map * constr ->
+ (constr -> evar_map -> bool) ->
+ ssrdir -> constr ->
+ evar_map * tpattern
+
+(** [findP env t i k] is a stateful function that finds the next occurrence
+ of a tpattern and calls the callback [k] to map the subterm matched.
+ The [int] argument passed to [k] is the number of binders traversed so far
+ plus the initial value [i].
+ @return [t] where the subterms identified by the selected occurrences of
+ the patter have been mapped using [k]
+ @raise NoMatch if the raise_NoMatch flag given to [mk_tpattern_matcher] is
+ [true] and if the pattern did not match
+ @raise UserEerror if the raise_NoMatch flag given to [mk_tpattern_matcher] is
+ [false] and if the pattern did not match *)
+type find_P =
+ env -> constr -> int -> k:subst -> constr
+
+(** [conclude ()] asserts that all mentioned ocurrences have been visited.
+ @return the instance of the pattern, the evarmap after the pattern
+ instantiation, the proof term and the ssrdit stored in the tpattern
+ @raise UserEerror if too many occurrences were specified *)
+type conclude =
+ unit -> constr * ssrdir * (evar_map * Evd.evar_universe_context * constr)
+
+(** [mk_tpattern_matcher b o sigma0 occ sigma_tplist] creates a pair
+ a function [find_P] and [conclude] with the behaviour explained above.
+ The flag [b] (default [false]) changes the error reporting behaviour
+ of [find_P] if none of the [tpattern] matches. The argument [o] can
+ be passed to tune the [UserError] eventually raised (useful if the
+ pattern is coming from the LHS/RHS of an equation) *)
+val mk_tpattern_matcher :
+ ?all_instances:bool ->
+ ?raise_NoMatch:bool ->
+ ?upats_origin:ssrdir * constr ->
+ evar_map -> occ -> evar_map * tpattern list ->
+ find_P * conclude
+
+(** Example of [mk_tpattern_matcher] to implement
+ [rewrite \{occ\}\[in t\]rules].
+ It first matches "in t" (called [pat]), then in all matched subterms
+ it matches the LHS of the rules using [find_R].
+ [concl0] is the initial goal, [concl] will be the goal where some terms
+ are replaced by a De Bruijn index. The [rw_progress] extra check
+ selects only occurrences that are not rewritten to themselves (e.g.
+ an occurrence "x + x" rewritten with the commutativity law of addition
+ is skipped) {[
+ let find_R, conclude = match pat with
+ | Some (_, In_T _) ->
+ let aux (sigma, pats) (d, r, lhs, rhs) =
+ let sigma, pat =
+ mk_tpattern env0 sigma0 (sigma, r) (rw_progress rhs) d lhs in
+ sigma, pats @ [pat] in
+ let rpats = List.fold_left aux (r_sigma, []) rules in
+ let find_R, end_R = mk_tpattern_matcher sigma0 occ rpats in
+ find_R ~k:(fun _ _ h -> mkRel h),
+ fun cl -> let rdx, d, r = end_R () in (d,r),rdx
+ | _ -> ... in
+ let concl = eval_pattern env0 sigma0 concl0 pat occ find_R in
+ let (d, r), rdx = conclude concl in ]} *)
+
+(* convenience shortcut: [pf_fill_occ_term gl occ (sigma,t)] returns
+ * the conclusion of [gl] where [occ] occurrences of [t] have been replaced
+ * by [Rel 1] and the instance of [t] *)
+val pf_fill_occ_term : goal sigma -> occ -> evar_map * constr -> constr * constr
+
+(* It may be handy to inject a simple term into the first form of cpattern *)
+val cpattern_of_term : char * glob_constr_and_expr -> cpattern
+
+(** Helpers to make stateful closures. Example: a [find_P] function may be
+ called many times, but the pattern instantiation phase is performed only the
+ first time. The corresponding [conclude] has to return the instantiated
+ pattern redex. Since it is up to [find_P] to raise [NoMatch] if the pattern
+ has no instance, [conclude] considers it an anomaly if the pattern did
+ not match *)
+
+(** [do_once r f] calls [f] and updates the ref only once *)
+val do_once : 'a option ref -> (unit -> 'a) -> unit
+(** [assert_done r] return the content of r. @raise Anomaly is r is [None] *)
+val assert_done : 'a option ref -> 'a
+
+(** Very low level APIs.
+ these are calls to evarconv's [the_conv_x] followed by
+ [solve_unif_constraints_with_heuristics] and [resolve_typeclasses].
+ In case of failure they raise [NoMatch] *)
+
+val unify_HO : env -> evar_map -> constr -> constr -> evar_map
+val pf_unify_HO : goal sigma -> constr -> constr -> goal sigma
+
+(** Some more low level functions needed to implement the full SSR language
+ on top of the former APIs *)
+val tag_of_cpattern : cpattern -> char
+val loc_of_cpattern : cpattern -> Loc.t
+val id_of_pattern : pattern -> Names.variable option
+val is_wildcard : cpattern -> bool
+val cpattern_of_id : Names.variable -> cpattern
+val cpattern_of_id : Names.variable -> cpattern
+val pr_constr_pat : constr -> Pp.std_ppcmds
+val pf_merge_uc : Evd.evar_universe_context -> goal Evd.sigma -> goal Evd.sigma
+val pf_unsafe_merge_uc : Evd.evar_universe_context -> goal Evd.sigma -> goal Evd.sigma
+
+(* One can also "Set SsrMatchingDebug" from a .v *)
+val debug : bool -> unit
+
+(* One should delimit a snippet with "Set SsrMatchingProfiling" and
+ * "Unset SsrMatchingProfiling" to get timings *)
+val profile : bool -> unit
+
+(* eof *)
diff --git a/plugins/ssrmatching/ssrmatching.v b/plugins/ssrmatching/ssrmatching.v
new file mode 100644
index 00000000..829ee05e
--- /dev/null
+++ b/plugins/ssrmatching/ssrmatching.v
@@ -0,0 +1,26 @@
+(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *)
+(* Distributed under the terms of CeCILL-B. *)
+Declare ML Module "ssrmatching_plugin".
+
+Module SsrMatchingSyntax.
+
+(* Reserve the notation for rewrite patterns so that the user is not allowed *)
+(* to declare it at a different level. *)
+Reserved Notation "( a 'in' b )" (at level 0).
+Reserved Notation "( a 'as' b )" (at level 0).
+Reserved Notation "( a 'in' b 'in' c )" (at level 0).
+Reserved Notation "( a 'as' b 'in' c )" (at level 0).
+
+(* Notation to define shortcuts for the "X in t" part of a pattern. *)
+Notation "( X 'in' t )" := (_ : fun X => t) : ssrpatternscope.
+Delimit Scope ssrpatternscope with pattern.
+
+(* Some shortcuts for recurrent "X in t" parts. *)
+Notation RHS := (X in _ = X)%pattern.
+Notation LHS := (X in X = _)%pattern.
+
+End SsrMatchingSyntax.
+
+Export SsrMatchingSyntax.
+
+Tactic Notation "ssrpattern" ssrpatternarg(p) := ssrpattern p .
diff --git a/plugins/ssrmatching/ssrmatching_plugin.mlpack b/plugins/ssrmatching/ssrmatching_plugin.mlpack
new file mode 100644
index 00000000..5fb1f156
--- /dev/null
+++ b/plugins/ssrmatching/ssrmatching_plugin.mlpack
@@ -0,0 +1 @@
+Ssrmatching
diff --git a/plugins/ssrmatching/vo.itarget b/plugins/ssrmatching/vo.itarget
new file mode 100644
index 00000000..b0eb3883
--- /dev/null
+++ b/plugins/ssrmatching/vo.itarget
@@ -0,0 +1 @@
+ssrmatching.vo
diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml
index 67c9dd0a..e18d19ce 100644
--- a/plugins/syntax/ascii_syntax.ml
+++ b/plugins/syntax/ascii_syntax.ml
@@ -6,8 +6,12 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "ascii_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
open Pp
-open Errors
+open CErrors
open Util
open Names
open Glob_term
diff --git a/plugins/syntax/ascii_syntax_plugin.mllib b/plugins/syntax/ascii_syntax_plugin.mllib
deleted file mode 100644
index b00f9250..00000000
--- a/plugins/syntax/ascii_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Ascii_syntax
-Ascii_syntax_plugin_mod
diff --git a/plugins/syntax/ascii_syntax_plugin.mlpack b/plugins/syntax/ascii_syntax_plugin.mlpack
new file mode 100644
index 00000000..7b9213a0
--- /dev/null
+++ b/plugins/syntax/ascii_syntax_plugin.mlpack
@@ -0,0 +1 @@
+Ascii_syntax
diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml
index 5f44904c..a9eb126b 100644
--- a/plugins/syntax/nat_syntax.ml
+++ b/plugins/syntax/nat_syntax.ml
@@ -6,6 +6,10 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "nat_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
(* This file defines the printer for natural numbers in [nat] *)
(*i*)
@@ -13,7 +17,7 @@ open Glob_term
open Bigint
open Coqlib
open Pp
-open Errors
+open CErrors
(*i*)
(**********************************************************************)
@@ -22,14 +26,16 @@ open Errors
let threshold = of_int 5000
+let warn_large_nat =
+ CWarnings.create ~name:"large-nat" ~category:"numbers"
+ (fun () -> strbrk "Stack overflow or segmentation fault happens when " ++
+ strbrk "working with large numbers in nat (observed threshold " ++
+ strbrk "may vary from 5000 to 70000 depending on your system " ++
+ strbrk "limits and on the command executed).")
+
let nat_of_int dloc n =
if is_pos_or_zero n then begin
- if less_than threshold n then
- msg_warning
- (strbrk "Stack overflow or segmentation fault happens when " ++
- strbrk "working with large numbers in nat (observed threshold " ++
- strbrk "may vary from 5000 to 70000 depending on your system " ++
- strbrk "limits and on the command executed).");
+ if less_than threshold n then warn_large_nat ();
let ref_O = GRef (dloc, glob_O, None) in
let ref_S = GRef (dloc, glob_S, None) in
let rec mk_nat acc n =
diff --git a/plugins/syntax/nat_syntax_plugin.mllib b/plugins/syntax/nat_syntax_plugin.mllib
deleted file mode 100644
index 69b0cb20..00000000
--- a/plugins/syntax/nat_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Nat_syntax
-Nat_syntax_plugin_mod
diff --git a/plugins/syntax/nat_syntax_plugin.mlpack b/plugins/syntax/nat_syntax_plugin.mlpack
new file mode 100644
index 00000000..39bdd62f
--- /dev/null
+++ b/plugins/syntax/nat_syntax_plugin.mlpack
@@ -0,0 +1 @@
+Nat_syntax
diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml
index fe9f1319..f65f9b79 100644
--- a/plugins/syntax/numbers_syntax.ml
+++ b/plugins/syntax/numbers_syntax.ml
@@ -6,6 +6,10 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "numbers_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
(* digit-based syntax for int31, bigN bigZ and bigQ *)
open Bigint
@@ -96,7 +100,7 @@ let int31_of_pos_bigint dloc n =
GApp (dloc, ref_construct, List.rev (args 31 n))
let error_negative dloc =
- Errors.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
+ CErrors.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
let interp_int31 dloc n =
if is_pos_or_zero n then
@@ -180,12 +184,12 @@ let bigN_of_pos_bigint dloc n =
let word = word_of_pos_bigint dloc h n in
let args =
if h < n_inlined then [word]
- else [Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word]
+ else [Nat_syntax_plugin.Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word]
in
GApp (dloc, ref_constructor, args)
let bigN_error_negative dloc =
- Errors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
+ CErrors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
let interp_bigN dloc n =
if is_pos_or_zero n then
diff --git a/plugins/syntax/numbers_syntax_plugin.mllib b/plugins/syntax/numbers_syntax_plugin.mllib
deleted file mode 100644
index ebc0bb20..00000000
--- a/plugins/syntax/numbers_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Numbers_syntax
-Numbers_syntax_plugin_mod
diff --git a/plugins/syntax/numbers_syntax_plugin.mlpack b/plugins/syntax/numbers_syntax_plugin.mlpack
new file mode 100644
index 00000000..e48c00a0
--- /dev/null
+++ b/plugins/syntax/numbers_syntax_plugin.mlpack
@@ -0,0 +1 @@
+Numbers_syntax
diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml
index 05d73f9e..3ae2d45f 100644
--- a/plugins/syntax/r_syntax.ml
+++ b/plugins/syntax/r_syntax.ml
@@ -10,6 +10,10 @@ open Util
open Names
open Globnames
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "r_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
exception Non_closed_number
(**********************************************************************)
diff --git a/plugins/syntax/r_syntax_plugin.mllib b/plugins/syntax/r_syntax_plugin.mllib
deleted file mode 100644
index 5c173a14..00000000
--- a/plugins/syntax/r_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-R_syntax
-R_syntax_plugin_mod
diff --git a/plugins/syntax/r_syntax_plugin.mlpack b/plugins/syntax/r_syntax_plugin.mlpack
new file mode 100644
index 00000000..d4ee75ea
--- /dev/null
+++ b/plugins/syntax/r_syntax_plugin.mlpack
@@ -0,0 +1 @@
+R_syntax
diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml
index 2e696f39..de0fa77e 100644
--- a/plugins/syntax/string_syntax.ml
+++ b/plugins/syntax/string_syntax.ml
@@ -7,10 +7,14 @@
(***********************************************************************)
open Globnames
-open Ascii_syntax
+open Ascii_syntax_plugin.Ascii_syntax
open Glob_term
open Coqlib
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "string_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
exception Non_closed_string
(* make a string term from the string s *)
diff --git a/plugins/syntax/string_syntax_plugin.mllib b/plugins/syntax/string_syntax_plugin.mllib
deleted file mode 100644
index b108c9e0..00000000
--- a/plugins/syntax/string_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-String_syntax
-String_syntax_plugin_mod
diff --git a/plugins/syntax/string_syntax_plugin.mlpack b/plugins/syntax/string_syntax_plugin.mlpack
new file mode 100644
index 00000000..45d6e0fa
--- /dev/null
+++ b/plugins/syntax/string_syntax_plugin.mlpack
@@ -0,0 +1 @@
+String_syntax
diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml
index 53c1b5d7..60803a36 100644
--- a/plugins/syntax/z_syntax.ml
+++ b/plugins/syntax/z_syntax.ml
@@ -7,11 +7,15 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Bigint
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "z_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
exception Non_closed_number
(**********************************************************************)
diff --git a/plugins/syntax/z_syntax_plugin.mllib b/plugins/syntax/z_syntax_plugin.mllib
deleted file mode 100644
index 36d41acc..00000000
--- a/plugins/syntax/z_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Z_syntax
-Z_syntax_plugin_mod
diff --git a/plugins/syntax/z_syntax_plugin.mlpack b/plugins/syntax/z_syntax_plugin.mlpack
new file mode 100644
index 00000000..411260c0
--- /dev/null
+++ b/plugins/syntax/z_syntax_plugin.mlpack
@@ -0,0 +1 @@
+Z_syntax
diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml
index ca1d0b7f..e18aece0 100644
--- a/pretyping/arguments_renaming.ml
+++ b/pretyping/arguments_renaming.ml
@@ -16,12 +16,12 @@ open Libobject
(*i*)
let name_table =
- Summary.ref (Refmap.empty : Name.t list list Refmap.t)
+ Summary.ref (Refmap.empty : Name.t list Refmap.t)
~name:"rename-arguments"
type req =
| ReqLocal
- | ReqGlobal of global_reference * Name.t list list
+ | ReqGlobal of global_reference * Name.t list
let load_rename_args _ (_, (_, (r, names))) =
name_table := Refmap.add r names !name_table
@@ -49,7 +49,7 @@ let discharge_rename_args = function
let vars,_,_ = section_segment_of_reference c in
let c' = pop_global_reference c in
let var_names = List.map (fun (id, _,_,_) -> Name id) vars in
- let names' = List.map (fun l -> var_names @ l) names in
+ let names' = var_names @ names in
Some (ReqGlobal (c', names), (c', names'))
with Not_found -> Some req)
| _ -> None
@@ -83,7 +83,7 @@ let rec rename_prod c = function
| _ -> c
let rename_type ty ref =
- try rename_prod ty (List.hd (arguments_names ref))
+ try rename_prod ty (arguments_names ref)
with Not_found -> ty
let rename_type_of_constant env c =
diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli
index a3340550..e123e778 100644
--- a/pretyping/arguments_renaming.mli
+++ b/pretyping/arguments_renaming.mli
@@ -11,10 +11,10 @@ open Globnames
open Environ
open Term
-val rename_arguments : bool -> global_reference -> Name.t list list -> unit
+val rename_arguments : bool -> global_reference -> Name.t list -> unit
-(** [Not_found] is raised is no names are defined for [r] *)
-val arguments_names : global_reference -> Name.t list list
+(** [Not_found] is raised if no names are defined for [r] *)
+val arguments_names : global_reference -> Name.t list
val rename_type_of_constant : env -> pconstant -> types
val rename_type_of_inductive : env -> pinductive -> types
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 3d6fa38d..6e4d7270 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -7,13 +7,12 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Nameops
open Term
open Vars
-open Context
open Termops
open Namegen
open Declarations
@@ -26,9 +25,12 @@ open Glob_ops
open Retyping
open Pretype_errors
open Evarutil
+open Evardefine
open Evarsolve
open Evarconv
open Evd
+open Sigma.Notations
+open Context.Rel.Declaration
(* Pattern-matching errors *)
@@ -60,13 +62,15 @@ let error_wrong_numarg_constructor_loc loc env c n =
let error_wrong_numarg_inductive_loc loc env c n =
raise_pattern_matching_error (loc, env, Evd.empty, WrongNumargInductive(c,n))
-let rec list_try_compile f = function
- | [a] -> f a
- | [] -> anomaly (str "try_find_f")
+let list_try_compile f l =
+ let rec aux errors = function
+ | [] -> if errors = [] then anomaly (str "try_find_f") else iraise (List.last errors)
| h::t ->
try f h
- with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ ->
- list_try_compile f t
+ with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ as e ->
+ let e = CErrors.push e in
+ aux (e::errors) t in
+ aux [] l
let force_name =
let nx = Name default_dependent_ident in function Anonymous -> nx | na -> na
@@ -131,7 +135,7 @@ type tomatch_status =
| Pushed of (bool*((constr * tomatch_type) * int list * Name.t))
| Alias of (bool*(Name.t * constr * (constr * types)))
| NonDepAlias
- | Abstract of int * rel_declaration
+ | Abstract of int * Context.Rel.Declaration.t
type tomatch_stack = tomatch_status list
@@ -273,13 +277,13 @@ let inductive_template evdref env tmloc ind =
| None -> fun _ -> (Loc.ghost, Evar_kinds.InternalHole) in
let (_,evarl,_) =
List.fold_right
- (fun (na,b,ty) (subst,evarl,n) ->
- match b with
- | None ->
+ (fun decl (subst,evarl,n) ->
+ match decl with
+ | LocalAssum (na,ty) ->
let ty' = substl subst ty in
let e = e_new_evar env evdref ~src:(hole_source n) ty' in
(e::subst,e::evarl,n+1)
- | Some b ->
+ | LocalDef (na,b,ty) ->
(substl subst b::subst,evarl,n+1))
arsign ([],[],1) in
applist (mkIndU indu,List.rev evarl)
@@ -307,15 +311,15 @@ let binding_vars_of_inductive = function
| NotInd _ -> []
| IsInd (_,IndType(_,realargs),_) -> List.filter isRel realargs
-let extract_inductive_data env sigma (_,b,t) =
- match b with
- | None ->
+let extract_inductive_data env sigma decl =
+ match decl with
+ | LocalAssum (_,t) ->
let tmtyp =
try try_find_ind env sigma t None
with Not_found -> NotInd (None,t) in
let tmtypvars = binding_vars_of_inductive tmtyp in
(tmtyp,tmtypvars)
- | Some _ ->
+ | LocalDef (_,_,t) ->
(NotInd (None, t), [])
let unify_tomatch_with_patterns evdref env loc typ pats realnames =
@@ -428,7 +432,7 @@ let remove_current_pattern eqn =
let push_current_pattern (cur,ty) eqn =
match eqn.patterns with
| pat::pats ->
- let rhs_env = push_rel (alias_of_pat pat,Some cur,ty) eqn.rhs.rhs_env in
+ let rhs_env = push_rel (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in
{ eqn with
rhs = { eqn.rhs with rhs_env = rhs_env };
patterns = pats }
@@ -455,9 +459,9 @@ let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
exception NotAdjustable
let rec adjust_local_defs loc = function
- | (pat :: pats, (_,None,_) :: decls) ->
+ | (pat :: pats, LocalAssum _ :: decls) ->
pat :: adjust_local_defs loc (pats,decls)
- | (pats, (_,Some _,_) :: decls) ->
+ | (pats, LocalDef _ :: decls) ->
PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls)
| [], [] -> []
| _ -> raise NotAdjustable
@@ -529,9 +533,10 @@ let dependencies_in_pure_rhs nargs eqns =
let deps_columns = matrix_transpose deps_rows in
List.map (List.exists (fun x -> x)) deps_columns
-let dependent_decl a = function
- | (na,None,t) -> dependent a t
- | (na,Some c,t) -> dependent a t || dependent a c
+let dependent_decl a =
+ function
+ | LocalAssum (na,t) -> dependent a t
+ | LocalDef (na,c,t) -> dependent a t || dependent a c
let rec dep_in_tomatch n = function
| (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch n l
@@ -602,7 +607,7 @@ let relocate_index_tomatch n1 n2 =
NonDepAlias :: genrec depth rest
| Abstract (i,d) :: rest ->
let i = relocate_rel n1 n2 depth i in
- Abstract (i,map_rel_declaration (relocate_index n1 n2 depth) d)
+ Abstract (i, map_constr (relocate_index n1 n2 depth) d)
:: genrec (depth+1) rest in
genrec 0
@@ -635,7 +640,7 @@ let replace_tomatch n c =
| NonDepAlias :: rest ->
NonDepAlias :: replrec depth rest
| Abstract (i,d) :: rest ->
- Abstract (i,map_rel_declaration (replace_term n c depth) d)
+ Abstract (i, map_constr (replace_term n c depth) d)
:: replrec (depth+1) rest in
replrec 0
@@ -660,7 +665,7 @@ let rec liftn_tomatch_stack n depth = function
NonDepAlias :: liftn_tomatch_stack n depth rest
| Abstract (i,d)::rest ->
let i = if i
let na =
merge_name
- (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
+ (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env t na) avoid))
d na
in
(na::l,(out_name na)::avoid))
@@ -728,18 +733,16 @@ let get_names env sign eqns =
(* We now replace the names y1 .. yn y by the actual names *)
(* xi1 .. xin xi to be found in the i-th clause of the matrix *)
-let set_declaration_name x (_,c,t) = (x,c,t)
-
-let recover_initial_subpattern_names = List.map2 set_declaration_name
+let recover_initial_subpattern_names = List.map2 set_name
let recover_and_adjust_alias_names names sign =
let rec aux = function
| [],[] ->
[]
- | x::names, (_,None,t)::sign ->
- (x,(alias_of_pat x,None,t)) :: aux (names,sign)
- | names, (na,(Some _ as c),t)::sign ->
- (PatVar (Loc.ghost,na),(na,c,t)) :: aux (names,sign)
+ | x::names, LocalAssum (_,t)::sign ->
+ (x, LocalAssum (alias_of_pat x,t)) :: aux (names,sign)
+ | names, (LocalDef (na,_,_) as decl)::sign ->
+ (PatVar (Loc.ghost,na), decl) :: aux (names,sign)
| _ -> assert false
in
List.split (aux (names,sign))
@@ -754,11 +757,12 @@ let push_rels_eqn_with_names sign eqn =
let sign = recover_initial_subpattern_names subpatnames sign in
push_rels_eqn sign eqn
-let push_generalized_decl_eqn env n (na,c,t) eqn =
- let na = match na with
- | Anonymous -> Anonymous
- | Name id -> pi1 (Environ.lookup_rel n eqn.rhs.rhs_env) in
- push_rels_eqn [(na,c,t)] eqn
+let push_generalized_decl_eqn env n decl eqn =
+ match get_name decl with
+ | Anonymous ->
+ push_rels_eqn [decl] eqn
+ | Name _ ->
+ push_rels_eqn [set_name (get_name (Environ.lookup_rel n eqn.rhs.rhs_env)) decl] eqn
let drop_alias_eqn eqn =
{ eqn with alias_stack = List.tl eqn.alias_stack }
@@ -766,7 +770,7 @@ let drop_alias_eqn eqn =
let push_alias_eqn alias eqn =
let aliasname = List.hd eqn.alias_stack in
let eqn = drop_alias_eqn eqn in
- let alias = set_declaration_name aliasname alias in
+ let alias = set_name aliasname alias in
push_rels_eqn [alias] eqn
(**********************************************************************)
@@ -837,10 +841,10 @@ let regeneralize_index_predicate n = map_predicate (relocate_index n 1) 0
let substnl_predicate sigma = map_predicate (substnl sigma)
(* This is parallel bindings *)
-let subst_predicate (args,copt) ccl tms =
+let subst_predicate (subst,copt) ccl tms =
let sigma = match copt with
- | None -> List.rev args
- | Some c -> c::(List.rev args) in
+ | None -> subst
+ | Some c -> c::subst in
substnl_predicate sigma 0 ccl tms
let specialize_predicate_var (cur,typ,dep) tms ccl =
@@ -921,7 +925,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl =
let tms = List.fold_right2 (fun par arg tomatch ->
match kind_of_term par with
| Rel i -> relocate_index_tomatch (i+n) (destRel arg) tomatch
- | _ -> tomatch) (realargs@[cur]) (extended_rel_list 0 sign)
+ | _ -> tomatch) (realargs@[cur]) (Context.Rel.to_extended_list 0 sign)
(lift_tomatch_stack n tms) in
(* Pred is already dependent in the current term to match (if *)
(* (na<>Anonymous) and its realargs; we just need to adjust it to *)
@@ -932,7 +936,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl =
in
let pred = extract_predicate ccl tms in
(* Build the predicate properly speaking *)
- let sign = List.map2 set_declaration_name (na::names) sign in
+ let sign = List.map2 set_name (na::names) sign in
it_mkLambda_or_LetIn_name env pred sign
(* [expand_arg] is used by [specialize_predicate]
@@ -1018,7 +1022,7 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl =
(* We prepare the substitution of X and x:I(X) *)
let realargsi =
if not (Int.equal nrealargs 0) then
- adjust_subst_to_rel_context arsign (Array.to_list cs.cs_concl_realargs)
+ subst_of_rel_context_instance arsign (Array.to_list cs.cs_concl_realargs)
else
[] in
let copti = match depna with
@@ -1118,14 +1122,14 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs =
let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with
| [], _ -> brs,tomatch,pred,[]
| n::deps, Abstract (i,d) :: tomatch ->
- let d = map_rel_declaration (nf_evar evd) d in
- let is_d = match d with (_, None, _) -> false | _ -> true in
+ let d = map_constr (nf_evar evd) d in
+ let is_d = match d with LocalAssum _ -> false | LocalDef _ -> true in
if is_d || List.exists (fun c -> dependent_decl (lift k c) d) tocheck
&& Array.exists (is_dependent_branch k) brs then
(* Dependency in the current term to match and its dependencies is real *)
let brs,tomatch,pred,inst = aux (k+1) brs tomatch pred (mkRel n::tocheck) deps in
let inst = match d with
- | (_, None, _) -> mkRel n :: inst
+ | LocalAssum _ -> mkRel n :: inst
| _ -> inst
in
brs, Abstract (i,d) :: tomatch, pred, inst
@@ -1187,12 +1191,13 @@ let group_equations pb ind current cstrs mat =
let rec generalize_problem names pb = function
| [] -> pb, []
| i::l ->
- let (na,b,t as d) = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
let pb',deps = generalize_problem names pb l in
- begin match (na, b) with
- | Anonymous, Some _ -> pb', deps
+ let d = map_constr (lift i) (Environ.lookup_rel i pb.env) in
+ begin match d with
+ | LocalDef (Anonymous,_,_) -> pb', deps
| _ ->
- let d = on_pi3 (whd_betaiota !(pb.evdref)) d in (* for better rendering *)
+ (* for better rendering *)
+ let d = map_type (whd_betaiota !(pb.evdref)) d in
let tomatch = lift_tomatch_stack 1 pb'.tomatch in
let tomatch = relocate_index_tomatch (i+1) 1 tomatch in
{ pb' with
@@ -1220,7 +1225,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
(* that had matched constructor C *)
let cs_args = const_info.cs_args in
let names,aliasname = get_names pb.env cs_args eqns in
- let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in
+ let typs = List.map2 set_name names cs_args
+ in
(* We build the matrix obtained by expanding the matching on *)
(* "C x1..xn as x" followed by a residual matching on eqn into *)
@@ -1230,7 +1236,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
(* We adjust the terms to match in the context they will be once the *)
(* context [x1:T1,..,xn:Tn] will have been pushed on the current env *)
let typs' =
- List.map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 typs in
+ List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 typs in
let extenv = push_rel_context typs pb.env in
@@ -1268,7 +1274,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
let typs' =
List.map2
- (fun (tm,(tmtyp,_),(na,_,_)) deps ->
+ (fun (tm, (tmtyp,_), decl) deps ->
+ let na = get_name decl in
let na = match curname, na with
| Name _, Anonymous -> curname
| Name _, Name _ -> na
@@ -1324,14 +1331,6 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
*)
-let mk_case pb (ci,pred,c,brs) =
- let mib = lookup_mind (fst ci.ci_ind) pb.env in
- match mib.mind_record with
- | Some (Some (_, cs, pbs)) ->
- Reduction.beta_appvect brs.(0)
- (Array.map (fun p -> mkProj (Projection.make p true, c)) cs)
- | _ -> mkCase (ci,pred,c,brs)
-
(**********************************************************************)
(* Main compiling descent *)
let rec compile pb =
@@ -1378,7 +1377,9 @@ and match_current pb (initial,tomatch) =
pred current indt (names,dep) tomatch in
let ci = make_case_info pb.env (fst mind) pb.casestyle in
let pred = nf_betaiota !(pb.evdref) pred in
- let case = mk_case pb (ci,pred,current,brvals) in
+ let case =
+ make_case_or_project pb.env indf ci pred current brvals
+ in
Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred;
{ uj_val = applist (case, inst);
uj_type = prod_applist typ inst }
@@ -1392,7 +1393,7 @@ and shift_problem ((current,t),_,na) pb =
let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in
let pb =
{ pb with
- env = push_rel (na,Some current,ty) pb.env;
+ env = push_rel (LocalDef (na,current,ty)) pb.env;
tomatch = tomatch;
pred = lift_predicate 1 pred tomatch;
history = pop_history pb.history;
@@ -1440,7 +1441,7 @@ and compile_generalization pb i d rest =
([false]). *)
and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest =
let f c t =
- let alias = (na,Some c,t) in
+ let alias = LocalDef (na,c,t) in
let pb =
{ pb with
env = push_rel alias pb.env;
@@ -1560,8 +1561,8 @@ let matx_of_eqns env eqns =
*)
let adjust_to_extended_env_and_remove_deps env extenv subst t =
- let n = rel_context_length (rel_context env) in
- let n' = rel_context_length (rel_context extenv) in
+ let n = Context.Rel.length (rel_context env) in
+ let n' = Context.Rel.length (rel_context extenv) in
(* We first remove the bindings that are dependently typed (they are
difficult to manage and it is not sure these are so useful in practice);
Notes:
@@ -1576,9 +1577,9 @@ let adjust_to_extended_env_and_remove_deps env extenv subst t =
(* \--------------extenv------------/ *)
let (p, _, _) = lookup_rel_id x (rel_context extenv) in
let rec traverse_local_defs p =
- match pi2 (lookup_rel p extenv) with
- | Some c -> assert (isRel c); traverse_local_defs (p + destRel c)
- | None -> p in
+ match lookup_rel p extenv with
+ | LocalDef (_,c,_) -> assert (isRel c); traverse_local_defs (p + destRel c)
+ | LocalAssum _ -> p in
let p = traverse_local_defs p in
let u = lift (n' - n) u in
try Some (p, u, expand_vars_in_term extenv u)
@@ -1623,7 +1624,7 @@ let abstract_tycon loc env evdref subst tycon extenv t =
convertible subterms of the substitution *)
let rec aux (k,env,subst as x) t =
let t = whd_evar !evdref t in match kind_of_term t with
- | Rel n when pi2 (lookup_rel n env) != None -> t
+ | Rel n when is_local_def (lookup_rel n env) -> t
| Evar ev ->
let ty = get_type_of env !evdref t in
let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in
@@ -1659,7 +1660,8 @@ let abstract_tycon loc env evdref subst tycon extenv t =
List.map (fun a -> not (isRel a) || dependent a u
|| Int.Set.mem (destRel a) depvl) inst in
let named_filter =
- List.map (fun (id,_,_) -> dependent (mkVar id) u)
+ let open Context.Named.Declaration in
+ List.map (fun d -> dependent (mkVar (get_id d)) u)
(named_context extenv) in
let filter = Filter.make (rel_filter @ named_filter) in
let candidates = u :: List.map mkRel vl in
@@ -1673,8 +1675,8 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t =
| None ->
(* This is the situation we are building a return predicate and
we are in an impossible branch *)
- let n = rel_context_length (rel_context env) in
- let n' = rel_context_length (rel_context tycon_env) in
+ let n = Context.Rel.length (rel_context env) in
+ let n' = Context.Rel.length (rel_context tycon_env) in
let impossible_case_type, u =
e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(loc,Evar_kinds.ImpossibleCase) in
(lift (n'-n) impossible_case_type, mkSort u)
@@ -1702,7 +1704,7 @@ let build_inversion_problem loc env sigma tms t =
let id = next_name_away (named_hd env t Anonymous) avoid in
PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in
let rec reveal_pattern t (subst,avoid as acc) =
- match kind_of_term (whd_betadeltaiota env sigma t) with
+ match kind_of_term (whd_all env sigma t) with
| Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc
| App (f,v) when isConstruct f ->
let cstr,u = destConstruct f in
@@ -1727,7 +1729,7 @@ let build_inversion_problem loc env sigma tms t =
List.rev_append patl patl',acc_sign,acc
| (t, NotInd (bo,typ)) :: tms ->
let pat,acc = make_patvar t acc in
- let d = (alias_of_pat pat,None,typ) in
+ let d = LocalAssum (alias_of_pat pat,typ) in
let patl,acc_sign,acc = aux (n+1) (push_rel d env) (d::acc_sign) tms acc in
pat::patl,acc_sign,acc in
let avoid0 = ids_of_context env in
@@ -1744,7 +1746,7 @@ let build_inversion_problem loc env sigma tms t =
let n = List.length sign in
let decls =
- List.map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 sign in
+ List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 sign in
let pb_env = push_rel_context sign env in
let decls =
@@ -1754,17 +1756,17 @@ let build_inversion_problem loc env sigma tms t =
let dep_sign = find_dependencies_signature (List.make n true) decls in
let sub_tms =
- List.map2 (fun deps (tm,(tmtyp,_),(na,b,t)) ->
- let na = if List.is_empty deps then Anonymous else force_name na in
+ List.map2 (fun deps (tm, (tmtyp,_), decl) ->
+ let na = if List.is_empty deps then Anonymous else force_name (get_name decl) in
Pushed (true,((tm,tmtyp),deps,na)))
dep_sign decls in
let subst = List.map (fun (na,t) -> (na,lift n t)) subst in
- (* [eqn1] is the first clause of the auxiliary pattern-matching that
+ (* [main_eqn] is the main clause of the auxiliary pattern-matching that
serves as skeleton for the return type: [patl] is the
substructure of constructors extracted from the list of
constraints on the inductive types of the multiple terms matched
in the original pattern-matching problem Xi *)
- let eqn1 =
+ let main_eqn =
{ patterns = patl;
alias_stack = [];
eqn_loc = Loc.ghost;
@@ -1775,36 +1777,37 @@ let build_inversion_problem loc env sigma tms t =
rhs_vars = List.map fst subst;
avoid_ids = avoid;
it = Some (lift n t) } } in
- (* [eqn2] is the default clause of the auxiliary pattern-matching: it will
- catch the clauses of the original pattern-matching problem Xi whose
- type constraints are incompatible with the constraints on the
+ (* [catch_all] is a catch-all default clause of the auxiliary
+ pattern-matching, if needed: it will catch the clauses
+ of the original pattern-matching problem Xi whose type
+ constraints are incompatible with the constraints on the
inductive types of the multiple terms matched in Xi *)
- let eqn2 =
- { patterns = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) patl;
- alias_stack = [];
- eqn_loc = Loc.ghost;
- used = ref false;
- rhs = { rhs_env = pb_env;
- rhs_vars = [];
- avoid_ids = avoid0;
- it = None } } in
+ let catch_all_eqn =
+ if List.for_all (irrefutable env) patl then
+ (* No need for a catch all clause *)
+ []
+ else
+ [ { patterns = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) patl;
+ alias_stack = [];
+ eqn_loc = Loc.ghost;
+ used = ref false;
+ rhs = { rhs_env = pb_env;
+ rhs_vars = [];
+ avoid_ids = avoid0;
+ it = None } } ] in
(* [pb] is the auxiliary pattern-matching serving as skeleton for the
return type of the original problem Xi *)
- (* let sigma, s = Evd.new_sort_variable sigma in *)
-(*FIXME TRY *)
- (* let sigma, s = Evd.new_sort_variable univ_flexible sigma in *)
let s' = Retyping.get_sort_of env sigma t in
let sigma, s = Evd.new_sort_variable univ_flexible_alg sigma in
let sigma = Evd.set_leq_sort env sigma s' s in
let evdref = ref sigma in
- (* let ty = evd_comb1 (refresh_universes false) evdref ty in *)
let pb =
{ env = pb_env;
evdref = evdref;
pred = (*ty *) mkSort s;
tomatch = sub_tms;
history = start_history n;
- mat = [eqn1;eqn2];
+ mat = main_eqn :: catch_all_eqn;
caseloc = loc;
casestyle = RegularStyle;
typing_function = build_tycon loc env pb_env s subst} in
@@ -1816,7 +1819,8 @@ let build_inversion_problem loc env sigma tms t =
let build_initial_predicate arsign pred =
let rec buildrec n pred tmnames = function
| [] -> List.rev tmnames,pred
- | ((na,c,t)::realdecls)::lnames ->
+ | (decl::realdecls)::lnames ->
+ let na = get_name decl in
let n' = n + List.length realdecls in
buildrec (n'+1) pred (force_name na::tmnames) lnames
| _ -> assert false
@@ -1828,7 +1832,9 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
match tm with
| NotInd (bo,typ) ->
(match t with
- | None -> [na,Option.map (lift n) bo,lift n typ]
+ | None -> (match bo with
+ | None -> [LocalAssum (na, lift n typ)]
+ | Some b -> [LocalDef (na, lift n b, lift n typ)])
| Some (loc,_,_) ->
user_err_loc (loc,"",
str"Unexpected type annotation for a term of non inductive type."))
@@ -1846,8 +1852,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
anomaly (Pp.str "Ill-formed 'in' clause in cases");
List.rev realnal
| None -> List.make nrealargs_ctxt Anonymous in
- (na,None,build_dependent_inductive env0 indf')
- ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in
+ LocalAssum (na, build_dependent_inductive env0 indf')
+ ::(List.map2 set_name realnal arsign) in
let rec buildrec n = function
| [],[] -> []
| (_,tm)::ltm, (_,x)::tmsign ->
@@ -1867,7 +1873,7 @@ let inh_conv_coerce_to_tycon loc env evdref j tycon =
(* We put the tycon inside the arity signature, possibly discovering dependencies. *)
let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c =
- let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in
+ let nar = List.fold_left (fun n sign -> Context.Rel.nhyps sign + n) 0 arsign in
let subst, len =
List.fold_right2 (fun (tm, tmtype) sign (subst, len) ->
let signlen = List.length sign in
@@ -1928,14 +1934,22 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c =
*)
let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
+ let refresh_tycon sigma t =
+ (** If we put the typing constraint in the term, it has to be
+ refreshed to preserve the invariant that no algebraic universe
+ can appear in the term. *)
+ refresh_universes ~status:Evd.univ_flexible ~onlyalg:true (Some true)
+ env sigma t
+ in
let preds =
match pred, tycon with
- (* No type annotation *)
+ (* No return clause *)
| None, Some t when not (noccur_with_meta 0 max_int t) ->
(* If the tycon is not closed w.r.t real variables, we try *)
(* two different strategies *)
- (* First strategy: we abstract the tycon wrt to the dependencies *)
- let p1 =
+ (* First strategy: we abstract the tycon wrt to the dependencies *)
+ let sigma, t = refresh_tycon sigma t in
+ let p1 =
prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in
(* Second strategy: we build an "inversion" predicate *)
let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in
@@ -1946,10 +1960,12 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
(* No dependent type constraint, or no constraints at all: *)
(* we use two strategies *)
let sigma,t = match tycon with
- | Some t -> sigma,t
+ | Some t -> refresh_tycon sigma t
| None ->
- let sigma, (t, _) =
+ let sigma = Sigma.Unsafe.of_evar_map sigma in
+ let Sigma ((t, _), sigma, _) =
new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in
+ let sigma = Sigma.to_evar_map sigma in
sigma, t
in
(* First strategy: we build an "inversion" predicate *)
@@ -1965,12 +1981,6 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
let evdref = ref sigma in
let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in
let sigma = !evdref in
- (* let sigma = Option.cata (fun tycon -> *)
- (* let na = Name (Id.of_string "x") in *)
- (* let tms = List.map (fun tm -> Pushed(tm,[],na)) tomatchs in *)
- (* let predinst = extract_predicate predcclj.uj_val tms in *)
- (* Coercion.inh_conv_coerce_to loc env !evdref predinst tycon) *)
- (* !evdref tycon in *)
let predccl = (j_nf_evar sigma predcclj).uj_val in
[sigma, predccl]
in
@@ -2016,7 +2026,9 @@ let mk_JMeq evdref typ x typ' y =
let mk_JMeq_refl evdref typ x =
papp evdref coq_JMeq_refl [| typ; x |]
-let hole = GHole (Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define true), Misctypes.IntroAnonymous, None)
+let hole =
+ GHole (Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false),
+ Misctypes.IntroAnonymous, None)
let constr_of_pat env evdref arsign pat avoid =
let rec typ env (ty, realargs) pat avoid =
@@ -2028,7 +2040,7 @@ let constr_of_pat env evdref arsign pat avoid =
let previd, id = prime avoid (Name (Id.of_string "wildcard")) in
Name id, id :: avoid
in
- (PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty,
+ (PatVar (l, name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty,
(List.map (fun x -> mkRel 1) realargs), 1, avoid)
| PatCstr (l,((_, i) as cstr),args,alias) ->
let cind = inductive_of_constructor cstr in
@@ -2045,7 +2057,8 @@ let constr_of_pat env evdref arsign pat avoid =
assert (Int.equal nb_args_constr (List.length args));
let patargs, args, sign, env, n, m, avoid =
List.fold_right2
- (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid) ->
+ (fun decl ua (patargs, args, sign, env, n, m, avoid) ->
+ let t = get_type decl in
let pat', sign', arg', typ', argtypargs, n', avoid =
let liftt = liftn (List.length sign) (succ (List.length args)) t in
typ env (substl args liftt, []) ua avoid
@@ -2067,7 +2080,7 @@ let constr_of_pat env evdref arsign pat avoid =
Anonymous ->
pat', sign, app, apptype, realargs, n, avoid
| Name id ->
- let sign = (alias, None, lift m ty) :: sign in
+ let sign = LocalAssum (alias, lift m ty) :: sign in
let avoid = id :: avoid in
let sign, i, avoid =
try
@@ -2079,14 +2092,14 @@ let constr_of_pat env evdref arsign pat avoid =
(lift 1 app) (* aliased term *)
in
let neq = eq_id avoid id in
- (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid
+ LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, neq :: avoid
with Reduction.NotConvertible -> sign, 1, avoid
in
(* Mark the equality as a hole *)
pat', sign, lift i app, lift i apptype, realargs, n + i, avoid
in
- let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in
- pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
+ let pat', sign, patc, patty, args, z, avoid = typ env (get_type (List.hd arsign), List.tl arsign) pat avoid in
+ pat', (sign, patc, (get_type (List.hd arsign), args), pat'), avoid
(* shadows functional version *)
@@ -2101,23 +2114,23 @@ match kind_of_term t with
| Rel 0 -> true
| _ -> false
-let rels_of_patsign l =
- List.map (fun ((na, b, t) as x) ->
- match b with
- | Some t' when is_topvar t' -> (na, None, t)
- | _ -> x) l
+let rels_of_patsign =
+ List.map (fun decl ->
+ match decl with
+ | LocalDef (na,t',t) when is_topvar t' -> LocalAssum (na,t)
+ | _ -> decl)
let vars_of_ctx ctx =
let _, y =
- List.fold_right (fun (na, b, t) (prev, vars) ->
- match b with
- | Some t' when is_topvar t' ->
+ List.fold_right (fun decl (prev, vars) ->
+ match decl with
+ | LocalDef (na,t',t) when is_topvar t' ->
prev,
(GApp (Loc.ghost,
(GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)),
[hole; GVar (Loc.ghost, prev)])) :: vars
| _ ->
- match na with
+ match get_name decl with
Anonymous -> invalid_arg "vars_of_ctx"
| Name n -> n, GVar (Loc.ghost, n) :: vars)
ctx (Id.of_string "vars_of_ctx_error", [])
@@ -2226,7 +2239,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
match ineqs with
| None -> [], arity
| Some ineqs ->
- [Anonymous, None, ineqs], lift 1 arity
+ [LocalAssum (Anonymous, ineqs)], lift 1 arity
in
let eqs_rels, arity = decompose_prod_n_assum neqs arity in
eqs_rels @ neqs_rels @ rhs_rels', arity
@@ -2237,7 +2250,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in
let _btype = evd_comb1 (Typing.type_of env) evdref bbody in
let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in
- let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in
+ let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in
let branch =
let bref = GVar (Loc.ghost, branch_name) in
match vars_of_ctx rhs_rels with
@@ -2286,7 +2299,7 @@ let abstract_tomatch env tomatchs tycon =
(fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in
let name = next_ident_away (Id.of_string "filtered_var") names in
(mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev,
- (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx,
+ LocalDef (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx,
name :: names, tycon)
([], [], [], tycon) tomatchs
in List.rev prev, ctx, tycon
@@ -2294,7 +2307,7 @@ let abstract_tomatch env tomatchs tycon =
let build_dependent_signature env evdref avoid tomatchs arsign =
let avoid = ref avoid in
let arsign = List.rev arsign in
- let allnames = List.rev_map (List.map pi1) arsign in
+ let allnames = List.rev_map (List.map get_name) arsign in
let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
let eqs, neqs, refls, slift, arsign' =
List.fold_left2
@@ -2310,11 +2323,15 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
(* Build the arity signature following the names in matched terms
as much as possible *)
let argsign = List.tl arsign in (* arguments in inverse application order *)
- let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *)
+ let app_decl = List.hd arsign in (* The matched argument *)
+ let appn = get_name app_decl in
+ let appt = get_type app_decl in
let argsign = List.rev argsign in (* arguments in application order *)
let env', nargeqs, argeqs, refl_args, slift, argsign' =
List.fold_left2
- (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) ->
+ (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg decl ->
+ let name = get_name decl in
+ let t = get_type decl in
let argt = Retyping.get_type_of env !evdref arg in
let eq, refl_arg =
if Reductionops.is_conv env !evdref argt t then
@@ -2332,16 +2349,16 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
let previd, id =
let name =
match kind_of_term arg with
- Rel n -> pi1 (lookup_rel n env)
+ Rel n -> get_name (lookup_rel n env)
| _ -> name
in
make_prime avoid name
in
(env, succ nargeqs,
- (Name (eq_id avoid previd), None, eq) :: argeqs,
+ (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs,
refl_arg :: refl_args,
pred slift,
- (Name id, b, t) :: argsign'))
+ set_name (Name id) decl :: argsign'))
(env, neqs, [], [], slift, []) args argsign
in
let eq = mk_JMeq evdref
@@ -2352,22 +2369,23 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
in
let refl_eq = mk_JMeq_refl evdref ty tm in
let previd, id = make_prime avoid appn in
- (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs,
+ ((LocalAssum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs,
succ nargeqs,
refl_eq :: refl_args,
pred slift,
- (((Name id, appb, appt) :: argsign') :: arsigns))
+ ((set_name (Name id) app_decl :: argsign') :: arsigns))
| _ -> (* Non dependent inductive or not inductive, just use a regular equality *)
- let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in
+ let decl = match arsign with [x] -> x | _ -> assert(false) in
+ let name = get_name decl in
let previd, id = make_prime avoid name in
- let arsign' = (Name id, b, typ) in
+ let arsign' = set_name (Name id) decl in
let tomatch_ty = type_of_tomatch ty in
let eq =
mk_eq evdref (lift nar tomatch_ty)
(mkRel slift) (lift nar tm)
in
- ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs,
+ ([LocalAssum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs,
(mk_eq_refl evdref tomatch_ty tm) :: refl_args,
pred slift, (arsign' :: []) :: arsigns))
([], 0, [], nar, []) tomatchs arsign
@@ -2412,7 +2430,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env
match tycon' with
| None -> let ev = mkExistential env evdref in ev, ev
| Some t ->
- let pred =
+ let pred =
match prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t with
| Some (evd, pred) -> evdref := evd; pred
| None ->
@@ -2441,7 +2459,9 @@ let compile_program_cases loc style (typing_function, evdref) tycon env
(* We push the initial terms to match and push their alias to rhs' envs *)
(* names of aliases will be recovered from patterns (hence Anonymous here) *)
- let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in
+ let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t)
+ | NotInd (Some b, t) -> LocalDef (na,b,t)
+ | IsInd (typ,_,_) -> LocalAssum (na,typ) in
let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in
let typs =
@@ -2489,11 +2509,11 @@ let compile_program_cases loc style (typing_function, evdref) tycon env
(* Main entry of the matching compilation *)
let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) =
- if predopt == None && Flags.is_program_mode () then
- compile_program_cases loc style (typing_fun, evdref)
+ if predopt == None && Flags.is_program_mode () && Program.is_program_cases () then
+ compile_program_cases loc style (typing_fun, evdref)
tycon env (predopt, tomatchl, eqns)
else
-
+
(* We build the matrix of patterns and right-hand side *)
let matx = matx_of_eqns env eqns in
@@ -2514,7 +2534,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
(* names of aliases will be recovered from patterns (hence Anonymous *)
(* here) *)
- let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in
+ let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t)
+ | NotInd (Some b,t) -> LocalDef (na,b,t)
+ | IsInd (typ,_,_) -> LocalAssum (na,typ) in
let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in
let typs =
@@ -2553,6 +2575,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
typing_function = typing_fun } in
let j = compile pb in
+
+ (* We coerce to the tycon (if an elim predicate was provided) *)
+ let j = inh_conv_coerce_to_tycon loc env myevdref j tycon in
evdref := !myevdref;
j in
@@ -2563,6 +2588,4 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
(* We check for unused patterns *)
List.iter (check_unused_pattern env) matx;
- (* We coerce to the tycon (if an elim predicate was provided) *)
- inh_conv_coerce_to_tycon loc env evdref j tycon
-
+ j
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index ab00aa16..ee4148de 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -8,7 +8,6 @@
open Names
open Term
-open Context
open Evd
open Environ
open Inductiveops
@@ -33,6 +32,8 @@ val error_wrong_numarg_constructor_loc : Loc.t -> env -> constructor -> int -> '
val error_wrong_numarg_inductive_loc : Loc.t -> env -> inductive -> int -> 'a
+val irrefutable : env -> cases_pattern -> bool
+
(** {6 Compilation primitive. } *)
val compile_cases :
@@ -45,11 +46,11 @@ val compile_cases :
val constr_of_pat :
Environ.env ->
Evd.evar_map ref ->
- rel_declaration list ->
+ Context.Rel.Declaration.t list ->
Glob_term.cases_pattern ->
Names.Id.t list ->
Glob_term.cases_pattern *
- (rel_declaration list * Term.constr *
+ (Context.Rel.Declaration.t list * Term.constr *
(Term.types * Term.constr list) * Glob_term.cases_pattern) *
Names.Id.t list
@@ -83,7 +84,7 @@ type tomatch_status =
| Pushed of (bool*((constr * tomatch_type) * int list * Name.t))
| Alias of (bool * (Name.t * constr * (constr * types)))
| NonDepAlias
- | Abstract of int * rel_declaration
+ | Abstract of int * Context.Rel.Declaration.t
type tomatch_stack = tomatch_status list
@@ -113,11 +114,11 @@ val compile : 'a pattern_matching_problem -> Environ.unsafe_judgment
val prepare_predicate : Loc.t ->
(Evarutil.type_constraint ->
- Environ.env -> Evd.evar_map ref -> 'a -> Environ.unsafe_judgment) ->
+ Environ.env -> Evd.evar_map ref -> glob_constr -> Environ.unsafe_judgment) ->
Environ.env ->
Evd.evar_map ->
(Term.types * tomatch_type) list ->
- Context.rel_context list ->
+ Context.Rel.t list ->
Constr.constr option ->
- 'a option -> (Evd.evar_map * Names.name list * Term.constr) list
-
+ glob_constr option ->
+ (Evd.evar_map * Names.name list * Term.constr) list
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
index 43062a0e..84bf849e 100644
--- a/pretyping/cbv.ml
+++ b/pretyping/cbv.ml
@@ -10,7 +10,7 @@ open Util
open Names
open Term
open Vars
-open Closure
+open CClosure
open Esubst
(**** Call by value reduction ****)
@@ -156,7 +156,7 @@ let strip_appl head stack =
(* Tests if fixpoint reduction is possible. *)
let fixp_reducible flgs ((reci,i),_) stk =
- if red_set flgs fIOTA then
+ if red_set flgs fFIX then
match stk with
| APP(appl,_) ->
Array.length appl > reci.(i) &&
@@ -168,7 +168,7 @@ let fixp_reducible flgs ((reci,i),_) stk =
false
let cofixp_reducible flgs _ stk =
- if red_set flgs fIOTA then
+ if red_set flgs fCOFIX then
match stk with
| (CASE _ | APP(_,CASE _)) -> true
| _ -> false
@@ -296,21 +296,21 @@ and cbv_stack_value info env = function
(* constructor in a Case -> IOTA *)
| (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,ci,env,stk)))
- when red_set (info_flags info) fIOTA ->
+ when red_set (info_flags info) fMATCH ->
let cargs =
Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in
cbv_stack_term info (stack_app cargs stk) env br.(n-1)
(* constructor of arity 0 in a Case -> IOTA *)
| (CONSTR(((_,n),u),[||]), CASE(_,br,_,env,stk))
- when red_set (info_flags info) fIOTA ->
+ when red_set (info_flags info) fMATCH ->
cbv_stack_term info stk env br.(n-1)
(* constructor in a Projection -> IOTA *)
| (CONSTR(((sp,n),u),[||]), APP(args,PROJ(p,pi,stk)))
- when red_set (info_flags info) fIOTA && Projection.unfolded p ->
+ when red_set (info_flags info) fMATCH && Projection.unfolded p ->
let arg = args.(pi.Declarations.proj_npars + pi.Declarations.proj_arg) in
- cbv_stack_value info env (arg, stk)
+ cbv_stack_value info env (strip_appl arg stk)
(* may be reduced later by application *)
| (FIXP(fix,env,[||]), APP(appl,TOP)) -> FIXP(fix,env,appl)
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
index de37d1fc..87a03abb 100644
--- a/pretyping/cbv.mli
+++ b/pretyping/cbv.mli
@@ -9,7 +9,7 @@
open Names
open Term
open Environ
-open Closure
+open CClosure
open Esubst
(***********************************************************************
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index ece92b66..4f265e76 100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Pp
open Flags
@@ -297,7 +297,7 @@ let lookup_path_to_sort_from env sigma s =
let get_coercion_constructor env coe =
let c, _ =
- Reductionops.whd_betadeltaiota_stack env Evd.empty coe.coe_value
+ Reductionops.whd_all_stack env Evd.empty coe.coe_value
in
match kind_of_term c with
| Construct (cstr,u) ->
@@ -387,7 +387,7 @@ let add_coercion_in_graph (ic,source,target) =
end;
let is_ambig = match !ambig_paths with [] -> false | _ -> true in
if is_ambig && is_verbose () then
- msg_warning (message_ambig !ambig_paths)
+ Feedback.msg_info (message_ambig !ambig_paths)
type coercion = {
coercion_type : coe_typ;
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index cf88be62..d509739c 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -26,6 +26,9 @@ val cl_typ_eq : cl_typ -> cl_typ -> bool
val subst_cl_typ : substitution -> cl_typ -> cl_typ
+(** Comparison of [cl_typ] *)
+val cl_typ_ord : cl_typ -> cl_typ -> int
+
(** This is the type of infos for declared classes *)
type cl_info_typ = {
cl_param : int }
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 489a311b..913e80f3 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -14,7 +14,7 @@
Corbineau, Feb 2008 *)
(* Turned into an abstract compilation unit by Matthieu Sozeau, March 2006 *)
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -63,7 +63,7 @@ let apply_coercion_args env evd check isproj argl funj =
{ uj_val = applist (j_val funj,argl);
uj_type = typ }
| h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *)
- match kind_of_term (whd_betadeltaiota env evd typ) with
+ match kind_of_term (whd_all env evd typ) with
| Prod (_,c1,c2) ->
if check && not (e_cumul env evdref (Retyping.get_type_of env evd h) c1) then
raise NoCoercion;
@@ -90,8 +90,9 @@ let inh_pattern_coerce_to loc env pat ind1 ind2 =
open Program
-let make_existential loc ?(opaque = Evar_kinds.Define true) env evdref c =
- Evarutil.e_new_evar env evdref ~src:(loc, Evar_kinds.QuestionMark opaque) c
+let make_existential loc ?(opaque = not (get_proofs_transparency ())) env evdref c =
+ let src = (loc, Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in
+ Evarutil.e_new_evar env evdref ~src c
let app_opt env evdref f t =
whd_betaiota !evdref (app_opt f t)
@@ -115,7 +116,7 @@ let disc_subset x =
exception NoSubtacCoercion
-let hnf env evd c = whd_betadeltaiota env evd c
+let hnf env evd c = whd_all env evd c
let hnf_nodelta env evd c = whd_betaiota evd c
let lift_args n sign =
@@ -129,7 +130,7 @@ let mu env evdref t =
let rec aux v =
let v' = hnf env !evdref v in
match disc_subset v' with
- Some (u, p) ->
+ | Some (u, p) ->
let f, ct = aux u in
let p = hnf_nodelta env !evdref p in
(Some (fun x ->
@@ -142,6 +143,7 @@ let mu env evdref t =
and coerce loc env evdref (x : Term.constr) (y : Term.constr)
: (Term.constr -> Term.constr) option
=
+ let open Context.Rel.Declaration in
let rec coerce_unify env x y =
let x = hnf env !evdref x and y = hnf env !evdref y in
try
@@ -151,8 +153,9 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
and coerce' env x y : (Term.constr -> Term.constr) option =
let subco () = subset_coerce env evdref x y in
let dest_prod c =
+ let open Context.Rel.Declaration in
match Reductionops.splay_prod_n env ( !evdref) 1 c with
- | [(na,b,t)], c -> (na,t), c
+ | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na,t), c
| _ -> raise NoSubtacCoercion
in
let coerce_application typ typ' c c' l l' =
@@ -187,9 +190,9 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
(subst1 hdy restT') (succ i) (fun x -> eq_app (co x))
else Some (fun x ->
let term = co x in
- Typing.solve_evars env evdref term)
+ Typing.e_solve_evars env evdref term)
in
- if isEvar c || isEvar c' then
+ if isEvar c || isEvar c' || not (Program.is_program_generalized_coercion ()) then
(* Second-order unification needed. *)
raise NoSubtacCoercion;
aux [] typ typ' 0 (fun x -> x)
@@ -205,7 +208,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
let name' =
Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.ids_of_context env))
in
- let env' = push_rel (name', None, a') env in
+ let env' = push_rel (LocalAssum (name', a')) env in
let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
(* env, x : a' |- c1 : lift 1 a' > lift 1 a *)
let coec1 = app_opt env' evdref c1 (mkRel 1) in
@@ -241,9 +244,8 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
let remove_head a c =
match kind_of_term c with
| Lambda (n, t, t') -> c, t'
- (*| Prod (n, t, t') -> t'*)
| Evar (k, args) ->
- let (evs, t) = Evarutil.define_evar_as_lambda env !evdref (k,args) in
+ let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k,args) in
evdref := evs;
let (n, dom, rng) = destLambda t in
let dom = whd_evar !evdref dom in
@@ -255,7 +257,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
| _ -> raise NoSubtacCoercion
in
let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in
- let env' = push_rel (Name Namegen.default_dependent_ident, None, a) env in
+ let env' = push_rel (LocalAssum (Name Namegen.default_dependent_ident, a)) env in
let c2 = coerce_unify env' b b' in
match c1, c2 with
| None, None -> None
@@ -278,7 +280,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
let c1 = coerce_unify env a a' in
let c2 = coerce_unify env b b' in
match c1, c2 with
- None, None -> None
+ | None, None -> None
| _, _ ->
Some
(fun x ->
@@ -297,9 +299,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
with NoSubtacCoercion ->
let typ = Typing.unsafe_type_of env evm c in
let typ' = Typing.unsafe_type_of env evm c' in
- (* if not (is_arity env evm typ) then *)
coerce_application typ typ' c c' l l')
- (* else subco () *)
else
subco ()
| x, y when Constr.equal c c' ->
@@ -307,9 +307,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
let evm = !evdref in
let lam_type = Typing.unsafe_type_of env evm c in
let lam_type' = Typing.unsafe_type_of env evm c' in
- (* if not (is_arity env evm lam_type) then ( *)
coerce_application lam_type lam_type' c c' l l'
- (* ) else subco () *)
else subco ()
| _ -> subco ())
| _, _ -> subco ()
@@ -335,10 +333,17 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
raise NoSubtacCoercion
in coerce_unify env x y
+let app_coercion env evdref coercion v =
+ match coercion with
+ | None -> v
+ | Some f ->
+ let v' = Typing.e_solve_evars env evdref (f v) in
+ whd_betaiota !evdref v'
+
let coerce_itf loc env evd v t c1 =
let evdref = ref evd in
let coercion = coerce loc env evdref t c1 in
- let t = Option.map (app_opt env evdref coercion) v in
+ let t = Option.map (app_coercion env evdref coercion) v in
!evdref, t
let saturate_evd env evd =
@@ -365,15 +370,15 @@ let apply_coercion env sigma p hj typ_cl =
(hj,typ_cl,sigma) p
in evd, j
with NoCoercion as e -> raise e
- | e when Errors.noncritical e -> anomaly (Pp.str "apply_coercion")
+ | e when CErrors.noncritical e -> anomaly (Pp.str "apply_coercion")
(* Try to coerce to a funclass; raise NoCoercion if not possible *)
let inh_app_fun_core env evd j =
- let t = whd_betadeltaiota env evd j.uj_type in
+ let t = whd_all env evd j.uj_type in
match kind_of_term t with
| Prod (_,_,_) -> (evd,j)
| Evar ev ->
- let (evd',t) = define_evar_as_product evd ev in
+ let (evd',t) = Evardefine.define_evar_as_product evd ev in
(evd',{ uj_val = j.uj_val; uj_type = t })
| _ ->
try let t,p =
@@ -410,11 +415,11 @@ let inh_tosort_force loc env evd j =
error_not_a_type_loc loc env evd j
let inh_coerce_to_sort loc env evd j =
- let typ = whd_betadeltaiota env evd j.uj_type in
+ let typ = whd_all env evd j.uj_type in
match kind_of_term typ with
| Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s })
| Evar ev when not (is_defined evd (fst ev)) ->
- let (evd',s) = define_evar_as_sort env evd ev in
+ let (evd',s) = Evardefine.define_evar_as_sort env evd ev in
(evd',{ utj_val = j.uj_val; utj_type = s })
| _ ->
inh_tosort_force loc env evd j
@@ -424,7 +429,7 @@ let inh_coerce_to_base loc env evd j =
let evdref = ref evd in
let ct, typ' = mu env evdref j.uj_type in
let res =
- { uj_val = app_opt env evdref ct j.uj_val;
+ { uj_val = app_coercion env evdref ct j.uj_val;
uj_type = typ' }
in !evdref, res
else (evd, j)
@@ -462,8 +467,8 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
try inh_coerce_to_fail env evd rigidonly v t c1
with NoCoercion ->
match
- kind_of_term (whd_betadeltaiota env evd t),
- kind_of_term (whd_betadeltaiota env evd c1)
+ kind_of_term (whd_all env evd t),
+ kind_of_term (whd_all env evd c1)
with
| Prod (name,t1,t2), Prod (_,u1,u2) ->
(* Conversion did not work, we may succeed with a coercion. *)
@@ -475,7 +480,8 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
let name = match name with
| Anonymous -> Name Namegen.default_dependent_ident
| _ -> name in
- let env1 = push_rel (name,None,u1) env in
+ let open Context.Rel.Declaration in
+ let env1 = push_rel (LocalAssum (name,u1)) env in
let (evd', v1) =
inh_conv_coerce_to_fail loc env1 evd rigidonly
(Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in
@@ -508,7 +514,7 @@ let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t =
error_actual_type_loc loc env best_failed_evd cj t e
else
inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t
- with NoCoercionNoUnifier (best_failed_evd,e) ->
+ with NoCoercionNoUnifier (_evd,_error) ->
error_actual_type_loc loc env best_failed_evd cj t e
in
let val' = match val' with Some v -> v | None -> assert(false) in
diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index ee3c43d8..886a9826 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -8,7 +8,7 @@
(*i*)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Globnames
@@ -17,10 +17,10 @@ open Termops
open Reductionops
open Term
open Vars
-open Context
open Pattern
open Patternops
open Misctypes
+open Context.Rel.Declaration
(*i*)
(* Given a term with second-order variables in it,
@@ -49,12 +49,12 @@ type bound_ident_map = Id.t Id.Map.t
exception PatternMatchingFailure
-let warn_bound_meta name =
- msg_warning (str "Collision between bound variable " ++ pr_id name ++
- str " and a metavariable of same name.")
+let warn_meta_collision =
+ CWarnings.create ~name:"meta-collision" ~category:"ltac"
+ (fun name ->
+ strbrk "Collision between bound variable " ++ pr_id name ++
+ strbrk " and a metavariable of same name.")
-let warn_bound_bound name =
- msg_warning (str "Collision between bound variables of name " ++ pr_id name)
let constrain n (ids, m as x) (names, terms as subst) =
try
@@ -62,18 +62,19 @@ let constrain n (ids, m as x) (names, terms as subst) =
if List.equal Id.equal ids ids' && eq_constr m m' then subst
else raise PatternMatchingFailure
with Not_found ->
- let () = if Id.Map.mem n names then warn_bound_meta n in
+ let () = if Id.Map.mem n names then warn_meta_collision n in
(names, Id.Map.add n x terms)
let add_binders na1 na2 binding_vars (names, terms as subst) =
match na1, na2 with
| Name id1, Name id2 when Id.Set.mem id1 binding_vars ->
if Id.Map.mem id1 names then
- let () = warn_bound_bound id1 in
+ let () = Glob_ops.warn_variable_collision id1 in
(names, terms)
else
let names = Id.Map.add id1 id2 names in
- let () = if Id.Map.mem id1 terms then warn_bound_meta id1 in
+ let () = if Id.Map.mem id1 terms then
+ warn_meta_collision id1 in
(names, terms)
| _ -> subst
@@ -255,24 +256,24 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels
sorec ctx env subst c1 c2
| PProd (na1,c1,d1), Prod(na2,c2,d2) ->
- sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env)
+ sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,c2)) env)
(add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
| PLambda (na1,c1,d1), Lambda(na2,c2,d2) ->
- sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env)
+ sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,c2)) env)
(add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
| PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) ->
- sorec ((na1,na2,t2)::ctx) (Environ.push_rel (na2,Some c2,t2) env)
+ sorec ((na1,na2,t2)::ctx) (Environ.push_rel (LocalDef (na2,c2,t2)) env)
(add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
| PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
let ctx_b2,b2 = decompose_lam_n_decls ci.ci_cstr_ndecls.(0) b2 in
let ctx_b2',b2' = decompose_lam_n_decls ci.ci_cstr_ndecls.(1) b2' in
- let n = rel_context_length ctx_b2 in
- let n' = rel_context_length ctx_b2' in
+ let n = Context.Rel.length ctx_b2 in
+ let n' = Context.Rel.length ctx_b2' in
if noccur_between 1 n b2 && noccur_between 1 n' b2' then
- let f l (na,_,t) = (Anonymous,na,t)::l in
+ let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = (Anonymous,na,t)::l in
let ctx_br = List.fold_left f ctx ctx_b2 in
let ctx_br' = List.fold_left f ctx ctx_b2' in
let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in
@@ -368,21 +369,21 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
| [c1; c2] -> mk_ctx (mkLambda (x, c1, c2))
| _ -> assert false
in
- let env' = Environ.push_rel (x,None,c1) env in
+ let env' = Environ.push_rel (LocalAssum (x,c1)) env in
try_aux [(env, c1); (env', c2)] next_mk_ctx next
| Prod (x,c1,c2) ->
let next_mk_ctx = function
| [c1; c2] -> mk_ctx (mkProd (x, c1, c2))
| _ -> assert false
in
- let env' = Environ.push_rel (x,None,c1) env in
+ let env' = Environ.push_rel (LocalAssum (x,c1)) env in
try_aux [(env, c1); (env', c2)] next_mk_ctx next
| LetIn (x,c1,t,c2) ->
let next_mk_ctx = function
| [c1; c2] -> mk_ctx (mkLetIn (x, c1, t, c2))
| _ -> assert false
in
- let env' = Environ.push_rel (x,Some c1,t) env in
+ let env' = Environ.push_rel (LocalDef (x,c1,t)) env in
try_aux [(env, c1); (env', c2)] next_mk_ctx next
| App (c1,lc) ->
let topdown = true in
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index c3877c56..85125a50 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -7,12 +7,11 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Term
open Vars
-open Context
open Inductiveops
open Environ
open Glob_term
@@ -25,6 +24,7 @@ open Nametab
open Mod_subst
open Misctypes
open Decl_kinds
+open Context.Named.Declaration
let dl = Loc.ghost
@@ -34,8 +34,15 @@ let print_universes = Flags.univ_print
(** If true, prints local context of evars, whatever print_arguments *)
let print_evar_arguments = ref false
-let add_name na b t (nenv, env) = add_name na nenv, push_rel (na, b, t) env
-let add_name_opt na b t (nenv, env) =
+let add_name na b t (nenv, env) =
+ let open Context.Rel.Declaration in
+ add_name na nenv, push_rel (match b with
+ | None -> LocalAssum (na,t)
+ | Some b -> LocalDef (na,b,t)
+ )
+ env
+
+let add_name_opt na b t (nenv, env) =
match t with
| None -> Termops.add_name na nenv, env
| Some t -> add_name na b t (nenv, env)
@@ -199,7 +206,7 @@ let computable p k =
engendrera un prédicat non dépendant) *)
let sign,ccl = decompose_lam_assum p in
- Int.equal (rel_context_length sign) (k + 1)
+ Int.equal (Context.Rel.length sign) (k + 1)
&&
noccur_between 1 (k+1) ccl
@@ -315,8 +322,8 @@ let is_nondep_branch c l =
try
(* FIXME: do better using tags from l *)
let sign,ccl = decompose_lam_n_decls (List.length l) c in
- noccur_between 1 (rel_context_length sign) ccl
- with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *)
+ noccur_between 1 (Context.Rel.length sign) ccl
+ with e when CErrors.noncritical e -> (* Not eta-expanded or not reduced *)
false
let extract_nondep_branches test c b l =
@@ -511,14 +518,20 @@ let rec detype flags avoid env sigma t =
else noparams ()
| Evar (evk,cl) ->
- let bound_to_itself_or_letin (id,b,_) c =
- b != None ||
- try let n = List.index Name.equal (Name id) (fst env) in
- isRelN n c
- with Not_found -> isVarId id c in
+ let bound_to_itself_or_letin decl c =
+ match decl with
+ | LocalDef _ -> true
+ | LocalAssum (id,_) ->
+ try let n = List.index Name.equal (Name id) (fst env) in
+ isRelN n c
+ with Not_found -> isVarId id c
+ in
let id,l =
try
- let id = Evd.evar_ident evk sigma in
+ let id = match Evd.evar_ident evk sigma with
+ | None -> Evd.pr_evar_suggested_name evk sigma
+ | Some id -> id
+ in
let l = Evd.evar_instance_array bound_to_itself_or_letin (Evd.find sigma evk) cl in
let fvs,rels = List.fold_left (fun (fvs,rels) (_,c) -> match kind_of_term c with Rel n -> (fvs,Int.Set.add n rels) | Var id -> (Id.Set.add id fvs,rels) | _ -> (fvs,rels)) (Id.Set.empty,Int.Set.empty) l in
let l = Evd.evar_instance_array (fun d c -> not !print_evar_arguments && (bound_to_itself_or_letin d c && not (isRel c && Int.Set.mem (destRel c) rels || isVar c && (Id.Set.mem (destVar c) fvs)))) (Evd.find sigma evk) cl in
@@ -607,7 +620,7 @@ and share_names flags n l avoid env sigma c t =
share_names flags (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c'
(* If built with the f/n notation: we renounce to share names *)
| _ ->
- if n>0 then msg_warning (strbrk "Detyping.detype: cannot factorize fix enough");
+ if n>0 then Feedback.msg_debug (strbrk "Detyping.detype: cannot factorize fix enough");
let c = detype flags avoid env sigma c in
let t = detype flags avoid env sigma t in
(List.rev l,c,t)
@@ -618,7 +631,7 @@ and detype_eqns flags avoid env sigma ci computable constructs consnargsl bl =
let mat = build_tree Anonymous (snd flags) (avoid,env) ci bl in
List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype flags avoid env sigma c))
mat
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
Array.to_list
(Array.map3 (detype_eqn flags avoid env sigma) constructs consnargsl bl)
@@ -673,23 +686,36 @@ and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c =
match bk with
| BProd -> GProd (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r)
| BLambda -> GLambda (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r)
- | BLetIn -> GLetIn (dl, na',detype (lax,false) avoid env sigma (Option.get body), r)
+ | BLetIn ->
+ let c = detype (lax,false) avoid env sigma (Option.get body) in
+ (* Heuristic: we display the type if in Prop *)
+ let s = try Retyping.get_sort_family_of (snd env) sigma ty with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in
+ let c = if s != InProp then c else
+ GCast (dl, c, CastConv (detype (lax,false) avoid env sigma ty)) in
+ GLetIn (dl, na', c, r)
let detype_rel_context ?(lax=false) where avoid env sigma sign =
let where = Option.map (fun c -> it_mkLambda_or_LetIn c sign) where in
let rec aux avoid env = function
| [] -> []
- | (na,b,t)::rest ->
+ | decl::rest ->
+ let open Context.Rel.Declaration in
+ let na = get_name decl in
+ let t = get_type decl in
let na',avoid' =
match where with
| None -> na,avoid
| Some c ->
- if b != None then
+ if is_local_def decl then
compute_displayed_let_name_in
(RenamingElsewhereFor (fst env,c)) avoid na c
else
compute_displayed_name_in
(RenamingElsewhereFor (fst env,c)) avoid na c in
+ let b = match decl with
+ | LocalAssum _ -> None
+ | LocalDef (_,b,_) -> Some b
+ in
let b' = Option.map (detype (lax,false) avoid env sigma) b in
let t' = detype (lax,false) avoid env sigma t in
(na',Explicit,b',t') :: aux avoid' (add_name na' b t env) rest
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index 838588dc..c51cb0f4 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -8,7 +8,6 @@
open Names
open Term
-open Context
open Environ
open Glob_term
open Termops
@@ -46,7 +45,7 @@ val detype_case :
val detype_sort : evar_map -> sorts -> glob_sort
val detype_rel_context : ?lax:bool -> constr option -> Id.t list -> (names_context * env) ->
- evar_map -> rel_context -> glob_decl list
+ evar_map -> Context.Rel.t -> glob_decl list
val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> closed_glob_constr -> glob_constr
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 637a9e50..9fd55a48 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -6,22 +6,25 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Term
open Vars
-open Closure
+open CClosure
open Reduction
open Reductionops
open Termops
open Environ
open Recordops
open Evarutil
+open Evardefine
open Evarsolve
open Globnames
open Evd
open Pretype_errors
+open Sigma.Notations
+open Context.Rel.Declaration
type unify_fun = transparent_state ->
env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result
@@ -39,12 +42,7 @@ let _ = Goptions.declare_bool_option {
let unfold_projection env evd ts p c =
let cst = Projection.constant p in
if is_transparent_constant ts cst then
- let c' = Some (mkProj (Projection.make cst true, c)) in
- match ReductionBehaviour.get (Globnames.ConstRef cst) with
- | None -> c'
- | Some (recargs, nargs, flags) ->
- if (List.mem `ReductionNeverUnfold flags) then None
- else c'
+ Some (mkProj (Projection.make cst true, c))
else None
let eval_flexible_term ts env evd c =
@@ -54,12 +52,15 @@ let eval_flexible_term ts env evd c =
then constant_opt_value_in env cu
else None
| Rel n ->
- (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v
- with Not_found -> None)
+ (try match lookup_rel n env with
+ | LocalAssum _ -> None
+ | LocalDef (_,v,_) -> Some (lift n v)
+ with Not_found -> None)
| Var id ->
(try
if is_transparent_variable ts id then
- let (_,v,_) = lookup_named id env in v
+ let open Context.Named.Declaration in
+ lookup_named id env |> get_value
else None
with Not_found -> None)
| LetIn (_,b,_,c) -> Some (subst1 b c)
@@ -96,21 +97,20 @@ let position_problem l2r = function
| CONV -> None
| CUMUL -> Some l2r
-let occur_rigidly ev evd t =
- let (l, app) = decompose_app_vect t in
- let rec aux t =
+let occur_rigidly (evk,_ as ev) evd t =
+ let rec aux t =
match kind_of_term (whd_evar evd t) with
| App (f, c) -> if aux f then Array.exists aux c else false
| Construct _ | Ind _ | Sort _ | Meta _ | Fix _ | CoFix _ -> true
| Proj (p, c) -> not (aux c)
- | Evar (ev',_) -> if Evar.equal ev ev' then raise Occur else false
+ | Evar (evk',_) -> if Evar.equal evk evk' then raise Occur else false
| Cast (p, _, _) -> aux p
| Lambda _ | LetIn _ -> false
| Const _ -> false
| Prod (_, b, t) -> ignore(aux b || aux t); true
| Rel _ | Var _ -> false
- | Case _ -> false
- in Array.exists (fun t -> try ignore(aux t); false with Occur -> true) app
+ | Case (_,_,c,_) -> if eq_constr (mkEvar ev) c then raise Occur else false
+ in try ignore(aux t); false with Occur -> true
(* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose
the problem (t1 stack1) = (t2 stack2) into a problem
@@ -138,6 +138,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) =
try
match kind_of_term t2 with
Prod (_,a,b) -> (* assert (l2=[]); *)
+ let _, a, b = destProd (Evarutil.nf_evar sigma t2) in
if dependent (mkRel 1) b then raise Not_found
else lookup_canonical_conversion (proji, Prod_cs),
(Stack.append_app [|a;pop b|] Stack.empty)
@@ -308,7 +309,7 @@ let exact_ise_stack2 env evd f sk1 sk2 =
if Reductionops.Stack.compare_shape sk1 sk2 then
ise_stack2 evd (List.rev sk1) (List.rev sk2)
else UnifFailure (evd, (* Dummy *) NotSameHead)
-
+
let rec evar_conv_x ts env evd pbty term1 term2 =
let term1 = whd_head_evar evd term1 in
let term2 = whd_head_evar evd term2 in
@@ -317,25 +318,22 @@ let rec evar_conv_x ts env evd pbty term1 term2 =
Note: incomplete heuristic... *)
let ground_test =
if is_ground_term evd term1 && is_ground_term evd term2 then (
- let evd, e =
+ let e =
try
let evd, b = infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts)
env evd term1 term2
in
- if b then evd, None
- else evd, Some (ConversionFailed (env,term1,term2))
- with Univ.UniverseInconsistency e -> evd, Some (UnifUnivInconsistency e)
+ if b then Success evd
+ else UnifFailure (evd, ConversionFailed (env,term1,term2))
+ with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e)
in
match e with
- | None -> Some (evd, e)
- | Some e ->
- if is_ground_env evd env then Some (evd, Some e)
- else None)
+ | UnifFailure (evd, e) when not (is_ground_env evd env) -> None
+ | _ -> Some e)
else None
in
match ground_test with
- | Some (evd, None) -> Success evd
- | Some (evd, Some e) -> UnifFailure (evd,e)
+ | Some result -> result
| None ->
(* Until pattern-unification is used consistently, use nohdbeta to not
destroy beta-redexes that can be used for 1st-order unification *)
@@ -364,8 +362,6 @@ let rec evar_conv_x ts env evd pbty term1 term2 =
and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
((term1,sk1 as appr1),csts1) ((term2,sk2 as appr2),csts2) =
- let default_fail i = (* costly *)
- UnifFailure (i,ConversionFailed (env, Stack.zip appr1, Stack.zip appr2)) in
let quick_fail i = (* not costly, loses info *)
UnifFailure (i, NotSameHead)
in
@@ -393,7 +389,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
assert (match sk with [] -> true | _ -> false);
let (na,c1,c'1) = destLambda term in
let c = nf_evar evd c1 in
- let env' = push_rel (na,None,c) env in
+ let env' = push_rel (LocalAssum (na,c)) env in
let out1 = whd_betaiota_deltazeta_for_iota_state
(fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in
let out2 = whd_nored_state evd
@@ -417,7 +413,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
let not_only_app = Stack.not_purely_applicative skM in
let f1 i =
match Stack.list_of_app_stack skF with
- | None -> default_fail evd
+ | None -> quick_fail evd
| Some lF ->
let tM = Stack.zip apprM in
miller_pfenning on_left
@@ -431,7 +427,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
else quick_fail i
and delta i =
switch (evar_eqappr_x ts env i pbty) (apprF,cstsF)
- (whd_betaiota_deltazeta_for_iota_state (fst ts) env i cstsM (vM,skM))
+ (whd_betaiota_deltazeta_for_iota_state
+ (fst ts) env i cstsM (vM,skM))
in
let default i = ise_try i [f1; consume apprF apprM; delta]
in
@@ -448,7 +445,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
try
let termM' = Retyping.expand_projection env evd p c [] in
let apprM', cstsM' =
- whd_betaiota_deltazeta_for_iota_state (fst ts) env evd cstsM (termM',skM)
+ whd_betaiota_deltazeta_for_iota_state
+ (fst ts) env evd cstsM (termM',skM)
in
let delta' i =
switch (evar_eqappr_x ts env i pbty) (apprF,cstsF) (apprM',cstsM')
@@ -464,10 +462,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
let flex_rigid on_left ev (termF, skF as apprF) (termR, skR as apprR) =
let switch f a b = if on_left then f a b else f b a in
let eta evd =
- match kind_of_term termR with
- | Lambda _ -> eta env evd false skR termR skF termF
- | Construct u -> eta_constructor ts env evd skR u skF termF
- | _ -> UnifFailure (evd,NotSameHead)
+ match kind_of_term termR with
+ | Lambda _ when (* if ever problem is ill-typed: *) List.is_empty skR ->
+ eta env evd false skR termR skF termF
+ | Construct u -> eta_constructor ts env evd skR u skF termF
+ | _ -> UnifFailure (evd,NotSameHead)
in
match Stack.list_of_app_stack skF with
| None ->
@@ -479,7 +478,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
ise_try evd
[eta;(* Postpone the use of an heuristic *)
(fun i ->
- if not (occur_rigidly (fst ev) i tR) then
+ if not (occur_rigidly ev i tR) then
let i,tF =
if isRel tR || isVar tR then
(* Optimization so as to generate candidates *)
@@ -497,15 +496,18 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
(* Evar must be undefined since we have flushed evars *)
let () = if !debug_unification then
let open Pp in
- pp (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ())
+ Feedback.msg_notice (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ())
++ fnl ()) in
match (flex_kind_of_term (fst ts) env evd term1 sk1,
flex_kind_of_term (fst ts) env evd term2 sk2) with
| Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) ->
+ (* sk1[?ev1] =? sk2[?ev2] *)
let f1 i =
+ (* Try first-order unification *)
match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with
- |None, Success i' ->
- (* Evar can be defined in i' *)
+ | None, Success i' ->
+ (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *)
+ (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *)
let ev1' = whd_evar i' (mkEvar ev1) in
if isEvar ev1' then
solve_simple_eqn (evar_conv_x ts) env i'
@@ -513,7 +515,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
else
evar_eqappr_x ts env evd pbty
((ev1', sk1), csts1) ((term2, sk2), csts2)
- |Some (r,[]), Success i' ->
+ | Some (r,[]), Success i' ->
+ (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *)
+ (* we now unify r[?ev1] and ?ev2 *)
let ev2' = whd_evar i' (mkEvar ev2) in
if isEvar ev2' then
solve_simple_eqn (evar_conv_x ts) env i'
@@ -521,16 +525,46 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
else
evar_eqappr_x ts env evd pbty
((ev2', sk1), csts1) ((term2, sk2), csts2)
-
- |Some ([],r), Success i' ->
+ | Some ([],r), Success i' ->
+ (* Symmetrically *)
+ (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *)
+ (* we now unify ?ev1 and r[?ev2] *)
let ev1' = whd_evar i' (mkEvar ev1) in
if isEvar ev1' then
solve_simple_eqn (evar_conv_x ts) env i'
(position_problem true pbty,destEvar ev1',Stack.zip(term2,r))
else evar_eqappr_x ts env evd pbty
((ev1', sk1), csts1) ((term2, sk2), csts2)
- |_, (UnifFailure _ as x) -> x
- |Some _, _ -> UnifFailure (i,NotSameArgSize)
+ | None, (UnifFailure _ as x) ->
+ (* sk1 and sk2 have no common outer part *)
+ if Stack.not_purely_applicative sk2 then
+ (* Ad hoc compatibility with 8.4 which treated non-app as rigid *)
+ flex_rigid true ev1 appr1 appr2
+ else
+ if Stack.not_purely_applicative sk1 then
+ (* Ad hoc compatibility with 8.4 which treated non-app as rigid *)
+ flex_rigid false ev2 appr2 appr1
+ else
+ (* We could instead try Miller unification, then
+ postpone to see if other equations help, as in:
+ [Check fun a b : unit => (eqáµ£efl : _ a = _ a b)] *)
+ x
+ | Some _, Success _ ->
+ (* sk1 and sk2 have a common outer part *)
+ if Stack.not_purely_applicative sk2 then
+ (* Ad hoc compatibility with 8.4 which treated non-app as rigid *)
+ flex_rigid true ev1 appr1 appr2
+ else
+ if Stack.not_purely_applicative sk1 then
+ (* Ad hoc compatibility with 8.4 which treated non-app as rigid *)
+ flex_rigid false ev2 appr2 appr1
+ else
+ (* We could instead try Miller unification, then
+ postpone to see if other equations help, as in:
+ [Check fun a b c : unit => (eqáµ£efl : _ a b = _ c a b)] *)
+ UnifFailure (i,NotSameArgSize)
+ | _, _ -> anomaly (Pp.str "Unexpected result from ise_stack2.")
+
and f2 i =
if Evar.equal sp1 sp2 then
match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with
@@ -553,14 +587,17 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
| MaybeFlexible v1, MaybeFlexible v2 -> begin
match kind_of_term term1, kind_of_term term2 with
| LetIn (na1,b1,t1,c'1), LetIn (na2,b2,t2,c'2) ->
- let f1 i =
+ let f1 i = (* FO *)
ise_and i
- [(fun i -> evar_conv_x ts env i CONV b1 b2);
+ [(fun i -> ise_try i
+ [(fun i -> evar_conv_x ts env i CUMUL t1 t2);
+ (fun i -> evar_conv_x ts env i CUMUL t2 t1)]);
+ (fun i -> evar_conv_x ts env i CONV b1 b2);
(fun i ->
let b = nf_evar i b1 in
let t = nf_evar i t1 in
let na = Nameops.name_max na1 na2 in
- evar_conv_x ts (push_rel (na,Some b,t) env) i pbty c'1 c'2);
+ evar_conv_x ts (push_rel (LocalDef (na,b,t)) env) i pbty c'1 c'2);
(fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)]
and f2 i =
let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1)
@@ -675,7 +712,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
(fun i ->
let c = nf_evar i c1 in
let na = Nameops.name_max na1 na2 in
- evar_conv_x ts (push_rel (na,None,c) env) i CONV c'1 c'2)]
+ evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i CONV c'1 c'2)]
| Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2
| Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1
@@ -708,10 +745,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
ise_try evd [f3; f4]
(* Eta-expansion *)
- | Rigid, _ when isLambda term1 ->
+ | Rigid, _ when isLambda term1 && (* if ever ill-typed: *) List.is_empty sk1 ->
eta env evd true sk1 term1 sk2 term2
- | _, Rigid when isLambda term2 ->
+ | _, Rigid when isLambda term2 && (* if ever ill-typed: *) List.is_empty sk2 ->
eta env evd false sk2 term2 sk1 term1
| Rigid, Rigid -> begin
@@ -726,7 +763,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
in Success evd'
with Univ.UniverseInconsistency p ->
UnifFailure (evd,UnifUnivInconsistency p)
- | e when Errors.noncritical e -> UnifFailure (evd,NotSameHead))
+ | e when CErrors.noncritical e -> UnifFailure (evd,NotSameHead))
| Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty ->
ise_and evd
@@ -734,7 +771,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
(fun i ->
let c = nf_evar i c1 in
let na = Nameops.name_max n1 n2 in
- evar_conv_x ts (push_rel (na,None,c) env) i pbty c'1 c'2)]
+ evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i pbty c'1 c'2)]
| Rel x1, Rel x2 ->
if Int.equal x1 x2 then
@@ -830,7 +867,9 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2)
(i,t2::ks, m-1, test)
else
let dloc = (Loc.ghost,Evar_kinds.InternalHole) in
- let (i',ev) = new_evar env i ~src:dloc (substl ks b) in
+ let i = Sigma.Unsafe.of_evar_map i in
+ let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in
+ let i' = Sigma.to_evar_map i' in
(i', ev :: ks, m - 1,test))
(evd,[],List.length bs,fun i -> Success i) bs
in
@@ -854,7 +893,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2)
and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 =
let mib = lookup_mind (fst ind) env in
match mib.Declarations.mind_record with
- | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite ->
+ | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite ->
let pars = mib.Declarations.mind_nparams in
(try
let l1' = Stack.tail pars sk1 in
@@ -909,6 +948,7 @@ let choose_less_dependent_instance evk evd term args =
| [] -> None
| (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd)
+open Context.Named.Declaration
let apply_on_subterm env evdref f c t =
let rec applyrec (env,(k,c) as acc) t =
(* By using eq_constr, we make an approximation, for instance, we *)
@@ -919,7 +959,7 @@ let apply_on_subterm env evdref f c t =
match kind_of_term t with
| Evar (evk,args) when Evd.is_undefined !evdref evk ->
let ctx = evar_filtered_context (Evd.find_undefined !evdref evk) in
- let g (_,b,_) a = if Option.is_empty b then applyrec acc a else a in
+ let g decl a = if is_local_assum decl then applyrec acc a else a in
mkEvar (evk, Array.of_list (List.map2 g ctx (Array.to_list args)))
| _ ->
map_constr_with_binders_left_to_right
@@ -936,17 +976,17 @@ let filter_possible_projections c ty ctxt args =
let fv2 = collect_vars (mkApp (c,args)) in
let len = Array.length args in
let tyvars = collect_vars ty in
- List.map_i (fun i (id,b,_) ->
+ List.map_i (fun i decl ->
let () = assert (i < len) in
let a = Array.unsafe_get args i in
- (match b with None -> false | Some c -> not (isRel c || isVar c)) ||
+ (match decl with LocalAssum _ -> false | LocalDef (_,c,_) -> not (isRel c || isVar c)) ||
a == c ||
(* Here we make an approximation, for instance, we could also be *)
(* interested in finding a term u convertible to c such that a occurs *)
(* in u *)
isRel a && Int.Set.mem (destRel a) fv1 ||
isVar a && Id.Set.mem (destVar a) fv2 ||
- Id.Set.mem id tyvars)
+ Id.Set.mem (get_id decl) tyvars)
0 ctxt
let solve_evars = ref (fun _ -> failwith "solve_evars not installed")
@@ -977,17 +1017,18 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
let env_evar = evar_filtered_env evi in
let sign = named_context_val env_evar in
let ctxt = evar_filtered_context evi in
- let instance = List.map mkVar (List.map pi1 ctxt) in
+ let instance = List.map mkVar (List.map get_id ctxt) in
let rec make_subst = function
- | (id,_,t)::ctxt', c::l, occs::occsl when isVarId id c ->
+ | decl'::ctxt', c::l, occs::occsl when isVarId (get_id decl') c ->
begin match occs with
| Some _ ->
error "Cannot force abstraction on identity instance."
| None ->
make_subst (ctxt',l,occsl)
end
- | (id,_,t)::ctxt', c::l, occs::occsl ->
+ | decl'::ctxt', c::l, occs::occsl ->
+ let (id,_,t) = to_tuple decl' in
let evs = ref [] in
let ty = Retyping.get_type_of env_rhs evd c in
let filter' = filter_possible_projections c ty ctxt args in
@@ -1004,7 +1045,9 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
| None ->
let evty = set_holes evdref cty subst in
let instance = Filter.filter_list filter instance in
- let evd,ev = new_evar_instance sign !evdref evty ~filter instance in
+ let evd = Sigma.Unsafe.of_evar_map !evdref in
+ let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in
+ let evd = Sigma.to_evar_map evd in
evdref := evd;
evsref := (fst (destEvar ev),evty)::!evsref;
ev in
@@ -1038,7 +1081,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
match evar_conv_x ts env_evar evd CUMUL idty evty with
| UnifFailure _ -> error "Cannot find an instance"
| Success evd ->
- match reconsider_conv_pbs (evar_conv_x ts) evd with
+ match reconsider_unif_constraints (evar_conv_x ts) evd with
| UnifFailure _ -> error "Cannot find an instance"
| Success evd ->
evd
@@ -1061,7 +1104,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
abstract_free_holes evd subst, true
with TypingFailed evd -> evd, false
-let second_order_matching_with_args ts env evd ev l t =
+let second_order_matching_with_args ts env evd pbty ev l t =
(*
let evd,ev = evar_absorb_arguments env evd ev l in
let argoccs = Array.map_to_list (fun _ -> None) (snd ev) in
@@ -1069,8 +1112,9 @@ let second_order_matching_with_args ts env evd ev l t =
if b then Success evd
else UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t))
if b then Success evd else
-*)
- UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t))
+ *)
+ let pb = (pbty,env,mkApp(mkEvar ev,l),t) in
+ UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities))
let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
let t1 = apprec_nohdbeta ts env evd (whd_head_evar evd t1) in
@@ -1086,7 +1130,9 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
type inference *)
(match choose_less_dependent_instance evk1 evd term2 args1 with
| Some evd -> Success evd
- | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)))
+ | None ->
+ let reason = ProblemBeyondCapabilities in
+ UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason)))
| (Rel _|Var _), Evar (evk2,args2) when app_empty
&& List.for_all (fun a -> Term.eq_constr a term1 || isEvar a)
(remove_instance_local_defs evd evk2 args2) ->
@@ -1094,12 +1140,14 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
type inference *)
(match choose_less_dependent_instance evk2 evd term1 args2 with
| Some evd -> Success evd
- | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)))
+ | None ->
+ let reason = ProblemBeyondCapabilities in
+ UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason)))
| Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 ->
- let f env evd pbty x y = is_trans_fconv pbty ts env evd x y in
+ let f env evd pbty x y = is_fconv ~reds:ts pbty env evd x y in
Success (solve_refl ~can_drop:true f env evd
(position_problem true pbty) evk1 args1 args2)
- | Evar ev1, Evar ev2 ->
+ | Evar ev1, Evar ev2 when app_empty ->
Success (solve_evar_evar ~force:true
(evar_define (evar_conv_x ts) ~choose:true) (evar_conv_x ts) env evd
(position_problem true pbty) ev1 ev2)
@@ -1109,27 +1157,32 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
ise_try evd
[(fun evd -> first_order_unification ts env evd (ev1,l1) appr2);
(fun evd ->
- second_order_matching_with_args ts env evd ev1 l1 t2)]
+ second_order_matching_with_args ts env evd pbty ev1 l1 t2)]
| _,Evar ev2 when Array.length l2 <= Array.length l1 ->
(* On "u u1 .. u(n+p) = ?n t1 .. tn", try first-order unification *)
(* and otherwise second-order matching *)
ise_try evd
[(fun evd -> first_order_unification ts env evd (ev2,l2) appr1);
(fun evd ->
- second_order_matching_with_args ts env evd ev2 l2 t1)]
+ second_order_matching_with_args ts env evd pbty ev2 l2 t1)]
| Evar ev1,_ ->
(* Try second-order pattern-matching *)
- second_order_matching_with_args ts env evd ev1 l1 t2
+ second_order_matching_with_args ts env evd pbty ev1 l1 t2
| _,Evar ev2 ->
(* Try second-order pattern-matching *)
- second_order_matching_with_args ts env evd ev2 l2 t1
+ second_order_matching_with_args ts env evd pbty ev2 l2 t1
| _ ->
(* Some head evar have been instantiated, or unknown kind of problem *)
evar_conv_x ts env evd pbty t1 t2
+let error_cannot_unify env evd pb ?reason t1 t2 =
+ Pretype_errors.error_cannot_unify_loc
+ (loc_of_conv_pb evd pb) env
+ evd ?reason (t1, t2)
+
let check_problems_are_solved env evd =
match snd (extract_all_conv_pbs evd) with
- | (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2)
+ | (pbty,env,t1,t2) as pb::_ -> error_cannot_unify env evd pb t1 t2
| _ -> ()
let max_undefined_with_candidates evd =
@@ -1160,7 +1213,7 @@ let rec solve_unconstrained_evars_with_candidates ts evd =
let conv_algo = evar_conv_x ts in
let evd = check_evar_instance evd evk a conv_algo in
let evd = Evd.define evk a evd in
- match reconsider_conv_pbs conv_algo evd with
+ match reconsider_unif_constraints conv_algo evd with
| Success evd -> solve_unconstrained_evars_with_candidates ts evd
| UnifFailure _ -> aux l
with
@@ -1174,16 +1227,16 @@ let rec solve_unconstrained_evars_with_candidates ts evd =
let solve_unconstrained_impossible_cases env evd =
Evd.fold_undefined (fun evk ev_info evd' ->
match ev_info.evar_source with
- | _,Evar_kinds.ImpossibleCase ->
+ | loc,Evar_kinds.ImpossibleCase ->
let j, ctx = coq_unit_judge () in
- let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd' ctx in
+ let evd' = Evd.merge_context_set Evd.univ_flexible_alg ~loc evd' ctx in
let ty = j_type j in
let conv_algo = evar_conv_x full_transparent_state in
let evd' = check_evar_instance evd' evk ty conv_algo in
Evd.define evk ty evd'
| _ -> evd') evd evd
-let consider_remaining_unif_problems env
+let solve_unif_constraints_with_heuristics env
?(ts=Conv_oracle.get_transp_state (Environ.oracle env)) evd =
let evd = solve_unconstrained_evars_with_candidates ts evd in
let rec aux evd pbs progress stuck =
@@ -1198,23 +1251,23 @@ let consider_remaining_unif_problems env
aux evd pbs progress (pb :: stuck)
end
| UnifFailure (evd,reason) ->
- Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb)
- env evd ~reason (t1, t2))
+ error_cannot_unify env evd pb ~reason t1 t2)
| _ ->
if progress then aux evd stuck false []
else
match stuck with
| [] -> (* We're finished *) evd
| (pbty,env,t1,t2 as pb) :: _ ->
- (* There remains stuck problems *)
- Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb)
- env evd (t1, t2)
+ (* There remains stuck problems *)
+ error_cannot_unify env evd pb t1 t2
in
let (evd,pbs) = extract_all_conv_pbs evd in
let heuristic_solved_evd = aux evd pbs false [] in
check_problems_are_solved env heuristic_solved_evd;
solve_unconstrained_impossible_cases env heuristic_solved_evd
+let consider_remaining_unif_problems = solve_unif_constraints_with_heuristics
+
(* Main entry points *)
exception UnableToUnify of evar_map * unification_error
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
index 14947c89..2231e5bc 100644
--- a/pretyping/evarconv.mli
+++ b/pretyping/evarconv.mli
@@ -33,7 +33,10 @@ val e_cumul : env -> ?ts:transparent_state -> evar_map ref -> constr -> constr -
(** Try heuristics to solve pending unification problems and to solve
evars with candidates *)
+val solve_unif_constraints_with_heuristics : env -> ?ts:transparent_state -> evar_map -> evar_map
+
val consider_remaining_unif_problems : env -> ?ts:transparent_state -> evar_map -> evar_map
+(** @deprecated Alias for [solve_unif_constraints_with_heuristics] *)
(** Check all pending unification problems are solved and raise an
error otherwise *)
diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml
new file mode 100644
index 00000000..f9ab75ce
--- /dev/null
+++ b/pretyping/evardefine.ml
@@ -0,0 +1,207 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* push_rel (map_constr (nf_evar sigma) d) e) env
+
+let env_nf_betaiotaevar sigma env =
+ let open Context.Rel.Declaration in
+ process_rel_context
+ (fun d e ->
+ push_rel (map_constr (Reductionops.nf_betaiota sigma) d) e) env
+
+(****************************************)
+(* Operations on value/type constraints *)
+(****************************************)
+
+type type_constraint = types option
+
+type val_constraint = constr option
+
+(* Old comment...
+ * Basically, we have the following kind of constraints (in increasing
+ * strength order):
+ * (false,(None,None)) -> no constraint at all
+ * (true,(None,None)) -> we must build a judgement which _TYPE is a kind
+ * (_,(None,Some ty)) -> we must build a judgement which _TYPE is ty
+ * (_,(Some v,_)) -> we must build a judgement which _VAL is v
+ * Maybe a concrete datatype would be easier to understand.
+ * We differentiate (true,(None,None)) from (_,(None,Some Type))
+ * because otherwise Case(s) would be misled, as in
+ * (n:nat) Case n of bool [_]nat end would infer the predicate Type instead
+ * of Set.
+ *)
+
+(* The empty type constraint *)
+let empty_tycon = None
+
+(* Builds a type constraint *)
+let mk_tycon ty = Some ty
+
+(* Constrains the value of a type *)
+let empty_valcon = None
+
+(* Builds a value constraint *)
+let mk_valcon c = Some c
+
+let idx = Namegen.default_dependent_ident
+
+(* Refining an evar to a product *)
+
+let define_pure_evar_as_product evd evk =
+ let open Context.Named.Declaration in
+ let evi = Evd.find_undefined evd evk in
+ let evenv = evar_env evi in
+ let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in
+ let concl = Reductionops.whd_all evenv evd evi.evar_concl in
+ let s = destSort concl in
+ let evd1,(dom,u1) =
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
+ (Sigma.to_evar_map evd1, e)
+ in
+ let evd2,rng =
+ let newenv = push_named (LocalAssum (id, dom)) evenv in
+ let src = evar_source evk evd1 in
+ let filter = Filter.extend 1 (evar_filter evi) in
+ if is_prop_sort s then
+ (* Impredicative product, conclusion must fall in [Prop]. *)
+ new_evar_unsafe newenv evd1 concl ~src ~filter
+ else
+ let status = univ_flexible_alg in
+ let evd3, (rng, srng) =
+ let evd1 = Sigma.Unsafe.of_evar_map evd1 in
+ let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in
+ (Sigma.to_evar_map evd3, e)
+ in
+ let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in
+ let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in
+ evd3, rng
+ in
+ let prod = mkProd (Name id, dom, subst_var id rng) in
+ let evd3 = Evd.define evk prod evd2 in
+ evd3,prod
+
+(* Refine an applied evar to a product and returns its instantiation *)
+
+let define_evar_as_product evd (evk,args) =
+ let evd,prod = define_pure_evar_as_product evd evk in
+ (* Quick way to compute the instantiation of evk with args *)
+ let na,dom,rng = destProd prod in
+ let evdom = mkEvar (fst (destEvar dom), args) in
+ let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
+ let evrng = mkEvar (fst (destEvar rng), evrngargs) in
+ evd,mkProd (na, evdom, evrng)
+
+(* Refine an evar with an abstraction
+
+ I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where:
+ - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y)
+ or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B
+ with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type
+ - x1..xq,y:A |- ?e':B
+*)
+
+let define_pure_evar_as_lambda env evd evk =
+ let open Context.Named.Declaration in
+ let evi = Evd.find_undefined evd evk in
+ let evenv = evar_env evi in
+ let typ = Reductionops.whd_all evenv evd (evar_concl evi) in
+ let evd1,(na,dom,rng) = match kind_of_term typ with
+ | Prod (na,dom,rng) -> (evd,(na,dom,rng))
+ | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ
+ | _ -> error_not_product_loc Loc.ghost env evd typ in
+ let avoid = ids_of_named_context (evar_context evi) in
+ let id =
+ next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in
+ let newenv = push_named (LocalAssum (id, dom)) evenv in
+ let filter = Filter.extend 1 (evar_filter evi) in
+ let src = evar_source evk evd1 in
+ let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
+ let lam = mkLambda (Name id, dom, subst_var id body) in
+ Evd.define evk lam evd2, lam
+
+let define_evar_as_lambda env evd (evk,args) =
+ let evd,lam = define_pure_evar_as_lambda env evd evk in
+ (* Quick way to compute the instantiation of evk with args *)
+ let na,dom,body = destLambda lam in
+ let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
+ let evbody = mkEvar (fst (destEvar body), evbodyargs) in
+ evd,mkLambda (na, dom, evbody)
+
+let rec evar_absorb_arguments env evd (evk,args as ev) = function
+ | [] -> evd,ev
+ | a::l ->
+ (* TODO: optimize and avoid introducing intermediate evars *)
+ let evd,lam = define_pure_evar_as_lambda env evd evk in
+ let _,_,body = destLambda lam in
+ let evk = fst (destEvar body) in
+ evar_absorb_arguments env evd (evk, Array.cons a args) l
+
+(* Refining an evar to a sort *)
+
+let define_evar_as_sort env evd (ev,args) =
+ let evd, u = new_univ_variable univ_rigid evd in
+ let evi = Evd.find_undefined evd ev in
+ let s = Type u in
+ let concl = Reductionops.whd_all (evar_env evi) evd evi.evar_concl in
+ let sort = destSort concl in
+ let evd' = Evd.define ev (mkSort s) evd in
+ Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s
+
+(* Propagation of constraints through application and abstraction:
+ Given a type constraint on a functional term, returns the type
+ constraint on its domain and codomain. If the input constraint is
+ an evar instantiate it with the product of 2 new evars. *)
+
+let split_tycon loc env evd tycon =
+ let rec real_split evd c =
+ let t = Reductionops.whd_all env evd c in
+ match kind_of_term t with
+ | Prod (na,dom,rng) -> evd, (na, dom, rng)
+ | Evar ev (* ev is undefined because of whd_all *) ->
+ let (evd',prod) = define_evar_as_product evd ev in
+ let (_,dom,rng) = destProd prod in
+ evd',(Anonymous, dom, rng)
+ | App (c,args) when isEvar c ->
+ let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in
+ real_split evd' (mkApp (lam,args))
+ | _ -> error_not_product_loc loc env evd c
+ in
+ match tycon with
+ | None -> evd,(Anonymous,None,None)
+ | Some c ->
+ let evd', (n, dom, rng) = real_split evd c in
+ evd', (n, mk_tycon dom, mk_tycon rng)
+
+let valcon_of_tycon x = x
+let lift_tycon n = Option.map (lift n)
+
+let pr_tycon env = function
+ None -> str "None"
+ | Some t -> Termops.print_constr_env env t
diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli
new file mode 100644
index 00000000..07b0e69d
--- /dev/null
+++ b/pretyping/evardefine.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* env -> env
+val env_nf_betaiotaevar : evar_map -> env -> env
+
+type type_constraint = types option
+type val_constraint = constr option
+
+val empty_tycon : type_constraint
+val mk_tycon : constr -> type_constraint
+val empty_valcon : val_constraint
+val mk_valcon : constr -> val_constraint
+
+(** Instantiate an evar by as many lambda's as needed so that its arguments
+ are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into
+ [?y[vars1:=args1,vars:=args]] with
+ [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *)
+val evar_absorb_arguments : env -> evar_map -> existential -> constr list ->
+ evar_map * existential
+
+val split_tycon :
+ Loc.t -> env -> evar_map -> type_constraint ->
+ evar_map * (Name.t * type_constraint * type_constraint)
+
+val valcon_of_tycon : type_constraint -> val_constraint
+val lift_tycon : int -> type_constraint -> type_constraint
+
+val define_evar_as_product : evar_map -> existential -> evar_map * types
+val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types
+val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts
+
+(** {6 debug pretty-printer:} *)
+
+val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
+
diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index 3bf6f376..4fd03084 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -7,11 +7,10 @@
(************************************************************************)
open Util
-open Errors
+open CErrors
open Names
open Term
open Vars
-open Context
open Environ
open Termops
open Evd
@@ -20,6 +19,7 @@ open Retyping
open Reductionops
open Evarutil
open Pretype_errors
+open Sigma.Notations
let normalize_evar evd ev =
match kind_of_term (whd_evar evd (mkEvar ev)) with
@@ -42,28 +42,39 @@ let get_polymorphic_positions f =
templ.template_param_levels)
| _ -> assert false
-let refresh_level evd s =
- match Evd.is_sort_variable evd s with
- | None -> true
- | Some l -> not (Evd.is_flexible_level evd l)
-
-let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t =
+let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false)
+ pbty env evd t =
let evdref = ref evd in
let modified = ref false in
- let rec refresh status dir t =
- match kind_of_term t with
- | Sort (Type u as s) when
- (match Univ.universe_level u with
- | None -> true
- | Some l -> not onlyalg && refresh_level evd s) ->
+ (* direction: true for fresh universes lower than the existing ones *)
+ let refresh_sort status ~direction s =
let s' = evd_comb0 (new_sort_variable status) evdref in
let evd =
- if dir then set_leq_sort env !evdref s' s
+ if direction then set_leq_sort env !evdref s' s
else set_leq_sort env !evdref s s'
in
- modified := true; evdref := evd; mkSort s'
+ modified := true; evdref := evd; mkSort s'
+ in
+ let rec refresh ~onlyalg status ~direction t =
+ match kind_of_term t with
+ | Sort (Type u as s) ->
+ (match Univ.universe_level u with
+ | None -> refresh_sort status ~direction s
+ | Some l ->
+ (match Evd.universe_rigidity evd l with
+ | UnivRigid ->
+ if not onlyalg then refresh_sort status ~direction s
+ else t
+ | UnivFlexible alg ->
+ if onlyalg && alg then
+ (evdref := Evd.make_flexible_variable !evdref false l; t)
+ else t))
+ | Sort (Prop Pos as s) when refreshset && not direction ->
+ (* Cannot make a universe "lower" than "Set",
+ only refreshing when we want higher universes. *)
+ refresh_sort status ~direction s
| Prod (na,u,v) ->
- mkProd (na,u,refresh status dir v)
+ mkProd (na, u, refresh ~onlyalg status ~direction v)
| _ -> t
(** Refresh the types of evars under template polymorphic references *)
and refresh_term_evars onevars top t =
@@ -76,11 +87,11 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t =
Array.iter (refresh_term_evars onevars false) args
| Evar (ev, a) when onevars ->
let evi = Evd.find !evdref ev in
- let ty' = refresh univ_flexible true evi.evar_concl in
+ let ty' = refresh ~onlyalg univ_flexible ~direction:true evi.evar_concl in
if !modified then
evdref := Evd.add !evdref ev {evi with evar_concl = ty'}
else ()
- | _ -> iter_constr (refresh_term_evars onevars false) t
+ | _ -> Constr.iter (refresh_term_evars onevars false) t
and refresh_polymorphic_positions args pos =
let rec aux i = function
| Some l :: ls ->
@@ -96,9 +107,11 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t =
in
let t' =
if isArity t then
- (match pbty with
- | None -> t
- | Some dir -> refresh status dir t)
+ match pbty with
+ | None ->
+ (* No cumulativity needed, but we still need to refresh the algebraics *)
+ refresh ~onlyalg:true univ_flexible ~direction:false t
+ | Some direction -> refresh ~onlyalg status ~direction t
else (refresh_term_evars false true t; t)
in
if !modified then !evdref, t' else !evdref, t
@@ -140,7 +153,7 @@ let recheck_applications conv_algo env evdref t =
let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in
let rec aux i ty =
if i < Array.length argsty then
- match kind_of_term (whd_betadeltaiota env !evdref ty) with
+ match kind_of_term (whd_all env !evdref ty) with
| Prod (na, dom, codom) ->
(match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with
| Success evd -> evdref := evd;
@@ -163,7 +176,8 @@ type 'a update =
| UpdateWith of 'a
| NoUpdate
-let inst_of_vars sign = Array.map_of_list (fun (id,_,_) -> mkVar id) sign
+open Context.Named.Declaration
+let inst_of_vars sign = Array.map_of_list (mkVar % get_id) sign
let restrict_evar_key evd evk filter candidates =
match filter, candidates with
@@ -181,7 +195,9 @@ let restrict_evar_key evd evk filter candidates =
let candidates = match candidates with
| NoUpdate -> evi.evar_candidates
| UpdateWith c -> Some c in
- restrict_evar evd evk filter candidates
+ let sigma = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (evk, sigma, _) = restrict_evar sigma evk filter candidates in
+ (Sigma.to_evar_map sigma, evk)
end
(* Restrict an applied evar and returns its restriction in the same context *)
@@ -206,32 +222,32 @@ let restrict_instance evd evk filter argsv =
let evi = Evd.find evd evk in
Filter.filter_array (Filter.compose (evar_filter evi) filter) argsv
+open Context.Rel.Declaration
let noccur_evar env evd evk c =
let cache = ref Int.Set.empty (* cache for let-ins *) in
- let rec occur_rec (k, env as acc) c =
+ let rec occur_rec check_types (k, env as acc) c =
match kind_of_term c with
| Evar (evk',args' as ev') ->
(match safe_evar_value evd ev' with
- | Some c -> occur_rec acc c
+ | Some c -> occur_rec check_types acc c
| None ->
if Evar.equal evk evk' then raise Occur
- else Array.iter (occur_rec acc) args')
+ else (if check_types then
+ occur_rec false acc (existential_type evd ev');
+ Array.iter (occur_rec check_types acc) args'))
| Rel i when i > k ->
- if not (Int.Set.mem (i-k) !cache) then
- (match pi2 (Environ.lookup_rel i env) with
- | None -> ()
- | Some b -> cache := Int.Set.add (i-k) !cache; occur_rec acc (lift i b))
- | Proj (p,c) ->
- let c =
- try Retyping.expand_projection env evd p c []
- with Retyping.RetypeError _ ->
- (* Can happen when called from w_unify which doesn't assign evars/metas
- eagerly enough *) c
- in occur_rec acc c
+ if not (Int.Set.mem (i-k) !cache) then
+ let decl = Environ.lookup_rel i env in
+ if check_types then
+ (cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i (get_type decl)));
+ (match decl with
+ | LocalAssum _ -> ()
+ | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i b))
+ | Proj (p,c) -> occur_rec true acc c
| _ -> iter_constr_with_full_binders (fun rd (k,env) -> (succ k, push_rel rd env))
- occur_rec acc c
+ (occur_rec check_types) acc c
in
- try occur_rec (0,env) c; true with Occur -> false
+ try occur_rec false (0,env) c; true with Occur -> false
(***************************************)
(* Managing chains of local definitons *)
@@ -242,9 +258,11 @@ let noccur_evar env evd evk c =
variable in its family of aliased variables *)
let compute_var_aliases sign =
- List.fold_right (fun (id,b,c) aliases ->
- match b with
- | Some t ->
+ let open Context.Named.Declaration in
+ List.fold_right (fun decl aliases ->
+ let id = get_id decl in
+ match decl with
+ | LocalDef (_,t,_) ->
(match kind_of_term t with
| Var id' ->
let aliases_of_id =
@@ -252,27 +270,30 @@ let compute_var_aliases sign =
Id.Map.add id (aliases_of_id@[t]) aliases
| _ ->
Id.Map.add id [t] aliases)
- | None -> aliases)
+ | LocalAssum _ -> aliases)
sign Id.Map.empty
let compute_rel_aliases var_aliases rels =
- snd (List.fold_right (fun (_,b,u) (n,aliases) ->
- (n-1,
- match b with
- | Some t ->
- (match kind_of_term t with
- | Var id' ->
- let aliases_of_n =
- try Id.Map.find id' var_aliases with Not_found -> [] in
- Int.Map.add n (aliases_of_n@[t]) aliases
- | Rel p ->
- let aliases_of_n =
- try Int.Map.find (p+n) aliases with Not_found -> [] in
- Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases
- | _ ->
- Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases)
- | None -> aliases))
- rels (List.length rels,Int.Map.empty))
+ snd (List.fold_right
+ (fun decl (n,aliases) ->
+ (n-1,
+ match decl with
+ | LocalDef (_,t,u) ->
+ (match kind_of_term t with
+ | Var id' ->
+ let aliases_of_n =
+ try Id.Map.find id' var_aliases with Not_found -> [] in
+ Int.Map.add n (aliases_of_n@[t]) aliases
+ | Rel p ->
+ let aliases_of_n =
+ try Int.Map.find (p+n) aliases with Not_found -> [] in
+ Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases
+ | _ ->
+ Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases)
+ | LocalAssum _ -> aliases)
+ )
+ rels
+ (List.length rels,Int.Map.empty))
let make_alias_map env =
(* We compute the chain of aliases for each var and rel *)
@@ -306,13 +327,13 @@ let normalize_alias aliases x =
let normalize_alias_var var_aliases id =
destVar (normalize_alias (var_aliases,Int.Map.empty) (mkVar id))
-let extend_alias (_,b,_) (var_aliases,rel_aliases) =
+let extend_alias decl (var_aliases,rel_aliases) =
let rel_aliases =
Int.Map.fold (fun n l -> Int.Map.add (n+1) (List.map (lift 1) l))
rel_aliases Int.Map.empty in
let rel_aliases =
- match b with
- | Some t ->
+ match decl with
+ | LocalDef(_,t,_) ->
(match kind_of_term t with
| Var id' ->
let aliases_of_binder =
@@ -324,7 +345,7 @@ let extend_alias (_,b,_) (var_aliases,rel_aliases) =
Int.Map.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases
| _ ->
Int.Map.add 1 [lift 1 t] rel_aliases)
- | None -> rel_aliases in
+ | LocalAssum _ -> rel_aliases in
(var_aliases, rel_aliases)
let expand_alias_once aliases x =
@@ -430,16 +451,17 @@ let get_actual_deps aliases l t =
| Rel n -> Int.Set.mem n fv_rels
| _ -> assert false) l
+open Context.Named.Declaration
let remove_instance_local_defs evd evk args =
let evi = Evd.find evd evk in
let len = Array.length args in
let rec aux sign i = match sign with
| [] ->
let () = assert (i = len) in []
- | (_, None, _) :: sign ->
+ | LocalAssum _ :: sign ->
let () = assert (i < len) in
(Array.unsafe_get args i) :: aux sign (succ i)
- | (_, Some _, _) :: sign ->
+ | LocalDef _ :: sign ->
aux sign (succ i)
in
aux (evar_filtered_context evi) 0
@@ -501,7 +523,8 @@ let solve_pattern_eqn env l c =
match kind_of_term a with
(* Rem: if [a] links to a let-in, do as if it were an assumption *)
| Rel n ->
- let d = map_rel_declaration (lift n) (lookup_rel n env) in
+ let open Context.Rel.Declaration in
+ let d = map_constr (lift n) (lookup_rel n env) in
mkLambda_or_LetIn d c'
| Var id ->
let d = lookup_named id env in mkNamedLambda_or_LetIn d c'
@@ -509,7 +532,7 @@ let solve_pattern_eqn env l c =
l c in
(* Warning: we may miss some opportunity to eta-reduce more since c'
is not in normal form *)
- whd_eta c'
+ shrink_eta c'
(*****************************************)
(* Refining/solving unification problems *)
@@ -530,9 +553,9 @@ let make_projectable_subst aliases sigma evi args =
let evar_aliases = compute_var_aliases sign in
let (_,full_subst,cstr_subst) =
List.fold_right
- (fun (id,b,c) (args,all,cstrs) ->
- match b,args with
- | None, a::rest ->
+ (fun decl (args,all,cstrs) ->
+ match decl,args with
+ | LocalAssum (id,c), a::rest ->
let a = whd_evar sigma a in
let cstrs =
let a',args = decompose_app_vect a in
@@ -542,7 +565,7 @@ let make_projectable_subst aliases sigma evi args =
Constrmap.add (fst cstr) ((args,id)::l) cstrs
| _ -> cstrs in
(rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs)
- | Some c, a::rest ->
+ | LocalDef (id,c,_), a::rest ->
let a = whd_evar sigma a in
(match kind_of_term c with
| Var id' ->
@@ -571,7 +594,9 @@ let make_projectable_subst aliases sigma evi args =
*)
let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env =
- let evd,evar_in_env = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in
+ let evd = Sigma.to_evar_map evd in
let t_in_env = whd_evar evd t_in_env in
let evd = define_fun env evd None (destEvar evar_in_env) t_in_env in
let ctxt = named_context_of_val sign in
@@ -596,16 +621,24 @@ let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_si
* substitution u1..uq.
*)
+exception MorePreciseOccurCheckNeeeded
+
let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
+ if Evd.is_defined evd evk1 then
+ (* Some circularity somewhere (see e.g. #3209) *)
+ raise MorePreciseOccurCheckNeeeded;
+ let (evk1,args1) = destEvar (whd_evar evd (mkEvar (evk1,args1))) in
let evi1 = Evd.find_undefined evd evk1 in
let env1,rel_sign = env_rel_context_chop k env in
let sign1 = evar_hyps evi1 in
let filter1 = evar_filter evi1 in
let src = subterm_source evk1 evi1.evar_source in
- let ids1 = List.map pi1 (named_context_of_val sign1) in
+ let ids1 = List.map get_id (named_context_of_val sign1) in
let inst_in_sign = List.map mkVar (Filter.filter_list filter1 ids1) in
+ let open Context.Rel.Declaration in
let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) =
- List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) ->
+ List.fold_right (fun d (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) ->
+ let LocalAssum (na,t_in_env) | LocalDef (na,_,t_in_env) = d in
let id = next_name_away na avoid in
let evd,t_in_sign =
let s = Retyping.get_sort_of env evd t_in_env in
@@ -613,13 +646,13 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
~status:univ_flexible (Some false) env evd (mkSort s) in
define_evar_from_virtual_equation define_fun env evd src t_in_env
ty_t_in_sign sign filter inst_in_env in
- let evd,b_in_sign = match b with
- | None -> evd,None
- | Some b ->
+ let evd,b_in_sign = match d with
+ | LocalAssum _ -> evd,None
+ | LocalDef (_,b,_) ->
let evd,b = define_evar_from_virtual_equation define_fun env evd src b
t_in_sign sign filter inst_in_env in
evd,Some b in
- (push_named_context_val (id,b_in_sign,t_in_sign) sign, Filter.extend 1 filter,
+ (push_named_context_val (Context.Named.Declaration.of_tuple (id,b_in_sign,t_in_sign)) sign, Filter.extend 1 filter,
(mkRel 1)::(List.map (lift 1) inst_in_env),
(mkRel 1)::(List.map (lift 1) inst_in_sign),
push_rel d env,evd,id::avoid))
@@ -632,8 +665,10 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
~status:univ_flexible (Some false) env evd (mkSort s) in
define_evar_from_virtual_equation define_fun env evd src ty_in_env
ty_t_in_sign sign2 filter2 inst2_in_env in
- let evd,ev2_in_sign =
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (ev2_in_sign, evd, _) =
new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in
+ let evd = Sigma.to_evar_map evd in
let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in
(evd, ev2_in_sign, ev2_in_env)
@@ -757,9 +792,10 @@ let project_with_effects aliases sigma effects t subst =
effects := p :: !effects;
c
+open Context.Named.Declaration
let rec find_solution_type evarenv = function
- | (id,ProjectVar)::l -> pi3 (lookup_named id evarenv)
- | [id,ProjectEvar _] -> (* bugged *) pi3 (lookup_named id evarenv)
+ | (id,ProjectVar)::l -> get_type (lookup_named id evarenv)
+ | [id,ProjectEvar _] -> (* bugged *) get_type (lookup_named id evarenv)
| (id,ProjectEvar _)::l -> find_solution_type evarenv l
| [] -> assert false
@@ -779,7 +815,7 @@ let rec do_projection_effects define_fun env ty evd = function
let evd = Evd.define evk (mkVar id) evd in
(* TODO: simplify constraints involving evk *)
let evd = do_projection_effects define_fun env ty evd p in
- let ty = whd_betadeltaiota env evd (Lazy.force ty) in
+ let ty = whd_all env evd (Lazy.force ty) in
if not (isSort ty) then
(* Don't try to instantiate if a sort because if evar_concl is an
evar it may commit to a univ level which is not the right
@@ -893,7 +929,7 @@ let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' =
*)
let set_of_evctx l =
- List.fold_left (fun s (id,_,_) -> Id.Set.add id s) Id.Set.empty l
+ List.fold_left (fun s decl -> Id.Set.add (get_id decl) s) Id.Set.empty l
let filter_effective_candidates evi filter candidates =
match filter with
@@ -925,7 +961,13 @@ let closure_of_filter evd evk = function
| Some filter ->
let evi = Evd.find_undefined evd evk in
let vars = collect_vars (Evarutil.nf_evar evd (evar_concl evi)) in
- let test b (id,c,_) = b || Idset.mem id vars || match c with None -> false | Some c -> not (isRel c || isVar c) in
+ let test b decl = b || Idset.mem (get_id decl) vars ||
+ match decl with
+ | LocalAssum _ ->
+ false
+ | LocalDef (_,c,_) ->
+ not (isRel c || isVar c)
+ in
let newfilter = Filter.map_along test filter (evar_context evi) in
(* Now ensure that restriction is at least what is was originally *)
let newfilter = Option.cata (Filter.map_along (&&) newfilter) newfilter (Filter.repr (evar_filter evi)) in
@@ -1007,21 +1049,6 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs =
* Note: argument f is the function used to instantiate evars.
*)
-let are_canonical_instances args1 args2 env =
- let n1 = Array.length args1 in
- let n2 = Array.length args2 in
- let rec aux n = function
- | (id,_,c)::sign
- when n < n1 && isVarId id args1.(n) && isVarId id args2.(n) ->
- aux (n+1) sign
- | [] ->
- let rec aux2 n =
- Int.equal n n1 ||
- (isRelN (n1-n) args1.(n) && isRelN (n1-n) args2.(n) && aux2 (n+1))
- in aux2 n
- | _ -> false in
- Int.equal n1 n2 && aux 0 (named_context env)
-
let filter_compatible_candidates conv_algo env evd evi args rhs c =
let c' = instantiate_evar_array evi c args in
match conv_algo env evd Reduction.CONV rhs c' with
@@ -1296,7 +1323,7 @@ let occur_evar_upto_types sigma n c =
seen := Evar.Set.add sp !seen;
Option.iter occur_rec (existential_opt_value sigma e);
occur_rec (existential_type sigma e))
- | _ -> iter_constr occur_rec c
+ | _ -> Constr.iter occur_rec c
in
try occur_rec c; false with Occur -> true
@@ -1381,15 +1408,16 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
let t = whd_evar !evdref t in
match kind_of_term t with
| Rel i when i>k ->
- (match pi2 (Environ.lookup_rel (i-k) env') with
- | None -> project_variable (mkRel (i-k))
- | Some b ->
+ let open Context.Rel.Declaration in
+ (match Environ.lookup_rel (i-k) env' with
+ | LocalAssum _ -> project_variable (mkRel (i-k))
+ | LocalDef (_,b,_) ->
try project_variable (mkRel (i-k))
with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i b))
| Var id ->
- (match pi2 (Environ.lookup_named id env') with
- | None -> project_variable t
- | Some b ->
+ (match Environ.lookup_named id env' with
+ | LocalAssum _ -> project_variable t
+ | LocalDef (_,b,_) ->
try project_variable t
with NotInvertibleUsingOurAlgorithm _ -> imitate envk b)
| LetIn (na,b,u,c) ->
@@ -1450,7 +1478,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
imitate envk t in
t::l
- with e when Errors.noncritical e -> l in
+ with e when CErrors.noncritical e -> l in
(match candidates with
| [x] -> x
| _ ->
@@ -1469,7 +1497,8 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
let names = ref Idset.empty in
let rec is_id_subst ctxt s =
match ctxt, s with
- | ((id, _, _) :: ctxt'), (c :: s') ->
+ | (decl :: ctxt'), (c :: s') ->
+ let id = get_id decl in
names := Idset.add id !names;
isVarId id c && is_id_subst ctxt' s'
| [], [] -> true
@@ -1538,11 +1567,13 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs =
postpone_non_unique_projection env evd pbty ev sols rhs
| NotEnoughInformationEvarEvar t ->
add_conv_oriented_pb (pbty,env,mkEvar ev,t) evd
+ | MorePreciseOccurCheckNeeeded ->
+ add_conv_oriented_pb (pbty,env,mkEvar ev,rhs) evd
| NotInvertibleUsingOurAlgorithm _ | MetaOccurInBodyInternal as e ->
raise e
| OccurCheckIn (evd,rhs) ->
(* last chance: rhs actually reduces to ev *)
- let c = whd_betadeltaiota env evd rhs in
+ let c = whd_all env evd rhs in
match kind_of_term c with
| Evar (evk',argsv2) when Evar.equal evk evk' ->
solve_refl (fun env sigma pb c c' -> is_fconv pb env sigma c c')
@@ -1580,7 +1611,7 @@ let status_changed lev (pbty,_,t1,t2) =
(try Evar.Set.mem (head_evar t1) lev with NoHeadEvar -> false) ||
(try Evar.Set.mem (head_evar t2) lev with NoHeadEvar -> false)
-let reconsider_conv_pbs conv_algo evd =
+let reconsider_unif_constraints conv_algo evd =
let (evd,pbs) = extract_changed_conv_pbs evd status_changed in
List.fold_left
(fun p (pbty,env,t1,t2 as x) ->
@@ -1593,6 +1624,8 @@ let reconsider_conv_pbs conv_algo evd =
(Success evd)
pbs
+let reconsider_conv_pbs = reconsider_unif_constraints
+
(* Tries to solve problem t1 = t2.
* Precondition: t1 is an uninstantiated evar
* Returns an optional list of evars that were instantiated, or None
@@ -1603,7 +1636,7 @@ let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1)
try
let t2 = whd_betaiota evd t2 in (* includes whd_evar *)
let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in
- reconsider_conv_pbs conv_algo evd
+ reconsider_unif_constraints conv_algo evd
with
| NotInvertibleUsingOurAlgorithm t ->
UnifFailure (evd,NotClean (ev1,env,t))
diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli
index 918ba12f..b6bdc078 100644
--- a/pretyping/evarsolve.mli
+++ b/pretyping/evarsolve.mli
@@ -34,8 +34,12 @@ type conv_fun_bool =
val evar_define : conv_fun -> ?choose:bool -> env -> evar_map ->
bool option -> existential -> constr -> evar_map
-val refresh_universes : ?status:Evd.rigid ->
- ?onlyalg:bool (* Only algebraic universes *) ->
+val refresh_universes :
+ ?status:Evd.rigid ->
+ ?onlyalg:bool (* Only algebraic universes *) ->
+ ?refreshset:bool ->
+ (* Also refresh Prop and Set universes, so that the returned type can be any supertype
+ of the original type *)
bool option (* direction: true for levels lower than the existing levels *) ->
env -> evar_map -> types -> evar_map * types
@@ -50,7 +54,10 @@ val solve_evar_evar : ?force:bool ->
val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map ->
bool option * existential * constr -> unification_result
+val reconsider_unif_constraints : conv_fun -> evar_map -> unification_result
+
val reconsider_conv_pbs : conv_fun -> evar_map -> unification_result
+(** @deprecated Alias for [reconsider_unif_constraints] *)
val is_unification_pattern_evar : env -> evar_map -> existential -> constr list ->
constr -> constr list option
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
deleted file mode 100644
index e23e5a53..00000000
--- a/pretyping/evarutil.ml
+++ /dev/null
@@ -1,872 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(*
- (match existential_opt_value sigma ev with
- | None -> raise (Uninstantiated_evar evk)
- | Some c -> flush_and_check_evars sigma c)
- | _ -> map_constr (flush_and_check_evars sigma) c
-
-(* let nf_evar_key = Profile.declare_profile "nf_evar" *)
-(* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *)
-let nf_evar = Reductionops.nf_evar
-let j_nf_evar sigma j =
- { uj_val = nf_evar sigma j.uj_val;
- uj_type = nf_evar sigma j.uj_type }
-let j_nf_betaiotaevar sigma j =
- { uj_val = nf_evar sigma j.uj_val;
- uj_type = Reductionops.nf_betaiota sigma j.uj_type }
-let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl
-let jv_nf_betaiotaevar sigma jl =
- Array.map (j_nf_betaiotaevar sigma) jl
-let jv_nf_evar sigma = Array.map (j_nf_evar sigma)
-let tj_nf_evar sigma {utj_val=v;utj_type=t} =
- {utj_val=nf_evar sigma v;utj_type=t}
-
-let env_nf_evar sigma env =
- process_rel_context
- (fun d e -> push_rel (map_rel_declaration (nf_evar sigma) d) e) env
-
-let env_nf_betaiotaevar sigma env =
- process_rel_context
- (fun d e ->
- push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env
-
-let nf_evars_universes evm =
- Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm)
- (Evd.universe_subst evm)
-
-let nf_evars_and_universes evm =
- let evm = Evd.nf_constraints evm in
- evm, nf_evars_universes evm
-
-let e_nf_evars_and_universes evdref =
- evdref := Evd.nf_constraints !evdref;
- nf_evars_universes !evdref, Evd.universe_subst !evdref
-
-let nf_evar_map_universes evm =
- let evm = Evd.nf_constraints evm in
- let subst = Evd.universe_subst evm in
- if Univ.LMap.is_empty subst then evm, nf_evar evm
- else
- let f = nf_evars_universes evm in
- Evd.raw_map (fun _ -> map_evar_info f) evm, f
-
-let nf_named_context_evar sigma ctx =
- Context.map_named_context (nf_evar sigma) ctx
-
-let nf_rel_context_evar sigma ctx =
- Context.map_rel_context (nf_evar sigma) ctx
-
-let nf_env_evar sigma env =
- let nc' = nf_named_context_evar sigma (Environ.named_context env) in
- let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in
- push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env)
-
-let nf_evar_info evc info = map_evar_info (nf_evar evc) info
-
-let nf_evar_map evm =
- Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm
-
-let nf_evar_map_undefined evm =
- Evd.raw_map_undefined (fun _ evi -> nf_evar_info evm evi) evm
-
-(*-------------------*)
-(* Auxiliary functions for the conversion algorithms modulo evars
- *)
-
-(* A probably faster though more approximative variant of
- [has_undefined (nf_evar c)]: instances are not substituted and
- maybe an evar occurs in an instance and it would disappear by
- instantiation *)
-
-let has_undefined_evars evd t =
- let rec has_ev t =
- match kind_of_term t with
- | Evar (ev,args) ->
- (match evar_body (Evd.find evd ev) with
- | Evar_defined c ->
- has_ev c; Array.iter has_ev args
- | Evar_empty ->
- raise NotInstantiatedEvar)
- | _ -> iter_constr has_ev t in
- try let _ = has_ev t in false
- with (Not_found | NotInstantiatedEvar) -> true
-
-let is_ground_term evd t =
- not (has_undefined_evars evd t)
-
-let is_ground_env evd env =
- let is_ground_decl = function
- (_,Some b,_) -> is_ground_term evd b
- | _ -> true in
- List.for_all is_ground_decl (rel_context env) &&
- List.for_all is_ground_decl (named_context env)
-
-(* Memoization is safe since evar_map and environ are applicative
- structures *)
-let memo f =
- let m = ref None in
- fun x y -> match !m with
- | Some (x', y', r) when x == x' && y == y' -> r
- | _ -> let r = f x y in m := Some (x, y, r); r
-
-let is_ground_env = memo is_ground_env
-
-(* Return the head evar if any *)
-
-exception NoHeadEvar
-
-let head_evar =
- let rec hrec c = match kind_of_term c with
- | Evar (evk,_) -> evk
- | Case (_,_,c,_) -> hrec c
- | App (c,_) -> hrec c
- | Cast (c,_,_) -> hrec c
- | _ -> raise NoHeadEvar
- in
- hrec
-
-(* Expand head evar if any (currently consider only applications but I
- guess it should consider Case too) *)
-
-let whd_head_evar_stack sigma c =
- let rec whrec (c, l as s) =
- match kind_of_term c with
- | Evar (evk,args as ev) ->
- let v =
- try Some (existential_value sigma ev)
- with NotInstantiatedEvar | Not_found -> None in
- begin match v with
- | None -> s
- | Some c -> whrec (c, l)
- end
- | Cast (c,_,_) -> whrec (c, l)
- | App (f,args) -> whrec (f, args :: l)
- | _ -> s
- in
- whrec (c, [])
-
-let whd_head_evar sigma c =
- let (f, args) = whd_head_evar_stack sigma c in
- (** optim: don't reallocate if empty/singleton *)
- match args with
- | [] -> f
- | [arg] -> mkApp (f, arg)
- | _ -> mkApp (f, Array.concat args)
-
-(**********************)
-(* Creating new metas *)
-(**********************)
-
-let meta_counter_summary_name = "meta counter"
-
-(* Generator of metavariables *)
-let new_meta =
- let meta_ctr = Summary.ref 0 ~name:meta_counter_summary_name in
- fun () -> incr meta_ctr; !meta_ctr
-
-let mk_new_meta () = mkMeta(new_meta())
-
-(* The list of non-instantiated existential declarations (order is important) *)
-
-let non_instantiated sigma =
- let listev = Evd.undefined_map sigma in
- Evar.Map.smartmap (fun evi -> nf_evar_info sigma evi) listev
-
-(************************)
-(* Manipulating filters *)
-(************************)
-
-let make_pure_subst evi args =
- snd (List.fold_right
- (fun (id,b,c) (args,l) ->
- match args with
- | a::rest -> (rest, (id,a)::l)
- | _ -> anomaly (Pp.str "Instance does not match its signature"))
- (evar_filtered_context evi) (Array.rev_to_list args,[]))
-
-(**********************)
-(* Creating new evars *)
-(**********************)
-
-let evar_counter_summary_name = "evar counter"
-
-(* Generator of existential names *)
-let new_untyped_evar =
- let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in
- fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr
-
-(*------------------------------------*
- * functional operations on evar sets *
- *------------------------------------*)
-
-(* [push_rel_context_to_named_context] builds the defining context and the
- * initial instance of an evar. If the evar is to be used in context
- *
- * Gamma = a1 ... an xp ... x1
- * \- named part -/ \- de Bruijn part -/
- *
- * then the x1...xp are turned into variables so that the evar is declared in
- * context
- *
- * a1 ... an xp ... x1
- * \----------- named part ------------/
- *
- * but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)"
- * so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed
- * in context Gamma.
- *
- * Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first)
- * Remark 2: If some of the ai or xj are definitions, we keep them in the
- * instance. This is necessary so that no unfolding of local definitions
- * happens when inferring implicit arguments (consider e.g. the problem
- * "x:nat; x':=x; f:forall y, y=y -> Prop |- f _ (refl_equal x')" which
- * produces the equation "?y[x,x']=?y[x,x']" =? "x'=x'": we want
- * the hole to be instantiated by x', not by x (which would have been
- * the case in [invert_definition] if x' had disappeared from the instance).
- * Note that at any time, if, in some context env, the instance of
- * declaration x:A is t and the instance of definition x':=phi(x) is u, then
- * we have the property that u and phi(t) are convertible in env.
- *)
-
-let subst2 subst vsubst c =
- substl subst (replace_vars vsubst c)
-
-let push_rel_context_to_named_context env typ =
- (* compute the instances relative to the named context and rel_context *)
- let ids = List.map pi1 (named_context env) in
- let inst_vars = List.map mkVar ids in
- let inst_rels = List.rev (rel_list 0 (nb_rel env)) in
- let replace_var_named_declaration id0 id (id',b,t) =
- let id' = if Id.equal id0 id' then id else id' in
- let vsubst = [id0 , mkVar id] in
- let b = match b with
- | None -> None
- | Some c -> Some (replace_vars vsubst c)
- in
- id', b, replace_vars vsubst t
- in
- let replace_var_named_context id0 id env =
- let nc = Environ.named_context env in
- let nc' = List.map (replace_var_named_declaration id0 id) nc in
- Environ.reset_with_named_context (val_of_named_context nc') env
- in
- let extract_if_neq id = function
- | Anonymous -> None
- | Name id' when id_ord id id' = 0 -> None
- | Name id' -> Some id'
- in
- (* move the rel context to a named context and extend the named instance *)
- (* with vars of the rel context *)
- (* We do keep the instances corresponding to local definition (see above) *)
- let (subst, vsubst, _, env) =
- Context.fold_rel_context
- (fun (na,c,t) (subst, vsubst, avoid, env) ->
- let id =
- (* ppedrot: we want to infer nicer names for the refine tactic, but
- keeping at the same time backward compatibility in other code
- using this function. For now, we only attempt to preserve the
- old behaviour of Program, but ultimately, one should do something
- about this whole name generation problem. *)
- if Flags.is_program_mode () then next_name_away na avoid
- else next_ident_away (id_of_name_using_hdchar env t na) avoid
- in
- match extract_if_neq id na with
- | Some id0 when not (is_section_variable id0) ->
- (* spiwack: if [id<>id0], rather than introducing a new
- binding named [id], we will keep [id0] (the name given
- by the user) and rename [id0] into [id] in the named
- context. Unless [id] is a section variable. *)
- let subst = List.map (replace_vars [id0,mkVar id]) subst in
- let vsubst = (id0,mkVar id)::vsubst in
- let d = (id0, Option.map (subst2 subst vsubst) c, subst2 subst vsubst t) in
- let env = replace_var_named_context id0 id env in
- (mkVar id0 :: subst, vsubst, id::avoid, push_named d env)
- | _ ->
- (* spiwack: if [id0] is a section variable renaming it is
- incorrect. We revert to a less robust behaviour where
- the new binder has name [id]. Which amounts to the same
- behaviour than when [id=id0]. *)
- let d = (id,Option.map (subst2 subst vsubst) c,subst2 subst vsubst t) in
- (mkVar id :: subst, vsubst, id::avoid, push_named d env)
- )
- (rel_context env) ~init:([], [], ids, env) in
- (named_context_val env, subst2 subst vsubst typ, inst_rels@inst_vars, subst, vsubst)
-
-(*------------------------------------*
- * Entry points to define new evars *
- *------------------------------------*)
-
-let default_source = (Loc.ghost,Evar_kinds.InternalHole)
-
-let restrict_evar evd evk filter candidates =
- let evk' = new_untyped_evar () in
- let evd = Evd.restrict evk evk' filter ?candidates evd in
- Evd.declare_future_goal evk' evd, evk'
-
-let new_pure_evar_full evd evi =
- let evk = new_untyped_evar () in
- let evd = Evd.add evd evk evi in
- let evd = Evd.declare_future_goal evk evd in
- (evd, evk)
-
-let new_pure_evar sign evd ?(src=default_source) ?filter ?candidates ?store ?naming ?(principal=false) typ =
- let default_naming =
- if principal then
- (* waiting for a more principled approach
- (unnamed evars, private names?) *)
- Misctypes.IntroFresh (Names.Id.of_string "tmp_goal")
- else
- Misctypes.IntroAnonymous
- in
- let naming = Option.default default_naming naming in
- let newevk = new_untyped_evar() in
- let evd = evar_declare sign newevk typ ~src ?filter ?candidates ?store ~naming evd in
- let evd =
- if principal then Evd.declare_principal_goal newevk evd
- else Evd.declare_future_goal newevk evd
- in
- (evd,newevk)
-
-let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance =
- assert (not !Flags.debug ||
- List.distinct (ids_of_named_context (named_context_of_val sign)));
- let evd,newevk = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in
- (evd,mkEvar (newevk,Array.of_list instance))
-
-(* [new_evar] declares a new existential in an env env with type typ *)
-(* Converting the env into the sign of the evar to define *)
-let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
- let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in
- let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in
- let instance =
- match filter with
- | None -> instance
- | Some filter -> Filter.filter_list filter instance in
- new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance
-
-let new_type_evar env evd ?src ?filter ?naming ?principal rigid =
- let evd', s = new_sort_variable rigid evd in
- let evd', e = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in
- evd', (e, s)
-
-let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid =
- let evd', c = new_type_evar env !evdref ?src ?filter ?naming ?principal rigid in
- evdref := evd';
- c
-
-let new_Type ?(rigid=Evd.univ_flexible) env evd =
- let evd', s = new_sort_variable rigid evd in
- evd', mkSort s
-
-let e_new_Type ?(rigid=Evd.univ_flexible) env evdref =
- let evd', s = new_sort_variable rigid !evdref in
- evdref := evd'; mkSort s
-
- (* The same using side-effect *)
-let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty =
- let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in
- evdref := evd';
- ev
-
-(* This assumes an evar with identity instance and generalizes it over only
- the De Bruijn part of the context *)
-let generalize_evar_over_rels sigma (ev,args) =
- let evi = Evd.find sigma ev in
- let sign = named_context_of_val evi.evar_hyps in
- List.fold_left2
- (fun (c,inst as x) a d ->
- if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x)
- (evi.evar_concl,[]) (Array.to_list args) sign
-
-(************************************)
-(* Removing a dependency in an evar *)
-(************************************)
-
-type clear_dependency_error =
-| OccurHypInSimpleClause of Id.t option
-| EvarTypingBreak of existential
-
-exception ClearDependencyError of Id.t * clear_dependency_error
-
-let cleared = Store.field ()
-
-exception Depends of Id.t
-
-let rec check_and_clear_in_constr env evdref err ids c =
- (* returns a new constr where all the evars have been 'cleaned'
- (ie the hypotheses ids have been removed from the contexts of
- evars) *)
- let check id' =
- if Id.Set.mem id' ids then
- raise (ClearDependencyError (id',err))
- in
- match kind_of_term c with
- | Var id' ->
- check id'; c
-
- | ( Const _ | Ind _ | Construct _ ) ->
- let vars = Environ.vars_of_global env c in
- Id.Set.iter check vars; c
-
- | Evar (evk,l as ev) ->
- if Evd.is_defined !evdref evk then
- (* If evk is already defined we replace it by its definition *)
- let nc = whd_evar !evdref c in
- (check_and_clear_in_constr env evdref err ids nc)
- else
- (* We check for dependencies to elements of ids in the
- evar_info corresponding to e and in the instance of
- arguments. Concurrently, we build a new evar
- corresponding to e where hypotheses of ids have been
- removed *)
- let evi = Evd.find_undefined !evdref evk in
- let ctxt = Evd.evar_filtered_context evi in
- let (rids,filter) =
- List.fold_right2
- (fun (rid, ob,c as h) a (ri,filter) ->
- try
- (* Check if some id to clear occurs in the instance
- a of rid in ev and remember the dependency *)
- let check id = if Id.Set.mem id ids then raise (Depends id) in
- let () = Id.Set.iter check (collect_vars a) in
- (* Check if some rid to clear in the context of ev
- has dependencies in another hyp of the context of ev
- and transitively remember the dependency *)
- let check id _ =
- if occur_var_in_decl (Global.env ()) id h
- then raise (Depends id)
- in
- let () = Id.Map.iter check ri in
- (* No dependency at all, we can keep this ev's context hyp *)
- (ri, true::filter)
- with Depends id -> (Id.Map.add rid id ri, false::filter))
- ctxt (Array.to_list l) (Id.Map.empty,[]) in
- (* Check if some rid to clear in the context of ev has dependencies
- in the type of ev and adjust the source of the dependency *)
- let _nconcl =
- try
- let nids = Id.Map.domain rids in
- check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids (evar_concl evi)
- with ClearDependencyError (rid,err) ->
- raise (ClearDependencyError (Id.Map.find rid rids,err)) in
-
- if Id.Map.is_empty rids then c
- else
- let origfilter = Evd.evar_filter evi in
- let filter = Evd.Filter.apply_subfilter origfilter filter in
- let evd,_ = restrict_evar !evdref evk filter None in
- evdref := evd;
- (* spiwack: hacking session to mark the old [evk] as having been "cleared" *)
- let evi = Evd.find !evdref evk in
- let extra = evi.evar_extra in
- let extra' = Store.set extra cleared true in
- let evi' = { evi with evar_extra = extra' } in
- evdref := Evd.add !evdref evk evi' ;
- (* spiwack: /hacking session *)
- whd_evar !evdref c
-
- | _ -> map_constr (check_and_clear_in_constr env evdref err ids) c
-
-let clear_hyps_in_evi_main env evdref hyps terms ids =
- (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some
- hypothesis does not depend on a element of ids, and erases ids in
- the contexts of the evars occurring in evi *)
- let terms =
- List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in
- let nhyps =
- let check_context ((id,ob,c) as decl) =
- let err = OccurHypInSimpleClause (Some id) in
- let ob' = Option.smartmap (fun c -> check_and_clear_in_constr env evdref err ids c) ob in
- let c' = check_and_clear_in_constr env evdref err ids c in
- if ob == ob' && c == c' then decl else (id, ob', c')
- in
- let check_value vk = match force_lazy_val vk with
- | None -> vk
- | Some (_, d) ->
- if (Id.Set.for_all (fun e -> not (Id.Set.mem e d)) ids) then
- (* v does depend on any of ids, it's ok *)
- vk
- else
- (* v depends on one of the cleared hyps:
- we forget the computed value *)
- dummy_lazy_val ()
- in
- remove_hyps ids check_context check_value hyps
- in
- (nhyps,terms)
-
-let clear_hyps_in_evi env evdref hyps concl ids =
- match clear_hyps_in_evi_main env evdref hyps [concl] ids with
- | (nhyps,[nconcl]) -> (nhyps,nconcl)
- | _ -> assert false
-
-let clear_hyps2_in_evi env evdref hyps t concl ids =
- match clear_hyps_in_evi_main env evdref hyps [t;concl] ids with
- | (nhyps,[t;nconcl]) -> (nhyps,t,nconcl)
- | _ -> assert false
-
-(* spiwack: a few functions to gather evars on which goals depend. *)
-let queue_set q is_dependent set =
- Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set
-let queue_term q is_dependent c =
- queue_set q is_dependent (evars_of_term c)
-
-let process_dependent_evar q acc evm is_dependent e =
- let evi = Evd.find evm e in
- (* Queues evars appearing in the types of the goal (conclusion, then
- hypotheses), they are all dependent. *)
- queue_term q true evi.evar_concl;
- List.iter begin fun (_,b,t) ->
- queue_term q true t;
- match b with
- | None -> ()
- | Some b -> queue_term q true b
- end (Environ.named_context_of_val evi.evar_hyps);
- match evi.evar_body with
- | Evar_empty ->
- if is_dependent then Evar.Map.add e None acc else acc
- | Evar_defined b ->
- let subevars = evars_of_term b in
- (* evars appearing in the definition of an evar [e] are marked
- as dependent when [e] is dependent itself: if [e] is a
- non-dependent goal, then, unless they are reach from another
- path, these evars are just other non-dependent goals. *)
- queue_set q is_dependent subevars;
- if is_dependent then Evar.Map.add e (Some subevars) acc else acc
-
-let gather_dependent_evars q evm =
- let acc = ref Evar.Map.empty in
- while not (Queue.is_empty q) do
- let (is_dependent,e) = Queue.pop q in
- (* checks if [e] has already been added to [!acc] *)
- begin if not (Evar.Map.mem e !acc) then
- acc := process_dependent_evar q !acc evm is_dependent e
- end
- done;
- !acc
-
-let gather_dependent_evars evm l =
- let q = Queue.create () in
- List.iter (fun a -> Queue.add (false,a) q) l;
- gather_dependent_evars q evm
-
-(* /spiwack *)
-
-(** The following functions return the set of undefined evars
- contained in the object, the defined evars being traversed.
- This is roughly a combination of the previous functions and
- [nf_evar]. *)
-
-let undefined_evars_of_term evd t =
- let rec evrec acc c =
- match kind_of_term c with
- | Evar (n, l) ->
- let acc = Array.fold_left evrec acc l in
- (try match (Evd.find evd n).evar_body with
- | Evar_empty -> Evar.Set.add n acc
- | Evar_defined c -> evrec acc c
- with Not_found -> anomaly ~label:"undefined_evars_of_term" (Pp.str "evar not found"))
- | _ -> fold_constr evrec acc c
- in
- evrec Evar.Set.empty t
-
-let undefined_evars_of_named_context evd nc =
- List.fold_right (fun (_, b, t) s ->
- Option.fold_left (fun s t ->
- Evar.Set.union s (undefined_evars_of_term evd t))
- (Evar.Set.union s (undefined_evars_of_term evd t)) b)
- nc Evar.Set.empty
-
-let undefined_evars_of_evar_info evd evi =
- Evar.Set.union (undefined_evars_of_term evd evi.evar_concl)
- (Evar.Set.union
- (match evi.evar_body with
- | Evar_empty -> Evar.Set.empty
- | Evar_defined b -> undefined_evars_of_term evd b)
- (undefined_evars_of_named_context evd
- (named_context_of_val evi.evar_hyps)))
-
-(* [check_evars] fails if some unresolved evar remains *)
-
-let check_evars env initial_sigma sigma c =
- let rec proc_rec c =
- match kind_of_term c with
- | Evar (evk,_ as ev) ->
- (match existential_opt_value sigma ev with
- | Some c -> proc_rec c
- | None ->
- if not (Evd.mem initial_sigma evk) then
- let (loc,k) = evar_source evk sigma in
- match k with
- | Evar_kinds.ImplicitArg (gr, (i, id), false) -> ()
- | _ -> error_unsolvable_implicit loc env sigma evk None)
- | _ -> iter_constr proc_rec c
- in proc_rec c
-
-(* spiwack: this is a more complete version of
- {!Termops.occur_evar}. The latter does not look recursively into an
- [evar_map]. If unification only need to check superficially, tactics
- do not have this luxury, and need the more complete version. *)
-let occur_evar_upto sigma n c =
- let rec occur_rec c = match kind_of_term c with
- | Evar (sp,_) when Evar.equal sp n -> raise Occur
- | Evar e -> Option.iter occur_rec (existential_opt_value sigma e)
- | _ -> iter_constr occur_rec c
- in
- try occur_rec c; false with Occur -> true
-
-
-(****************************************)
-(* Operations on value/type constraints *)
-(****************************************)
-
-type type_constraint = types option
-
-type val_constraint = constr option
-
-(* Old comment...
- * Basically, we have the following kind of constraints (in increasing
- * strength order):
- * (false,(None,None)) -> no constraint at all
- * (true,(None,None)) -> we must build a judgement which _TYPE is a kind
- * (_,(None,Some ty)) -> we must build a judgement which _TYPE is ty
- * (_,(Some v,_)) -> we must build a judgement which _VAL is v
- * Maybe a concrete datatype would be easier to understand.
- * We differentiate (true,(None,None)) from (_,(None,Some Type))
- * because otherwise Case(s) would be misled, as in
- * (n:nat) Case n of bool [_]nat end would infer the predicate Type instead
- * of Set.
- *)
-
-(* The empty type constraint *)
-let empty_tycon = None
-
-(* Builds a type constraint *)
-let mk_tycon ty = Some ty
-
-(* Constrains the value of a type *)
-let empty_valcon = None
-
-(* Builds a value constraint *)
-let mk_valcon c = Some c
-
-let idx = Namegen.default_dependent_ident
-
-(* Refining an evar to a product *)
-
-let define_pure_evar_as_product evd evk =
- let evi = Evd.find_undefined evd evk in
- let evenv = evar_env evi in
- let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in
- let concl = whd_betadeltaiota evenv evd evi.evar_concl in
- let s = destSort concl in
- let evd1,(dom,u1) =
- new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
- let evd2,rng =
- let newenv = push_named (id, None, dom) evenv in
- let src = evar_source evk evd1 in
- let filter = Filter.extend 1 (evar_filter evi) in
- if is_prop_sort s then
- (* Impredicative product, conclusion must fall in [Prop]. *)
- new_evar newenv evd1 concl ~src ~filter
- else
- let status = univ_flexible_alg in
- let evd3, (rng, srng) =
- new_type_evar newenv evd1 status ~src ~filter in
- let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in
- let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in
- evd3, rng
- in
- let prod = mkProd (Name id, dom, subst_var id rng) in
- let evd3 = Evd.define evk prod evd2 in
- evd3,prod
-
-(* Refine an applied evar to a product and returns its instantiation *)
-
-let define_evar_as_product evd (evk,args) =
- let evd,prod = define_pure_evar_as_product evd evk in
- (* Quick way to compute the instantiation of evk with args *)
- let na,dom,rng = destProd prod in
- let evdom = mkEvar (fst (destEvar dom), args) in
- let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
- let evrng = mkEvar (fst (destEvar rng), evrngargs) in
- evd,mkProd (na, evdom, evrng)
-
-(* Refine an evar with an abstraction
-
- I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where:
- - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y)
- or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B
- with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type
- - x1..xq,y:A |- ?e':B
-*)
-
-let define_pure_evar_as_lambda env evd evk =
- let evi = Evd.find_undefined evd evk in
- let evenv = evar_env evi in
- let typ = whd_betadeltaiota evenv evd (evar_concl evi) in
- let evd1,(na,dom,rng) = match kind_of_term typ with
- | Prod (na,dom,rng) -> (evd,(na,dom,rng))
- | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ
- | _ -> error_not_product_loc Loc.ghost env evd typ in
- let avoid = ids_of_named_context (evar_context evi) in
- let id =
- next_name_away_with_default_using_types "x" na avoid (whd_evar evd dom) in
- let newenv = push_named (id, None, dom) evenv in
- let filter = Filter.extend 1 (evar_filter evi) in
- let src = evar_source evk evd1 in
- let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
- let lam = mkLambda (Name id, dom, subst_var id body) in
- Evd.define evk lam evd2, lam
-
-let define_evar_as_lambda env evd (evk,args) =
- let evd,lam = define_pure_evar_as_lambda env evd evk in
- (* Quick way to compute the instantiation of evk with args *)
- let na,dom,body = destLambda lam in
- let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
- let evbody = mkEvar (fst (destEvar body), evbodyargs) in
- evd,mkLambda (na, dom, evbody)
-
-let rec evar_absorb_arguments env evd (evk,args as ev) = function
- | [] -> evd,ev
- | a::l ->
- (* TODO: optimize and avoid introducing intermediate evars *)
- let evd,lam = define_pure_evar_as_lambda env evd evk in
- let _,_,body = destLambda lam in
- let evk = fst (destEvar body) in
- evar_absorb_arguments env evd (evk, Array.cons a args) l
-
-(* Refining an evar to a sort *)
-
-let define_evar_as_sort env evd (ev,args) =
- let evd, u = new_univ_variable univ_rigid evd in
- let evi = Evd.find_undefined evd ev in
- let s = Type u in
- let concl = whd_betadeltaiota (evar_env evi) evd evi.evar_concl in
- let sort = destSort concl in
- let evd' = Evd.define ev (mkSort s) evd in
- Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s
-
-(* We don't try to guess in which sort the type should be defined, since
- any type has type Type. May cause some trouble, but not so far... *)
-
-let judge_of_new_Type evd =
- let evd', s = new_univ_variable univ_rigid evd in
- evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }
-
-(* Propagation of constraints through application and abstraction:
- Given a type constraint on a functional term, returns the type
- constraint on its domain and codomain. If the input constraint is
- an evar instantiate it with the product of 2 new evars. *)
-
-let split_tycon loc env evd tycon =
- let rec real_split evd c =
- let t = whd_betadeltaiota env evd c in
- match kind_of_term t with
- | Prod (na,dom,rng) -> evd, (na, dom, rng)
- | Evar ev (* ev is undefined because of whd_betadeltaiota *) ->
- let (evd',prod) = define_evar_as_product evd ev in
- let (_,dom,rng) = destProd prod in
- evd',(Anonymous, dom, rng)
- | App (c,args) when isEvar c ->
- let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in
- real_split evd' (mkApp (lam,args))
- | _ -> error_not_product_loc loc env evd c
- in
- match tycon with
- | None -> evd,(Anonymous,None,None)
- | Some c ->
- let evd', (n, dom, rng) = real_split evd c in
- evd', (n, mk_tycon dom, mk_tycon rng)
-
-let valcon_of_tycon x = x
-let lift_tycon n = Option.map (lift n)
-
-let pr_tycon env = function
- None -> str "None"
- | Some t -> Termops.print_constr_env env t
-
-let subterm_source evk (loc,k) =
- let evk = match k with
- | Evar_kinds.SubEvar (evk) -> evk
- | _ -> evk in
- (loc,Evar_kinds.SubEvar evk)
-
-
-(** Term exploration up to instantiation. *)
-let kind_of_term_upto sigma t =
- Constr.kind (Reductionops.whd_evar sigma t)
-
-(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and
- [u] up to existential variable instantiation and equalisable
- universes. The term [t] is interpreted in [sigma1] while [u] is
- interpreted in [sigma2]. The universe constraints in [sigma2] are
- assumed to be an extention of those in [sigma1]. *)
-let eq_constr_univs_test sigma1 sigma2 t u =
- (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *)
- let open Evd in
- let b, c =
- Universes.eq_constr_univs_infer_with
- (fun t -> kind_of_term_upto sigma1 t)
- (fun u -> kind_of_term_upto sigma2 u)
- (universes sigma2) t u
- in
- if b then
- try let _ = add_universe_constraints sigma2 c in true
- with Univ.UniverseInconsistency _ | UniversesDiffer -> false
- else false
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
deleted file mode 100644
index f68651a7..00000000
--- a/pretyping/evarutil.mli
+++ /dev/null
@@ -1,255 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* metavariable
-val mk_new_meta : unit -> constr
-
-(** {6 Creating a fresh evar given their type and context} *)
-val new_evar :
- env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
- ?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr ->
- ?principal:bool -> types -> evar_map * constr
-
-val new_pure_evar :
- named_context_val -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
- ?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr ->
- ?principal:bool -> types -> evar_map * evar
-
-val new_pure_evar_full : evar_map -> evar_info -> evar_map * evar
-
-(** the same with side-effects *)
-val e_new_evar :
- env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
- ?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr ->
- ?principal:bool -> types -> constr
-
-(** Create a new Type existential variable, as we keep track of
- them during type-checking and unification. *)
-val new_type_evar :
- env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
- ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid ->
- evar_map * (constr * sorts)
-
-val e_new_type_evar : env -> evar_map ref ->
- ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
- ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts
-
-val new_Type : ?rigid:rigid -> env -> evar_map -> evar_map * constr
-val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr
-
-val restrict_evar : evar_map -> existential_key -> Filter.t ->
- constr list option -> evar_map * existential_key
-
-(** Polymorphic constants *)
-
-val new_global : evar_map -> Globnames.global_reference -> evar_map * constr
-val e_new_global : evar_map ref -> Globnames.global_reference -> constr
-
-(** Create a fresh evar in a context different from its definition context:
- [new_evar_instance sign evd ty inst] creates a new evar of context
- [sign] and type [ty], [inst] is a mapping of the evar context to
- the context where the evar should occur. This means that the terms
- of [inst] are typed in the occurrence context and their type (seen
- as a telescope) is [sign] *)
-val new_evar_instance :
- named_context_val -> evar_map -> types ->
- ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list ->
- ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr ->
- ?principal:bool ->
- constr list -> evar_map * constr
-
-val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list
-
-(** {6 Evars/Metas switching...} *)
-
-val non_instantiated : evar_map -> evar_info Evar.Map.t
-
-(** {6 Unification utils} *)
-
-(** [head_evar c] returns the head evar of [c] if any *)
-exception NoHeadEvar
-val head_evar : constr -> existential_key (** may raise NoHeadEvar *)
-
-(* Expand head evar if any *)
-val whd_head_evar : evar_map -> constr -> constr
-
-(* An over-approximation of [has_undefined (nf_evars evd c)] *)
-val has_undefined_evars : evar_map -> constr -> bool
-
-val is_ground_term : evar_map -> constr -> bool
-val is_ground_env : evar_map -> env -> bool
-(** [check_evars env initial_sigma extended_sigma c] fails if some
- new unresolved evar remains in [c] *)
-val check_evars : env -> evar_map -> evar_map -> constr -> unit
-
-val define_evar_as_product : evar_map -> existential -> evar_map * types
-val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types
-val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts
-
-(** Instantiate an evar by as many lambda's as needed so that its arguments
- are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into
- [?y[vars1:=args1,vars:=args]] with
- [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *)
-val evar_absorb_arguments : env -> evar_map -> existential -> constr list ->
- evar_map * existential
-
-(** [gather_dependent_evars evm seeds] classifies the evars in [evm]
- as dependent_evars and goals (these may overlap). A goal is an
- evar in [seeds] or an evar appearing in the (partial) definition
- of a goal. A dependent evar is an evar appearing in the type
- (hypotheses and conclusion) of a goal, or in the type or (partial)
- definition of a dependent evar. The value return is a map
- associating to each dependent evar [None] if it has no (partial)
- definition or [Some s] if [s] is the list of evars appearing in
- its (partial) definition. *)
-val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.Map.t
-
-(** The following functions return the set of undefined evars
- contained in the object, the defined evars being traversed.
- This is roughly a combination of the previous functions and
- [nf_evar]. *)
-
-val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t
-val undefined_evars_of_named_context : evar_map -> named_context -> Evar.Set.t
-val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t
-
-(** [occur_evar_upto sigma k c] returns [true] if [k] appears in
- [c]. It looks up recursively in [sigma] for the value of existential
- variables. *)
-val occur_evar_upto : evar_map -> Evar.t -> Constr.t -> bool
-
-(** {6 Value/Type constraints} *)
-
-val judge_of_new_Type : evar_map -> evar_map * unsafe_judgment
-
-type type_constraint = types option
-type val_constraint = constr option
-
-val empty_tycon : type_constraint
-val mk_tycon : constr -> type_constraint
-val empty_valcon : val_constraint
-val mk_valcon : constr -> val_constraint
-
-val split_tycon :
- Loc.t -> env -> evar_map -> type_constraint ->
- evar_map * (Name.t * type_constraint * type_constraint)
-
-val valcon_of_tycon : type_constraint -> val_constraint
-val lift_tycon : int -> type_constraint -> type_constraint
-
-(***********************************************************)
-
-(** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains
- uninstantiated; [nf_evar] leaves uninstantiated evars as is *)
-
-val nf_evar : evar_map -> constr -> constr
-val j_nf_evar : evar_map -> unsafe_judgment -> unsafe_judgment
-val jl_nf_evar :
- evar_map -> unsafe_judgment list -> unsafe_judgment list
-val jv_nf_evar :
- evar_map -> unsafe_judgment array -> unsafe_judgment array
-val tj_nf_evar :
- evar_map -> unsafe_type_judgment -> unsafe_type_judgment
-
-val nf_named_context_evar : evar_map -> named_context -> named_context
-val nf_rel_context_evar : evar_map -> rel_context -> rel_context
-val nf_env_evar : evar_map -> env -> env
-
-val nf_evar_info : evar_map -> evar_info -> evar_info
-val nf_evar_map : evar_map -> evar_map
-val nf_evar_map_undefined : evar_map -> evar_map
-
-val env_nf_evar : evar_map -> env -> env
-val env_nf_betaiotaevar : evar_map -> env -> env
-
-val j_nf_betaiotaevar : evar_map -> unsafe_judgment -> unsafe_judgment
-val jv_nf_betaiotaevar :
- evar_map -> unsafe_judgment array -> unsafe_judgment array
-(** Presenting terms without solved evars *)
-
-val nf_evars_universes : evar_map -> constr -> constr
-
-val nf_evars_and_universes : evar_map -> evar_map * (constr -> constr)
-val e_nf_evars_and_universes : evar_map ref -> (constr -> constr) * Universes.universe_opt_subst
-
-(** Normalize the evar map w.r.t. universes, after simplification of constraints.
- Return the substitution function for constrs as well. *)
-val nf_evar_map_universes : evar_map -> evar_map * (constr -> constr)
-
-(** Replacing all evars, possibly raising [Uninstantiated_evar] *)
-exception Uninstantiated_evar of existential_key
-val flush_and_check_evars : evar_map -> constr -> constr
-
-(** {6 Term manipulation up to instantiation} *)
-
-(** Like {!Constr.kind} except that [kind_of_term sigma t] exposes [t]
- as an evar [e] only if [e] is uninstantiated in [sigma]. Otherwise the
- value of [e] in [sigma] is (recursively) used. *)
-val kind_of_term_upto : evar_map -> constr -> (constr,types) kind_of_term
-
-(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and
- [u] up to existential variable instantiation and equalisable
- universes. The term [t] is interpreted in [sigma1] while [u] is
- interpreted in [sigma2]. The universe constraints in [sigma2] are
- assumed to be an extention of those in [sigma1]. *)
-val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool
-
-(** {6 debug pretty-printer:} *)
-
-val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
-
-
-(** {6 Removing hyps in evars'context}
-raise OccurHypInSimpleClause if the removal breaks dependencies *)
-
-type clear_dependency_error =
-| OccurHypInSimpleClause of Id.t option
-| EvarTypingBreak of existential
-
-exception ClearDependencyError of Id.t * clear_dependency_error
-
-(* spiwack: marks an evar that has been "defined" by clear.
- used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*)
-val cleared : bool Store.field
-
-val clear_hyps_in_evi : env -> evar_map ref -> named_context_val -> types ->
- Id.Set.t -> named_context_val * types
-
-val clear_hyps2_in_evi : env -> evar_map ref -> named_context_val -> types -> types ->
- Id.Set.t -> named_context_val * types * types
-
-val push_rel_context_to_named_context : Environ.env -> types ->
- named_context_val * types * constr list * constr list * (identifier*constr) list
-
-val generalize_evar_over_rels : evar_map -> existential -> types * constr list
-
-(** Evar combinators *)
-
-val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a
-val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a
-val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a
-
-val subterm_source : existential_key -> Evar_kinds.t Loc.located ->
- Evar_kinds.t Loc.located
-
-val meta_counter_summary_name : string
-val evar_counter_summary_name : string
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
deleted file mode 100644
index 01083142..00000000
--- a/pretyping/evd.ml
+++ /dev/null
@@ -1,1908 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* t -> bool
- val identity : t
- val filter_list : t -> 'a list -> 'a list
- val filter_array : t -> 'a array -> 'a array
- val extend : int -> t -> t
- val compose : t -> t -> t
- val apply_subfilter : t -> bool list -> t
- val restrict_upon : t -> int -> (int -> bool) -> t option
- val map_along : (bool -> 'a -> bool) -> t -> 'a list -> t
- val make : bool list -> t
- val repr : t -> bool list option
-end =
-struct
- type t = bool list option
- (** We guarantee through the interface that if a filter is [Some _] then it
- contains at least one [false] somewhere. *)
-
- let identity = None
-
- let rec equal l1 l2 = match l1, l2 with
- | [], [] -> true
- | h1 :: l1, h2 :: l2 ->
- (if h1 then h2 else not h2) && equal l1 l2
- | _ -> false
-
- let equal l1 l2 = match l1, l2 with
- | None, None -> true
- | Some _, None | None, Some _ -> false
- | Some l1, Some l2 -> equal l1 l2
-
- let rec is_identity = function
- | [] -> true
- | true :: l -> is_identity l
- | false :: _ -> false
-
- let normalize f = if is_identity f then None else Some f
-
- let filter_list f l = match f with
- | None -> l
- | Some f -> CList.filter_with f l
-
- let filter_array f v = match f with
- | None -> v
- | Some f -> CArray.filter_with f v
-
- let rec extend n l =
- if n = 0 then l
- else extend (pred n) (true :: l)
-
- let extend n = function
- | None -> None
- | Some f -> Some (extend n f)
-
- let compose f1 f2 = match f1 with
- | None -> f2
- | Some f1 ->
- match f2 with
- | None -> None
- | Some f2 -> normalize (CList.filter_with f1 f2)
-
- let apply_subfilter_array filter subfilter =
- (** In both cases we statically know that the argument will contain at
- least one [false] *)
- match filter with
- | None -> Some (Array.to_list subfilter)
- | Some f ->
- let len = Array.length subfilter in
- let fold b (i, ans) =
- if b then
- let () = assert (0 <= i) in
- (pred i, Array.unsafe_get subfilter i :: ans)
- else
- (i, false :: ans)
- in
- Some (snd (List.fold_right fold f (pred len, [])))
-
- let apply_subfilter filter subfilter =
- apply_subfilter_array filter (Array.of_list subfilter)
-
- let restrict_upon f len p =
- let newfilter = Array.init len p in
- if Array.for_all (fun id -> id) newfilter then None
- else
- Some (apply_subfilter_array f newfilter)
-
- let map_along f flt l =
- let ans = match flt with
- | None -> List.map (fun x -> f true x) l
- | Some flt -> List.map2 f flt l
- in
- normalize ans
-
- let make l = normalize l
-
- let repr f = f
-
-end
-
-(* The kinds of existential variables are now defined in [Evar_kinds] *)
-
-(* The type of mappings for existential variables *)
-
-module Dummy = struct end
-module Store = Store.Make(Dummy)
-
-type evar = Term.existential_key
-
-let string_of_existential evk = "?X" ^ string_of_int (Evar.repr evk)
-
-type evar_body =
- | Evar_empty
- | Evar_defined of constr
-
-type evar_info = {
- evar_concl : constr;
- evar_hyps : named_context_val;
- evar_body : evar_body;
- evar_filter : Filter.t;
- evar_source : Evar_kinds.t Loc.located;
- evar_candidates : constr list option; (* if not None, list of allowed instances *)
- evar_extra : Store.t }
-
-let make_evar hyps ccl = {
- evar_concl = ccl;
- evar_hyps = hyps;
- evar_body = Evar_empty;
- evar_filter = Filter.identity;
- evar_source = (Loc.ghost,Evar_kinds.InternalHole);
- evar_candidates = None;
- evar_extra = Store.empty
-}
-
-let instance_mismatch () =
- anomaly (Pp.str "Signature and its instance do not match")
-
-let evar_concl evi = evi.evar_concl
-
-let evar_filter evi = evi.evar_filter
-
-let evar_body evi = evi.evar_body
-
-let evar_context evi = named_context_of_val evi.evar_hyps
-
-let evar_filtered_context evi =
- Filter.filter_list (evar_filter evi) (evar_context evi)
-
-let evar_hyps evi = evi.evar_hyps
-
-let evar_filtered_hyps evi = match Filter.repr (evar_filter evi) with
-| None -> evar_hyps evi
-| Some filter ->
- let rec make_hyps filter ctxt = match filter, ctxt with
- | [], [] -> empty_named_context_val
- | false :: filter, _ :: ctxt -> make_hyps filter ctxt
- | true :: filter, decl :: ctxt ->
- let hyps = make_hyps filter ctxt in
- push_named_context_val decl hyps
- | _ -> instance_mismatch ()
- in
- make_hyps filter (evar_context evi)
-
-let evar_env evi = Global.env_of_context evi.evar_hyps
-
-let evar_filtered_env evi = match Filter.repr (evar_filter evi) with
-| None -> evar_env evi
-| Some filter ->
- let rec make_env filter ctxt = match filter, ctxt with
- | [], [] -> reset_context (Global.env ())
- | false :: filter, _ :: ctxt -> make_env filter ctxt
- | true :: filter, decl :: ctxt ->
- let env = make_env filter ctxt in
- push_named decl env
- | _ -> instance_mismatch ()
- in
- make_env filter (evar_context evi)
-
-let map_evar_body f = function
- | Evar_empty -> Evar_empty
- | Evar_defined d -> Evar_defined (f d)
-
-let map_evar_info f evi =
- {evi with
- evar_body = map_evar_body f evi.evar_body;
- evar_hyps = map_named_val f evi.evar_hyps;
- evar_concl = f evi.evar_concl;
- evar_candidates = Option.map (List.map f) evi.evar_candidates }
-
-let evar_ident_info evi =
- match evi.evar_source with
- | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id
- | _,Evar_kinds.VarInstance id -> id
- | _,Evar_kinds.GoalEvar -> Id.of_string "Goal"
- | _ ->
- let env = reset_with_named_context evi.evar_hyps (Global.env()) in
- Namegen.id_of_name_using_hdchar env evi.evar_concl Anonymous
-
-(* This exception is raised by *.existential_value *)
-exception NotInstantiatedEvar
-
-(* Note: let-in contributes to the instance *)
-
-let evar_instance_array test_id info args =
- let len = Array.length args in
- let rec instrec filter ctxt i = match filter, ctxt with
- | [], [] ->
- if Int.equal i len then []
- else instance_mismatch ()
- | false :: filter, _ :: ctxt ->
- instrec filter ctxt i
- | true :: filter, (id,_,_ as d) :: ctxt ->
- if i < len then
- let c = Array.unsafe_get args i in
- if test_id d c then instrec filter ctxt (succ i)
- else (id, c) :: instrec filter ctxt (succ i)
- else instance_mismatch ()
- | _ -> instance_mismatch ()
- in
- match Filter.repr (evar_filter info) with
- | None ->
- let map i (id,_,_ as d) =
- if (i < len) then
- let c = Array.unsafe_get args i in
- if test_id d c then None else Some (id,c)
- else instance_mismatch ()
- in
- List.map_filter_i map (evar_context info)
- | Some filter ->
- instrec filter (evar_context info) 0
-
-let make_evar_instance_array info args =
- evar_instance_array (fun (id,_,_) -> isVarId id) info args
-
-let instantiate_evar_array info c args =
- let inst = make_evar_instance_array info args in
- match inst with
- | [] -> c
- | _ -> replace_vars inst c
-
-module StringOrd = struct type t = string let compare = String.compare end
-module UNameMap = struct
-
- include Map.Make(StringOrd)
-
- let union s t =
- if s == t then s
- else
- merge (fun k l r ->
- match l, r with
- | Some _, _ -> l
- | _, _ -> r) s t
-end
-
-(* 2nd part used to check consistency on the fly. *)
-type evar_universe_context =
- { uctx_names : Univ.Level.t UNameMap.t * string Univ.LMap.t;
- uctx_local : Univ.universe_context_set; (** The local context of variables *)
- uctx_univ_variables : Universes.universe_opt_subst;
- (** The local universes that are unification variables *)
- uctx_univ_algebraic : Univ.universe_set;
- (** The subset of unification variables that can be instantiated with
- algebraic universes as they appear in inferred types only. *)
- uctx_universes : Univ.universes; (** The current graph extended with the local constraints *)
- uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *)
- }
-
-let empty_evar_universe_context =
- { uctx_names = UNameMap.empty, Univ.LMap.empty;
- uctx_local = Univ.ContextSet.empty;
- uctx_univ_variables = Univ.LMap.empty;
- uctx_univ_algebraic = Univ.LSet.empty;
- uctx_universes = Univ.initial_universes;
- uctx_initial_universes = Univ.initial_universes }
-
-let evar_universe_context_from e =
- let u = universes e in
- {empty_evar_universe_context with
- uctx_universes = u; uctx_initial_universes = u}
-
-let is_empty_evar_universe_context ctx =
- Univ.ContextSet.is_empty ctx.uctx_local &&
- Univ.LMap.is_empty ctx.uctx_univ_variables
-
-let union_evar_universe_context ctx ctx' =
- if ctx == ctx' then ctx
- else if is_empty_evar_universe_context ctx' then ctx
- else
- let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in
- let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in
- let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local)
- (Univ.ContextSet.levels ctx.uctx_local) in
- let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in
- let declarenew g =
- Univ.LSet.fold (fun u g -> Univ.add_universe u false g) newus g
- in
- let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in
- { uctx_names = (names, names_rev);
- uctx_local = local;
- uctx_univ_variables =
- Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables;
- uctx_univ_algebraic =
- Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic;
- uctx_initial_universes = declarenew ctx.uctx_initial_universes;
- uctx_universes =
- if local == ctx.uctx_local then ctx.uctx_universes
- else
- let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in
- Univ.merge_constraints cstrsr (declarenew ctx.uctx_universes) }
-
-(* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *)
-(* let union_evar_universe_context = *)
-(* Profile.profile2 union_evar_universe_context_key union_evar_universe_context;; *)
-
-type 'a in_evar_universe_context = 'a * evar_universe_context
-
-let evar_universe_context_set diff ctx =
- let initctx = ctx.uctx_local in
- let cstrs =
- Univ.LSet.fold
- (fun l cstrs ->
- try
- match Univ.LMap.find l ctx.uctx_univ_variables with
- | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs
- | None -> cstrs
- with Not_found | Option.IsNone -> cstrs)
- (Univ.Instance.levels (Univ.UContext.instance diff)) Univ.Constraint.empty
- in
- Univ.ContextSet.add_constraints cstrs initctx
-
-let evar_universe_context_constraints ctx = snd ctx.uctx_local
-let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_local
-
-let evar_universe_context_of ctx = { empty_evar_universe_context with uctx_local = ctx }
-let evar_universe_context_subst ctx = ctx.uctx_univ_variables
-
-let add_uctx_names s l (names, names_rev) =
- (UNameMap.add s l names, Univ.LMap.add l s names_rev)
-
-let evar_universe_context_of_binders b =
- let ctx = empty_evar_universe_context in
- let names =
- List.fold_left (fun acc (id, l) -> add_uctx_names (Id.to_string id) l acc)
- ctx.uctx_names b
- in { ctx with uctx_names = names }
-
-let instantiate_variable l b v =
- v := Univ.LMap.add l (Some b) !v
-
-exception UniversesDiffer
-
-let process_universe_constraints univs vars alg cstrs =
- let vars = ref vars in
- let normalize = Universes.normalize_universe_opt_subst vars in
- let rec unify_universes fo l d r local =
- let l = normalize l and r = normalize r in
- if Univ.Universe.equal l r then local
- else
- let varinfo x =
- match Univ.Universe.level x with
- | None -> Inl x
- | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg)
- in
- if d == Universes.ULe then
- if Univ.check_leq univs l r then
- (** Keep Prop/Set <= var around if var might be instantiated by prop or set
- later. *)
- if Univ.Universe.is_level l then
- match Univ.Universe.level r with
- | Some r ->
- Univ.Constraint.add (Option.get (Univ.Universe.level l),Univ.Le,r) local
- | _ -> local
- else local
- else
- match Univ.Universe.level r with
- | None -> error ("Algebraic universe on the right")
- | Some rl ->
- if Univ.Level.is_small rl then
- let levels = Univ.Universe.levels l in
- Univ.LSet.fold (fun l local ->
- if Univ.Level.is_small l || Univ.LMap.mem l !vars then
- unify_universes fo (Univ.Universe.make l) Universes.UEq r local
- else raise (Univ.UniverseInconsistency (Univ.Le, Univ.Universe.make l, r, None)))
- levels local
- else
- Univ.enforce_leq l r local
- else if d == Universes.ULub then
- match varinfo l, varinfo r with
- | (Inr (l, true, _), Inr (r, _, _))
- | (Inr (r, _, _), Inr (l, true, _)) ->
- instantiate_variable l (Univ.Universe.make r) vars;
- Univ.enforce_eq_level l r local
- | Inr (_, _, _), Inr (_, _, _) ->
- unify_universes true l Universes.UEq r local
- | _, _ -> assert false
- else (* d = Universes.UEq *)
- match varinfo l, varinfo r with
- | Inr (l', lloc, _), Inr (r', rloc, _) ->
- let () =
- if lloc then
- instantiate_variable l' r vars
- else if rloc then
- instantiate_variable r' l vars
- else if not (Univ.check_eq univs l r) then
- (* Two rigid/global levels, none of them being local,
- one of them being Prop/Set, disallow *)
- if Univ.Level.is_small l' || Univ.Level.is_small r' then
- raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None))
- else
- if fo then
- raise UniversesDiffer
- in
- Univ.enforce_eq_level l' r' local
- | Inr (l, loc, alg), Inl r
- | Inl r, Inr (l, loc, alg) ->
- let inst = Univ.univ_level_rem l r r in
- if alg then (instantiate_variable l inst vars; local)
- else
- let lu = Univ.Universe.make l in
- if Univ.univ_level_mem l r then
- Univ.enforce_leq inst lu local
- else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None))
- | _, _ (* One of the two is algebraic or global *) ->
- if Univ.check_eq univs l r then local
- else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None))
- in
- let local =
- Universes.Constraints.fold (fun (l,d,r) local -> unify_universes false l d r local)
- cstrs Univ.Constraint.empty
- in
- !vars, local
-
-let add_constraints_context ctx cstrs =
- let univs, local = ctx.uctx_local in
- let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc ->
- let l = Univ.Universe.make l and r = Univ.Universe.make r in
- let cstr' =
- if d == Univ.Lt then (Univ.Universe.super l, Universes.ULe, r)
- else (l, (if d == Univ.Le then Universes.ULe else Universes.UEq), r)
- in Universes.Constraints.add cstr' acc)
- cstrs Universes.Constraints.empty
- in
- let vars, local' =
- process_universe_constraints ctx.uctx_universes
- ctx.uctx_univ_variables ctx.uctx_univ_algebraic
- cstrs'
- in
- { ctx with uctx_local = (univs, Univ.Constraint.union local local');
- uctx_univ_variables = vars;
- uctx_universes = Univ.merge_constraints local' ctx.uctx_universes }
-
-(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *)
-(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *)
-
-let add_universe_constraints_context ctx cstrs =
- let univs, local = ctx.uctx_local in
- let vars, local' =
- process_universe_constraints ctx.uctx_universes
- ctx.uctx_univ_variables ctx.uctx_univ_algebraic
- cstrs
- in
- { ctx with uctx_local = (univs, Univ.Constraint.union local local');
- uctx_univ_variables = vars;
- uctx_universes = Univ.merge_constraints local' ctx.uctx_universes }
-
-(* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *)
-(* let add_universe_constraints_context = *)
-(* Profile.profile2 addunivconstrkey add_universe_constraints_context;; *)
-(*******************************************************************)
-(* Metamaps *)
-
-(*******************************************************************)
-(* Constraints for existential variables *)
-(*******************************************************************)
-
-type 'a freelisted = {
- rebus : 'a;
- freemetas : Int.Set.t }
-
-(* Collects all metavars appearing in a constr *)
-let metavars_of c =
- let rec collrec acc c =
- match kind_of_term c with
- | Meta mv -> Int.Set.add mv acc
- | _ -> fold_constr collrec acc c
- in
- collrec Int.Set.empty c
-
-let mk_freelisted c =
- { rebus = c; freemetas = metavars_of c }
-
-let map_fl f cfl = { cfl with rebus=f cfl.rebus }
-
-(* Status of an instance found by unification wrt to the meta it solves:
- - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X)
- - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X)
- - a term that can be eta-expanded n times while still being a solution
- (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice)
-*)
-
-type instance_constraint = IsSuperType | IsSubType | Conv
-
-let eq_instance_constraint c1 c2 = c1 == c2
-
-(* Status of the unification of the type of an instance against the type of
- the meta it instantiates:
- - CoerceToType means that the unification of types has not been done
- and that a coercion can still be inserted: the meta should not be
- substituted freely (this happens for instance given via the
- "with" binding clause).
- - TypeProcessed means that the information obtainable from the
- unification of types has been extracted.
- - TypeNotProcessed means that the unification of types has not been
- done but it is known that no coercion may be inserted: the meta
- can be substituted freely.
-*)
-
-type instance_typing_status =
- CoerceToType | TypeNotProcessed | TypeProcessed
-
-(* Status of an instance together with the status of its type unification *)
-
-type instance_status = instance_constraint * instance_typing_status
-
-(* Clausal environments *)
-
-type clbinding =
- | Cltyp of Name.t * constr freelisted
- | Clval of Name.t * (constr freelisted * instance_status) * constr freelisted
-
-let map_clb f = function
- | Cltyp (na,cfl) -> Cltyp (na,map_fl f cfl)
- | Clval (na,(cfl1,pb),cfl2) -> Clval (na,(map_fl f cfl1,pb),map_fl f cfl2)
-
-(* name of defined is erased (but it is pretty-printed) *)
-let clb_name = function
- Cltyp(na,_) -> (na,false)
- | Clval (na,_,_) -> (na,true)
-
-(***********************)
-
-module Metaset = Int.Set
-
-module Metamap = Int.Map
-
-let metamap_to_list m =
- Metamap.fold (fun n v l -> (n,v)::l) m []
-
-(*************************)
-(* Unification state *)
-
-type conv_pb = Reduction.conv_pb
-type evar_constraint = conv_pb * Environ.env * constr * constr
-
-module EvMap = Evar.Map
-
-type evar_map = {
- (** Existential variables *)
- defn_evars : evar_info EvMap.t;
- undf_evars : evar_info EvMap.t;
- evar_names : Id.t EvMap.t * existential_key Idmap.t;
- (** Universes *)
- universes : evar_universe_context;
- (** Conversion problems *)
- conv_pbs : evar_constraint list;
- last_mods : Evar.Set.t;
- (** Metas *)
- metas : clbinding Metamap.t;
- (** Interactive proofs *)
- effects : Safe_typing.private_constants;
- future_goals : Evar.t list; (** list of newly created evars, to be
- eventually turned into goals if not solved.*)
- principal_future_goal : Evar.t option; (** if [Some e], [e] must be
- contained
- [future_goals]. The evar
- [e] will inherit
- properties (now: the
- name) of the evar which
- will be instantiated with
- a term containing [e]. *)
- extras : Store.t;
-}
-
-(*** Lifting primitive from Evar.Map. ***)
-
-let add_name_newly_undefined naming evk evi (evtoid,idtoev) =
- let id = match naming with
- | Misctypes.IntroAnonymous ->
- let id = evar_ident_info evi in
- Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev)
- | Misctypes.IntroIdentifier id ->
- let id' =
- Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in
- if not (Names.Id.equal id id') then
- user_err_loc
- (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id);
- id'
- | Misctypes.IntroFresh id ->
- Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in
- (EvMap.add evk id evtoid, Idmap.add id evk idtoev)
-
-let add_name_undefined naming evk evi (evtoid,idtoev as evar_names) =
- if EvMap.mem evk evtoid then
- evar_names
- else
- add_name_newly_undefined naming evk evi evar_names
-
-let remove_name_defined evk (evtoid,idtoev) =
- let id = EvMap.find evk evtoid in
- (EvMap.remove evk evtoid, Idmap.remove id idtoev)
-
-let remove_name_possibly_already_defined evk evar_names =
- try remove_name_defined evk evar_names
- with Not_found -> evar_names
-
-let rename evk id evd =
- let (evtoid,idtoev) = evd.evar_names in
- let id' = EvMap.find evk evtoid in
- if Idmap.mem id idtoev then anomaly (str "Evar name already in use");
- { evd with evar_names =
- (EvMap.add evk id evtoid (* overwrite old name *),
- Idmap.add id evk (Idmap.remove id' idtoev)) }
-
-let reassign_name_defined evk evk' (evtoid,idtoev) =
- let id = EvMap.find evk evtoid in
- (EvMap.add evk' id (EvMap.remove evk evtoid),
- Idmap.add id evk' (Idmap.remove id idtoev))
-
-let add d e i = match i.evar_body with
-| Evar_empty ->
- let evar_names = add_name_undefined Misctypes.IntroAnonymous e i d.evar_names in
- { d with undf_evars = EvMap.add e i d.undf_evars; evar_names }
-| Evar_defined _ ->
- let evar_names = remove_name_possibly_already_defined e d.evar_names in
- { d with defn_evars = EvMap.add e i d.defn_evars; evar_names }
-
-let remove d e =
- let undf_evars = EvMap.remove e d.undf_evars in
- let defn_evars = EvMap.remove e d.defn_evars in
- let principal_future_goal = match d.principal_future_goal with
- | None -> None
- | Some e' -> if Evar.equal e e' then None else d.principal_future_goal
- in
- let future_goals = List.filter (fun e' -> not (Evar.equal e e')) d.future_goals in
- { d with undf_evars; defn_evars; principal_future_goal; future_goals }
-
-let find d e =
- try EvMap.find e d.undf_evars
- with Not_found -> EvMap.find e d.defn_evars
-
-let find_undefined d e = EvMap.find e d.undf_evars
-
-let mem d e = EvMap.mem e d.undf_evars || EvMap.mem e d.defn_evars
-
-(* spiwack: this function loses information from the original evar_map
- it might be an idea not to export it. *)
-let to_list d =
- (* Workaround for change in Map.fold behavior in ocaml 3.08.4 *)
- let l = ref [] in
- EvMap.iter (fun evk x -> l := (evk,x)::!l) d.defn_evars;
- EvMap.iter (fun evk x -> l := (evk,x)::!l) d.undf_evars;
- !l
-
-let undefined_map d = d.undf_evars
-
-let drop_all_defined d = { d with defn_evars = EvMap.empty }
-
-(* spiwack: not clear what folding over an evar_map, for now we shall
- simply fold over the inner evar_map. *)
-let fold f d a =
- EvMap.fold f d.defn_evars (EvMap.fold f d.undf_evars a)
-
-let fold_undefined f d a = EvMap.fold f d.undf_evars a
-
-let raw_map f d =
- let f evk info =
- let ans = f evk info in
- let () = match info.evar_body, ans.evar_body with
- | Evar_defined _, Evar_empty
- | Evar_empty, Evar_defined _ ->
- anomaly (str "Unrespectful mapping function.")
- | _ -> ()
- in
- ans
- in
- let defn_evars = EvMap.smartmapi f d.defn_evars in
- let undf_evars = EvMap.smartmapi f d.undf_evars in
- { d with defn_evars; undf_evars; }
-
-let raw_map_undefined f d =
- let f evk info =
- let ans = f evk info in
- let () = match ans.evar_body with
- | Evar_defined _ ->
- anomaly (str "Unrespectful mapping function.")
- | _ -> ()
- in
- ans
- in
- { d with undf_evars = EvMap.smartmapi f d.undf_evars; }
-
-let is_evar = mem
-
-let is_defined d e = EvMap.mem e d.defn_evars
-
-let is_undefined d e = EvMap.mem e d.undf_evars
-
-let existential_value d (n, args) =
- let info = find d n in
- match evar_body info with
- | Evar_defined c ->
- instantiate_evar_array info c args
- | Evar_empty ->
- raise NotInstantiatedEvar
-
-let existential_opt_value d ev =
- try Some (existential_value d ev)
- with NotInstantiatedEvar -> None
-
-let existential_type d (n, args) =
- let info =
- try find d n
- with Not_found ->
- anomaly (str "Evar " ++ str (string_of_existential n) ++ str " was not declared") in
- instantiate_evar_array info info.evar_concl args
-
-let add_constraints d c =
- { d with universes = add_constraints_context d.universes c }
-
-let add_universe_constraints d c =
- { d with universes = add_universe_constraints_context d.universes c }
-
-(*** /Lifting... ***)
-
-(* evar_map are considered empty disregarding histories *)
-let is_empty d =
- EvMap.is_empty d.defn_evars &&
- EvMap.is_empty d.undf_evars &&
- List.is_empty d.conv_pbs &&
- Metamap.is_empty d.metas
-
-let cmap f evd =
- { evd with
- metas = Metamap.map (map_clb f) evd.metas;
- defn_evars = EvMap.map (map_evar_info f) evd.defn_evars;
- undf_evars = EvMap.map (map_evar_info f) evd.undf_evars
- }
-
-(* spiwack: deprecated *)
-let create_evar_defs sigma = { sigma with
- conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty }
-(* spiwack: tentatively deprecated *)
-let create_goal_evar_defs sigma = { sigma with
- (* conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty } *)
- metas=Metamap.empty }
-
-let empty = {
- defn_evars = EvMap.empty;
- undf_evars = EvMap.empty;
- universes = empty_evar_universe_context;
- conv_pbs = [];
- last_mods = Evar.Set.empty;
- metas = Metamap.empty;
- effects = Safe_typing.empty_private_constants;
- evar_names = (EvMap.empty,Idmap.empty); (* id<->key for undefined evars *)
- future_goals = [];
- principal_future_goal = None;
- extras = Store.empty;
-}
-
-let from_env e =
- { empty with universes = evar_universe_context_from e }
-
-let from_ctx ctx = { empty with universes = ctx }
-
-let has_undefined evd = not (EvMap.is_empty evd.undf_evars)
-
-let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d =
- let conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs in
- let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in
- let universes =
- if not with_univs then evd.universes
- else union_evar_universe_context evd.universes d.universes
- in
- { evd with
- metas = d.metas;
- last_mods; conv_pbs; universes }
-
-let merge_universe_context evd uctx' =
- { evd with universes = union_evar_universe_context evd.universes uctx' }
-
-let set_universe_context evd uctx' =
- { evd with universes = uctx' }
-
-let add_conv_pb ?(tail=false) pb d =
- if tail then {d with conv_pbs = d.conv_pbs @ [pb]}
- else {d with conv_pbs = pb::d.conv_pbs}
-
-let evar_source evk d = (find d evk).evar_source
-
-let evar_ident evk evd =
- try EvMap.find evk (fst evd.evar_names)
- with Not_found ->
- (* Unnamed (non-dependent) evar *)
- add_suffix (Id.of_string "X") (string_of_int (Evar.repr evk))
-
-let evar_key id evd =
- Idmap.find id (snd evd.evar_names)
-
-let define_aux def undef evk body =
- let oldinfo =
- try EvMap.find evk undef
- with Not_found ->
- if EvMap.mem evk def then
- anomaly ~label:"Evd.define" (Pp.str "cannot define an evar twice")
- else
- anomaly ~label:"Evd.define" (Pp.str "cannot define undeclared evar")
- in
- let () = assert (oldinfo.evar_body == Evar_empty) in
- let newinfo = { oldinfo with evar_body = Evar_defined body } in
- EvMap.add evk newinfo def, EvMap.remove evk undef
-
-(* define the existential of section path sp as the constr body *)
-let define evk body evd =
- let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in
- let last_mods = match evd.conv_pbs with
- | [] -> evd.last_mods
- | _ -> Evar.Set.add evk evd.last_mods
- in
- let evar_names = remove_name_defined evk evd.evar_names in
- { evd with defn_evars; undf_evars; last_mods; evar_names }
-
-let evar_declare hyps evk ty ?(src=(Loc.ghost,Evar_kinds.InternalHole))
- ?(filter=Filter.identity) ?candidates ?(store=Store.empty)
- ?(naming=Misctypes.IntroAnonymous) evd =
- let () = match Filter.repr filter with
- | None -> ()
- | Some filter ->
- assert (Int.equal (List.length filter) (List.length (named_context_of_val hyps)))
- in
- let evar_info = {
- evar_hyps = hyps;
- evar_concl = ty;
- evar_body = Evar_empty;
- evar_filter = filter;
- evar_source = src;
- evar_candidates = candidates;
- evar_extra = store; }
- in
- let evar_names = add_name_newly_undefined naming evk evar_info evd.evar_names in
- { evd with undf_evars = EvMap.add evk evar_info evd.undf_evars; evar_names }
-
-let restrict evk evk' filter ?candidates evd =
- let evar_info = EvMap.find evk evd.undf_evars in
- let evar_info' =
- { evar_info with evar_filter = filter;
- evar_candidates = candidates;
- evar_extra = Store.empty } in
- let evar_names = reassign_name_defined evk evk' evd.evar_names in
- let ctxt = Filter.filter_list filter (evar_context evar_info) in
- let id_inst = Array.map_of_list (fun (id,_,_) -> mkVar id) ctxt in
- let body = mkEvar(evk',id_inst) in
- let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in
- { evd with undf_evars = EvMap.add evk' evar_info' undf_evars;
- defn_evars; evar_names }
-
-let downcast evk ccl evd =
- let evar_info = EvMap.find evk evd.undf_evars in
- let evar_info' = { evar_info with evar_concl = ccl } in
- { evd with undf_evars = EvMap.add evk evar_info' evd.undf_evars }
-
-(* extracts conversion problems that satisfy predicate p *)
-(* Note: conv_pbs not satisying p are stored back in reverse order *)
-let extract_conv_pbs evd p =
- let (pbs,pbs1) =
- List.fold_left
- (fun (pbs,pbs1) pb ->
- if p pb then
- (pb::pbs,pbs1)
- else
- (pbs,pb::pbs1))
- ([],[])
- evd.conv_pbs
- in
- {evd with conv_pbs = pbs1; last_mods = Evar.Set.empty},
- pbs
-
-let extract_changed_conv_pbs evd p =
- extract_conv_pbs evd (fun pb -> p evd.last_mods pb)
-
-let extract_all_conv_pbs evd =
- extract_conv_pbs evd (fun _ -> true)
-
-let loc_of_conv_pb evd (pbty,env,t1,t2) =
- match kind_of_term (fst (decompose_app t1)) with
- | Evar (evk1,_) -> fst (evar_source evk1 evd)
- | _ ->
- match kind_of_term (fst (decompose_app t2)) with
- | Evar (evk2,_) -> fst (evar_source evk2 evd)
- | _ -> Loc.ghost
-
-(** The following functions return the set of evars immediately
- contained in the object *)
-
-(* excluding defined evars *)
-
-let evar_list c =
- let rec evrec acc c =
- match kind_of_term c with
- | Evar (evk, _ as ev) -> ev :: acc
- | _ -> fold_constr evrec acc c in
- evrec [] c
-
-let evars_of_term c =
- let rec evrec acc c =
- match kind_of_term c with
- | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l)
- | _ -> fold_constr evrec acc c
- in
- evrec Evar.Set.empty c
-
-let evars_of_named_context nc =
- List.fold_right (fun (_, b, t) s ->
- Option.fold_left (fun s t ->
- Evar.Set.union s (evars_of_term t))
- (Evar.Set.union s (evars_of_term t)) b)
- nc Evar.Set.empty
-
-let evars_of_filtered_evar_info evi =
- Evar.Set.union (evars_of_term evi.evar_concl)
- (Evar.Set.union
- (match evi.evar_body with
- | Evar_empty -> Evar.Set.empty
- | Evar_defined b -> evars_of_term b)
- (evars_of_named_context (evar_filtered_context evi)))
-
-(**********************************************************)
-(* Sort variables *)
-
-type rigid =
- | UnivRigid
- | UnivFlexible of bool (** Is substitution by an algebraic ok? *)
-
-let univ_rigid = UnivRigid
-let univ_flexible = UnivFlexible false
-let univ_flexible_alg = UnivFlexible true
-
-let evar_universe_context d = d.universes
-
-let universe_context_set d = d.universes.uctx_local
-
-let pr_uctx_level uctx =
- let map, map_rev = uctx.uctx_names in
- fun l ->
- try str(Univ.LMap.find l map_rev)
- with Not_found ->
- Universes.pr_with_global_universes l
-
-let universe_context ?names evd =
- match names with
- | None -> [], Univ.ContextSet.to_context evd.universes.uctx_local
- | Some pl ->
- let levels = Univ.ContextSet.levels evd.universes.uctx_local in
- let newinst, map, left =
- List.fold_right
- (fun (loc,id) (newinst, map, acc) ->
- let l =
- try UNameMap.find (Id.to_string id) (fst evd.universes.uctx_names)
- with Not_found ->
- user_err_loc (loc, "universe_context",
- str"Universe " ++ pr_id id ++ str" is not bound anymore.")
- in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc))
- pl ([], [], levels)
- in
- if not (Univ.LSet.is_empty left) then
- let n = Univ.LSet.cardinal left in
- errorlabstrm "universe_context"
- (str(CString.plural n "Universe") ++ spc () ++
- Univ.LSet.pr (pr_uctx_level evd.universes) left ++
- spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.")
- else
- let inst = Univ.Instance.of_array (Array.of_list newinst) in
- let ctx = Univ.UContext.make (inst,
- Univ.ContextSet.constraints evd.universes.uctx_local)
- in map, ctx
-
-let restrict_universe_context evd vars =
- let uctx = evd.universes in
- let uctx' = Universes.restrict_universe_context uctx.uctx_local vars in
- { evd with universes = { uctx with uctx_local = uctx' } }
-
-let universe_subst evd =
- evd.universes.uctx_univ_variables
-
-let merge_uctx sideff rigid uctx ctx' =
- let open Univ in
- let levels = ContextSet.levels ctx' in
- let uctx = if sideff then uctx else
- match rigid with
- | UnivRigid -> uctx
- | UnivFlexible b ->
- let fold u accu =
- if LMap.mem u accu then accu
- else LMap.add u None accu
- in
- let uvars' = LSet.fold fold levels uctx.uctx_univ_variables in
- if b then
- { uctx with uctx_univ_variables = uvars';
- uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels }
- else { uctx with uctx_univ_variables = uvars' }
- in
- let uctx_local =
- if sideff then uctx.uctx_local
- else ContextSet.append ctx' uctx.uctx_local
- in
- let declare g =
- LSet.fold (fun u g ->
- try Univ.add_universe u false g
- with Univ.AlreadyDeclared when sideff -> g)
- levels g
- in
- let initial = declare uctx.uctx_initial_universes in
- let univs = declare uctx.uctx_universes in
- let uctx_universes = merge_constraints (ContextSet.constraints ctx') univs in
- { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial }
-
-let merge_context_set ?(sideff=false) rigid evd ctx' =
- {evd with universes = merge_uctx sideff rigid evd.universes ctx'}
-
-let merge_uctx_subst uctx s =
- { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s }
-
-let merge_universe_subst evd subst =
- {evd with universes = merge_uctx_subst evd.universes subst }
-
-let with_context_set rigid d (a, ctx) =
- (merge_context_set rigid d ctx, a)
-
-let emit_universe_side_effects eff u =
- let uctxs = Safe_typing.universes_of_private eff in
- List.fold_left (merge_uctx true univ_rigid) u uctxs
-
-let uctx_new_univ_variable rigid name predicative
- ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) =
- let u = Universes.new_univ_level (Global.current_dirpath ()) in
- let ctx' = Univ.ContextSet.add_universe u ctx in
- let uctx', pred =
- match rigid with
- | UnivRigid -> uctx, true
- | UnivFlexible b ->
- let uvars' = Univ.LMap.add u None uvars in
- if b then {uctx with uctx_univ_variables = uvars';
- uctx_univ_algebraic = Univ.LSet.add u avars}, false
- else {uctx with uctx_univ_variables = uvars'}, false
- in
- let names =
- match name with
- | Some n -> add_uctx_names n u uctx.uctx_names
- | None -> uctx.uctx_names
- in
- let initial =
- Univ.add_universe u false uctx.uctx_initial_universes
- in
- let uctx' =
- {uctx' with uctx_names = names; uctx_local = ctx';
- uctx_universes = Univ.add_universe u false uctx.uctx_universes;
- uctx_initial_universes = initial}
- in uctx', u
-
-let new_univ_level_variable ?name ?(predicative=true) rigid evd =
- let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in
- ({evd with universes = uctx'}, u)
-
-let new_univ_variable ?name ?(predicative=true) rigid evd =
- let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in
- ({evd with universes = uctx'}, Univ.Universe.make u)
-
-let new_sort_variable ?name ?(predicative=true) rigid d =
- let (d', u) = new_univ_variable rigid ?name ~predicative d in
- (d', Type u)
-
-let add_global_univ d u =
- let uctx = d.universes in
- let initial =
- Univ.add_universe u true uctx.uctx_initial_universes
- in
- let univs =
- Univ.add_universe u true uctx.uctx_universes
- in
- { d with universes = { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local;
- uctx_initial_universes = initial;
- uctx_universes = univs } }
-
-let make_flexible_variable evd b u =
- let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as ctx = evd.universes in
- let uvars' = Univ.LMap.add u None uvars in
- let avars' =
- if b then
- let uu = Univ.Universe.make u in
- let substu_not_alg u' v =
- Option.cata (fun vu -> Univ.Universe.equal uu vu && not (Univ.LSet.mem u' avars)) false v
- in
- if not (Univ.LMap.exists substu_not_alg uvars)
- then Univ.LSet.add u avars else avars
- else avars
- in
- {evd with universes = {ctx with uctx_univ_variables = uvars';
- uctx_univ_algebraic = avars'}}
-
-let make_evar_universe_context e l =
- let uctx = evar_universe_context_from e in
- match l with
- | None -> uctx
- | Some us ->
- List.fold_left
- (fun uctx (loc,id) ->
- fst (uctx_new_univ_variable univ_rigid (Some (Id.to_string id)) true uctx))
- uctx us
-
-(****************************************)
-(* Operations on constants *)
-(****************************************)
-
-let fresh_sort_in_family ?(rigid=univ_flexible) env evd s =
- with_context_set rigid evd (Universes.fresh_sort_in_family env s)
-
-let fresh_constant_instance env evd c =
- with_context_set univ_flexible evd (Universes.fresh_constant_instance env c)
-
-let fresh_inductive_instance env evd i =
- with_context_set univ_flexible evd (Universes.fresh_inductive_instance env i)
-
-let fresh_constructor_instance env evd c =
- with_context_set univ_flexible evd (Universes.fresh_constructor_instance env c)
-
-let fresh_global ?(rigid=univ_flexible) ?names env evd gr =
- with_context_set rigid evd (Universes.fresh_global_instance ?names env gr)
-
-let whd_sort_variable evd t = t
-
-let is_sort_variable evd s =
- match s with
- | Type u ->
- (match Univ.universe_level u with
- | Some l as x ->
- let uctx = evd.universes in
- if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then x
- else None
- | None -> None)
- | _ -> None
-
-let is_flexible_level evd l =
- let uctx = evd.universes in
- Univ.LMap.mem l uctx.uctx_univ_variables
-
-let is_eq_sort s1 s2 =
- if Sorts.equal s1 s2 then None
- else
- let u1 = univ_of_sort s1
- and u2 = univ_of_sort s2 in
- if Univ.Universe.equal u1 u2 then None
- else Some (u1, u2)
-
-let normalize_universe evd =
- let vars = ref evd.universes.uctx_univ_variables in
- let normalize = Universes.normalize_universe_opt_subst vars in
- normalize
-
-let normalize_universe_instance evd l =
- let vars = ref evd.universes.uctx_univ_variables in
- let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in
- Univ.Instance.subst_fn normalize l
-
-let normalize_sort evars s =
- match s with
- | Prop _ -> s
- | Type u ->
- let u' = normalize_universe evars u in
- if u' == u then s else Type u'
-
-(* FIXME inefficient *)
-let set_eq_sort env d s1 s2 =
- let s1 = normalize_sort d s1 and s2 = normalize_sort d s2 in
- match is_eq_sort s1 s2 with
- | None -> d
- | Some (u1, u2) ->
- if not (type_in_type env) then
- add_universe_constraints d
- (Universes.Constraints.singleton (u1,Universes.UEq,u2))
- else
- d
-
-let has_lub evd u1 u2 =
- (* let normalize = Universes.normalize_universe_opt_subst (ref univs.uctx_univ_variables) in *)
- (* (\* let dref, norm = memo_normalize_universe d in *\) *)
- (* let u1 = normalize u1 and u2 = normalize u2 in *)
- if Univ.Universe.equal u1 u2 then evd
- else add_universe_constraints evd
- (Universes.Constraints.singleton (u1,Universes.ULub,u2))
-
-let set_eq_level d u1 u2 =
- add_constraints d (Univ.enforce_eq_level u1 u2 Univ.Constraint.empty)
-
-let set_leq_level d u1 u2 =
- add_constraints d (Univ.enforce_leq_level u1 u2 Univ.Constraint.empty)
-
-let set_eq_instances ?(flex=false) d u1 u2 =
- add_universe_constraints d
- (Universes.enforce_eq_instances_univs flex u1 u2 Universes.Constraints.empty)
-
-let set_leq_sort env evd s1 s2 =
- let s1 = normalize_sort evd s1
- and s2 = normalize_sort evd s2 in
- match is_eq_sort s1 s2 with
- | None -> evd
- | Some (u1, u2) ->
- (* if Univ.is_type0_univ u2 then *)
- (* if Univ.is_small_univ u1 then evd *)
- (* else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, [])) *)
- (* else if Univ.is_type0m_univ u2 then *)
- (* raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, [])) *)
- (* else *)
- if not (type_in_type env) then
- add_universe_constraints evd (Universes.Constraints.singleton (u1,Universes.ULe,u2))
- else evd
-
-let check_eq evd s s' =
- Univ.check_eq evd.universes.uctx_universes s s'
-
-let check_leq evd s s' =
- Univ.check_leq evd.universes.uctx_universes s s'
-
-let subst_univs_context_with_def def usubst (ctx, cst) =
- (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst)
-
-let normalize_evar_universe_context_variables uctx =
- let normalized_variables, undef, def, subst =
- Universes.normalize_univ_variables uctx.uctx_univ_variables
- in
- let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in
- let ctx_local', univs = Universes.refresh_constraints uctx.uctx_initial_universes ctx_local in
- subst, { uctx with uctx_local = ctx_local';
- uctx_univ_variables = normalized_variables;
- uctx_universes = univs }
-
-(* let normvarsconstrkey = Profile.declare_profile "normalize_evar_universe_context_variables";; *)
-(* let normalize_evar_universe_context_variables = *)
-(* Profile.profile1 normvarsconstrkey normalize_evar_universe_context_variables;; *)
-
-let abstract_undefined_variables uctx =
- let vars' =
- Univ.LMap.fold (fun u v acc ->
- if v == None then Univ.LSet.remove u acc
- else acc)
- uctx.uctx_univ_variables uctx.uctx_univ_algebraic
- in { uctx with uctx_local = Univ.ContextSet.empty;
- uctx_univ_algebraic = vars' }
-
-let fix_undefined_variables ({ universes = uctx } as evm) =
- let algs', vars' =
- Univ.LMap.fold (fun u v (algs, vars as acc) ->
- if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars)
- else acc)
- uctx.uctx_univ_variables
- (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables)
- in
- {evm with universes =
- { uctx with uctx_univ_variables = vars';
- uctx_univ_algebraic = algs' } }
-
-
-let refresh_undefined_univ_variables uctx =
- let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in
- let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (Univ.subst_univs_level_level subst u) acc)
- uctx.uctx_univ_algebraic Univ.LSet.empty
- in
- let vars =
- Univ.LMap.fold
- (fun u v acc ->
- Univ.LMap.add (Univ.subst_univs_level_level subst u)
- (Option.map (Univ.subst_univs_level_universe subst) v) acc)
- uctx.uctx_univ_variables Univ.LMap.empty
- in
- let declare g = Univ.LSet.fold (fun u g -> Univ.add_universe u false g)
- (Univ.ContextSet.levels ctx') g in
- let initial = declare uctx.uctx_initial_universes in
- let univs = declare Univ.initial_universes in
- let uctx' = {uctx_names = uctx.uctx_names;
- uctx_local = ctx';
- uctx_univ_variables = vars; uctx_univ_algebraic = alg;
- uctx_universes = univs;
- uctx_initial_universes = initial } in
- uctx', subst
-
-let refresh_undefined_universes evd =
- let uctx', subst = refresh_undefined_univ_variables evd.universes in
- let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in
- evd', subst
-
-let normalize_evar_universe_context uctx =
- let rec fixpoint uctx =
- let ((vars',algs'), us') =
- Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables
- uctx.uctx_univ_algebraic
- in
- if Univ.ContextSet.equal us' uctx.uctx_local then uctx
- else
- let us', universes = Universes.refresh_constraints uctx.uctx_initial_universes us' in
- let uctx' =
- { uctx_names = uctx.uctx_names;
- uctx_local = us';
- uctx_univ_variables = vars';
- uctx_univ_algebraic = algs';
- uctx_universes = universes;
- uctx_initial_universes = uctx.uctx_initial_universes }
- in fixpoint uctx'
- in fixpoint uctx
-
-let nf_univ_variables evd =
- let subst, uctx' = normalize_evar_universe_context_variables evd.universes in
- let evd' = {evd with universes = uctx'} in
- evd', subst
-
-let nf_constraints evd =
- let subst, uctx' = normalize_evar_universe_context_variables evd.universes in
- let uctx' = normalize_evar_universe_context uctx' in
- {evd with universes = uctx'}
-
-let nf_constraints =
- if Flags.profile then
- let nfconstrkey = Profile.declare_profile "nf_constraints" in
- Profile.profile1 nfconstrkey nf_constraints
- else nf_constraints
-
-let universe_of_name evd s =
- UNameMap.find s (fst evd.universes.uctx_names)
-
-let add_universe_name evd s l =
- let names' = add_uctx_names s l evd.universes.uctx_names in
- {evd with universes = {evd.universes with uctx_names = names'}}
-
-let universes evd = evd.universes.uctx_universes
-
-let update_sigma_env evd env =
- let univs = Environ.universes env in
- let eunivs =
- { evd.universes with uctx_initial_universes = univs;
- uctx_universes = univs }
- in
- let eunivs = merge_uctx true univ_rigid eunivs eunivs.uctx_local in
- { evd with universes = eunivs }
-
-(* Conversion w.r.t. an evar map and its local universes. *)
-
-let test_conversion_gen env evd pb t u =
- match pb with
- | Reduction.CONV ->
- Reduction.trans_conv_universes
- full_transparent_state ~evars:(existential_opt_value evd) env
- evd.universes.uctx_universes t u
- | Reduction.CUMUL -> Reduction.trans_conv_leq_universes
- full_transparent_state ~evars:(existential_opt_value evd) env
- evd.universes.uctx_universes t u
-
-let test_conversion env d pb t u =
- try test_conversion_gen env d pb t u; true
- with _ -> false
-
-let eq_constr_univs evd t u =
- let b, c = Universes.eq_constr_univs_infer evd.universes.uctx_universes t u in
- if b then
- try let evd' = add_universe_constraints evd c in evd', b
- with Univ.UniverseInconsistency _ | UniversesDiffer -> evd, false
- else evd, b
-
-let e_eq_constr_univs evdref t u =
- let evd, b = eq_constr_univs !evdref t u in
- evdref := evd; b
-
-(**********************************************************)
-(* Side effects *)
-
-let emit_side_effects eff evd =
- { evd with effects = Safe_typing.concat_private eff evd.effects;
- universes = emit_universe_side_effects eff evd.universes }
-
-let drop_side_effects evd =
- { evd with effects = Safe_typing.empty_private_constants; }
-
-let eval_side_effects evd = evd.effects
-
-(* Future goals *)
-let declare_future_goal evk evd =
- { evd with future_goals = evk::evd.future_goals }
-
-let declare_principal_goal evk evd =
- match evd.principal_future_goal with
- | None -> { evd with
- future_goals = evk::evd.future_goals;
- principal_future_goal=Some evk; }
- | Some _ -> Errors.error "Only one main subgoal per instantiation."
-
-let future_goals evd = evd.future_goals
-
-let principal_future_goal evd = evd.principal_future_goal
-
-let reset_future_goals evd =
- { evd with future_goals = [] ; principal_future_goal=None }
-
-let restore_future_goals evd gls pgl =
- { evd with future_goals = gls ; principal_future_goal = pgl }
-
-(**********************************************************)
-(* Accessing metas *)
-
-(** We use this function to overcome OCaml compiler limitations and to prevent
- the use of costly in-place modifications. *)
-let set_metas evd metas = {
- defn_evars = evd.defn_evars;
- undf_evars = evd.undf_evars;
- universes = evd.universes;
- conv_pbs = evd.conv_pbs;
- last_mods = evd.last_mods;
- metas;
- effects = evd.effects;
- evar_names = evd.evar_names;
- future_goals = evd.future_goals;
- principal_future_goal = evd.principal_future_goal;
- extras = evd.extras;
-}
-
-let meta_list evd = metamap_to_list evd.metas
-
-let undefined_metas evd =
- let filter = function
- | (n,Clval(_,_,typ)) -> None
- | (n,Cltyp (_,typ)) -> Some n
- in
- let m = List.map_filter filter (meta_list evd) in
- List.sort Int.compare m
-
-let map_metas_fvalue f evd =
- let map = function
- | Clval(id,(c,s),typ) -> Clval(id,(mk_freelisted (f c.rebus),s),typ)
- | x -> x
- in
- set_metas evd (Metamap.smartmap map evd.metas)
-
-let meta_opt_fvalue evd mv =
- match Metamap.find mv evd.metas with
- | Clval(_,b,_) -> Some b
- | Cltyp _ -> None
-
-let meta_defined evd mv =
- match Metamap.find mv evd.metas with
- | Clval _ -> true
- | Cltyp _ -> false
-
-let try_meta_fvalue evd mv =
- match Metamap.find mv evd.metas with
- | Clval(_,b,_) -> b
- | Cltyp _ -> raise Not_found
-
-let meta_fvalue evd mv =
- try try_meta_fvalue evd mv
- with Not_found -> anomaly ~label:"meta_fvalue" (Pp.str "meta has no value")
-
-let meta_value evd mv =
- (fst (try_meta_fvalue evd mv)).rebus
-
-let meta_ftype evd mv =
- match Metamap.find mv evd.metas with
- | Cltyp (_,b) -> b
- | Clval(_,_,b) -> b
-
-let meta_type evd mv = (meta_ftype evd mv).rebus
-
-let meta_declare mv v ?(name=Anonymous) evd =
- let metas = Metamap.add mv (Cltyp(name,mk_freelisted v)) evd.metas in
- set_metas evd metas
-
-let meta_assign mv (v, pb) evd =
- let modify _ = function
- | Cltyp (na, ty) -> Clval (na, (mk_freelisted v, pb), ty)
- | _ -> anomaly ~label:"meta_assign" (Pp.str "already defined")
- in
- let metas = Metamap.modify mv modify evd.metas in
- set_metas evd metas
-
-let meta_reassign mv (v, pb) evd =
- let modify _ = function
- | Clval(na, _, ty) -> Clval (na, (mk_freelisted v, pb), ty)
- | _ -> anomaly ~label:"meta_reassign" (Pp.str "not yet defined")
- in
- let metas = Metamap.modify mv modify evd.metas in
- set_metas evd metas
-
-(* If the meta is defined then forget its name *)
-let meta_name evd mv =
- try fst (clb_name (Metamap.find mv evd.metas)) with Not_found -> Anonymous
-
-let explain_no_such_bound_variable evd id =
- let mvl =
- List.rev (Metamap.fold (fun n clb l ->
- let na = fst (clb_name clb) in
- if na != Anonymous then out_name na :: l else l)
- evd.metas []) in
- errorlabstrm "Evd.meta_with_name"
- (str"No such bound variable " ++ pr_id id ++
- (if mvl == [] then str " (no bound variables at all in the expression)."
- else
- (str" (possible name" ++
- str (if List.length mvl == 1 then " is: " else "s are: ") ++
- pr_enum pr_id mvl ++ str").")))
-
-let meta_with_name evd id =
- let na = Name id in
- let (mvl,mvnodef) =
- Metamap.fold
- (fun n clb (l1,l2 as l) ->
- let (na',def) = clb_name clb in
- if Name.equal na na' then if def then (n::l1,l2) else (n::l1,n::l2)
- else l)
- evd.metas ([],[]) in
- match mvnodef, mvl with
- | _,[] ->
- explain_no_such_bound_variable evd id
- | ([n],_|_,[n]) ->
- n
- | _ ->
- errorlabstrm "Evd.meta_with_name"
- (str "Binder name \"" ++ pr_id id ++
- strbrk "\" occurs more than once in clause.")
-
-let clear_metas evd = {evd with metas = Metamap.empty}
-
-let meta_merge ?(with_univs = true) evd1 evd2 =
- let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in
- let universes =
- if with_univs then union_evar_universe_context evd2.universes evd1.universes
- else evd2.universes
- in
- {evd2 with universes; metas; }
-
-type metabinding = metavariable * constr * instance_status
-
-let retract_coercible_metas evd =
- let mc = ref [] in
- let map n v = match v with
- | Clval (na, (b, (Conv, CoerceToType as s)), typ) ->
- let () = mc := (n, b.rebus, s) :: !mc in
- Cltyp (na, typ)
- | v -> v
- in
- let metas = Metamap.smartmapi map evd.metas in
- !mc, set_metas evd metas
-
-let subst_defined_metas_evars (bl,el) c =
- let rec substrec c = match kind_of_term c with
- | Meta i ->
- let select (j,_,_) = Int.equal i j in
- substrec (pi2 (List.find select bl))
- | Evar (evk,args) ->
- let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in
- (try substrec (pi3 (List.find select el))
- with Not_found -> map_constr substrec c)
- | _ -> map_constr substrec c
- in try Some (substrec c) with Not_found -> None
-
-let evar_source_of_meta mv evd =
- match meta_name evd mv with
- | Anonymous -> (Loc.ghost,Evar_kinds.GoalEvar)
- | Name id -> (Loc.ghost,Evar_kinds.VarInstance id)
-
-let dependent_evar_ident ev evd =
- let evi = find evd ev in
- match evi.evar_source with
- | (_,Evar_kinds.VarInstance id) -> id
- | _ -> anomaly (str "Not an evar resulting of a dependent binding")
-
-(**********************************************************)
-(* Extra data *)
-
-let get_extra_data evd = evd.extras
-let set_extra_data extras evd = { evd with extras }
-
-(*******************************************************************)
-
-type pending = (* before: *) evar_map * (* after: *) evar_map
-
-type pending_constr = pending * constr
-
-type open_constr = evar_map * constr
-
-(*******************************************************************)
-(* The type constructor ['a sigma] adds an evar map to an object of
- type ['a] *)
-type 'a sigma = {
- it : 'a ;
- sigma : evar_map
-}
-
-let sig_it x = x.it
-let sig_sig x = x.sigma
-let on_sig s f =
- let sigma', v = f s.sigma in
- { s with sigma = sigma' }, v
-
-(*******************************************************************)
-(* The state monad with state an evar map. *)
-
-module MonadR =
- Monad.Make (struct
-
- type +'a t = evar_map -> evar_map * 'a
-
- let return a = fun s -> (s,a)
-
- let (>>=) x f = fun s ->
- let (s',a) = x s in
- f a s'
-
- let (>>) x y = fun s ->
- let (s',()) = x s in
- y s'
-
- let map f x = fun s ->
- on_snd f (x s)
-
- end)
-
-module Monad =
- Monad.Make (struct
-
- type +'a t = evar_map -> 'a * evar_map
-
- let return a = fun s -> (a,s)
-
- let (>>=) x f = fun s ->
- let (a,s') = x s in
- f a s'
-
- let (>>) x y = fun s ->
- let ((),s') = x s in
- y s'
-
- let map f x = fun s ->
- on_fst f (x s)
-
- end)
-
-(**********************************************************)
-(* Failure explanation *)
-
-type unsolvability_explanation = SeveralInstancesFound of int
-
-(**********************************************************)
-(* Pretty-printing *)
-
-let pr_existential_key sigma evk = str "?" ++ pr_id (evar_ident evk sigma)
-
-let pr_instance_status (sc,typ) =
- begin match sc with
- | IsSubType -> str " [or a subtype of it]"
- | IsSuperType -> str " [or a supertype of it]"
- | Conv -> mt ()
- end ++
- begin match typ with
- | CoerceToType -> str " [up to coercion]"
- | TypeNotProcessed -> mt ()
- | TypeProcessed -> str " [type is checked]"
- end
-
-let pr_meta_map mmap =
- let pr_name = function
- Name id -> str"[" ++ pr_id id ++ str"]"
- | _ -> mt() in
- let pr_meta_binding = function
- | (mv,Cltyp (na,b)) ->
- hov 0
- (pr_meta mv ++ pr_name na ++ str " : " ++
- print_constr b.rebus ++ fnl ())
- | (mv,Clval(na,(b,s),t)) ->
- hov 0
- (pr_meta mv ++ pr_name na ++ str " := " ++
- print_constr b.rebus ++
- str " : " ++ print_constr t.rebus ++
- spc () ++ pr_instance_status s ++ fnl ())
- in
- prlist pr_meta_binding (metamap_to_list mmap)
-
-let pr_decl ((id,b,_),ok) =
- match b with
- | None -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}")
- | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++
- print_constr c ++ str (if ok then ")" else "}")
-
-let rec pr_evar_source = function
- | Evar_kinds.QuestionMark _ -> str "underscore"
- | Evar_kinds.CasesType false -> str "pattern-matching return predicate"
- | Evar_kinds.CasesType true ->
- str "subterm of pattern-matching return predicate"
- | Evar_kinds.BinderType (Name id) -> str "type of " ++ Nameops.pr_id id
- | Evar_kinds.BinderType Anonymous -> str "type of anonymous binder"
- | Evar_kinds.ImplicitArg (c,(n,ido),b) ->
- let id = Option.get ido in
- str "parameter " ++ pr_id id ++ spc () ++ str "of" ++
- spc () ++ print_constr (printable_constr_of_global c)
- | Evar_kinds.InternalHole -> str "internal placeholder"
- | Evar_kinds.TomatchTypeParameter (ind,n) ->
- pr_nth n ++ str " argument of type " ++ print_constr (mkInd ind)
- | Evar_kinds.GoalEvar -> str "goal evar"
- | Evar_kinds.ImpossibleCase -> str "type of impossible pattern-matching clause"
- | Evar_kinds.MatchingVar _ -> str "matching variable"
- | Evar_kinds.VarInstance id -> str "instance of " ++ pr_id id
- | Evar_kinds.SubEvar evk ->
- str "subterm of " ++ str (string_of_existential evk)
-
-let pr_evar_info evi =
- let phyps =
- try
- let decls = match Filter.repr (evar_filter evi) with
- | None -> List.map (fun c -> (c, true)) (evar_context evi)
- | Some filter -> List.combine (evar_context evi) filter
- in
- prlist_with_sep spc pr_decl (List.rev decls)
- with Invalid_argument _ -> str "Ill-formed filtered context" in
- let pty = print_constr evi.evar_concl in
- let pb =
- match evi.evar_body with
- | Evar_empty -> mt ()
- | Evar_defined c -> spc() ++ str"=> " ++ print_constr c
- in
- let candidates =
- match evi.evar_body, evi.evar_candidates with
- | Evar_empty, Some l ->
- spc () ++ str "{" ++
- prlist_with_sep (fun () -> str "|") print_constr l ++ str "}"
- | _ ->
- mt ()
- in
- let src = str "(" ++ pr_evar_source (snd evi.evar_source) ++ str ")" in
- hov 2
- (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]" ++
- candidates ++ spc() ++ src)
-
-let compute_evar_dependency_graph (sigma : evar_map) =
- (* Compute the map binding ev to the evars whose body depends on ev *)
- let fold evk evi acc =
- let fold_ev evk' acc =
- let tab =
- try EvMap.find evk' acc
- with Not_found -> Evar.Set.empty
- in
- EvMap.add evk' (Evar.Set.add evk tab) acc
- in
- match evar_body evi with
- | Evar_empty -> assert false
- | Evar_defined c -> Evar.Set.fold fold_ev (evars_of_term c) acc
- in
- EvMap.fold fold sigma.defn_evars EvMap.empty
-
-let evar_dependency_closure n sigma =
- (** Create the DAG of depth [n] representing the recursive dependencies of
- undefined evars. *)
- let graph = compute_evar_dependency_graph sigma in
- let rec aux n curr accu =
- if Int.equal n 0 then Evar.Set.union curr accu
- else
- let fold evk accu =
- try
- let deps = EvMap.find evk graph in
- Evar.Set.union deps accu
- with Not_found -> accu
- in
- (** Consider only the newly added evars *)
- let ncurr = Evar.Set.fold fold curr Evar.Set.empty in
- (** Merge the others *)
- let accu = Evar.Set.union curr accu in
- aux (n - 1) ncurr accu
- in
- let undef = EvMap.domain (undefined_map sigma) in
- aux n undef Evar.Set.empty
-
-let evar_dependency_closure n sigma =
- let deps = evar_dependency_closure n sigma in
- let map = EvMap.bind (fun ev -> find sigma ev) deps in
- EvMap.bindings map
-
-let has_no_evar sigma =
- EvMap.is_empty sigma.defn_evars && EvMap.is_empty sigma.undf_evars
-
-let pr_evd_level evd = pr_uctx_level evd.universes
-
-let pr_evar_universe_context ctx =
- let prl = pr_uctx_level ctx in
- if is_empty_evar_universe_context ctx then mt ()
- else
- (str"UNIVERSES:"++brk(0,1)++
- h 0 (Univ.pr_universe_context_set prl ctx.uctx_local) ++ fnl () ++
- str"ALGEBRAIC UNIVERSES:"++brk(0,1)++
- h 0 (Univ.LSet.pr prl ctx.uctx_univ_algebraic) ++ fnl() ++
- str"UNDEFINED UNIVERSES:"++brk(0,1)++
- h 0 (Universes.pr_universe_opt_subst ctx.uctx_univ_variables) ++ fnl())
-
-let print_env_short env =
- let pr_body n = function
- | None -> pr_name n
- | Some b -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" in
- let pr_named_decl (n, b, _) = pr_body (Name n) b in
- let pr_rel_decl (n, b, _) = pr_body n b in
- let nc = List.rev (named_context env) in
- let rc = List.rev (rel_context env) in
- str "[" ++ pr_sequence pr_named_decl nc ++ str "]" ++ spc () ++
- str "[" ++ pr_sequence pr_rel_decl rc ++ str "]"
-
-let pr_evar_constraints pbs =
- let pr_evconstr (pbty, env, t1, t2) =
- print_env_short env ++ spc () ++ str "|-" ++ spc () ++
- print_constr_env env t1 ++ spc () ++
- str (match pbty with
- | Reduction.CONV -> "=="
- | Reduction.CUMUL -> "<=") ++
- spc () ++ print_constr_env env t2
- in
- prlist_with_sep fnl pr_evconstr pbs
-
-let pr_evar_map_gen with_univs pr_evars sigma =
- let { universes = uvs } = sigma in
- let evs = if has_no_evar sigma then mt () else pr_evars sigma ++ fnl ()
- and svs = if with_univs then pr_evar_universe_context uvs else mt ()
- and cstrs =
- if List.is_empty sigma.conv_pbs then mt ()
- else
- str "CONSTRAINTS:" ++ brk (0, 1) ++
- pr_evar_constraints sigma.conv_pbs ++ fnl ()
- and metas =
- if Metamap.is_empty sigma.metas then mt ()
- else
- str "METAS:" ++ brk (0, 1) ++ pr_meta_map sigma.metas
- in
- evs ++ svs ++ cstrs ++ metas
-
-let pr_evar_list sigma l =
- let pr (ev, evi) =
- h 0 (str (string_of_existential ev) ++
- str "==" ++ pr_evar_info evi ++
- (if evi.evar_body == Evar_empty
- then str " {" ++ pr_id (evar_ident ev sigma) ++ str "}"
- else mt ()))
- in
- h 0 (prlist_with_sep fnl pr l)
-
-let pr_evar_by_depth depth sigma = match depth with
-| None ->
- (* Print all evars *)
- str"EVARS:"++brk(0,1)++pr_evar_list sigma (to_list sigma)++fnl()
-| Some n ->
- (* Print all evars *)
- str"UNDEFINED EVARS:"++
- (if Int.equal n 0 then mt() else str" (+level "++int n++str" closure):")++
- brk(0,1)++
- pr_evar_list sigma (evar_dependency_closure n sigma)++fnl()
-
-let pr_evar_by_filter filter sigma =
- let defined = Evar.Map.filter filter sigma.defn_evars in
- let undefined = Evar.Map.filter filter sigma.undf_evars in
- let prdef =
- if Evar.Map.is_empty defined then mt ()
- else str "DEFINED EVARS:" ++ brk (0, 1) ++
- pr_evar_list sigma (Evar.Map.bindings defined)
- in
- let prundef =
- if Evar.Map.is_empty undefined then mt ()
- else str "UNDEFINED EVARS:" ++ brk (0, 1) ++
- pr_evar_list sigma (Evar.Map.bindings undefined)
- in
- prdef ++ prundef
-
-let pr_evar_map ?(with_univs=true) depth sigma =
- pr_evar_map_gen with_univs (fun sigma -> pr_evar_by_depth depth sigma) sigma
-
-let pr_evar_map_filter ?(with_univs=true) filter sigma =
- pr_evar_map_gen with_univs (fun sigma -> pr_evar_by_filter filter sigma) sigma
-
-let pr_metaset metas =
- str "[" ++ pr_sequence pr_meta (Metaset.elements metas) ++ str "]"
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
deleted file mode 100644
index 0b4f1853..00000000
--- a/pretyping/evd.mli
+++ /dev/null
@@ -1,621 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* string
-
-(** {6 Evar filters} *)
-
-module Filter :
-sig
- type t
- (** Evar filters, seen as bitmasks. *)
-
- val equal : t -> t -> bool
- (** Equality over filters *)
-
- val identity : t
- (** The identity filter. *)
-
- val filter_list : t -> 'a list -> 'a list
- (** Filter a list. Sizes must coincide. *)
-
- val filter_array : t -> 'a array -> 'a array
- (** Filter an array. Sizes must coincide. *)
-
- val extend : int -> t -> t
- (** [extend n f] extends [f] on the left with [n]-th times [true]. *)
-
- val compose : t -> t -> t
- (** Horizontal composition : [compose f1 f2] only keeps parts of [f2] where
- [f1] is set. In particular, [f1] and [f2] must have the same length. *)
-
- val apply_subfilter : t -> bool list -> t
- (** [apply_subfilter f1 f2] applies filter [f2] where [f1] is [true]. In
- particular, the length of [f2] is the number of times [f1] is [true] *)
-
- val restrict_upon : t -> int -> (int -> bool) -> t option
- (** Ad-hoc primitive. *)
-
- val map_along : (bool -> 'a -> bool) -> t -> 'a list -> t
- (** Apply the function on the filter and the list. Sizes must coincide. *)
-
- val make : bool list -> t
- (** Create out of a list *)
-
- val repr : t -> bool list option
- (** Observe as a bool list. *)
-
-end
-
-(** {6 Evar infos} *)
-
-type evar_body =
- | Evar_empty
- | Evar_defined of constr
-
-
-module Store : Store.S
-(** Datatype used to store additional information in evar maps. *)
-
-type evar_info = {
- evar_concl : constr;
- (** Type of the evar. *)
- evar_hyps : named_context_val;
- (** Context of the evar. *)
- evar_body : evar_body;
- (** Optional content of the evar. *)
- evar_filter : Filter.t;
- (** Boolean mask over {!evar_hyps}. Should have the same length.
- TODO: document me more. *)
- evar_source : Evar_kinds.t located;
- (** Information about the evar. *)
- evar_candidates : constr list option;
- (** TODO: document this *)
- evar_extra : Store.t
- (** Extra store, used for clever hacks. *)
-}
-
-val make_evar : named_context_val -> types -> evar_info
-val evar_concl : evar_info -> constr
-val evar_context : evar_info -> named_context
-val evar_filtered_context : evar_info -> named_context
-val evar_hyps : evar_info -> named_context_val
-val evar_filtered_hyps : evar_info -> named_context_val
-val evar_body : evar_info -> evar_body
-val evar_filter : evar_info -> Filter.t
-val evar_env : evar_info -> env
-val evar_filtered_env : evar_info -> env
-
-val map_evar_body : (constr -> constr) -> evar_body -> evar_body
-val map_evar_info : (constr -> constr) -> evar_info -> evar_info
-
-(** {6 Unification state} **)
-
-type evar_universe_context
-(** The universe context associated to an evar map *)
-
-type evar_map
-(** Type of unification state. Essentially a bunch of state-passing data needed
- to handle incremental term construction. *)
-
-val empty : evar_map
-(** The empty evar map. *)
-
-val from_env : env -> evar_map
-(** The empty evar map with given universe context, taking its initial
- universes from env. *)
-
-val from_ctx : evar_universe_context -> evar_map
-(** The empty evar map with given universe context *)
-
-val is_empty : evar_map -> bool
-(** Whether an evarmap is empty. *)
-
-val has_undefined : evar_map -> bool
-(** [has_undefined sigma] is [true] if and only if
- there are uninstantiated evars in [sigma]. *)
-
-val add : evar_map -> evar -> evar_info -> evar_map
-(** [add sigma ev info] adds [ev] with evar info [info] in sigma.
- Precondition: ev must not preexist in [sigma]. *)
-
-val find : evar_map -> evar -> evar_info
-(** Recover the data associated to an evar. *)
-
-val find_undefined : evar_map -> evar -> evar_info
-(** Same as {!find} but restricted to undefined evars. For efficiency
- reasons. *)
-
-val remove : evar_map -> evar -> evar_map
-(** Remove an evar from an evar map. Use with caution. *)
-
-val mem : evar_map -> evar -> bool
-(** Whether an evar is present in an evarmap. *)
-
-val fold : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
-(** Apply a function to all evars and their associated info in an evarmap. *)
-
-val fold_undefined : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
-(** Same as {!fold}, but restricted to undefined evars. For efficiency
- reasons. *)
-
-val raw_map : (evar -> evar_info -> evar_info) -> evar_map -> evar_map
-(** Apply the given function to all evars in the map. Beware: this function
- expects the argument function to preserve the kind of [evar_body], i.e. it
- must send [Evar_empty] to [Evar_empty] and [Evar_defined c] to some
- [Evar_defined c']. *)
-
-val raw_map_undefined : (evar -> evar_info -> evar_info) -> evar_map -> evar_map
-(** Same as {!raw_map}, but restricted to undefined evars. For efficiency
- reasons. *)
-
-val define : evar -> constr -> evar_map -> evar_map
-(** Set the body of an evar to the given constr. It is expected that:
- {ul
- {- The evar is already present in the evarmap.}
- {- The evar is not defined in the evarmap yet.}
- {- All the evars present in the constr should be present in the evar map.}
- } *)
-
-val cmap : (constr -> constr) -> evar_map -> evar_map
-(** Map the function on all terms in the evar map. *)
-
-val is_evar : evar_map -> evar -> bool
-(** Alias for {!mem}. *)
-
-val is_defined : evar_map -> evar -> bool
-(** Whether an evar is defined in an evarmap. *)
-
-val is_undefined : evar_map -> evar -> bool
-(** Whether an evar is not defined in an evarmap. *)
-
-val add_constraints : evar_map -> Univ.constraints -> evar_map
-(** Add universe constraints in an evar map. *)
-
-val undefined_map : evar_map -> evar_info Evar.Map.t
-(** Access the undefined evar mapping directly. *)
-
-val drop_all_defined : evar_map -> evar_map
-
-(** {6 Instantiating partial terms} *)
-
-exception NotInstantiatedEvar
-
-val existential_value : evar_map -> existential -> constr
-(** [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
- no body and [Not_found] if it does not exist in [sigma] *)
-
-val existential_type : evar_map -> existential -> types
-
-val existential_opt_value : evar_map -> existential -> constr option
-(** Same as {!existential_value} but returns an option instead of raising an
- exception. *)
-
-val evar_instance_array : (named_declaration -> 'a -> bool) -> evar_info ->
- 'a array -> (Id.t * 'a) list
-
-val instantiate_evar_array : evar_info -> constr -> constr array -> constr
-
-val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool ->
- evar_map -> evar_map -> evar_map
-(** spiwack: this function seems to somewhat break the abstraction. *)
-
-(** {6 Misc} *)
-
-val evar_declare :
- named_context_val -> evar -> types -> ?src:Loc.t * Evar_kinds.t ->
- ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr -> evar_map -> evar_map
-(** Convenience function. Just a wrapper around {!add}. *)
-
-val restrict : evar -> evar -> Filter.t -> ?candidates:constr list ->
- evar_map -> evar_map
-(** Restrict an undefined evar into a new evar by filtering context and
- possibly limiting the instances to a set of candidates *)
-
-val downcast : evar -> types -> evar_map -> evar_map
-(** Change the type of an undefined evar to a new type assumed to be a
- subtype of its current type; subtyping must be ensured by caller *)
-
-val evar_source : existential_key -> evar_map -> Evar_kinds.t located
-(** Convenience function. Wrapper around {!find} to recover the source of an
- evar in a given evar map. *)
-
-val evar_ident : existential_key -> evar_map -> Id.t
-
-val rename : existential_key -> Id.t -> evar_map -> evar_map
-
-val evar_key : Id.t -> evar_map -> existential_key
-
-val evar_source_of_meta : metavariable -> evar_map -> Evar_kinds.t located
-
-val dependent_evar_ident : existential_key -> evar_map -> Id.t
-
-(** {5 Side-effects} *)
-
-val emit_side_effects : Safe_typing.private_constants -> evar_map -> evar_map
-(** Push a side-effect into the evar map. *)
-
-val eval_side_effects : evar_map -> Safe_typing.private_constants
-(** Return the effects contained in the evar map. *)
-
-val drop_side_effects : evar_map -> evar_map
-(** This should not be used. For hacking purposes. *)
-
-(** {5 Future goals} *)
-
-val declare_future_goal : Evar.t -> evar_map -> evar_map
-(** Adds an existential variable to the list of future goals. For
- internal uses only. *)
-
-val declare_principal_goal : Evar.t -> evar_map -> evar_map
-(** Adds an existential variable to the list of future goals and make
- it principal. Only one existential variable can be made principal, an
- error is raised otherwise. For internal uses only. *)
-
-val future_goals : evar_map -> Evar.t list
-(** Retrieves the list of future goals. Used by the [refine] primitive
- of the tactic engine. *)
-
-val principal_future_goal : evar_map -> Evar.t option
-(** Retrieves the name of the principal existential variable if there
- is one. Used by the [refine] primitive of the tactic engine. *)
-
-val reset_future_goals : evar_map -> evar_map
-(** Clears the list of future goals (as well as the principal future
- goal). Used by the [refine] primitive of the tactic engine. *)
-
-val restore_future_goals : evar_map -> Evar.t list -> Evar.t option -> evar_map
-(** Sets the future goals (including the principal future goal) to a
- previous value. Intended to be used after a local list of future
- goals has been consumed. Used by the [refine] primitive of the
- tactic engine. *)
-
-(** {5 Sort variables}
-
- Evar maps also keep track of the universe constraints defined at a given
- point. This section defines the relevant manipulation functions. *)
-
-val whd_sort_variable : evar_map -> constr -> constr
-
-exception UniversesDiffer
-
-val add_universe_constraints : evar_map -> Universes.universe_constraints -> evar_map
-(** Add the given universe unification constraints to the evar map.
- @raises UniversesDiffer in case a first-order unification fails.
- @raises UniverseInconsistency
-*)
-
-(** {5 Extra data}
-
- Evar maps can contain arbitrary data, allowing to use an extensible state.
- As evar maps are theoretically used in a strict state-passing style, such
- additional data should be passed along transparently. Some old and bug-prone
- code tends to drop them nonetheless, so you should keep cautious.
-
-*)
-
-val get_extra_data : evar_map -> Store.t
-val set_extra_data : Store.t -> evar_map -> evar_map
-
-(** {5 Enriching with evar maps} *)
-
-type 'a sigma = {
- it : 'a ;
- (** The base object. *)
- sigma : evar_map
- (** The added unification state. *)
-}
-(** The type constructor ['a sigma] adds an evar map to an object of type
- ['a]. *)
-
-val sig_it : 'a sigma -> 'a
-val sig_sig : 'a sigma -> evar_map
-val on_sig : 'a sigma -> (evar_map -> evar_map * 'b) -> 'a sigma * 'b
-
-(** {5 The state monad with state an evar map} *)
-
-module MonadR : Monad.S with type +'a t = evar_map -> evar_map * 'a
-module Monad : Monad.S with type +'a t = evar_map -> 'a * evar_map
-
-
-(** {5 Meta machinery}
-
- These functions are almost deprecated. They were used before the
- introduction of the full-fledged evar calculus. In an ideal world, they
- should be removed. Alas, some parts of the code still use them. Do not use
- in newly-written code. *)
-
-module Metaset : Set.S with type elt = metavariable
-module Metamap : Map.ExtS with type key = metavariable and module Set := Metaset
-
-type 'a freelisted = {
- rebus : 'a;
- freemetas : Metaset.t }
-
-val metavars_of : constr -> Metaset.t
-val mk_freelisted : constr -> constr freelisted
-val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted
-
-(** Status of an instance found by unification wrt to the meta it solves:
- - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X)
- - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X)
- - a term that can be eta-expanded n times while still being a solution
- (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice)
-*)
-
-type instance_constraint = IsSuperType | IsSubType | Conv
-
-val eq_instance_constraint :
- instance_constraint -> instance_constraint -> bool
-
-(** Status of the unification of the type of an instance against the type of
- the meta it instantiates:
- - CoerceToType means that the unification of types has not been done
- and that a coercion can still be inserted: the meta should not be
- substituted freely (this happens for instance given via the
- "with" binding clause).
- - TypeProcessed means that the information obtainable from the
- unification of types has been extracted.
- - TypeNotProcessed means that the unification of types has not been
- done but it is known that no coercion may be inserted: the meta
- can be substituted freely.
-*)
-
-type instance_typing_status =
- CoerceToType | TypeNotProcessed | TypeProcessed
-
-(** Status of an instance together with the status of its type unification *)
-
-type instance_status = instance_constraint * instance_typing_status
-
-(** Clausal environments *)
-
-type clbinding =
- | Cltyp of Name.t * constr freelisted
- | Clval of Name.t * (constr freelisted * instance_status) * constr freelisted
-
-(** Unification constraints *)
-type conv_pb = Reduction.conv_pb
-type evar_constraint = conv_pb * env * constr * constr
-val add_conv_pb : ?tail:bool -> evar_constraint -> evar_map -> evar_map
-
-val extract_changed_conv_pbs : evar_map ->
- (Evar.Set.t -> evar_constraint -> bool) ->
- evar_map * evar_constraint list
-val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list
-val loc_of_conv_pb : evar_map -> evar_constraint -> Loc.t
-
-(** The following functions return the set of evars immediately
- contained in the object; need the term to be evar-normal otherwise
- defined evars are returned too. *)
-
-val evar_list : constr -> existential list
- (** excluding evars in instances of evars and collected with
- redundancies from right to left (used by tactic "instantiate") *)
-
-val evars_of_term : constr -> Evar.Set.t
- (** including evars in instances of evars *)
-
-val evars_of_named_context : named_context -> Evar.Set.t
-
-val evars_of_filtered_evar_info : evar_info -> Evar.Set.t
-
-(** Metas *)
-val meta_list : evar_map -> (metavariable * clbinding) list
-val meta_defined : evar_map -> metavariable -> bool
-
-val meta_value : evar_map -> metavariable -> constr
-(** [meta_fvalue] raises [Not_found] if meta not in map or [Anomaly] if
- meta has no value *)
-
-val meta_fvalue : evar_map -> metavariable -> constr freelisted * instance_status
-val meta_opt_fvalue : evar_map -> metavariable -> (constr freelisted * instance_status) option
-val meta_type : evar_map -> metavariable -> types
-val meta_ftype : evar_map -> metavariable -> types freelisted
-val meta_name : evar_map -> metavariable -> Name.t
-val meta_with_name : evar_map -> Id.t -> metavariable
-val meta_declare :
- metavariable -> types -> ?name:Name.t -> evar_map -> evar_map
-val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map
-val meta_reassign : metavariable -> constr * instance_status -> evar_map -> evar_map
-
-val clear_metas : evar_map -> evar_map
-
-(** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *)
-val meta_merge : ?with_univs:bool -> evar_map -> evar_map -> evar_map
-
-val undefined_metas : evar_map -> metavariable list
-val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map
-
-type metabinding = metavariable * constr * instance_status
-
-val retract_coercible_metas : evar_map -> metabinding list * evar_map
-val subst_defined_metas_evars : metabinding list * ('a * existential * constr) list -> constr -> constr option
-
-(** {5 FIXME: Nothing to do here} *)
-
-(*********************************************************
- Sort/universe variables *)
-
-(** Rigid or flexible universe variables *)
-
-type rigid =
- | UnivRigid
- | UnivFlexible of bool (** Is substitution by an algebraic ok? *)
-
-val univ_rigid : rigid
-val univ_flexible : rigid
-val univ_flexible_alg : rigid
-
-type 'a in_evar_universe_context = 'a * evar_universe_context
-
-val evar_universe_context_set : Univ.universe_context -> evar_universe_context -> Univ.universe_context_set
-val evar_universe_context_constraints : evar_universe_context -> Univ.constraints
-val evar_context_universe_context : evar_universe_context -> Univ.universe_context
-val evar_universe_context_of : Univ.universe_context_set -> evar_universe_context
-val empty_evar_universe_context : evar_universe_context
-val union_evar_universe_context : evar_universe_context -> evar_universe_context ->
- evar_universe_context
-val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst
-
-val evar_universe_context_of_binders :
- Universes.universe_binders -> evar_universe_context
-
-val make_evar_universe_context : env -> (Id.t located) list option -> evar_universe_context
-val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map
-(** Raises Not_found if not a name for a universe in this map. *)
-val universe_of_name : evar_map -> string -> Univ.universe_level
-val add_universe_name : evar_map -> string -> Univ.universe_level -> evar_map
-
-val universes : evar_map -> Univ.universes
-
-val add_constraints_context : evar_universe_context ->
- Univ.constraints -> evar_universe_context
-
-
-val normalize_evar_universe_context_variables : evar_universe_context ->
- Univ.universe_subst in_evar_universe_context
-
-val normalize_evar_universe_context : evar_universe_context ->
- evar_universe_context
-
-val new_univ_level_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe_level
-val new_univ_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe
-val new_sort_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * sorts
-val add_global_univ : evar_map -> Univ.Level.t -> evar_map
-
-val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map
-val is_sort_variable : evar_map -> sorts -> Univ.universe_level option
-(** [is_sort_variable evm s] returns [Some u] or [None] if [s] is
- not a local sort variable declared in [evm] *)
-val is_flexible_level : evar_map -> Univ.Level.t -> bool
-
-val whd_sort_variable : evar_map -> constr -> constr
-(* val normalize_universe_level : evar_map -> Univ.universe_level -> Univ.universe_level *)
-val normalize_universe : evar_map -> Univ.universe -> Univ.universe
-val normalize_universe_instance : evar_map -> Univ.universe_instance -> Univ.universe_instance
-
-val set_leq_sort : env -> evar_map -> sorts -> sorts -> evar_map
-val set_eq_sort : env -> evar_map -> sorts -> sorts -> evar_map
-val has_lub : evar_map -> Univ.universe -> Univ.universe -> evar_map
-val set_eq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map
-val set_leq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map
-val set_eq_instances : ?flex:bool ->
- evar_map -> Univ.universe_instance -> Univ.universe_instance -> evar_map
-
-val check_eq : evar_map -> Univ.universe -> Univ.universe -> bool
-val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool
-
-val evar_universe_context : evar_map -> evar_universe_context
-val universe_context_set : evar_map -> Univ.universe_context_set
-val universe_context : ?names:(Id.t located) list -> evar_map ->
- (Id.t * Univ.Level.t) list * Univ.universe_context
-val universe_subst : evar_map -> Universes.universe_opt_subst
-val universes : evar_map -> Univ.universes
-
-
-val merge_universe_context : evar_map -> evar_universe_context -> evar_map
-val set_universe_context : evar_map -> evar_universe_context -> evar_map
-
-val merge_context_set : ?sideff:bool -> rigid -> evar_map -> Univ.universe_context_set -> evar_map
-val merge_universe_subst : evar_map -> Universes.universe_opt_subst -> evar_map
-
-val with_context_set : rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a
-
-val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst
-val abstract_undefined_variables : evar_universe_context -> evar_universe_context
-
-val fix_undefined_variables : evar_map -> evar_map
-
-val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_subst
-
-val nf_constraints : evar_map -> evar_map
-
-val update_sigma_env : evar_map -> env -> evar_map
-
-(** Polymorphic universes *)
-
-val fresh_sort_in_family : ?rigid:rigid -> env -> evar_map -> sorts_family -> evar_map * sorts
-val fresh_constant_instance : env -> evar_map -> constant -> evar_map * pconstant
-val fresh_inductive_instance : env -> evar_map -> inductive -> evar_map * pinductive
-val fresh_constructor_instance : env -> evar_map -> constructor -> evar_map * pconstructor
-
-val fresh_global : ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map ->
- Globnames.global_reference -> evar_map * constr
-
-(********************************************************************
- Conversion w.r.t. an evar map, not unifying universes. See
- [Reductionops.infer_conv] for conversion up-to universes. *)
-
-val test_conversion : env -> evar_map -> conv_pb -> constr -> constr -> bool
-(** WARNING: This does not allow unification of universes *)
-
-val eq_constr_univs : evar_map -> constr -> constr -> evar_map * bool
-(** Syntactic equality up to universes, recording the associated constraints *)
-
-val e_eq_constr_univs : evar_map ref -> constr -> constr -> bool
-(** Syntactic equality up to universes. *)
-
-(********************************************************************)
-(* constr with holes and pending resolution of classes, conversion *)
-(* problems, candidates, etc. *)
-
-type pending = (* before: *) evar_map * (* after: *) evar_map
-
-type pending_constr = pending * constr
-
-type open_constr = evar_map * constr (* Special case when before is empty *)
-
-(** Partially constructed constrs. *)
-
-type unsolvability_explanation = SeveralInstancesFound of int
-(** Failure explanation. *)
-
-val pr_existential_key : evar_map -> evar -> Pp.std_ppcmds
-
-(** {5 Debug pretty-printers} *)
-
-val pr_evar_info : evar_info -> Pp.std_ppcmds
-val pr_evar_constraints : evar_constraint list -> Pp.std_ppcmds
-val pr_evar_map : ?with_univs:bool -> int option -> evar_map -> Pp.std_ppcmds
-val pr_evar_map_filter : ?with_univs:bool -> (Evar.t -> evar_info -> bool) ->
- evar_map -> Pp.std_ppcmds
-val pr_metaset : Metaset.t -> Pp.std_ppcmds
-val pr_evar_universe_context : evar_universe_context -> Pp.std_ppcmds
-val pr_evd_level : evar_map -> Univ.Level.t -> Pp.std_ppcmds
-
-(** {5 Deprecated functions} *)
-
-val create_evar_defs : evar_map -> evar_map
-(** Create an [evar_map] with empty meta map: *)
-
-val create_goal_evar_defs : evar_map -> evar_map
diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml
index 6733b7fc..4caa1e99 100644
--- a/pretyping/find_subterm.ml
+++ b/pretyping/find_subterm.ml
@@ -8,7 +8,7 @@
open Pp
open Util
-open Errors
+open CErrors
open Names
open Locus
open Term
@@ -59,19 +59,22 @@ let proceed_with_occurrences f occs x =
(** Applying a function over a named_declaration with an hypothesis
location request *)
-let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) =
- let f = f (Some (id,hyploc)) in
- match bodyopt,hyploc with
- | None, InHypValueOnly ->
+let map_named_declaration_with_hyploc f hyploc acc decl =
+ let open Context.Named.Declaration in
+ let f = f (Some (get_id decl, hyploc)) in
+ match decl,hyploc with
+ | LocalAssum (id,_), InHypValueOnly ->
error_occurrences_error (IncorrectInValueOccurrence id)
- | None, _ | Some _, InHypTypeOnly ->
- let acc,typ = f acc typ in acc,(id,bodyopt,typ)
- | Some body, InHypValueOnly ->
- let acc,body = f acc body in acc,(id,Some body,typ)
- | Some body, InHyp ->
+ | LocalAssum (id,typ), _ ->
+ let acc,typ = f acc typ in acc, LocalAssum (id,typ)
+ | LocalDef (id,body,typ), InHypTypeOnly ->
+ let acc,typ = f acc typ in acc, LocalDef (id,body,typ)
+ | LocalDef (id,body,typ), InHypValueOnly ->
+ let acc,body = f acc body in acc, LocalDef (id,body,typ)
+ | LocalDef (id,body,typ), InHyp ->
let acc,body = f acc body in
let acc,typ = f acc typ in
- acc,(id,Some body,typ)
+ acc, LocalDef (id,body,typ)
(** Finding a subterm up to some testing function *)
@@ -105,7 +108,6 @@ let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t =
raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,e)) in
let rec substrec k t =
if nowhere_except_in && !pos > maxocc then t else
- if not (Vars.closed0 t) then subst_below k t else
try
let subst = test.match_fun test.testing_state t in
if Locusops.is_selected !pos occs then
diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli
index 28108f8c..c741ab04 100644
--- a/pretyping/find_subterm.mli
+++ b/pretyping/find_subterm.mli
@@ -7,7 +7,6 @@
(************************************************************************)
open Locus
-open Context
open Term
open Evd
open Pretype_errors
@@ -50,7 +49,7 @@ val replace_term_occ_modulo : occurrences or_like_first ->
val replace_term_occ_decl_modulo :
(occurrences * hyp_location_flag) or_like_first ->
'a testing_function -> (unit -> constr) ->
- named_declaration -> named_declaration
+ Context.Named.Declaration.t -> Context.Named.Declaration.t
(** [subst_closed_term_occ occl c d] replaces occurrences of
closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC),
@@ -62,7 +61,7 @@ val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first ->
closed [c] at positions [occl] by [Rel 1] in [decl]. *)
val subst_closed_term_occ_decl : env -> evar_map ->
(occurrences * hyp_location_flag) or_like_first ->
- constr -> named_declaration -> named_declaration * evar_map
+ constr -> Context.Named.Declaration.t -> Context.Named.Declaration.t * evar_map
(** Miscellaneous *)
val error_invalid_occurrence : int list -> 'a
diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml
index c9860864..51660818 100644
--- a/pretyping/glob_ops.ml
+++ b/pretyping/glob_ops.ml
@@ -266,7 +266,7 @@ let add_name_to_ids set na =
| Anonymous -> set
| Name id -> Id.Set.add id set
-let free_glob_vars =
+let free_glob_vars =
let rec vars bounded vs = function
| GVar (loc,id') -> if Id.Set.mem id' bounded then vs else Id.Set.add id' vs
| GApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args)
@@ -324,10 +324,24 @@ let free_glob_vars =
let vs = vars Id.Set.empty Id.Set.empty rt in
Id.Set.elements vs
+let glob_visible_short_qualid c =
+ let rec aux acc = function
+ | GRef (_,c,_) ->
+ let qualid = Nametab.shortest_qualid_of_global Id.Set.empty c in
+ let dir,id = Libnames.repr_qualid qualid in
+ if DirPath.is_empty dir then id :: acc else acc
+ | c ->
+ fold_glob_constr aux acc c
+ in aux [] c
+
+let warn_variable_collision =
+ let open Pp in
+ CWarnings.create ~name:"variable-collision" ~category:"ltac"
+ (fun name ->
+ strbrk "Collision between bound variables of name " ++ pr_id name)
+
let add_and_check_ident id set =
- if Id.Set.mem id set then
- Pp.(msg_warning
- (str "Collision between bound variables of name " ++ Id.print id));
+ if Id.Set.mem id set then warn_variable_collision id;
Id.Set.add id set
let bound_glob_vars =
@@ -455,6 +469,78 @@ let loc_of_glob_constr = function
| GHole (loc,_,_,_) -> loc
| GCast (loc,_,_) -> loc
+(**********************************************************************)
+(* Alpha-renaming *)
+
+let collide_id l id = List.exists (fun (id',id'') -> Id.equal id id' || Id.equal id id'') l
+let test_id l id = if collide_id l id then raise Not_found
+let test_na l na = name_iter (test_id l) na
+
+let update_subst na l =
+ let in_range id l = List.exists (fun (_,id') -> Id.equal id id') l in
+ let l' = name_fold Id.List.remove_assoc na l in
+ name_fold
+ (fun id _ ->
+ if in_range id l' then
+ let id' = Namegen.next_ident_away_from id (fun id' -> in_range id' l') in
+ Name id', (id,id')::l
+ else na,l)
+ na (na,l)
+
+exception UnsoundRenaming
+
+let rename_var l id =
+ try
+ let id' = Id.List.assoc id l in
+ (* Check that no other earlier binding hide the one found *)
+ let _,(id'',_) = List.extract_first (fun (_,id) -> Id.equal id id') l in
+ if Id.equal id id'' then id' else raise UnsoundRenaming
+ with Not_found ->
+ if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming
+ else id
+
+let rec rename_glob_vars l = function
+ | GVar (loc,id) as r ->
+ let id' = rename_var l id in
+ if id == id' then r else GVar (loc,id')
+ | GRef (_,VarRef id,_) as r ->
+ if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming
+ else r
+ | GProd (loc,na,bk,t,c) ->
+ let na',l' = update_subst na l in
+ GProd (loc,na,bk,rename_glob_vars l t,rename_glob_vars l' c)
+ | GLambda (loc,na,bk,t,c) ->
+ let na',l' = update_subst na l in
+ GLambda (loc,na',bk,rename_glob_vars l t,rename_glob_vars l' c)
+ | GLetIn (loc,na,b,c) ->
+ let na',l' = update_subst na l in
+ GLetIn (loc,na',rename_glob_vars l b,rename_glob_vars l' c)
+ (* Lazy strategy: we fail if a collision with renaming occurs, rather than renaming further *)
+ | GCases (loc,ci,po,tomatchl,cls) ->
+ let test_pred_pat (na,ino) =
+ test_na l na; Option.iter (fun (_,_,nal) -> List.iter (test_na l) nal) ino in
+ let test_clause idl = List.iter (test_id l) idl in
+ let po = Option.map (rename_glob_vars l) po in
+ let tomatchl = Util.List.map_left (fun (tm,x) -> test_pred_pat x; (rename_glob_vars l tm,x)) tomatchl in
+ let cls = Util.List.map_left (fun (loc,idl,p,c) -> test_clause idl; (loc,idl,p,rename_glob_vars l c)) cls in
+ GCases (loc,ci,po,tomatchl,cls)
+ | GLetTuple (loc,nal,(na,po),c,b) ->
+ List.iter (test_na l) (na::nal);
+ GLetTuple (loc,nal,(na,Option.map (rename_glob_vars l) po),
+ rename_glob_vars l c,rename_glob_vars l b)
+ | GIf (loc,c,(na,po),b1,b2) ->
+ test_na l na;
+ GIf (loc,rename_glob_vars l c,(na,Option.map (rename_glob_vars l) po),
+ rename_glob_vars l b1,rename_glob_vars l b2)
+ | GRec (loc,k,idl,decls,bs,ts) ->
+ Array.iter (test_id l) idl;
+ GRec (loc,k,idl,
+ Array.map (List.map (fun (na,k,bbd,bty) ->
+ test_na l na; (na,k,Option.map (rename_glob_vars l) bbd,rename_glob_vars l bty))) decls,
+ Array.map (rename_glob_vars l) bs,
+ Array.map (rename_glob_vars l) ts)
+ | r -> map_glob_constr (rename_glob_vars l) r
+
(**********************************************************************)
(* Conversion from glob_constr to cases pattern, if possible *)
diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli
index 45444234..55e6b653 100644
--- a/pretyping/glob_ops.mli
+++ b/pretyping/glob_ops.mli
@@ -34,12 +34,25 @@ val map_glob_constr :
val map_glob_constr_left_to_right :
(glob_constr -> glob_constr) -> glob_constr -> glob_constr
+val warn_variable_collision : ?loc:Loc.t -> Id.t -> unit
+
val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a
val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit
val occur_glob_constr : Id.t -> glob_constr -> bool
val free_glob_vars : glob_constr -> Id.t list
val bound_glob_vars : glob_constr -> Id.Set.t
val loc_of_glob_constr : glob_constr -> Loc.t
+val glob_visible_short_qualid : glob_constr -> Id.t list
+
+(* Renaming free variables using a renaming map; fails with
+ [UnsoundRenaming] if applying the renaming would introduce
+ collision, as in, e.g., renaming [P x y] using substitution [(x,y)];
+ inner alpha-conversion done only for forall, fun, let but
+ not for cases and fix *)
+
+exception UnsoundRenaming
+val rename_var : (Id.t * Id.t) list -> Id.t -> Id.t
+val rename_glob_vars : (Id.t * Id.t) list -> glob_constr -> glob_constr
(** [map_pattern_binders f m c] applies [f] to all the binding names
in a pattern-matching expression ({!Glob_term.GCases}) represented
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index d5f6e9b3..39aeb41f 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -11,7 +11,7 @@
(* This file builds various inductive schemes *)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Libnames
@@ -19,7 +19,6 @@ open Globnames
open Nameops
open Term
open Vars
-open Context
open Namegen
open Declarations
open Declareops
@@ -28,6 +27,8 @@ open Inductiveops
open Environ
open Reductionops
open Nametab
+open Sigma.Notations
+open Context.Rel.Declaration
type dep_flag = bool
@@ -35,12 +36,14 @@ type dep_flag = bool
type recursion_scheme_error =
| NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive
| NotMutualInScheme of inductive * inductive
+ | NotAllowedDependentAnalysis of (*isrec:*) bool * inductive
exception RecursionSchemeError of recursion_scheme_error
let make_prod_dep dep env = if dep then mkProd_name env else mkProd
let mkLambda_string s t c = mkLambda (Name (Id.of_string s), t, c)
+
(*******************************************)
(* Building curryfied elimination *)
(*******************************************)
@@ -60,7 +63,7 @@ let check_privacy_block mib =
let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
let lnamespar = Vars.subst_instance_context u mib.mind_params_ctxt in
- let indf = make_ind_family(pind, Termops.extended_rel_list 0 lnamespar) in
+ let indf = make_ind_family(pind, Context.Rel.to_extended_list 0 lnamespar) in
let constrs = get_constructors env indf in
let projs = get_projections env indf in
@@ -77,7 +80,6 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
(* mais pas très joli ... (mais manque get_sort_of à ce niveau) *)
let env' = push_rel_context lnamespar env in
-
let rec add_branch env k =
if Int.equal k (Array.length mip.mind_consnames) then
let nbprod = k+1 in
@@ -85,14 +87,14 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
let indf' = lift_inductive_family nbprod indf in
let arsign,_ = get_arity env indf' in
let depind = build_dependent_inductive env indf' in
- let deparsign = (Anonymous,None,depind)::arsign in
+ let deparsign = LocalAssum (Anonymous,depind)::arsign in
let ci = make_case_info env (fst pind) RegularStyle in
let pbody =
appvect
(mkRel (ndepar + nbprod),
- if dep then Termops.extended_rel_vect 0 deparsign
- else Termops.extended_rel_vect 1 arsign) in
+ if dep then Context.Rel.to_extended_vect 0 deparsign
+ else Context.Rel.to_extended_vect 1 arsign) in
let p =
it_mkLambda_or_LetIn_name env'
((if dep then mkLambda_name env' else mkLambda)
@@ -118,15 +120,16 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
let cs = lift_constructor (k+1) constrs.(k) in
let t = build_branch_type env dep (mkRel (k+1)) cs in
mkLambda_string "f" t
- (add_branch (push_rel (Anonymous, None, t) env) (k+1))
+ (add_branch (push_rel (LocalAssum (Anonymous, t)) env) (k+1))
in
- let sigma, s = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in
+ let Sigma (s, sigma, p) = Sigma.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in
let typP = make_arity env' dep indf s in
let c =
it_mkLambda_or_LetIn_name env
(mkLambda_string "P" typP
- (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar
- in sigma, c
+ (add_branch (push_rel (LocalAssum (Anonymous,typP)) env') 0)) lnamespar
+ in
+ Sigma (c, sigma, p)
(* check if the type depends recursively on one of the inductive scheme *)
@@ -150,23 +153,26 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
let nparams = List.length vargs in
let process_pos env depK pk =
let rec prec env i sign p =
- let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
+ let p',largs = whd_allnolet_stack env sigma p in
match kind_of_term p' with
| Prod (n,t,c) ->
- let d = (n,None,t) in
+ let d = LocalAssum (n,t) in
make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c)
- | LetIn (n,b,t,c) ->
- let d = (n,Some b,t) in
+ | LetIn (n,b,t,c) when List.is_empty largs ->
+ let d = LocalDef (n,b,t) in
mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c)
| Ind (_,_) ->
let realargs = List.skipn nparams largs in
let base = applist (lift i pk,realargs) in
if depK then
Reduction.beta_appvect
- base [|applist (mkRel (i+1), Termops.extended_rel_list 0 sign)|]
+ base [|applist (mkRel (i+1), Context.Rel.to_extended_list 0 sign)|]
else
base
- | _ -> assert false
+ | _ ->
+ let t' = whd_all env sigma p in
+ if Term.eq_constr p' t' then assert false
+ else prec env i sign t'
in
prec env 0 []
in
@@ -179,31 +185,29 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
| ra::rest ->
(match dest_recarg ra with
| Mrec (_,j) when is_rec -> (depPvect.(j),rest)
- | Imbr _ ->
- msg_warning (strbrk "Ignoring recursive call");
- (None,rest)
+ | Imbr _ -> (None,rest)
| _ -> (None, rest))
in
(match optionpos with
| None ->
make_prod env
(n,t,
- process_constr (push_rel (n,None,t) env) (i+1) c_0 rest
+ process_constr (push_rel (LocalAssum (n,t)) env) (i+1) c_0 rest
(nhyps-1) (i::li))
| Some(dep',p) ->
let nP = lift (i+1+decP) p in
- let env' = push_rel (n,None,t) env in
+ let env' = push_rel (LocalAssum (n,t)) env in
let t_0 = process_pos env' dep' nP (lift 1 t) in
make_prod_dep (dep || dep') env
(n,t,
mkArrow t_0
(process_constr
- (push_rel (Anonymous,None,t_0) env')
+ (push_rel (LocalAssum (Anonymous,t_0)) env')
(i+2) (lift 1 c_0) rest (nhyps-1) (i::li))))
| LetIn (n,b,t,c_0) ->
mkLetIn (n,b,t,
process_constr
- (push_rel (n,Some b,t) env)
+ (push_rel (LocalDef (n,b,t)) env)
(i+1) c_0 recargs (nhyps-1) li)
| _ -> assert false
else
@@ -225,25 +229,28 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
let process_pos env fk =
let rec prec env i hyps p =
- let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
+ let p',largs = whd_allnolet_stack env sigma p in
match kind_of_term p' with
| Prod (n,t,c) ->
- let d = (n,None,t) in
+ let d = LocalAssum (n,t) in
mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c)
- | LetIn (n,b,t,c) ->
- let d = (n,Some b,t) in
+ | LetIn (n,b,t,c) when List.is_empty largs ->
+ let d = LocalDef (n,b,t) in
mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
| Ind _ ->
let realargs = List.skipn nparrec largs
- and arg = appvect (mkRel (i+1), Termops.extended_rel_vect 0 hyps) in
+ and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect 0 hyps) in
applist(lift i fk,realargs@[arg])
- | _ -> assert false
+ | _ ->
+ let t' = whd_all env sigma p in
+ if Term.eq_constr t' p' then assert false
+ else prec env i hyps t'
in
prec env 0 []
in
(* ici, cstrprods est la liste des produits du constructeur instantié *)
let rec process_constr env i f = function
- | (n,None,t as d)::cprest, recarg::rest ->
+ | (LocalAssum (n,t) as d)::cprest, recarg::rest ->
let optionpos =
match dest_recarg recarg with
| Norec -> None
@@ -264,7 +271,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
(n,t,process_constr env' (i+1)
(whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1); arg])))
(cprest,rest)))
- | (n,Some c,t as d)::cprest, rest ->
+ | (LocalDef (n,c,t) as d)::cprest, rest ->
mkLetIn
(n,c,t,
process_constr (push_rel d env) (i+1) (lift 1 f)
@@ -275,24 +282,13 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
in
process_constr env 0 f (List.rev cstr.cs_args, recargs)
-
-(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k
- variables *)
-let context_chop k ctx =
- let rec chop_aux acc = function
- | (0, l2) -> (List.rev acc, l2)
- | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t)
- | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
- | (_, []) -> failwith "context_chop"
- in chop_aux [] (k,ctx)
-
(* Main function *)
let mis_make_indrec env sigma listdepkind mib u =
let nparams = mib.mind_nparams in
let nparrec = mib.mind_nparams_rec in
let evdref = ref sigma in
let lnonparrec,lnamesparrec =
- context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in
+ Termops.context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in
let nrec = List.length listdepkind in
let depPvec =
Array.make mib.mind_ntypes (None : (bool * constr) option) in
@@ -321,29 +317,29 @@ let mis_make_indrec env sigma listdepkind mib u =
(* arity in the context of the fixpoint, i.e.
P1..P_nrec f1..f_nbconstruct *)
- let args = Termops.extended_rel_list (nrec+nbconstruct) lnamesparrec in
+ let args = Context.Rel.to_extended_list (nrec+nbconstruct) lnamesparrec in
let indf = make_ind_family((indi,u),args) in
let arsign,_ = get_arity env indf in
let depind = build_dependent_inductive env indf in
- let deparsign = (Anonymous,None,depind)::arsign in
+ let deparsign = LocalAssum (Anonymous,depind)::arsign in
- let nonrecpar = rel_context_length lnonparrec in
- let larsign = rel_context_length deparsign in
+ let nonrecpar = Context.Rel.length lnonparrec in
+ let larsign = Context.Rel.length deparsign in
let ndepar = larsign - nonrecpar in
let dect = larsign+nrec+nbconstruct in
(* constructors in context of the Cases expr, i.e.
P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *)
- let args' = Termops.extended_rel_list (dect+nrec) lnamesparrec in
- let args'' = Termops.extended_rel_list ndepar lnonparrec in
+ let args' = Context.Rel.to_extended_list (dect+nrec) lnamesparrec in
+ let args'' = Context.Rel.to_extended_list ndepar lnonparrec in
let indf' = make_ind_family((indi,u),args'@args'') in
let branches =
let constrs = get_constructors env indf' in
let fi = Termops.rel_vect (dect-i-nctyi) nctyi in
let vecfi = Array.map
- (fun f -> appvect (f, Termops.extended_rel_vect ndepar lnonparrec))
+ (fun f -> appvect (f, Context.Rel.to_extended_vect ndepar lnonparrec))
fi
in
Array.map3
@@ -361,12 +357,12 @@ let mis_make_indrec env sigma listdepkind mib u =
let depind' = build_dependent_inductive env indf' in
let arsign',_ = get_arity env indf' in
- let deparsign' = (Anonymous,None,depind')::arsign' in
+ let deparsign' = LocalAssum (Anonymous,depind')::arsign' in
let pargs =
- let nrpar = Termops.extended_rel_list (2*ndepar) lnonparrec
- and nrar = if dep then Termops.extended_rel_list 0 deparsign'
- else Termops.extended_rel_list 1 arsign'
+ let nrpar = Context.Rel.to_extended_list (2*ndepar) lnonparrec
+ and nrar = if dep then Context.Rel.to_extended_list 0 deparsign'
+ else Context.Rel.to_extended_list 1 arsign'
in nrpar@nrar
in
@@ -381,25 +377,9 @@ let mis_make_indrec env sigma listdepkind mib u =
(Anonymous,depind',concl))
arsign'
in
- let obj =
- let projs = get_projections env indf in
- match projs with
- | None -> (mkCase (ci, pred,
- mkRel 1,
- branches))
- | Some ps ->
- let branch = branches.(0) in
- let ctx, br = decompose_lam_assum branch in
- let n, subst =
- List.fold_right (fun (na,b,t) (i, subst) ->
- if b == None then
- let t = mkProj (Projection.make ps.(i) true, mkRel 1) in
- (i + 1, t :: subst)
- else (i, mkRel 0 :: subst))
- ctx (0, [])
- in
- let term = substl subst br in
- term
+ let obj =
+ Inductiveops.make_case_or_project env indf ci pred
+ (mkRel 1) branches
in
it_mkLambda_or_LetIn_name env obj
(Termops.lift_rel_context nrec deparsign)
@@ -409,14 +389,14 @@ let mis_make_indrec env sigma listdepkind mib u =
let typtyi =
let concl =
- let pargs = if dep then Termops.extended_rel_vect 0 deparsign
- else Termops.extended_rel_vect 1 arsign
+ let pargs = if dep then Context.Rel.to_extended_vect 0 deparsign
+ else Context.Rel.to_extended_vect 1 arsign
in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs)
in it_mkProd_or_LetIn_name env
concl
deparsign
in
- mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp)
+ mrec (i+nctyi) (Context.Rel.nhyps arsign ::ln) (typtyi::ltyp)
(deftyi::ldef) rest
| [] ->
let fixn = Array.of_list (List.rev ln) in
@@ -437,28 +417,28 @@ let mis_make_indrec env sigma listdepkind mib u =
else
let recarg = (dest_subterms recargsvec.(tyi)).(j) in
let recarg = recargpar@recarg in
- let vargs = Termops.extended_rel_list (nrec+i+j) lnamesparrec in
+ let vargs = Context.Rel.to_extended_list (nrec+i+j) lnamesparrec in
let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in
let p_0 =
type_rec_branch
true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg
in
mkLambda_string "f" p_0
- (onerec (push_rel (Anonymous,None,p_0) env) (j+1))
+ (onerec (push_rel (LocalAssum (Anonymous,p_0)) env) (j+1))
in onerec env 0
| [] ->
makefix i listdepkind
in
let rec put_arity env i = function
| ((indi,u),_,_,dep,kinds)::rest ->
- let indf = make_ind_family ((indi,u), Termops.extended_rel_list i lnamesparrec) in
+ let indf = make_ind_family ((indi,u), Context.Rel.to_extended_list i lnamesparrec) in
let s =
Evarutil.evd_comb1 (Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env)
evdref kinds
in
let typP = make_arity env dep indf s in
mkLambda_string "P" typP
- (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest)
+ (put_arity (push_rel (LocalAssum (Anonymous,typP)) env) (i+1) rest)
| [] ->
make_branch env 0 listdepkind
in
@@ -474,7 +454,9 @@ let mis_make_indrec env sigma listdepkind mib u =
it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind)
lnamesparrec
else
- let evd', c = mis_make_case_com dep env !evdref (indi,u) (mibi,mipi) kind in
+ let sigma = Sigma.Unsafe.of_evar_map !evdref in
+ let Sigma (c, sigma, _) = mis_make_case_com dep env sigma (indi,u) (mibi,mipi) kind in
+ let evd' = Sigma.to_evar_map sigma in
evdref := evd'; c
in
(* Body of mis_make_indrec *)
@@ -485,6 +467,8 @@ let mis_make_indrec env sigma listdepkind mib u =
let build_case_analysis_scheme env sigma pity dep kind =
let (mib,mip) = lookup_mind_specif env (fst pity) in
+ if dep && not (Inductiveops.has_dependent_elim mib) then
+ raise (RecursionSchemeError (NotAllowedDependentAnalysis (false, fst pity)));
mis_make_case_com dep env sigma pity (mib,mip) kind
let is_in_prop mip =
@@ -494,7 +478,7 @@ let is_in_prop mip =
let build_case_analysis_scheme_default env sigma pity kind =
let (mib,mip) = lookup_mind_specif env (fst pity) in
- let dep = not (is_in_prop mip) in
+ let dep = not (is_in_prop mip || not (Inductiveops.has_dependent_elim mib)) in
mis_make_case_com dep env sigma pity (mib,mip) kind
(**********************************************************************)
@@ -555,6 +539,8 @@ let check_arities env listdepkind =
let build_mutual_induction_scheme env sigma = function
| ((mind,u),dep,s)::lrecspec ->
let (mib,mip) = lookup_mind_specif env mind in
+ if dep && not (Inductiveops.has_dependent_elim mib) then
+ raise (RecursionSchemeError (NotAllowedDependentAnalysis (true, mind)));
let (sp,tyi) = mind in
let listdepkind =
((mind,u),mib,mip,dep,s)::
@@ -574,6 +560,8 @@ let build_mutual_induction_scheme env sigma = function
let build_induction_scheme env sigma pind dep kind =
let (mib,mip) = lookup_mind_specif env (fst pind) in
+ if dep && not (Inductiveops.has_dependent_elim mib) then
+ raise (RecursionSchemeError (NotAllowedDependentAnalysis (true, fst pind)));
let sigma, l = mis_make_indrec env sigma [(pind,mib,mip,dep,kind)] mib (snd pind) in
sigma, List.hd l
@@ -592,7 +580,7 @@ let make_elimination_ident id s = add_suffix id (elimination_suffix s)
let lookup_eliminator ind_sp s =
let kn,i = ind_sp in
- let mp,dp,l = repr_mind kn in
+ let mp,dp,l = KerName.repr (MutInd.canonical kn) in
let ind_id = (Global.lookup_mind kn).mind_packets.(i).mind_typename in
let id = add_suffix ind_id (elimination_suffix s) in
(* Try first to get an eliminator defined in the same section as the *)
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index 4d81a59e..192b64a5 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.mli
@@ -16,6 +16,7 @@ open Evd
type recursion_scheme_error =
| NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive
| NotMutualInScheme of inductive * inductive
+ | NotAllowedDependentAnalysis of (*isrec:*) bool * inductive
exception RecursionSchemeError of recursion_scheme_error
@@ -25,16 +26,18 @@ type dep_flag = bool
(** Build a case analysis elimination scheme in some sort family *)
-val build_case_analysis_scheme : env -> evar_map -> pinductive ->
- dep_flag -> sorts_family -> evar_map * constr
+val build_case_analysis_scheme : env -> 'r Sigma.t -> pinductive ->
+ dep_flag -> sorts_family -> (constr, 'r) Sigma.sigma
-(** Build a dependent case elimination predicate unless type is in Prop *)
+(** Build a dependent case elimination predicate unless type is in Prop
+ or is a recursive record with primitive projections. *)
-val build_case_analysis_scheme_default : env -> evar_map -> pinductive ->
- sorts_family -> evar_map * constr
+val build_case_analysis_scheme_default : env -> 'r Sigma.t -> pinductive ->
+ sorts_family -> (constr, 'r) Sigma.sigma
(** Builds a recursive induction scheme (Peano-induction style) in the same
- sort family as the inductive family; it is dependent if not in Prop *)
+ sort family as the inductive family; it is dependent if not in Prop
+ or a recursive record with primitive projections. *)
val build_induction_scheme : env -> evar_map -> pinductive ->
dep_flag -> sorts_family -> evar_map * constr
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index fb180b8b..214e19fe 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -6,18 +6,18 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Univ
open Term
open Vars
-open Context
open Termops
open Declarations
open Declareops
open Environ
open Reductionops
+open Context.Rel.Declaration
(* The following three functions are similar to the ones defined in
Inductive, but they expect an env *)
@@ -142,12 +142,12 @@ let constructor_nallargs_env env ((kn,i),j) =
let constructor_nalldecls (indsp,j) = (* TOCHANGE en decls *)
let (mib,mip) = Global.lookup_inductive indsp in
- mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt)
+ mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt)
let constructor_nalldecls_env env ((kn,i),j) = (* TOCHANGE en decls *)
let mib = Environ.lookup_mind kn env in
let mip = mib.mind_packets.(i) in
- mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt)
+ mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt)
(* Arity of constructors excluding params, excluding local defs *)
@@ -213,21 +213,21 @@ let inductive_nparams_env env ind =
let inductive_nparamdecls ind =
let (mib,mip) = Global.lookup_inductive ind in
- rel_context_length mib.mind_params_ctxt
+ Context.Rel.length mib.mind_params_ctxt
let inductive_nparamdecls_env env ind =
let (mib,mip) = Inductive.lookup_mind_specif env ind in
- rel_context_length mib.mind_params_ctxt
+ Context.Rel.length mib.mind_params_ctxt
(* Full length of arity (with local defs) *)
let inductive_nalldecls ind =
let (mib,mip) = Global.lookup_inductive ind in
- rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls
+ Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls
let inductive_nalldecls_env env ind =
let (mib,mip) = Inductive.lookup_mind_specif env ind in
- rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls
+ Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls
(* Others *)
@@ -249,13 +249,13 @@ let inductive_alldecls_env env (ind,u) =
let constructor_has_local_defs (indsp,j) =
let (mib,mip) = Global.lookup_inductive indsp in
- let l1 = mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt) in
+ let l1 = mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) in
let l2 = recarg_length mip.mind_recargs j + mib.mind_nparams in
not (Int.equal l1 l2)
let inductive_has_local_defs ind =
let (mib,mip) = Global.lookup_inductive ind in
- let l1 = rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls in
+ let l1 = Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls in
let l2 = mib.mind_nparams + mip.mind_nrealargs in
not (Int.equal l1 l2)
@@ -269,15 +269,20 @@ let projection_nparams_env env p =
let projection_nparams p = projection_nparams_env (Global.env ()) p
+let has_dependent_elim mib =
+ match mib.mind_record with
+ | Some (Some _) -> mib.mind_finite == Decl_kinds.BiFinite
+ | _ -> true
+
(* Annotation for cases *)
let make_case_info env ind style =
let (mib,mip) = Inductive.lookup_mind_specif env ind in
let ind_tags =
- rel_context_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in
+ Context.Rel.to_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in
let cstr_tags =
Array.map2 (fun c n ->
let d,_ = decompose_prod_assum c in
- rel_context_tags (List.firstn n d))
+ Context.Rel.to_tags (List.firstn n d))
mip.mind_nf_lc mip.mind_consnrealdecls in
let print_info = { ind_tags; cstr_tags; style } in
{ ci_ind = ind;
@@ -292,7 +297,7 @@ type constructor_summary = {
cs_cstr : pconstructor;
cs_params : constr list;
cs_nargs : int;
- cs_args : rel_context;
+ cs_args : Context.Rel.t;
cs_concl_realargs : constr array
}
@@ -303,21 +308,15 @@ let lift_constructor n cs = {
cs_args = lift_rel_context n cs.cs_args;
cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs
}
-(* Accept less parameters than in the signature *)
-
-let instantiate_params t args sign =
- let rec inst s t = function
- | ((_,None,_)::ctxt,a::args) ->
- (match kind_of_term t with
- | Prod(_,_,t) -> inst (a::s) t (ctxt,args)
- | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch"))
- | ((_,(Some b),_)::ctxt,args) ->
- (match kind_of_term t with
- | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args)
- | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch"))
- | _, [] -> substl s t
- | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch")
- in inst [] t (List.rev sign,args)
+
+(* Accept either all parameters or only recursively uniform ones *)
+let instantiate_params t params sign =
+ let nnonrecpar = Context.Rel.nhyps sign - List.length params in
+ (* Adjust the signature if recursively non-uniform parameters are not here *)
+ let _,sign = context_chop nnonrecpar sign in
+ let _,t = decompose_prod_n_assum (Context.Rel.length sign) t in
+ let subst = subst_of_rel_context_instance sign params in
+ substl subst t
let get_constructor ((ind,u as indu),mib,mip,params) j =
assert (j <= Array.length mip.mind_consnames);
@@ -329,7 +328,7 @@ let get_constructor ((ind,u as indu),mib,mip,params) j =
let vargs = List.skipn (List.length params) allargs in
{ cs_cstr = (ith_constructor_of_inductive ind j,u);
cs_params = params;
- cs_nargs = rel_context_length args;
+ cs_nargs = Context.Rel.length args;
cs_args = args;
cs_concl_realargs = Array.of_list vargs }
@@ -344,6 +343,35 @@ let get_projections env (ind,params) =
| Some (Some (id, projs, pbs)) -> Some projs
| _ -> None
+let make_case_or_project env indf ci pred c branches =
+ let projs = get_projections env indf in
+ match projs with
+ | None -> (mkCase (ci, pred, c, branches))
+ | Some ps ->
+ assert(Array.length branches == 1);
+ let () =
+ let _, _, t = destLambda pred in
+ let (ind, _), _ = dest_ind_family indf in
+ let mib, _ = Inductive.lookup_mind_specif env ind in
+ if (* dependent *) not (noccurn 1 t) &&
+ not (has_dependent_elim mib) then
+ errorlabstrm "make_case_or_project"
+ Pp.(str"Dependent case analysis not allowed" ++
+ str" on inductive type " ++ Names.MutInd.print (fst ind))
+ in
+ let branch = branches.(0) in
+ let ctx, br = decompose_lam_n_assum (Array.length ps) branch in
+ let n, subst =
+ List.fold_right
+ (fun decl (i, subst) ->
+ match decl with
+ | LocalAssum (na, t) ->
+ let t = mkProj (Projection.make ps.(i) true, c) in
+ (i + 1, t :: subst)
+ | LocalDef (na, b, t) -> (i, substl subst b :: subst))
+ ctx (0, [])
+ in substl subst br
+
(* substitution in a signature *)
let substnl_rel_context subst n sign =
@@ -354,14 +382,6 @@ let substnl_rel_context subst n sign =
let substl_rel_context subst = substnl_rel_context subst 0
-let instantiate_context sign args =
- let rec aux subst = function
- | (_,None,_)::sign, a::args -> aux (a::subst) (sign,args)
- | (_,Some b,_)::sign, args -> aux (substl subst b::subst) (sign,args)
- | [], [] -> subst
- | _ -> anomaly (Pp.str "Signature/instance mismatch in inductive family")
- in aux [] (List.rev sign,args)
-
let get_arity env ((ind,u),params) =
let (mib,mip) = Inductive.lookup_mind_specif env ind in
let parsign =
@@ -379,7 +399,7 @@ let get_arity env ((ind,u),params) =
let parsign = Vars.subst_instance_context u parsign in
let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in
let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in
- let subst = instantiate_context parsign params in
+ let subst = subst_of_rel_context_instance parsign params in
let arsign = Vars.subst_instance_context u arsign in
(substl_rel_context subst arsign, Inductive.inductive_sort_family mip)
@@ -388,14 +408,14 @@ let build_dependent_constructor cs =
applist
(mkConstructU cs.cs_cstr,
(List.map (lift cs.cs_nargs) cs.cs_params)
- @(extended_rel_list 0 cs.cs_args))
+ @(Context.Rel.to_extended_list 0 cs.cs_args))
let build_dependent_inductive env ((ind, params) as indf) =
let arsign,_ = get_arity env indf in
let nrealargs = List.length arsign in
applist
(mkIndU ind,
- (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign))
+ (List.map (lift nrealargs) params)@(Context.Rel.to_extended_list 0 arsign))
(* builds the arity of an elimination predicate in sort [s] *)
@@ -404,7 +424,7 @@ let make_arity_signature env dep indf =
if dep then
(* We need names everywhere *)
Namegen.name_context env
- ((Anonymous,None,build_dependent_inductive env indf)::arsign)
+ ((LocalAssum (Anonymous,build_dependent_inductive env indf))::arsign)
(* Costly: would be better to name once for all at definition time *)
else
(* No need to enforce names *)
@@ -430,14 +450,17 @@ let extract_mrectype t =
| Ind ind -> (ind, l)
| _ -> raise Not_found
-let find_mrectype env sigma c =
- let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+let find_mrectype_vect env sigma c =
+ let (t, l) = decompose_appvect (whd_all env sigma c) in
match kind_of_term t with
| Ind ind -> (ind, l)
| _ -> raise Not_found
+let find_mrectype env sigma c =
+ let (ind, v) = find_mrectype_vect env sigma c in (ind, Array.to_list v)
+
let find_rectype env sigma c =
- let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+ let (t, l) = decompose_app (whd_all env sigma c) in
match kind_of_term t with
| Ind (ind,u as indu) ->
let (mib,mip) = Inductive.lookup_mind_specif env ind in
@@ -447,7 +470,7 @@ let find_rectype env sigma c =
| _ -> raise Not_found
let find_inductive env sigma c =
- let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+ let (t, l) = decompose_app (whd_all env sigma c) in
match kind_of_term t with
| Ind ind
when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite <> Decl_kinds.CoFinite ->
@@ -455,7 +478,7 @@ let find_inductive env sigma c =
| _ -> raise Not_found
let find_coinductive env sigma c =
- let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+ let (t, l) = decompose_app (whd_all env sigma c) in
match kind_of_term t with
| Ind ind
when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite == Decl_kinds.CoFinite ->
@@ -469,9 +492,9 @@ let find_coinductive env sigma c =
let is_predicate_explicitly_dep env pred arsign =
let rec srec env pval arsign =
- let pv' = whd_betadeltaiota env Evd.empty pval in
+ let pv' = whd_all env Evd.empty pval in
match kind_of_term pv', arsign with
- | Lambda (na,t,b), (_,None,_)::arsign ->
+ | Lambda (na,t,b), (LocalAssum _)::arsign ->
srec (push_rel_assum (na,t) env) b arsign
| Lambda (na,_,t), _ ->
@@ -517,7 +540,7 @@ let set_pattern_names env ind brv =
let arities =
Array.map
(fun c ->
- rel_context_length ((prod_assum c)) -
+ Context.Rel.length ((prod_assum c)) -
mib.mind_nparams)
mip.mind_nf_lc in
Array.map2 (set_names env) arities brv
@@ -529,7 +552,7 @@ let type_case_branches_with_names env indspec p c =
let (params,realargs) = List.chop nparams args in
let lbrty = Inductive.build_branches_type ind specif params p in
(* Build case type *)
- let conclty = Reduction.betazeta_appvect (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in
+ let conclty = lambda_appvect_assum (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in
(* Adjust names *)
if is_elim_predicate_explicitly_dependent env p (ind,params) then
(set_pattern_names env (fst ind) lbrty, conclty)
@@ -551,11 +574,11 @@ let arity_of_case_predicate env (ind,params) dep k =
that appear in the type of the inductive by the sort of the
conclusion, and the other ones by fresh universes. *)
let rec instantiate_universes env evdref scl is = function
- | (_,Some _,_ as d)::sign, exp ->
+ | (LocalDef _ as d)::sign, exp ->
d :: instantiate_universes env evdref scl is (sign, exp)
| d::sign, None::exp ->
d :: instantiate_universes env evdref scl is (sign, exp)
- | (na,None,ty)::sign, Some l::exp ->
+ | (LocalAssum (na,ty))::sign, Some l::exp ->
let ctx,_ = Reduction.dest_arity env ty in
let u = Univ.Universe.make l in
let s =
@@ -569,7 +592,7 @@ let rec instantiate_universes env evdref scl is = function
let evm = Evd.set_leq_sort env evm s (Sorts.sort_of_univ u) in
evdref := evm; s
in
- (na,None,mkArity(ctx,s)):: instantiate_universes env evdref scl is (sign, exp)
+ (LocalAssum (na,mkArity(ctx,s))) :: instantiate_universes env evdref scl is (sign, exp)
| sign, [] -> sign (* Uniform parameters are exhausted *)
| [], _ -> assert false
@@ -603,9 +626,9 @@ let type_of_projection_knowing_arg env sigma p c ty =
let control_only_guard env c =
let check_fix_cofix e c = match kind_of_term c with
| CoFix (_,(_,_,_) as cofix) ->
- Inductive.check_cofix e cofix
+ Inductive.check_cofix e cofix
| Fix (_,(_,_,_) as fix) ->
- Inductive.check_fix e fix
+ Inductive.check_fix e fix
| _ -> ()
in
let rec iter env c =
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index 7cd2ff2a..7bd61659 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -8,7 +8,6 @@
open Names
open Term
-open Context
open Declarations
open Environ
open Evd
@@ -92,12 +91,12 @@ val inductive_nparamdecls : inductive -> int
val inductive_nparamdecls_env : env -> inductive -> int
(** @return params context *)
-val inductive_paramdecls : pinductive -> rel_context
-val inductive_paramdecls_env : env -> pinductive -> rel_context
+val inductive_paramdecls : pinductive -> Context.Rel.t
+val inductive_paramdecls_env : env -> pinductive -> Context.Rel.t
(** @return full arity context, hence with letin *)
-val inductive_alldecls : pinductive -> rel_context
-val inductive_alldecls_env : env -> pinductive -> rel_context
+val inductive_alldecls : pinductive -> Context.Rel.t
+val inductive_alldecls_env : env -> pinductive -> Context.Rel.t
(** {7 Extract information from a constructor name} *)
@@ -123,19 +122,24 @@ val inductive_has_local_defs : inductive -> bool
val allowed_sorts : env -> inductive -> sorts_family list
+(** (Co)Inductive records with primitive projections do not have eta-conversion,
+ hence no dependent elimination. *)
+val has_dependent_elim : mutual_inductive_body -> bool
+
(** Primitive projections *)
val projection_nparams : projection -> int
val projection_nparams_env : env -> projection -> int
val type_of_projection_knowing_arg : env -> evar_map -> Projection.t ->
- constr -> types -> types
+ constr -> types -> types
+
(** Extract information from an inductive family *)
type constructor_summary = {
cs_cstr : pconstructor; (* internal name of the constructor plus universes *)
- cs_params : constr list; (* parameters of the constructor in current ctx *)
- cs_nargs : int; (* length of arguments signature (letin included) *)
- cs_args : rel_context; (* signature of the arguments (letin included) *)
+ cs_params : constr list; (* parameters of the constructor in current ctx *)
+ cs_nargs : int; (* length of arguments signature (letin included) *)
+ cs_args : Context.Rel.t; (* signature of the arguments (letin included) *)
cs_concl_realargs : constr array; (* actual realargs in the concl of cstr *)
}
val lift_constructor : int -> constructor_summary -> constructor_summary
@@ -148,17 +152,18 @@ val get_projections : env -> inductive_family -> constant array option
(** [get_arity] returns the arity of the inductive family instantiated
with the parameters; if recursively non-uniform parameters are not
part of the inductive family, they appears in the arity *)
-val get_arity : env -> inductive_family -> rel_context * sorts_family
+val get_arity : env -> inductive_family -> Context.Rel.t * sorts_family
val build_dependent_constructor : constructor_summary -> constr
val build_dependent_inductive : env -> inductive_family -> constr
-val make_arity_signature : env -> bool -> inductive_family -> rel_context
+val make_arity_signature : env -> bool -> inductive_family -> Context.Rel.t
val make_arity : env -> bool -> inductive_family -> sorts -> types
val build_branch_type : env -> bool -> constr -> constructor_summary -> types
(** Raise [Not_found] if not given a valid inductive type *)
val extract_mrectype : constr -> pinductive * constr list
val find_mrectype : env -> evar_map -> types -> pinductive * constr list
+val find_mrectype_vect : env -> evar_map -> types -> pinductive * constr array
val find_rectype : env -> evar_map -> types -> inductive_type
val find_inductive : env -> evar_map -> types -> pinductive * constr list
val find_coinductive : env -> evar_map -> types -> pinductive * constr list
@@ -175,6 +180,14 @@ val type_case_branches_with_names :
(** Annotation for cases *)
val make_case_info : env -> inductive -> case_style -> case_info
+(** Make a case or substitute projections if the inductive type is a record
+ with primitive projections.
+ Fail with an error if the elimination is dependent while the
+ inductive type does not allow dependent elimination. *)
+val make_case_or_project :
+ env -> inductive_family -> case_info ->
+ (* pred *) constr -> (* term *) constr -> (* branches *) constr array -> constr
+
(*i Compatibility
val make_default_case_info : env -> case_style -> inductive -> case_info
i*)
diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml
index d89aeccd..e4fbf8d5 100644
--- a/pretyping/locusops.ml
+++ b/pretyping/locusops.ml
@@ -50,9 +50,9 @@ let is_nowhere = function
let simple_clause_of enum_hyps cl =
let error_occurrences () =
- Errors.error "This tactic does not support occurrences selection" in
+ CErrors.error "This tactic does not support occurrences selection" in
let error_body_selection () =
- Errors.error "This tactic does not support body selection" in
+ CErrors.error "This tactic does not support body selection" in
let hyps =
match cl.onhyps with
| None ->
@@ -84,7 +84,7 @@ let concrete_clause_of enum_hyps cl =
(** Miscellaneous functions *)
let out_arg = function
- | Misctypes.ArgVar _ -> Errors.anomaly (Pp.str "Unevaluated or_var variable")
+ | Misctypes.ArgVar _ -> CErrors.anomaly (Pp.str "Unevaluated or_var variable")
| Misctypes.ArgArg x -> x
let occurrences_of_hyp id cls =
diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml
deleted file mode 100644
index fc3f0cc7..00000000
--- a/pretyping/namegen.ml
+++ /dev/null
@@ -1,395 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(*
- let rec find_prefix = function
- |MPfile dp1 -> not (DirPath.equal dp1 dp)
- |MPdot(mp,_) -> find_prefix mp
- |MPbound(_) -> false
- in find_prefix (Lib.current_mp ())
- | _ -> false
-
-let is_imported_ref = function
- | VarRef _ -> false
- | IndRef (kn,_)
- | ConstructRef ((kn,_),_) ->
- let (mp,_,_) = repr_mind kn in is_imported_modpath mp
- | ConstRef kn ->
- let (mp,_,_) = repr_con kn in is_imported_modpath mp
-
-let is_global id =
- try
- let ref = locate (qualid_of_ident id) in
- not (is_imported_ref ref)
- with Not_found ->
- false
-
-let is_constructor id =
- try
- match locate (qualid_of_ident id) with
- | ConstructRef _ -> true
- | _ -> false
- with Not_found ->
- false
-
-(**********************************************************************)
-(* Generating "intuitive" names from its type *)
-
-let head_name c = (* Find the head constant of a constr if any *)
- let rec hdrec c =
- match kind_of_term c with
- | Prod (_,_,c) | Lambda (_,_,c) | LetIn (_,_,_,c)
- | Cast (c,_,_) | App (c,_) -> hdrec c
- | Proj (kn,_) -> Some (Label.to_id (con_label (Projection.constant kn)))
- | Const _ | Ind _ | Construct _ | Var _ ->
- Some (basename_of_global (global_of_constr c))
- | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) ->
- Some (match lna.(i) with Name id -> id | _ -> assert false)
- | Sort _ | Rel _ | Meta _|Evar _|Case (_, _, _, _) -> None
- in
- hdrec c
-
-let lowercase_first_char id = (* First character of a constr *)
- Unicode.lowercase_first_char (Id.to_string id)
-
-let sort_hdchar = function
- | Prop(_) -> "P"
- | Type(_) -> "T"
-
-let hdchar env c =
- let rec hdrec k c =
- match kind_of_term c with
- | Prod (_,_,c) | Lambda (_,_,c) | LetIn (_,_,_,c) -> hdrec (k+1) c
- | Cast (c,_,_) | App (c,_) -> hdrec k c
- | Proj (kn,_) -> lowercase_first_char (Label.to_id (con_label (Projection.constant kn)))
- | Const (kn,_) -> lowercase_first_char (Label.to_id (con_label kn))
- | Ind (x,_) -> lowercase_first_char (basename_of_global (IndRef x))
- | Construct (x,_) -> lowercase_first_char (basename_of_global (ConstructRef x))
- | Var id -> lowercase_first_char id
- | Sort s -> sort_hdchar s
- | Rel n ->
- (if n<=k then "p" (* the initial term is flexible product/function *)
- else
- try match Environ.lookup_rel (n-k) env with
- | (Name id,_,_) -> lowercase_first_char id
- | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t)
- with Not_found -> "y")
- | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) ->
- let id = match lna.(i) with Name id -> id | _ -> assert false in
- lowercase_first_char id
- | Evar _ (* We could do better... *)
- | Meta _ | Case (_, _, _, _) -> "y"
- in
- hdrec 0 c
-
-let id_of_name_using_hdchar env a = function
- | Anonymous -> Id.of_string (hdchar env a)
- | Name id -> id
-
-let named_hd env a = function
- | Anonymous -> Name (Id.of_string (hdchar env a))
- | x -> x
-
-let mkProd_name env (n,a,b) = mkProd (named_hd env a n, a, b)
-let mkLambda_name env (n,a,b) = mkLambda (named_hd env a n, a, b)
-
-let lambda_name = mkLambda_name
-let prod_name = mkProd_name
-
-let prod_create env (a,b) = mkProd (named_hd env a Anonymous, a, b)
-let lambda_create env (a,b) = mkLambda (named_hd env a Anonymous, a, b)
-
-let name_assumption env (na,c,t) =
- match c with
- | None -> (named_hd env t na, None, t)
- | Some body -> (named_hd env body na, c, t)
-
-let name_context env hyps =
- snd
- (List.fold_left
- (fun (env,hyps) d ->
- let d' = name_assumption env d in (push_rel d' env, d' :: hyps))
- (env,[]) (List.rev hyps))
-
-let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b
-let mkLambda_or_LetIn_name env b d = mkLambda_or_LetIn (name_assumption env d)b
-
-let it_mkProd_or_LetIn_name env b hyps =
- it_mkProd_or_LetIn b (name_context env hyps)
-let it_mkLambda_or_LetIn_name env b hyps =
- it_mkLambda_or_LetIn b (name_context env hyps)
-
-(**********************************************************************)
-(* Fresh names *)
-
-(* Looks for next "good" name by lifting subscript *)
-
-let next_ident_away_from id bad =
- let rec name_rec id = if bad id then name_rec (lift_subscript id) else id in
- name_rec id
-
-(* Restart subscript from x0 if name starts with xN, or x00 if name
- starts with x0N, etc *)
-
-let restart_subscript id =
- if not (has_subscript id) then id else
- (* It would probably be better with something in the spirit of
- *** make_ident id (Some 0) *** but compatibility would be lost... *)
- forget_subscript id
-
-let rec to_avoid id = function
-| [] -> false
-| id' :: avoid -> Id.equal id id' || to_avoid id avoid
-
-let occur_rel p env id =
- try
- let name = lookup_name_of_rel p env in
- begin match name with
- | Name id' -> Id.equal id' id
- | Anonymous -> false
- end
- with Not_found -> false (* Unbound indice : may happen in debug *)
-
-let visibly_occur_id id (nenv,c) =
- let rec occur n c = match kind_of_term c with
- | Const _ | Ind _ | Construct _ | Var _
- when
- let short = shortest_qualid_of_global Id.Set.empty (global_of_constr c) in
- qualid_eq short (qualid_of_ident id) ->
- raise Occur
- | Rel p when p>n && occur_rel (p-n) nenv id -> raise Occur
- | _ -> iter_constr_with_binders succ occur n c
- in
- try occur 1 c; false
- with Occur -> true
- | Not_found -> false (* Happens when a global is not in the env *)
-
-(* Now, there are different renaming strategies... *)
-
-(* 1- Looks for a fresh name for printing in cases pattern *)
-
-let next_name_away_in_cases_pattern env_t na avoid =
- let id = match na with Name id -> id | Anonymous -> default_dependent_ident in
- let bad id = to_avoid id avoid || is_constructor id
- || visibly_occur_id id env_t in
- next_ident_away_from id bad
-
-(* 2- Looks for a fresh name for introduction in goal *)
-
-(* The legacy strategy for renaming introduction variables is not very uniform:
- - if the name to use is fresh in the context but used as a global
- name, then a fresh name is taken by finding a free subscript
- starting from the current subscript;
- - but if the name to use is not fresh in the current context, the fresh
- name is taken by finding a free subscript starting from 0 *)
-
-let next_ident_away_in_goal id avoid =
- let id = if to_avoid id avoid then restart_subscript id else id in
- let bad id = to_avoid id avoid || (is_global id && not (is_section_variable id)) in
- next_ident_away_from id bad
-
-let next_name_away_in_goal na avoid =
- let id = match na with
- | Name id -> id
- | Anonymous -> default_non_dependent_ident in
- next_ident_away_in_goal id avoid
-
-(* 3- Looks for next fresh name outside a list that is moreover valid
- as a global identifier; the legacy algorithm is that if the name is
- already used in the list, one looks for a name of same base with
- lower available subscript; if the name is not in the list but is
- used globally, one looks for a name of same base with lower subscript
- beyond the current subscript *)
-
-let next_global_ident_away id avoid =
- let id = if to_avoid id avoid then restart_subscript id else id in
- let bad id = to_avoid id avoid || is_global id in
- next_ident_away_from id bad
-
-(* 4- Looks for next fresh name outside a list; if name already used,
- looks for same name with lower available subscript *)
-
-let next_ident_away id avoid =
- if to_avoid id avoid then
- next_ident_away_from (restart_subscript id) (fun id -> to_avoid id avoid)
- else id
-
-let next_name_away_with_default default na avoid =
- let id = match na with Name id -> id | Anonymous -> Id.of_string default in
- next_ident_away id avoid
-
-let reserved_type_name = ref (fun t -> Anonymous)
-let set_reserved_typed_name f = reserved_type_name := f
-
-let next_name_away_with_default_using_types default na avoid t =
- let id = match na with
- | Name id -> id
- | Anonymous -> match !reserved_type_name t with
- | Name id -> id
- | Anonymous -> Id.of_string default in
- next_ident_away id avoid
-
-let next_name_away = next_name_away_with_default default_non_dependent_string
-
-let make_all_name_different env =
- let avoid = ref (ids_of_named_context (named_context env)) in
- process_rel_context
- (fun (na,c,t) newenv ->
- let na = named_hd newenv t na in
- let id = next_name_away na !avoid in
- avoid := id::!avoid;
- push_rel (Name id,c,t) newenv)
- env
-
-(* 5- Looks for next fresh name outside a list; avoids also to use names that
- would clash with short name of global references; if name is already used,
- looks for name of same base with lower available subscript beyond current
- subscript *)
-
-let next_ident_away_for_default_printing env_t id avoid =
- let bad id = to_avoid id avoid || visibly_occur_id id env_t in
- next_ident_away_from id bad
-
-let next_name_away_for_default_printing env_t na avoid =
- let id = match na with
- | Name id -> id
- | Anonymous ->
- (* In principle, an anonymous name is not dependent and will not be *)
- (* taken into account by the function compute_displayed_name_in; *)
- (* just in case, invent a valid name *)
- default_non_dependent_ident in
- next_ident_away_for_default_printing env_t id avoid
-
-(**********************************************************************)
-(* Displaying terms avoiding bound variables clashes *)
-
-(* Renaming strategy introduced in December 1998:
-
- - Rule number 1: all names, even if unbound and not displayed, contribute
- to the list of names to avoid
- - Rule number 2: only the dependency status is used for deciding if
- a name is displayed or not
-
- Example:
- bool_ind: "forall (P:bool->Prop)(f:(P true))(f:(P false))(b:bool), P b" is
- displayed "forall P:bool->Prop, P true -> P false -> forall b:bool, P b"
- but f and f0 contribute to the list of variables to avoid (knowing
- that f and f0 are how the f's would be named if introduced, assuming
- no other f and f0 are already used).
-*)
-
-type renaming_flags =
- | RenamingForCasesPattern of (Name.t list * constr)
- | RenamingForGoal
- | RenamingElsewhereFor of (Name.t list * constr)
-
-let next_name_for_display flags =
- match flags with
- | RenamingForCasesPattern env_t -> next_name_away_in_cases_pattern env_t
- | RenamingForGoal -> next_name_away_in_goal
- | RenamingElsewhereFor env_t -> next_name_away_for_default_printing env_t
-
-(* Remark: Anonymous var may be dependent in Evar's contexts *)
-let compute_displayed_name_in flags avoid na c =
- match na with
- | Anonymous when noccurn 1 c ->
- (Anonymous,avoid)
- | _ ->
- let fresh_id = next_name_for_display flags na avoid in
- let idopt = if noccurn 1 c then Anonymous else Name fresh_id in
- (idopt, fresh_id::avoid)
-
-let compute_and_force_displayed_name_in flags avoid na c =
- match na with
- | Anonymous when noccurn 1 c ->
- (Anonymous,avoid)
- | _ ->
- let fresh_id = next_name_for_display flags na avoid in
- (Name fresh_id, fresh_id::avoid)
-
-let compute_displayed_let_name_in flags avoid na c =
- let fresh_id = next_name_for_display flags na avoid in
- (Name fresh_id, fresh_id::avoid)
-
-let rename_bound_vars_as_displayed avoid env c =
- let rec rename avoid env c =
- match kind_of_term c with
- | Prod (na,c1,c2) ->
- let na',avoid' =
- compute_displayed_name_in
- (RenamingElsewhereFor (env,c2)) avoid na c2 in
- mkProd (na', c1, rename avoid' (add_name na' env) c2)
- | LetIn (na,c1,t,c2) ->
- let na',avoid' =
- compute_displayed_let_name_in
- (RenamingElsewhereFor (env,c2)) avoid na c2 in
- mkLetIn (na',c1,t, rename avoid' (add_name na' env) c2)
- | Cast (c,k,t) -> mkCast (rename avoid env c, k,t)
- | _ -> c
- in
- rename avoid env c
-
-(**********************************************************************)
-(* "H"-based naming strategy introduced June 2014 for hypotheses in
- Prop produced by case/elim/destruct/induction, in place of the
- strategy that was using the first letter of the type, leading to
- inelegant "n:~A", "e:t=u", etc. when eliminating sumbool or similar
- types *)
-
-let h_based_elimination_names = ref false
-
-let use_h_based_elimination_names () =
- !h_based_elimination_names && Flags.version_strictly_greater Flags.V8_4
-
-open Goptions
-
-let _ = declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "use of \"H\"-based proposition names in elimination tactics";
- optkey = ["Standard";"Proposition";"Elimination";"Names"];
- optread = (fun () -> !h_based_elimination_names);
- optwrite = (:=) h_based_elimination_names }
diff --git a/pretyping/namegen.mli b/pretyping/namegen.mli
deleted file mode 100644
index 6751bd3c..00000000
--- a/pretyping/namegen.mli
+++ /dev/null
@@ -1,102 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* string
-val sort_hdchar : sorts -> string
-val hdchar : env -> types -> string
-val id_of_name_using_hdchar : env -> types -> Name.t -> Id.t
-val named_hd : env -> types -> Name.t -> Name.t
-val head_name : types -> Id.t option
-
-val mkProd_name : env -> Name.t * types * types -> types
-val mkLambda_name : env -> Name.t * types * constr -> constr
-
-(** Deprecated synonyms of [mkProd_name] and [mkLambda_name] *)
-val prod_name : env -> Name.t * types * types -> types
-val lambda_name : env -> Name.t * types * constr -> constr
-
-val prod_create : env -> types * types -> constr
-val lambda_create : env -> types * constr -> constr
-val name_assumption : env -> rel_declaration -> rel_declaration
-val name_context : env -> rel_context -> rel_context
-
-val mkProd_or_LetIn_name : env -> types -> rel_declaration -> types
-val mkLambda_or_LetIn_name : env -> constr -> rel_declaration -> constr
-val it_mkProd_or_LetIn_name : env -> types -> rel_context -> types
-val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr
-
-(*********************************************************************
- Fresh names *)
-
-(** Avoid clashing with a name satisfying some predicate *)
-val next_ident_away_from : Id.t -> (Id.t -> bool) -> Id.t
-
-(** Avoid clashing with a name of the given list *)
-val next_ident_away : Id.t -> Id.t list -> Id.t
-
-(** Avoid clashing with a name already used in current module *)
-val next_ident_away_in_goal : Id.t -> Id.t list -> Id.t
-
-(** Avoid clashing with a name already used in current module
- but tolerate overwriting section variables, as in goals *)
-val next_global_ident_away : Id.t -> Id.t list -> Id.t
-
-(** Avoid clashing with a constructor name already used in current module *)
-val next_name_away_in_cases_pattern : (Termops.names_context * constr) -> Name.t -> Id.t list -> Id.t
-
-(** Default is [default_non_dependent_ident] *)
-val next_name_away : Name.t -> Id.t list -> Id.t
-
-val next_name_away_with_default : string -> Name.t -> Id.t list ->
- Id.t
-
-val next_name_away_with_default_using_types : string -> Name.t ->
- Id.t list -> types -> Id.t
-
-val set_reserved_typed_name : (types -> Name.t) -> unit
-
-(*********************************************************************
- Making name distinct for displaying *)
-
-type renaming_flags =
- | RenamingForCasesPattern of (Name.t list * constr) (** avoid only global constructors *)
- | RenamingForGoal (** avoid all globals (as in intro) *)
- | RenamingElsewhereFor of (Name.t list * constr)
-
-val make_all_name_different : env -> env
-
-val compute_displayed_name_in :
- renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list
-val compute_and_force_displayed_name_in :
- renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list
-val compute_displayed_let_name_in :
- renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list
-val rename_bound_vars_as_displayed :
- Id.t list -> Name.t list -> types -> types
-
-(**********************************************************************)
-(* Naming strategy for arguments in Prop when eliminating inductive types *)
-
-val use_h_based_elimination_names : unit -> bool
diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index 6d09d569..0dd64697 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Term
open Vars
open Environ
@@ -18,7 +18,7 @@ open Inductive
open Util
open Nativecode
open Nativevalues
-open Nativelambda
+open Context.Rel.Declaration
(** This module implements normalization by evaluation to OCaml code *)
@@ -35,13 +35,13 @@ let invert_tag cst tag reloc_tbl =
with Find_at j -> (j+1)
let decompose_prod env t =
- let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in
+ let (name,dom,codom as res) = destProd (whd_all env t) in
match name with
| Anonymous -> (Name (id_of_string "x"),dom,codom)
| _ -> res
let app_type env c =
- let t = whd_betadeltaiota env c in
+ let t = whd_all env c in
try destApp t with DestKO -> (t,[||])
@@ -121,9 +121,8 @@ let build_case_type dep p realargs c =
else mkApp(p, realargs)
(* TODO move this function *)
-let type_of_rel env n =
- let (_,_,ty) = lookup_rel n env in
- lift n ty
+let type_of_rel env n =
+ lookup_rel n env |> get_type |> lift n
let type_of_prop = mkSort type1_sort
@@ -132,8 +131,9 @@ let type_of_sort s =
| Prop _ -> type_of_prop
| Type u -> mkType (Univ.super u)
-let type_of_var env id =
- try let (_,_,ty) = lookup_named id env in ty
+let type_of_var env id =
+ let open Context.Named.Declaration in
+ try lookup_named id env |> get_type
with Not_found ->
anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound")
@@ -178,10 +178,10 @@ let rec nf_val env v typ =
let name,dom,codom =
try decompose_prod env typ
with DestKO ->
- Errors.anomaly
+ CErrors.anomaly
(Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
in
- let env = push_rel (name,None,dom) env in
+ let env = push_rel (LocalAssum (name,dom)) env in
let body = nf_val env (f (mk_rel_accu lvl)) codom in
mkLambda(name,dom,body)
| Vconst n -> construct_of_constr_const env n typ
@@ -224,7 +224,7 @@ and nf_args env accu t =
let _,dom,codom =
try decompose_prod env t with
DestKO ->
- Errors.anomaly
+ CErrors.anomaly
(Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
in
let c = nf_val env arg dom in
@@ -241,7 +241,7 @@ and nf_bargs env b t =
let _,dom,codom =
try decompose_prod env !t with
DestKO ->
- Errors.anomaly
+ CErrors.anomaly
(Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
in
let c = nf_val env (block_field b i) dom in
@@ -257,7 +257,7 @@ and nf_atom env atom =
| Aprod(n,dom,codom) ->
let dom = nf_type env dom in
let vn = mk_rel_accu (nb_rel env) in
- let env = push_rel (n,None,dom) env in
+ let env = push_rel (LocalAssum (n,dom)) env in
let codom = nf_type env (codom vn) in
mkProd(n,dom,codom)
| Ameta (mv,_) -> mkMeta mv
@@ -289,7 +289,7 @@ and nf_atom_type env atom =
let pT =
hnf_prod_applist env
(Inductiveops.type_of_inductive env ind) (Array.to_list params) in
- let pT = whd_betadeltaiota env pT in
+ let pT = whd_all env pT in
let dep, p = nf_predicate env ind mip params p pT in
(* Calcul du type des branches *)
let btypes = build_branches_type env (fst ind) mib mip u params dep p in
@@ -328,7 +328,7 @@ and nf_atom_type env atom =
| Aprod(n,dom,codom) ->
let dom,s1 = nf_type_sort env dom in
let vn = mk_rel_accu (nb_rel env) in
- let env = push_rel (n,None,dom) env in
+ let env = push_rel (LocalAssum (n,dom)) env in
let codom,s2 = nf_type_sort env (codom vn) in
mkProd(n,dom,codom), mkSort (sort_of_product env s1 s2)
| Aevar(ev,ty) ->
@@ -352,11 +352,11 @@ and nf_predicate env ind mip params v pT =
let name,dom,codom =
try decompose_prod env pT with
DestKO ->
- Errors.anomaly
+ CErrors.anomaly
(Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
in
let dep,body =
- nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in
+ nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in
dep, mkLambda(name,dom,body)
| Vfun f, _ ->
let k = nb_rel env in
@@ -366,7 +366,7 @@ and nf_predicate env ind mip params v pT =
let rargs = Array.init n (fun i -> mkRel (n-i)) in
let params = if Int.equal n 0 then params else Array.map (lift n) params in
let dom = mkApp(mkIndU ind,Array.append params rargs) in
- let body = nf_type (push_rel (name,None,dom) env) vb in
+ let body = nf_type (push_rel (LocalAssum (name,dom)) env) vb in
true, mkLambda(name,dom,body)
| _, _ -> false, nf_type env v
@@ -389,16 +389,16 @@ let native_norm env sigma c ty =
let code, upd = mk_norm_code penv sigma prefix c in
match Nativelib.compile ml_filename code with
| true, fn ->
- if !Flags.debug then Pp.msg_debug (Pp.str "Running norm ...");
+ if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ...");
let t0 = Sys.time () in
Nativelib.call_linker ~fatal:true prefix fn (Some upd);
let t1 = Sys.time () in
let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in
- if !Flags.debug then Pp.msg_debug (Pp.str time_info);
+ if !Flags.debug then Feedback.msg_debug (Pp.str time_info);
let res = nf_val env !Nativelib.rt1 ty in
let t2 = Sys.time () in
let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in
- if !Flags.debug then Pp.msg_debug (Pp.str time_info);
+ if !Flags.debug then Feedback.msg_debug (Pp.str time_info);
res
| _ -> anomaly (Pp.str "Compilation failure")
diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli
index bbda55f4..0b1ce8e5 100644
--- a/pretyping/nativenorm.mli
+++ b/pretyping/nativenorm.mli
@@ -8,7 +8,6 @@
open Term
open Environ
open Evd
-open Nativelambda
(** This module implements normalization by evaluation to OCaml code *)
diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml
index af46c390..fe73b610 100644
--- a/pretyping/patternops.ml
+++ b/pretyping/patternops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Globnames
@@ -123,6 +123,7 @@ let head_of_constr_reference c = match kind_of_term c with
let pattern_of_constr env sigma t =
let rec pattern_of_constr env t =
+ let open Context.Rel.Declaration in
match kind_of_term t with
| Rel n -> PRel n
| Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n)))
@@ -132,11 +133,11 @@ let pattern_of_constr env sigma t =
| Sort (Type _) -> PSort (GType [])
| Cast (c,_,_) -> pattern_of_constr env c
| LetIn (na,c,t,b) -> PLetIn (na,pattern_of_constr env c,
- pattern_of_constr (push_rel (na,Some c,t) env) b)
+ pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b)
| Prod (na,c,b) -> PProd (na,pattern_of_constr env c,
- pattern_of_constr (push_rel (na, None, c) env) b)
+ pattern_of_constr (push_rel (LocalAssum (na, c)) env) b)
| Lambda (na,c,b) -> PLambda (na,pattern_of_constr env c,
- pattern_of_constr (push_rel (na, None, c) env) b)
+ pattern_of_constr (push_rel (LocalAssum (na, c)) env) b)
| App (f,a) ->
(match
match kind_of_term f with
@@ -316,6 +317,10 @@ let rev_it_mkPLambda = List.fold_right mkPLambda
let err loc pp = user_err_loc (loc,"pattern_of_glob_constr", pp)
+let warn_cast_in_pattern =
+ CWarnings.create ~name:"cast-in-pattern" ~category:"automation"
+ (fun () -> Pp.strbrk "Casts are ignored in patterns")
+
let rec pat_of_raw metas vars = function
| GVar (_,id) ->
(try PRel (List.index Name.equal (Name id) vars)
@@ -347,7 +352,7 @@ let rec pat_of_raw metas vars = function
| GHole _ ->
PMeta None
| GCast (_,c,_) ->
- Pp.msg_warning (strbrk "Cast not taken into account in constr pattern");
+ warn_cast_in_pattern ();
pat_of_raw metas vars c
| GIf (_,c,(_,None),b1,b2) ->
PIf (pat_of_raw metas vars c,
diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli
index 5f877814..1f63565d 100644
--- a/pretyping/patternops.mli
+++ b/pretyping/patternops.mli
@@ -6,7 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Context
open Term
open Globnames
open Glob_term
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index cf5b08c5..00b6100c 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -14,15 +14,16 @@ open Type_errors
type unification_error =
| OccurCheck of existential_key * constr
- | NotClean of existential * env * constr
+ | NotClean of existential * env * constr (* Constr is a variable not in scope *)
| NotSameArgSize
| NotSameHead
| NoCanonicalStructure
- | ConversionFailed of env * constr * constr
+ | ConversionFailed of env * constr * constr (* Non convertible closed terms *)
| MetaOccurInBody of existential_key
| InstanceNotSameType of existential_key * env * types * types
| UnifUnivInconsistency of Univ.univ_inconsistency
| CannotSolveConstraint of Evd.evar_constraint * unification_error
+ | ProblemBeyondCapabilities
type position = (Id.t * Locus.hyp_location_flag) option
@@ -59,7 +60,7 @@ type pretype_error =
exception PretypeError of env * Evd.evar_map * pretype_error
let precatchable_exception = function
- | Errors.UserError _ | TypeError _ | PretypeError _
+ | CErrors.UserError _ | TypeError _ | PretypeError _
| Nametab.GlobalizationError _ -> true
| _ -> false
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index f617df9e..880f48e5 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -24,6 +24,7 @@ type unification_error =
| InstanceNotSameType of existential_key * env * types * types
| UnifUnivInconsistency of Univ.univ_inconsistency
| CannotSolveConstraint of Evd.evar_constraint * unification_error
+ | ProblemBeyondCapabilities
type position = (Id.t * Locus.hyp_location_flag) option
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index ac0104d9..4b6d10c6 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -22,13 +22,12 @@
open Pp
-open Errors
+open CErrors
open Util
open Names
open Evd
open Term
open Vars
-open Context
open Termops
open Reductionops
open Environ
@@ -37,17 +36,20 @@ open Typeops
open Globnames
open Nameops
open Evarutil
+open Evardefine
open Pretype_errors
open Glob_term
open Glob_ops
open Evarconv
open Pattern
open Misctypes
+open Sigma.Notations
+open Context.Named.Declaration
type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
type var_map = constr_under_binders Id.Map.t
type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t
-type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t
+type unbound_ltac_var_map = Geninterp.Val.t Id.Map.t
type ltac_var_map = {
ltac_constrs : var_map;
ltac_uconstrs : uconstr_var_map;
@@ -56,6 +58,8 @@ type ltac_var_map = {
}
type glob_constr_ltac_closure = ltac_var_map * glob_constr
type pure_open_constr = evar_map * constr
+type 'a delayed_open =
+ { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma }
(************************************************************************)
(* This concerns Cases *)
@@ -64,6 +68,61 @@ open Inductiveops
(************************************************************************)
+module ExtraEnv =
+struct
+
+type t = {
+ env : Environ.env;
+ extra : Evarutil.ext_named_context Lazy.t;
+ (** Delay the computation of the evar extended environment *)
+}
+
+let get_extra env =
+ let open Context.Named.Declaration in
+ let ids = List.map get_id (named_context env) in
+ let avoid = List.fold_right Id.Set.add ids Id.Set.empty in
+ Context.Rel.fold_outside push_rel_decl_to_named_context
+ (Environ.rel_context env) ~init:(empty_csubst, [], avoid, named_context env)
+
+let make_env env = { env = env; extra = lazy (get_extra env) }
+let rel_context env = rel_context env.env
+
+let push_rel d env = {
+ env = push_rel d env.env;
+ extra = lazy (push_rel_decl_to_named_context d (Lazy.force env.extra));
+}
+
+let pop_rel_context n env = make_env (pop_rel_context n env.env)
+
+let push_rel_context ctx env = {
+ env = push_rel_context ctx env.env;
+ extra = lazy (List.fold_right push_rel_decl_to_named_context ctx (Lazy.force env.extra));
+}
+
+let lookup_named id env = lookup_named id env.env
+
+let e_new_evar env evdref ?src ?naming typ =
+ let subst2 subst vsubst c = csubst_subst subst (replace_vars vsubst c) in
+ let open Context.Named.Declaration in
+ let inst_vars = List.map (fun d -> mkVar (get_id d)) (named_context env.env) in
+ let inst_rels = List.rev (rel_list 0 (nb_rel env.env)) in
+ let (subst, vsubst, _, nc) = Lazy.force env.extra in
+ let typ' = subst2 subst vsubst typ in
+ let instance = inst_rels @ inst_vars in
+ let sign = val_of_named_context nc in
+ let sigma = Sigma.Unsafe.of_evar_map !evdref in
+ let Sigma (e, sigma, _) = new_evar_instance sign sigma typ' ?src ?naming instance in
+ evdref := Sigma.to_evar_map sigma;
+ e
+
+let push_rec_types (lna,typarray,_) env =
+ let ctxt = Array.map2_i (fun i na t -> Context.Rel.Declaration.LocalAssum (na, lift i t)) lna typarray in
+ Array.fold_left (fun e assum -> push_rel assum e) env ctxt
+
+end
+
+open ExtraEnv
+
(* An auxiliary function for searching for fixpoint guard indexes *)
exception Found of int array
@@ -77,7 +136,7 @@ let search_guard loc env possible_indexes fixdefs =
let fix = ((indexes, 0),fixdefs) in
(try check_fix env fix
with reraise ->
- let (e, info) = Errors.push reraise in
+ let (e, info) = CErrors.push reraise in
let info = Loc.add_loc info loc in
iraise (e, info));
indexes
@@ -87,18 +146,23 @@ let search_guard loc env possible_indexes fixdefs =
List.iter
(fun l ->
let indexes = Array.of_list l in
- let fix = ((indexes, 0),fixdefs) in
- try check_fix env fix; raise (Found indexes)
+ let fix = ((indexes, 0),fixdefs) in
+ (* spiwack: We search for a unspecified structural
+ argument under the assumption that we need to check the
+ guardedness condition (otherwise the first inductive argument
+ will be chosen). A more robust solution may be to raise an
+ error when totality is assumed but the strutural argument is
+ not specified. *)
+ try
+ let flags = { (typing_flags env) with Declarations.check_guarded = true } in
+ let env = Environ.set_typing_flags flags env in
+ check_fix env fix; raise (Found indexes)
with TypeError _ -> ())
(List.combinations possible_indexes);
let errmsg = "Cannot guess decreasing argument of fix." in
user_err_loc (loc,"search_guard", Pp.str errmsg)
with Found indexes -> indexes)
-(* To embed constr in glob_constr *)
-let ((constr_in : constr -> Dyn.t),
- (constr_out : Dyn.t -> constr)) = Dyn.create "constr"
-
(* To force universe name declaration before use *)
let strict_universe_declarations = ref true
@@ -134,24 +198,24 @@ let interp_universe_level_name evd (loc,s) =
let level = Univ.Level.make dp num in
let evd =
try Evd.add_global_univ evd level
- with Univ.AlreadyDeclared -> evd
+ with UGraph.AlreadyDeclared -> evd
in evd, level
else
try
- let id =
- try Id.of_string s with _ -> raise Not_found in
- evd, Idmap.find id names
+ let level = Evd.universe_of_name evd s in
+ evd, level
with Not_found ->
- try let level = Evd.universe_of_name evd s in
- evd, level
+ try
+ let id = try Id.of_string s with _ -> raise Not_found in
+ evd, snd (Idmap.find id names)
with Not_found ->
if not (is_strict_universe_declarations ()) then
- new_univ_level_variable ~name:s univ_rigid evd
+ new_univ_level_variable ~loc ~name:s univ_rigid evd
else user_err_loc (loc, "interp_universe_level_name",
Pp.(str "Undeclared universe: " ++ str s))
-let interp_universe evd = function
- | [] -> let evd, l = new_univ_level_variable univ_rigid evd in
+let interp_universe ?loc evd = function
+ | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in
evd, Univ.Universe.make l
| l ->
List.fold_left (fun (evd, u) l ->
@@ -159,15 +223,15 @@ let interp_universe evd = function
(evd', Univ.sup u (Univ.Universe.make l)))
(evd, Univ.Universe.type0m) l
-let interp_universe_level evd = function
- | None -> new_univ_level_variable univ_rigid evd
+let interp_universe_level loc evd = function
+ | None -> new_univ_level_variable ~loc univ_rigid evd
| Some (loc,s) -> interp_universe_level_name evd (loc,s)
-let interp_sort evd = function
+let interp_sort ?loc evd = function
| GProp -> evd, Prop Null
| GSet -> evd, Prop Pos
| GType n ->
- let evd, u = interp_universe evd n in
+ let evd, u = interp_universe ?loc evd n in
evd, Type u
let interp_elimination_sort = function
@@ -175,23 +239,31 @@ let interp_elimination_sort = function
| GSet -> InSet
| GType _ -> InType
+type inference_hook = env -> evar_map -> evar -> evar_map * constr
+
type inference_flags = {
use_typeclasses : bool;
- use_unif_heuristics : bool;
- use_hook : (env -> evar_map -> evar -> constr) option;
+ solve_unification_constraints : bool;
+ use_hook : inference_hook option;
fail_evar : bool;
expand_evars : bool
}
-let frozen_holes (sigma, sigma') =
- let fold evk _ accu = Evar.Set.add evk accu in
- Evd.fold_undefined fold sigma Evar.Set.empty
-
-let pending_holes (sigma, sigma') =
- let fold evk _ accu =
- if not (Evd.mem sigma evk) then Evar.Set.add evk accu else accu
- in
- Evd.fold_undefined fold sigma' Evar.Set.empty
+(* Compute the set of still-undefined initial evars up to restriction
+ (e.g. clearing) and the set of yet-unsolved evars freshly created
+ in the extension [sigma'] of [sigma] (excluding the restrictions of
+ the undefined evars of [sigma] to be freshly created evars of
+ [sigma']). Otherwise said, we partition the undefined evars of
+ [sigma'] into those already in [sigma] or deriving from an evar in
+ [sigma] by restriction, and the evars properly created in [sigma'] *)
+
+let frozen_and_pending_holes (sigma, sigma') =
+ let add_derivative_of evk evi acc =
+ match advance sigma' evk with None -> acc | Some evk' -> Evar.Set.add evk' acc in
+ let frozen = Evd.fold_undefined add_derivative_of sigma Evar.Set.empty in
+ let fold evk _ accu = if not (Evar.Set.mem evk frozen) then Evar.Set.add evk accu else accu in
+ let pending = Evd.fold_undefined fold sigma' Evar.Set.empty in
+ (frozen,pending)
let apply_typeclasses env evdref frozen fail_evar =
let filter_frozen evk = Evar.Set.mem evk frozen in
@@ -209,7 +281,7 @@ let apply_inference_hook hook evdref pending =
if Evd.is_undefined sigma evk (* in particular not defined by side-effect *)
then
try
- let c = hook sigma evk in
+ let sigma, c = hook sigma evk in
Evd.define evk c sigma
with Exit ->
sigma
@@ -218,10 +290,10 @@ let apply_inference_hook hook evdref pending =
let apply_heuristics env evdref fail_evar =
(* Resolve eagerly, potentially making wrong choices *)
- try evdref := consider_remaining_unif_problems
+ try evdref := solve_unif_constraints_with_heuristics
~ts:(Typeclasses.classes_transparent_state ()) env !evdref
- with e when Errors.noncritical e ->
- let e = Errors.push e in if fail_evar then iraise e
+ with e when CErrors.noncritical e ->
+ let e = CErrors.push e in if fail_evar then iraise e
let check_typeclasses_instances_are_solved env current_sigma frozen =
(* Naive way, call resolution again with failure flag *)
@@ -237,6 +309,23 @@ let check_extra_evars_are_solved env current_sigma pending =
| _ ->
error_unsolvable_implicit loc env current_sigma evk None) pending
+(* [check_evars] fails if some unresolved evar remains *)
+
+let check_evars env initial_sigma sigma c =
+ let rec proc_rec c =
+ match kind_of_term c with
+ | Evar (evk,_ as ev) ->
+ (match existential_opt_value sigma ev with
+ | Some c -> proc_rec c
+ | None ->
+ if not (Evd.mem initial_sigma evk) then
+ let (loc,k) = evar_source evk sigma in
+ match k with
+ | Evar_kinds.ImplicitArg (gr, (i, id), false) -> ()
+ | _ -> Pretype_errors.error_unsolvable_implicit loc env sigma evk None)
+ | _ -> Constr.iter proc_rec c
+ in proc_rec c
+
let check_evars_are_solved env current_sigma frozen pending =
check_typeclasses_instances_are_solved env current_sigma frozen;
check_problems_are_solved env current_sigma;
@@ -245,19 +334,17 @@ let check_evars_are_solved env current_sigma frozen pending =
(* Try typeclasses, hooks, unification heuristics ... *)
let solve_remaining_evars flags env current_sigma pending =
- let frozen = frozen_holes pending in
- let pending = pending_holes pending in
+ let frozen,pending = frozen_and_pending_holes pending in
let evdref = ref current_sigma in
if flags.use_typeclasses then apply_typeclasses env evdref frozen false;
if Option.has_some flags.use_hook then
apply_inference_hook (Option.get flags.use_hook env) evdref pending;
- if flags.use_unif_heuristics then apply_heuristics env evdref false;
+ if flags.solve_unification_constraints then apply_heuristics env evdref false;
if flags.fail_evar then check_evars_are_solved env !evdref frozen pending;
!evdref
let check_evars_are_solved env current_sigma pending =
- let frozen = frozen_holes pending in
- let pending = pending_holes pending in
+ let frozen,pending = frozen_and_pending_holes pending in
check_evars_are_solved env current_sigma frozen pending
let process_inference_flags flags env initial_sigma (sigma,c) =
@@ -268,26 +355,11 @@ let process_inference_flags flags env initial_sigma (sigma,c) =
(* Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *)
let allow_anonymous_refs = ref false
-(* Utilisé pour inférer le prédicat des Cases *)
-(* Semble exagérement fort *)
-(* Faudra préférer une unification entre les types de toutes les clauses *)
-(* et autoriser des ? à rester dans le résultat de l'unification *)
-
-let evar_type_fixpoint loc env evdref lna lar vdefj =
- let lt = Array.length vdefj in
- if Int.equal (Array.length lar) lt then
- for i = 0 to lt-1 do
- if not (e_cumul env evdref (vdefj.(i)).uj_type
- (lift lt lar.(i))) then
- error_ill_typed_rec_body_loc loc env !evdref
- i lna vdefj lar
- done
-
(* coerce to tycon if any *)
let inh_conv_coerce_to_tycon resolve_tc loc env evdref j = function
| None -> j
| Some t ->
- evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env) evdref j t
+ evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env.ExtraEnv.env) evdref j t
let check_instance loc subst = function
| [] -> ()
@@ -321,11 +393,12 @@ let ltac_interp_name_env k0 lvar env =
specification of pretype which accepts to start with a non empty
rel_context) *)
(* tail is the part of the env enriched by pretyping *)
- let n = rel_context_length (rel_context env) - k0 in
+ let n = Context.Rel.length (rel_context env) - k0 in
let ctxt,_ = List.chop n (rel_context env) in
- let env = pop_rel_context n env in
- let ctxt = List.map (fun (na,c,t) -> ltac_interp_name lvar na,c,t) ctxt in
- push_rel_context ctxt env
+ let open Context.Rel.Declaration in
+ let ctxt' = List.smartmap (map_name (ltac_interp_name lvar)) ctxt in
+ if List.equal (fun d1 d2 -> Name.equal (get_name d1) (get_name d2)) ctxt ctxt' then env
+ else push_rel_context ctxt' (pop_rel_context n env)
let invert_ltac_bound_name lvar env id0 id =
let id' = Id.Map.find id lvar.ltac_idents in
@@ -336,7 +409,7 @@ let invert_ltac_bound_name lvar env id0 id =
str " which is not bound in current context.")
let protected_get_type_of env sigma c =
- try Retyping.get_type_of ~lax:true env sigma c
+ try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c
with Retyping.RetypeError _ ->
errorlabstrm ""
(str "Cannot reinterpret " ++ quote (print_constr c) ++
@@ -372,13 +445,15 @@ let pretype_id pretype k0 loc env evdref lvar id =
with Not_found ->
(* Check if [id] is a ltac variable not bound to a term *)
(* and build a nice error message *)
- if Id.Map.mem id lvar.ltac_genargs then
+ if Id.Map.mem id lvar.ltac_genargs then begin
+ let Geninterp.Val.Dyn (typ, _) = Id.Map.find id lvar.ltac_genargs in
user_err_loc (loc,"",
- str "Variable " ++ pr_id id ++ str " should be bound to a term.");
+ str "Variable " ++ pr_id id ++ str " should be bound to a term but is \
+ bound to a " ++ Geninterp.Val.pr typ ++ str ".")
+ end;
(* Check if [id] is a section or goal variable *)
try
- let (_,_,typ) = lookup_named id env in
- { uj_val = mkVar id; uj_type = typ }
+ { uj_val = mkVar id; uj_type = (get_type (lookup_named id env)) }
with Not_found ->
(* [id] not found, standard error message *)
error_var_not_found_loc loc id
@@ -389,11 +464,11 @@ let evar_kind_of_term sigma c =
(*************************************************************************)
(* Main pretyping function *)
-let interp_universe_level_name evd l =
+let interp_universe_level_name loc evd l =
match l with
| GProp -> evd, Univ.Level.prop
| GSet -> evd, Univ.Level.set
- | GType s -> interp_universe_level evd s
+ | GType s -> interp_universe_level loc evd s
let pretype_global loc rigid env evd gr us =
let evd, instance =
@@ -408,7 +483,7 @@ let pretype_global loc rigid env evd gr us =
str "Universe instance should have length " ++ int len)
else
let evd, l' = List.fold_left (fun (evd, univs) l ->
- let evd, l = interp_universe_level_name evd l in
+ let evd, l = interp_universe_level_name loc evd l in
(evd, l :: univs)) (evd, []) l
in
if List.exists (fun l -> Univ.Level.is_prop l) l' then
@@ -417,14 +492,13 @@ let pretype_global loc rigid env evd gr us =
str " universe instances must be greater or equal to Set.");
evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l')))
in
- Evd.fresh_global ~rigid ?names:instance env evd gr
+ Evd.fresh_global ~loc ~rigid ?names:instance env.ExtraEnv.env evd gr
let pretype_ref loc evdref env ref us =
match ref with
| VarRef id ->
(* Section variable *)
- (try let (_,_,ty) = lookup_named id env in
- make_judge (mkVar id) ty
+ (try make_judge (mkVar id) (get_type (lookup_named id env))
with Not_found ->
(* This may happen if env is a goal env and section variables have
been cleared - section variables should be different from goal
@@ -433,34 +507,29 @@ let pretype_ref loc evdref env ref us =
| ref ->
let evd, c = pretype_global loc univ_flexible env !evdref ref us in
let () = evdref := evd in
- let ty = Typing.unsafe_type_of env evd c in
+ let ty = Typing.unsafe_type_of env.ExtraEnv.env evd c in
make_judge c ty
-let judge_of_Type evd s =
- let evd, s = interp_universe evd s in
+let judge_of_Type loc evd s =
+ let evd, s = interp_universe ~loc evd s in
let judge =
{ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }
in
evd, judge
-let pretype_sort evdref = function
+let pretype_sort loc evdref = function
| GProp -> judge_of_prop
| GSet -> judge_of_set
- | GType s -> evd_comb1 judge_of_Type evdref s
+ | GType s -> evd_comb1 (judge_of_Type loc) evdref s
let new_type_evar env evdref loc =
- let e, s =
- evd_comb0 (fun evd -> Evarutil.new_type_evar env evd
- univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref
- in e
-
-let get_projection env cst =
- let cb = lookup_constant cst env in
- match cb.Declarations.const_proj with
- | Some {Declarations.proj_ind = mind; proj_npars = n;
- proj_arg = m; proj_type = ty} ->
- (cst,mind,n,m,ty)
- | None -> raise Not_found
+ let sigma = Sigma.Unsafe.of_evar_map !evdref in
+ let Sigma ((e, _), sigma, _) =
+ Evarutil.new_type_evar env.ExtraEnv.env sigma
+ univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)
+ in
+ evdref := Sigma.to_evar_map sigma;
+ e
let (f_genarg_interp, genarg_interp_hook) = Hook.make ()
@@ -468,16 +537,11 @@ let (f_genarg_interp, genarg_interp_hook) = Hook.make ()
(* in environment [env], with existential variables [evdref] and *)
(* the type constraint tycon *)
-let is_GHole = function
- | GHole _ -> true
- | _ -> false
-
-let evars = ref Id.Map.empty
-
-let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var_map) t =
+let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdref (lvar : ltac_var_map) t =
let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in
let pretype_type = pretype_type k0 resolve_tc in
let pretype = pretype k0 resolve_tc in
+ let open Context.Rel.Declaration in
match t with
| GRef (loc,ref,u) ->
inh_conv_coerce_to_tycon loc env evdref
@@ -499,7 +563,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
let hyps = evar_filtered_context (Evd.find !evdref evk) in
let args = pretype_instance k0 resolve_tc env evdref lvar loc hyps evk inst in
let c = mkEvar (evk, args) in
- let j = (Retyping.get_judgment_of env !evdref c) in
+ let j = (Retyping.get_judgment_of env.ExtraEnv.env !evdref c) in
inh_conv_coerce_to_tycon loc env evdref j tycon
| GPatVar (loc,(someta,n)) ->
@@ -528,7 +592,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
| None ->
new_type_evar env evdref loc in
let ist = lvar.ltac_genargs in
- let (c, sigma) = Hook.get f_genarg_interp ty env !evdref ist arg in
+ let (c, sigma) = Hook.get f_genarg_interp ty env.ExtraEnv.env !evdref ist arg in
let () = evdref := sigma in
{ uj_val = c; uj_type = ty }
@@ -537,16 +601,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
[] -> ctxt
| (na,bk,None,ty)::bl ->
let ty' = pretype_type empty_valcon env evdref lvar ty in
- let dcl = (na,None,ty'.utj_val) in
- let dcl' = (ltac_interp_name lvar na,None,ty'.utj_val) in
- type_bl (push_rel dcl env) (add_rel_decl dcl' ctxt) bl
+ let dcl = LocalAssum (na, ty'.utj_val) in
+ let dcl' = LocalAssum (ltac_interp_name lvar na,ty'.utj_val) in
+ type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl
| (na,bk,Some bd,ty)::bl ->
let ty' = pretype_type empty_valcon env evdref lvar ty in
let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in
- let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
- let dcl' = (ltac_interp_name lvar na,Some bd'.uj_val,ty'.utj_val) in
- type_bl (push_rel dcl env) (add_rel_decl dcl' ctxt) bl in
- let ctxtv = Array.map (type_bl env empty_rel_context) bl in
+ let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in
+ let dcl' = LocalDef (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in
+ type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl in
+ let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in
let larj =
Array.map2
(fun e ar ->
@@ -562,7 +626,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
let fixi = match fixkind with
| GFix (vn,i) -> i
| GCoFix i -> i
- in e_conv env evdref ftys.(fixi) t
+ in e_conv env.ExtraEnv.env evdref ftys.(fixi) t
| None -> true
in
(* Note: bodies are not used by push_rec_types, so [||] is safe *)
@@ -573,14 +637,14 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
(* we lift nbfix times the type in tycon, because of
* the nbfix variables pushed to newenv *)
let (ctxt,ty) =
- decompose_prod_n_assum (rel_context_length ctxt)
+ decompose_prod_n_assum (Context.Rel.length ctxt)
(lift nbfix ftys.(i)) in
let nenv = push_rel_context ctxt newenv in
let j = pretype (mk_tycon ty) nenv evdref lvar def in
{ uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
ctxtv vdef in
- evar_type_fixpoint loc env evdref names ftys vdefj;
+ Typing.check_type_fixpoint loc env.ExtraEnv.env evdref names ftys vdefj;
let ftys = Array.map (nf_evar !evdref) ftys in
let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in
let fixj = match fixkind with
@@ -599,13 +663,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
vn)
in
let fixdecls = (names,ftys,fdefs) in
- let indexes = search_guard loc env possible_indexes fixdecls in
+ let indexes =
+ search_guard
+ loc env.ExtraEnv.env possible_indexes fixdecls
+ in
make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i)
| GCoFix i ->
let cofix = (i,(names,ftys,fdefs)) in
- (try check_cofix env cofix
+ (try check_cofix env.ExtraEnv.env cofix
with reraise ->
- let (e, info) = Errors.push reraise in
+ let (e, info) = CErrors.push reraise in
let info = Loc.add_loc info loc in
iraise (e, info));
make_judge (mkCoFix cofix) ftys.(i)
@@ -613,7 +680,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
inh_conv_coerce_to_tycon loc env evdref fixj tycon
| GSort (loc,s) ->
- let j = pretype_sort evdref s in
+ let j = pretype_sort loc evdref s in
inh_conv_coerce_to_tycon loc env evdref j tycon
| GApp (loc,f,args) ->
@@ -633,7 +700,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
if Int.equal npars 0 then []
else
try
- let IndType (indf, args) = find_rectype env !evdref ty in
+ let IndType (indf, args) = find_rectype env.ExtraEnv.env !evdref ty in
let ((ind',u'),pars) = dest_ind_family indf in
if eq_ind ind ind' then pars
else (* Let the usual code throw an error *) []
@@ -642,9 +709,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
in
let app_f =
match kind_of_term fj.uj_val with
- | Const (p, u) when Environ.is_projection p env ->
+ | Const (p, u) when Environ.is_projection p env.ExtraEnv.env ->
let p = Projection.make p false in
- let pb = Environ.lookup_projection p env in
+ let pb = Environ.lookup_projection p env.ExtraEnv.env in
let npars = pb.Declarations.proj_npars in
fun n ->
if n == npars + 1 then fun _ v -> mkProj (p, v)
@@ -655,8 +722,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
| [] -> resj
| c::rest ->
let argloc = loc_of_glob_constr c in
- let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in
- let resty = whd_betadeltaiota env !evdref resj.uj_type in
+ let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env.ExtraEnv.env) evdref resj in
+ let resty = whd_all env.ExtraEnv.env !evdref resj.uj_type in
match kind_of_term resty with
| Prod (na,c1,c2) ->
let tycon = Some c1 in
@@ -665,7 +732,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
match candargs with
| [] -> [], j_val hj
| arg :: args ->
- if e_conv env evdref (j_val hj) arg then
+ if e_conv env.ExtraEnv.env evdref (j_val hj) arg then
args, nf_evar !evdref (j_val hj)
else [], j_val hj
in
@@ -676,7 +743,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
| _ ->
let hj = pretype empty_tycon env evdref lvar c in
error_cant_apply_not_functional_loc
- (Loc.merge floc argloc) env !evdref
+ (Loc.merge floc argloc) env.ExtraEnv.env !evdref
resj [hj]
in
let resj = apply_rec env 1 fj candargs args in
@@ -684,13 +751,13 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
match evar_kind_of_term !evdref resj.uj_val with
| App (f,args) ->
let f = whd_evar !evdref f in
- if is_template_polymorphic env f then
+ if is_template_polymorphic env.ExtraEnv.env f then
(* Special case for inductive type applications that must be
refreshed right away. *)
let sigma = !evdref in
let c = mkApp (f,Array.map (whd_evar sigma) args) in
- let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env) evdref c in
- let t = Retyping.get_type_of env !evdref c in
+ let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env.ExtraEnv.env) evdref c in
+ let t = Retyping.get_type_of env.ExtraEnv.env !evdref c in
make_judge c (* use this for keeping evars: resj.uj_val *) t
else resj
| _ -> resj
@@ -703,20 +770,20 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
match tycon with
| None -> evd, tycon
| Some ty ->
- let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in
+ let evd, ty' = Coercion.inh_coerce_to_prod loc env.ExtraEnv.env evd ty in
evd, Some ty')
evdref tycon
in
- let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in
+ let (name',dom,rng) = evd_comb1 (split_tycon loc env.ExtraEnv.env) evdref tycon' in
let dom_valcon = valcon_of_tycon dom in
let j = pretype_type dom_valcon env evdref lvar c1 in
(* The name specified by ltac is used also to create bindings. So
the substitution must also be applied on variables before they are
looked up in the rel context. *)
- let var = (name,None,j.utj_val) in
+ let var = LocalAssum (name, j.utj_val) in
let j' = pretype rng (push_rel var env) evdref lvar c2 in
let name = ltac_interp_name lvar name in
- let resj = judge_of_abstraction env (orelse_name name name') j j' in
+ let resj = judge_of_abstraction env.ExtraEnv.env (orelse_name name name') j j' in
inh_conv_coerce_to_tycon loc env evdref resj tycon
| GProd(loc,name,bk,c1,c2) ->
@@ -729,16 +796,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
let j = pretype_type empty_valcon env evdref lvar c2 in
{ j with utj_val = lift 1 j.utj_val }
| Name _ ->
- let var = (name,j.utj_val) in
- let env' = push_rel_assum var env in
+ let var = LocalAssum (name, j.utj_val) in
+ let env' = push_rel var env in
pretype_type empty_valcon env' evdref lvar c2
in
let name = ltac_interp_name lvar name in
let resj =
try
- judge_of_product env name j j'
+ judge_of_product env.ExtraEnv.env name j j'
with TypeError _ as e ->
- let (e, info) = Errors.push e in
+ let (e, info) = CErrors.push e in
let info = Loc.add_loc info loc in
iraise (e, info) in
inh_conv_coerce_to_tycon loc env evdref resj tycon
@@ -752,12 +819,12 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
| _ -> pretype empty_tycon env evdref lvar c1
in
let t = evd_comb1 (Evarsolve.refresh_universes
- ~onlyalg:true ~status:Evd.univ_flexible (Some false) env)
+ ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env)
evdref j.uj_type in
(* The name specified by ltac is used also to create bindings. So
the substitution must also be applied on variables before they are
looked up in the rel context. *)
- let var = (name,Some j.uj_val,t) in
+ let var = LocalDef (name, j.uj_val, t) in
let tycon = lift_tycon 1 tycon in
let j' = pretype tycon (push_rel var env) evdref lvar c2 in
let name = ltac_interp_name lvar name in
@@ -767,12 +834,12 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
| GLetTuple (loc,nal,(na,po),c,d) ->
let cj = pretype empty_tycon env evdref lvar c in
let (IndType (indf,realargs)) =
- try find_rectype env !evdref cj.uj_type
+ try find_rectype env.ExtraEnv.env !evdref cj.uj_type
with Not_found ->
let cloc = loc_of_glob_constr c in
- error_case_not_inductive_loc cloc env !evdref cj
+ error_case_not_inductive_loc cloc env.ExtraEnv.env !evdref cj
in
- let cstrs = get_constructors env indf in
+ let cstrs = get_constructors env.ExtraEnv.env indf in
if not (Int.equal (Array.length cstrs) 1) then
user_err_loc (loc,"",str "Destructing let is only for inductive types" ++
str " with one constructor.");
@@ -781,18 +848,18 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
user_err_loc (loc,"", str "Destructing let on this type expects " ++
int cs.cs_nargs ++ str " variables.");
let fsign, record =
- match get_projections env indf with
- | None -> List.map2 (fun na (_,c,t) -> (na,c,t))
- (List.rev nal) cs.cs_args, false
+ match get_projections env.ExtraEnv.env indf with
+ | None ->
+ List.map2 set_name (List.rev nal) cs.cs_args, false
| Some ps ->
let rec aux n k names l =
match names, l with
- | na :: names, ((_, None, t) :: l) ->
+ | na :: names, (LocalAssum (_,t) :: l) ->
let proj = Projection.make ps.(cs.cs_nargs - k) true in
- (na, Some (lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val))), t)
+ LocalDef (na, lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t)
:: aux (n+1) (k + 1) names l
- | na :: names, ((_, c, t) :: l) ->
- (na, c, t) :: aux (n+1) k names l
+ | na :: names, (decl :: l) ->
+ set_name na decl :: aux (n+1) k names l
| [], [] -> []
| _ -> assert false
in aux 1 1 (List.rev nal) cs.cs_args, true in
@@ -800,38 +867,38 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
if not record then
let nal = List.map (fun na -> ltac_interp_name lvar na) nal in
let nal = List.rev nal in
- let fsign = List.map2 (fun na (_,b,t) -> (na,b,t)) nal fsign in
+ let fsign = List.map2 set_name nal fsign in
let f = it_mkLambda_or_LetIn f fsign in
- let ci = make_case_info env (fst ind) LetStyle in
+ let ci = make_case_info env.ExtraEnv.env (fst ind) LetStyle in
mkCase (ci, p, cj.uj_val,[|f|])
else it_mkLambda_or_LetIn f fsign
in
let env_f = push_rel_context fsign env in
(* Make dependencies from arity signature impossible *)
let arsgn =
- let arsgn,_ = get_arity env indf in
+ let arsgn,_ = get_arity env.ExtraEnv.env indf in
if not !allow_anonymous_refs then
- List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+ List.map (set_name Anonymous) arsgn
else arsgn
in
- let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+ let psign = LocalAssum (na, build_dependent_inductive env.ExtraEnv.env indf) :: arsgn in
let nar = List.length arsgn in
(match po with
| Some p ->
let env_p = push_rel_context psign env in
let pj = pretype_type empty_valcon env_p evdref lvar p in
let ccl = nf_evar !evdref pj.utj_val in
- let psign = make_arity_signature env true indf in (* with names *)
+ let psign = make_arity_signature env.ExtraEnv.env true indf in (* with names *)
let p = it_mkLambda_or_LetIn ccl psign in
let inst =
(Array.to_list cs.cs_concl_realargs)
@[build_dependent_constructor cs] in
let lp = lift cs.cs_nargs p in
- let fty = hnf_lam_applist env !evdref lp inst in
+ let fty = hnf_lam_applist env.ExtraEnv.env !evdref lp inst in
let fj = pretype (mk_tycon fty) env_f evdref lvar d in
let v =
let ind,_ = dest_ind_family indf in
- Typing.check_allowed_sort env !evdref ind cj.uj_val p;
+ Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p;
obj ind p cj.uj_val fj.uj_val
in
{ uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
@@ -844,37 +911,37 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
if noccur_between 1 cs.cs_nargs ccl then
lift (- cs.cs_nargs) ccl
else
- error_cant_find_case_type_loc loc env !evdref
+ error_cant_find_case_type_loc loc env.ExtraEnv.env !evdref
cj.uj_val in
(* let ccl = refresh_universes ccl in *)
let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
let v =
let ind,_ = dest_ind_family indf in
- Typing.check_allowed_sort env !evdref ind cj.uj_val p;
+ Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p;
obj ind p cj.uj_val fj.uj_val
in { uj_val = v; uj_type = ccl })
| GIf (loc,c,(na,po),b1,b2) ->
let cj = pretype empty_tycon env evdref lvar c in
let (IndType (indf,realargs)) =
- try find_rectype env !evdref cj.uj_type
+ try find_rectype env.ExtraEnv.env !evdref cj.uj_type
with Not_found ->
let cloc = loc_of_glob_constr c in
- error_case_not_inductive_loc cloc env !evdref cj in
- let cstrs = get_constructors env indf in
+ error_case_not_inductive_loc cloc env.ExtraEnv.env !evdref cj in
+ let cstrs = get_constructors env.ExtraEnv.env indf in
if not (Int.equal (Array.length cstrs) 2) then
user_err_loc (loc,"",
str "If is only for inductive types with two constructors.");
let arsgn =
- let arsgn,_ = get_arity env indf in
+ let arsgn,_ = get_arity env.ExtraEnv.env indf in
if not !allow_anonymous_refs then
(* Make dependencies from arity signature impossible *)
- List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+ List.map (set_name Anonymous) arsgn
else arsgn
in
let nar = List.length arsgn in
- let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+ let psign = LocalAssum (na, build_dependent_inductive env.ExtraEnv.env indf) :: arsgn in
let pred,p = match po with
| Some p ->
let env_p = push_rel_context psign env in
@@ -894,19 +961,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
let pred = nf_evar !evdref pred in
let p = nf_evar !evdref p in
let f cs b =
- let n = rel_context_length cs.cs_args in
+ let n = Context.Rel.length cs.cs_args in
let pi = lift n pred in (* liftn n 2 pred ? *)
let pi = beta_applist (pi, [build_dependent_constructor cs]) in
let csgn =
if not !allow_anonymous_refs then
- List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args
+ List.map (set_name Anonymous) cs.cs_args
else
- List.map
- (fun (n, b, t) ->
- match n with
- Name _ -> (n, b, t)
- | Anonymous -> (Name Namegen.default_non_dependent_ident, b, t))
- cs.cs_args
+ List.map (map_name (function Name _ as n -> n
+ | Anonymous -> Name Namegen.default_non_dependent_ident))
+ cs.cs_args
in
let env_c = push_rel_context csgn env in
let bj = pretype (mk_tycon pi) env_c evdref lvar b in
@@ -915,9 +979,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
let b2 = f cstrs.(1) b2 in
let v =
let ind,_ = dest_ind_family indf in
- let ci = make_case_info env (fst ind) IfStyle in
+ let ci = make_case_info env.ExtraEnv.env (fst ind) IfStyle in
let pred = nf_evar !evdref pred in
- Typing.check_allowed_sort env !evdref ind cj.uj_val pred;
+ Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val pred;
mkCase (ci, pred, cj.uj_val, [|b1;b2|])
in
let cj = { uj_val = v; uj_type = p } in
@@ -925,51 +989,55 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
| GCases (loc,sty,po,tml,eqns) ->
Cases.compile_cases loc sty
- ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref)
- tycon env (* loc *) (po,tml,eqns)
+ ((fun vtyc env evdref -> pretype vtyc (make_env env) evdref lvar),evdref)
+ tycon env.ExtraEnv.env (* loc *) (po,tml,eqns)
| GCast (loc,c,k) ->
let cj =
match k with
| CastCoerce ->
let cj = pretype empty_tycon env evdref lvar c in
- evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj
+ evd_comb1 (Coercion.inh_coerce_to_base loc env.ExtraEnv.env) evdref cj
| CastConv t | CastVM t | CastNative t ->
let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in
let tj = pretype_type empty_valcon env evdref lvar t in
- let tval = nf_evar !evdref tj.utj_val in
- let cj = match k with
+ let tval = evd_comb1 (Evarsolve.refresh_universes
+ ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env)
+ evdref tj.utj_val in
+ let tval = nf_evar !evdref tval in
+ let cj, tval = match k with
| VMcast ->
let cj = pretype empty_tycon env evdref lvar c in
- let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
+ let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in
if not (occur_existential cty || occur_existential tval) then
- let (evd,b) = Reductionops.vm_infer_conv env !evdref cty tval in
- if b then (evdref := evd; cj)
+ let (evd,b) = Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval in
+ if b then (evdref := evd; cj, tval)
else
- error_actual_type_loc loc env !evdref cj tval
- (ConversionFailed (env,cty,tval))
+ error_actual_type_loc loc env.ExtraEnv.env !evdref cj tval
+ (ConversionFailed (env.ExtraEnv.env,cty,tval))
else user_err_loc (loc,"",str "Cannot check cast with vm: " ++
str "unresolved arguments remain.")
| NATIVEcast ->
let cj = pretype empty_tycon env evdref lvar c in
- let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
+ let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in
begin
- let (evd,b) = Nativenorm.native_infer_conv env !evdref cty tval in
- if b then (evdref := evd; cj)
+ let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval in
+ if b then (evdref := evd; cj, tval)
else
- error_actual_type_loc loc env !evdref cj tval
- (ConversionFailed (env,cty,tval))
+ error_actual_type_loc loc env.ExtraEnv.env !evdref cj tval
+ (ConversionFailed (env.ExtraEnv.env,cty,tval))
end
| _ ->
- pretype (mk_tycon tval) env evdref lvar c
+ pretype (mk_tycon tval) env evdref lvar c, tval
in
let v = mkCast (cj.uj_val, k, tval) in
{ uj_val = v; uj_type = tval }
in inh_conv_coerce_to_tycon loc env evdref cj tycon
and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update =
- let f (id,_,t) (subst,update) =
- let t = replace_vars subst t in
+ let f decl (subst,update) =
+ let id = get_id decl in
+ let t = replace_vars subst (get_type decl) in
let c, update =
try
let c = List.assoc id update in
@@ -978,11 +1046,11 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update =
with Not_found ->
try
let (n,_,t') = lookup_rel_id id (rel_context env) in
- if is_conv env !evdref t t' then mkRel n, update else raise Not_found
+ if is_conv env.ExtraEnv.env !evdref t t' then mkRel n, update else raise Not_found
with Not_found ->
try
- let (_,_,t') = lookup_named id env in
- if is_conv env !evdref t t' then mkVar id, update else raise Not_found
+ let t' = lookup_named id env |> get_type in
+ if is_conv env.ExtraEnv.env !evdref t t' then mkVar id, update else raise Not_found
with Not_found ->
user_err_loc (loc,"",str "Cannot interpret " ++
pr_existential_key !evdref evk ++
@@ -993,17 +1061,17 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update =
Array.map_of_list snd subst
(* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
-and pretype_type k0 resolve_tc valcon env evdref lvar = function
+and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function
| GHole (loc, knd, naming, None) ->
(match valcon with
| Some v ->
let s =
let sigma = !evdref in
- let t = Retyping.get_type_of env sigma v in
- match kind_of_term (whd_betadeltaiota env sigma t) with
+ let t = Retyping.get_type_of env.ExtraEnv.env sigma v in
+ match kind_of_term (whd_all env.ExtraEnv.env sigma t) with
| Sort s -> s
| Evar ev when is_Type (existential_type sigma ev) ->
- evd_comb1 (define_evar_as_sort env) evdref ev
+ evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev
| _ -> anomaly (Pp.str "Found a type constraint which is not a type")
in
{ utj_val = v;
@@ -1016,18 +1084,19 @@ and pretype_type k0 resolve_tc valcon env evdref lvar = function
| c ->
let j = pretype k0 resolve_tc empty_tycon env evdref lvar c in
let loc = loc_of_glob_constr c in
- let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in
+ let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env.ExtraEnv.env) evdref j in
match valcon with
| None -> tj
| Some v ->
- if e_cumul env evdref v tj.utj_val then tj
+ if e_cumul env.ExtraEnv.env evdref v tj.utj_val then tj
else
error_unexpected_type_loc
- (loc_of_glob_constr c) env !evdref tj.utj_val v
+ (loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v
let ise_pretype_gen flags env sigma lvar kind c =
+ let env = make_env env in
let evdref = ref sigma in
- let k0 = rel_context_length (rel_context env) in
+ let k0 = Context.Rel.length (rel_context env) in
let c' = match kind with
| WithoutTypeConstraint ->
(pretype k0 flags.use_typeclasses empty_tycon env evdref lvar c).uj_val
@@ -1036,18 +1105,18 @@ let ise_pretype_gen flags env sigma lvar kind c =
| IsType ->
(pretype_type k0 flags.use_typeclasses empty_valcon env evdref lvar c).utj_val
in
- process_inference_flags flags env sigma (!evdref,c')
+ process_inference_flags flags env.ExtraEnv.env sigma (!evdref,c')
let default_inference_flags fail = {
use_typeclasses = true;
- use_unif_heuristics = true;
+ solve_unification_constraints = true;
use_hook = None;
fail_evar = fail;
expand_evars = true }
let no_classes_no_fail_inference_flags = {
use_typeclasses = false;
- use_unif_heuristics = true;
+ solve_unification_constraints = true;
use_hook = None;
fail_evar = false;
expand_evars = true }
@@ -1068,19 +1137,21 @@ let on_judgment f j =
{uj_val = c; uj_type = t}
let understand_judgment env sigma c =
+ let env = make_env env in
let evdref = ref sigma in
- let k0 = rel_context_length (rel_context env) in
+ let k0 = Context.Rel.length (rel_context env) in
let j = pretype k0 true empty_tycon env evdref empty_lvar c in
let j = on_judgment (fun c ->
- let evd, c = process_inference_flags all_and_fail_flags env sigma (!evdref,c) in
+ let evd, c = process_inference_flags all_and_fail_flags env.ExtraEnv.env sigma (!evdref,c) in
evdref := evd; c) j
in j, Evd.evar_universe_context !evdref
let understand_judgment_tcc env evdref c =
- let k0 = rel_context_length (rel_context env) in
+ let env = make_env env in
+ let k0 = Context.Rel.length (rel_context env) in
let j = pretype k0 true empty_tycon env evdref empty_lvar c in
on_judgment (fun c ->
- let (evd,c) = process_inference_flags all_no_fail_flags env Evd.empty (!evdref,c) in
+ let (evd,c) = process_inference_flags all_no_fail_flags env.ExtraEnv.env Evd.empty (!evdref,c) in
evdref := evd; c) j
let ise_pretype_gen_ctx flags env sigma lvar kind c =
@@ -1106,3 +1177,32 @@ let understand_tcc_evars ?(flags=all_no_fail_flags) env evdref ?(expected_type=W
let understand_ltac flags env sigma lvar kind c =
ise_pretype_gen flags env sigma lvar kind c
+
+let constr_flags = {
+ use_typeclasses = true;
+ solve_unification_constraints = true;
+ use_hook = None;
+ fail_evar = true;
+ expand_evars = true }
+
+(* Fully evaluate an untyped constr *)
+let type_uconstr ?(flags = constr_flags)
+ ?(expected_type = WithoutTypeConstraint) ist c =
+ { delayed = begin fun env sigma ->
+ let { closure; term } = c in
+ let vars = {
+ ltac_constrs = closure.typed;
+ ltac_uconstrs = closure.untyped;
+ ltac_idents = closure.idents;
+ ltac_genargs = Id.Map.empty;
+ } in
+ let sigma = Sigma.to_evar_map sigma in
+ let (sigma, c) = understand_ltac flags env sigma vars expected_type term in
+ Sigma.Unsafe.of_pair (c, sigma)
+ end }
+
+let pretype k0 resolve_tc typcon env evdref lvar t =
+ pretype k0 resolve_tc typcon (make_env env) evdref lvar t
+
+let pretype_type k0 resolve_tc valcon env evdref lvar t =
+ pretype_type k0 resolve_tc valcon (make_env env) evdref lvar t
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index ac899a78..0f3f7c3c 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -29,7 +29,7 @@ type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
type var_map = Pattern.constr_under_binders Id.Map.t
type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t
-type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t
+type unbound_ltac_var_map = Geninterp.Val.t Id.Map.t
type ltac_var_map = {
ltac_constrs : var_map;
@@ -47,14 +47,19 @@ val empty_lvar : ltac_var_map
type glob_constr_ltac_closure = ltac_var_map * glob_constr
type pure_open_constr = evar_map * constr
+type inference_hook = env -> evar_map -> evar -> evar_map * constr
+
type inference_flags = {
use_typeclasses : bool;
- use_unif_heuristics : bool;
- use_hook : (env -> evar_map -> evar -> constr) option;
+ solve_unification_constraints : bool;
+ use_hook : inference_hook option;
fail_evar : bool;
expand_evars : bool
}
+type 'a delayed_open =
+ { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma }
+
val default_inference_flags : bool -> inference_flags
val no_classes_no_fail_inference_flags : inference_flags
@@ -114,6 +119,11 @@ val understand_judgment : env -> evar_map ->
val understand_judgment_tcc : env -> evar_map ref ->
glob_constr -> unsafe_judgment
+val type_uconstr :
+ ?flags:inference_flags ->
+ ?expected_type:typing_constraint ->
+ Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open
+
(** Trying to solve remaining evars and remaining conversion problems
possibly using type classes, heuristics, external tactic solver
hook depending on given flags. *)
@@ -130,6 +140,10 @@ val solve_remaining_evars : inference_flags ->
val check_evars_are_solved :
env -> (* current map: *) evar_map -> (* map to check: *) pending -> unit
+(** [check_evars env initial_sigma extended_sigma c] fails if some
+ new unresolved evar remains in [c] *)
+val check_evars : env -> evar_map -> evar_map -> constr -> unit
+
(**/**)
(** Internal of Pretyping... *)
val pretype :
@@ -148,12 +162,9 @@ val ise_pretype_gen :
(** To embed constr in glob_constr *)
-val constr_in : constr -> Dyn.t
-val constr_out : Dyn.t -> constr
-
-val interp_sort : evar_map -> glob_sort -> evar_map * sorts
+val interp_sort : ?loc:Loc.t -> evar_map -> glob_sort -> evar_map * sorts
val interp_elimination_sort : glob_sort -> sorts_family
val genarg_interp_hook :
- (types -> env -> evar_map -> Genarg.typed_generic_argument Id.Map.t ->
+ (types -> env -> evar_map -> unbound_ltac_var_map ->
Genarg.glob_generic_argument -> constr * evar_map) Hook.t
diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib
index a644e3d1..c8b3307d 100644
--- a/pretyping/pretyping.mllib
+++ b/pretyping/pretyping.mllib
@@ -1,7 +1,5 @@
Locusops
-Termops
-Namegen
-Evd
+Pretype_errors
Reductionops
Inductiveops
Vnorm
@@ -9,9 +7,8 @@ Arguments_renaming
Nativenorm
Retyping
Cbv
-Pretype_errors
Find_subterm
-Evarutil
+Evardefine
Evarsolve
Recordops
Evarconv
diff --git a/pretyping/program.ml b/pretyping/program.ml
index 0bd121f6..62aedcfb 100644
--- a/pretyping/program.ml
+++ b/pretyping/program.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -15,10 +15,12 @@ open Term
let make_dir l = DirPath.make (List.rev_map Id.of_string l)
let find_reference locstr dir s =
- let sp = Libnames.make_path (make_dir dir) (Id.of_string s) in
+ let dp = make_dir dir in
+ let sp = Libnames.make_path dp (Id.of_string s) in
try Nametab.global_of_path sp
with Not_found ->
- anomaly ~label:locstr (Pp.str "cannot find" ++ spc () ++ Libnames.pr_path sp)
+ user_err_loc (Loc.ghost, "", str "Library " ++ Libnames.pr_dirpath dp ++
+ str " has to be required first.")
let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s
let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s)
@@ -67,3 +69,43 @@ let mk_coq_and l =
(fun c conj ->
mkApp (and_typ, [| c ; conj |]))
l
+
+(* true = transparent by default, false = opaque if possible *)
+let proofs_transparency = ref true
+let program_cases = ref true
+let program_generalized_coercion = ref true
+
+let set_proofs_transparency = (:=) proofs_transparency
+let get_proofs_transparency () = !proofs_transparency
+
+let is_program_generalized_coercion () = !program_generalized_coercion
+let is_program_cases () = !program_cases
+
+open Goptions
+
+let _ =
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ optname = "preferred transparency of Program obligations";
+ optkey = ["Transparent";"Obligations"];
+ optread = get_proofs_transparency;
+ optwrite = set_proofs_transparency; }
+
+let _ =
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ optname = "program cases";
+ optkey = ["Program";"Cases"];
+ optread = (fun () -> !program_cases);
+ optwrite = (:=) program_cases }
+
+let _ =
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ optname = "program generalized coercion";
+ optkey = ["Program";"Generalized";"Coercion"];
+ optread = (fun () -> !program_generalized_coercion);
+ optwrite = (:=) program_generalized_coercion }
diff --git a/pretyping/program.mli b/pretyping/program.mli
index b7ebcbc9..023ff8ca 100644
--- a/pretyping/program.mli
+++ b/pretyping/program.mli
@@ -37,3 +37,7 @@ val mk_coq_not : constr -> constr
(** Polymorphic application of delayed references *)
val papp : Evd.evar_map ref -> (unit -> global_reference) -> constr array -> constr
+
+val get_proofs_transparency : unit -> bool
+val is_program_cases : unit -> bool
+val is_program_generalized_coercion : unit -> bool
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index 560beb6f..284af0cb 100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -13,7 +13,7 @@
(* This file registers properties of records: projections and
canonical structures *)
-open Errors
+open CErrors
open Util
open Pp
open Names
@@ -176,7 +176,7 @@ let cs_pattern_of_constr t =
App (f,vargs) ->
begin
try Const_cs (global_of_constr f) , None, Array.to_list vargs
- with e when Errors.noncritical e -> raise Not_found
+ with e when CErrors.noncritical e -> raise Not_found
end
| Rel n -> Default_cs, Some n, []
| Prod (_,a,b) when not (Termops.dependent (mkRel 1) b) -> Prod_cs, None, [a; Termops.pop b]
@@ -184,11 +184,18 @@ let cs_pattern_of_constr t =
| _ ->
begin
try Const_cs (global_of_constr t) , None, []
- with e when Errors.noncritical e -> raise Not_found
+ with e when CErrors.noncritical e -> raise Not_found
end
+let warn_projection_no_head_constant =
+ CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker"
+ (fun (t,con_pp,proji_sp_pp) ->
+ strbrk "Projection value has no head constant: "
+ ++ Termops.print_constr t ++ strbrk " in canonical instance "
+ ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.")
+
(* Intended to always succeed *)
-let compute_canonical_projections (con,ind) =
+let compute_canonical_projections warn (con,ind) =
let env = Global.env () in
let ctx = Univ.instantiate_univ_context (Environ.constant_context env con) in
let u = Univ.UContext.instance ctx in
@@ -213,13 +220,10 @@ let compute_canonical_projections (con,ind) =
let patt, n , args = cs_pattern_of_constr t in
((ConstRef proji_sp, patt, t, n, args) :: l)
with Not_found ->
- if Flags.is_verbose () then
- (let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con)
+ let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con)
and proji_sp_pp = Nametab.pr_global_env Id.Set.empty (ConstRef proji_sp) in
- msg_warning (strbrk "No global reference exists for projection value"
- ++ Termops.print_constr t ++ strbrk " in instance "
- ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it."));
- l
+ if warn then warn_projection_no_head_constant (t,con_pp,proji_sp_pp);
+ l
end
| _ -> l)
[] lps in
@@ -235,9 +239,15 @@ let pr_cs_pattern = function
| Default_cs -> str "_"
| Sort_cs s -> Termops.pr_sort_family s
-let open_canonical_structure i (_,o) =
- if Int.equal i 1 then
- let lo = compute_canonical_projections o in
+let warn_redundant_canonical_projection =
+ CWarnings.create ~name:"redundant-canonical-projection" ~category:"typechecker"
+ (fun (hd_val,prj,new_can_s,old_can_s) ->
+ strbrk "Ignoring canonical projection to " ++ hd_val
+ ++ strbrk " by " ++ prj ++ strbrk " in "
+ ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s)
+
+let add_canonical_structure warn o =
+ let lo = compute_canonical_projections warn o in
List.iter (fun ((proj,(cs_pat,_ as pat)),s) ->
let l = try Refmap.find proj !object_table with Not_found -> [] in
let ocs = try Some (assoc_pat cs_pat l)
@@ -245,17 +255,18 @@ let open_canonical_structure i (_,o) =
in match ocs with
| None -> object_table := Refmap.add proj ((pat,s)::l) !object_table;
| Some (c, cs) ->
- if Flags.is_verbose () then
let old_can_s = (Termops.print_constr cs.o_DEF)
and new_can_s = (Termops.print_constr s.o_DEF) in
let prj = (Nametab.pr_global_env Id.Set.empty proj)
and hd_val = (pr_cs_pattern cs_pat) in
- msg_warning (strbrk "Ignoring canonical projection to " ++ hd_val
- ++ strbrk " by " ++ prj ++ strbrk " in "
- ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s)) lo
+ if warn then warn_redundant_canonical_projection (hd_val,prj,new_can_s,old_can_s))
+ lo
+
+let open_canonical_structure i (_, o) =
+ if Int.equal i 1 then add_canonical_structure false o
-let cache_canonical_structure o =
- open_canonical_structure 1 o
+let cache_canonical_structure (_, o) =
+ add_canonical_structure true o
let subst_canonical_structure (subst,(cst,ind as obj)) =
(* invariant: cst is an evaluable reference. Thus we can take *)
@@ -299,7 +310,7 @@ let check_and_decompose_canonical_structure ref =
| Construct ((indsp,1),u) -> indsp
| _ -> error_not_structure ref in
let s = try lookup_structure indsp with Not_found -> error_not_structure ref in
- let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in
+ let ntrue_projs = List.count snd s.s_PROJKIND in
if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then
error_not_structure ref;
(sp,indsp)
@@ -317,7 +328,7 @@ let is_open_canonical_projection env sigma (c,args) =
(** Check if there is some canonical projection attached to this structure *)
let _ = Refmap.find ref !object_table in
try
- let arg = whd_betadeltaiota env sigma (Stack.nth args n) in
+ let arg = whd_all env sigma (Stack.nth args n) in
let hd = match kind_of_term arg with App (hd, _) -> hd | _ -> arg in
not (isConstruct hd)
with Failure _ -> false
diff --git a/pretyping/redops.ml b/pretyping/redops.ml
index c188995a..7d65925e 100644
--- a/pretyping/redops.ml
+++ b/pretyping/redops.ml
@@ -14,25 +14,29 @@ let make_red_flag l =
let rec add_flag red = function
| [] -> red
| FBeta :: lf -> add_flag { red with rBeta = true } lf
- | FIota :: lf -> add_flag { red with rIota = true } lf
+ | FMatch :: lf -> add_flag { red with rMatch = true } lf
+ | FFix :: lf -> add_flag { red with rFix = true } lf
+ | FCofix :: lf -> add_flag { red with rCofix = true } lf
| FZeta :: lf -> add_flag { red with rZeta = true } lf
| FConst l :: lf ->
if red.rDelta then
- Errors.error
+ CErrors.error
"Cannot set both constants to unfold and constants not to unfold";
add_flag { red with rConst = union_consts red.rConst l } lf
| FDeltaBut l :: lf ->
if red.rConst <> [] && not red.rDelta then
- Errors.error
+ CErrors.error
"Cannot set both constants to unfold and constants not to unfold";
add_flag
{ red with rConst = union_consts red.rConst l; rDelta = true }
lf
in
add_flag
- {rBeta = false; rIota = false; rZeta = false; rDelta = false; rConst = []}
+ {rBeta = false; rMatch = false; rFix = false; rCofix = false;
+ rZeta = false; rDelta = false; rConst = []}
l
let all_flags =
- {rBeta = true; rIota = true; rZeta = true; rDelta = true; rConst = []}
+ {rBeta = true; rMatch = true; rFix = true; rCofix = true;
+ rZeta = true; rDelta = true; rConst = []}
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 13b7fb40..297f0a1a 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -6,16 +6,16 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Term
open Vars
-open Context
open Termops
open Univ
open Evd
open Environ
+open Context.Rel.Declaration
exception Elimconst
@@ -26,6 +26,19 @@ exception Elimconst
their parameters in its stack.
*)
+let refolding_in_reduction = ref false
+let _ = Goptions.declare_bool_option {
+ Goptions.optsync = true; Goptions.optdepr = false;
+ Goptions.optname =
+ "Perform refolding of fixpoints/constants like cbn during reductions";
+ Goptions.optkey = ["Refolding";"Reduction"];
+ Goptions.optread = (fun () -> !refolding_in_reduction);
+ Goptions.optwrite = (fun a -> refolding_in_reduction:=a);
+}
+
+let get_refolding_in_reduction () = !refolding_in_reduction
+let set_refolding_in_reduction = (:=) refolding_in_reduction
+
(** Machinery to custom the behavior of the reduction *)
module ReductionBehaviour = struct
open Globnames
@@ -153,9 +166,6 @@ module Cst_stack = struct
let empty = []
let is_empty = CList.is_empty
- let sanity x y =
- assert(Term.eq_constr x y)
-
let drop_useless = function
| _ :: ((_,_,[])::_ as q) -> q
| l -> l
@@ -164,9 +174,9 @@ module Cst_stack = struct
let append2cst = function
| (c,params,[]) -> (c, h::params, [])
| (c,params,((i,t)::q)) when i = pred (Array.length t) ->
- let () = sanity h t.(i) in (c, params, q)
+ (c, params, q)
| (c,params,(i,t)::q) ->
- let () = sanity h t.(i) in (c, params, (succ i,t)::q)
+ (c, params, (succ i,t)::q)
in
drop_useless (List.map append2cst cst_l)
@@ -573,7 +583,7 @@ type state = constr * constr Stack.t
type contextual_reduction_function = env -> evar_map -> constr -> constr
type reduction_function = contextual_reduction_function
type local_reduction_function = evar_map -> constr -> constr
-type e_reduction_function = env -> evar_map -> constr -> evar_map * constr
+type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma }
type contextual_stack_reduction_function =
env -> evar_map -> constr -> constr * constr list
@@ -594,9 +604,7 @@ let pr_state (tm,sk) =
(*** Reduction Functions Operators ***)
(*************************************)
-let safe_evar_value sigma ev =
- try Some (Evd.existential_value sigma ev)
- with NotInstantiatedEvar | Not_found -> None
+let safe_evar_value = Evarutil.safe_evar_value
let safe_meta_value sigma ev =
try Some (Evd.meta_value sigma ev)
@@ -608,7 +616,7 @@ let strong whdfun env sigma t =
strongrec env t
let local_strong whdfun sigma =
- let rec strongrec t = map_constr strongrec (whdfun sigma t) in
+ let rec strongrec t = Constr.map strongrec (whdfun sigma t) in
strongrec
let rec strong_prodspine redfun sigma c =
@@ -621,36 +629,21 @@ let rec strong_prodspine redfun sigma c =
(*** Reduction using bindingss ***)
(*************************************)
-(* Local *)
-let nored = Closure.RedFlags.no_red
-let beta = Closure.beta
-let eta = Closure.RedFlags.mkflags [Closure.RedFlags.fETA]
-let zeta = Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]
-let betaiota = Closure.betaiota
-let betaiotazeta = Closure.betaiotazeta
-
-(* Contextual *)
-let delta = Closure.RedFlags.mkflags [Closure.RedFlags.fDELTA]
-let betalet = Closure.RedFlags.mkflags [Closure.RedFlags.fBETA;Closure.RedFlags.fZETA]
-let betaetalet = Closure.RedFlags.red_add betalet Closure.RedFlags.fETA
-let betadelta = Closure.RedFlags.red_add betalet Closure.RedFlags.fDELTA
-let betadeltaeta = Closure.RedFlags.red_add betadelta Closure.RedFlags.fETA
-let betadeltaiota = Closure.RedFlags.red_add betadelta Closure.RedFlags.fIOTA
-let betadeltaiota_nolet = Closure.betadeltaiotanolet
-let betadeltaiotaeta = Closure.RedFlags.red_add betadeltaiota Closure.RedFlags.fETA
+let eta = CClosure.RedFlags.mkflags [CClosure.RedFlags.fETA]
(* Beta Reduction tools *)
-let apply_subst recfun env cst_l t stack =
+let apply_subst recfun env refold cst_l t stack =
let rec aux env cst_l t stack =
match (Stack.decomp stack,kind_of_term t) with
| Some (h,stacktl), Lambda (_,_,c) ->
- aux (h::env) (Cst_stack.add_param h cst_l) c stacktl
+ let cst_l' = if refold then Cst_stack.add_param h cst_l else cst_l in
+ aux (h::env) cst_l' c stacktl
| _ -> recfun cst_l (substl env t, stack)
in aux env cst_l t stack
let stacklam recfun env t stack =
- apply_subst (fun _ -> recfun) env Cst_stack.empty t stack
+ apply_subst (fun _ -> recfun) env false Cst_stack.empty t stack
let beta_applist (c,l) =
stacklam Stack.zip [] c (Stack.append_app_list l Stack.empty)
@@ -715,11 +708,16 @@ let contract_cofix ?env ?reference (bodynum,(names,types,bodies as typedbodies))
substl closure bodies.(bodynum)
(** Similar to the "fix" case below *)
-let reduce_and_refold_cofix recfun env cst_l cofix sk =
- let raw_answer = contract_cofix ~env ?reference:(Cst_stack.reference cst_l) cofix in
+let reduce_and_refold_cofix recfun env refold cst_l cofix sk =
+ let raw_answer =
+ let env = if refold then Some env else None in
+ contract_cofix ?env ?reference:(Cst_stack.reference cst_l) cofix in
apply_subst
- (fun x (t,sk') -> recfun x (Cst_stack.best_replace (mkCoFix cofix) cst_l t,sk'))
- [] Cst_stack.empty raw_answer sk
+ (fun x (t,sk') ->
+ let t' =
+ if refold then Cst_stack.best_replace (mkCoFix cofix) cst_l t else t in
+ recfun x (t',sk'))
+ [] refold Cst_stack.empty raw_answer sk
let reduce_mind_case mia =
match kind_of_term mia.mconstr with
@@ -755,11 +753,18 @@ let contract_fix ?env ?reference ((recindices,bodynum),(names,types,bodies as ty
replace the fixpoint by the best constant from [cst_l]
Other rels are directly substituted by constants "magically found from the
context" in contract_fix *)
-let reduce_and_refold_fix recfun env cst_l fix sk =
- let raw_answer = contract_fix ~env ?reference:(Cst_stack.reference cst_l) fix in
+let reduce_and_refold_fix recfun env refold cst_l fix sk =
+ let raw_answer =
+ let env = if refold then None else Some env in
+ contract_fix ?env ?reference:(Cst_stack.reference cst_l) fix in
apply_subst
- (fun x (t,sk') -> recfun x (Cst_stack.best_replace (mkFix fix) cst_l t,sk'))
- [] Cst_stack.empty raw_answer sk
+ (fun x (t,sk') ->
+ let t' =
+ if refold then
+ Cst_stack.best_replace (mkFix fix) cst_l t
+ else t
+ in recfun x (t',sk'))
+ [] refold Cst_stack.empty raw_answer sk
let fix_recarg ((recindices,bodynum),_) stack =
assert (0 <= bodynum && bodynum < Array.length recindices);
@@ -799,28 +804,31 @@ let equal_stacks (x, l) (y, l') =
| None -> false
| Some (lft1,lft2) -> f_equal (x, lft1) (y, lft2)
-let rec whd_state_gen ?csts tactic_mode flags env sigma =
+let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma =
+ let open Context.Named.Declaration in
let rec whrec cst_l (x, stack as s) =
let () = if !debug_RAKAM then
let open Pp in
- pp (h 0 (str "<<" ++ Termops.print_constr x ++
+ Feedback.msg_notice
+ (h 0 (str "<<" ++ Termops.print_constr x ++
str "|" ++ cut () ++ Cst_stack.pr cst_l ++
str "|" ++ cut () ++ Stack.pr Termops.print_constr stack ++
- str ">>") ++ fnl ())
+ str ">>"))
in
let fold () =
let () = if !debug_RAKAM then
- let open Pp in pp (str "<><><><><>" ++ fnl ()) in
- if tactic_mode then (Stack.best_state s cst_l,Cst_stack.empty) else (s,cst_l)
+ let open Pp in Feedback.msg_notice (str "<><><><><>") in
+ (s,cst_l)
in
match kind_of_term x with
- | Rel n when Closure.RedFlags.red_set flags Closure.RedFlags.fDELTA ->
+ | Rel n when CClosure.RedFlags.red_set flags CClosure.RedFlags.fDELTA ->
(match lookup_rel n env with
- | (_,Some body,_) -> whrec Cst_stack.empty (lift n body, stack)
+ | LocalDef (_,body,_) -> whrec Cst_stack.empty (lift n body, stack)
| _ -> fold ())
- | Var id when Closure.RedFlags.red_set flags (Closure.RedFlags.fVAR id) ->
+ | Var id when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fVAR id) ->
(match lookup_named id env with
- | (_,Some body,_) -> whrec (Cst_stack.add_cst (mkVar id) cst_l) (body, stack)
+ | LocalDef (_,body,_) ->
+ whrec (if refold then Cst_stack.add_cst (mkVar id) cst_l else cst_l) (body, stack)
| _ -> fold ())
| Evar ev ->
(match safe_evar_value sigma ev with
@@ -830,12 +838,13 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
(match safe_meta_value sigma ev with
| Some body -> whrec cst_l (body, stack)
| None -> fold ())
- | Const (c,u as const) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST c) ->
+ | Const (c,u as const) when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fCONST c) ->
(match constant_opt_value_in env const with
| None -> fold ()
| Some body ->
if not tactic_mode
- then whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack)
+ then whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l)
+ (body, stack)
else (* Looks for ReductionBehaviour *)
match ReductionBehaviour.get (Globnames.ConstRef c) with
| None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack)
@@ -870,7 +879,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
whrec Cst_stack.empty
(arg,Stack.Cst(Stack.Cst_const const,curr,remains,bef,cst_l)::s')
)
- | Proj (p, c) when Closure.RedFlags.red_projection flags p ->
+ | Proj (p, c) when CClosure.RedFlags.red_projection flags p ->
(let pb = lookup_projection p env in
let kn = Projection.constant p in
let npars = pb.Declarations.proj_npars
@@ -911,21 +920,21 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
(arg,Stack.Cst(Stack.Cst_proj p,curr,remains,
Stack.append_app [|c|] bef,cst_l)::s'))
- | LetIn (_,b,_,c) when Closure.RedFlags.red_set flags Closure.RedFlags.fZETA ->
- apply_subst whrec [b] cst_l c stack
+ | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA ->
+ apply_subst whrec [b] refold cst_l c stack
| Cast (c,_,_) -> whrec cst_l (c, stack)
| App (f,cl) ->
whrec
- (Cst_stack.add_args cl cst_l)
+ (if refold then Cst_stack.add_args cl cst_l else cst_l)
(f, Stack.append_app cl stack)
| Lambda (na,t,c) ->
(match Stack.decomp stack with
- | Some _ when Closure.RedFlags.red_set flags Closure.RedFlags.fBETA ->
- apply_subst whrec [] cst_l x stack
- | None when Closure.RedFlags.red_set flags Closure.RedFlags.fETA ->
- let env' = push_rel (na,None,t) env in
- let whrec' = whd_state_gen tactic_mode flags env' sigma in
- (match kind_of_term (Stack.zip ~refold:true (fst (whrec' (c, Stack.empty)))) with
+ | Some _ when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA ->
+ apply_subst whrec [] refold cst_l x stack
+ | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA ->
+ let env' = push_rel (LocalAssum (na,t)) env in
+ let whrec' = whd_state_gen ~refold ~tactic_mode flags env' sigma in
+ (match kind_of_term (Stack.zip ~refold (fst (whrec' (c, Stack.empty)))) with
| App (f,cl) ->
let napp = Array.length cl in
if napp > 0 then
@@ -950,16 +959,18 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
whrec Cst_stack.empty (arg, Stack.Fix(f,bef,cst_l)::s'))
| Construct ((ind,c),u) ->
- if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+ let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in
+ let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in
+ if use_match || use_fix then
match Stack.strip_app stack with
- |args, (Stack.Case(ci, _, lf,_)::s') ->
+ |args, (Stack.Case(ci, _, lf,_)::s') when use_match ->
whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s')
- |args, (Stack.Proj (n,m,p,_)::s') ->
+ |args, (Stack.Proj (n,m,p,_)::s') when use_match ->
whrec Cst_stack.empty (Stack.nth args (n+m), s')
- |args, (Stack.Fix (f,s',cst_l)::s'') ->
+ |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix ->
let x' = Stack.zip(x,args) in
let out_sk = s' @ (Stack.append_app [|x'|] s'') in
- reduce_and_refold_fix whrec env cst_l f out_sk
+ reduce_and_refold_fix whrec env refold cst_l f out_sk
|args, (Stack.Cst (const,curr,remains,s',cst_l) :: s'') ->
let x' = Stack.zip(x,args) in
begin match remains with
@@ -969,7 +980,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
(match constant_opt_value_in env const with
| None -> fold ()
| Some body ->
- whrec (Cst_stack.add_cst (mkConstU const) cst_l)
+ whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l)
(body, s' @ (Stack.append_app [|x'|] s'')))
| Stack.Cst_proj p ->
let pb = lookup_projection p env in
@@ -988,35 +999,37 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
Stack.Cst (const,next,remains',s' @ (Stack.append_app [|x'|] bef),cst_l) :: s''')
end
|_, (Stack.App _|Stack.Update _|Stack.Shift _)::_ -> assert false
- |_, [] -> fold ()
+ |_, _ -> fold ()
else fold ()
| CoFix cofix ->
- if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+ if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then
match Stack.strip_app stack with
|args, ((Stack.Case _ |Stack.Proj _)::s') ->
- reduce_and_refold_cofix whrec env cst_l cofix stack
+ reduce_and_refold_cofix whrec env refold cst_l cofix stack
|_ -> fold ()
else fold ()
| Rel _ | Var _ | Const _ | LetIn _ | Proj _ -> fold ()
| Sort _ | Ind _ | Prod _ -> fold ()
in
- whrec (Option.default Cst_stack.empty csts)
+ fun xs ->
+ let (s,cst_l as res) = whrec (Option.default Cst_stack.empty csts) xs in
+ if tactic_mode then (Stack.best_state s cst_l,Cst_stack.empty) else res
(** reduction machine without global env and refold machinery *)
let local_whd_state_gen flags sigma =
let rec whrec (x, stack as s) =
match kind_of_term x with
- | LetIn (_,b,_,c) when Closure.RedFlags.red_set flags Closure.RedFlags.fZETA ->
+ | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA ->
stacklam whrec [b] c stack
| Cast (c,_,_) -> whrec (c, stack)
| App (f,cl) -> whrec (f, Stack.append_app cl stack)
| Lambda (_,_,c) ->
(match Stack.decomp stack with
- | Some (a,m) when Closure.RedFlags.red_set flags Closure.RedFlags.fBETA ->
+ | Some (a,m) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA ->
stacklam whrec [a] c m
- | None when Closure.RedFlags.red_set flags Closure.RedFlags.fETA ->
+ | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA ->
(match kind_of_term (Stack.zip (whrec (c, Stack.empty))) with
| App (f,cl) ->
let napp = Array.length cl in
@@ -1032,7 +1045,7 @@ let local_whd_state_gen flags sigma =
| _ -> s)
| _ -> s)
- | Proj (p,c) when Closure.RedFlags.red_projection flags p ->
+ | Proj (p,c) when CClosure.RedFlags.red_projection flags p ->
(let pb = lookup_projection p (Global.env ()) in
whrec (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg,
p, Cst_stack.empty)
@@ -1057,21 +1070,23 @@ let local_whd_state_gen flags sigma =
| None -> s)
| Construct ((ind,c),u) ->
- if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+ let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in
+ let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in
+ if use_match || use_fix then
match Stack.strip_app stack with
- |args, (Stack.Case(ci, _, lf,_)::s') ->
+ |args, (Stack.Case(ci, _, lf,_)::s') when use_match ->
whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s')
- |args, (Stack.Proj (n,m,p,_) :: s') ->
+ |args, (Stack.Proj (n,m,p,_) :: s') when use_match ->
whrec (Stack.nth args (n+m), s')
- |args, (Stack.Fix (f,s',cst)::s'') ->
+ |args, (Stack.Fix (f,s',cst)::s'') when use_fix ->
let x' = Stack.zip(x,args) in
whrec (contract_fix f, s' @ (Stack.append_app [|x'|] s''))
|_, (Stack.App _|Stack.Update _|Stack.Shift _|Stack.Cst _)::_ -> assert false
- |_, [] -> s
+ |_, _ -> s
else s
| CoFix cofix ->
- if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+ if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then
match Stack.strip_app stack with
|args, ((Stack.Case _ | Stack.Proj _)::s') ->
whrec (contract_cofix cofix, stack)
@@ -1083,7 +1098,7 @@ let local_whd_state_gen flags sigma =
whrec
let raw_whd_state_gen flags env =
- let f sigma s = fst (whd_state_gen false flags env sigma s) in
+ let f sigma s = fst (whd_state_gen (get_refolding_in_reduction ()) false flags env sigma s) in
f
let stack_red_of_state_red f =
@@ -1093,7 +1108,7 @@ let stack_red_of_state_red f =
(* Drops the Cst_stack *)
let iterate_whd_gen refold flags env sigma s =
let rec aux t =
- let (hd,sk),_ = whd_state_gen refold flags env sigma (t,Stack.empty) in
+ let (hd,sk),_ = whd_state_gen refold false flags env sigma (t,Stack.empty) in
let whd_sk = Stack.map aux sk in
Stack.zip ~refold (hd,whd_sk)
in aux s
@@ -1103,109 +1118,72 @@ let red_of_state_red f sigma x =
(* 0. No Reduction Functions *)
-let whd_nored_state = local_whd_state_gen nored
+let whd_nored_state = local_whd_state_gen CClosure.nored
let whd_nored_stack = stack_red_of_state_red whd_nored_state
let whd_nored = red_of_state_red whd_nored_state
(* 1. Beta Reduction Functions *)
-let whd_beta_state = local_whd_state_gen beta
+let whd_beta_state = local_whd_state_gen CClosure.beta
let whd_beta_stack = stack_red_of_state_red whd_beta_state
let whd_beta = red_of_state_red whd_beta_state
-(* Nouveau ! *)
-let whd_betaetalet_state = local_whd_state_gen betaetalet
-let whd_betaetalet_stack = stack_red_of_state_red whd_betaetalet_state
-let whd_betaetalet = red_of_state_red whd_betaetalet_state
-
-let whd_betalet_state = local_whd_state_gen betalet
+let whd_betalet_state = local_whd_state_gen CClosure.betazeta
let whd_betalet_stack = stack_red_of_state_red whd_betalet_state
let whd_betalet = red_of_state_red whd_betalet_state
(* 2. Delta Reduction Functions *)
-let whd_delta_state e = raw_whd_state_gen delta e
+let whd_delta_state e = raw_whd_state_gen CClosure.delta e
let whd_delta_stack env = stack_red_of_state_red (whd_delta_state env)
let whd_delta env = red_of_state_red (whd_delta_state env)
-let whd_betadelta_state e = raw_whd_state_gen betadelta e
-let whd_betadelta_stack env =
- stack_red_of_state_red (whd_betadelta_state env)
-let whd_betadelta env =
- red_of_state_red (whd_betadelta_state env)
+let whd_betadeltazeta_state e = raw_whd_state_gen CClosure.betadeltazeta e
+let whd_betadeltazeta_stack env =
+ stack_red_of_state_red (whd_betadeltazeta_state env)
+let whd_betadeltazeta env =
+ red_of_state_red (whd_betadeltazeta_state env)
-let whd_betadeltaeta_state e = raw_whd_state_gen betadeltaeta e
-let whd_betadeltaeta_stack env =
- stack_red_of_state_red (whd_betadeltaeta_state env)
-let whd_betadeltaeta env =
- red_of_state_red (whd_betadeltaeta_state env)
-
(* 3. Iota reduction Functions *)
-let whd_betaiota_state = local_whd_state_gen betaiota
+let whd_betaiota_state = local_whd_state_gen CClosure.betaiota
let whd_betaiota_stack = stack_red_of_state_red whd_betaiota_state
let whd_betaiota = red_of_state_red whd_betaiota_state
-let whd_betaiotazeta_state = local_whd_state_gen betaiotazeta
+let whd_betaiotazeta_state = local_whd_state_gen CClosure.betaiotazeta
let whd_betaiotazeta_stack = stack_red_of_state_red whd_betaiotazeta_state
let whd_betaiotazeta = red_of_state_red whd_betaiotazeta_state
-let whd_betadeltaiota_state env = raw_whd_state_gen betadeltaiota env
-let whd_betadeltaiota_stack env =
- stack_red_of_state_red (whd_betadeltaiota_state env)
-let whd_betadeltaiota env =
- red_of_state_red (whd_betadeltaiota_state env)
-
-let whd_betadeltaiotaeta_state env = raw_whd_state_gen betadeltaiotaeta env
-let whd_betadeltaiotaeta_stack env =
- stack_red_of_state_red (whd_betadeltaiotaeta_state env)
-let whd_betadeltaiotaeta env =
- red_of_state_red (whd_betadeltaiotaeta_state env)
+let whd_all_state env = raw_whd_state_gen CClosure.all env
+let whd_all_stack env =
+ stack_red_of_state_red (whd_all_state env)
+let whd_all env =
+ red_of_state_red (whd_all_state env)
-let whd_betadeltaiota_nolet_state env = raw_whd_state_gen betadeltaiota_nolet env
-let whd_betadeltaiota_nolet_stack env =
- stack_red_of_state_red (whd_betadeltaiota_nolet_state env)
-let whd_betadeltaiota_nolet env =
- red_of_state_red (whd_betadeltaiota_nolet_state env)
+let whd_allnolet_state env = raw_whd_state_gen CClosure.allnolet env
+let whd_allnolet_stack env =
+ stack_red_of_state_red (whd_allnolet_state env)
+let whd_allnolet env =
+ red_of_state_red (whd_allnolet_state env)
-(* 4. Eta reduction Functions *)
+(* 4. Ad-hoc eta reduction, does not subsitute evars *)
-let whd_eta c = Stack.zip (local_whd_state_gen eta Evd.empty (c,Stack.empty))
+let shrink_eta c = Stack.zip (local_whd_state_gen eta Evd.empty (c,Stack.empty))
(* 5. Zeta Reduction Functions *)
-let whd_zeta c = Stack.zip (local_whd_state_gen zeta Evd.empty (c,Stack.empty))
+let whd_zeta_state = local_whd_state_gen CClosure.zeta
+let whd_zeta_stack = stack_red_of_state_red whd_zeta_state
+let whd_zeta = red_of_state_red whd_zeta_state
(****************************************************************************)
(* Reduction Functions *)
(****************************************************************************)
(* Replacing defined evars for error messages *)
-let rec whd_evar sigma c =
- match kind_of_term c with
- | Evar ev ->
- let (evk, args) = ev in
- let args = Array.map (fun c -> whd_evar sigma c) args in
- (match safe_evar_value sigma (evk, args) with
- Some c -> whd_evar sigma c
- | None -> c)
- | Sort (Type u) ->
- let u' = Evd.normalize_universe sigma u in
- if u' == u then c else mkSort (Sorts.sort_of_univ u')
- | Const (c', u) when not (Univ.Instance.is_empty u) ->
- let u' = Evd.normalize_universe_instance sigma u in
- if u' == u then c else mkConstU (c', u')
- | Ind (i, u) when not (Univ.Instance.is_empty u) ->
- let u' = Evd.normalize_universe_instance sigma u in
- if u' == u then c else mkIndU (i, u')
- | Construct (co, u) when not (Univ.Instance.is_empty u) ->
- let u' = Evd.normalize_universe_instance sigma u in
- if u' == u then c else mkConstructU (co, u')
- | _ -> c
-
-let nf_evar =
- local_strong whd_evar
+let whd_evar = Evarutil.whd_evar
+let nf_evar = Evarutil.nf_evar
(* lazy reduction functions. The infos must be created for each term *)
(* Note by HH [oct 08] : why would it be the job of clos_norm_flags to add
@@ -1213,16 +1191,16 @@ let nf_evar =
let clos_norm_flags flgs env sigma t =
try
let evars ev = safe_evar_value sigma ev in
- Closure.norm_val
- (Closure.create_clos_infos ~evars flgs env)
- (Closure.inject t)
+ CClosure.norm_val
+ (CClosure.create_clos_infos ~evars flgs env)
+ (CClosure.inject t)
with e when is_anomaly e -> error "Tried to normalize ill-typed term"
-let nf_beta = clos_norm_flags Closure.beta (Global.env ())
-let nf_betaiota = clos_norm_flags Closure.betaiota (Global.env ())
-let nf_betaiotazeta = clos_norm_flags Closure.betaiotazeta (Global.env ())
-let nf_betadeltaiota env sigma =
- clos_norm_flags Closure.betadeltaiota env sigma
+let nf_beta = clos_norm_flags CClosure.beta (Global.env ())
+let nf_betaiota = clos_norm_flags CClosure.betaiota (Global.env ())
+let nf_betaiotazeta = clos_norm_flags CClosure.betaiotazeta (Global.env ())
+let nf_all env sigma =
+ clos_norm_flags CClosure.all env sigma
(********************************************************************)
@@ -1253,31 +1231,29 @@ let pb_equal = function
let report_anomaly _ =
let e = UserError ("", Pp.str "Conversion test raised an anomaly") in
- let e = Errors.push e in
+ let e = CErrors.push e in
iraise e
-let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y =
+let test_trans_conversion (f: constr Reduction.extended_conversion_function) reds env sigma x y =
try
let evars ev = safe_evar_value sigma ev in
- let _ = f ~evars reds env (Evd.universes sigma) x y in
+ let _ = f ~reds env ~evars:(evars, Evd.universes sigma) x y in
true
with Reduction.NotConvertible -> false
| e when is_anomaly e -> report_anomaly e
-let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma
-let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma
-let is_trans_fconv = function Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq
-
-let is_conv = is_trans_conv full_transparent_state
-let is_conv_leq = is_trans_conv_leq full_transparent_state
-let is_fconv = function | Reduction.CONV -> is_conv | Reduction.CUMUL -> is_conv_leq
+let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv reds env sigma
+let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_leq reds env sigma
+let is_fconv ?(reds=full_transparent_state) = function
+ | Reduction.CONV -> is_conv ~reds
+ | Reduction.CUMUL -> is_conv_leq ~reds
let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y =
let f = match pb with
- | Reduction.CONV -> Reduction.trans_conv_universes
- | Reduction.CUMUL -> Reduction.trans_conv_leq_universes
+ | Reduction.CONV -> Reduction.conv
+ | Reduction.CUMUL -> Reduction.conv_leq
in
- try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true
+ try f ~reds:ts env ~evars:(safe_evar_value sigma, Evd.universes sigma) x y; true
with Reduction.NotConvertible -> false
| Univ.UniverseInconsistency _ -> false
| e when is_anomaly e -> report_anomaly e
@@ -1286,7 +1262,7 @@ let sigma_compare_sorts env pb s0 s1 sigma =
match pb with
| Reduction.CONV -> Evd.set_eq_sort env sigma s0 s1
| Reduction.CUMUL -> Evd.set_leq_sort env sigma s0 s1
-
+
let sigma_compare_instances ~flex i0 i1 sigma =
try Evd.set_eq_instances ~flex sigma i0 i1
with Evd.UniversesDiffer
@@ -1299,18 +1275,21 @@ let sigma_univ_state =
let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL)
?(ts=full_transparent_state) env sigma x y =
- try
+ try
+ let fold cstr sigma =
+ try Some (Evd.add_universe_constraints sigma cstr)
+ with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> None
+ in
let b, sigma =
- let b, cstrs =
+ let ans =
if pb == Reduction.CUMUL then
- Universes.leq_constr_univs_infer (Evd.universes sigma) x y
+ Universes.leq_constr_univs_infer (Evd.universes sigma) fold x y sigma
else
- Universes.eq_constr_univs_infer (Evd.universes sigma) x y
+ Universes.eq_constr_univs_infer (Evd.universes sigma) fold x y sigma
in
- if b then
- try true, Evd.add_universe_constraints sigma cstrs
- with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> false, sigma
- else false, sigma
+ match ans with
+ | None -> false, sigma
+ | Some sigma -> true, sigma
in
if b then sigma, true
else
@@ -1416,7 +1395,7 @@ let instance sigma s c =
* error message. *)
let hnf_prod_app env sigma t n =
- match kind_of_term (whd_betadeltaiota env sigma t) with
+ match kind_of_term (whd_all env sigma t) with
| Prod (_,_,b) -> subst1 n b
| _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product")
@@ -1427,7 +1406,7 @@ let hnf_prod_applist env sigma t nl =
List.fold_left (hnf_prod_app env sigma) t nl
let hnf_lam_app env sigma t n =
- match kind_of_term (whd_betadeltaiota env sigma t) with
+ match kind_of_term (whd_all env sigma t) with
| Lambda (_,_,b) -> subst1 n b
| _ -> anomaly ~label:"hnf_lam_app" (Pp.str "Need an abstraction")
@@ -1439,10 +1418,10 @@ let hnf_lam_applist env sigma t nl =
let splay_prod env sigma =
let rec decrec env m c =
- let t = whd_betadeltaiota env sigma c in
+ let t = whd_all env sigma c in
match kind_of_term t with
| Prod (n,a,c0) ->
- decrec (push_rel (n,None,a) env)
+ decrec (push_rel (LocalAssum (n,a)) env)
((n,a)::m) c0
| _ -> m,t
in
@@ -1450,10 +1429,10 @@ let splay_prod env sigma =
let splay_lam env sigma =
let rec decrec env m c =
- let t = whd_betadeltaiota env sigma c in
+ let t = whd_all env sigma c in
match kind_of_term t with
| Lambda (n,a,c0) ->
- decrec (push_rel (n,None,a) env)
+ decrec (push_rel (LocalAssum (n,a)) env)
((n,a)::m) c0
| _ -> m,t
in
@@ -1461,21 +1440,21 @@ let splay_lam env sigma =
let splay_prod_assum env sigma =
let rec prodec_rec env l c =
- let t = whd_betadeltaiota_nolet env sigma c in
+ let t = whd_allnolet env sigma c in
match kind_of_term t with
| Prod (x,t,c) ->
- prodec_rec (push_rel (x,None,t) env)
- (add_rel_decl (x, None, t) l) c
+ prodec_rec (push_rel (LocalAssum (x,t)) env)
+ (Context.Rel.add (LocalAssum (x,t)) l) c
| LetIn (x,b,t,c) ->
- prodec_rec (push_rel (x, Some b, t) env)
- (add_rel_decl (x, Some b, t) l) c
+ prodec_rec (push_rel (LocalDef (x,b,t)) env)
+ (Context.Rel.add (LocalDef (x,b,t)) l) c
| Cast (c,_,_) -> prodec_rec env l c
| _ ->
- let t' = whd_betadeltaiota env sigma t in
+ let t' = whd_all env sigma t in
if Term.eq_constr t t' then l,t
else prodec_rec env l t'
in
- prodec_rec env empty_rel_context
+ prodec_rec env Context.Rel.empty
let splay_arity env sigma c =
let l, c = splay_prod env sigma c in
@@ -1487,26 +1466,26 @@ let sort_of_arity env sigma c = snd (splay_arity env sigma c)
let splay_prod_n env sigma n =
let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else
- match kind_of_term (whd_betadeltaiota env sigma c) with
+ match kind_of_term (whd_all env sigma c) with
| Prod (n,a,c0) ->
- decrec (push_rel (n,None,a) env)
- (m-1) (add_rel_decl (n,None,a) ln) c0
+ decrec (push_rel (LocalAssum (n,a)) env)
+ (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0
| _ -> invalid_arg "splay_prod_n"
in
- decrec env n empty_rel_context
+ decrec env n Context.Rel.empty
let splay_lam_n env sigma n =
let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else
- match kind_of_term (whd_betadeltaiota env sigma c) with
+ match kind_of_term (whd_all env sigma c) with
| Lambda (n,a,c0) ->
- decrec (push_rel (n,None,a) env)
- (m-1) (add_rel_decl (n,None,a) ln) c0
+ decrec (push_rel (LocalAssum (n,a)) env)
+ (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0
| _ -> invalid_arg "splay_lam_n"
in
- decrec env n empty_rel_context
+ decrec env n Context.Rel.empty
let is_sort env sigma t =
- match kind_of_term (whd_betadeltaiota env sigma t) with
+ match kind_of_term (whd_all env sigma t) with
| Sort s -> true
| _ -> false
@@ -1514,20 +1493,22 @@ let is_sort env sigma t =
of case/fix (heuristic used by evar_conv) *)
let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s =
+ let refold = get_refolding_in_reduction () in
+ let tactic_mode = false in
let rec whrec csts s =
- let (t, stack as s),csts' = whd_state_gen ~csts false betaiota env sigma s in
+ let (t, stack as s),csts' = whd_state_gen ~csts ~refold ~tactic_mode CClosure.betaiota env sigma s in
match Stack.strip_app stack with
|args, (Stack.Case _ :: _ as stack') ->
- let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false
- (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in
+ let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode
+ (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in
if reducible_mind_case t_o then whrec csts_o (t_o, stack_o@stack') else s,csts'
|args, (Stack.Fix _ :: _ as stack') ->
- let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false
- (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in
+ let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode
+ (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in
if isConstruct t_o then whrec csts_o (t_o, stack_o@stack') else s,csts'
|args, (Stack.Proj (n,m,p,_) :: stack'') ->
- let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false
- (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in
+ let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode
+ (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in
if isConstruct t_o then
whrec Cst_stack.empty (Stack.nth stack_o (n+m), stack'')
else s,csts'
@@ -1536,10 +1517,10 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s =
let find_conclusion env sigma =
let rec decrec env c =
- let t = whd_betadeltaiota env sigma c in
+ let t = whd_all env sigma c in
match kind_of_term t with
- | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
- | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
+ | Prod (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0
+ | Lambda (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0
| t -> t
in
decrec env
@@ -1623,7 +1604,7 @@ let meta_reducible_instance evd b =
with
| Some g -> irec (mkProj (p,g))
| None -> mkProj (p,c))
- | _ -> map_constr irec u
+ | _ -> Constr.map irec u
in
if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus
else irec b.rebus
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index aea0a9ae..4cd7a2a8 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -8,7 +8,6 @@
open Names
open Term
-open Context
open Univ
open Evd
open Environ
@@ -29,6 +28,11 @@ module ReductionBehaviour : sig
val print : Globnames.global_reference -> Pp.std_ppcmds
end
+(** Option telling if reduction should use the refolding machinery of cbn
+ (off by default) *)
+val get_refolding_in_reduction : unit -> bool
+val set_refolding_in_reduction : bool -> unit
+
(** {6 Machinery about a stack of unfolded constant }
cst applied to params must convertible to term of the state applied to args
@@ -109,7 +113,7 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr
type reduction_function = contextual_reduction_function
type local_reduction_function = evar_map -> constr -> constr
-type e_reduction_function = env -> evar_map -> constr -> evar_map * constr
+type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma }
type contextual_stack_reduction_function =
env -> evar_map -> constr -> constr * constr list
@@ -135,21 +139,21 @@ val stack_reduction_of_reduction :
i*)
val stacklam : (state -> 'a) -> constr list -> constr -> constr Stack.t -> 'a
-val whd_state_gen : ?csts:Cst_stack.t -> bool -> Closure.RedFlags.reds ->
- Environ.env -> Evd.evar_map -> state -> state * Cst_stack.t
+val whd_state_gen : ?csts:Cst_stack.t -> refold:bool -> tactic_mode:bool ->
+ CClosure.RedFlags.reds -> Environ.env -> Evd.evar_map -> state -> state * Cst_stack.t
-val iterate_whd_gen : bool -> Closure.RedFlags.reds ->
+val iterate_whd_gen : bool -> CClosure.RedFlags.reds ->
Environ.env -> Evd.evar_map -> Term.constr -> Term.constr
(** {6 Generic Optimized Reduction Function using Closures } *)
-val clos_norm_flags : Closure.RedFlags.reds -> reduction_function
+val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function
(** Same as [(strong whd_beta[delta][iota])], but much faster on big terms *)
val nf_beta : local_reduction_function
val nf_betaiota : local_reduction_function
val nf_betaiotazeta : local_reduction_function
-val nf_betadeltaiota : reduction_function
+val nf_all : reduction_function
val nf_evar : evar_map -> constr -> constr
(** Lazy strategy, weak head reduction *)
@@ -159,9 +163,8 @@ val whd_nored : local_reduction_function
val whd_beta : local_reduction_function
val whd_betaiota : local_reduction_function
val whd_betaiotazeta : local_reduction_function
-val whd_betadeltaiota : contextual_reduction_function
-val whd_betadeltaiota_nolet : contextual_reduction_function
-val whd_betaetalet : local_reduction_function
+val whd_all : contextual_reduction_function
+val whd_allnolet : contextual_reduction_function
val whd_betalet : local_reduction_function
(** Removes cast and put into applicative form *)
@@ -169,18 +172,16 @@ val whd_nored_stack : local_stack_reduction_function
val whd_beta_stack : local_stack_reduction_function
val whd_betaiota_stack : local_stack_reduction_function
val whd_betaiotazeta_stack : local_stack_reduction_function
-val whd_betadeltaiota_stack : contextual_stack_reduction_function
-val whd_betadeltaiota_nolet_stack : contextual_stack_reduction_function
-val whd_betaetalet_stack : local_stack_reduction_function
+val whd_all_stack : contextual_stack_reduction_function
+val whd_allnolet_stack : contextual_stack_reduction_function
val whd_betalet_stack : local_stack_reduction_function
val whd_nored_state : local_state_reduction_function
val whd_beta_state : local_state_reduction_function
val whd_betaiota_state : local_state_reduction_function
val whd_betaiotazeta_state : local_state_reduction_function
-val whd_betadeltaiota_state : contextual_state_reduction_function
-val whd_betadeltaiota_nolet_state : contextual_state_reduction_function
-val whd_betaetalet_state : local_state_reduction_function
+val whd_all_state : contextual_state_reduction_function
+val whd_allnolet_state : contextual_state_reduction_function
val whd_betalet_state : local_state_reduction_function
(** {6 Head normal forms } *)
@@ -188,18 +189,14 @@ val whd_betalet_state : local_state_reduction_function
val whd_delta_stack : stack_reduction_function
val whd_delta_state : state_reduction_function
val whd_delta : reduction_function
-val whd_betadelta_stack : stack_reduction_function
-val whd_betadelta_state : state_reduction_function
-val whd_betadelta : reduction_function
-val whd_betadeltaeta_stack : stack_reduction_function
-val whd_betadeltaeta_state : state_reduction_function
-val whd_betadeltaeta : reduction_function
-val whd_betadeltaiotaeta_stack : stack_reduction_function
-val whd_betadeltaiotaeta_state : state_reduction_function
-val whd_betadeltaiotaeta : reduction_function
-
-val whd_eta : constr -> constr
-val whd_zeta : constr -> constr
+val whd_betadeltazeta_stack : stack_reduction_function
+val whd_betadeltazeta_state : state_reduction_function
+val whd_betadeltazeta : reduction_function
+val whd_zeta_stack : local_stack_reduction_function
+val whd_zeta_state : local_state_reduction_function
+val whd_zeta : local_reduction_function
+
+val shrink_eta : constr -> constr
(** Various reduction functions *)
@@ -218,11 +215,10 @@ val splay_prod : env -> evar_map -> constr -> (Name.t * constr) list * constr
val splay_lam : env -> evar_map -> constr -> (Name.t * constr) list * constr
val splay_arity : env -> evar_map -> constr -> (Name.t * constr) list * sorts
val sort_of_arity : env -> evar_map -> constr -> sorts
-val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr
-val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr
+val splay_prod_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr
+val splay_lam_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr
val splay_prod_assum :
- env -> evar_map -> constr -> rel_context * constr
-val is_sort : env -> evar_map -> types -> bool
+ env -> evar_map -> constr -> Context.Rel.t * constr
type 'a miota_args = {
mP : constr; (** the result type *)
@@ -251,13 +247,9 @@ type conversion_test = constraints -> constraints
val pb_is_equal : conv_pb -> bool
val pb_equal : conv_pb -> conv_pb
-val is_conv : env -> evar_map -> constr -> constr -> bool
-val is_conv_leq : env -> evar_map -> constr -> constr -> bool
-val is_fconv : conv_pb -> env -> evar_map -> constr -> constr -> bool
-
-val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr -> bool
-val is_trans_conv_leq : transparent_state -> env -> evar_map -> constr -> constr -> bool
-val is_trans_fconv : conv_pb -> transparent_state -> env -> evar_map -> constr -> constr -> bool
+val is_conv : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool
+val is_conv_leq : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool
+val is_fconv : ?reds:transparent_state -> conv_pb -> env -> evar_map -> constr -> constr -> bool
(** [check_conv] Checks universe constraints only.
pb defaults to CUMUL and ts to a full transparent state.
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index cb4e588e..98b36fb9 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Term
open Vars
@@ -18,6 +18,7 @@ open Reductionops
open Environ
open Termops
open Arguments_renaming
+open Context.Rel.Declaration
type retype_error =
| NotASort
@@ -61,7 +62,7 @@ let get_type_from_constraints env sigma t =
let rec subst_type env sigma typ = function
| [] -> typ
| h::rest ->
- match kind_of_term (whd_betadeltaiota env sigma typ) with
+ match kind_of_term (whd_all env sigma typ) with
| Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest
| _ -> retype_error NonFunctionalConstruction
@@ -70,29 +71,30 @@ let rec subst_type env sigma typ = function
let sort_of_atomic_type env sigma ft args =
let rec concl_of_arity env n ar args =
- match kind_of_term (whd_betadeltaiota env sigma ar), args with
- | Prod (na, t, b), h::l -> concl_of_arity (push_rel (na,Some (lift n h),t) env) (n + 1) b l
+ match kind_of_term (whd_all env sigma ar), args with
+ | Prod (na, t, b), h::l -> concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l
| Sort s, [] -> s
| _ -> retype_error NotASort
in concl_of_arity env 0 ft (Array.to_list args)
let type_of_var env id =
- try let (_,_,ty) = lookup_named id env in ty
+ let open Context.Named.Declaration in
+ try get_type (lookup_named id env)
with Not_found -> retype_error (BadVariable id)
let decomp_sort env sigma t =
- match kind_of_term (whd_betadeltaiota env sigma t) with
+ match kind_of_term (whd_all env sigma t) with
| Sort s -> s
| _ -> retype_error NotASort
let retype ?(polyprop=true) sigma =
- let rec type_of env cstr=
+ let rec type_of env cstr =
match kind_of_term cstr with
| Meta n ->
(try strip_outer_cast (Evd.meta_ftype sigma n).Evd.rebus
with Not_found -> retype_error (BadMeta n))
| Rel n ->
- let (_,_,ty) = lookup_rel n env in
+ let ty = get_type (lookup_rel n env) in
lift n ty
| Var id -> type_of_var env id
| Const cst -> rename_type_of_constant env cst
@@ -111,13 +113,13 @@ let retype ?(polyprop=true) sigma =
in
let n = inductive_nrealdecls_env env (fst (fst (dest_ind_family indf))) in
let t = betazetaevar_applist sigma n p realargs in
- (match kind_of_term (whd_betadeltaiota env sigma (type_of env t)) with
+ (match kind_of_term (whd_all env sigma (type_of env t)) with
| Prod _ -> whd_beta sigma (applist (t, [c]))
| _ -> t)
| Lambda (name,c1,c2) ->
- mkProd (name, c1, type_of (push_rel (name,None,c1) env) c2)
+ mkProd (name, c1, type_of (push_rel (LocalAssum (name,c1)) env) c2)
| LetIn (name,b,c1,c2) ->
- subst1 b (type_of (push_rel (name,Some b,c1) env) c2)
+ subst1 b (type_of (push_rel (LocalDef (name,b,c1)) env) c2)
| Fix ((_,i),(_,tys,_)) -> tys.(i)
| CoFix (i,(_,tys,_)) -> tys.(i)
| App(f,args) when is_template_polymorphic env f ->
@@ -140,7 +142,7 @@ let retype ?(polyprop=true) sigma =
| Sort (Prop c) -> type1_sort
| Sort (Type u) -> Type (Univ.super u)
| Prod (name,t,c2) ->
- (match (sort_of env t, sort_of (push_rel (name,None,t) env) c2) with
+ (match (sort_of env t, sort_of (push_rel (LocalAssum (name,t)) env) c2) with
| _, (Prop Null as s) -> s
| Prop _, (Prop Pos as s) -> s
| Type _, (Prop Pos as s) when is_impredicative_set env -> s
@@ -161,7 +163,7 @@ let retype ?(polyprop=true) sigma =
| Sort (Prop c) -> InType
| Sort (Type u) -> InType
| Prod (name,t,c2) ->
- let s2 = sort_family_of (push_rel (name,None,t) env) c2 in
+ let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in
if not (is_impredicative_set env) &&
s2 == InSet && sort_family_of env t == InType then InType else s2
| App(f,args) when is_template_polymorphic env f ->
@@ -235,9 +237,9 @@ let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c }
let sorts_of_context env evc ctxt =
let rec aux = function
| [] -> env,[]
- | (_,_,t as d)::ctxt ->
+ | d :: ctxt ->
let env,sorts = aux ctxt in
- let s = get_sort_of env evc t in
+ let s = get_sort_of env evc (get_type d) in
(push_rel d env,s::sorts) in
snd (aux ctxt)
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
index 37cec0c6..8ca40f82 100644
--- a/pretyping/retyping.mli
+++ b/pretyping/retyping.mli
@@ -8,7 +8,6 @@
open Term
open Evd
-open Context
open Environ
(** This family of functions assumes its constr argument is known to be
@@ -44,6 +43,8 @@ val type_of_global_reference_knowing_parameters : env -> evar_map -> constr ->
val type_of_global_reference_knowing_conclusion :
env -> evar_map -> constr -> types -> evar_map * types
-val sorts_of_context : env -> evar_map -> rel_context -> sorts list
+val sorts_of_context : env -> evar_map -> Context.Rel.t -> sorts list
val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr
+
+val print_retype_error : retype_error -> Pp.std_ppcmds
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 7c4f28ca..820a81b5 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -18,11 +18,12 @@ open Termops
open Find_subterm
open Namegen
open Environ
-open Closure
+open CClosure
open Reductionops
open Cbv
open Patternops
open Locus
+open Sigma.Notations
(* Errors *)
@@ -53,12 +54,13 @@ let is_evaluable env = function
| EvalVarRef id -> is_evaluable_var env id
let value_of_evaluable_ref env evref u =
+ let open Context.Named.Declaration in
match evref with
| EvalConstRef con ->
(try constant_value_in env (con,u)
with NotEvaluableConst IsProj ->
raise (Invalid_argument "value_of_evaluable_ref"))
- | EvalVarRef id -> Option.get (pi2 (lookup_named id env))
+ | EvalVarRef id -> lookup_named id env |> get_value |> Option.get
let evaluable_of_global_reference env = function
| ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst
@@ -103,29 +105,29 @@ let destEvalRefU c = match kind_of_term c with
| Evar ev -> (EvalEvar ev, Univ.Instance.empty)
| _ -> anomaly (Pp.str "Not an unfoldable reference")
-let unsafe_reference_opt_value env sigma eval =
+let unsafe_reference_opt_value env sigma eval =
match eval with
| EvalConst cst ->
(match (lookup_constant cst env).Declarations.const_body with
| Declarations.Def c -> Some (Mod_subst.force_constr c)
| _ -> None)
| EvalVar id ->
- let (_,v,_) = lookup_named id env in
- v
+ let open Context.Named.Declaration in
+ lookup_named id env |> get_value
| EvalRel n ->
- let (_,v,_) = lookup_rel n env in
- Option.map (lift n) v
+ let open Context.Rel.Declaration in
+ lookup_rel n env |> map_value (lift n) |> get_value
| EvalEvar ev -> Evd.existential_opt_value sigma ev
let reference_opt_value env sigma eval u =
match eval with
| EvalConst cst -> constant_opt_value_in env (cst,u)
| EvalVar id ->
- let (_,v,_) = lookup_named id env in
- v
+ let open Context.Named.Declaration in
+ lookup_named id env |> get_value
| EvalRel n ->
- let (_,v,_) = lookup_rel n env in
- Option.map (lift n) v
+ let open Context.Rel.Declaration in
+ lookup_rel n env |> map_value (lift n) |> get_value
| EvalEvar ev -> Evd.existential_opt_value sigma ev
exception NotEvaluable
@@ -255,10 +257,11 @@ let invert_name labs l na0 env sigma ref = function
let compute_consteval_direct env sigma ref =
let rec srec env n labs onlyproj c =
- let c',l = whd_betadelta_stack env sigma c in
+ let c',l = whd_betadeltazeta_stack env sigma c in
match kind_of_term c' with
| Lambda (id,t,g) when List.is_empty l && not onlyproj ->
- srec (push_rel (id,None,t) env) (n+1) (t::labs) onlyproj g
+ let open Context.Rel.Declaration in
+ srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g
| Fix fix when not onlyproj ->
(try check_fix_reversibility labs l fix
with Elimconst -> NotAnElimination)
@@ -277,7 +280,8 @@ let compute_consteval_mutual_fix env sigma ref =
let nargs = List.length l in
match kind_of_term c' with
| Lambda (na,t,g) when List.is_empty l ->
- srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g
+ let open Context.Rel.Declaration in
+ srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g
| Fix ((lv,i),(names,_,_)) ->
(* Last known constant wrapping Fix is ref = [labs](Fix l) *)
(match compute_consteval_direct env sigma ref with
@@ -371,7 +375,8 @@ let make_elim_fun (names,(nbfix,lv,n)) u largs =
let dummy = mkProp
let vfx = Id.of_string "_expanded_fix_"
let vfun = Id.of_string "_eliminator_function_"
-let venv = val_of_named_context [(vfx, None, dummy); (vfun, None, dummy)]
+let venv = let open Context.Named.Declaration in
+ val_of_named_context [LocalAssum (vfx, dummy); LocalAssum (vfun, dummy)]
(* Mark every occurrence of substituted vars (associated to a function)
as a problem variable: an evar that can be instantiated either by
@@ -385,7 +390,9 @@ let substl_with_function subst sigma constr =
if i <= k + Array.length v then
match v.(i-k-1) with
| (fx, Some (min, ref)) ->
- let (sigma, evk) = Evarutil.new_pure_evar venv !evd dummy in
+ let sigma = Sigma.Unsafe.of_evar_map !evd in
+ let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma dummy in
+ let sigma = Sigma.to_evar_map sigma in
evd := sigma;
minargs := Evar.Map.add evk min !minargs;
lift k (mkEvar (evk, [|fx;ref|]))
@@ -534,9 +541,11 @@ let match_eval_ref_value env sigma constr =
| Const (sp, u) when is_evaluable env (EvalConstRef sp) ->
Some (constant_value_in env (sp, u))
| Var id when is_evaluable env (EvalVarRef id) ->
- let (_,v,_) = lookup_named id env in v
- | Rel n -> let (_,v,_) = lookup_rel n env in
- Option.map (lift n) v
+ let open Context.Named.Declaration in
+ lookup_named id env |> get_value
+ | Rel n ->
+ let open Context.Rel.Declaration in
+ lookup_rel n env |> map_value (lift n) |> get_value
| Evar ev -> Evd.existential_opt_value sigma ev
| _ -> None
@@ -601,12 +610,14 @@ let whd_nothing_for_iota env sigma s =
let rec whrec (x, stack as s) =
match kind_of_term x with
| Rel n ->
+ let open Context.Rel.Declaration in
(match lookup_rel n env with
- | (_,Some body,_) -> whrec (lift n body, stack)
+ | LocalDef (_,body,_) -> whrec (lift n body, stack)
| _ -> s)
| Var id ->
+ let open Context.Named.Declaration in
(match lookup_named id env with
- | (_,Some body,_) -> whrec (body, stack)
+ | LocalDef (_,body,_) -> whrec (body, stack)
| _ -> s)
| Evar ev ->
(try whrec (Evd.existential_value sigma ev, stack)
@@ -809,7 +820,9 @@ let try_red_product env sigma c =
simpfun (Stack.zip (f,stack')))
| _ -> simpfun (appvect (redrec env f, l)))
| Cast (c,_,_) -> redrec env c
- | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b)
+ | Prod (x,a,b) ->
+ let open Context.Rel.Declaration in
+ mkProd (x, a, redrec (push_rel (LocalAssum (x,a)) env) b)
| LetIn (x,a,b,t) -> redrec env (subst1 a t)
| Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf))
| Proj (p, c) ->
@@ -857,7 +870,7 @@ let red_product env sigma c =
*)
let whd_simpl_orelse_delta_but_fix_old env sigma c =
- let whd_all = whd_betadeltaiota_state env sigma in
+ let whd_all = whd_all_state env sigma in
let rec redrec (x, stack as s) =
match kind_of_term x with
| Lambda (na,t,c) ->
@@ -940,8 +953,6 @@ let matches_head env sigma c t =
| Proj (p, _) -> Constr_matching.matches env sigma c (mkConst (Projection.constant p))
| _ -> raise Constr_matching.PatternMatchingFailure
-let is_pattern_meta = function Pattern.PMeta _ -> true | _ -> false
-
(** FIXME: Specific function to handle projections: it ignores what happens on the
parameters. This is a temporary fix while rewrite etc... are not up to equivalence
of the projection and its eta expanded form.
@@ -962,10 +973,12 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c =
| _ -> mkApp (app', [| a' |]))
| _ -> map_constr_with_binders_left_to_right g f acc c
-let e_contextually byhead (occs,c) f env sigma t =
+let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t ->
let (nowhere_except_in,locs) = Locusops.convert_occs occs in
let maxocc = List.fold_right max locs 0 in
let pos = ref 1 in
+ let sigma = Sigma.to_evar_map sigma in
+ (** FIXME: we do suspicious things with this evarmap *)
let evd = ref sigma in
let rec traverse nested (env,c as envc) t =
if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t
@@ -984,8 +997,8 @@ let e_contextually byhead (occs,c) f env sigma t =
(* Skip inner occurrences for stable counting of occurrences *)
if locs != [] then
ignore (traverse_below (Some (!pos-1)) envc t);
- let evm, t = f subst env !evd t in
- (evd := evm; t)
+ let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) t in
+ (evd := Sigma.to_evar_map evm; t)
end
else
traverse_below nested envc t
@@ -1004,11 +1017,15 @@ let e_contextually byhead (occs,c) f env sigma t =
in
let t' = traverse None (env,c) t in
if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs;
- !evd, t'
+ Sigma.Unsafe.of_pair (t', !evd)
+ end }
let contextually byhead occs f env sigma t =
- let f' subst env sigma t = sigma, f subst env sigma t in
- snd (e_contextually byhead occs f' env sigma t)
+ let f' subst = { e_redfun = begin fun env sigma t ->
+ Sigma.here (f subst env (Sigma.to_evar_map sigma) t) sigma
+ end } in
+ let Sigma (c, _, _) = (e_contextually byhead occs f').e_redfun env (Sigma.Unsafe.of_evar_map sigma) t in
+ c
(* linear bindings (following pretty-printer) of the value of name in c.
* n is the number of the next occurrence of name.
@@ -1055,10 +1072,6 @@ let unfold env sigma name =
else
error (string_of_evaluable_ref env name^" is opaque.")
-let is_projection env = function
- | EvalVarRef _ -> false
- | EvalConstRef c -> Environ.is_projection c env
-
(* [unfoldoccs : (readable_constraints -> (int list * full_path) -> constr -> constr)]
* Unfolds the constant name in a term c following a list of occurrences occl.
* at the occurrences of occ_list. If occ_list is empty, unfold all occurrences.
@@ -1112,7 +1125,7 @@ let cbv_norm_flags flags env sigma t =
let cbv_beta = cbv_norm_flags beta empty_env
let cbv_betaiota = cbv_norm_flags betaiota empty_env
-let cbv_betadeltaiota env sigma = cbv_norm_flags betadeltaiota env sigma
+let cbv_betadeltaiota env sigma = cbv_norm_flags all env sigma
let compute = cbv_betadeltaiota
@@ -1131,13 +1144,15 @@ let abstract_scheme env (locc,a) (c, sigma) =
let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in
mkLambda (na,ta,c'), sigma'
-let pattern_occs loccs_trm env sigma c =
+let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c ->
+ let sigma = Sigma.to_evar_map sigma in
let abstr_trm, sigma = List.fold_right (abstract_scheme env) loccs_trm (c,sigma) in
try
let _ = Typing.unsafe_type_of env sigma abstr_trm in
- sigma, applist(abstr_trm, List.map snd loccs_trm)
+ Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma)
with Type_errors.TypeError (env',t) ->
raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t))))
+ end }
(* Used in several tactics. *)
@@ -1163,14 +1178,15 @@ let reduce_to_ind_gen allow_product env sigma t =
match kind_of_term (fst (decompose_app t)) with
| Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l)
| Prod (n,ty,t') ->
+ let open Context.Rel.Declaration in
if allow_product then
- elimrec (push_rel (n,None,ty) env) t' ((n,None,ty)::l)
+ elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l)
else
errorlabstrm "" (str"Not an inductive definition.")
| _ ->
(* Last chance: we allow to bypass the Opaque flag (as it
was partially the case between V5.10 and V8.1 *)
- let t' = whd_betadeltaiota env sigma t in
+ let t' = whd_all env sigma t in
match kind_of_term (fst (decompose_app t')) with
| Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l)
| _ -> errorlabstrm "" (str"Not an inductive product.")
@@ -1241,7 +1257,8 @@ let reduce_to_ref_gen allow_product env sigma ref t =
match kind_of_term c with
| Prod (n,ty,t') ->
if allow_product then
- elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l)
+ let open Context.Rel.Declaration in
+ elimrec (push_rel (LocalAssum (n,t)) env) t' ((LocalAssum (n,ty))::l)
else
error_cannot_recognize ref
| _ ->
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
index 6a7248e1..f8dfe1ad 100644
--- a/pretyping/tacred.mli
+++ b/pretyping/tacred.mli
@@ -61,13 +61,12 @@ val unfoldn :
val fold_commands : constr list -> reduction_function
(** Pattern *)
-val pattern_occs : (occurrences * constr) list -> env -> evar_map -> constr ->
- evar_map * constr
+val pattern_occs : (occurrences * constr) list -> e_reduction_function
(** Rem: Lazy strategies are defined in Reduction *)
(** Call by value strategy (uses Closures) *)
-val cbv_norm_flags : Closure.RedFlags.reds -> reduction_function
+val cbv_norm_flags : CClosure.RedFlags.reds -> reduction_function
val cbv_beta : local_reduction_function
val cbv_betaiota : local_reduction_function
val cbv_betadeltaiota : reduction_function
diff --git a/pretyping/termops.ml b/pretyping/termops.ml
deleted file mode 100644
index 9d469cb7..00000000
--- a/pretyping/termops.ml
+++ /dev/null
@@ -1,1026 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* (str "Set")
- | Prop Null -> (str "Prop")
- | Type u -> (str "Type(" ++ Univ.Universe.pr u ++ str ")")
-
-let pr_sort_family = function
- | InSet -> (str "Set")
- | InProp -> (str "Prop")
- | InType -> (str "Type")
-
-let pr_name = function
- | Name id -> pr_id id
- | Anonymous -> str "_"
-
-let pr_con sp = str(string_of_con sp)
-
-let pr_fix pr_constr ((t,i),(lna,tl,bl)) =
- let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in
- hov 1
- (str"fix " ++ int i ++ spc() ++ str"{" ++
- v 0 (prlist_with_sep spc (fun (na,i,ty,bd) ->
- pr_name na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++
- cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++
- str"}")
-
-let pr_puniverses p u =
- if Univ.Instance.is_empty u then p
- else p ++ str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)"
-
-let rec pr_constr c = match kind_of_term c with
- | Rel n -> str "#"++int n
- | Meta n -> str "Meta(" ++ int n ++ str ")"
- | Var id -> pr_id id
- | Sort s -> print_sort s
- | Cast (c,_, t) -> hov 1
- (str"(" ++ pr_constr c ++ cut() ++
- str":" ++ pr_constr t ++ str")")
- | Prod (Name(id),t,c) -> hov 1
- (str"forall " ++ pr_id id ++ str":" ++ pr_constr t ++ str"," ++
- spc() ++ pr_constr c)
- | Prod (Anonymous,t,c) -> hov 0
- (str"(" ++ pr_constr t ++ str " ->" ++ spc() ++
- pr_constr c ++ str")")
- | Lambda (na,t,c) -> hov 1
- (str"fun " ++ pr_name na ++ str":" ++
- pr_constr t ++ str" =>" ++ spc() ++ pr_constr c)
- | LetIn (na,b,t,c) -> hov 0
- (str"let " ++ pr_name na ++ str":=" ++ pr_constr b ++
- str":" ++ brk(1,2) ++ pr_constr t ++ cut() ++
- pr_constr c)
- | App (c,l) -> hov 1
- (str"(" ++ pr_constr c ++ spc() ++
- prlist_with_sep spc pr_constr (Array.to_list l) ++ str")")
- | Evar (e,l) -> hov 1
- (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++
- prlist_with_sep spc pr_constr (Array.to_list l) ++str"}")
- | Const (c,u) -> str"Cst(" ++ pr_puniverses (pr_con c) u ++ str")"
- | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i) u ++ str")"
- | Construct (((sp,i),j),u) ->
- str"Constr(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")"
- | Proj (p,c) -> str"Proj(" ++ pr_con (Projection.constant p) ++ str"," ++ bool (Projection.unfolded p) ++ pr_constr c ++ str")"
- | Case (ci,p,c,bl) -> v 0
- (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++
- pr_constr c ++ str"of") ++ cut() ++
- prlist_with_sep (fun _ -> brk(1,2)) pr_constr (Array.to_list bl) ++
- cut() ++ str"end")
- | Fix f -> pr_fix pr_constr f
- | CoFix(i,(lna,tl,bl)) ->
- let fixl = Array.mapi (fun i na -> (na,tl.(i),bl.(i))) lna in
- hov 1
- (str"cofix " ++ int i ++ spc() ++ str"{" ++
- v 0 (prlist_with_sep spc (fun (na,ty,bd) ->
- pr_name na ++ str":" ++ pr_constr ty ++
- cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++
- str"}")
-
-let term_printer = ref (fun _ -> pr_constr)
-let print_constr_env t = !term_printer t
-let print_constr t = !term_printer (Global.env()) t
-let set_print_constr f = term_printer := f
-
-let pr_var_decl env (id,c,typ) =
- let pbody = match c with
- | None -> (mt ())
- | Some c ->
- (* Force evaluation *)
- let pb = print_constr_env env c in
- (str" := " ++ pb ++ cut () ) in
- let pt = print_constr_env env typ in
- let ptyp = (str" : " ++ pt) in
- (pr_id id ++ hov 0 (pbody ++ ptyp))
-
-let pr_rel_decl env (na,c,typ) =
- let pbody = match c with
- | None -> mt ()
- | Some c ->
- (* Force evaluation *)
- let pb = print_constr_env env c in
- (str":=" ++ spc () ++ pb ++ spc ()) in
- let ptyp = print_constr_env env typ in
- match na with
- | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
- | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
-
-let print_named_context env =
- hv 0 (fold_named_context
- (fun env d pps ->
- pps ++ ws 2 ++ pr_var_decl env d)
- env ~init:(mt ()))
-
-let print_rel_context env =
- hv 0 (fold_rel_context
- (fun env d pps -> pps ++ ws 2 ++ pr_rel_decl env d)
- env ~init:(mt ()))
-
-let print_env env =
- let sign_env =
- fold_named_context
- (fun env d pps ->
- let pidt = pr_var_decl env d in
- (pps ++ fnl () ++ pidt))
- env ~init:(mt ())
- in
- let db_env =
- fold_rel_context
- (fun env d pps ->
- let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat))
- env ~init:(mt ())
- in
- (sign_env ++ db_env)
-
-(* [Rel (n+m);...;Rel(n+1)] *)
-let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i))
-
-let rel_list n m =
- let rec reln l p =
- if p>m then l else reln (mkRel(n+p)::l) (p+1)
- in
- reln [] 1
-
-(* Same as [rel_list] but takes a context as argument and skips let-ins *)
-let extended_rel_list n hyps =
- let rec reln l p = function
- | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps
- | (_,Some _,_) :: hyps -> reln l (p+1) hyps
- | [] -> l
- in
- reln [] 1 hyps
-
-let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps)
-
-
-
-let push_rel_assum (x,t) env = push_rel (x,None,t) env
-
-let push_rels_assum assums =
- push_rel_context (List.map (fun (x,t) -> (x,None,t)) assums)
-
-let push_named_rec_types (lna,typarray,_) env =
- let ctxt =
- Array.map2_i
- (fun i na t ->
- match na with
- | Name id -> (id, None, lift i t)
- | Anonymous -> anomaly (Pp.str "Fix declarations must be named"))
- lna typarray in
- Array.fold_left
- (fun e assum -> push_named assum e) env ctxt
-
-let lookup_rel_id id sign =
- let rec lookrec n = function
- | [] -> raise Not_found
- | (Anonymous, _, _) :: l -> lookrec (n + 1) l
- | (Name id', b, t) :: l ->
- if Names.Id.equal id' id then (n, b, t) else lookrec (n + 1) l
- in
- lookrec 1 sign
-
-(* Constructs either [forall x:t, c] or [let x:=b:t in c] *)
-let mkProd_or_LetIn (na,body,t) c =
- match body with
- | None -> mkProd (na, t, c)
- | Some b -> mkLetIn (na, b, t, c)
-
-(* Constructs either [forall x:t, c] or [c] in which [x] is replaced by [b] *)
-let mkProd_wo_LetIn (na,body,t) c =
- match body with
- | None -> mkProd (na, t, c)
- | Some b -> subst1 b c
-
-let it_mkProd init = List.fold_left (fun c (n,t) -> mkProd (n, t, c)) init
-let it_mkLambda init = List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) init
-
-let it_named_context_quantifier f ~init =
- List.fold_left (fun c d -> f d c) init
-
-let it_mkProd_or_LetIn init = it_named_context_quantifier mkProd_or_LetIn ~init
-let it_mkProd_wo_LetIn init = it_named_context_quantifier mkProd_wo_LetIn ~init
-let it_mkLambda_or_LetIn init = it_named_context_quantifier mkLambda_or_LetIn ~init
-let it_mkNamedProd_or_LetIn init = it_named_context_quantifier mkNamedProd_or_LetIn ~init
-let it_mkNamedProd_wo_LetIn init = it_named_context_quantifier mkNamedProd_wo_LetIn ~init
-let it_mkNamedLambda_or_LetIn init = it_named_context_quantifier mkNamedLambda_or_LetIn ~init
-
-let it_mkLambda_or_LetIn_from_no_LetIn c decls =
- let rec aux k decls c = match decls with
- | [] -> c
- | (na,Some b,t)::decls -> mkLetIn (na,b,t,aux (k-1) decls (liftn 1 k c))
- | (na,None,t)::decls -> mkLambda (na,t,aux (k-1) decls c)
- in aux (List.length decls) (List.rev decls) c
-
-(* *)
-
-(* strips head casts and flattens head applications *)
-let rec strip_head_cast c = match kind_of_term c with
- | App (f,cl) ->
- let rec collapse_rec f cl2 = match kind_of_term f with
- | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
- | Cast (c,_,_) -> collapse_rec c cl2
- | _ -> if Int.equal (Array.length cl2) 0 then f else mkApp (f,cl2)
- in
- collapse_rec f cl
- | Cast (c,_,_) -> strip_head_cast c
- | _ -> c
-
-let rec drop_extra_implicit_args c = match kind_of_term c with
- (* Removed trailing extra implicit arguments, what improves compatibility
- for constants with recently added maximal implicit arguments *)
- | App (f,args) when isEvar (Array.last args) ->
- drop_extra_implicit_args
- (mkApp (f,fst (Array.chop (Array.length args - 1) args)))
- | _ -> c
-
-(* Get the last arg of an application *)
-let last_arg c = match kind_of_term c with
- | App (f,cl) -> Array.last cl
- | _ -> anomaly (Pp.str "last_arg")
-
-(* Get the last arg of an application *)
-let decompose_app_vect c =
- match kind_of_term c with
- | App (f,cl) -> (f, cl)
- | _ -> (c,[||])
-
-let adjust_app_list_size f1 l1 f2 l2 =
- let len1 = List.length l1 and len2 = List.length l2 in
- if Int.equal len1 len2 then (f1,l1,f2,l2)
- else if len1 < len2 then
- let extras,restl2 = List.chop (len2-len1) l2 in
- (f1, l1, applist (f2,extras), restl2)
- else
- let extras,restl1 = List.chop (len1-len2) l1 in
- (applist (f1,extras), restl1, f2, l2)
-
-let adjust_app_array_size f1 l1 f2 l2 =
- let len1 = Array.length l1 and len2 = Array.length l2 in
- if Int.equal len1 len2 then (f1,l1,f2,l2)
- else if len1 < len2 then
- let extras,restl2 = Array.chop (len2-len1) l2 in
- (f1, l1, appvect (f2,extras), restl2)
- else
- let extras,restl1 = Array.chop (len1-len2) l1 in
- (appvect (f1,extras), restl1, f2, l2)
-
-(* [map_constr_with_named_binders g f l c] maps [f l] on the immediate
- subterms of [c]; it carries an extra data [l] (typically a name
- list) which is processed by [g na] (which typically cons [na] to
- [l]) at each binder traversal (with name [na]); it is not recursive
- and the order with which subterms are processed is not specified *)
-
-let map_constr_with_named_binders g f l c = match kind_of_term c with
- | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
- | Construct _) -> c
- | Cast (c,k,t) -> mkCast (f l c, k, f l t)
- | Prod (na,t,c) -> mkProd (na, f l t, f (g na l) c)
- | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c)
- | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c)
- | App (c,al) -> mkApp (f l c, Array.map (f l) al)
- | Proj (p,c) -> mkProj (p, f l c)
- | Evar (e,al) -> mkEvar (e, Array.map (f l) al)
- | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl)
- | Fix (ln,(lna,tl,bl)) ->
- let l' = Array.fold_left (fun l na -> g na l) l lna in
- mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
- | CoFix(ln,(lna,tl,bl)) ->
- let l' = Array.fold_left (fun l na -> g na l) l lna in
- mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
-
-(* [map_constr_with_binders_left_to_right g f n c] maps [f n] on the
- immediate subterms of [c]; it carries an extra data [n] (typically
- a lift index) which is processed by [g] (which typically add 1 to
- [n]) at each binder traversal; the subterms are processed from left
- to right according to the usual representation of the constructions
- (this may matter if [f] does a side-effect); it is not recursive;
- in fact, the usual representation of the constructions is at the
- time being almost those of the ML representation (except for
- (co-)fixpoint) *)
-
-let fold_rec_types g (lna,typarray,_) e =
- let ctxt = Array.map2_i (fun i na t -> (na, None, lift i t)) lna typarray in
- Array.fold_left (fun e assum -> g assum e) e ctxt
-
-let map_left2 f a g b =
- let l = Array.length a in
- if Int.equal l 0 then [||], [||] else begin
- let r = Array.make l (f a.(0)) in
- let s = Array.make l (g b.(0)) in
- for i = 1 to l - 1 do
- r.(i) <- f a.(i);
- s.(i) <- g b.(i)
- done;
- r, s
- end
-
-let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
- | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
- | Construct _) -> c
- | Cast (b,k,t) ->
- let b' = f l b in
- let t' = f l t in
- if b' == b && t' == t then c
- else mkCast (b',k,t')
- | Prod (na,t,b) ->
- let t' = f l t in
- let b' = f (g (na,None,t) l) b in
- if t' == t && b' == b then c
- else mkProd (na, t', b')
- | Lambda (na,t,b) ->
- let t' = f l t in
- let b' = f (g (na,None,t) l) b in
- if t' == t && b' == b then c
- else mkLambda (na, t', b')
- | LetIn (na,bo,t,b) ->
- let bo' = f l bo in
- let t' = f l t in
- let b' = f (g (na,Some bo,t) l) b in
- if bo' == bo && t' == t && b' == b then c
- else mkLetIn (na, bo', t', b')
- | App (c,[||]) -> assert false
- | App (t,al) ->
- (*Special treatment to be able to recognize partially applied subterms*)
- let a = al.(Array.length al - 1) in
- let app = (mkApp (t, Array.sub al 0 (Array.length al - 1))) in
- let app' = f l app in
- let a' = f l a in
- if app' == app && a' == a then c
- else mkApp (app', [| a' |])
- | Proj (p,b) ->
- let b' = f l b in
- if b' == b then c
- else mkProj (p, b')
- | Evar (e,al) ->
- let al' = Array.map_left (f l) al in
- if Array.for_all2 (==) al' al then c
- else mkEvar (e, al')
- | Case (ci,p,b,bl) ->
- (* In v8 concrete syntax, predicate is after the term to match! *)
- let b' = f l b in
- let p' = f l p in
- let bl' = Array.map_left (f l) bl in
- if b' == b && p' == p && bl' == bl then c
- else mkCase (ci, p', b', bl')
- | Fix (ln,(lna,tl,bl as fx)) ->
- let l' = fold_rec_types g fx l in
- let (tl', bl') = map_left2 (f l) tl (f l') bl in
- if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl'
- then c
- else mkFix (ln,(lna,tl',bl'))
- | CoFix(ln,(lna,tl,bl as fx)) ->
- let l' = fold_rec_types g fx l in
- let (tl', bl') = map_left2 (f l) tl (f l') bl in
- if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl'
- then c
- else mkCoFix (ln,(lna,tl',bl'))
-
-(* strong *)
-let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
- | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
- | Construct _) -> cstr
- | Cast (c,k, t) ->
- let c' = f l c in
- let t' = f l t in
- if c==c' && t==t' then cstr else mkCast (c', k, t')
- | Prod (na,t,c) ->
- let t' = f l t in
- let c' = f (g (na,None,t) l) c in
- if t==t' && c==c' then cstr else mkProd (na, t', c')
- | Lambda (na,t,c) ->
- let t' = f l t in
- let c' = f (g (na,None,t) l) c in
- if t==t' && c==c' then cstr else mkLambda (na, t', c')
- | LetIn (na,b,t,c) ->
- let b' = f l b in
- let t' = f l t in
- let c' = f (g (na,Some b,t) l) c in
- if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c')
- | App (c,al) ->
- let c' = f l c in
- let al' = Array.map (f l) al in
- if c==c' && Array.for_all2 (==) al al' then cstr else mkApp (c', al')
- | Proj (p,c) ->
- let c' = f l c in
- if c' == c then cstr else mkProj (p, c')
- | Evar (e,al) ->
- let al' = Array.map (f l) al in
- if Array.for_all2 (==) al al' then cstr else mkEvar (e, al')
- | Case (ci,p,c,bl) ->
- let p' = f l p in
- let c' = f l c in
- let bl' = Array.map (f l) bl in
- if p==p' && c==c' && Array.for_all2 (==) bl bl' then cstr else
- mkCase (ci, p', c', bl')
- | Fix (ln,(lna,tl,bl)) ->
- let tl' = Array.map (f l) tl in
- let l' =
- Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
- let bl' = Array.map (f l') bl in
- if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl'
- then cstr
- else mkFix (ln,(lna,tl',bl'))
- | CoFix(ln,(lna,tl,bl)) ->
- let tl' = Array.map (f l) tl in
- let l' =
- Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
- let bl' = Array.map (f l') bl in
- if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl'
- then cstr
- else mkCoFix (ln,(lna,tl',bl'))
-
-(* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate
- subterms of [c] starting from [acc] and proceeding from left to
- right according to the usual representation of the constructions as
- [fold_constr] but it carries an extra data [n] (typically a lift
- index) which is processed by [g] (which typically add 1 to [n]) at
- each binder traversal; it is not recursive *)
-
-let fold_constr_with_full_binders g f n acc c = match kind_of_term c with
- | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
- | Construct _) -> acc
- | Cast (c,_, t) -> f n (f n acc c) t
- | Prod (na,t,c) -> f (g (na,None,t) n) (f n acc t) c
- | Lambda (na,t,c) -> f (g (na,None,t) n) (f n acc t) c
- | LetIn (na,b,t,c) -> f (g (na,Some b,t) n) (f n (f n acc b) t) c
- | App (c,l) -> Array.fold_left (f n) (f n acc c) l
- | Proj (p,c) -> f n acc c
- | Evar (_,l) -> Array.fold_left (f n) acc l
- | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl
- | Fix (_,(lna,tl,bl)) ->
- let n' = CArray.fold_left2 (fun c n t -> g (n,None,t) c) n lna tl in
- let fd = Array.map2 (fun t b -> (t,b)) tl bl in
- Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd
- | CoFix (_,(lna,tl,bl)) ->
- let n' = CArray.fold_left2 (fun c n t -> g (n,None,t) c) n lna tl in
- let fd = Array.map2 (fun t b -> (t,b)) tl bl in
- Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd
-
-let fold_constr_with_binders g f n acc c =
- fold_constr_with_full_binders (fun _ x -> g x) f n acc c
-
-(* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate
- subterms of [c]; it carries an extra data [acc] which is processed by [g] at
- each binder traversal; it is not recursive and the order with which
- subterms are processed is not specified *)
-
-let iter_constr_with_full_binders g f l c = match kind_of_term c with
- | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
- | Construct _) -> ()
- | Cast (c,_, t) -> f l c; f l t
- | Prod (na,t,c) -> f l t; f (g (na,None,t) l) c
- | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c
- | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c
- | App (c,args) -> f l c; Array.iter (f l) args
- | Proj (p,c) -> f l c
- | Evar (_,args) -> Array.iter (f l) args
- | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl
- | Fix (_,(lna,tl,bl)) ->
- let l' = Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
- Array.iter (f l) tl;
- Array.iter (f l') bl
- | CoFix (_,(lna,tl,bl)) ->
- let l' = Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
- Array.iter (f l) tl;
- Array.iter (f l') bl
-
-(***************************)
-(* occurs check functions *)
-(***************************)
-
-exception Occur
-
-let occur_meta c =
- let rec occrec c = match kind_of_term c with
- | Meta _ -> raise Occur
- | _ -> iter_constr occrec c
- in try occrec c; false with Occur -> true
-
-let occur_existential c =
- let rec occrec c = match kind_of_term c with
- | Evar _ -> raise Occur
- | _ -> iter_constr occrec c
- in try occrec c; false with Occur -> true
-
-let occur_meta_or_existential c =
- let rec occrec c = match kind_of_term c with
- | Evar _ -> raise Occur
- | Meta _ -> raise Occur
- | _ -> iter_constr occrec c
- in try occrec c; false with Occur -> true
-
-let occur_evar n c =
- let rec occur_rec c = match kind_of_term c with
- | Evar (sp,_) when Evar.equal sp n -> raise Occur
- | _ -> iter_constr occur_rec c
- in
- try occur_rec c; false with Occur -> true
-
-let occur_in_global env id constr =
- let vars = vars_of_global env constr in
- if Id.Set.mem id vars then raise Occur
-
-let occur_var env id c =
- let rec occur_rec c =
- match kind_of_term c with
- | Var _ | Const _ | Ind _ | Construct _ -> occur_in_global env id c
- | _ -> iter_constr occur_rec c
- in
- try occur_rec c; false with Occur -> true
-
-let occur_var_in_decl env hyp (_,c,typ) =
- match c with
- | None -> occur_var env hyp typ
- | Some body ->
- occur_var env hyp typ ||
- occur_var env hyp body
-
-(* returns the list of free debruijn indices in a term *)
-
-let free_rels m =
- let rec frec depth acc c = match kind_of_term c with
- | Rel n -> if n >= depth then Int.Set.add (n-depth+1) acc else acc
- | _ -> fold_constr_with_binders succ frec depth acc c
- in
- frec 1 Int.Set.empty m
-
-(* collects all metavar occurrences, in left-to-right order, preserving
- * repetitions and all. *)
-
-let collect_metas c =
- let rec collrec acc c =
- match kind_of_term c with
- | Meta mv -> List.add_set Int.equal mv acc
- | _ -> fold_constr collrec acc c
- in
- List.rev (collrec [] c)
-
-(* collects all vars; warning: this is only visible vars, not dependencies in
- all section variables; for the latter, use global_vars_set *)
-let collect_vars c =
- let rec aux vars c = match kind_of_term c with
- | Var id -> Id.Set.add id vars
- | _ -> fold_constr aux vars c in
- aux Id.Set.empty c
-
-(* Tests whether [m] is a subterm of [t]:
- [m] is appropriately lifted through abstractions of [t] *)
-
-let dependent_main noevar univs m t =
- let eqc x y = if univs then fst (Universes.eq_constr_universes x y) else eq_constr_nounivs x y in
- let rec deprec m t =
- if eqc m t then
- raise Occur
- else
- match kind_of_term m, kind_of_term t with
- | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt ->
- deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm)));
- CArray.Fun1.iter deprec m
- (Array.sub lt
- (Array.length lm) ((Array.length lt) - (Array.length lm)))
- | _, Cast (c,_,_) when noevar && isMeta c -> ()
- | _, Evar _ when noevar -> ()
- | _ -> iter_constr_with_binders (fun c -> lift 1 c) deprec m t
- in
- try deprec m t; false with Occur -> true
-
-let dependent = dependent_main false false
-let dependent_no_evar = dependent_main true false
-
-let dependent_univs = dependent_main false true
-let dependent_univs_no_evar = dependent_main true true
-
-let dependent_in_decl a (_,c,t) =
- match c with
- | None -> dependent a t
- | Some body -> dependent a body || dependent a t
-
-let count_occurrences m t =
- let n = ref 0 in
- let rec countrec m t =
- if eq_constr m t then
- incr n
- else
- match kind_of_term m, kind_of_term t with
- | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt ->
- countrec m (mkApp (ft,Array.sub lt 0 (Array.length lm)));
- Array.iter (countrec m)
- (Array.sub lt
- (Array.length lm) ((Array.length lt) - (Array.length lm)))
- | _, Cast (c,_,_) when isMeta c -> ()
- | _, Evar _ -> ()
- | _ -> iter_constr_with_binders (lift 1) countrec m t
- in
- countrec m t;
- !n
-
-(* Synonymous *)
-let occur_term = dependent
-
-let pop t = lift (-1) t
-
-(***************************)
-(* bindings functions *)
-(***************************)
-
-type meta_type_map = (metavariable * types) list
-
-type meta_value_map = (metavariable * constr) list
-
-let rec subst_meta bl c =
- match kind_of_term c with
- | Meta i -> (try Int.List.assoc i bl with Not_found -> c)
- | _ -> map_constr (subst_meta bl) c
-
-(* First utilities for avoiding telescope computation for subst_term *)
-
-let prefix_application eq_fun (k,c) (t : constr) =
- let c' = collapse_appl c and t' = collapse_appl t in
- match kind_of_term c', kind_of_term t' with
- | App (f1,cl1), App (f2,cl2) ->
- let l1 = Array.length cl1
- and l2 = Array.length cl2 in
- if l1 <= l2
- && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then
- Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1)))
- else
- None
- | _ -> None
-
-let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) =
- let c' = collapse_appl c and t' = collapse_appl t in
- match kind_of_term c', kind_of_term t' with
- | App (f1,cl1), App (f2,cl2) ->
- let l1 = Array.length cl1
- and l2 = Array.length cl2 in
- if l1 <= l2
- && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then
- Some (mkApp ((lift k by_c), Array.sub cl2 l1 (l2 - l1)))
- else
- None
- | _ -> None
-
-(* Recognizing occurrences of a given subterm in a term: [subst_term c t]
- substitutes [(Rel 1)] for all occurrences of term [c] in a term [t];
- works if [c] has rels *)
-
-let subst_term_gen eq_fun c t =
- let rec substrec (k,c as kc) t =
- match prefix_application eq_fun kc t with
- | Some x -> x
- | None ->
- if eq_fun c t then mkRel k
- else
- map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) substrec kc t
- in
- substrec (1,c) t
-
-let subst_term = subst_term_gen eq_constr
-
-(* Recognizing occurrences of a given subterm in a term :
- [replace_term c1 c2 t] substitutes [c2] for all occurrences of
- term [c1] in a term [t]; works if [c1] and [c2] have rels *)
-
-let replace_term_gen eq_fun c by_c in_t =
- let rec substrec (k,c as kc) t =
- match my_prefix_application eq_fun kc by_c t with
- | Some x -> x
- | None ->
- (if eq_fun c t then (lift k by_c) else
- map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c))
- substrec kc t)
- in
- substrec (0,c) in_t
-
-let replace_term = replace_term_gen eq_constr
-
-let vars_of_env env =
- let s =
- Context.fold_named_context (fun (id,_,_) s -> Id.Set.add id s)
- (named_context env) ~init:Id.Set.empty in
- Context.fold_rel_context
- (fun (na,_,_) s -> match na with Name id -> Id.Set.add id s | _ -> s)
- (rel_context env) ~init:s
-
-let add_vname vars = function
- Name id -> Id.Set.add id vars
- | _ -> vars
-
-(*************************)
-(* Names environments *)
-(*************************)
-type names_context = Name.t list
-let add_name n nl = n::nl
-let lookup_name_of_rel p names =
- try List.nth names (p-1)
- with Invalid_argument _ | Failure _ -> raise Not_found
-let lookup_rel_of_name id names =
- let rec lookrec n = function
- | Anonymous :: l -> lookrec (n+1) l
- | (Name id') :: l -> if Id.equal id' id then n else lookrec (n+1) l
- | [] -> raise Not_found
- in
- lookrec 1 names
-let empty_names_context = []
-
-let ids_of_rel_context sign =
- Context.fold_rel_context
- (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l)
- sign ~init:[]
-
-let ids_of_named_context sign =
- Context.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[]
-
-let ids_of_context env =
- (ids_of_rel_context (rel_context env))
- @ (ids_of_named_context (named_context env))
-
-
-let names_of_rel_context env =
- List.map (fun (na,_,_) -> na) (rel_context env)
-
-let is_section_variable id =
- try let _ = Global.lookup_named id in true
- with Not_found -> false
-
-let isGlobalRef c =
- match kind_of_term c with
- | Const _ | Ind _ | Construct _ | Var _ -> true
- | _ -> false
-
-let is_template_polymorphic env f =
- match kind_of_term f with
- | Ind ind -> Environ.template_polymorphic_pind ind env
- | Const c -> Environ.template_polymorphic_pconstant c env
- | _ -> false
-
-let base_sort_cmp pb s0 s1 =
- match (s0,s1) with
- | (Prop c1, Prop c2) -> c1 == Null || c2 == Pos (* Prop <= Set *)
- | (Prop c1, Type u) -> pb == Reduction.CUMUL
- | (Type u1, Type u2) -> true
- | _ -> false
-
-(* eq_constr extended with universe erasure *)
-let compare_constr_univ f cv_pb t1 t2 =
- match kind_of_term t1, kind_of_term t2 with
- Sort s1, Sort s2 -> base_sort_cmp cv_pb s1 s2
- | Prod (_,t1,c1), Prod (_,t2,c2) ->
- f Reduction.CONV t1 t2 && f cv_pb c1 c2
- | _ -> compare_constr (fun t1 t2 -> f Reduction.CONV t1 t2) t1 t2
-
-let rec constr_cmp cv_pb t1 t2 = compare_constr_univ constr_cmp cv_pb t1 t2
-
-let eq_constr t1 t2 = constr_cmp Reduction.CONV t1 t2
-
-(* App(c,[t1,...tn]) -> ([c,t1,...,tn-1],tn)
- App(c,[||]) -> ([],c) *)
-let split_app c = match kind_of_term c with
- App(c,l) ->
- let len = Array.length l in
- if Int.equal len 0 then ([],c) else
- let last = Array.get l (len-1) in
- let prev = Array.sub l 0 (len-1) in
- c::(Array.to_list prev), last
- | _ -> assert false
-
-type subst = (rel_context*constr) Evar.Map.t
-
-exception CannotFilter
-
-let filtering env cv_pb c1 c2 =
- let evm = ref Evar.Map.empty in
- let define cv_pb e1 ev c1 =
- try let (e2,c2) = Evar.Map.find ev !evm in
- let shift = List.length e1 - List.length e2 in
- if constr_cmp cv_pb c1 (lift shift c2) then () else raise CannotFilter
- with Not_found ->
- evm := Evar.Map.add ev (e1,c1) !evm
- in
- let rec aux env cv_pb c1 c2 =
- match kind_of_term c1, kind_of_term c2 with
- | App _, App _ ->
- let ((p1,l1),(p2,l2)) = (split_app c1),(split_app c2) in
- let () = aux env cv_pb l1 l2 in
- begin match p1, p2 with
- | [], [] -> ()
- | (h1 :: p1), (h2 :: p2) ->
- aux env cv_pb (applistc h1 p1) (applistc h2 p2)
- | _ -> assert false
- end
- | Prod (n,t1,c1), Prod (_,t2,c2) ->
- aux env cv_pb t1 t2;
- aux ((n,None,t1)::env) cv_pb c1 c2
- | _, Evar (ev,_) -> define cv_pb env ev c1
- | Evar (ev,_), _ -> define cv_pb env ev c2
- | _ ->
- if compare_constr_univ
- (fun pb c1 c2 -> aux env pb c1 c2; true) cv_pb c1 c2 then ()
- else raise CannotFilter
- (* TODO: le reste des binders *)
- in
- aux env cv_pb c1 c2; !evm
-
-let decompose_prod_letin : constr -> int * rel_context * constr =
- let rec prodec_rec i l c = match kind_of_term c with
- | Prod (n,t,c) -> prodec_rec (succ i) ((n,None,t)::l) c
- | LetIn (n,d,t,c) -> prodec_rec (succ i) ((n,Some d,t)::l) c
- | Cast (c,_,_) -> prodec_rec i l c
- | _ -> i,l,c in
- prodec_rec 0 []
-
-let align_prod_letin c a : rel_context * constr =
- let (lc,_,_) = decompose_prod_letin c in
- let (la,l,a) = decompose_prod_letin a in
- if not (la >= lc) then invalid_arg "align_prod_letin";
- let (l1,l2) = Util.List.chop lc l in
- l2,it_mkProd_or_LetIn a l1
-
-(* We reduce a series of head eta-redex or nothing at all *)
-(* [x1:c1;...;xn:cn]@(f;a1...an;x1;...;xn) --> @(f;a1...an) *)
-(* Remplace 2 earlier buggish versions *)
-
-let rec eta_reduce_head c =
- match kind_of_term c with
- | Lambda (_,c1,c') ->
- (match kind_of_term (eta_reduce_head c') with
- | App (f,cl) ->
- let lastn = (Array.length cl) - 1 in
- if lastn < 0 then anomaly (Pp.str "application without arguments")
- else
- (match kind_of_term cl.(lastn) with
- | Rel 1 ->
- let c' =
- if Int.equal lastn 0 then f
- else mkApp (f, Array.sub cl 0 lastn)
- in
- if noccurn 1 c'
- then lift (-1) c'
- else c
- | _ -> c)
- | _ -> c)
- | _ -> c
-
-
-(* iterator on rel context *)
-let process_rel_context f env =
- let sign = named_context_val env in
- let rels = rel_context env in
- let env0 = reset_with_named_context sign env in
- Context.fold_rel_context f rels ~init:env0
-
-let assums_of_rel_context sign =
- Context.fold_rel_context
- (fun (na,c,t) l ->
- match c with
- Some _ -> l
- | None -> (na, t)::l)
- sign ~init:[]
-
-let map_rel_context_in_env f env sign =
- let rec aux env acc = function
- | d::sign ->
- aux (push_rel d env) (map_rel_declaration (f env) d :: acc) sign
- | [] ->
- acc
- in
- aux env [] (List.rev sign)
-
-let map_rel_context_with_binders f sign =
- let rec aux k = function
- | d::sign -> map_rel_declaration (f k) d :: aux (k-1) sign
- | [] -> []
- in
- aux (rel_context_length sign) sign
-
-let substl_rel_context l =
- map_rel_context_with_binders (fun k -> substnl l (k-1))
-
-let lift_rel_context n =
- map_rel_context_with_binders (liftn n)
-
-let smash_rel_context sign =
- let rec aux acc = function
- | [] -> acc
- | (_,None,_ as d) :: l -> aux (d::acc) l
- | (_,Some b,_) :: l ->
- (* Quadratic in the number of let but there are probably a few of them *)
- aux (List.rev (substl_rel_context [b] (List.rev acc))) l
- in List.rev (aux [] sign)
-
-let adjust_subst_to_rel_context sign l =
- let rec aux subst sign l =
- match sign, l with
- | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args'
- | (_,Some c,_)::sign', args' ->
- aux (substl subst c :: subst) sign' args'
- | [], [] -> List.rev subst
- | _ -> anomaly (Pp.str "Instance and signature do not match")
- in aux [] (List.rev sign) l
-
-let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init
-
-let rec mem_named_context id = function
- | (id',_,_) :: _ when Id.equal id id' -> true
- | _ :: sign -> mem_named_context id sign
- | [] -> false
-
-let compact_named_context_reverse sign =
- let compact l (i1,c1,t1) =
- match l with
- | [] -> [[i1],c1,t1]
- | (l2,c2,t2)::q ->
- if Option.equal Constr.equal c1 c2 && Constr.equal t1 t2
- then (i1::l2,c2,t2)::q
- else ([i1],c1,t1)::l
- in Context.fold_named_context_reverse compact ~init:[] sign
-
-let compact_named_context sign = List.rev (compact_named_context_reverse sign)
-
-let clear_named_body id env =
- let aux _ = function
- | (id',Some c,t) when Id.equal id id' -> push_named (id,None,t)
- | d -> push_named d in
- fold_named_context aux env ~init:(reset_context env)
-
-let global_vars env ids = Id.Set.elements (global_vars_set env ids)
-
-let global_vars_set_of_decl env = function
- | (_,None,t) -> global_vars_set env t
- | (_,Some c,t) ->
- Id.Set.union (global_vars_set env t)
- (global_vars_set env c)
-
-let dependency_closure env sign hyps =
- if Id.Set.is_empty hyps then [] else
- let (_,lh) =
- Context.fold_named_context_reverse
- (fun (hs,hl) (x,_,_ as d) ->
- if Id.Set.mem x hs then
- (Id.Set.union (global_vars_set_of_decl env d) (Id.Set.remove x hs),
- x::hl)
- else (hs,hl))
- ~init:(hyps,[])
- sign in
- List.rev lh
-
-(* Combinators on judgments *)
-
-let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type }
-let on_judgment_value f j = { j with uj_val = f j.uj_val }
-let on_judgment_type f j = { j with uj_type = f j.uj_type }
-
-(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k
- variables; skips let-in's *)
-let context_chop k ctx =
- let rec chop_aux acc = function
- | (0, l2) -> (List.rev acc, l2)
- | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t)
- | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
- | (_, []) -> anomaly (Pp.str "context_chop")
- in chop_aux [] (k,ctx)
-
-(* Do not skip let-in's *)
-let env_rel_context_chop k env =
- let rels = rel_context env in
- let ctx1,ctx2 = List.chop k rels in
- push_rel_context ctx2 (reset_with_named_context (named_context_val env) env),
- ctx1
-
-(*******************************************)
-(* Functions to deal with impossible cases *)
-(*******************************************)
-let impossible_default_case = ref None
-
-let set_impossible_default_clause c = impossible_default_case := Some c
-
-let coq_unit_judge =
- let na1 = Name (Id.of_string "A") in
- let na2 = Name (Id.of_string "H") in
- fun () ->
- match !impossible_default_case with
- | Some fn ->
- let (id,type_of_id), ctx = fn () in
- make_judge id type_of_id, ctx
- | None ->
- (* In case the constants id/ID are not defined *)
- make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1)))
- (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))),
- Univ.ContextSet.empty
diff --git a/pretyping/termops.mli b/pretyping/termops.mli
deleted file mode 100644
index ca98f8d7..00000000
--- a/pretyping/termops.mli
+++ /dev/null
@@ -1,248 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* std_ppcmds
-val pr_sort_family : sorts_family -> std_ppcmds
-val pr_fix : (constr -> std_ppcmds) -> fixpoint -> std_ppcmds
-
-(** debug printer: do not use to display terms to the casual user... *)
-val set_print_constr : (env -> constr -> std_ppcmds) -> unit
-val print_constr : constr -> std_ppcmds
-val print_constr_env : env -> constr -> std_ppcmds
-val print_named_context : env -> std_ppcmds
-val pr_rel_decl : env -> rel_declaration -> std_ppcmds
-val print_rel_context : env -> std_ppcmds
-val print_env : env -> std_ppcmds
-
-(** about contexts *)
-val push_rel_assum : Name.t * types -> env -> env
-val push_rels_assum : (Name.t * types) list -> env -> env
-val push_named_rec_types : Name.t array * types array * 'a -> env -> env
-
-val lookup_rel_id : Id.t -> rel_context -> int * constr option * types
-(** Associates the contents of an identifier in a [rel_context]. Raise
- [Not_found] if there is no such identifier. *)
-
-(** Functions that build argument lists matching a block of binders or a context.
- [rel_vect n m] builds [|Rel (n+m);...;Rel(n+1)|]
- [extended_rel_vect n ctx] extends the [ctx] context of length [m]
- with [n] elements.
-*)
-val rel_vect : int -> int -> constr array
-val rel_list : int -> int -> constr list
-val extended_rel_list : int -> rel_context -> constr list
-val extended_rel_vect : int -> rel_context -> constr array
-
-(** iterators/destructors on terms *)
-val mkProd_or_LetIn : rel_declaration -> types -> types
-val mkProd_wo_LetIn : rel_declaration -> types -> types
-val it_mkProd : types -> (Name.t * types) list -> types
-val it_mkLambda : constr -> (Name.t * types) list -> constr
-val it_mkProd_or_LetIn : types -> rel_context -> types
-val it_mkProd_wo_LetIn : types -> rel_context -> types
-val it_mkLambda_or_LetIn : constr -> rel_context -> constr
-val it_mkNamedProd_or_LetIn : types -> named_context -> types
-val it_mkNamedProd_wo_LetIn : types -> named_context -> types
-val it_mkNamedLambda_or_LetIn : constr -> named_context -> constr
-
-(* Ad hoc version reinserting letin, assuming the body is defined in
- the context where the letins are expanded *)
-val it_mkLambda_or_LetIn_from_no_LetIn : constr -> rel_context -> constr
-
-(** {6 Generic iterators on constr} *)
-
-val map_constr_with_named_binders :
- (Name.t -> 'a -> 'a) ->
- ('a -> constr -> constr) -> 'a -> constr -> constr
-val map_constr_with_binders_left_to_right :
- (rel_declaration -> 'a -> 'a) ->
- ('a -> constr -> constr) ->
- 'a -> constr -> constr
-val map_constr_with_full_binders :
- (rel_declaration -> 'a -> 'a) ->
- ('a -> constr -> constr) -> 'a -> constr -> constr
-
-(** [fold_constr_with_binders g f n acc c] folds [f n] on the immediate
- subterms of [c] starting from [acc] and proceeding from left to
- right according to the usual representation of the constructions as
- [fold_constr] but it carries an extra data [n] (typically a lift
- index) which is processed by [g] (which typically add 1 to [n]) at
- each binder traversal; it is not recursive *)
-
-val fold_constr_with_binders :
- ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b
-
-val fold_constr_with_full_binders :
- (rel_declaration -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) ->
- 'a -> 'b -> constr -> 'b
-
-val iter_constr_with_full_binders :
- (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a ->
- constr -> unit
-
-(**********************************************************************)
-
-val strip_head_cast : constr -> constr
-val drop_extra_implicit_args : constr -> constr
-
-(** occur checks *)
-exception Occur
-val occur_meta : types -> bool
-val occur_existential : types -> bool
-val occur_meta_or_existential : types -> bool
-val occur_evar : existential_key -> types -> bool
-val occur_var : env -> Id.t -> types -> bool
-val occur_var_in_decl :
- env ->
- Id.t -> 'a * types option * types -> bool
-val free_rels : constr -> Int.Set.t
-
-(** [dependent m t] tests whether [m] is a subterm of [t] *)
-val dependent : constr -> constr -> bool
-val dependent_no_evar : constr -> constr -> bool
-val dependent_univs : constr -> constr -> bool
-val dependent_univs_no_evar : constr -> constr -> bool
-val dependent_in_decl : constr -> named_declaration -> bool
-val count_occurrences : constr -> constr -> int
-val collect_metas : constr -> int list
-val collect_vars : constr -> Id.Set.t (** for visible vars only *)
-val occur_term : constr -> constr -> bool (** Synonymous
- of dependent
- Substitution of metavariables *)
-type meta_value_map = (metavariable * constr) list
-val subst_meta : meta_value_map -> constr -> constr
-
-(** Type assignment for metavariables *)
-type meta_type_map = (metavariable * types) list
-
-(** [pop c] lifts by -1 the positive indexes in [c] *)
-val pop : constr -> constr
-
-(** {6 ... } *)
-(** Substitution of an arbitrary large term. Uses equality modulo
- reduction of let *)
-
-(** [subst_term_gen eq d c] replaces [Rel 1] by [d] in [c] using [eq]
- as equality *)
-val subst_term_gen :
- (constr -> constr -> bool) -> constr -> constr -> constr
-
-(** [replace_term_gen eq d e c] replaces [d] by [e] in [c] using [eq]
- as equality *)
-val replace_term_gen :
- (constr -> constr -> bool) ->
- constr -> constr -> constr -> constr
-
-(** [subst_term d c] replaces [Rel 1] by [d] in [c] *)
-val subst_term : constr -> constr -> constr
-
-(** [replace_term d e c] replaces [d] by [e] in [c] *)
-val replace_term : constr -> constr -> constr -> constr
-
-(** Alternative term equalities *)
-val base_sort_cmp : Reduction.conv_pb -> sorts -> sorts -> bool
-val compare_constr_univ : (Reduction.conv_pb -> constr -> constr -> bool) ->
- Reduction.conv_pb -> constr -> constr -> bool
-val constr_cmp : Reduction.conv_pb -> constr -> constr -> bool
-val eq_constr : constr -> constr -> bool (* FIXME rename: erases universes*)
-
-val eta_reduce_head : constr -> constr
-
-exception CannotFilter
-
-(** Lightweight first-order filtering procedure. Unification
- variables ar represented by (untyped) Evars.
- [filtering c1 c2] returns the substitution n'th evar ->
- (context,term), or raises [CannotFilter].
- Warning: Outer-kernel sort subtyping are taken into account: c1 has
- to be smaller than c2 wrt. sorts. *)
-type subst = (rel_context*constr) Evar.Map.t
-val filtering : rel_context -> Reduction.conv_pb -> constr -> constr -> subst
-
-val decompose_prod_letin : constr -> int * rel_context * constr
-val align_prod_letin : constr -> constr -> rel_context * constr
-
-(** Get the last arg of a constr intended to be an application *)
-val last_arg : constr -> constr
-
-(** Force the decomposition of a term as an applicative one *)
-val decompose_app_vect : constr -> constr * constr array
-
-val adjust_app_list_size : constr -> constr list -> constr -> constr list ->
- (constr * constr list * constr * constr list)
-val adjust_app_array_size : constr -> constr array -> constr -> constr array ->
- (constr * constr array * constr * constr array)
-
-(** name contexts *)
-type names_context = Name.t list
-val add_name : Name.t -> names_context -> names_context
-val lookup_name_of_rel : int -> names_context -> Name.t
-val lookup_rel_of_name : Id.t -> names_context -> int
-val empty_names_context : names_context
-val ids_of_rel_context : rel_context -> Id.t list
-val ids_of_named_context : named_context -> Id.t list
-val ids_of_context : env -> Id.t list
-val names_of_rel_context : env -> names_context
-
-val context_chop : int -> rel_context -> rel_context * rel_context
-val env_rel_context_chop : int -> env -> env * rel_context
-
-(** Set of local names *)
-val vars_of_env: env -> Id.Set.t
-val add_vname : Id.Set.t -> Name.t -> Id.Set.t
-
-(** other signature iterators *)
-val process_rel_context : (rel_declaration -> env -> env) -> env -> env
-val assums_of_rel_context : rel_context -> (Name.t * constr) list
-val lift_rel_context : int -> rel_context -> rel_context
-val substl_rel_context : constr list -> rel_context -> rel_context
-val smash_rel_context : rel_context -> rel_context (** expand lets in context *)
-val adjust_subst_to_rel_context : rel_context -> constr list -> constr list
-val map_rel_context_in_env :
- (env -> constr -> constr) -> env -> rel_context -> rel_context
-val map_rel_context_with_binders :
- (int -> constr -> constr) -> rel_context -> rel_context
-val fold_named_context_both_sides :
- ('a -> named_declaration -> named_declaration list -> 'a) ->
- named_context -> init:'a -> 'a
-val mem_named_context : Id.t -> named_context -> bool
-val compact_named_context : named_context -> named_list_context
-val compact_named_context_reverse : named_context -> named_list_context
-
-val clear_named_body : Id.t -> env -> env
-
-val global_vars : env -> constr -> Id.t list
-val global_vars_set_of_decl : env -> named_declaration -> Id.Set.t
-
-(** Gives an ordered list of hypotheses, closed by dependencies,
- containing a given set *)
-val dependency_closure : env -> named_context -> Id.Set.t -> Id.t list
-
-(** Test if an identifier is the basename of a global reference *)
-val is_section_variable : Id.t -> bool
-
-val isGlobalRef : constr -> bool
-
-val is_template_polymorphic : env -> constr -> bool
-
-(** Combinators on judgments *)
-
-val on_judgment : (types -> types) -> unsafe_judgment -> unsafe_judgment
-val on_judgment_value : (types -> types) -> unsafe_judgment -> unsafe_judgment
-val on_judgment_type : (types -> types) -> unsafe_judgment -> unsafe_judgment
-
-(** {6 Functions to deal with impossible cases } *)
-val set_impossible_default_clause : (unit -> (constr * types) Univ.in_universe_context_set) -> unit
-val coq_unit_judge : unit -> unsafe_judgment Univ.in_universe_context_set
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 3be98a1a..b8da6b68 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -12,11 +12,11 @@ open Globnames
open Decl_kinds
open Term
open Vars
-open Context
open Evd
open Util
open Typeclasses_errors
open Libobject
+open Context.Rel.Declaration
(*i*)
let typeclasses_unique_solutions = ref false
@@ -25,7 +25,7 @@ let get_typeclasses_unique_solutions () = !typeclasses_unique_solutions
open Goptions
-let set_typeclasses_unique_solutions =
+let _ =
declare_bool_option
{ optsync = true;
optdepr = false;
@@ -46,10 +46,10 @@ let set_typeclass_transparency gr local c = Hook.get set_typeclass_transparency
let (classes_transparent_state, classes_transparent_state_hook) = Hook.make ()
let classes_transparent_state () = Hook.get classes_transparent_state ()
-let solve_instantiation_problem = ref (fun _ _ _ _ -> assert false)
+let get_solve_one_instance, solve_one_instance_hook = Hook.make ()
let resolve_one_typeclass ?(unique=get_typeclasses_unique_solutions ()) env evm t =
- !solve_instantiation_problem env evm t unique
+ Hook.get get_solve_one_instance env evm t unique
type direction = Forward | Backward
@@ -59,13 +59,14 @@ type typeclass = {
cl_impl : global_reference;
(* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *)
- cl_context : (global_reference * bool) option list * rel_context;
+ cl_context : (global_reference * bool) option list * Context.Rel.t;
(* Context of definitions and properties on defs, will not be shared *)
- cl_props : rel_context;
+ cl_props : Context.Rel.t;
(* The method implementaions as projections. *)
- cl_projs : (Name.t * (direction * int option) option * constant option) list;
+ cl_projs : (Name.t * (direction * Vernacexpr.hint_info_expr) option
+ * constant option) list;
cl_strict : bool;
@@ -76,10 +77,9 @@ type typeclasses = typeclass Refmap.t
type instance = {
is_class: global_reference;
- is_pri: int option;
+ is_info: Vernacexpr.hint_info_expr;
(* Sections where the instance should be redeclared,
- -1 for discard, 0 for none, mutable to avoid redeclarations
- when multiple rebuild_object happen. *)
+ -1 for discard, 0 for none. *)
is_global: int;
is_poly: bool;
is_impl: global_reference;
@@ -89,15 +89,15 @@ type instances = (instance Refmap.t) Refmap.t
let instance_impl is = is.is_impl
-let instance_priority is = is.is_pri
+let hint_priority is = is.is_info.Vernacexpr.hint_priority
-let new_instance cl pri glob poly impl =
+let new_instance cl info glob poly impl =
let global =
if glob then Lib.sections_depth ()
else -1
in
{ is_class = cl.cl_impl;
- is_pri = pri ;
+ is_info = info ;
is_global = global ;
is_poly = poly;
is_impl = impl }
@@ -127,7 +127,7 @@ let typeclass_univ_instance (cl,u') =
in Array.fold_left2 (fun subst u u' -> Univ.LMap.add u u' subst)
Univ.LMap.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u')
in
- let subst_ctx = Context.map_rel_context (subst_univs_level_constr subst) in
+ let subst_ctx = Context.Rel.map (subst_univs_level_constr subst) in
{ cl with cl_context = fst cl.cl_context, subst_ctx (snd cl.cl_context);
cl_props = subst_ctx cl.cl_props}, u'
@@ -150,7 +150,7 @@ let dest_class_arity env c =
let class_of_constr c =
try Some (dest_class_arity (Global.env ()) c)
- with e when Errors.noncritical e -> None
+ with e when CErrors.noncritical e -> None
let is_class_constr c =
try let gr, u = Universes.global_of_constr c in
@@ -181,9 +181,7 @@ let subst_class (subst,cl) =
let do_subst_con c = Mod_subst.subst_constant subst c
and do_subst c = Mod_subst.subst_mps subst c
and do_subst_gr gr = fst (subst_global subst gr) in
- let do_subst_ctx ctx = List.smartmap
- (fun (na, b, t) -> (na, Option.smartmap do_subst b, do_subst t))
- ctx in
+ let do_subst_ctx = List.smartmap (map_constr do_subst) in
let do_subst_context (grs,ctx) =
List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs,
do_subst_ctx ctx in
@@ -200,15 +198,19 @@ let discharge_class (_,cl) =
let repl = Lib.replacement_context () in
let rel_of_variable_context ctx = List.fold_right
( fun (n,_,b,t) (ctx', subst) ->
- let decl = (Name n, Option.map (substn_vars 1 subst) b, substn_vars 1 subst t) in
+ let decl = match b with
+ | None -> LocalAssum (Name n, substn_vars 1 subst t)
+ | Some b -> LocalDef (Name n, substn_vars 1 subst b, substn_vars 1 subst t)
+ in
(decl :: ctx', n :: subst)
) ctx ([], []) in
let discharge_rel_context subst n rel =
- let rel = map_rel_context (Cooking.expmod_constr repl) rel in
+ let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in
let ctx, _ =
List.fold_right
- (fun (id, b, t) (ctx, k) ->
- (id, Option.smartmap (substn_vars k subst) b, substn_vars k subst t) :: ctx, succ k)
+ (fun decl (ctx, k) ->
+ map_constr (substn_vars k subst) decl :: ctx, succ k
+ )
rel ([], n)
in ctx
in
@@ -218,15 +220,15 @@ let discharge_class (_,cl) =
| ConstRef cst -> Lib.section_segment_of_constant cst
| IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in
let discharge_context ctx' subst (grs, ctx) =
- let grs' =
- let newgrs = List.map (fun (_, _, t) ->
- match class_of_constr t with
- | None -> None
- | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true))
- ctx'
+ let grs' =
+ let newgrs = List.map (fun decl ->
+ match decl |> get_type |> class_of_constr with
+ | None -> None
+ | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true))
+ ctx'
in
- List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
- @ newgrs
+ List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
+ @ newgrs
in grs', discharge_rel_context subst 1 ctx @ ctx' in
let cl_impl' = Lib.discharge_global cl.cl_impl in
if cl_impl' == cl.cl_impl then cl else
@@ -247,7 +249,7 @@ let rebuild_class cl =
try
let cst = Tacred.evaluable_of_global_reference (Global.env ()) cl.cl_impl in
set_typeclass_transparency cst false false; cl
- with e when Errors.noncritical e -> cl
+ with e when CErrors.noncritical e -> cl
let class_input : typeclass -> obj =
declare_object
@@ -270,9 +272,11 @@ let check_instance env sigma c =
let (evd, c) = resolve_one_typeclass env sigma
(Retyping.get_type_of env sigma c) in
not (Evd.has_undefined evd)
- with e when Errors.noncritical e -> false
+ with e when CErrors.noncritical e -> false
+
+open Vernacexpr
-let build_subclasses ~check env sigma glob pri =
+let build_subclasses ~check env sigma glob { hint_priority = pri } =
let _id = Nametab.basename_of_global glob in
let _next_id =
let i = ref (-1) in
@@ -287,7 +291,7 @@ let build_subclasses ~check env sigma glob pri =
| None -> []
| Some (rels, ((tc,u), args)) ->
let instapp =
- Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels))
+ Reductionops.whd_beta sigma (appvectc c (Context.Rel.to_extended_vect 0 rels))
in
let projargs = Array.of_list (args @ [instapp]) in
let projs = List.map_filter
@@ -295,24 +299,24 @@ let build_subclasses ~check env sigma glob pri =
match b with
| None -> None
| Some (Backward, _) -> None
- | Some (Forward, pri') ->
+ | Some (Forward, info) ->
let proj = Option.get proj in
let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in
if check && check_instance env sigma body then None
else
- let pri =
- match pri, pri' with
+ let newpri =
+ match pri, info.hint_priority with
| Some p, Some p' -> Some (p + p')
| Some p, None -> Some (p + 1)
| _, _ -> None
in
- Some (ConstRef proj, pri, body)) tc.cl_projs
+ Some (ConstRef proj, { info with hint_priority = newpri }, body)) tc.cl_projs
in
- let declare_proj hints (cref, pri, body) =
+ let declare_proj hints (cref, info, body) =
let path' = cref :: path in
let ty = Retyping.get_type_of env sigma body in
let rest = aux pri body ty path' in
- hints @ (path', pri, body) :: rest
+ hints @ (path', info, body) :: rest
in List.fold_left declare_proj [] projs
in
let term = Universes.constr_of_global_univ (glob,Univ.UContext.instance ctx) in
@@ -366,11 +370,11 @@ let is_local i = Int.equal i.is_global (-1)
let add_instance check inst =
let poly = Global.is_polymorphic inst.is_impl in
add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst)
- inst.is_pri poly;
+ inst.is_info poly;
List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path
(is_local inst) pri poly)
(build_subclasses ~check:(check && not (isVarRef inst.is_impl))
- (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_pri)
+ (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info)
let rebuild_instance (action, inst) =
let () = match action with
@@ -402,26 +406,22 @@ let remove_instance i =
Lib.add_anonymous_leaf (instance_input (RemoveInstance, i));
remove_instance_hint i.is_impl
-let declare_instance pri local glob =
+let declare_instance info local glob =
let ty = Global.type_of_global_unsafe glob in
+ let info = Option.default {hint_priority = None; hint_pattern = None} info in
match class_of_constr ty with
| Some (rels, ((tc,_), args) as _cl) ->
- add_instance (new_instance tc pri (not local) (Flags.use_polymorphic_flag ()) glob)
-(* let path, hints = build_subclasses (not local) (Global.env ()) Evd.empty glob in *)
-(* let entries = List.map (fun (path, pri, c) -> (pri, local, path, c)) hints in *)
-(* Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry entries); *)
-(* Auto.add_hints local [typeclasses_db] *)
-(* (Auto.HintsCutEntry (PathSeq (PathStar (PathAtom PathAny), path))) *)
+ add_instance (new_instance tc info (not local) (Flags.use_polymorphic_flag ()) glob)
| None -> ()
let add_class cl =
add_class cl;
List.iter (fun (n, inst, body) ->
match inst with
- | Some (Backward, pri) ->
+ | Some (Backward, info) ->
(match body with
- | None -> Errors.error "Non-definable projection can not be declared as a subinstance"
- | Some b -> declare_instance pri false (ConstRef b))
+ | None -> CErrors.error "Non-definable projection can not be declared as a subinstance"
+ | Some b -> declare_instance (Some info) false (ConstRef b))
| _ -> ())
cl.cl_projs
@@ -432,11 +432,7 @@ let add_class cl =
*)
let instance_constructor (cl,u) args =
- let filter (_, b, _) = match b with
- | None -> true
- | Some _ -> false
- in
- let lenpars = List.length (List.filter filter (snd cl.cl_context)) in
+ let lenpars = List.count is_local_assum (snd cl.cl_context) in
let pars = fst (List.chop lenpars args) in
match cl.cl_impl with
| IndRef ind ->
@@ -492,18 +488,21 @@ let is_instance = function
Nota: we will only check the resolvability status of undefined evars.
*)
-let resolvable = Store.field ()
+let resolvable = Proofview.Unsafe.typeclass_resolvable
let set_resolvable s b =
- Store.set s resolvable b
+ if b then Store.remove s resolvable
+ else Store.set s resolvable ()
let is_resolvable evi =
assert (match evi.evar_body with Evar_empty -> true | _ -> false);
- Option.default true (Store.get evi.evar_extra resolvable)
+ Option.is_empty (Store.get evi.evar_extra resolvable)
let mark_resolvability_undef b evi =
- let t = Store.set evi.evar_extra resolvable b in
- { evi with evar_extra = t }
+ if is_resolvable evi == (b : bool) then evi
+ else
+ let t = set_resolvable evi.evar_extra b in
+ { evi with evar_extra = t }
let mark_resolvability b evi =
assert (match evi.evar_body with Evar_empty -> true | _ -> false);
@@ -538,16 +537,16 @@ let has_typeclasses filter evd =
in
Evar.Map.exists check (Evd.undefined_map evd)
-let solve_instantiations_problem = ref (fun _ _ _ _ _ _ -> assert false)
+let get_solve_all_instances, solve_all_instances_hook = Hook.make ()
-let solve_problem env evd filter unique split fail =
- !solve_instantiations_problem env evd filter unique split fail
+let solve_all_instances env evd filter unique split fail =
+ Hook.get get_solve_all_instances env evd filter unique split fail
(** Profiling resolution of typeclasses *)
(* let solve_classeskey = Profile.declare_profile "solve_typeclasses" *)
(* let solve_problem = Profile.profile5 solve_classeskey solve_problem *)
-let resolve_typeclasses ?(filter=no_goals) ?(unique=get_typeclasses_unique_solutions ())
+let resolve_typeclasses ?(fast_path = true) ?(filter=no_goals) ?(unique=get_typeclasses_unique_solutions ())
?(split=true) ?(fail=true) env evd =
- if not (has_typeclasses filter evd) then evd
- else solve_problem env evd filter unique split fail
+ if fast_path && not (has_typeclasses filter evd) then evd
+ else solve_all_instances env evd filter unique split fail
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index 9e018f61..620bc367 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -9,7 +9,6 @@
open Names
open Globnames
open Term
-open Context
open Evd
open Environ
@@ -24,16 +23,16 @@ type typeclass = {
(** Context in which the definitions are typed. Includes both typeclass parameters and superclasses.
The boolean indicates if the typeclass argument is a direct superclass and the global reference
gives a direct link to the class itself. *)
- cl_context : (global_reference * bool) option list * rel_context;
+ cl_context : (global_reference * bool) option list * Context.Rel.t;
(** Context of definitions and properties on defs, will not be shared *)
- cl_props : rel_context;
+ cl_props : Context.Rel.t;
(** The methods implementations of the typeclass as projections.
Some may be undefinable due to sorting restrictions or simply undefined if
no name is provided. The [int option option] indicates subclasses whose hint has
the given priority. *)
- cl_projs : (Name.t * (direction * int option) option * constant option) list;
+ cl_projs : (Name.t * (direction * Vernacexpr.hint_info_expr) option * constant option) list;
(** Whether we use matching or full unification during resolution *)
cl_strict : bool;
@@ -51,7 +50,7 @@ val all_instances : unit -> instance list
val add_class : typeclass -> unit
-val new_instance : typeclass -> int option -> bool -> Decl_kinds.polymorphic ->
+val new_instance : typeclass -> Vernacexpr.hint_info_expr -> bool -> Decl_kinds.polymorphic ->
global_reference -> instance
val add_instance : instance -> unit
val remove_instance : instance -> unit
@@ -68,11 +67,11 @@ val dest_class_app : env -> constr -> typeclass puniverses * constr list
val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses
(** Just return None if not a class *)
-val class_of_constr : constr -> (rel_context * (typeclass puniverses * constr list)) option
+val class_of_constr : constr -> (Context.Rel.t * (typeclass puniverses * constr list)) option
val instance_impl : instance -> global_reference
-val instance_priority : instance -> int option
+val hint_priority : instance -> int option
val is_class : global_reference -> bool
val is_instance : global_reference -> bool
@@ -102,7 +101,7 @@ val mark_resolvable : evar_info -> evar_info
val is_class_evar : evar_map -> evar_info -> bool
val is_class_type : evar_map -> types -> bool
-val resolve_typeclasses : ?filter:evar_filter -> ?unique:bool ->
+val resolve_typeclasses : ?fast_path:bool -> ?filter:evar_filter -> ?unique:bool ->
?split:bool -> ?fail:bool -> env -> evar_map -> evar_map
val resolve_one_typeclass : ?unique:bool -> env -> evar_map -> types -> open_constr
@@ -114,21 +113,22 @@ val classes_transparent_state : unit -> transparent_state
val add_instance_hint_hook :
(global_reference_or_constr -> global_reference list ->
- bool (* local? *) -> int option -> Decl_kinds.polymorphic -> unit) Hook.t
+ bool (* local? *) -> Vernacexpr.hint_info_expr -> Decl_kinds.polymorphic -> unit) Hook.t
val remove_instance_hint_hook : (global_reference -> unit) Hook.t
val add_instance_hint : global_reference_or_constr -> global_reference list ->
- bool -> int option -> Decl_kinds.polymorphic -> unit
+ bool -> Vernacexpr.hint_info_expr -> Decl_kinds.polymorphic -> unit
val remove_instance_hint : global_reference -> unit
-val solve_instantiations_problem : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) ref
-val solve_instantiation_problem : (env -> evar_map -> types -> bool -> open_constr) ref
+val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t
+val solve_one_instance_hook : (env -> evar_map -> types -> bool -> open_constr) Hook.t
-val declare_instance : int option -> bool -> global_reference -> unit
+val declare_instance : Vernacexpr.hint_info_expr option -> bool -> global_reference -> unit
(** Build the subinstances hints for a given typeclass object.
check tells if we should check for existence of the
subinstances and add only the missing ones. *)
-val build_subclasses : check:bool -> env -> evar_map -> global_reference -> int option (* priority *) ->
- (global_reference list * int option * constr) list
+val build_subclasses : check:bool -> env -> evar_map -> global_reference ->
+ Vernacexpr.hint_info_expr ->
+ (global_reference list * Vernacexpr.hint_info_expr * constr) list
diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml
index a0f63198..b1dfb19a 100644
--- a/pretyping/typeclasses_errors.ml
+++ b/pretyping/typeclasses_errors.ml
@@ -9,7 +9,6 @@
(*i*)
open Names
open Term
-open Context
open Environ
open Constrexpr
open Globnames
@@ -20,7 +19,7 @@ type contexts = Parameters | Properties
type typeclass_error =
| NotAClass of constr
| UnboundMethod of global_reference * Id.t Loc.located (* Class name, method *)
- | MismatchedContextInstance of contexts * constr_expr list * rel_context (* found, expected *)
+ | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (* found, expected *)
exception TypeClassError of env * typeclass_error
diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli
index 7facb06f..ee76f638 100644
--- a/pretyping/typeclasses_errors.mli
+++ b/pretyping/typeclasses_errors.mli
@@ -9,7 +9,6 @@
open Loc
open Names
open Term
-open Context
open Environ
open Constrexpr
open Globnames
@@ -19,7 +18,7 @@ type contexts = Parameters | Properties
type typeclass_error =
| NotAClass of constr
| UnboundMethod of global_reference * Id.t located (** Class name, method *)
- | MismatchedContextInstance of contexts * constr_expr list * rel_context (** found, expected *)
+ | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (** found, expected *)
exception TypeClassError of env * typeclass_error
@@ -27,5 +26,5 @@ val not_a_class : env -> constr -> 'a
val unbound_method : env -> global_reference -> Id.t located -> 'a
-val mismatched_ctx_inst : env -> contexts -> constr_expr list -> rel_context -> 'a
+val mismatched_ctx_inst : env -> contexts -> constr_expr list -> Context.Rel.t -> 'a
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index eb16628b..9e9997f7 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Term
open Vars
@@ -18,6 +18,7 @@ open Inductive
open Inductiveops
open Typeops
open Arguments_renaming
+open Context.Rel.Declaration
let meta_type evd mv =
let ty =
@@ -35,10 +36,10 @@ let inductive_type_knowing_parameters env (ind,u) jl =
Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp
let e_type_judgment env evdref j =
- match kind_of_term (whd_betadeltaiota env !evdref j.uj_type) with
+ match kind_of_term (whd_all env !evdref j.uj_type) with
| Sort s -> {utj_val = j.uj_val; utj_type = s }
| Evar ev ->
- let (evd,s) = Evarutil.define_evar_as_sort env !evdref ev in
+ let (evd,s) = Evardefine.define_evar_as_sort env !evdref ev in
evdref := evd; { utj_val = j.uj_val; utj_type = s }
| _ -> error_not_type env j
@@ -53,14 +54,14 @@ let e_judge_of_apply env evdref funj argjv =
{ uj_val = mkApp (j_val funj, Array.map j_val argjv);
uj_type = typ }
| hj::restjl ->
- match kind_of_term (whd_betadeltaiota env !evdref typ) with
+ match kind_of_term (whd_all env !evdref typ) with
| Prod (_,c1,c2) ->
if Evarconv.e_cumul env evdref hj.uj_type c1 then
apply_rec (n+1) (subst1 hj.uj_val c2) restjl
else
error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv
| Evar ev ->
- let (evd',t) = Evarutil.define_evar_as_product !evdref ev in
+ let (evd',t) = Evardefine.define_evar_as_product !evdref ev in
evdref := evd';
let (_,_,c2) = destProd t in
apply_rec (n+1) (subst1 hj.uj_val c2) restjl
@@ -86,18 +87,18 @@ let e_is_correct_arity env evdref c pj ind specif params =
let allowed_sorts = elim_sorts specif in
let error () = error_elim_arity env ind allowed_sorts c pj None in
let rec srec env pt ar =
- let pt' = whd_betadeltaiota env !evdref pt in
+ let pt' = whd_all env !evdref pt in
match kind_of_term pt', ar with
- | Prod (na1,a1,t), (_,None,a1')::ar' ->
+ | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' ->
if not (Evarconv.e_cumul env evdref a1 a1') then error ();
- srec (push_rel (na1,None,a1) env) t ar'
+ srec (push_rel (LocalAssum (na1,a1)) env) t ar'
| Sort s, [] ->
if not (Sorts.List.mem (Sorts.family s) allowed_sorts)
then error ()
| Evar (ev,_), [] ->
let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in
evdref := Evd.define ev (mkSort s) evd
- | _, (_,Some _,_ as d)::ar' ->
+ | _, (LocalDef _ as d)::ar' ->
srec (push_rel d env) (lift 1 pt') ar'
| _ ->
error ()
@@ -109,23 +110,32 @@ let e_type_case_branches env evdref (ind,largs) pj c =
let nparams = inductive_params specif in
let (params,realargs) = List.chop nparams largs in
let p = pj.uj_val in
- let univ = e_is_correct_arity env evdref c pj ind specif params in
+ let () = e_is_correct_arity env evdref c pj ind specif params in
let lc = build_branches_type ind specif params p in
- let n = (snd specif).Declarations.mind_nrealargs in
- let ty =
- whd_betaiota !evdref (Reduction.betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) in
- (lc, ty, univ)
+ let n = (snd specif).Declarations.mind_nrealdecls in
+ let ty = whd_betaiota !evdref (lambda_applist_assum (n+1) p (realargs@[c])) in
+ (lc, ty)
let e_judge_of_case env evdref ci pj cj lfj =
let indspec =
try find_mrectype env !evdref cj.uj_type
with Not_found -> error_case_not_inductive env cj in
let _ = check_case_info env (fst indspec) ci in
- let (bty,rslty,univ) = e_type_case_branches env evdref indspec pj cj.uj_val in
+ let (bty,rslty) = e_type_case_branches env evdref indspec pj cj.uj_val in
e_check_branch_types env evdref (fst indspec) cj (lfj,bty);
{ uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj);
uj_type = rslty }
+let check_type_fixpoint loc env evdref lna lar vdefj =
+ let lt = Array.length vdefj in
+ if Int.equal (Array.length lar) lt then
+ for i = 0 to lt-1 do
+ if not (Evarconv.e_cumul env evdref (vdefj.(i)).uj_type
+ (lift lt lar.(i))) then
+ Pretype_errors.error_ill_typed_rec_body_loc loc env !evdref
+ i lna vdefj lar
+ done
+
(* FIXME: might depend on the level of actual parameters!*)
let check_allowed_sort env sigma ind c p =
let pj = Retyping.get_judgment_of env sigma p in
@@ -230,14 +240,14 @@ let rec execute env evdref cstr =
| Lambda (name,c1,c2) ->
let j = execute env evdref c1 in
let var = e_type_judgment env evdref j in
- let env1 = push_rel (name,None,var.utj_val) env in
+ let env1 = push_rel (LocalAssum (name, var.utj_val)) env in
let j' = execute env1 evdref c2 in
judge_of_abstraction env1 name var j'
| Prod (name,c1,c2) ->
let j = execute env evdref c1 in
let varj = e_type_judgment env evdref j in
- let env1 = push_rel (name,None,varj.utj_val) env in
+ let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in
let j' = execute env1 evdref c2 in
let varj' = e_type_judgment env1 evdref j' in
judge_of_product env name varj varj'
@@ -247,7 +257,7 @@ let rec execute env evdref cstr =
let j2 = execute env evdref c2 in
let j2 = e_type_judgment env evdref j2 in
let _ = e_judge_of_cast env evdref j1 DEFAULTcast j2 in
- let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
+ let env1 = push_rel (LocalDef (name, j1.uj_val, j2.utj_val)) env in
let j3 = execute env1 evdref c3 in
judge_of_letin env name j1 j2 j3
@@ -263,12 +273,12 @@ and execute_recdef env evdref (names,lar,vdef) =
let env1 = push_rec_types (names,lara,vdef) env in
let vdefj = execute_array env1 evdref vdef in
let vdefv = Array.map j_val vdefj in
- let _ = type_fixpoint env1 names lara vdefj in
+ let _ = check_type_fixpoint Loc.ghost env1 evdref names lara vdefj in
(names,lara,vdefv)
and execute_array env evdref = Array.map (execute env evdref)
-let check env evdref c t =
+let e_check env evdref c t =
let env = enrich_env env evdref in
let j = execute env evdref c in
if not (Evarconv.e_cumul env evdref j.uj_type t) then
@@ -284,7 +294,7 @@ let unsafe_type_of env evd c =
(* Sort of a type *)
-let sort_of env evdref c =
+let e_sort_of env evdref c =
let env = enrich_env env evdref in
let j = execute env evdref c in
let a = e_type_judgment env evdref j in
@@ -311,10 +321,10 @@ let e_type_of ?(refresh=false) env evdref c =
c
else j.uj_type
-let solve_evars env evdref c =
+let e_solve_evars env evdref c =
let env = enrich_env env evdref in
let c = (execute env evdref c).uj_val in
(* side-effect on evdref *)
nf_evar !evdref c
-let _ = Evarconv.set_solve_evars solve_evars
+let _ = Evarconv.set_solve_evars e_solve_evars
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
index dafd7523..04e5e40b 100644
--- a/pretyping/typing.mli
+++ b/pretyping/typing.mli
@@ -24,18 +24,23 @@ val type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types
val e_type_of : ?refresh:bool -> env -> evar_map ref -> constr -> types
(** Typecheck a type and return its sort *)
-val sort_of : env -> evar_map ref -> types -> sorts
+val e_sort_of : env -> evar_map ref -> types -> sorts
(** Typecheck a term has a given type (assuming the type is OK) *)
-val check : env -> evar_map ref -> constr -> types -> unit
+val e_check : env -> evar_map ref -> constr -> types -> unit
(** Returns the instantiated type of a metavariable *)
val meta_type : evar_map -> metavariable -> types
(** Solve existential variables using typing *)
-val solve_evars : env -> evar_map ref -> constr -> constr
+val e_solve_evars : env -> evar_map ref -> constr -> constr
(** Raise an error message if incorrect elimination for this inductive *)
(** (first constr is term to match, second is return predicate) *)
val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr ->
unit
+
+(** Raise an error message if bodies have types not unifiable with the
+ expected ones *)
+val check_type_fixpoint : Loc.t -> env -> evar_map ref ->
+ Names.Name.t array -> types array -> unsafe_judgment array -> unit
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index f97f6fbc..25931869 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Pp
open Util
open Names
@@ -19,6 +19,7 @@ open Evd
open Reduction
open Reductionops
open Evarutil
+open Evardefine
open Evarsolve
open Pretype_errors
open Retyping
@@ -27,6 +28,8 @@ open Recordops
open Locus
open Locusops
open Find_subterm
+open Sigma.Notations
+open Context.Named.Declaration
let keyed_unification = ref (false)
let _ = Goptions.declare_bool_option {
@@ -57,7 +60,7 @@ let occur_meta_or_undefined_evar evd c =
| Evar_defined c ->
occrec c; Array.iter occrec args
| Evar_empty -> raise Occur)
- | _ -> iter_constr occrec c
+ | _ -> Constr.iter occrec c
in try occrec c; false with Occur | Not_found -> true
let occur_meta_evd sigma mv c =
@@ -66,7 +69,7 @@ let occur_meta_evd sigma mv c =
let c = whd_evar sigma (whd_meta sigma c) in
match kind_of_term c with
| Meta mv' when Int.equal mv mv' -> raise Occur
- | _ -> iter_constr occrec c
+ | _ -> Constr.iter occrec c
in try occrec c; false with Occur -> true
(* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms,
@@ -74,7 +77,10 @@ let occur_meta_evd sigma mv c =
let abstract_scheme env evd c l lname_typ =
List.fold_left2
- (fun (t,evd) (locc,a) (na,_,ta) ->
+ (fun (t,evd) (locc,a) decl ->
+ let open Context.Rel.Declaration in
+ let na = get_name decl in
+ let ta = get_type decl in
let na = match kind_of_term a with Var id -> Name id | _ -> na in
(* [occur_meta ta] test removed for support of eelim/ecase but consequences
are unclear...
@@ -107,7 +113,9 @@ let set_occurrences_of_last_arg args =
Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args)
let abstract_list_all_with_dependencies env evd typ c l =
- let evd,ev = new_evar env evd typ in
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (ev, evd, _) = new_evar env evd typ in
+ let evd = Sigma.to_evar_map evd in
let evd,ev' = evar_absorb_arguments env evd (destEvar ev) l in
let n = List.length l in
let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in
@@ -143,7 +151,7 @@ let rec subst_meta_instances bl c =
| Meta i ->
let select (j,_,_) = Int.equal i j in
(try pi2 (List.find select bl) with Not_found -> c)
- | _ -> map_constr (subst_meta_instances bl) c
+ | _ -> Constr.map (subst_meta_instances bl) c
(** [env] should be the context in which the metas live *)
@@ -161,7 +169,7 @@ let pose_all_metas_as_evars env evd t =
evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref;
ev)
| _ ->
- map_constr aux t in
+ Constr.map aux t in
let c = aux t in
(* side-effect *)
(!evdref, c)
@@ -356,6 +364,22 @@ let set_no_delta_flags flags = {
resolve_evars = flags.resolve_evars
}
+(* For the first phase of keyed unification, restrict
+ to conversion (including beta-iota) only on closed terms *)
+let set_no_delta_open_core_flags flags = { flags with
+ modulo_delta = empty_transparent_state;
+ modulo_betaiota = false;
+}
+
+let set_no_delta_open_flags flags = {
+ core_unify_flags = set_no_delta_open_core_flags flags.core_unify_flags;
+ merge_unify_flags = set_no_delta_open_core_flags flags.merge_unify_flags;
+ subterm_unify_flags = set_no_delta_open_core_flags flags.subterm_unify_flags;
+ allow_K_in_toplevel_higher_order_unification =
+ flags.allow_K_in_toplevel_higher_order_unification;
+ resolve_evars = flags.resolve_evars
+}
+
(* Default flag for the "simple apply" version of unification of a *)
(* type against a type (e.g. apply) *)
(* We set only the flags available at the time the new "apply" extended *)
@@ -436,7 +460,7 @@ let use_metas_pattern_unification flags nb l =
Array.for_all (fun c -> isRel c && destRel c <= nb) l
type key =
- | IsKey of Closure.table_key
+ | IsKey of CClosure.table_key
| IsProj of projection * constr
let expand_table_key env = function
@@ -455,8 +479,8 @@ let unfold_projection env p stk =
let expand_key ts env sigma = function
| Some (IsKey k) -> expand_table_key env k
| Some (IsProj (p, c)) ->
- let red = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma
- Cst_stack.empty (c, unfold_projection env p [])))
+ let red = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma
+ Cst_stack.empty (c, unfold_projection env p [])))
in if Term.eq_constr (mkProj (p, c)) red then None else Some red
| None -> None
@@ -481,7 +505,8 @@ let key_of env b flags f =
Id.Pred.mem id (fst flags.modulo_delta) ->
Some (IsKey (VarKey id))
| Proj (p, c) when Projection.unfolded p
- || Cpred.mem (Projection.constant p) (snd flags.modulo_delta) ->
+ || (is_transparent env (ConstKey (Projection.constant p)) &&
+ (Cpred.mem (Projection.constant p) (snd flags.modulo_delta))) ->
Some (IsProj (p, c))
| _ -> None
@@ -547,7 +572,8 @@ let constr_cmp pb sigma flags t u =
else sigma, b
let do_reduce ts (env, nb) sigma c =
- Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma Cst_stack.empty (c, Stack.empty)))
+ Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state
+ ts env sigma Cst_stack.empty (c, Stack.empty)))
let use_full_betaiota flags =
flags.modulo_betaiota && Flags.version_strictly_greater Flags.V8_3
@@ -556,6 +582,19 @@ let isAllowedEvar flags c = match kind_of_term c with
| Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars)
| _ -> false
+
+let subst_defined_metas_evars (bl,el) c =
+ let rec substrec c = match kind_of_term c with
+ | Meta i ->
+ let select (j,_,_) = Int.equal i j in
+ substrec (pi2 (List.find select bl))
+ | Evar (evk,args) ->
+ let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in
+ (try substrec (pi3 (List.find select el))
+ with Not_found -> Constr.map substrec c)
+ | _ -> Constr.map substrec c
+ in try Some (substrec c) with Not_found -> None
+
let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN =
match subst_defined_metas_evars (metasubst,[]) tyM with
| None -> sigma
@@ -592,7 +631,7 @@ let is_eta_constructor_app env ts f l1 term =
| Construct (((_, i as ind), j), u) when i == 0 && j == 1 ->
let mib = lookup_mind (fst ind) env in
(match mib.Declarations.mind_record with
- | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite &&
+ | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite &&
Array.length projs == Array.length l1 - mib.Declarations.mind_nparams ->
(** Check that the other term is neutral *)
is_neutral env ts term
@@ -619,7 +658,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
and cN = Evarutil.whd_head_evar sigma curn in
let () =
if !debug_unification then
- msg_debug (Termops.print_constr_env curenv cM ++ str" ~= " ++ Termops.print_constr_env curenv cN)
+ Feedback.msg_debug (Termops.print_constr_env curenv cM ++ str" ~= " ++ Termops.print_constr_env curenv cN)
in
match (kind_of_term cM,kind_of_term cN) with
| Meta k1, Meta k2 ->
@@ -704,7 +743,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
then Evd.set_leq_sort curenv sigma s1 s2
else Evd.set_eq_sort curenv sigma s1 s2
in (sigma', metasubst, evarsubst)
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
error_cannot_unify curenv sigma (m,n))
| Lambda (na,t1,c1), Lambda (_,t2,c2) ->
@@ -1016,12 +1055,14 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
else error_cannot_unify (fst curenvnb) sigma (cM,cN)
in
- if !debug_unification then msg_debug (str "Starting unification");
+ if !debug_unification then Feedback.msg_debug (str "Starting unification");
let opt = { at_top = conv_at_top; with_types = false; with_cs = true } in
try
let res =
- if occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n
- || subterm_restriction opt flags then None
+ if subterm_restriction opt flags ||
+ occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n
+ then
+ None
else
let sigma, b = match flags.modulo_conv_on_closed_terms with
| Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n
@@ -1037,11 +1078,12 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
let a = match res with
| Some sigma -> sigma, ms, es
| None -> unirec_rec (env,0) cv_pb opt subst m n in
- if !debug_unification then msg_debug (str "Leaving unification with success");
+ if !debug_unification then Feedback.msg_debug (str "Leaving unification with success");
a
with e ->
- if !debug_unification then msg_debug (str "Leaving unification with failure");
- raise e
+ let e = CErrors.push e in
+ if !debug_unification then Feedback.msg_debug (str "Leaving unification with failure");
+ iraise e
let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env
@@ -1050,7 +1092,7 @@ let left = true
let right = false
let rec unify_with_eta keptside flags env sigma c1 c2 =
-(* Question: try whd_betadeltaiota on ci if not two lambdas? *)
+(* Question: try whd_all on ci if not two lambdas? *)
match kind_of_term c1, kind_of_term c2 with
| (Lambda (na,t1,c1'), Lambda (_,t2,c2')) ->
let env' = push_rel_assum (na,t1) env in
@@ -1098,11 +1140,11 @@ let merge_instances env sigma flags st1 st2 c1 c2 =
else (right, st2, res)
| (IsSuperType,IsSubType) ->
(try (left, IsSubType, unify_0 env sigma CUMUL flags c2 c1)
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
(right, IsSubType, unify_0 env sigma CUMUL flags c1 c2))
| (IsSubType,IsSuperType) ->
(try (left, IsSuperType, unify_0 env sigma CUMUL flags c1 c2)
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
(right, IsSuperType, unify_0 env sigma CUMUL flags c2 c1))
(* Unification
@@ -1154,31 +1196,31 @@ let merge_instances env sigma flags st1 st2 c1 c2 =
* close it off. But this might not always work,
* since other metavars might also need to be resolved. *)
-let applyHead env evd n c =
- let rec apprec n c cty evd =
+let applyHead env (type r) (evd : r Sigma.t) n c =
+ let rec apprec : type s. _ -> _ -> _ -> (r, s) Sigma.le -> s Sigma.t -> (constr, r) Sigma.sigma =
+ fun n c cty p evd ->
if Int.equal n 0 then
- (evd, c)
+ Sigma (c, evd, p)
else
- match kind_of_term (whd_betadeltaiota env evd cty) with
+ match kind_of_term (whd_all env (Sigma.to_evar_map evd) cty) with
| Prod (_,c1,c2) ->
- let (evd',evar) =
- Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
- apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
+ let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
+ apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd'
| _ -> error "Apply_Head_Then"
in
- apprec n c (Typing.unsafe_type_of env evd c) evd
-
+ apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c) Sigma.refl evd
+
let is_mimick_head ts f =
match kind_of_term f with
- | Const (c,u) -> not (Closure.is_transparent_constant ts c)
- | Var id -> not (Closure.is_transparent_variable ts id)
+ | Const (c,u) -> not (CClosure.is_transparent_constant ts c)
+ | Var id -> not (CClosure.is_transparent_variable ts id)
| (Rel _|Construct _|Ind _) -> true
| _ -> false
let try_to_coerce env evd c cty tycon =
let j = make_judge c cty in
let (evd',j') = inh_conv_coerce_rigid_to true Loc.ghost env evd j tycon in
- let evd' = Evarconv.consider_remaining_unif_problems env evd' in
+ let evd' = Evarconv.solve_unif_constraints_with_heuristics env evd' in
let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in
(evd',j'.uj_val)
@@ -1228,7 +1270,11 @@ let solve_simple_evar_eqn ts env evd ev rhs =
| UnifFailure (evd,reason) ->
error_cannot_unify env evd ~reason (mkEvar ev,rhs);
| Success evd ->
- Evarconv.consider_remaining_unif_problems env evd
+ if Flags.version_less_or_equal Flags.V8_5 then
+ (* We used to force solving unrelated problems at arbitrary times *)
+ Evarconv.solve_unif_constraints_with_heuristics env evd
+ else (* solve_simple_eqn calls reconsider_unif_constraints itself *)
+ evd
(* [w_merge env sigma b metas evars] merges common instances in metas
or in evars, possibly generating new unification problems; if [b]
@@ -1255,7 +1301,6 @@ let w_merge env with_types flags (evd,metas,evars) =
if is_mimick_head flags.modulo_delta f then
let evd' =
mimick_undefined_evar evd flags f (Array.length cl) evk in
- (* let evd' = Evarconv.consider_remaining_unif_problems env evd' in *)
w_merge_rec evd' metas evars eqns
else
let evd' =
@@ -1303,7 +1348,7 @@ let w_merge env with_types flags (evd,metas,evars) =
else
let evd' =
if occur_meta_evd evd mv c then
- if isMetaOf mv (whd_betadeltaiota env evd c) then evd
+ if isMetaOf mv (whd_all env evd c) then evd
else error_cannot_unify env evd (mkMeta mv,c)
else
meta_assign mv (c,(status,TypeProcessed)) evd in
@@ -1313,7 +1358,7 @@ let w_merge env with_types flags (evd,metas,evars) =
let rec process_eqns failures = function
| (mv,status,c)::eqns ->
(match (try Inl (unify_type env evd flags mv status c)
- with e when Errors.noncritical e -> Inr e)
+ with e when CErrors.noncritical e -> Inr e)
with
| Inr e -> process_eqns (((mv,status,c),e)::failures) eqns
| Inl (evd,metas,evars) ->
@@ -1327,7 +1372,9 @@ let w_merge env with_types flags (evd,metas,evars) =
and mimick_undefined_evar evd flags hdc nargs sp =
let ev = Evd.find_undefined evd sp in
let sp_env = Global.env_of_context ev.evar_hyps in
- let (evd', c) = applyHead sp_env evd nargs hdc in
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (c, evd', _) = applyHead sp_env evd nargs hdc in
+ let evd' = Sigma.to_evar_map evd' in
let (evd'',mc,ec) =
unify_0 sp_env evd' CUMUL flags
(get_type_of sp_env evd' c) ev.evar_concl in
@@ -1345,10 +1392,11 @@ let w_merge env with_types flags (evd,metas,evars) =
in w_merge_rec evd [] [] eqns
in
let res = (* merge constraints *)
- w_merge_rec evd (order_metas metas) (List.rev evars) []
+ w_merge_rec evd (order_metas metas)
+ (* Assign evars in the order of assignments during unification *)
+ (List.rev evars) []
in
- if with_types then check_types res
- else res
+ if with_types then check_types res else res
let w_unify_meta_types env ?(flags=default_unify_flags ()) evd =
let metas,evd = retract_coercible_metas evd in
@@ -1406,7 +1454,7 @@ let w_typed_unify_array env evd flags f1 l1 f2 l2 =
let subst = Array.fold_left2 fold_subst subst l1 l2 in
let evd = w_merge env true flags.merge_unify_flags subst in
try_resolve_typeclasses env evd flags.resolve_evars
- (mkApp(f1,l1)) (mkApp(f2,l2))
+ (mkApp(f1,l1)) (mkApp(f2,l2))
(* takes a substitution s, an open term op and a closed term cl
try to find a subterm of cl which matches op, if op is just a Meta
@@ -1430,15 +1478,16 @@ let indirectly_dependent c d decls =
it is needed otherwise, as e.g. when abstracting over "2" in
"forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious
way to see that the second hypothesis depends indirectly over 2 *)
- List.exists (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls
+ List.exists (fun d' -> dependent_in_decl (mkVar (get_id d')) d) decls
let indirect_dependency d decls =
- pi1 (List.hd (List.filter (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls))
+ decls |> List.filter (fun d' -> dependent_in_decl (mkVar (get_id d')) d) |> List.hd |> get_id
let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) =
+ let current_sigma = Sigma.to_evar_map current_sigma in
let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in
let sigma, subst = nf_univ_variables sigma in
- sigma, subst_univs_constr subst (nf_evar sigma c)
+ Sigma.Unsafe.of_pair (subst_univs_constr subst (nf_evar sigma c), sigma)
let default_matching_core_flags sigma =
let ts = Names.full_transparent_state in {
@@ -1450,9 +1499,7 @@ let default_matching_core_flags sigma =
check_applied_meta_types = true;
use_pattern_unification = false;
use_meta_bound_pattern_unification = false;
- frozen_evars =
- fold_undefined (fun evk _ evars -> Evar.Set.add evk evars)
- sigma Evar.Set.empty;
+ frozen_evars = Evar.Map.domain (Evd.undefined_map sigma);
restrict_conv_on_strict_subterms = false;
modulo_betaiota = false;
modulo_eta = false;
@@ -1514,11 +1561,12 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) =
| PretypeError (_,_,CannotUnify (c1,c2,Some e)) ->
raise (NotUnifiable (Some (c1,c2,e)))
(** MS: This is pretty bad, it catches Not_found for example *)
- | e when Errors.noncritical e -> raise (NotUnifiable None) in
+ | e when CErrors.noncritical e -> raise (NotUnifiable None) in
let merge_fun c1 c2 =
match c1, c2 with
- | Some (evd,c1,_) as x, Some (_,c2,_) ->
- if is_conv env sigma c1 c2 then x else raise (NotUnifiable None)
+ | Some (evd,c1,x), Some (_,c2,_) ->
+ let (evd,b) = infer_conv ~pb:CONV env evd c1 c2 in
+ if b then Some (evd, c1, x) else raise (NotUnifiable None)
| Some _, None -> c1
| None, Some _ -> c2
| None, None -> None in
@@ -1543,7 +1591,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
let x = id_of_name_using_hdchar (Global.env()) t name in
let ids = ids_of_named_context (named_context env) in
if name == Anonymous then next_ident_away_in_goal x ids else
- if mem_named_context x (named_context env) then
+ if mem_named_context_val x (named_context_val env) then
errorlabstrm "Unification.make_abstraction_core"
(str "The variable " ++ Nameops.pr_id x ++ str " is already declared.")
else
@@ -1551,21 +1599,15 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
in
let likefirst = clause_with_generic_occurrences occs in
let mkvarid () = mkVar id in
- let compute_dependency _ (hyp,_,_ as d) (sign,depdecls) =
+ let compute_dependency _ d (sign,depdecls) =
+ let hyp = get_id d in
match occurrences_of_hyp hyp occs with
| NoOccurrences, InHyp ->
- if indirectly_dependent c d depdecls then
- (* Told explicitly not to abstract over [d], but it is dependent *)
- let id' = indirect_dependency d depdecls in
- errorlabstrm "" (str "Cannot abstract over " ++ Nameops.pr_id id'
- ++ str " without also abstracting or erasing " ++ Nameops.pr_id hyp
- ++ str ".")
- else
- (push_named_context_val d sign,depdecls)
+ (push_named_context_val d sign,depdecls)
| AllOccurrences, InHyp as occ ->
let occ = if likefirst then LikeFirst else AtOccs occ in
let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in
- if Context.eq_named_declaration d newdecl
+ if Context.Named.Declaration.equal d newdecl
&& not (indirectly_dependent c d depdecls)
then
if check_occs && not (in_every_hyp occs)
@@ -1588,8 +1630,12 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
replace_term_occ_modulo occ test mkvarid concl
in
let lastlhyp =
- if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in
- (id,sign,depdecls,lastlhyp,ccl,out test)
+ if List.is_empty depdecls then None else Some (get_id (List.last depdecls)) in
+ let res = match out test with
+ | None -> None
+ | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma))
+ in
+ (id,sign,depdecls,lastlhyp,ccl,res)
with
SubtermUnificationError e ->
raise (PretypeError (env,sigma,CannotUnifyOccurrences e))
@@ -1611,12 +1657,13 @@ type abstraction_request =
| AbstractPattern of prefix_of_inductive_support_flag * (types -> bool) * Name.t * pending_constr * clause * bool
| AbstractExact of Name.t * constr * types option * clause * bool
-type abstraction_result =
+type 'r abstraction_result =
Names.Id.t * named_context_val *
- Context.named_declaration list * Names.Id.t option *
- types * (Evd.evar_map * constr) option
+ Context.Named.Declaration.t list * Names.Id.t option *
+ types * (constr, 'r) Sigma.sigma option
let make_abstraction env evd ccl abs =
+ let evd = Sigma.to_evar_map evd in
match abs with
| AbstractPattern (from_prefix,check,name,c,occs,check_occs) ->
make_abstraction_core name
@@ -1791,17 +1838,25 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t =
let allow_K = flags.allow_K_in_toplevel_higher_order_unification in
let flags =
if occur_meta_or_existential op || !keyed_unification then
+ (* This is up to delta for subterms w/o metas ... *)
flags
else
(* up to Nov 2014, unification was bypassed on evar/meta-free terms;
now it is called in a minimalistic way, at least to possibly
unify pre-existing non frozen evars of the goal or of the
pattern *)
- set_no_delta_flags flags in
+ set_no_delta_flags flags in
+ let t' = (strip_outer_cast op,t) in
let (evd',cl) =
try
- (* This is up to delta for subterms w/o metas ... *)
- w_unify_to_subterm env evd ~flags (strip_outer_cast op,t)
+ if is_keyed_unification () then
+ try (* First try finding a subterm w/o conversion on open terms *)
+ let flags = set_no_delta_open_flags flags in
+ w_unify_to_subterm env evd ~flags t'
+ with e ->
+ (* If this fails, try with full conversion *)
+ w_unify_to_subterm env evd ~flags t'
+ else w_unify_to_subterm env evd ~flags t'
with PretypeError (env,_,NoOccurrenceFound _) when
allow_K ||
(* w_unify_to_subterm does not go through evars, so
@@ -1828,21 +1883,14 @@ let secondOrderAbstraction env evd flags typ (p, oplist) =
error_wrong_abstraction_type env evd'
(Evd.meta_name evd p) pred typp predtyp;
w_merge env false flags.merge_unify_flags
- (evd',[p,pred,(Conv,TypeProcessed)],[])
-
- (* let evd',metas,evars = *)
- (* try unify_0 env evd' CUMUL flags predtyp typp *)
- (* with NotConvertible -> *)
- (* error_wrong_abstraction_type env evd *)
- (* (Evd.meta_name evd p) pred typp predtyp *)
- (* in *)
- (* w_merge env false flags (evd',(p,pred,(Conv,TypeProcessed))::metas,evars) *)
+ (evd',[p,pred,(Conv,TypeProcessed)],[])
let secondOrderDependentAbstraction env evd flags typ (p, oplist) =
let typp = Typing.meta_type evd p in
let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in
w_merge env false flags.merge_unify_flags
- (evd,[p,pred,(Conv,TypeProcessed)],[])
+ (evd,[p,pred,(Conv,TypeProcessed)],[])
+
let secondOrderAbstractionAlgo dep =
if dep then secondOrderDependentAbstraction else secondOrderAbstraction
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index d5d5caf9..0ad882a9 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -75,15 +75,15 @@ type abstraction_request =
| AbstractExact of Names.Name.t * constr * types option * Locus.clause * bool
val finish_evar_resolution : ?flags:Pretyping.inference_flags ->
- env -> Evd.evar_map -> pending_constr -> Evd.evar_map * constr
+ env -> 'r Sigma.t -> pending_constr -> (constr, 'r) Sigma.sigma
-type abstraction_result =
+type 'r abstraction_result =
Names.Id.t * named_context_val *
- Context.named_declaration list * Names.Id.t option *
- types * (Evd.evar_map * constr) option
+ Context.Named.Declaration.t list * Names.Id.t option *
+ types * (constr, 'r) Sigma.sigma option
-val make_abstraction : env -> Evd.evar_map -> constr ->
- abstraction_request -> abstraction_result
+val make_abstraction : env -> 'r Sigma.t -> constr ->
+ abstraction_request -> 'r abstraction_result
val pose_all_metas_as_evars : env -> evar_map -> constr -> evar_map * constr
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 7d86fad9..e281f22d 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -15,6 +15,7 @@ open Environ
open Inductive
open Reduction
open Vm
+open Context.Rel.Declaration
(*******************************************)
(* Calcul de la forme normal d'un terme *)
@@ -23,7 +24,7 @@ open Vm
let crazy_type = mkSet
let decompose_prod env t =
- let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in
+ let (name,dom,codom as res) = destProd (whd_all env t) in
match name with
| Anonymous -> (Name (Id.of_string "x"), dom, codom)
| Name _ -> res
@@ -46,12 +47,10 @@ let invert_tag cst tag reloc_tbl =
(* Argggg, ces constructeurs de ... qui commencent a 1*)
let find_rectype_a env c =
- let (t, l) =
- let t = whd_betadeltaiota env c in
- try destApp t with DestKO -> (t,[||]) in
+ let (t, l) = decompose_appvect (whd_all env c) in
match kind_of_term t with
| Ind ind -> (ind, l)
- | _ -> raise Not_found
+ | _ -> assert false
(* Instantiate inductives and parameters in constructor type *)
@@ -59,11 +58,11 @@ let type_constructor mind mib u typ params =
let s = ind_subst mind mib u in
let ctyp = substl s typ in
let ctyp = subst_instance_constr u ctyp in
- let ndecls = Context.rel_context_length mib.mind_params_ctxt in
+ let ndecls = Context.Rel.length mib.mind_params_ctxt in
if Int.equal ndecls 0 then ctyp
else
let _,ctyp = decompose_prod_n_assum ndecls ctyp in
- substl (List.rev (Termops.adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params)))
+ substl (List.rev (adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params)))
ctyp
@@ -140,7 +139,7 @@ and nf_whd env whd typ =
let dom = nf_vtype env (dom p) in
let name = Name (Id.of_string "x") in
let vc = body_of_vfun (nb_rel env) (codom p) in
- let codom = nf_vtype (push_rel (name,None,dom) env) vc in
+ let codom = nf_vtype (push_rel (LocalAssum (name,dom)) env) vc in
mkProd(name,dom,codom)
| Vfun f -> nf_fun env f typ
| Vfix(f,None) -> nf_fix env f
@@ -208,11 +207,12 @@ and constr_type_of_idkey env (idkey : Vars.id_key) stk =
in
nf_univ_args ~nb_univs mk env stk
| VarKey id ->
- let (_,_,ty) = lookup_named id env in
+ let open Context.Named.Declaration in
+ let ty = get_type (lookup_named id env) in
nf_stk env (mkVar id) ty stk
| RelKey i ->
let n = (nb_rel env - i) in
- let (_,_,ty) = lookup_rel n env in
+ let ty = get_type (lookup_rel n env) in
nf_stk env (mkRel n) (lift n ty) stk
and nf_stk ?from:(from=0) env c t stk =
@@ -238,7 +238,7 @@ and nf_stk ?from:(from=0) env c t stk =
let params,realargs = Util.Array.chop nparams allargs in
let pT =
hnf_prod_applist env (type_of_ind env (ind,u)) (Array.to_list params) in
- let pT = whd_betadeltaiota env pT in
+ let pT = whd_all env pT in
let dep, p = nf_predicate env (ind,u) mip params (type_of_switch sw) pT in
(* Calcul du type des branches *)
let btypes = build_branches_type env ind mib mip u params dep p in
@@ -266,7 +266,7 @@ and nf_predicate env ind mip params v pT =
let vb = body_of_vfun k f in
let name,dom,codom = decompose_prod env pT in
let dep,body =
- nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in
+ nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in
dep, mkLambda(name,dom,body)
| Vfun f, _ ->
let k = nb_rel env in
@@ -276,7 +276,7 @@ and nf_predicate env ind mip params v pT =
let rargs = Array.init n (fun i -> mkRel (n-i)) in
let params = if Int.equal n 0 then params else Array.map (lift n) params in
let dom = mkApp(mkIndU ind,Array.append params rargs) in
- let body = nf_vtype (push_rel (name,None,dom) env) vb in
+ let body = nf_vtype (push_rel (LocalAssum (name,dom)) env) vb in
true, mkLambda(name,dom,body)
| _, _ -> false, nf_val env v crazy_type
@@ -309,10 +309,10 @@ and nf_fun env f typ =
try decompose_prod env typ
with DestKO ->
(* 27/2/13: Turned this into an anomaly *)
- Errors.anomaly
+ CErrors.anomaly
(Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
in
- let body = nf_val (push_rel (name,None,dom) env) vb codom in
+ let body = nf_val (push_rel (LocalAssum (name,dom)) env) vb codom in
mkLambda(name,dom,body)
and nf_fix env f =
diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli
index bdc6c1db..58f5b14e 100644
--- a/pretyping/vnorm.mli
+++ b/pretyping/vnorm.mli
@@ -8,7 +8,6 @@
open Term
open Environ
-open Evd
(** {6 Reduction functions } *)
val cbv_vm : env -> constr -> types -> constr
diff --git a/printing/genprint.ml b/printing/genprint.ml
index d4f792b7..0ec35e07 100644
--- a/printing/genprint.ml
+++ b/printing/genprint.ml
@@ -19,8 +19,9 @@ module PrintObj =
struct
type ('raw, 'glb, 'top) obj = ('raw, 'glb, 'top) printer
let name = "printer"
- let default wit = match unquote (rawwit wit) with
- | ExtraArgType name ->
+ let default wit = match wit with
+ | ExtraArg tag ->
+ let name = ArgT.repr tag in
let printer = {
raw = (fun _ -> str "");
glb = (fun _ -> str "");
@@ -40,6 +41,6 @@ let raw_print wit v = (Print.obj wit).raw v
let glb_print wit v = (Print.obj wit).glb v
let top_print wit v = (Print.obj wit).top v
-let generic_raw_print v = unpack { unpacker = fun w v -> raw_print w (raw v); } v
-let generic_glb_print v = unpack { unpacker = fun w v -> glb_print w (glb v); } v
-let generic_top_print v = unpack { unpacker = fun w v -> top_print w (top v); } v
+let generic_raw_print (GenArg (Rawwit w, v)) = raw_print w v
+let generic_glb_print (GenArg (Glbwit w, v)) = glb_print w v
+let generic_top_print (GenArg (Topwit w, v)) = top_print w v
diff --git a/printing/miscprint.ml b/printing/miscprint.ml
index 22db3d0b..7b2c5695 100644
--- a/printing/miscprint.ml
+++ b/printing/miscprint.ml
@@ -28,14 +28,14 @@ and pr_intro_pattern_action prc = function
| IntroInjection pl ->
str "[=" ++ hv 0 (prlist_with_sep spc (pr_intro_pattern prc) pl) ++
str "]"
- | IntroApplyOn (c,pat) -> pr_intro_pattern prc pat ++ str "/" ++ prc c
+ | IntroApplyOn (c,pat) -> pr_intro_pattern prc pat ++ str "%" ++ prc c
| IntroRewrite true -> str "->"
| IntroRewrite false -> str "<-"
and pr_or_and_intro_pattern prc = function
- | [pl] ->
+ | IntroAndPattern pl ->
str "(" ++ hv 0 (prlist_with_sep pr_comma (pr_intro_pattern prc) pl) ++ str ")"
- | pll ->
+ | IntroOrPattern pll ->
str "[" ++
hv 0 (prlist_with_sep pr_bar (prlist_with_sep spc (pr_intro_pattern prc)) pll)
++ str "]"
diff --git a/printing/ppannotation.ml b/printing/ppannotation.ml
index df7f925b..511f9356 100644
--- a/printing/ppannotation.ml
+++ b/printing/ppannotation.ml
@@ -20,7 +20,6 @@ type t =
| AGlobAtomicTacticExpr of glob_atomic_tactic_expr
| ARawTacticExpr of raw_tactic_expr
| ARawAtomicTacticExpr of raw_atomic_tactic_expr
- | ATacticExpr of tactic_expr
| AAtomicTacticExpr of atomic_tactic_expr
let tag_of_annotation = function
@@ -32,7 +31,6 @@ let tag_of_annotation = function
| AGlobAtomicTacticExpr _ -> "glob_atomic_tactic_expr"
| ARawTacticExpr _ -> "raw_tactic_expr"
| ARawAtomicTacticExpr _ -> "raw_atomic_tactic_expr"
- | ATacticExpr _ -> "tactic_expr"
| AAtomicTacticExpr _ -> "atomic_tactic_expr"
let attributes_of_annotation a =
diff --git a/printing/ppannotation.mli b/printing/ppannotation.mli
index 84724053..a0fef1a7 100644
--- a/printing/ppannotation.mli
+++ b/printing/ppannotation.mli
@@ -23,7 +23,6 @@ type t =
| AGlobAtomicTacticExpr of glob_atomic_tactic_expr
| ARawTacticExpr of raw_tactic_expr
| ARawAtomicTacticExpr of raw_atomic_tactic_expr
- | ATacticExpr of tactic_expr
| AAtomicTacticExpr of atomic_tactic_expr
val tag_of_annotation : t -> string
diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml
index e21bfa00..aa94fb7b 100644
--- a/printing/ppconstr.ml
+++ b/printing/ppconstr.ml
@@ -7,7 +7,7 @@
(************************************************************************)
(*i*)
-open Errors
+open CErrors
open Util
open Pp
open Names
@@ -129,15 +129,13 @@ end) = struct
str "`" ++ str hd ++ c ++ str tl
let pr_com_at n =
- if Flags.do_beautify() && not (Int.equal n 0) then comment n
+ if !Flags.beautify && not (Int.equal n 0) then comment (CLexer.extract_comments n)
else mt()
let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp)
let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c)
- let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)"
-
let pr_univ l =
match l with
| [_,x] -> str x
@@ -151,13 +149,19 @@ end) = struct
| GType [] -> tag_type (str "Type")
| GType u -> hov 0 (tag_type (str "Type") ++ pr_univ_annot pr_univ u)
+ let pr_glob_level = function
+ | GProp -> tag_type (str "Prop")
+ | GSet -> tag_type (str "Set")
+ | GType None -> tag_type (str "Type")
+ | GType (Some (_, u)) -> tag_type (str u)
+
let pr_qualid sp =
let (sl, id) = repr_qualid sp in
- let id = tag_ref (str (Id.to_string id)) in
+ let id = tag_ref (pr_id id) in
let sl = match List.rev (DirPath.repr sl) with
| [] -> mt ()
| sl ->
- let pr dir = tag_path (str (Id.to_string dir)) ++ str "." in
+ let pr dir = tag_path (pr_id dir) ++ str "." in
prlist pr sl
in
sl ++ id
@@ -182,7 +186,7 @@ end) = struct
let pr_reference = function
| Qualid (_, qid) -> pr_qualid qid
- | Ident (_, id) -> tag_var (str (Id.to_string id))
+ | Ident (_, id) -> tag_var (pr_id id)
let pr_cref ref us =
pr_reference ref ++ pr_universe_instance us
@@ -246,16 +250,16 @@ end) = struct
| CPatAlias (_, p, id) ->
pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las
- | CPatCstr (_,c, [], []) ->
+ | CPatCstr (_,c, None, []) ->
pr_reference c, latom
- | CPatCstr (_, c, [], args) ->
+ | CPatCstr (_, c, None, args) ->
pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
- | CPatCstr (_, c, args, []) ->
+ | CPatCstr (_, c, Some args, []) ->
str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
- | CPatCstr (_, c, expl_args, extra_args) ->
+ | CPatCstr (_, c, Some expl_args, extra_args) ->
surround (str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) expl_args)
++ prlist (pr_patt spc (lapp,L)) extra_args, lapp
@@ -281,6 +285,8 @@ end) = struct
| CPatDelimiters (_,k,p) ->
pr_delimiters k (pr_patt mt lsimplepatt p), 1
+ | CPatCast _ ->
+ assert false
in
let loc = cases_pattern_expr_loc p in
pr_with_comments loc
@@ -300,6 +306,7 @@ end) = struct
let begin_of_binder = function
LocalRawDef((loc,_),_) -> fst (Loc.unloc loc)
| LocalRawAssum((loc,_)::_,_,_) -> fst (Loc.unloc loc)
+ | LocalPattern(loc,_,_) -> fst (Loc.unloc loc)
| _ -> assert false
let begin_of_binders = function
@@ -348,6 +355,13 @@ end) = struct
| _ -> c, CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in
surround (pr_lname na ++ pr_opt_type pr_c topt ++
str":=" ++ cut() ++ pr_c c)
+ | LocalPattern (loc,p,tyo) ->
+ let p = pr_patt lsimplepatt p in
+ match tyo with
+ | None ->
+ str "'" ++ p
+ | Some ty ->
+ str "'" ++ surround (p ++ spc () ++ str ":" ++ ws 1 ++ pr_c ty)
let pr_undelimited_binders sep pr_c =
prlist_with_sep sep (pr_binder_among_many pr_c)
@@ -356,13 +370,13 @@ end) = struct
let n = begin_of_binders bl in
match bl with
| [LocalRawAssum (nal,k,t)] ->
- pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,k,t)
- | LocalRawAssum _ :: _ as bdl ->
- pr_com_at n ++ kw() ++ pr_undelimited_binders sep pr_c bdl
+ kw n ++ pr_binder false pr_c (nal,k,t)
+ | (LocalRawAssum _ | LocalPattern _) :: _ as bdl ->
+ kw n ++ pr_undelimited_binders sep pr_c bdl
| _ -> assert false
let pr_binders_gen pr_c sep is_open =
- if is_open then pr_delimited_binders mt sep pr_c
+ if is_open then pr_delimited_binders pr_com_at sep pr_c
else pr_undelimited_binders sep pr_c
let rec extract_prod_binders = function
@@ -371,6 +385,11 @@ end) = struct
if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
| CProdN (loc,[],c) ->
extract_prod_binders c
+ | CProdN (loc,[[_,Name id],bk,t],
+ CCases (_,LetPatternStyle,None, [CRef (Ident (_,id'),None),None,None],[(_,[_,[p]],b)]))
+ when Id.equal id id' && not (Id.Set.mem id (Topconstr.free_vars_of_constr_expr b)) ->
+ let bl,c = extract_prod_binders b in
+ LocalPattern (loc,p,None) :: bl, c
| CProdN (loc,(nal,bk,t)::bl,c) ->
let bl,c = extract_prod_binders (CProdN(loc,bl,c)) in
LocalRawAssum (nal,bk,t) :: bl, c
@@ -382,6 +401,11 @@ end) = struct
if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
| CLambdaN (loc,[],c) ->
extract_lam_binders c
+ | CLambdaN (loc,[[_,Name id],bk,t],
+ CCases (_,LetPatternStyle,None, [CRef (Ident (_,id'),None),None,None],[(_,[_,[p]],b)]))
+ when Id.equal id id' && not (Id.Set.mem id (Topconstr.free_vars_of_constr_expr b)) ->
+ let bl,c = extract_lam_binders b in
+ LocalPattern (loc,p,None) :: bl, c
| CLambdaN (loc,(nal,bk,t)::bl,c) ->
let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in
LocalRawAssum (nal,bk,t) :: bl, c
@@ -432,6 +456,7 @@ end) = struct
let names_of_binder = function
| LocalRawAssum (nal,_,_) -> nal
| LocalRawDef (_,_) -> []
+ | LocalPattern _ -> assert false
in let ids = List.flatten (List.map names_of_binder bl) in
if List.length ids > 1 then
spc() ++ str "{" ++ keyword "struct" ++ spc () ++ pr_id id ++ str"}"
@@ -457,7 +482,7 @@ end) = struct
(pr_decl true) dl ++
fnl() ++ keyword "for" ++ spc () ++ pr_id id
- let pr_asin pr (na,indnalopt) =
+ let pr_asin pr na indnalopt =
(match na with (* Decision of printing "_" or not moved to constrextern.ml *)
| Some na -> spc () ++ keyword "as" ++ spc () ++ pr_lname na
| None -> mt ()) ++
@@ -465,8 +490,8 @@ end) = struct
| None -> mt ()
| Some t -> spc () ++ keyword "in" ++ spc () ++ pr_patt lsimplepatt t)
- let pr_case_item pr (tm,asin) =
- hov 0 (pr (lcast,E) tm ++ pr_asin pr asin)
+ let pr_case_item pr (tm,as_clause, in_clause) =
+ hov 0 (pr (lcast,E) tm ++ pr_asin pr as_clause in_clause)
let pr_case_type pr po =
match po with
@@ -495,9 +520,14 @@ end) = struct
pr (lapp,L) a ++
prlist (fun a -> spc () ++ pr_expl_args pr a) l)
- let pr_forall () = keyword "forall" ++ spc ()
+ let pr_record_body_gen pr l =
+ spc () ++
+ prlist_with_sep pr_semicolon
+ (fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr ltop c)) l
- let pr_fun () = keyword "fun" ++ spc ()
+ let pr_forall n = keyword "forall" ++ pr_com_at n ++ spc ()
+
+ let pr_fun n = keyword "fun" ++ pr_com_at n ++ spc ()
let pr_fun_sep = spc () ++ str "=>"
@@ -595,28 +625,17 @@ end) = struct
return (p, lproj)
| CApp (_,(None,a),l) ->
return (pr_app (pr mt) a l, lapp)
- | CRecord (_,w,l) ->
- let beg =
- match w with
- | None ->
- spc ()
- | Some t ->
- spc () ++ pr spc ltop t ++ spc ()
- ++ keyword "with" ++ spc ()
- in
+ | CRecord (_,l) ->
return (
- hv 0 (str"{|" ++ beg ++
- prlist_with_sep pr_semicolon
- (fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr spc ltop c)) l
- ++ str" |}"),
+ hv 0 (str"{|" ++ pr_record_body_gen (pr spc) l ++ str" |}"),
latom
)
- | CCases (_,LetPatternStyle,rtntypopt,[c,asin],[(_,[(loc,[p])],b)]) ->
+ | CCases (_,LetPatternStyle,rtntypopt,[c,as_clause,in_clause],[(_,[(loc,[p])],b)]) ->
return (
hv 0 (
keyword "let" ++ spc () ++ str"'" ++
hov 0 (pr_patt ltop p ++
- pr_asin (pr_dangling_with_for mt pr) asin ++
+ pr_asin (pr_dangling_with_for mt pr) as_clause in_clause ++
str " :=" ++ pr spc ltop c ++
pr_case_type (pr_dangling_with_for mt pr) rtntypopt ++
spc () ++ keyword "in" ++ pr spc ltop b)),
@@ -741,6 +760,8 @@ end) = struct
let pr_cases_pattern_expr = pr_patt ltop
+ let pr_record_body = pr_record_body_gen pr
+
let pr_binders = pr_undelimited_binders spc (pr ltop)
end
@@ -778,6 +799,22 @@ end
let do_not_tag _ x = x
+let split_token tag s =
+ let len = String.length s in
+ let rec parse_string off i =
+ if Int.equal i len then
+ if Int.equal off i then mt () else tag (str (String.sub s off (i - off)))
+ else if s.[i] == ' ' then
+ if Int.equal off i then parse_space 1 (succ i)
+ else tag (str (String.sub s off (i - off))) ++ parse_space 1 (succ i)
+ else parse_string off (succ i)
+ and parse_space spc i =
+ if Int.equal i len then str (String.make spc ' ')
+ else if s.[i] == ' ' then parse_space (succ spc) (succ i)
+ else str (String.make spc ' ') ++ parse_string i (succ i)
+ in
+ parse_string 0 0
+
(** Instantiating Make with tagging functions that only add style
information. *)
include Make (struct
@@ -786,7 +823,7 @@ include Make (struct
let tag_evar = tag Tag.evar
let tag_type = tag Tag.univ
let tag_unparsing = function
- | UnpTerminal s -> tag Tag.notation
+ | UnpTerminal s -> fun _ -> split_token (fun pp -> tag Tag.notation pp) s
| _ -> do_not_tag ()
let tag_constr_expr = do_not_tag
let tag_path = tag Tag.path
diff --git a/printing/ppconstrsig.mli b/printing/ppconstrsig.mli
index c711dd8f..3de0d805 100644
--- a/printing/ppconstrsig.mli
+++ b/printing/ppconstrsig.mli
@@ -44,12 +44,14 @@ module type Pp = sig
val pr_qualid : qualid -> std_ppcmds
val pr_patvar : patvar -> std_ppcmds
+ val pr_glob_level : glob_level -> std_ppcmds
val pr_glob_sort : glob_sort -> std_ppcmds
val pr_guard_annot : (constr_expr -> std_ppcmds) ->
local_binder list ->
('a * Names.Id.t) option * recursion_order_expr ->
std_ppcmds
+ val pr_record_body : (reference * constr_expr) list -> std_ppcmds
val pr_binders : local_binder list -> std_ppcmds
val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds
val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
diff --git a/printing/pptactic.ml b/printing/pptactic.ml
index 7e903d2d..fcc30d70 100644
--- a/printing/pptactic.ml
+++ b/printing/pptactic.ml
@@ -9,11 +9,12 @@
open Pp
open Names
open Namegen
-open Errors
+open CErrors
open Util
open Constrexpr
open Tacexpr
open Genarg
+open Geninterp
open Constrarg
open Libnames
open Ppextend
@@ -26,22 +27,20 @@ open Printer
let pr_global x = Nametab.pr_global_env Id.Set.empty x
-type grammar_terminals = string option list
+type 'a grammar_tactic_prod_item_expr =
+| TacTerm of string
+| TacNonTerm of Loc.t * 'a * Names.Id.t
+
+type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list
type pp_tactic = {
- pptac_args : argument_type list;
- pptac_prods : int * grammar_terminals;
+ pptac_level : int;
+ pptac_prods : grammar_terminals;
}
-(* ML Extensions *)
-let prtac_tab = Hashtbl.create 17
-
(* Tactic notations *)
let prnotation_tab = Summary.ref ~name:"pptactic-notation" KNmap.empty
-let declare_ml_tactic_pprule key pt =
- Hashtbl.add prtac_tab (key, pt.pptac_args) pt.pptac_prods
-
let declare_notation_tactic_pprule kn pt =
prnotation_tab := KNmap.add kn pt !prnotation_tab
@@ -60,14 +59,14 @@ type 'a glob_extra_genarg_printer =
type 'a extra_genarg_printer =
(Term.constr -> std_ppcmds) ->
(Term.constr -> std_ppcmds) ->
- (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+ (tolerability -> Val.t -> std_ppcmds) ->
'a -> std_ppcmds
let genarg_pprule = ref String.Map.empty
let declare_extra_genarg_pprule wit f g h =
- let s = match unquote (topwit wit) with
- | ExtraArgType s -> s
+ let s = match wit with
+ | ExtraArg s -> ArgT.repr s
| _ -> error
"Can declare a pretty-printing rule only for extra argument types."
in
@@ -93,8 +92,6 @@ module Make
: raw_tactic_expr -> std_ppcmds -> std_ppcmds
val tag_raw_atomic_tactic_expr
: raw_atomic_tactic_expr -> std_ppcmds -> std_ppcmds
- val tag_tactic_expr
- : tactic_expr -> std_ppcmds -> std_ppcmds
val tag_atomic_tactic_expr
: atomic_tactic_expr -> std_ppcmds -> std_ppcmds
end)
@@ -105,6 +102,39 @@ module Make
let keyword x = tag_keyword (str x)
let primitive x = tag_primitive (str x)
+ let has_type (Val.Dyn (tag, x)) t = match Val.eq tag t with
+ | None -> false
+ | Some _ -> true
+
+ let unbox : type a. Val.t -> a Val.typ -> a= fun (Val.Dyn (tag, x)) t ->
+ match Val.eq tag t with
+ | None -> assert false
+ | Some Refl -> x
+
+ let rec pr_value lev v : std_ppcmds =
+ if has_type v Val.typ_list then
+ pr_sequence (fun x -> pr_value lev x) (unbox v Val.typ_list)
+ else if has_type v Val.typ_opt then
+ pr_opt_no_spc (fun x -> pr_value lev x) (unbox v Val.typ_opt)
+ else if has_type v Val.typ_pair then
+ let (v1, v2) = unbox v Val.typ_pair in
+ str "(" ++ pr_value lev v1 ++ str ", " ++ pr_value lev v2 ++ str ")"
+ else
+ let Val.Dyn (tag, x) = v in
+ let name = Val.repr tag in
+ let default = str "<" ++ str name ++ str ">" in
+ match ArgT.name name with
+ | None -> default
+ | Some (ArgT.Any arg) ->
+ let wit = ExtraArg arg in
+ match val_tag (Topwit wit) with
+ | Val.Base t ->
+ begin match Val.eq t tag with
+ | None -> default
+ | Some Refl -> Genprint.generic_top_print (in_gen (Topwit wit) x)
+ end
+ | _ -> default
+
let pr_with_occurrences pr (occs,c) =
match occs with
| AllOccurrences ->
@@ -121,7 +151,8 @@ module Make
exception ComplexRedFlag
let pr_short_red_flag pr r =
- if not r.rBeta || not r.rIota || not r.rZeta then raise ComplexRedFlag
+ if not r.rBeta || not r.rMatch || not r.rFix || not r.rCofix || not r.rZeta then
+ raise ComplexRedFlag
else if List.is_empty r.rConst then
if r.rDelta then mt () else raise ComplexRedFlag
else (if r.rDelta then str "-" else mt ()) ++
@@ -131,9 +162,12 @@ module Make
try pr_short_red_flag pr r
with complexRedFlags ->
(if r.rBeta then pr_arg str "beta" else mt ()) ++
- (if r.rIota then pr_arg str "iota" else mt ()) ++
- (if r.rZeta then pr_arg str "zeta" else mt ()) ++
- (if List.is_empty r.rConst then
+ (if r.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else
+ (if r.rMatch then pr_arg str "match" else mt ()) ++
+ (if r.rFix then pr_arg str "fix" else mt ()) ++
+ (if r.rCofix then pr_arg str "cofix" else mt ())) ++
+ (if r.rZeta then pr_arg str "zeta" else mt ()) ++
+ (if List.is_empty r.rConst then
if r.rDelta then pr_arg str "delta"
else mt ()
else
@@ -150,7 +184,8 @@ module Make
| Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f)
++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o
| Cbv f ->
- if f.rBeta && f.rIota && f.rZeta && f.rDelta && List.is_empty f.rConst then
+ if f.rBeta && f.rMatch && f.rFix && f.rCofix &&
+ f.rZeta && f.rDelta && List.is_empty f.rConst then
keyword "compute"
else
hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f)
@@ -184,7 +219,7 @@ module Make
| ConstrContext ((_,id),c) ->
hov 0
(keyword "context" ++ spc () ++ pr_id id ++ spc () ++
- str "[" ++ prlc c ++ str "]")
+ str "[ " ++ prlc c ++ str " ]")
| ConstrTypeOf c ->
hov 1 (keyword "type of" ++ spc() ++ prc c)
| ConstrTerm c when test c ->
@@ -240,8 +275,10 @@ module Make
| NoBindings -> mt ()
let pr_clear_flag clear_flag pp x =
- (match clear_flag with Some false -> str "!" | Some true -> str ">" | None -> mt())
- ++ pp x
+ match clear_flag with
+ | Some false -> surround (pp x)
+ | Some true -> str ">" ++ pp x
+ | None -> pp x
let pr_with_bindings prc prlc (c,bl) =
prc c ++ pr_bindings prc prlc bl
@@ -263,193 +300,177 @@ module Make
let with_evars ev s = if ev then "e" ^ s else s
+ let hov_if_not_empty n p = if Pp.ismt p then p else hov n p
- let rec pr_raw_generic prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) =
- match Genarg.genarg_tag x with
- | IntOrVarArgType -> pr_or_var int (out_gen (rawwit wit_int_or_var) x)
- | IdentArgType -> pr_id (out_gen (rawwit wit_ident) x)
- | VarArgType -> pr_located pr_id (out_gen (rawwit wit_var) x)
- | GenArgType -> pr_raw_generic prc prlc prtac prpat prref (out_gen (rawwit wit_genarg) x)
- | ConstrArgType -> prc (out_gen (rawwit wit_constr) x)
- | ConstrMayEvalArgType ->
- pr_may_eval prc prlc (pr_or_by_notation prref) prpat
- (out_gen (rawwit wit_constr_may_eval) x)
- | QuantHypArgType -> pr_quantified_hypothesis (out_gen (rawwit wit_quant_hyp) x)
- | RedExprArgType ->
- pr_red_expr (prc,prlc,pr_or_by_notation prref,prpat)
- (out_gen (rawwit wit_red_expr) x)
- | OpenConstrArgType -> prc (snd (out_gen (rawwit wit_open_constr) x))
- | ConstrWithBindingsArgType ->
- pr_with_bindings prc prlc (out_gen (rawwit wit_constr_with_bindings) x)
- | BindingsArgType ->
- pr_bindings_no_with prc prlc (out_gen (rawwit wit_bindings) x)
- | ListArgType _ ->
- let list_unpacker wit l =
- let map x = pr_raw_generic prc prlc prtac prpat prref (in_gen (rawwit wit) x) in
- pr_sequence map (raw l)
- in
- hov 0 (list_unpack { list_unpacker } x)
- | OptArgType _ ->
- let opt_unpacker wit o = match raw o with
- | None -> mt ()
- | Some x -> pr_raw_generic prc prlc prtac prpat prref (in_gen (rawwit wit) x)
- in
- hov 0 (opt_unpack { opt_unpacker } x)
- | PairArgType _ ->
- let pair_unpacker wit1 wit2 o =
- let p, q = raw o in
- let p = in_gen (rawwit wit1) p in
- let q = in_gen (rawwit wit2) q in
- pr_sequence (pr_raw_generic prc prlc prtac prpat prref) [p; q]
- in
- hov 0 (pair_unpack { pair_unpacker } x)
- | ExtraArgType s ->
- try pi1 (String.Map.find s !genarg_pprule) prc prlc prtac x
- with Not_found -> Genprint.generic_raw_print x
-
-
- let rec pr_glb_generic prc prlc prtac prpat x =
- match Genarg.genarg_tag x with
- | IntOrVarArgType -> pr_or_var int (out_gen (glbwit wit_int_or_var) x)
- | IdentArgType -> pr_id (out_gen (glbwit wit_ident) x)
- | VarArgType -> pr_located pr_id (out_gen (glbwit wit_var) x)
- | GenArgType -> pr_glb_generic prc prlc prtac prpat (out_gen (glbwit wit_genarg) x)
- | ConstrArgType -> prc (out_gen (glbwit wit_constr) x)
- | ConstrMayEvalArgType ->
- pr_may_eval prc prlc
- (pr_or_var (pr_and_short_name pr_evaluable_reference)) prpat
- (out_gen (glbwit wit_constr_may_eval) x)
- | QuantHypArgType ->
- pr_quantified_hypothesis (out_gen (glbwit wit_quant_hyp) x)
- | RedExprArgType ->
- pr_red_expr
- (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference),prpat)
- (out_gen (glbwit wit_red_expr) x)
- | OpenConstrArgType -> prc (snd (out_gen (glbwit wit_open_constr) x))
- | ConstrWithBindingsArgType ->
- pr_with_bindings prc prlc (out_gen (glbwit wit_constr_with_bindings) x)
- | BindingsArgType ->
- pr_bindings_no_with prc prlc (out_gen (glbwit wit_bindings) x)
- | ListArgType _ ->
- let list_unpacker wit l =
- let map x = pr_glb_generic prc prlc prtac prpat (in_gen (glbwit wit) x) in
- pr_sequence map (glb l)
- in
- hov 0 (list_unpack { list_unpacker } x)
- | OptArgType _ ->
- let opt_unpacker wit o = match glb o with
+ let rec pr_raw_generic_rec prc prlc prtac prpat prref (GenArg (Rawwit wit, x)) =
+ match wit with
+ | ListArg wit ->
+ let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in
+ let ans = pr_sequence map x in
+ hov_if_not_empty 0 ans
+ | OptArg wit ->
+ let ans = match x with
| None -> mt ()
- | Some x -> pr_glb_generic prc prlc prtac prpat (in_gen (glbwit wit) x)
+ | Some x -> pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x)
in
- hov 0 (opt_unpack { opt_unpacker } x)
- | PairArgType _ ->
- let pair_unpacker wit1 wit2 o =
- let p, q = glb o in
- let p = in_gen (glbwit wit1) p in
- let q = in_gen (glbwit wit2) q in
- pr_sequence (pr_glb_generic prc prlc prtac prpat) [p; q]
- in
- hov 0 (pair_unpack { pair_unpacker } x)
- | ExtraArgType s ->
- try pi2 (String.Map.find s !genarg_pprule) prc prlc prtac x
- with Not_found -> Genprint.generic_glb_print x
-
- let rec pr_top_generic prc prlc prtac prpat x =
- match Genarg.genarg_tag x with
- | IntOrVarArgType -> pr_or_var int (out_gen (topwit wit_int_or_var) x)
- | IdentArgType -> pr_id (out_gen (topwit wit_ident) x)
- | VarArgType -> pr_id (out_gen (topwit wit_var) x)
- | GenArgType -> pr_top_generic prc prlc prtac prpat (out_gen (topwit wit_genarg) x)
- | ConstrArgType -> prc (out_gen (topwit wit_constr) x)
- | ConstrMayEvalArgType -> prc (out_gen (topwit wit_constr_may_eval) x)
- | QuantHypArgType -> pr_quantified_hypothesis (out_gen (topwit wit_quant_hyp) x)
- | RedExprArgType ->
- pr_red_expr (prc,prlc,pr_evaluable_reference,prpat)
- (out_gen (topwit wit_red_expr) x)
- | OpenConstrArgType -> prc (snd (out_gen (topwit wit_open_constr) x))
- | ConstrWithBindingsArgType ->
- let (c,b) = (out_gen (topwit wit_constr_with_bindings) x).Evd.it in
- pr_with_bindings prc prlc (c,b)
- | BindingsArgType ->
- pr_bindings_no_with prc prlc (out_gen (topwit wit_bindings) x).Evd.it
- | ListArgType _ ->
- let list_unpacker wit l =
- let map x = pr_top_generic prc prlc prtac prpat (in_gen (topwit wit) x) in
- pr_sequence map (top l)
- in
- hov 0 (list_unpack { list_unpacker } x)
- | OptArgType _ ->
- let opt_unpacker wit o = match top o with
+ hov_if_not_empty 0 ans
+ | PairArg (wit1, wit2) ->
+ let p, q = x in
+ let p = in_gen (rawwit wit1) p in
+ let q = in_gen (rawwit wit2) q in
+ hov_if_not_empty 0 (pr_sequence (pr_raw_generic_rec prc prlc prtac prpat prref) [p; q])
+ | ExtraArg s ->
+ try pi1 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (rawwit wit) x)
+ with Not_found -> Genprint.generic_raw_print (in_gen (rawwit wit) x)
+
+
+ let rec pr_glb_generic_rec prc prlc prtac prpat (GenArg (Glbwit wit, x)) =
+ match wit with
+ | ListArg wit ->
+ let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in
+ let ans = pr_sequence map x in
+ hov_if_not_empty 0 ans
+ | OptArg wit ->
+ let ans = match x with
| None -> mt ()
- | Some x -> pr_top_generic prc prlc prtac prpat (in_gen (topwit wit) x)
- in
- hov 0 (opt_unpack { opt_unpacker } x)
- | PairArgType _ ->
- let pair_unpacker wit1 wit2 o =
- let p, q = top o in
- let p = in_gen (topwit wit1) p in
- let q = in_gen (topwit wit2) q in
- pr_sequence (pr_top_generic prc prlc prtac prpat) [p; q]
+ | Some x -> pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x)
in
- hov 0 (pair_unpack { pair_unpacker } x)
- | ExtraArgType s ->
- try pi3 (String.Map.find s !genarg_pprule) prc prlc prtac x
- with Not_found -> Genprint.generic_top_print x
+ hov_if_not_empty 0 ans
+ | PairArg (wit1, wit2) ->
+ let p, q = x in
+ let p = in_gen (glbwit wit1) p in
+ let q = in_gen (glbwit wit2) q in
+ let ans = pr_sequence (pr_glb_generic_rec prc prlc prtac prpat) [p; q] in
+ hov_if_not_empty 0 ans
+ | ExtraArg s ->
+ try pi2 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (glbwit wit) x)
+ with Not_found -> Genprint.generic_glb_print (in_gen (glbwit wit) x)
let rec tacarg_using_rule_token pr_gen = function
- | Some s :: l, al -> keyword s :: tacarg_using_rule_token pr_gen (l,al)
- | None :: l, a :: al ->
- let r = tacarg_using_rule_token pr_gen (l,al) in
- pr_gen a :: r
- | [], [] -> []
- | _ -> failwith "Inconsistent arguments of extended tactic"
+ | [] -> []
+ | TacTerm s :: l -> keyword s :: tacarg_using_rule_token pr_gen l
+ | TacNonTerm (_, (symb, arg), _) :: l ->
+ pr_gen symb arg :: tacarg_using_rule_token pr_gen l
let pr_tacarg_using_rule pr_gen l =
let l = match l with
- | (Some s :: l, al) ->
+ | 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. *)
- primitive s :: (tacarg_using_rule_token pr_gen (l, al))
+ primitive s :: tacarg_using_rule_token pr_gen l
| _ -> tacarg_using_rule_token pr_gen l
in
pr_sequence (fun x -> x) l
- let pr_extend_gen pr_gen lev s l =
- try
- let tags = List.map genarg_tag l in
- let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in
- let p = pr_tacarg_using_rule pr_gen (pl,l) in
- if lev' > lev then surround p else p
- with Not_found ->
- let name = str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic in
+ let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l =
+ let name =
+ str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++
+ str "@" ++ int i
+ in
let args = match l with
| [] -> mt ()
| _ -> spc() ++ pr_sequence pr_gen l
in
str "<" ++ name ++ str ">" ++ args
+ let rec pr_user_symbol = function
+ | Extend.Ulist1 tkn -> "ne_" ^ pr_user_symbol tkn ^ "_list"
+ | Extend.Ulist1sep (tkn, _) -> "ne_" ^ pr_user_symbol tkn ^ "_list"
+ | Extend.Ulist0 tkn -> pr_user_symbol tkn ^ "_list"
+ | Extend.Ulist0sep (tkn, _) -> pr_user_symbol tkn ^ "_list"
+ | Extend.Uopt tkn -> pr_user_symbol tkn ^ "_opt"
+ | Extend.Uentry tag ->
+ let ArgT.Any tag = tag in
+ ArgT.repr tag
+ | Extend.Uentryl (tkn, lvl) -> "tactic" ^ string_of_int lvl
+
+ let pr_alias_key key =
+ try
+ let prods = (KNmap.find key !prnotation_tab).pptac_prods in
+ let rec pr = function
+ | TacTerm s -> primitive s
+ | TacNonTerm (_, symb, _) -> str (Printf.sprintf "(%s)" (pr_user_symbol symb))
+ in
+ pr_sequence pr prods
+ with Not_found ->
+ KerName.print key
+
let pr_alias_gen pr_gen lev key l =
try
let pp = KNmap.find key !prnotation_tab in
- let (lev', pl) = pp.pptac_prods in
- let p = pr_tacarg_using_rule pr_gen (pl, l) in
- if lev' > lev then surround p else p
+ let rec pack prods args = match prods, args with
+ | [], [] -> []
+ | TacTerm s :: prods, args -> TacTerm s :: pack prods args
+ | TacNonTerm (loc, symb, id) :: prods, arg :: args ->
+ TacNonTerm (loc, (symb, arg), id) :: pack prods args
+ | _ -> raise Not_found
+ in
+ let prods = pack pp.pptac_prods l in
+ let p = pr_tacarg_using_rule pr_gen prods in
+ if pp.pptac_level > lev then surround p else p
with Not_found ->
- KerName.print key ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)"
-
- let pr_raw_extend prc prlc prtac prpat =
- pr_extend_gen (pr_raw_generic prc prlc prtac prpat pr_reference)
- let pr_glob_extend prc prlc prtac prpat =
- pr_extend_gen (pr_glb_generic prc prlc prtac prpat)
- let pr_extend prc prlc prtac prpat =
- pr_extend_gen (pr_top_generic prc prlc prtac prpat)
-
- let pr_raw_alias prc prlc prtac prpat =
- pr_alias_gen (pr_raw_generic prc prlc prtac prpat pr_reference)
- let pr_glob_alias prc prlc prtac prpat =
- pr_alias_gen (pr_glb_generic prc prlc prtac prpat)
- let pr_alias prc prlc prtac prpat =
- pr_alias_gen (pr_top_generic prc prlc prtac prpat)
+ let pr arg = str "_" in
+ KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)"
+
+ let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.ghost, arg))
+
+ let is_genarg tag wit =
+ let ArgT.Any tag = tag in
+ argument_type_eq (ArgumentType (ExtraArg tag)) wit
+
+ let get_list : type l. l generic_argument -> l generic_argument list option =
+ function (GenArg (wit, arg)) -> match wit with
+ | Rawwit (ListArg wit) -> Some (List.map (in_gen (rawwit wit)) arg)
+ | Glbwit (ListArg wit) -> Some (List.map (in_gen (glbwit wit)) arg)
+ | _ -> None
+
+ let get_opt : type l. l generic_argument -> l generic_argument option option =
+ function (GenArg (wit, arg)) -> match wit with
+ | Rawwit (OptArg wit) -> Some (Option.map (in_gen (rawwit wit)) arg)
+ | Glbwit (OptArg wit) -> Some (Option.map (in_gen (glbwit wit)) arg)
+ | _ -> None
+
+ let rec pr_any_arg : type l. (_ -> l generic_argument -> std_ppcmds) -> _ -> l generic_argument -> std_ppcmds =
+ fun prtac symb arg -> match symb with
+ | Extend.Uentry tag when is_genarg tag (genarg_tag arg) -> prtac (1, Any) arg
+ | Extend.Ulist1 s | Extend.Ulist0 s ->
+ begin match get_list arg with
+ | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+ | Some l -> pr_sequence (pr_any_arg prtac s) l
+ end
+ | Extend.Ulist1sep (s, sep) | Extend.Ulist0sep (s, sep) ->
+ begin match get_list arg with
+ | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+ | Some l -> prlist_with_sep (fun () -> str sep) (pr_any_arg prtac s) l
+ end
+ | Extend.Uopt s ->
+ begin match get_opt arg with
+ | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+ | Some l -> pr_opt (pr_any_arg prtac s) l
+ end
+ | Extend.Uentry _ | Extend.Uentryl _ ->
+ str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+
+ let rec pr_targ prtac symb arg = match symb with
+ | Extend.Uentry tag when is_genarg tag (ArgumentType wit_tactic) ->
+ prtac (1, Any) arg
+ | Extend.Uentryl (_, l) -> prtac (l, Any) arg
+ | _ ->
+ match arg with
+ | TacGeneric arg ->
+ let pr l arg = prtac l (TacGeneric arg) in
+ pr_any_arg pr symb arg
+ | _ -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+
+ let pr_raw_extend_rec prc prlc prtac prpat =
+ pr_extend_gen (pr_farg prtac)
+ let pr_glob_extend_rec prc prlc prtac prpat =
+ pr_extend_gen (pr_farg prtac)
+
+ let pr_raw_alias prc prlc prtac prpat lev key args =
+ pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args
+ let pr_glob_alias prc prlc prtac prpat lev key args =
+ pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args
(**********************************************************************)
(* The tactic printer *)
@@ -514,10 +535,9 @@ module Make
let pr_with_induction_names prc = function
| None, None -> mt ()
- | Some eqpat, None -> spc () ++ hov 1 (pr_eqn_ipat eqpat)
- | None, Some ipat -> spc () ++ hov 1 (pr_as_disjunctive_ipat prc ipat)
+ | Some eqpat, None -> hov 1 (pr_eqn_ipat eqpat)
+ | None, Some ipat -> hov 1 (pr_as_disjunctive_ipat prc ipat)
| Some eqpat, Some ipat ->
- spc () ++
hov 1 (pr_as_disjunctive_ipat prc ipat ++ spc () ++ pr_eqn_ipat eqpat)
let pr_as_intro_pattern prc ipat =
@@ -559,21 +579,21 @@ module Make
spc() ++ prc c ++ pr_as_ipat prdc ipat
let pr_by_tactic prt = function
- | TacId [] -> mt ()
- | tac -> spc() ++ keyword "by" ++ spc () ++ prt tac
+ | Some tac -> keyword "by" ++ spc () ++ prt tac
+ | None -> mt()
let pr_hyp_location pr_id = function
- | occs, InHyp -> spc () ++ pr_with_occurrences pr_id occs
+ | occs, InHyp -> pr_with_occurrences pr_id occs
| occs, InHypTypeOnly ->
- spc () ++ pr_with_occurrences (fun id ->
+ pr_with_occurrences (fun id ->
str "(" ++ keyword "type of" ++ spc () ++ pr_id id ++ str ")"
) occs
| occs, InHypValueOnly ->
- spc () ++ pr_with_occurrences (fun id ->
+ pr_with_occurrences (fun id ->
str "(" ++ keyword "value of" ++ spc () ++ pr_id id ++ str ")"
) occs
- let pr_in pp = spc () ++ hov 0 (keyword "in" ++ pp)
+ let pr_in pp = hov 0 (keyword "in" ++ pp)
let pr_simple_hyp_clause pr_id = function
| [] -> mt ()
@@ -583,6 +603,17 @@ module Make
| None -> mt ()
| Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat
+ let pr_in_clause pr_id = function
+ | { onhyps=None; concl_occs=NoOccurrences } ->
+ (str "* |-")
+ | { onhyps=None; concl_occs=occs } ->
+ (pr_with_occurrences (fun () -> str "*") (occs,()))
+ | { onhyps=Some l; concl_occs=NoOccurrences } ->
+ prlist_with_sep (fun () -> str ", ") (pr_hyp_location pr_id) l
+ | { onhyps=Some l; concl_occs=occs } ->
+ let pr_occs = pr_with_occurrences (fun () -> str" |- *") (occs,()) in
+ (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs)
+
let pr_clauses default_is_concl pr_id = function
| { onhyps=Some []; concl_occs=occs }
when (match default_is_concl with Some true -> true | _ -> false) ->
@@ -599,7 +630,8 @@ module Make
| _ -> pr_with_occurrences (fun () -> str" |- *") (occs,())
in
pr_in
- (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l ++ pr_occs)
+ (prlist_with_sep (fun () -> str",")
+ (fun id -> spc () ++ pr_hyp_location pr_id id) l ++ pr_occs)
let pr_orient b = if b then mt () else str "<- "
@@ -610,16 +642,30 @@ module Make
| RepeatStar -> str "?"
| RepeatPlus -> str "!"
- let pr_induction_arg prc prlc = function
+ let pr_core_destruction_arg prc prlc = function
| ElimOnConstr c -> pr_with_bindings prc prlc c
| ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id)
| ElimOnAnonHyp n -> int n
- let pr_induction_kind = function
+ let pr_destruction_arg prc prlc (clear_flag,h) =
+ pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h
+
+ let pr_inversion_kind = function
| SimpleInversion -> primitive "simple inversion"
| FullInversion -> primitive "inversion"
| FullInversionClear -> primitive "inversion_clear"
+ let pr_range_selector (i, j) =
+ if Int.equal i j then int i
+ else int i ++ str "-" ++ int j
+
+ let pr_goal_selector = function
+ | SelectNth i -> int i ++ str ":"
+ | SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++
+ str "]" ++ str ":"
+ | SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":"
+ | SelectAll -> str "all" ++ str ":"
+
let pr_lazy = function
| General -> keyword "multi"
| Select -> keyword "lazy"
@@ -630,9 +676,9 @@ module Make
| Subterm (b,None,a) ->
(** ppedrot: we don't make difference between [appcontext] and [context]
anymore, and the interpretation is governed by a flag instead. *)
- keyword "context" ++ str" [" ++ pr_pat a ++ str "]"
+ keyword "context" ++ str" [ " ++ pr_pat a ++ str " ]"
| Subterm (b,Some id,a) ->
- keyword "context" ++ spc () ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]"
+ keyword "context" ++ spc () ++ pr_id id ++ str "[ " ++ pr_pat a ++ str " ]"
let pr_match_hyps pr_pat = function
| Hyp (nal,mp) ->
@@ -706,20 +752,13 @@ module Make
str " ]")
let pr_hintbases = function
- | None -> spc () ++ keyword "with" ++ str" *"
+ | None -> keyword "with" ++ str" *"
| Some [] -> mt ()
- | Some l ->
- spc () ++ hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l)
+ | Some l -> hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l)
let pr_auto_using prc = function
| [] -> mt ()
- | l -> spc () ++
- hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l)
-
- let string_of_debug = function
- | Off -> ""
- | Debug -> "debug "
- | Info -> "info_"
+ | l -> hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l)
let pr_then () = str ";"
@@ -746,7 +785,6 @@ module Make
type 'a printer = {
pr_tactic : tolerability -> 'tacexpr -> std_ppcmds;
pr_constr : 'trm -> std_ppcmds;
- pr_uconstr : 'utrm -> std_ppcmds;
pr_lconstr : 'trm -> std_ppcmds;
pr_dconstr : 'dtrm -> std_ppcmds;
pr_pattern : 'pat -> std_ppcmds;
@@ -755,13 +793,12 @@ module Make
pr_reference : 'ref -> std_ppcmds;
pr_name : 'nam -> std_ppcmds;
pr_generic : 'lev generic_argument -> std_ppcmds;
- pr_extend : int -> ml_tactic_name -> 'lev generic_argument list -> std_ppcmds;
- pr_alias : int -> KerName.t -> 'lev generic_argument list -> std_ppcmds;
+ pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> std_ppcmds;
+ pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> std_ppcmds;
}
constraint 'a = <
term :'trm;
- utrm :'utrm;
dterm :'dtrm;
pattern :'pat;
constant :'cst;
@@ -771,306 +808,216 @@ module Make
level :'lev
>
- let make_pr_tac pr strip_prod_binders tag_atom tag =
+ 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_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_constrarg c = spc () ++ pr.pr_constr c in
+ let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in
+ let pr_intarg n = spc () ++ int n in
+
+ (* Some printing combinators *)
+ let pr_eliminator cb = keyword "using" ++ pr_arg pr_with_bindings cb in
+
+ let pr_binder_fix (nal,t) =
+ (* match t with
+ | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal
+ | _ ->*)
+ let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in
+ spc() ++ hov 1 (str"(" ++ s ++ str")") in
+
+ let pr_fix_tac (id,n,c) =
+ let rec set_nth_name avoid n = function
+ (nal,ty)::bll ->
+ if n <= List.length nal then
+ match List.chop (n-1) nal with
+ _, (_,Name id) :: _ -> id, (nal,ty)::bll
+ | bef, (loc,Anonymous) :: aft ->
+ let id = next_ident_away (Id.of_string"y") avoid in
+ id, ((bef@(loc,Name id)::aft, ty)::bll)
+ | _ -> assert false
+ else
+ let (id,bll') = set_nth_name avoid (n-List.length nal) bll in
+ (id,(nal,ty)::bll')
+ | [] -> assert false in
+ let (bll,ty) = strip_prod_binders n c in
+ let names =
+ List.fold_left
+ (fun ln (nal,_) -> List.fold_left
+ (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln)
+ ln nal)
+ [] bll in
+ let idarg,bll = set_nth_name names n bll in
+ let annot = match names with
+ | [_] ->
+ mt ()
+ | _ ->
+ spc() ++ str"{"
+ ++ keyword "struct" ++ spc ()
+ ++ pr_id idarg ++ str"}"
+ in
+ hov 1 (str"(" ++ pr_id id ++
+ prlist pr_binder_fix bll ++ annot ++ str" :" ++
+ pr_lconstrarg ty ++ str")") in
+ (* spc() ++
+ hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ _pr_constrarg
+ c)
+ *)
+ let pr_cofix_tac (id,c) =
+ hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in
+
+ (* Printing tactics as arguments *)
+ let rec pr_atom0 a = tag_atom a (match a with
+ | TacIntroPattern (false,[]) -> primitive "intros"
+ | TacIntroPattern (true,[]) -> primitive "eintros"
+ | t -> str "(" ++ pr_atom1 t ++ str ")"
+ )
+
+ (* Main tactic printer *)
+ and pr_atom1 a = tag_atom a (match a with
+ (* Basic tactics *)
+ | TacIntroPattern (ev,[]) as t ->
+ pr_atom0 t
+ | TacIntroPattern (ev,(_::_ as p)) ->
+ hov 1 (primitive (if ev then "eintros" else "intros") ++ spc () ++
+ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) 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
+ )
+ | TacElim (ev,cb,cbo) ->
+ hov 1 (
+ primitive (with_evars ev "elim")
+ ++ pr_arg pr_with_bindings_arg cb
+ ++ pr_opt pr_eliminator cbo)
+ | TacCase (ev,cb) ->
+ hov 1 (primitive (with_evars ev "case") ++ spc () ++ pr_with_bindings_arg cb)
+ | TacMutualFix (id,n,l) ->
+ hov 1 (
+ primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc()
+ ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_fix_tac l)
+ | TacMutualCofix (id,l) ->
+ hov 1 (
+ primitive "cofix" ++ spc () ++ pr_id id ++ spc()
+ ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l
+ )
+ | TacAssert (b,Some tac,ipat,c) ->
+ hov 1 (
+ primitive (if b then "assert" else "enough") ++
+ pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++
+ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac
+ )
+ | TacAssert (_,None,ipat,c) ->
+ hov 1 (
+ primitive "pose proof"
+ ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr 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)
+ l
+ )
+ | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl ->
+ hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c)
+ | TacLetTac (na,c,cl,b,e) ->
+ hov 1 (
+ (if b then primitive "set" else primitive "remember") ++
+ (if b then pr_pose pr.pr_constr pr.pr_lconstr na c
+ else pr_pose_as_style pr.pr_constr 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 ()) ->
+ hov 1 (str "instantiate" ++ spc() ++
+ hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
+ pr_lconstrarg c ++ str ")" ))
+ | TacInstantiate (n,c,HypLocation (id,hloc)) ->
+ hov 1 (str "instantiate" ++ spc() ++
+ hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
+ pr_lconstrarg c ++ str ")" )
+ ++ str "in" ++ pr_hyp_location pr.pr_name (id,[],(hloc,ref None)))
+ *)
+
+ (* Derived basic tactics *)
+ | TacInductionDestruct (isrec,ev,(l,el)) ->
+ hov 1 (
+ 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_opt (pr_clauses None pr.pr_name) cl) l ++
+ pr_opt pr_eliminator el
+ )
- (* some shortcuts *)
- let _pr_bindings = pr_bindings pr.pr_constr pr.pr_lconstr in
- let pr_ex_bindings = pr_bindings_gen true pr.pr_constr pr.pr_lconstr in
- let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr 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
+ (* Conversion *)
+ | TacReduce (r,h) ->
+ hov 1 (
+ pr_red_expr r
+ ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h
+ )
+ | TacChange (op,c,h) ->
+ hov 1 (
+ primitive "change" ++ brk (1,1)
+ ++ (
+ match op with
+ None ->
+ mt ()
+ | Some p ->
+ pr.pr_pattern p ++ spc ()
+ ++ keyword "with" ++ spc ()
+ ) ++ pr.pr_dconstr c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h
+ )
- let pr_constrarg c = spc () ++ pr.pr_constr c in
- let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in
- let pr_intarg n = spc () ++ int n in
+ (* Equality and inversion *)
+ | TacRewrite (ev,l,cl,tac) ->
+ hov 1 (
+ primitive (with_evars ev "rewrite") ++ spc ()
+ ++ prlist_with_sep
+ (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)
+ 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
+ )
+ | TacInversion (DepInversion (k,c,ids),hyp) ->
+ 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
+ )
+ | 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_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
+ ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl
+ )
+ )
+ in
+ pr_atom1
- (* Some printing combinators *)
- let pr_eliminator cb = keyword "using" ++ pr_arg pr_with_bindings cb in
+ let make_pr_tac pr strip_prod_binders tag_atom tag =
let extract_binders = function
| Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body)
| body -> ([],body) in
-
- let pr_binder_fix (nal,t) =
- (* match t with
- | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal
- | _ ->*)
- let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in
- spc() ++ hov 1 (str"(" ++ s ++ str")") in
-
- let pr_fix_tac (id,n,c) =
- let rec set_nth_name avoid n = function
- (nal,ty)::bll ->
- if n <= List.length nal then
- match List.chop (n-1) nal with
- _, (_,Name id) :: _ -> id, (nal,ty)::bll
- | bef, (loc,Anonymous) :: aft ->
- let id = next_ident_away (Id.of_string"y") avoid in
- id, ((bef@(loc,Name id)::aft, ty)::bll)
- | _ -> assert false
- else
- let (id,bll') = set_nth_name avoid (n-List.length nal) bll in
- (id,(nal,ty)::bll')
- | [] -> assert false in
- let (bll,ty) = strip_prod_binders n c in
- let names =
- List.fold_left
- (fun ln (nal,_) -> List.fold_left
- (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln)
- ln nal)
- [] bll in
- let idarg,bll = set_nth_name names n bll in
- let annot = match names with
- | [_] ->
- mt ()
- | _ ->
- spc() ++ str"{"
- ++ keyword "struct" ++ spc ()
- ++ pr_id idarg ++ str"}"
- in
- hov 1 (str"(" ++ pr_id id ++
- prlist pr_binder_fix bll ++ annot ++ str" :" ++
- pr_lconstrarg ty ++ str")") in
- (* spc() ++
- hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ pr_constrarg
- c)
- *)
- let pr_cofix_tac (id,c) =
- hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in
-
- (* Printing tactics as arguments *)
- let rec pr_atom0 a = tag_atom a (match a with
- | TacIntroPattern [] -> primitive "intros"
- | TacIntroMove (None,MoveLast) -> primitive "intro"
- | TacTrivial (d,[],Some []) -> str (string_of_debug d) ++ primitive "trivial"
- | TacAuto (d,None,[],Some []) -> str (string_of_debug d) ++ primitive "auto"
- | TacClear (true,[]) -> primitive "clear"
- | t -> str "(" ++ pr_atom1 t ++ str ")"
- )
-
- (* Main tactic printer *)
- and pr_atom1 a = tag_atom a (match a with
- (* Basic tactics *)
- | TacIntroPattern [] as t ->
- pr_atom0 t
- | TacIntroPattern (_::_ as p) ->
- hov 1 (primitive "intros" ++ spc () ++
- prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)
- | TacIntroMove (None,MoveLast) as t ->
- pr_atom0 t
- | TacIntroMove (Some id,MoveLast) ->
- primitive "intro" ++ spc () ++ pr_id id
- | TacIntroMove (ido,hto) ->
- hov 1 (primitive "intro" ++ pr_opt pr_id ido ++
- Miscprint.pr_move_location pr.pr_name hto)
- | TacExact c ->
- hov 1 (primitive "exact" ++ pr_constrarg c)
- | 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_in_hyp_as pr.pr_dconstr pr.pr_name inhyp
- )
- | TacElim (ev,cb,cbo) ->
- hov 1 (
- primitive (with_evars ev "elim")
- ++ pr_arg pr_with_bindings_arg cb
- ++ pr_opt pr_eliminator cbo)
- | TacCase (ev,cb) ->
- hov 1 (primitive (with_evars ev "case") ++ spc () ++ pr_with_bindings_arg cb)
- | TacFix (ido,n) -> hov 1 (primitive "fix" ++ pr_opt pr_id ido ++ pr_intarg n)
- | TacMutualFix (id,n,l) ->
- hov 1 (
- primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc()
- ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_fix_tac l)
- | TacCofix ido ->
- hov 1 (primitive "cofix" ++ pr_opt pr_id ido)
- | TacMutualCofix (id,l) ->
- hov 1 (
- primitive "cofix" ++ spc () ++ pr_id id ++ spc()
- ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l
- )
- | TacAssert (b,Some tac,ipat,c) ->
- hov 1 (
- primitive (if b then "assert" else "enough") ++
- pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++
- pr_by_tactic (pr.pr_tactic ltop) tac
- )
- | TacAssert (_,None,ipat,c) ->
- hov 1 (
- primitive "pose proof"
- ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr 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)
- l
- )
- | TacGeneralizeDep c ->
- hov 1 (
- primitive "generalize" ++ spc () ++ str "dependent"
- ++ pr_constrarg c
- )
- | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl ->
- hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c)
- | TacLetTac (na,c,cl,b,e) ->
- hov 1 (
- (if b then primitive "set" else primitive "remember") ++
- (if b then pr_pose pr.pr_constr pr.pr_lconstr na c
- else pr_pose_as_style pr.pr_constr na c) ++
- pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++
- pr_clauses (Some b) pr.pr_name cl)
- (* | TacInstantiate (n,c,ConclLocation ()) ->
- hov 1 (str "instantiate" ++ spc() ++
- hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
- pr_lconstrarg c ++ str ")" ))
- | TacInstantiate (n,c,HypLocation (id,hloc)) ->
- hov 1 (str "instantiate" ++ spc() ++
- hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
- pr_lconstrarg c ++ str ")" )
- ++ str "in" ++ pr_hyp_location pr.pr_name (id,[],(hloc,ref None)))
- *)
-
- (* Derived basic tactics *)
- | TacInductionDestruct (isrec,ev,(l,el)) ->
- hov 1 (
- primitive (with_evars ev (if isrec then "induction" else "destruct"))
- ++ spc ()
- ++ prlist_with_sep pr_comma (fun ((clear_flag,h),ids,cl) ->
- pr_clear_flag clear_flag (pr_induction_arg pr.pr_dconstr pr.pr_dconstr) h ++
- pr_with_induction_names pr.pr_dconstr ids ++
- pr_opt_no_spc (pr_clauses None pr.pr_name) cl) l ++
- pr_opt pr_eliminator el
- )
- | TacDoubleInduction (h1,h2) ->
- hov 1 (
- primitive "double induction"
- ++ pr_arg pr_quantified_hypothesis h1
- ++ pr_arg pr_quantified_hypothesis h2
- )
-
- (* Automation tactics *)
- | TacTrivial (_,[],Some []) as x ->
- pr_atom0 x
- | TacTrivial (d,lems,db) ->
- hov 0 (
- str (string_of_debug d) ++ primitive "trivial"
- ++ pr_auto_using pr.pr_constr lems ++ pr_hintbases db
- )
- | TacAuto (_,None,[],Some []) as x ->
- pr_atom0 x
- | TacAuto (d,n,lems,db) ->
- hov 0 (
- str (string_of_debug d) ++ primitive "auto"
- ++ pr_opt (pr_or_var int) n
- ++ pr_auto_using pr.pr_constr lems ++ pr_hintbases db
- )
-
- (* Context management *)
- | TacClear (true,[]) as t ->
- pr_atom0 t
- | TacClear (keep,l) ->
- hov 1 (
- primitive "clear" ++ spc ()
- ++ (if keep then str "- " else mt ())
- ++ prlist_with_sep spc pr.pr_name l
- )
- | TacClearBody l ->
- hov 1 (
- primitive "clearbody" ++ spc ()
- ++ prlist_with_sep spc pr.pr_name l
- )
- | TacMove (id1,id2) ->
- hov 1 (
- primitive "move"
- ++ brk (1,1) ++ pr.pr_name id1
- ++ Miscprint.pr_move_location pr.pr_name id2
- )
- | TacRename l ->
- hov 1 (
- primitive "rename" ++ brk (1,1)
- ++ prlist_with_sep
- (fun () -> str "," ++ brk (1,1))
- (fun (i1,i2) ->
- pr.pr_name i1 ++ spc () ++ str "into" ++ spc () ++ pr.pr_name i2)
- l
- )
-
- (* Constructors *)
- | TacSplit (ev,l) ->
- hov 1 (
- primitive (with_evars ev "exists")
- ++ prlist_with_sep (fun () -> str",") pr_ex_bindings l
- )
-
- (* Conversion *)
- | TacReduce (r,h) ->
- hov 1 (
- pr_red_expr r
- ++ pr_clauses (Some true) pr.pr_name h
- )
- | TacChange (op,c,h) ->
- hov 1 (
- primitive "change" ++ brk (1,1)
- ++ (
- match op with
- None ->
- mt ()
- | Some p ->
- pr.pr_pattern p ++ spc ()
- ++ keyword "with" ++ spc ()
- ) ++ pr.pr_dconstr c ++ pr_clauses (Some true) pr.pr_name h
- )
-
- (* Equivalence relations *)
- | TacSymmetry cls ->
- primitive "symmetry" ++ pr_clauses (Some true) pr.pr_name cls
-
- (* Equality and inversion *)
- | TacRewrite (ev,l,cl,by) ->
- hov 1 (
- primitive (with_evars ev "rewrite") ++ spc ()
- ++ prlist_with_sep
- (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)
- l
- ++ pr_clauses (Some true) pr.pr_name cl
- ++ (
- match by with
- | Some by -> pr_by_tactic (pr.pr_tactic ltop) by
- | None -> mt()
- )
- )
- | TacInversion (DepInversion (k,c,ids),hyp) ->
- hov 1 (
- primitive "dependent " ++ pr_induction_kind k ++ spc ()
- ++ pr_quantified_hypothesis hyp
- ++ pr_with_inversion_names pr.pr_dconstr ids
- ++ pr_with_constr pr.pr_constr c
- )
- | TacInversion (NonDepInversion (k,cl,ids),hyp) ->
- hov 1 (
- pr_induction_kind k ++ spc ()
- ++ pr_quantified_hypothesis hyp
- ++ pr_with_inversion_names pr.pr_dconstr ids
- ++ 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
- ++ pr_simple_hyp_clause pr.pr_name cl
- )
- )
- in
-
let rec pr_tac inherited tac =
let return (doc, l) = (tag tac doc, l) in
let (strm, prec) = return (match tac with
@@ -1225,10 +1172,11 @@ module Make
keyword "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
| TacComplete t ->
pr_tac (lcomplete,E) t, lcomplete
+ | TacSelect (s, tac) -> pr_goal_selector 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_atom1 t)), ltatom
+ pr_with_comments loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom
| TacArg(_,Tacexp e) ->
pr.pr_tactic (latom,E) e, latom
| TacArg(_,ConstrMayEval (ConstrTerm c)) ->
@@ -1251,26 +1199,17 @@ module Make
| TacML (loc,s,l) ->
pr_with_comments loc (pr.pr_extend 1 s l), lcall
| TacAlias (loc,kn,l) ->
- pr_with_comments loc (pr.pr_alias (level_of inherited) kn (List.map snd l)), latom
+ pr_with_comments loc (pr.pr_alias (level_of inherited) kn l), latom
)
in
if prec_less prec inherited then strm
else str"(" ++ strm ++ str")"
and pr_tacarg = function
- | TacDynamic (loc,t) ->
- pr_with_comments loc
- (str "<" ++ keyword "dynamic" ++ str " [" ++ str (Dyn.tag t) ++ str "]>")
- | MetaIdArg (loc,true,s) ->
- pr_with_comments loc (str "$" ++ str s)
- | MetaIdArg (loc,false,s) ->
- pr_with_comments loc (keyword "constr:" ++ str " $" ++ str 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
- | UConstr c ->
- keyword "uconstr:" ++ pr.pr_uconstr c
| TacFreshId l ->
keyword "fresh" ++ pr_fresh_ids l
| TacPretype c ->
@@ -1278,7 +1217,7 @@ module Make
| TacNumgoals ->
keyword "numgoals"
| (TacCall _|Tacexp _ | TacGeneric _) as a ->
- keyword "ltac:" ++ pr_tac (latom,E) (TacArg (Loc.ghost,a))
+ hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.ghost,a))))
in pr_tac
@@ -1298,7 +1237,6 @@ module Make
let pr = {
pr_tactic = pr_raw_tactic_level;
pr_constr = pr_constr_expr;
- pr_uconstr = pr_constr_expr;
pr_dconstr = pr_constr_expr;
pr_lconstr = pr_lconstr_expr;
pr_pattern = pr_constr_pattern_expr;
@@ -1306,8 +1244,8 @@ module Make
pr_constant = pr_or_by_notation pr_reference;
pr_reference = pr_reference;
pr_name = pr_lident;
- pr_generic = Genprint.generic_raw_print;
- pr_extend = pr_raw_extend pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr;
+ pr_generic = pr_raw_generic_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference;
+ pr_extend = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr;
pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr;
} in
make_pr_tac
@@ -1319,9 +1257,9 @@ module Make
let pr_and_constr_expr pr (c,_) = pr c
- let pr_pat_and_constr_expr pr ((c,_),_) = pr c
+ let pr_pat_and_constr_expr pr (_,(c,_),_) = pr c
- let rec pr_glob_tactic_level env n t =
+ let pr_glob_tactic_level env n t =
let glob_printers =
(strip_prod_binders_glob_constr)
in
@@ -1329,7 +1267,6 @@ module Make
let pr = {
pr_tactic = prtac;
pr_constr = pr_and_constr_expr (pr_glob_constr_env env);
- pr_uconstr = 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);
@@ -1337,8 +1274,10 @@ module Make
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 = Genprint.generic_glb_print;
- pr_extend = pr_glob_extend
+ pr_generic = pr_glb_generic_rec
+ (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
+ prtac (pr_pat_and_constr_expr (pr_glob_constr_env env));
+ pr_extend = pr_glob_extend_rec
(pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
prtac (pr_pat_and_constr_expr (pr_glob_constr_env env));
pr_alias = pr_glob_alias
@@ -1363,39 +1302,49 @@ module Make
| _ -> error "Cannot translate fix tactic: not enough products" in
strip_ty [] n ty
- let pr_tactic_level env n t =
- let typed_printers =
- (strip_prod_binders_constr)
- in
- let prtac n (t:tactic_expr) =
+ let pr_atomic_tactic_level env n t =
+ let prtac n (t:atomic_tactic_expr) =
let pr = {
- pr_tactic = pr_glob_tactic_level env;
+ pr_tactic = (fun _ _ -> str "");
pr_constr = pr_constr_env env Evd.empty;
- pr_uconstr = pr_closed_glob_env env Evd.empty;
pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env);
pr_lconstr = pr_lconstr_env env Evd.empty;
- 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_constant = pr_and_short_name (pr_evaluable_reference_env env);
+ pr_pattern = pr_constr_pattern_env env Evd.empty;
+ pr_lpattern = pr_lconstr_pattern_env env Evd.empty;
+ pr_constant = pr_evaluable_reference_env env;
pr_reference = pr_located pr_ltac_constant;
pr_name = pr_id;
- pr_generic = Genprint.generic_top_print;
- pr_extend = pr_extend
- (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty)
- (pr_glob_tactic_level env) pr_constr_pattern;
- pr_alias = pr_alias
- (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty)
- (pr_glob_tactic_level env) pr_constr_pattern;
+ (** Those are not used by the atomic printer *)
+ pr_generic = (fun _ -> assert false);
+ pr_extend = (fun _ _ _ -> assert false);
+ pr_alias = (fun _ _ _ -> assert false);
}
in
- make_pr_tac
- pr typed_printers
- tag_atomic_tactic_expr tag_tactic_expr
- n t
+ pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t
in
prtac n t
- let pr_tactic env = pr_tactic_level env ltop
+ let pr_raw_generic env = pr_raw_generic_rec
+ pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference
+
+ let pr_glb_generic env = pr_glb_generic_rec
+ (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
+ (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env))
+
+ let pr_raw_extend env = pr_raw_extend_rec
+ pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr
+
+ let pr_glob_extend env = pr_glob_extend_rec
+ (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
+ (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env))
+
+ let pr_alias pr lev key args =
+ pr_alias_gen (fun _ arg -> pr arg) lev key args
+
+ let pr_extend pr lev ml args =
+ pr_extend_gen pr lev ml args
+
+ let pr_atomic_tactic env = pr_atomic_tactic_level env ltop
end
@@ -1425,37 +1374,77 @@ include Make (Ppconstr) (struct
let tag_glob_atomic_tactic_expr = do_not_tag
let tag_raw_tactic_expr = do_not_tag
let tag_raw_atomic_tactic_expr = do_not_tag
- let tag_tactic_expr = do_not_tag
let tag_atomic_tactic_expr = do_not_tag
end)
(** Registering *)
+let run_delayed c =
+ Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma }
+
+let run_delayed_destruction_arg = function (* HH: Using Evd.empty looks suspicious *)
+ | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (fst (run_delayed g))
+ | clear_flag,ElimOnAnonHyp n as x -> x
+ | clear_flag,ElimOnIdent id as x -> x
+
let () =
let pr_bool b = if b then str "true" else str "false" in
let pr_unit _ = str "()" in
let pr_string s = str "\"" ++ str s ++ str "\"" in
+ Genprint.register_print0 Constrarg.wit_int_or_var
+ (pr_or_var int) (pr_or_var int) int;
Genprint.register_print0 Constrarg.wit_ref
pr_reference (pr_or_var (pr_located pr_global)) pr_global;
+ Genprint.register_print0 Constrarg.wit_ident
+ pr_id pr_id pr_id;
+ Genprint.register_print0 Constrarg.wit_var
+ (pr_located pr_id) (pr_located pr_id) pr_id;
Genprint.register_print0
Constrarg.wit_intro_pattern
(Miscprint.pr_intro_pattern pr_constr_expr)
(Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c))
- (Miscprint.pr_intro_pattern (fun c -> pr_constr (snd (c (Global.env()) Evd.empty))));
+ (Miscprint.pr_intro_pattern (fun c -> pr_constr (fst (run_delayed c))));
Genprint.register_print0
Constrarg.wit_clause_dft_concl
(pr_clauses (Some true) pr_lident)
(pr_clauses (Some true) pr_lident)
(pr_clauses (Some true) (fun id -> pr_lident (Loc.ghost,id)))
;
- Genprint.register_print0 Constrarg.wit_sort
- pr_glob_sort pr_glob_sort (pr_sort Evd.empty);
+ Genprint.register_print0
+ Constrarg.wit_constr
+ Ppconstr.pr_constr_expr
+ (fun (c, _) -> Printer.pr_glob_constr c)
+ Printer.pr_constr
+ ;
Genprint.register_print0
Constrarg.wit_uconstr
Ppconstr.pr_constr_expr
(fun (c,_) -> Printer.pr_glob_constr c)
Printer.pr_closed_glob
;
+ Genprint.register_print0
+ Constrarg.wit_open_constr
+ Ppconstr.pr_constr_expr
+ (fun (c, _) -> Printer.pr_glob_constr c)
+ Printer.pr_constr
+ ;
+ Genprint.register_print0 Constrarg.wit_red_expr
+ (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr))
+ (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr))
+ (pr_red_expr (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern));
+ Genprint.register_print0 Constrarg.wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis;
+ Genprint.register_print0 Constrarg.wit_bindings
+ (pr_bindings_no_with pr_constr_expr pr_lconstr_expr)
+ (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr))
+ (fun it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it)));
+ Genprint.register_print0 Constrarg.wit_constr_with_bindings
+ (pr_with_bindings pr_constr_expr pr_lconstr_expr)
+ (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr))
+ (fun it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it)));
+ Genprint.register_print0 Constrarg.wit_destruction_arg
+ (pr_destruction_arg pr_constr_expr pr_lconstr_expr)
+ (pr_destruction_arg (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr))
+ (fun it -> pr_destruction_arg pr_constr pr_lconstr (run_delayed_destruction_arg it));
Genprint.register_print0 Stdarg.wit_int int int int;
Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool;
Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit;
@@ -1466,16 +1455,10 @@ let () =
let printer _ _ prtac = prtac (0, E) in
declare_extra_genarg_pprule wit_tactic printer printer printer
-let _ = Hook.set Tactic_debug.tactic_printer
- (fun x -> pr_glob_tactic (Global.env()) x)
-
-let _ = Hook.set Tactic_debug.match_pattern_printer
- (fun env sigma hyp -> pr_match_pattern (pr_constr_pattern_env env sigma) hyp)
-
-let _ = Hook.set Tactic_debug.match_rule_printer
- (fun rl ->
- pr_match_rule false (pr_glob_tactic (Global.env()))
- (fun (_,p) -> pr_constr_pattern p) rl)
+let () =
+ let pr_unit _ _ _ () = str "()" in
+ let printer _ _ prtac = prtac (0, E) in
+ declare_extra_genarg_pprule wit_ltac printer printer pr_unit
module Richpp = struct
@@ -1490,7 +1473,6 @@ module Richpp = struct
let tag_glob_atomic_tactic_expr a = tag (AGlobAtomicTacticExpr a)
let tag_raw_tactic_expr e = tag (ARawTacticExpr e)
let tag_raw_atomic_tactic_expr a = tag (ARawAtomicTacticExpr a)
- let tag_tactic_expr e = tag (ATacticExpr e)
let tag_atomic_tactic_expr a = tag (AAtomicTacticExpr a)
end)
diff --git a/printing/pptactic.mli b/printing/pptactic.mli
index 31346561..86e3ea54 100644
--- a/printing/pptactic.mli
+++ b/printing/pptactic.mli
@@ -11,11 +11,15 @@
open Pp
open Genarg
+open Geninterp
open Names
open Constrexpr
open Tacexpr
open Ppextend
+type 'a grammar_tactic_prod_item_expr =
+| TacTerm of string
+| TacNonTerm of Loc.t * 'a * Names.Id.t
type 'a raw_extra_genarg_printer =
(constr_expr -> std_ppcmds) ->
@@ -32,7 +36,7 @@ type 'a glob_extra_genarg_printer =
type 'a extra_genarg_printer =
(Term.constr -> std_ppcmds) ->
(Term.constr -> std_ppcmds) ->
- (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+ (tolerability -> Val.t -> std_ppcmds) ->
'a -> std_ppcmds
val declare_extra_genarg_pprule :
@@ -41,14 +45,13 @@ val declare_extra_genarg_pprule :
'b glob_extra_genarg_printer ->
'c extra_genarg_printer -> unit
-type grammar_terminals = string option list
+type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list
type pp_tactic = {
- pptac_args : argument_type list;
- pptac_prods : int * grammar_terminals;
+ pptac_level : int;
+ pptac_prods : grammar_terminals;
}
-val declare_ml_tactic_pprule : ml_tactic_name -> pp_tactic -> unit
val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit
(** The default pretty-printers produce {!Pp.std_ppcmds} that are
diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli
index b2323acb..665e055f 100644
--- a/printing/pptacticsig.mli
+++ b/printing/pptacticsig.mli
@@ -8,11 +8,10 @@
open Pp
open Genarg
-open Constrexpr
+open Geninterp
open Tacexpr
open Ppextend
open Environ
-open Pattern
open Misctypes
module type Pp = sig
@@ -30,48 +29,31 @@ module type Pp = sig
val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds
val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds
+ val pr_in_clause :
+ ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds
+
val pr_clauses : bool option ->
('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds
- val pr_raw_generic :
- (constr_expr -> std_ppcmds) ->
- (constr_expr -> std_ppcmds) ->
- (tolerability -> raw_tactic_expr -> std_ppcmds) ->
- (constr_expr -> std_ppcmds) ->
- (Libnames.reference -> std_ppcmds) -> rlevel generic_argument ->
- std_ppcmds
-
- val pr_glb_generic :
- (glob_constr_and_expr -> Pp.std_ppcmds) ->
- (glob_constr_and_expr -> Pp.std_ppcmds) ->
- (tolerability -> glob_tactic_expr -> std_ppcmds) ->
- (glob_constr_pattern_and_expr -> std_ppcmds) ->
- glevel generic_argument -> std_ppcmds
-
- val pr_top_generic :
- (Term.constr -> std_ppcmds) ->
- (Term.constr -> std_ppcmds) ->
- (tolerability -> glob_tactic_expr -> std_ppcmds) ->
- (Pattern.constr_pattern -> std_ppcmds) ->
- tlevel generic_argument ->
- std_ppcmds
-
- val pr_raw_extend:
- (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) ->
- (tolerability -> raw_tactic_expr -> std_ppcmds) ->
- (constr_expr -> std_ppcmds) -> int ->
- ml_tactic_name -> raw_generic_argument list -> std_ppcmds
-
- val pr_glob_extend:
- (glob_constr_and_expr -> std_ppcmds) -> (glob_constr_and_expr -> std_ppcmds) ->
- (tolerability -> glob_tactic_expr -> std_ppcmds) ->
- (glob_constr_pattern_and_expr -> std_ppcmds) -> int ->
- ml_tactic_name -> glob_generic_argument list -> std_ppcmds
+
+ val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds
+
+ val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds
+
+ val pr_raw_extend: env -> int ->
+ ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds
+
+ val pr_glob_extend: env -> int ->
+ ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds
val pr_extend :
- (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) ->
- (tolerability -> glob_tactic_expr -> std_ppcmds) ->
- (constr_pattern -> std_ppcmds) -> int ->
- ml_tactic_name -> typed_generic_argument list -> std_ppcmds
+ (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds
+
+ val pr_alias_key : Names.KerName.t -> std_ppcmds
+
+ val pr_alias : (Val.t -> std_ppcmds) ->
+ int -> Names.KerName.t -> Val.t list -> std_ppcmds
+
+ val pr_alias_key : Names.KerName.t -> std_ppcmds
val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds
@@ -81,7 +63,7 @@ module type Pp = sig
val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds
- val pr_tactic : env -> tactic_expr -> std_ppcmds
+ val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds
val pr_hintbases : string list option -> std_ppcmds
@@ -91,4 +73,11 @@ module type Pp = sig
('constr -> std_ppcmds) ->
('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds
+ val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds
+
+ val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
+ ('b, 'a) match_rule -> std_ppcmds
+
+ val pr_value : tolerability -> Val.t -> std_ppcmds
+
end
diff --git a/printing/pputils.ml b/printing/pputils.ml
index 906b463a..50ce56fb 100644
--- a/printing/pputils.ml
+++ b/printing/pputils.ml
@@ -9,7 +9,11 @@
open Pp
let pr_located pr (loc, x) =
- if Flags.do_beautify () && loc <> Loc.ghost then
+ if !Flags.beautify && loc <> Loc.ghost then
let (b, e) = Loc.unloc loc in
- Pp.comment b ++ pr x ++ Pp.comment e
+ (* Side-effect: order matters *)
+ let before = Pp.comment (CLexer.extract_comments b) in
+ let x = pr x in
+ let after = Pp.comment (CLexer.extract_comments e) in
+ before ++ x ++ after
else pr x
diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml
index d2f59e7b..5d6d36d5 100644
--- a/printing/ppvernac.ml
+++ b/printing/ppvernac.ml
@@ -9,7 +9,7 @@
open Pp
open Names
-open Errors
+open CErrors
open Util
open Extend
open Vernacexpr
@@ -34,6 +34,8 @@ module Make
let keyword s = tag_keyword (str s)
+ let pr_constr = pr_constr_expr
+ let pr_lconstr = pr_lconstr_expr
let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr
let pr_lident (loc,id) =
@@ -79,21 +81,11 @@ module Make
| VernacEndSubproof -> str""
| _ -> str"."
- let pr_gen t =
- pr_raw_generic
- pr_constr_expr
- pr_lconstr_expr
- pr_raw_tactic_level
- pr_constr_expr
- pr_reference t
+ let pr_gen t = pr_raw_generic (Global.env ()) t
let sep = fun _ -> spc()
let sep_v2 = fun _ -> str"," ++ spc()
- let pr_ne_sep sep pr = function
- [] -> mt()
- | l -> sep() ++ pr l
-
let pr_set_entry_type = function
| ETName -> str"ident"
| ETReference -> str"global"
@@ -105,18 +97,6 @@ module Make
| ETBinder false -> str "closed binder"
| ETBinderList _ | ETConstrList _ -> failwith "Internal entry type"
- let strip_meta id =
- let s = Id.to_string id in
- if s.[0] == '$' then Id.of_string (String.sub s 1 (String.length s - 1))
- else id
-
- let pr_production_item = function
- | TacNonTerm (loc,nt,Some (p,sep)) ->
- let pp_sep = if not (String.is_empty sep) then str "," ++ quote (str sep) else mt () in
- str nt ++ str"(" ++ pr_id (strip_meta p) ++ pp_sep ++ str")"
- | TacNonTerm (loc,nt,None) -> str nt
- | TacTerm s -> qs s
-
let pr_comment pr_c = function
| CommentConstr c -> pr_c c
| CommentString s -> qs s
@@ -181,14 +161,22 @@ module Make
| HintsReference r -> pr_reference r
| HintsConstr c -> pr_c c
+ let pr_hint_mode = function
+ | ModeInput -> str"+"
+ | ModeNoHeadEvar -> str"!"
+ | ModeOutput -> str"-"
+
+ let pr_hint_info pr_pat { hint_priority = pri; hint_pattern = pat } =
+ pr_opt (fun x -> str"|" ++ int x) pri ++
+ pr_opt (fun y -> (if Option.is_empty pri then str"| " else mt()) ++ pr_pat y) pat
+
let pr_hints db h pr_c pr_pat =
let opth = pr_opt_hintbases db in
let pph =
match h with
| HintsResolve l ->
keyword "Resolve " ++ prlist_with_sep sep
- (fun (pri, _, c) -> pr_reference_or_constr pr_c c ++
- match pri with Some x -> spc () ++ str"(" ++ int x ++ str")" | None -> mt ())
+ (fun (info, _, c) -> pr_reference_or_constr pr_c c ++ pr_hint_info pr_pat info)
l
| HintsImmediate l ->
keyword "Immediate" ++ spc() ++
@@ -202,8 +190,8 @@ module Make
| HintsMode (m, l) ->
keyword "Mode"
++ spc ()
- ++ pr_reference m ++ spc() ++ prlist_with_sep spc
- (fun b -> if b then str"+" else str"-") l
+ ++ pr_reference m ++ spc() ++
+ prlist_with_sep spc pr_hint_mode l
| HintsConstructors c ->
keyword "Constructors"
++ spc() ++ prlist_with_sep spc pr_reference c
@@ -243,6 +231,11 @@ module Make
| NoInline -> str "[no inline]"
| InlineAt i -> str "[inline at level " ++ int i ++ str "]"
+ let pr_assumption_inline = function
+ | DefaultInline -> str "Inline"
+ | NoInline -> mt ()
+ | InlineAt i -> str "Inline(" ++ int i ++ str ")"
+
let pr_module_ast_inl leading_space pr_c (mast,inl) =
pr_module_ast leading_space pr_c mast ++ pr_inline inl
@@ -272,11 +265,12 @@ module Make
| _ as c -> brk(0,2) ++ str" :" ++ pr_c c
let pr_decl_notation prc ((loc,ntn),c,scopt) =
- fnl () ++ keyword "where " ++ qs ntn ++ str " := " ++ prc c ++
+ fnl () ++ keyword "where " ++ qs ntn ++ str " := "
+ ++ Flags.without_option Flags.beautify prc c ++
pr_opt (fun sc -> str ": " ++ str sc) scopt
let pr_binders_arg =
- pr_ne_sep spc pr_binders
+ pr_non_empty_arg pr_binders
let pr_and_type_binders_arg bl =
pr_binders_arg bl
@@ -375,8 +369,9 @@ module Make
| SetAssoc RightA -> keyword "right associativity"
| SetAssoc NonA -> keyword "no associativity"
| SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ
- | SetOnlyParsing Flags.Current -> keyword "only parsing"
- | SetOnlyParsing v -> keyword("compat \"" ^ Flags.pr_version v ^ "\"")
+ | SetOnlyPrinting -> keyword "only printing"
+ | SetOnlyParsing -> keyword "only parsing"
+ | SetCompatVersion v -> keyword("compat \"" ^ Flags.pr_version v ^ "\"")
| SetFormat("text",s) -> keyword "format " ++ pr_located qs s
| SetFormat(k,s) -> keyword "format " ++ qs k ++ spc() ++ pr_located qs s
@@ -385,22 +380,19 @@ module Make
| l -> spc() ++
hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")")
- let print_level n =
- if not (Int.equal n 0) then
- spc () ++ tag_keyword (str "(at level " ++ int n ++ str ")")
- else
- mt ()
-
- let pr_grammar_tactic_rule n (_,pil,t) =
- hov 2 (keyword "Tactic Notation" ++ print_level n ++ spc() ++
- hov 0 (prlist_with_sep sep pr_production_item pil ++
- spc() ++ str":=" ++ spc() ++ pr_raw_tactic t))
-
let pr_univs pl =
match pl with
| None -> mt ()
| Some pl -> str"@{" ++ prlist_with_sep spc pr_lident pl ++ str"}"
+ let pr_rec_definition ((((loc,id),pl),ro,bl,type_,def),ntn) =
+ let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in
+ let annot = pr_guard_annot pr_lconstr_expr bl ro in
+ pr_id id ++ pr_univs pl ++ pr_binders_arg bl ++ annot
+ ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_
+ ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr def) def
+ ++ prlist (pr_decl_notation pr_constr) ntn
+
let pr_statement head (idpl,(bl,c,guard)) =
assert (not (Option.is_empty idpl));
let id, pl = Option.get idpl in
@@ -417,894 +409,843 @@ module Make
(**************************************)
(* Pretty printer for vernac commands *)
(**************************************)
- let make_pr_vernac pr_constr pr_lconstr =
- let pr_constrarg c = spc () ++ pr_constr c in
- let pr_lconstrarg c = spc () ++ pr_lconstr c in
- let pr_intarg n = spc () ++ int n in
- let pr_oc = function
- None -> str" :"
- | Some true -> str" :>"
- | Some false -> str" :>>"
- in
- let pr_record_field ((x, pri), ntn) =
- let prx = match x with
- | (oc,AssumExpr (id,t)) ->
- hov 1 (pr_lname id ++
- pr_oc oc ++ spc() ++
- pr_lconstr_expr t)
- | (oc,DefExpr(id,b,opt)) -> (match opt with
- | Some t ->
- hov 1 (pr_lname id ++
- pr_oc oc ++ spc() ++
- pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b)
- | None ->
- hov 1 (pr_lname id ++ str" :=" ++ spc() ++
- pr_lconstr b)) in
- let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in
- prx ++ prpri ++ prlist (pr_decl_notation pr_constr) ntn
- in
- let pr_record_decl b c fs =
- pr_opt pr_lident c ++ (if c = None then str"{" else str" {") ++
- hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}")
- in
- let pr_printable = function
- | PrintFullContext ->
- keyword "Print All"
- | PrintSectionContext s ->
- keyword "Print Section" ++ spc() ++ Libnames.pr_reference s
- | PrintGrammar ent ->
- keyword "Print Grammar" ++ spc() ++ str ent
- | PrintLoadPath dir ->
- keyword "Print LoadPath" ++ pr_opt pr_dirpath dir
- | PrintModules ->
- keyword "Print Modules"
- | PrintMLLoadPath ->
- keyword "Print ML Path"
- | PrintMLModules ->
- keyword "Print ML Modules"
- | PrintDebugGC ->
- keyword "Print ML GC"
- | PrintGraph ->
- keyword "Print Graph"
- | PrintClasses ->
- keyword "Print Classes"
- | PrintTypeClasses ->
- keyword "Print TypeClasses"
- | PrintInstances qid ->
- keyword "Print Instances" ++ spc () ++ pr_smart_global qid
- | PrintLtac qid ->
- keyword "Print Ltac" ++ spc() ++ pr_ltac_ref qid
- | PrintCoercions ->
- keyword "Print Coercions"
- | PrintCoercionPaths (s,t) ->
- keyword "Print Coercion Paths" ++ spc()
- ++ pr_class_rawexpr s ++ spc()
- ++ pr_class_rawexpr t
- | PrintCanonicalConversions ->
- keyword "Print Canonical Structures"
- | PrintTables ->
- keyword "Print Tables"
- | PrintHintGoal ->
- keyword "Print Hint"
- | PrintHint qid ->
- keyword "Print Hint" ++ spc () ++ pr_smart_global qid
- | PrintHintDb ->
- keyword "Print Hint *"
- | PrintHintDbName s ->
- keyword "Print HintDb" ++ spc () ++ str s
- | PrintRewriteHintDbName s ->
- keyword "Print Rewrite HintDb" ++ spc() ++ str s
- | PrintUniverses (b, fopt) ->
- let cmd =
- if b then "Print Sorted Universes"
- else "Print Universes"
+ let pr_constrarg c = spc () ++ pr_constr c
+ let pr_lconstrarg c = spc () ++ pr_lconstr c
+ let pr_intarg n = spc () ++ int n
+
+ let pr_oc = function
+ | None -> str" :"
+ | Some true -> str" :>"
+ | Some false -> str" :>>"
+
+ let pr_record_field ((x, pri), ntn) =
+ let prx = match x with
+ | (oc,AssumExpr (id,t)) ->
+ hov 1 (pr_lname id ++
+ pr_oc oc ++ spc() ++
+ pr_lconstr_expr t)
+ | (oc,DefExpr(id,b,opt)) -> (match opt with
+ | Some t ->
+ hov 1 (pr_lname id ++
+ pr_oc oc ++ spc() ++
+ pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b)
+ | None ->
+ hov 1 (pr_lname id ++ str" :=" ++ spc() ++
+ pr_lconstr b)) in
+ let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in
+ prx ++ prpri ++ prlist (pr_decl_notation pr_constr) ntn
+
+ let pr_record_decl b c fs =
+ pr_opt pr_lident c ++ (if c = None then str"{" else str" {") ++
+ hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}")
+
+ let pr_printable = function
+ | PrintFullContext ->
+ keyword "Print All"
+ | PrintSectionContext s ->
+ keyword "Print Section" ++ spc() ++ Libnames.pr_reference s
+ | PrintGrammar ent ->
+ keyword "Print Grammar" ++ spc() ++ str ent
+ | PrintLoadPath dir ->
+ keyword "Print LoadPath" ++ pr_opt pr_dirpath dir
+ | PrintModules ->
+ keyword "Print Modules"
+ | PrintMLLoadPath ->
+ keyword "Print ML Path"
+ | PrintMLModules ->
+ keyword "Print ML Modules"
+ | PrintDebugGC ->
+ keyword "Print ML GC"
+ | PrintGraph ->
+ keyword "Print Graph"
+ | PrintClasses ->
+ keyword "Print Classes"
+ | PrintTypeClasses ->
+ keyword "Print TypeClasses"
+ | PrintInstances qid ->
+ keyword "Print Instances" ++ spc () ++ pr_smart_global qid
+ | PrintCoercions ->
+ keyword "Print Coercions"
+ | PrintCoercionPaths (s,t) ->
+ keyword "Print Coercion Paths" ++ spc()
+ ++ pr_class_rawexpr s ++ spc()
+ ++ pr_class_rawexpr t
+ | PrintCanonicalConversions ->
+ keyword "Print Canonical Structures"
+ | PrintTables ->
+ keyword "Print Tables"
+ | PrintHintGoal ->
+ keyword "Print Hint"
+ | PrintHint qid ->
+ keyword "Print Hint" ++ spc () ++ pr_smart_global qid
+ | PrintHintDb ->
+ keyword "Print Hint *"
+ | PrintHintDbName s ->
+ keyword "Print HintDb" ++ spc () ++ str s
+ | PrintUniverses (b, fopt) ->
+ let cmd =
+ if b then "Print Sorted Universes"
+ else "Print Universes"
+ in
+ keyword cmd ++ pr_opt str fopt
+ | PrintName qid ->
+ keyword "Print" ++ spc() ++ pr_smart_global qid
+ | PrintModuleType qid ->
+ keyword "Print Module Type" ++ spc() ++ pr_reference qid
+ | PrintModule qid ->
+ keyword "Print Module" ++ spc() ++ pr_reference qid
+ | PrintInspect n ->
+ keyword "Inspect" ++ spc() ++ int n
+ | PrintScopes ->
+ keyword "Print Scopes"
+ | PrintScope s ->
+ keyword "Print Scope" ++ spc() ++ str s
+ | PrintVisibility s ->
+ keyword "Print Visibility" ++ pr_opt str s
+ | PrintAbout (qid,gopt) ->
+ pr_opt (fun g -> int g ++ str ":"++ spc()) gopt
+ ++ keyword "About" ++ spc() ++ pr_smart_global qid
+ | PrintImplicit qid ->
+ keyword "Print Implicit" ++ spc() ++ pr_smart_global qid
+ (* spiwack: command printing all the axioms and section variables used in a
+ term *)
+ | PrintAssumptions (b, t, qid) ->
+ let cmd = match b, t with
+ | true, true -> "Print All Dependencies"
+ | true, false -> "Print Opaque Dependencies"
+ | false, true -> "Print Transparent Dependencies"
+ | false, false -> "Print Assumptions"
+ in
+ keyword cmd ++ spc() ++ pr_smart_global qid
+ | PrintNamespace dp ->
+ keyword "Print Namespace" ++ pr_dirpath dp
+ | PrintStrategy None ->
+ keyword "Print Strategies"
+ | PrintStrategy (Some qid) ->
+ keyword "Print Strategy" ++ pr_smart_global qid
+
+ let pr_using e = str (Proof_using.to_string e)
+
+ let rec pr_vernac_body v =
+ let return = Taggers.tag_vernac v in
+ match v with
+ | VernacPolymorphic (poly, v) ->
+ let s = if poly then keyword "Polymorphic" else keyword "Monomorphic" in
+ return (s ++ spc () ++ pr_vernac_body v)
+ | VernacProgram v ->
+ return (keyword "Program" ++ spc() ++ pr_vernac_body v)
+ | VernacLocal (local, v) ->
+ return (pr_locality local ++ spc() ++ pr_vernac_body v)
+
+ (* Stm *)
+ | VernacStm JoinDocument ->
+ return (keyword "Stm JoinDocument")
+ | VernacStm PrintDag ->
+ return (keyword "Stm PrintDag")
+ | VernacStm Finish ->
+ return (keyword "Stm Finish")
+ | VernacStm Wait ->
+ return (keyword "Stm Wait")
+ | VernacStm (Observe id) ->
+ return (keyword "Stm Observe " ++ str(Stateid.to_string id))
+ | VernacStm (Command v) ->
+ return (keyword "Stm Command " ++ pr_vernac_body v)
+ | VernacStm (PGLast v) ->
+ return (keyword "Stm PGLast " ++ pr_vernac_body v)
+
+ (* Proof management *)
+ | VernacAbortAll ->
+ return (keyword "Abort All")
+ | VernacRestart ->
+ return (keyword "Restart")
+ | VernacUnfocus ->
+ return (keyword "Unfocus")
+ | VernacUnfocused ->
+ return (keyword "Unfocused")
+ | VernacGoal c ->
+ return (keyword "Goal" ++ pr_lconstrarg c)
+ | VernacAbort id ->
+ return (keyword "Abort" ++ pr_opt pr_lident id)
+ | VernacUndo i ->
+ return (
+ if Int.equal i 1 then keyword "Undo" else keyword "Undo" ++ pr_intarg i
+ )
+ | VernacUndoTo i ->
+ return (keyword "Undo" ++ spc() ++ keyword "To" ++ pr_intarg i)
+ | VernacBacktrack (i,j,k) ->
+ return (keyword "Backtrack" ++ spc() ++ prlist_with_sep sep int [i;j;k])
+ | VernacFocus i ->
+ return (keyword "Focus" ++ pr_opt int i)
+ | VernacShow s ->
+ let pr_goal_reference = function
+ | OpenSubgoals -> mt ()
+ | NthGoal n -> spc () ++ int n
+ | GoalId id -> spc () ++ pr_id id
+ | GoalUid n -> spc () ++ str n in
+ let pr_showable = function
+ | ShowGoal n -> keyword "Show" ++ pr_goal_reference n
+ | ShowGoalImplicitly n -> keyword "Show Implicit Arguments" ++ pr_opt int n
+ | ShowProof -> keyword "Show Proof"
+ | ShowNode -> keyword "Show Node"
+ | ShowScript -> keyword "Show Script"
+ | ShowExistentials -> keyword "Show Existentials"
+ | ShowUniverses -> keyword "Show Universes"
+ | ShowTree -> keyword "Show Tree"
+ | ShowProofNames -> keyword "Show Conjectures"
+ | ShowIntros b -> keyword "Show " ++ (if b then keyword "Intros" else keyword "Intro")
+ | ShowMatch id -> keyword "Show Match " ++ pr_reference id
+ | ShowThesis -> keyword "Show Thesis"
in
- keyword cmd ++ pr_opt str fopt
- | PrintName qid ->
- keyword "Print" ++ spc() ++ pr_smart_global qid
- | PrintModuleType qid ->
- keyword "Print Module Type" ++ spc() ++ pr_reference qid
- | PrintModule qid ->
- keyword "Print Module" ++ spc() ++ pr_reference qid
- | PrintInspect n ->
- keyword "Inspect" ++ spc() ++ int n
- | PrintScopes ->
- keyword "Print Scopes"
- | PrintScope s ->
- keyword "Print Scope" ++ spc() ++ str s
- | PrintVisibility s ->
- keyword "Print Visibility" ++ pr_opt str s
- | PrintAbout (qid,gopt) ->
- pr_opt (fun g -> int g ++ str ":"++ spc()) gopt
- ++ keyword "About" ++ spc() ++ pr_smart_global qid
- | PrintImplicit qid ->
- keyword "Print Implicit" ++ spc() ++ pr_smart_global qid
- (* spiwack: command printing all the axioms and section variables used in a
- term *)
- | PrintAssumptions (b, t, qid) ->
- let cmd = match b, t with
- | true, true -> "Print All Dependencies"
- | true, false -> "Print Opaque Dependencies"
- | false, true -> "Print Transparent Dependencies"
- | false, false -> "Print Assumptions"
+ return (pr_showable s)
+ | VernacCheckGuard ->
+ return (keyword "Guarded")
+
+ (* Resetting *)
+ | VernacResetName id ->
+ return (keyword "Reset" ++ spc() ++ pr_lident id)
+ | VernacResetInitial ->
+ return (keyword "Reset Initial")
+ | VernacBack i ->
+ return (
+ if Int.equal i 1 then keyword "Back" else keyword "Back" ++ pr_intarg i
+ )
+ | VernacBackTo i ->
+ return (keyword "BackTo" ++ pr_intarg i)
+
+ (* State management *)
+ | VernacWriteState s ->
+ return (keyword "Write State" ++ spc () ++ qs s)
+ | VernacRestoreState s ->
+ return (keyword "Restore State" ++ spc() ++ qs s)
+
+ (* Control *)
+ | VernacLoad (f,s) ->
+ return (
+ keyword "Load"
+ ++ if f then
+ (spc() ++ keyword "Verbose" ++ spc())
+ else
+ spc() ++ qs s
+ )
+ | VernacTime (_,v) ->
+ return (keyword "Time" ++ spc() ++ pr_vernac_body v)
+ | VernacRedirect (s, (_,v)) ->
+ return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_body v)
+ | VernacTimeout(n,v) ->
+ return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_body v)
+ | VernacFail v ->
+ return (keyword "Fail" ++ spc() ++ pr_vernac_body v)
+ | VernacError _ ->
+ return (keyword "No-parsing-rule for VernacError")
+
+ (* Syntax *)
+ | VernacOpenCloseScope (_,(opening,sc)) ->
+ return (
+ keyword (if opening then "Open " else "Close ") ++
+ keyword "Scope" ++ spc() ++ str sc
+ )
+ | VernacDelimiters (sc,Some key) ->
+ return (
+ keyword "Delimit Scope" ++ spc () ++ str sc ++
+ spc() ++ keyword "with" ++ spc () ++ str key
+ )
+ | VernacDelimiters (sc, None) ->
+ return (
+ keyword "Undelimit Scope" ++ spc () ++ str sc
+ )
+ | VernacBindScope (sc,cll) ->
+ return (
+ keyword "Bind Scope" ++ spc () ++ str sc ++
+ spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_class_rawexpr cll
+ )
+ | VernacArgumentsScope (q,scl) ->
+ let pr_opt_scope = function
+ | None -> str"_"
+ | Some sc -> str sc
in
- keyword cmd ++ spc() ++ pr_smart_global qid
- | PrintNamespace dp ->
- keyword "Print Namespace" ++ pr_dirpath dp
- | PrintStrategy None ->
- keyword "Print Strategies"
- | PrintStrategy (Some qid) ->
- keyword "Print Strategy" ++ pr_smart_global qid
- in
+ return (
+ keyword "Arguments Scope"
+ ++ spc() ++ pr_smart_global q
+ ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]"
+ )
+ | VernacInfix (_,((_,s),mv),q,sn) -> (* A Verifier *)
+ return (
+ hov 0 (hov 0 (keyword "Infix "
+ ++ qs s ++ str " :=" ++ pr_constrarg q) ++
+ pr_syntax_modifiers mv ++
+ (match sn with
+ | None -> mt()
+ | Some sc -> spc() ++ str":" ++ spc() ++ str sc))
+ )
+ | VernacNotation (_,c,((_,s),l),opt) ->
+ return (
+ hov 2 (keyword "Notation" ++ spc() ++ qs s ++
+ str " :=" ++ Flags.without_option Flags.beautify pr_constrarg c ++ pr_syntax_modifiers l ++
+ (match opt with
+ | None -> mt()
+ | Some sc -> str" :" ++ spc() ++ str sc))
+ )
+ | VernacSyntaxExtension (_,(s,l)) ->
+ return (
+ keyword "Reserved Notation" ++ spc() ++ pr_located qs s ++
+ pr_syntax_modifiers l
+ )
+ | VernacNotationAddFormat(s,k,v) ->
+ return (
+ keyword "Format Notation " ++ qs s ++ spc () ++ qs k ++ spc() ++ qs v
+ )
+
+ (* Gallina *)
+ | VernacDefinition (d,id,b) -> (* A verifier... *)
+ let pr_def_token (l,dk) =
+ let l = match l with Some x -> x | None -> Decl_kinds.Global in
+ keyword (Kindops.string_of_definition_kind (l,false,dk))
+ in
+ let pr_reduce = function
+ | None -> mt()
+ | Some r ->
+ keyword "Eval" ++ spc() ++
+ pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) r ++
+ keyword " in" ++ spc()
+ in
+ let pr_def_body = function
+ | DefineBody (bl,red,body,d) ->
+ let ty = match d with
+ | None -> mt()
+ | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty
+ in
+ (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body))
+ | ProveBody (bl,t) ->
+ (pr_binders_arg bl, str" :" ++ pr_spc_lconstr t, None) in
+ let (binds,typ,c) = pr_def_body b in
+ return (
+ hov 2 (
+ pr_def_token d ++ spc()
+ ++ pr_plident id ++ binds ++ typ
+ ++ (match c with
+ | None -> mt()
+ | Some cc -> str" :=" ++ spc() ++ cc))
+ )
+
+ | VernacStartTheoremProof (ki,l,_) ->
+ return (
+ hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++
+ prlist (pr_statement (spc () ++ keyword "with")) (List.tl l))
+ )
+
+ | VernacEndProof Admitted ->
+ return (keyword "Admitted")
+
+ | VernacEndProof (Proved (opac,o)) -> return (
+ match o with
+ | None -> (match opac with
+ | Transparent -> keyword "Defined"
+ | Opaque None -> keyword "Qed"
+ | Opaque (Some l) ->
+ keyword "Qed" ++ spc() ++ str"export" ++
+ prlist_with_sep (fun () -> str", ") pr_lident l)
+ | Some (id,th) -> (match th with
+ | None -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id
+ | Some tok -> keyword "Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)
+ )
+ | VernacExactProof c ->
+ return (hov 2 (keyword "Proof" ++ pr_lconstrarg c))
+ | VernacAssumption (stre,t,l) ->
+ let n = List.length (List.flatten (List.map fst (List.map snd l))) in
+ let pr_params (c, (xl, t)) =
+ hov 2 (prlist_with_sep sep pr_plident xl ++ spc() ++
+ (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t)) in
+ let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in
+ return (hov 2 (pr_assumption_token (n > 1) stre ++
+ pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions))
+ | VernacInductive (p,f,l) ->
+ let pr_constructor (coe,(id,c)) =
+ hov 2 (pr_lident id ++ str" " ++
+ (if coe then str":>" else str":") ++
+ Flags.without_option Flags.beautify pr_spc_lconstr c)
+ in
+ let pr_constructor_list b l = match l with
+ | Constructors [] -> mt()
+ | Constructors l ->
+ let fst_sep = match l with [_] -> " " | _ -> " | " in
+ pr_com_at (begin_of_inductive l) ++
+ fnl() ++ str fst_sep ++
+ prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l
+ | RecordDecl (c,fs) ->
+ pr_record_decl b c fs
+ in
+ let pr_oneind key (((coe,(id,pl)),indpar,s,k,lc),ntn) =
+ hov 0 (
+ str key ++ spc() ++
+ (if coe then str"> " else str"") ++ pr_lident id ++ pr_univs pl ++
+ pr_and_type_binders_arg indpar ++
+ pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) s ++
+ str" :=") ++ pr_constructor_list k lc ++
+ prlist (pr_decl_notation pr_constr) ntn
+ in
+ let key =
+ let (_,_,_,k,_),_ = List.hd l in
+ match k with Record -> "Record" | Structure -> "Structure"
+ | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive"
+ | Class _ -> "Class" | Variant -> "Variant"
+ in
+ return (
+ hov 1 (pr_oneind key (List.hd l)) ++
+ (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
+ )
+
+ | VernacFixpoint (local, recs) ->
+ let local = match local with
+ | Some Discharge -> "Let "
+ | Some Local -> "Local "
+ | None | Some Global -> ""
+ in
+ return (
+ hov 0 (str local ++ keyword "Fixpoint" ++ spc () ++
+ prlist_with_sep (fun _ -> fnl () ++ keyword "with"
+ ++ spc ()) pr_rec_definition recs)
+ )
+
+ | VernacCoFixpoint (local, corecs) ->
+ let local = match local with
+ | Some Discharge -> keyword "Let" ++ spc ()
+ | Some Local -> keyword "Local" ++ spc ()
+ | None | Some Global -> str ""
+ in
+ let pr_onecorec ((((loc,id),pl),bl,c,def),ntn) =
+ pr_id id ++ pr_univs pl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++
+ spc() ++ pr_lconstr_expr c ++
+ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++
+ prlist (pr_decl_notation pr_constr) ntn
+ in
+ return (
+ hov 0 (local ++ keyword "CoFixpoint" ++ spc() ++
+ prlist_with_sep (fun _ -> fnl() ++ keyword "with" ++ spc ()) pr_onecorec corecs)
+ )
+ | VernacScheme l ->
+ return (
+ hov 2 (keyword "Scheme" ++ spc() ++
+ prlist_with_sep (fun _ -> fnl() ++ keyword "with" ++ spc ()) pr_onescheme l)
+ )
+ | VernacCombinedScheme (id, l) ->
+ return (
+ hov 2 (keyword "Combined Scheme" ++ spc() ++
+ pr_lident id ++ spc() ++ keyword "from" ++ spc() ++
+ prlist_with_sep (fun _ -> fnl() ++ str", ") pr_lident l)
+ )
+ | VernacUniverse v ->
+ return (
+ hov 2 (keyword "Universe" ++ spc () ++
+ prlist_with_sep (fun _ -> str",") pr_lident v)
+ )
+ | VernacConstraint v ->
+ let pr_uconstraint (l, d, r) =
+ pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++
+ pr_glob_level r
+ in
+ return (
+ hov 2 (keyword "Constraint" ++ spc () ++
+ prlist_with_sep (fun _ -> str",") pr_uconstraint v)
+ )
+
+ (* Gallina extensions *)
+ | VernacBeginSection id ->
+ return (hov 2 (keyword "Section" ++ spc () ++ pr_lident id))
+ | VernacEndSegment id ->
+ return (hov 2 (keyword "End" ++ spc() ++ pr_lident id))
+ | VernacNameSectionHypSet (id,set) ->
+ return (hov 2 (keyword "Package" ++ spc() ++ pr_lident id ++ spc()++
+ str ":="++spc()++pr_using set))
+ | VernacRequire (from, exp, l) ->
+ let from = match from with
+ | None -> mt ()
+ | Some r -> keyword "From" ++ spc () ++ pr_module r ++ spc ()
+ in
+ return (
+ hov 2
+ (from ++ keyword "Require" ++ spc() ++ pr_require_token exp ++
+ prlist_with_sep sep pr_module l)
+ )
+ | VernacImport (f,l) ->
+ return (
+ (if f then keyword "Export" else keyword "Import") ++ spc() ++
+ prlist_with_sep sep pr_import_module l
+ )
+ | VernacCanonical q ->
+ return (
+ keyword "Canonical Structure" ++ spc() ++ pr_smart_global q
+ )
+ | VernacCoercion (_,id,c1,c2) ->
+ return (
+ hov 1 (
+ keyword "Coercion" ++ spc() ++
+ pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++
+ spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2)
+ )
+ | VernacIdentityCoercion (_,id,c1,c2) ->
+ return (
+ hov 1 (
+ keyword "Identity Coercion" ++ spc() ++ pr_lident id ++
+ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++
+ spc() ++ pr_class_rawexpr c2)
+ )
+
+ | VernacInstance (abst, sup, (instid, bk, cl), props, info) ->
+ return (
+ hov 1 (
+ (if abst then keyword "Declare" ++ spc () else mt ()) ++
+ keyword "Instance" ++
+ (match instid with
+ | (loc, Name id), l -> spc () ++ pr_plident ((loc, id),l) ++ spc ()
+ | (_, Anonymous), _ -> mt ()) ++
+ pr_and_type_binders_arg sup ++
+ str":" ++ spc () ++
+ (match bk with Implicit -> str "! " | Explicit -> mt ()) ++
+ pr_constr cl ++ pr_hint_info pr_constr_pattern_expr info ++
+ (match props with
+ | Some (true,CRecord (_,l)) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}"
+ | Some (true,_) -> assert false
+ | Some (false,p) -> spc () ++ str":=" ++ spc () ++ pr_constr p
+ | None -> mt()))
+ )
+
+ | VernacContext l ->
+ return (
+ hov 1 (
+ keyword "Context" ++ pr_and_type_binders_arg l)
+ )
+
+ | VernacDeclareInstances insts ->
+ let pr_inst (id, info) =
+ pr_reference id ++ pr_hint_info pr_constr_pattern_expr info
+ in
+ return (
+ hov 1 (keyword "Existing" ++ spc () ++
+ keyword(String.plural (List.length insts) "Instance") ++
+ spc () ++ prlist_with_sep (fun () -> str", ") pr_inst insts)
+ )
+
+ | VernacDeclareClass id ->
+ return (
+ hov 1 (keyword "Existing" ++ spc () ++ keyword "Class" ++ spc () ++ pr_reference id)
+ )
+
+ (* Modules and Module Types *)
+ | VernacDefineModule (export,m,bl,tys,bd) ->
+ let b = pr_module_binders bl pr_lconstr in
+ return (
+ hov 2 (keyword "Module" ++ spc() ++ pr_require_token export ++
+ pr_lident m ++ b ++
+ pr_of_module_type pr_lconstr tys ++
+ (if List.is_empty bd then mt () else str ":= ") ++
+ prlist_with_sep (fun () -> str " <+")
+ (pr_module_ast_inl true pr_lconstr) bd)
+ )
+ | VernacDeclareModule (export,id,bl,m1) ->
+ let b = pr_module_binders bl pr_lconstr in
+ return (
+ hov 2 (keyword "Declare Module" ++ spc() ++ pr_require_token export ++
+ pr_lident id ++ b ++ str " :" ++
+ pr_module_ast_inl true pr_lconstr m1)
+ )
+ | VernacDeclareModuleType (id,bl,tyl,m) ->
+ let b = pr_module_binders bl pr_lconstr in
+ let pr_mt = pr_module_ast_inl true pr_lconstr in
+ return (
+ hov 2 (keyword "Module Type " ++ pr_lident id ++ b ++
+ prlist_strict (fun m -> str " <:" ++ pr_mt m) tyl ++
+ (if List.is_empty m then mt () else str ":= ") ++
+ prlist_with_sep (fun () -> str " <+ ") pr_mt m)
+ )
+ | VernacInclude (mexprs) ->
+ let pr_m = pr_module_ast_inl false pr_lconstr in
+ return (
+ hov 2 (keyword "Include" ++ spc() ++
+ prlist_with_sep (fun () -> str " <+ ") pr_m mexprs)
+ )
+ (* Solving *)
+ | VernacSolveExistential (i,c) ->
+ return (keyword "Existential" ++ spc () ++ int i ++ pr_lconstrarg c)
+
+ (* Auxiliary file and library management *)
+ | VernacAddLoadPath (fl,s,d) ->
+ return (
+ hov 2
+ (keyword "Add" ++
+ (if fl then spc () ++ keyword "Rec" ++ spc () else spc()) ++
+ keyword "LoadPath" ++ spc() ++ qs s ++
+ (match d with
+ | None -> mt()
+ | Some dir -> spc() ++ keyword "as" ++ spc() ++ pr_dirpath dir))
+ )
+ | VernacRemoveLoadPath s ->
+ return (keyword "Remove LoadPath" ++ qs s)
+ | VernacAddMLPath (fl,s) ->
+ return (
+ keyword "Add"
+ ++ (if fl then spc () ++ keyword "Rec" ++ spc () else spc())
+ ++ keyword "ML Path"
+ ++ qs s
+ )
+ | VernacDeclareMLModule (l) ->
+ return (
+ hov 2 (keyword "Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l)
+ )
+ | VernacChdir s ->
+ return (keyword "Cd" ++ pr_opt qs s)
- let pr_using e = str (Proof_using.to_string e) in
-
- let rec pr_vernac v =
- let return = Taggers.tag_vernac v in
- match v with
- | VernacPolymorphic (poly, v) ->
- let s = if poly then keyword "Polymorphic" else keyword "Monomorphic" in
- return (s ++ pr_vernac v)
- | VernacProgram v ->
- return (keyword "Program" ++ spc() ++ pr_vernac v)
- | VernacLocal (local, v) ->
- return (pr_locality local ++ spc() ++ pr_vernac v)
-
- (* Stm *)
- | VernacStm JoinDocument ->
- return (keyword "Stm JoinDocument")
- | VernacStm PrintDag ->
- return (keyword "Stm PrintDag")
- | VernacStm Finish ->
- return (keyword "Stm Finish")
- | VernacStm Wait ->
- return (keyword "Stm Wait")
- | VernacStm (Observe id) ->
- return (keyword "Stm Observe " ++ str(Stateid.to_string id))
- | VernacStm (Command v) ->
- return (keyword "Stm Command " ++ pr_vernac v)
- | VernacStm (PGLast v) ->
- return (keyword "Stm PGLast " ++ pr_vernac v)
-
- (* Proof management *)
- | VernacAbortAll ->
- return (keyword "Abort All")
- | VernacRestart ->
- return (keyword "Restart")
- | VernacUnfocus ->
- return (keyword "Unfocus")
- | VernacUnfocused ->
- return (keyword "Unfocused")
- | VernacGoal c ->
- return (keyword "Goal" ++ pr_lconstrarg c)
- | VernacAbort id ->
- return (keyword "Abort" ++ pr_opt pr_lident id)
- | VernacUndo i ->
- return (
- if Int.equal i 1 then keyword "Undo" else keyword "Undo" ++ pr_intarg i
- )
- | VernacUndoTo i ->
- return (keyword "Undo" ++ spc() ++ keyword "To" ++ pr_intarg i)
- | VernacBacktrack (i,j,k) ->
- return (keyword "Backtrack" ++ spc() ++ prlist_with_sep sep int [i;j;k])
- | VernacFocus i ->
- return (keyword "Focus" ++ pr_opt int i)
- | VernacShow s ->
- let pr_goal_reference = function
- | OpenSubgoals -> mt ()
- | NthGoal n -> spc () ++ int n
- | GoalId id -> spc () ++ pr_id id
- | GoalUid n -> spc () ++ str n in
- let pr_showable = function
- | ShowGoal n -> keyword "Show" ++ pr_goal_reference n
- | ShowGoalImplicitly n -> keyword "Show Implicit Arguments" ++ pr_opt int n
- | ShowProof -> keyword "Show Proof"
- | ShowNode -> keyword "Show Node"
- | ShowScript -> keyword "Show Script"
- | ShowExistentials -> keyword "Show Existentials"
- | ShowUniverses -> keyword "Show Universes"
- | ShowTree -> keyword "Show Tree"
- | ShowProofNames -> keyword "Show Conjectures"
- | ShowIntros b -> keyword "Show " ++ (if b then keyword "Intros" else keyword "Intro")
- | ShowMatch id -> keyword "Show Match " ++ pr_lident id
- | ShowThesis -> keyword "Show Thesis"
- in
- return (pr_showable s)
- | VernacCheckGuard ->
- return (keyword "Guarded")
-
- (* Resetting *)
- | VernacResetName id ->
- return (keyword "Reset" ++ spc() ++ pr_lident id)
- | VernacResetInitial ->
- return (keyword "Reset Initial")
- | VernacBack i ->
- return (
- if Int.equal i 1 then keyword "Back" else keyword "Back" ++ pr_intarg i
- )
- | VernacBackTo i ->
- return (keyword "BackTo" ++ pr_intarg i)
-
- (* State management *)
- | VernacWriteState s ->
- return (keyword "Write State" ++ spc () ++ qs s)
- | VernacRestoreState s ->
- return (keyword "Restore State" ++ spc() ++ qs s)
-
- (* Control *)
- | VernacLoad (f,s) ->
- return (
- keyword "Load"
- ++ if f then
- (spc() ++ keyword "Verbose" ++ spc())
- else
- spc() ++ qs s
- )
- | VernacTime v ->
- return (keyword "Time" ++ spc() ++ pr_vernac_list v)
- | VernacRedirect (s, v) ->
- return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_list v)
- | VernacTimeout(n,v) ->
- return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac v)
- | VernacFail v ->
- return (keyword "Fail" ++ spc() ++ pr_vernac v)
- | VernacError _ ->
- return (keyword "No-parsing-rule for VernacError")
-
- (* Syntax *)
- | VernacTacticNotation (n,r,e) ->
- return (pr_grammar_tactic_rule n ("",r,e))
- | VernacOpenCloseScope (_,(opening,sc)) ->
- return (
- keyword (if opening then "Open " else "Close ") ++
- keyword "Scope" ++ spc() ++ str sc
- )
- | VernacDelimiters (sc,Some key) ->
- return (
- keyword "Delimit Scope" ++ spc () ++ str sc ++
- spc() ++ keyword "with" ++ spc () ++ str key
- )
- | VernacDelimiters (sc, None) ->
- return (
- keyword "Undelimit Scope" ++ spc () ++ str sc
- )
- | VernacBindScope (sc,cll) ->
- return (
- keyword "Bind Scope" ++ spc () ++ str sc ++
- spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_smart_global cll
- )
- | VernacArgumentsScope (q,scl) ->
- let pr_opt_scope = function
- | None -> str"_"
- | Some sc -> str sc
- in
- return (
- keyword "Arguments Scope"
- ++ spc() ++ pr_smart_global q
- ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]"
- )
- | VernacInfix (_,((_,s),mv),q,sn) -> (* A Verifier *)
- return (
- hov 0 (hov 0 (keyword "Infix "
- ++ qs s ++ str " :=" ++ pr_constrarg q) ++
- pr_syntax_modifiers mv ++
- (match sn with
- | None -> mt()
- | Some sc -> spc() ++ str":" ++ spc() ++ str sc))
- )
- | VernacNotation (_,c,((_,s),l),opt) ->
- let ps =
- let n = String.length s in
- if n > 2 && s.[0] == '\'' && s.[n-1] == '\''
- then
- let s' = String.sub s 1 (n-2) in
- if String.contains s' '\'' then qs s else str s'
- else qs s
- in
- return (
- hov 2 (keyword "Notation" ++ spc() ++ ps ++
- str " :=" ++ pr_constrarg c ++ pr_syntax_modifiers l ++
- (match opt with
- | None -> mt()
- | Some sc -> str" :" ++ spc() ++ str sc))
- )
- | VernacSyntaxExtension (_,(s,l)) ->
- return (
- keyword "Reserved Notation" ++ spc() ++ pr_located qs s ++
- pr_syntax_modifiers l
- )
- | VernacNotationAddFormat(s,k,v) ->
- return (
- keyword "Format Notation " ++ qs s ++ spc () ++ qs k ++ spc() ++ qs v
- )
-
- (* Gallina *)
- | VernacDefinition (d,id,b) -> (* A verifier... *)
- let pr_def_token (l,dk) =
- let l = match l with Some x -> x | None -> Decl_kinds.Global in
- keyword (Kindops.string_of_definition_kind (l,false,dk))
- in
- let pr_reduce = function
- | None -> mt()
- | Some r ->
- keyword "Eval" ++ spc() ++
- pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) r ++
- keyword " in" ++ spc()
- in
- let pr_def_body = function
- | DefineBody (bl,red,body,d) ->
- let ty = match d with
- | None -> mt()
- | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty
+ (* Commands *)
+ | VernacCreateHintDb (dbname,b) ->
+ return (
+ hov 1 (keyword "Create HintDb" ++ spc () ++
+ str dbname ++ (if b then str" discriminated" else mt ()))
+ )
+ | VernacRemoveHints (dbnames, ids) ->
+ return (
+ hov 1 (keyword "Remove Hints" ++ spc () ++
+ prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++
+ pr_opt_hintbases dbnames)
+ )
+ | VernacHints (_, dbnames,h) ->
+ return (pr_hints dbnames h pr_constr pr_constr_pattern_expr)
+ | VernacSyntacticDefinition (id,(ids,c),_,compat) ->
+ return (
+ hov 2
+ (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++
+ prlist_with_sep spc pr_id ids ++ str":=" ++ pr_constrarg c ++
+ pr_syntax_modifiers
+ (match compat with
+ | None -> []
+ | Some Flags.Current -> [SetOnlyParsing]
+ | Some v -> [SetCompatVersion v]))
+ )
+ | VernacDeclareImplicits (q,[]) ->
+ return (
+ hov 2 (keyword "Implicit Arguments" ++ spc() ++ pr_smart_global q)
+ )
+ | VernacDeclareImplicits (q,impls) ->
+ return (
+ hov 1 (keyword "Implicit Arguments" ++ spc () ++
+ spc() ++ pr_smart_global q ++ spc() ++
+ prlist_with_sep spc (fun imps ->
+ str"[" ++ prlist_with_sep sep pr_explanation imps ++ str"]")
+ impls)
+ )
+ | VernacArguments (q, args, more_implicits, nargs, mods) ->
+ return (
+ hov 2 (
+ keyword "Arguments" ++ spc() ++
+ pr_smart_global q ++
+ let pr_s = function None -> str"" | Some (_,s) -> str "%" ++ str s in
+ let pr_if b x = if b then x else str "" in
+ let pr_br imp x = match imp with
+ | Vernacexpr.Implicit -> str "[" ++ x ++ str "]"
+ | Vernacexpr.MaximallyImplicit -> str "{" ++ x ++ str "}"
+ | Vernacexpr.NotImplicit -> x in
+ let rec print_arguments n l =
+ match n, l with
+ | Some 0, l -> spc () ++ str"/" ++ print_arguments None l
+ | _, [] -> mt()
+ | n, { name = id; recarg_like = k;
+ notation_scope = s;
+ implicit_status = imp } :: tl ->
+ spc() ++ pr_br imp (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++
+ print_arguments (Option.map pred n) tl
+ in
+ let rec print_implicits = function
+ | [] -> mt ()
+ | (name, impl) :: rest ->
+ spc() ++ pr_br impl (pr_name name) ++ print_implicits rest
in
- (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body))
- | ProveBody (bl,t) ->
- (pr_binders_arg bl, str" :" ++ pr_spc_lconstr t, None) in
- let (binds,typ,c) = pr_def_body b in
- return (
- hov 2 (
- pr_def_token d ++ spc()
- ++ pr_plident id ++ binds ++ typ
- ++ (match c with
- | None -> mt()
- | Some cc -> str" :=" ++ spc() ++ cc))
- )
-
- | VernacStartTheoremProof (ki,l,_) ->
- return (
- hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++
- prlist (pr_statement (spc () ++ keyword "with")) (List.tl l))
- )
-
- | VernacEndProof Admitted ->
- return (keyword "Admitted")
-
- | VernacEndProof (Proved (opac,o)) -> return (
- match o with
- | None -> (match opac with
- | Transparent -> keyword "Defined"
- | Opaque None -> keyword "Qed"
- | Opaque (Some l) ->
- keyword "Qed" ++ spc() ++ str"export" ++
- prlist_with_sep (fun () -> str", ") pr_lident l)
- | Some (id,th) -> (match th with
- | None -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id
- | Some tok -> keyword "Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)
+ print_arguments nargs args ++
+ if not (List.is_empty more_implicits) then
+ prlist (fun l -> str"," ++ print_implicits l) more_implicits
+ else (mt ()) ++
+ (if not (List.is_empty mods) then str" : " else str"") ++
+ prlist_with_sep (fun () -> str", " ++ spc()) (function
+ | `ReductionDontExposeCase -> keyword "simpl nomatch"
+ | `ReductionNeverUnfold -> keyword "simpl never"
+ | `DefaultImplicits -> keyword "default implicits"
+ | `Rename -> keyword "rename"
+ | `Assert -> keyword "assert"
+ | `ExtraScopes -> keyword "extra scopes"
+ | `ClearImplicits -> keyword "clear implicits"
+ | `ClearScopes -> keyword "clear scopes")
+ mods)
+ )
+ | VernacReserve bl ->
+ let n = List.length (List.flatten (List.map fst bl)) in
+ return (
+ hov 2 (tag_keyword (str"Implicit Type" ++ str (if n > 1 then "s " else " "))
+ ++ pr_ne_params_list pr_lconstr_expr (List.map (fun sb -> false,sb) bl))
+ )
+ | VernacGeneralizable g ->
+ return (
+ hov 1 (tag_keyword (
+ str"Generalizable Variable" ++
+ match g with
+ | None -> str "s none"
+ | Some [] -> str "s all"
+ | Some idl ->
+ str (if List.length idl > 1 then "s " else " ") ++
+ prlist_with_sep spc pr_lident idl)
+ ))
+ | VernacSetOpacity(k,l) when Conv_oracle.is_transparent k ->
+ return (
+ hov 1 (keyword "Transparent" ++
+ spc() ++ prlist_with_sep sep pr_smart_global l)
)
- | VernacExactProof c ->
- return (hov 2 (keyword "Proof" ++ pr_lconstrarg c))
- | VernacAssumption (stre,_,l) ->
- let n = List.length (List.flatten (List.map fst (List.map snd l))) in
- let pr_params (c, (xl, t)) =
- hov 2 (prlist_with_sep sep pr_plident xl ++ spc() ++
- (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t))
- in
- let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in
- return (hov 2 (pr_assumption_token (n > 1) stre ++ spc() ++ assumptions))
- | VernacInductive (p,f,l) ->
- let pr_constructor (coe,(id,c)) =
- hov 2 (pr_lident id ++ str" " ++
- (if coe then str":>" else str":") ++
- pr_spc_lconstr c)
- in
- let pr_constructor_list b l = match l with
- | Constructors [] -> mt()
- | Constructors l ->
- let fst_sep = match l with [_] -> " " | _ -> " | " in
- pr_com_at (begin_of_inductive l) ++
- fnl() ++ str fst_sep ++
- prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l
- | RecordDecl (c,fs) ->
- pr_record_decl b c fs
- in
- let pr_oneind key (((coe,(id,pl)),indpar,s,k,lc),ntn) =
- hov 0 (
- str key ++ spc() ++
- (if coe then str"> " else str"") ++ pr_lident id ++ pr_univs pl ++
- pr_and_type_binders_arg indpar ++ spc() ++
- Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++
- str" :=") ++ pr_constructor_list k lc ++
- prlist (pr_decl_notation pr_constr) ntn
- in
- let key =
- let (_,_,_,k,_),_ = List.hd l in
- match k with Record -> "Record" | Structure -> "Structure"
- | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive"
- | Class _ -> "Class" | Variant -> "Variant"
- in
- return (
- hov 1 (pr_oneind key (List.hd l)) ++
- (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
- )
-
- | VernacFixpoint (local, recs) ->
- let local = match local with
- | Some Discharge -> "Let "
- | Some Local -> "Local "
- | None | Some Global -> ""
- in
- let pr_onerec = function
- | (((loc,id),pl),ro,bl,type_,def),ntn ->
- let annot = pr_guard_annot pr_lconstr_expr bl ro in
- pr_id id ++ pr_univs pl ++ pr_binders_arg bl ++ annot
- ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_
- ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++
- prlist (pr_decl_notation pr_constr) ntn
- in
- return (
- hov 0 (str local ++ keyword "Fixpoint" ++ spc () ++
- prlist_with_sep (fun _ -> fnl () ++ keyword "with" ++ spc ()) pr_onerec recs)
- )
-
- | VernacCoFixpoint (local, corecs) ->
- let local = match local with
- | Some Discharge -> keyword "Let" ++ spc ()
- | Some Local -> keyword "Local" ++ spc ()
- | None | Some Global -> str ""
- in
- let pr_onecorec ((((loc,id),pl),bl,c,def),ntn) =
- pr_id id ++ pr_univs pl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++
- spc() ++ pr_lconstr_expr c ++
- pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++
- prlist (pr_decl_notation pr_constr) ntn
- in
- return (
- hov 0 (local ++ keyword "CoFixpoint" ++ spc() ++
- prlist_with_sep (fun _ -> fnl() ++ keyword "with" ++ spc ()) pr_onecorec corecs)
- )
- | VernacScheme l ->
- return (
- hov 2 (keyword "Scheme" ++ spc() ++
- prlist_with_sep (fun _ -> fnl() ++ keyword "with" ++ spc ()) pr_onescheme l)
- )
- | VernacCombinedScheme (id, l) ->
- return (
- hov 2 (keyword "Combined Scheme" ++ spc() ++
- pr_lident id ++ spc() ++ keyword "from" ++ spc() ++
- prlist_with_sep (fun _ -> fnl() ++ str", ") pr_lident l)
- )
- | VernacUniverse v ->
- return (
- hov 2 (keyword "Universe" ++ spc () ++
- prlist_with_sep (fun _ -> str",") pr_lident v)
- )
- | VernacConstraint v ->
- let pr_uconstraint (l, d, r) =
- pr_lident l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ pr_lident r
- in
- return (
- hov 2 (keyword "Constraint" ++ spc () ++
- prlist_with_sep (fun _ -> str",") pr_uconstraint v)
- )
-
- (* Gallina extensions *)
- | VernacBeginSection id ->
- return (hov 2 (keyword "Section" ++ spc () ++ pr_lident id))
- | VernacEndSegment id ->
- return (hov 2 (keyword "End" ++ spc() ++ pr_lident id))
- | VernacNameSectionHypSet (id,set) ->
- return (hov 2 (keyword "Package" ++ spc() ++ pr_lident id ++ spc()++
- str ":="++spc()++pr_using set))
- | VernacRequire (from, exp, l) ->
- let from = match from with
- | None -> mt ()
- | Some r -> keyword "From" ++ spc () ++ pr_module r ++ spc ()
- in
- return (
- hov 2
- (from ++ keyword "Require" ++ spc() ++ pr_require_token exp ++
- prlist_with_sep sep pr_module l)
- )
- | VernacImport (f,l) ->
- return (
- (if f then keyword "Export" else keyword "Import") ++ spc() ++
- prlist_with_sep sep pr_import_module l
- )
- | VernacCanonical q ->
- return (
- keyword "Canonical Structure" ++ spc() ++ pr_smart_global q
- )
- | VernacCoercion (_,id,c1,c2) ->
- return (
- hov 1 (
- keyword "Coercion" ++ spc() ++
- pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++
- spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2)
- )
- | VernacIdentityCoercion (_,id,c1,c2) ->
- return (
- hov 1 (
- keyword "Identity Coercion" ++ spc() ++ pr_lident id ++
- spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++
- spc() ++ pr_class_rawexpr c2)
- )
-
- | VernacInstance (abst, sup, (instid, bk, cl), props, pri) ->
- return (
- hov 1 (
- (if abst then keyword "Declare" ++ spc () else mt ()) ++
- keyword "Instance" ++
- (match snd instid with Name id -> spc () ++ pr_lident (fst instid, id) ++ spc () |
- Anonymous -> mt ()) ++
- pr_and_type_binders_arg sup ++
- str":" ++ spc () ++
- pr_constr cl ++ pr_priority pri ++
- (match props with
- | Some (_,p) -> spc () ++ str":=" ++ spc () ++ pr_constr p
- | None -> mt()))
- )
-
- | VernacContext l ->
- return (
- hov 1 (
- keyword "Context" ++ spc () ++ pr_and_type_binders_arg l)
- )
-
- | VernacDeclareInstances (ids, pri) ->
- return (
- hov 1 (keyword "Existing" ++ spc () ++
- keyword(String.plural (List.length ids) "Instance") ++
- spc () ++ prlist_with_sep spc pr_reference ids ++ pr_priority pri)
- )
-
- | VernacDeclareClass id ->
- return (
- hov 1 (keyword "Existing" ++ spc () ++ keyword "Class" ++ spc () ++ pr_reference id)
- )
-
- (* Modules and Module Types *)
- | VernacDefineModule (export,m,bl,tys,bd) ->
- let b = pr_module_binders bl pr_lconstr in
- return (
- hov 2 (keyword "Module" ++ spc() ++ pr_require_token export ++
- pr_lident m ++ b ++
- pr_of_module_type pr_lconstr tys ++
- (if List.is_empty bd then mt () else str ":= ") ++
- prlist_with_sep (fun () -> str " <+ ")
- (pr_module_ast_inl true pr_lconstr) bd)
- )
- | VernacDeclareModule (export,id,bl,m1) ->
- let b = pr_module_binders bl pr_lconstr in
- return (
- hov 2 (keyword "Declare Module" ++ spc() ++ pr_require_token export ++
- pr_lident id ++ b ++
- pr_module_ast_inl true pr_lconstr m1)
- )
- | VernacDeclareModuleType (id,bl,tyl,m) ->
- let b = pr_module_binders bl pr_lconstr in
- let pr_mt = pr_module_ast_inl true pr_lconstr in
- return (
- hov 2 (keyword "Module Type " ++ pr_lident id ++ b ++
- prlist_strict (fun m -> str " <: " ++ pr_mt m) tyl ++
- (if List.is_empty m then mt () else str ":= ") ++
- prlist_with_sep (fun () -> str " <+ ") pr_mt m)
- )
- | VernacInclude (mexprs) ->
- let pr_m = pr_module_ast_inl false pr_lconstr in
- return (
- hov 2 (keyword "Include" ++ spc() ++
- prlist_with_sep (fun () -> str " <+ ") pr_m mexprs)
- )
- (* Solving *)
- | VernacSolve (i,info,tac,deftac) ->
- let pr_goal_selector = function
- | SelectNth i -> int i ++ str":"
- | SelectId id -> pr_id id ++ str":"
- | SelectAll -> str"all" ++ str":"
- | SelectAllParallel -> str"par"
+ | VernacSetOpacity(Conv_oracle.Opaque,l) ->
+ return (
+ hov 1 (keyword "Opaque" ++
+ spc() ++ prlist_with_sep sep pr_smart_global l)
+ )
+ | VernacSetOpacity _ ->
+ return (
+ CErrors.anomaly (keyword "VernacSetOpacity used to set something else")
+ )
+ | VernacSetStrategy l ->
+ let pr_lev = function
+ | Conv_oracle.Opaque -> keyword "opaque"
+ | Conv_oracle.Expand -> keyword "expand"
+ | l when Conv_oracle.is_transparent l -> keyword "transparent"
+ | Conv_oracle.Level n -> int n
in
- let pr_info =
- match info with
- | None -> mt ()
- | Some i -> str"Info"++spc()++int i++spc()
+ let pr_line (l,q) =
+ hov 2 (pr_lev l ++ spc() ++
+ str"[" ++ prlist_with_sep sep pr_smart_global q ++ str"]")
in
return (
- (if i = Proof_global.get_default_goal_selector () then mt() else pr_goal_selector i) ++
- pr_info ++
- pr_raw_tactic tac
- ++ (if deftac then str ".." else mt ())
+ hov 1 (keyword "Strategy" ++ spc() ++
+ hv 0 (prlist_with_sep sep pr_line l))
+ )
+ | VernacUnsetOption (na) ->
+ return (
+ hov 1 (keyword "Unset" ++ spc() ++ pr_printoption na None)
+ )
+ | VernacSetOption (na,v) ->
+ return (
+ hov 2 (keyword "Set" ++ spc() ++ pr_set_option na v)
+ )
+ | VernacSetAppendOption (na,v) ->
+ return (
+ hov 2 (keyword "Set" ++ spc() ++ pr_printoption na None ++
+ spc() ++ keyword "Append" ++ spc() ++ qs v)
+ )
+ | VernacAddOption (na,l) ->
+ return (
+ hov 2 (keyword "Add" ++ spc() ++ pr_printoption na (Some l))
+ )
+ | VernacRemoveOption (na,l) ->
+ return (
+ hov 2 (keyword "Remove" ++ spc() ++ pr_printoption na (Some l))
+ )
+ | VernacMemOption (na,l) ->
+ return (
+ hov 2 (keyword "Test" ++ spc() ++ pr_printoption na (Some l))
+ )
+ | VernacPrintOption na ->
+ return (
+ hov 2 (keyword "Test" ++ spc() ++ pr_printoption na None)
+ )
+ | VernacCheckMayEval (r,io,c) ->
+ let pr_mayeval r c = match r with
+ | Some r0 ->
+ hov 2 (keyword "Eval" ++ spc() ++
+ pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r0 ++
+ spc() ++ keyword "in" ++ spc () ++ pr_lconstr c)
+ | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c)
+ in
+ let pr_i = match io with None -> mt () | Some i -> int i ++ str ": " in
+ return (pr_i ++ pr_mayeval r c)
+ | VernacGlobalCheck c ->
+ return (hov 2 (keyword "Type" ++ pr_constrarg c))
+ | VernacDeclareReduction (s,r) ->
+ return (
+ keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++
+ pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r
+ )
+ | VernacPrint p ->
+ return (pr_printable p)
+ | VernacSearch (sea,g,sea_r) ->
+ return (pr_search sea g sea_r pr_constr_pattern_expr)
+ | VernacLocate loc ->
+ let pr_locate =function
+ | LocateAny qid -> pr_smart_global qid
+ | LocateTerm qid -> keyword "Term" ++ spc() ++ pr_smart_global qid
+ | LocateFile f -> keyword "File" ++ spc() ++ qs f
+ | LocateLibrary qid -> keyword "Library" ++ spc () ++ pr_module qid
+ | LocateModule qid -> keyword "Module" ++ spc () ++ pr_module qid
+ | LocateTactic qid -> keyword "Ltac" ++ spc () ++ pr_ltac_ref qid
+ in
+ return (keyword "Locate" ++ spc() ++ pr_locate loc)
+ | VernacRegister (id, RegisterInline) ->
+ return (
+ hov 2
+ (keyword "Register Inline" ++ spc() ++ pr_lident id)
+ )
+ | VernacComments l ->
+ return (
+ hov 2
+ (keyword "Comments" ++ spc()
+ ++ prlist_with_sep sep (pr_comment pr_constr) l)
+ )
+
+ (* Toplevel control *)
+ | VernacToplevelControl exn ->
+ return (pr_topcmd exn)
+
+ (* For extension *)
+ | VernacExtend (s,c) ->
+ return (pr_extend s c)
+ | VernacProof (None, None) ->
+ return (keyword "Proof")
+ | VernacProof (None, Some e) ->
+ return (keyword "Proof " ++ spc () ++
+ keyword "using" ++ spc() ++ pr_using e)
+ | VernacProof (Some te, None) ->
+ return (keyword "Proof with" ++ spc() ++ pr_raw_tactic te)
+ | VernacProof (Some te, Some e) ->
+ return (
+ keyword "Proof" ++ spc () ++
+ keyword "using" ++ spc() ++ pr_using e ++ spc() ++
+ keyword "with" ++ spc() ++pr_raw_tactic te
)
- | VernacSolveExistential (i,c) ->
- return (keyword "Existential" ++ spc () ++ int i ++ pr_lconstrarg c)
-
- (* Auxiliary file and library management *)
- | VernacAddLoadPath (fl,s,d) ->
- return (
- hov 2
- (keyword "Add" ++
- (if fl then spc () ++ keyword "Rec" ++ spc () else spc()) ++
- keyword "LoadPath" ++ spc() ++ qs s ++
- (match d with
- | None -> mt()
- | Some dir -> spc() ++ keyword "as" ++ spc() ++ pr_dirpath dir))
- )
- | VernacRemoveLoadPath s ->
- return (keyword "Remove LoadPath" ++ qs s)
- | VernacAddMLPath (fl,s) ->
- return (
- keyword "Add"
- ++ (if fl then spc () ++ keyword "Rec" ++ spc () else spc())
- ++ keyword "ML Path"
- ++ qs s
- )
- | VernacDeclareMLModule (l) ->
- return (
- hov 2 (keyword "Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l)
- )
- | VernacChdir s ->
- return (keyword "Cd" ++ pr_opt qs s)
-
- (* Commands *)
- | VernacDeclareTacticDefinition (rc,l) ->
- let pr_tac_body (id, redef, body) =
- let idl, body =
- match body with
- | Tacexpr.TacFun (idl,b) -> idl,b
- | _ -> [], body in
- pr_ltac_ref id ++
- prlist (function None -> str " _"
- | Some id -> spc () ++ pr_id id) idl
- ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++
- pr_raw_tactic body
- in
- return (
- hov 1
- (keyword "Ltac" ++ spc () ++
- prlist_with_sep (fun () ->
- fnl() ++ keyword "with" ++ spc ()) pr_tac_body l)
- )
- | VernacCreateHintDb (dbname,b) ->
- return (
- hov 1 (keyword "Create HintDb" ++ spc () ++
- str dbname ++ (if b then str" discriminated" else mt ()))
- )
- | VernacRemoveHints (dbnames, ids) ->
- return (
- hov 1 (keyword "Remove Hints" ++ spc () ++
- prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++
- pr_opt_hintbases dbnames)
- )
- | VernacHints (_, dbnames,h) ->
- return (pr_hints dbnames h pr_constr pr_constr_pattern_expr)
- | VernacSyntacticDefinition (id,(ids,c),_,onlyparsing) ->
- return (
- hov 2
- (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++
- prlist (fun x -> spc() ++ pr_id x) ids ++ str":=" ++ pr_constrarg c ++
- pr_syntax_modifiers
- (match onlyparsing with None -> [] | Some v -> [SetOnlyParsing v]))
- )
- | VernacDeclareImplicits (q,[]) ->
- return (
- hov 2 (keyword "Implicit Arguments" ++ spc() ++ pr_smart_global q)
- )
- | VernacDeclareImplicits (q,impls) ->
- return (
- hov 1 (keyword "Implicit Arguments" ++ spc () ++
- spc() ++ pr_smart_global q ++ spc() ++
- prlist_with_sep spc (fun imps ->
- str"[" ++ prlist_with_sep sep pr_explanation imps ++ str"]")
- impls)
- )
- | VernacArguments (q, impl, nargs, mods) ->
- return (
- hov 2 (
- keyword "Arguments" ++ spc() ++
- pr_smart_global q ++
- let pr_s = function None -> str"" | Some (_,s) -> str "%" ++ str s in
- let pr_if b x = if b then x else str "" in
- let pr_br imp max x = match imp, max with
- | true, false -> str "[" ++ x ++ str "]"
- | true, true -> str "{" ++ x ++ str "}"
- | _ -> x in
- let rec aux n l =
- match n, l with
- | 0, l -> spc () ++ str"/" ++ aux ~-1 l
- | _, [] -> mt()
- | n, (id,k,s,imp,max) :: tl ->
- spc() ++ pr_br imp max (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++
- aux (n-1) tl in
- prlist_with_sep (fun () -> str", ") (aux nargs) impl ++
- if not (List.is_empty mods) then str" : " else str"" ++
- prlist_with_sep (fun () -> str", " ++ spc()) (function
- | `ReductionDontExposeCase -> keyword "simpl nomatch"
- | `ReductionNeverUnfold -> keyword "simpl never"
- | `DefaultImplicits -> keyword "default implicits"
- | `Rename -> keyword "rename"
- | `Assert -> keyword "assert"
- | `ExtraScopes -> keyword "extra scopes"
- | `ClearImplicits -> keyword "clear implicits"
- | `ClearScopes -> keyword "clear scopes")
- mods)
- )
- | VernacReserve bl ->
- let n = List.length (List.flatten (List.map fst bl)) in
- return (
- hov 2 (tag_keyword (str"Implicit Type" ++ str (if n > 1 then "s " else " "))
- ++ pr_ne_params_list pr_lconstr_expr (List.map (fun sb -> false,sb) bl))
- )
- | VernacGeneralizable g ->
- return (
- hov 1 (tag_keyword (
- str"Generalizable Variable" ++
- match g with
- | None -> str "s none"
- | Some [] -> str "s all"
- | Some idl ->
- str (if List.length idl > 1 then "s " else " ") ++
- prlist_with_sep spc pr_lident idl)
- ))
- | VernacSetOpacity(k,l) when Conv_oracle.is_transparent k ->
- return (
- hov 1 (keyword "Transparent" ++
- spc() ++ prlist_with_sep sep pr_smart_global l)
- )
- | VernacSetOpacity(Conv_oracle.Opaque,l) ->
- return (
- hov 1 (keyword "Opaque" ++
- spc() ++ prlist_with_sep sep pr_smart_global l)
- )
- | VernacSetOpacity _ ->
- return (
- Errors.anomaly (keyword "VernacSetOpacity used to set something else")
- )
- | VernacSetStrategy l ->
- let pr_lev = function
- | Conv_oracle.Opaque -> keyword "opaque"
- | Conv_oracle.Expand -> keyword "expand"
- | l when Conv_oracle.is_transparent l -> keyword "transparent"
- | Conv_oracle.Level n -> int n
- in
- let pr_line (l,q) =
- hov 2 (pr_lev l ++ spc() ++
- str"[" ++ prlist_with_sep sep pr_smart_global q ++ str"]")
- in
- return (
- hov 1 (keyword "Strategy" ++ spc() ++
- hv 0 (prlist_with_sep sep pr_line l))
- )
- | VernacUnsetOption (na) ->
- return (
- hov 1 (keyword "Unset" ++ spc() ++ pr_printoption na None)
- )
- | VernacSetOption (na,v) ->
- return (
- hov 2 (keyword "Set" ++ spc() ++ pr_set_option na v)
- )
- | VernacAddOption (na,l) ->
- return (
- hov 2 (keyword "Add" ++ spc() ++ pr_printoption na (Some l))
- )
- | VernacRemoveOption (na,l) ->
- return (
- hov 2 (keyword "Remove" ++ spc() ++ pr_printoption na (Some l))
- )
- | VernacMemOption (na,l) ->
- return (
- hov 2 (keyword "Test" ++ spc() ++ pr_printoption na (Some l))
- )
- | VernacPrintOption na ->
- return (
- hov 2 (keyword "Test" ++ spc() ++ pr_printoption na None)
- )
- | VernacCheckMayEval (r,io,c) ->
- let pr_mayeval r c = match r with
- | Some r0 ->
- hov 2 (keyword "Eval" ++ spc() ++
- pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r0 ++
- spc() ++ keyword "in" ++ spc () ++ pr_lconstr c)
- | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c)
- in
- let pr_i = match io with None -> mt () | Some i -> int i ++ str ": " in
- return (pr_i ++ pr_mayeval r c)
- | VernacGlobalCheck c ->
- return (hov 2 (keyword "Type" ++ pr_constrarg c))
- | VernacDeclareReduction (s,r) ->
- return (
- keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++
- pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r
- )
- | VernacPrint p ->
- return (pr_printable p)
- | VernacSearch (sea,g,sea_r) ->
- return (pr_search sea g sea_r pr_constr_pattern_expr)
- | VernacLocate loc ->
- let pr_locate =function
- | LocateAny qid -> pr_smart_global qid
- | LocateTerm qid -> keyword "Term" ++ spc() ++ pr_smart_global qid
- | LocateFile f -> keyword "File" ++ spc() ++ qs f
- | LocateLibrary qid -> keyword "Library" ++ spc () ++ pr_module qid
- | LocateModule qid -> keyword "Module" ++ spc () ++ pr_module qid
- | LocateTactic qid -> keyword "Ltac" ++ spc () ++ pr_ltac_ref qid
- in
- return (keyword "Locate" ++ spc() ++ pr_locate loc)
- | VernacRegister (id, RegisterInline) ->
- return (
- hov 2
- (keyword "Register Inline" ++ spc() ++ pr_lident id)
- )
- | VernacComments l ->
- return (
- hov 2
- (keyword "Comments" ++ spc()
- ++ prlist_with_sep sep (pr_comment pr_constr) l)
- )
- | VernacNop ->
- mt()
-
- (* Toplevel control *)
- | VernacToplevelControl exn ->
- return (pr_topcmd exn)
-
- (* For extension *)
- | VernacExtend (s,c) ->
- return (pr_extend s c)
- | VernacProof (None, None) ->
- return (keyword "Proof")
- | VernacProof (None, Some e) ->
- return (keyword "Proof " ++ spc () ++
- keyword "using" ++ spc() ++ pr_using e)
- | VernacProof (Some te, None) ->
- return (keyword "Proof with" ++ spc() ++ pr_raw_tactic te)
- | VernacProof (Some te, Some e) ->
- return (
- keyword "Proof" ++ spc () ++
- keyword "using" ++ spc() ++ pr_using e ++ spc() ++
- keyword "with" ++ spc() ++pr_raw_tactic te
- )
- | VernacProofMode s ->
- return (keyword "Proof Mode" ++ str s)
- | VernacBullet b ->
- return (begin match b with
- | Dash n -> str (String.make n '-')
- | Star n -> str (String.make n '*')
- | Plus n -> str (String.make n '+')
- end ++ spc())
- | VernacSubproof None ->
- return (str "{")
- | VernacSubproof (Some i) ->
- return (keyword "BeginSubproof" ++ spc () ++ int i)
- | VernacEndSubproof ->
- return (str "}")
-
- and pr_vernac_list l =
- hov 2 (str"[" ++ spc() ++
- prlist (fun v -> pr_located pr_vernac v ++ sep_end (snd v) ++ fnl()) l
- ++ spc() ++ str"]")
-
- and pr_extend s cl =
- let pr_arg a =
- try pr_gen a
- with Failure _ -> str "" in
- try
- let rl = Egramml.get_extend_vernac_rule s in
- let start,rl,cl =
- match rl with
- | Egramml.GramTerminal s :: rl -> str s, rl, cl
- | Egramml.GramNonTerminal _ :: rl -> pr_arg (List.hd cl), rl, List.tl cl
- | [] -> anomaly (Pp.str "Empty entry") in
- let (pp,_) =
- List.fold_left
- (fun (strm,args) pi ->
- let pp,args = match pi with
- | Egramml.GramNonTerminal _ -> (pr_arg (List.hd args), List.tl args)
- | Egramml.GramTerminal s -> (str s, args) in
- (strm ++ spc() ++ pp), args)
- (start,cl) rl in
- hov 1 pp
- with Not_found ->
- hov 1 (str "TODO(" ++ str (fst s) ++ prlist_with_sep sep pr_arg cl ++ str ")")
-
- in pr_vernac
-
- let pr_vernac_body v = make_pr_vernac pr_constr_expr pr_lconstr_expr v
-
- let pr_vernac v = make_pr_vernac pr_constr_expr pr_lconstr_expr v ++ sep_end v
-
- let pr_vernac x =
- try pr_vernac x
- with e -> Errors.print e
+ | VernacProofMode s ->
+ return (keyword "Proof Mode" ++ str s)
+ | VernacBullet b ->
+ return (begin match b with
+ | Dash n -> str (String.make n '-')
+ | Star n -> str (String.make n '*')
+ | Plus n -> str (String.make n '+')
+ end)
+ | VernacSubproof None ->
+ return (str "{")
+ | VernacSubproof (Some i) ->
+ return (keyword "BeginSubproof" ++ spc () ++ int i)
+ | VernacEndSubproof ->
+ return (str "}")
+
+ and pr_extend s cl =
+ let pr_arg a =
+ try pr_gen a
+ with Failure _ -> str "" in
+ try
+ let rl = Egramml.get_extend_vernac_rule s in
+ let rec aux rl cl =
+ match rl, cl with
+ | Egramml.GramNonTerminal _ :: rl, arg :: cl -> pr_arg arg :: aux rl cl
+ | Egramml.GramTerminal s :: rl, cl -> str s :: aux rl cl
+ | [], [] -> []
+ | _ -> assert false in
+ hov 1 (pr_sequence (fun x -> x) (aux rl cl))
+ with Not_found ->
+ hov 1 (str "TODO(" ++ str (fst s) ++ spc () ++ prlist_with_sep sep pr_arg cl ++ str ")")
+
+ let pr_vernac v =
+ try pr_vernac_body v ++ sep_end v
+ with e -> CErrors.print e
end
diff --git a/printing/ppvernacsig.mli b/printing/ppvernacsig.mli
index 5d1c8933..5e5e4bcf 100644
--- a/printing/ppvernacsig.mli
+++ b/printing/ppvernacsig.mli
@@ -8,6 +8,9 @@
module type Pp = sig
+ (** Prints a fixpoint body *)
+ val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.std_ppcmds
+
(** Prints a vernac expression *)
val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds
diff --git a/printing/prettyp.ml b/printing/prettyp.ml
index fd51fd6b..e117f1dc 100644
--- a/printing/prettyp.ml
+++ b/printing/prettyp.ml
@@ -11,7 +11,7 @@
*)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Nameops
@@ -35,7 +35,7 @@ type object_pr = {
print_syntactic_def : kernel_name -> std_ppcmds;
print_module : bool -> Names.module_path -> std_ppcmds;
print_modtype : module_path -> std_ppcmds;
- print_named_decl : Id.t * constr option * types -> std_ppcmds;
+ print_named_decl : Context.Named.Declaration.t -> std_ppcmds;
print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option;
print_context : bool -> int option -> Lib.library_segment -> std_ppcmds;
print_typed_value_in_env : Environ.env -> Evd.evar_map -> Term.constr * Term.types -> Pp.std_ppcmds;
@@ -132,7 +132,8 @@ let print_renames_list prefix l =
let need_expansion impl ref =
let typ = Global.type_of_global_unsafe ref in
let ctx = prod_assum typ in
- let nprods = List.length (List.filter (fun (_,b,_) -> Option.is_empty b) ctx) in
+ let open Context.Rel.Declaration in
+ let nprods = List.count is_local_assum ctx in
not (List.is_empty impl) && List.length impl >= nprods &&
let _,lastimpl = List.chop nprods impl in
List.exists is_status_implicit lastimpl
@@ -168,8 +169,10 @@ type opacity =
| FullyOpaque
| TransparentMaybeOpacified of Conv_oracle.level
-let opacity env = function
- | VarRef v when not (Option.is_empty (pi2 (Environ.lookup_named v env))) ->
+let opacity env =
+ let open Context.Named.Declaration in
+ function
+ | VarRef v when is_local_def (Environ.lookup_named v env) ->
Some(TransparentMaybeOpacified
(Conv_oracle.get_strategy (Environ.oracle env) (VarKey v)))
| ConstRef cst ->
@@ -212,15 +215,21 @@ let print_polymorphism ref =
else "not universe polymorphic") ]
else []
+let print_type_in_type ref =
+ let unsafe = Global.is_type_in_type ref in
+ if unsafe then
+ [ pr_global ref ++ str " relies on an unsafe universe hierarchy"]
+ else []
+
let print_primitive_record recflag mipv = function
| Some (Some (_, ps,_)) ->
let eta = match recflag with
- | Decl_kinds.CoFinite -> mt ()
- | Decl_kinds.Finite | Decl_kinds.BiFinite -> str " and has eta conversion"
+ | Decl_kinds.CoFinite | Decl_kinds.Finite -> str" without eta conversion"
+ | Decl_kinds.BiFinite -> str " with eta conversion"
in
- [pr_id mipv.(0).mind_typename ++ str" is primitive" ++ eta ++ str"."]
+ [pr_id mipv.(0).mind_typename ++ str" has primitive projections" ++ eta ++ str"."]
| _ -> []
-
+
let print_primitive ref =
match ref with
| IndRef ind ->
@@ -232,7 +241,7 @@ let print_name_infos ref =
let impls = implicits_of_global ref in
let scopes = Notation.find_arguments_scope ref in
let renames =
- try List.hd (Arguments_renaming.arguments_names ref) with Not_found -> [] in
+ try Arguments_renaming.arguments_names ref with Not_found -> [] in
let type_info_for_implicit =
if need_expansion (select_impargs_size 0 impls) ref then
(* Need to reduce since implicits are computed with products flattened *)
@@ -241,6 +250,7 @@ let print_name_infos ref =
else
[] in
print_polymorphism ref @
+ print_type_in_type ref @
print_primitive ref @
type_info_for_implicit @
print_renames_list (mt()) renames @
@@ -271,7 +281,7 @@ let print_inductive_implicit_args =
let print_inductive_renames =
print_args_data_of_inductive_ids
(fun r ->
- try List.hd (Arguments_renaming.arguments_names r) with Not_found -> [])
+ try Arguments_renaming.arguments_names r with Not_found -> [])
((!=) Anonymous)
print_renames_list
@@ -440,11 +450,13 @@ let print_named_def name body typ =
let print_named_assum name typ =
str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]"
-let gallina_print_named_decl (id,c,typ) =
- let s = Id.to_string id in
- match c with
- | Some body -> print_named_def s body typ
- | None -> print_named_assum s typ
+let gallina_print_named_decl =
+ let open Context.Named.Declaration in
+ function
+ | LocalAssum (id, typ) ->
+ print_named_assum (Id.to_string id) typ
+ | LocalDef (id, body, typ) ->
+ print_named_def (Id.to_string id) body typ
let assumptions_for_print lna =
List.fold_right (fun na env -> add_name na env) lna empty_names_context
@@ -721,8 +733,8 @@ let print_any_name = function
try (* Var locale de but, pas var de section... donc pas d'implicits *)
let dir,str = repr_qualid qid in
if not (DirPath.is_empty dir) then raise Not_found;
- let (_,c,typ) = Global.lookup_named str in
- (print_named_decl (str,c,typ))
+ let open Context.Named.Declaration in
+ str |> Global.lookup_named |> set_id str |> print_named_decl
with Not_found ->
errorlabstrm
"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.")
@@ -750,8 +762,8 @@ let print_opaque_name qid =
let ty = Universes.unsafe_type_of_global gr in
print_typed_value (mkConstruct cstr, ty)
| VarRef id ->
- let (_,c,ty) = lookup_named id env in
- print_named_decl (id,c,ty)
+ let open Context.Named.Declaration in
+ lookup_named id env |> set_id id |> print_named_decl
let print_about_any loc k =
match k with
@@ -860,7 +872,7 @@ let pr_instance env i =
(* gallina_print_constant_with_infos i.is_impl *)
(* lighter *)
print_ref false (instance_impl i) ++
- begin match instance_priority i with
+ begin match hint_priority i with
| None -> mt ()
| Some i -> spc () ++ str "|" ++ spc () ++ int i
end
diff --git a/printing/prettyp.mli b/printing/prettyp.mli
index 6f3556ad..0eab1557 100644
--- a/printing/prettyp.mli
+++ b/printing/prettyp.mli
@@ -66,7 +66,7 @@ type object_pr = {
print_syntactic_def : kernel_name -> std_ppcmds;
print_module : bool -> Names.module_path -> std_ppcmds;
print_modtype : module_path -> std_ppcmds;
- print_named_decl : Id.t * constr option * types -> std_ppcmds;
+ print_named_decl : Context.Named.Declaration.t -> std_ppcmds;
print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option;
print_context : bool -> int option -> Lib.library_segment -> std_ppcmds;
print_typed_value_in_env : Environ.env -> Evd.evar_map -> Term.constr * Term.types -> Pp.std_ppcmds;
diff --git a/printing/printer.ml b/printing/printer.ml
index 5ad0e453..04337f6b 100644
--- a/printing/printer.ml
+++ b/printing/printer.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -28,9 +28,7 @@ let delayed_emacs_cmd s =
if !Flags.print_emacs then s () else str ""
let get_current_context () =
- try Pfedit.get_current_goal_context ()
- with e when Logic.catchable_exception e ->
- (Evd.empty, Global.env())
+ Pfedit.get_current_context ()
(**********************************************************************)
(** Terms *)
@@ -50,7 +48,7 @@ let pr_lconstr_core goal_concl_style env sigma t =
let pr_lconstr_env env = pr_lconstr_core false env
let pr_constr_env env = pr_constr_core false env
-let _ = Hook.set Proofview.Refine.pr_constr pr_constr_env
+let _ = Hook.set Refine.pr_constr pr_constr_env
let pr_lconstr_goal_style_env env = pr_lconstr_core true env
let pr_constr_goal_style_env env = pr_constr_core true env
@@ -186,7 +184,7 @@ let safe_gen f env sigma c =
let orig_extern_ref = Constrextern.get_extern_reference () in
let extern_ref loc vars r =
try orig_extern_ref loc vars r
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
Libnames.Qualid (loc, qualid_of_global env r)
in
Constrextern.set_extern_reference extern_ref;
@@ -194,7 +192,7 @@ let safe_gen f env sigma c =
let p = f env sigma c in
Constrextern.set_extern_reference orig_extern_ref;
p
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
Constrextern.set_extern_reference orig_extern_ref;
str "??"
@@ -262,16 +260,19 @@ let pr_var_decl_skel pr_id env sigma (id,c,typ) =
let ptyp = (str" : " ++ pt) in
(pr_id id ++ hov 0 (pbody ++ ptyp))
-let pr_var_decl env sigma (id,c,typ) =
- pr_var_decl_skel pr_id env sigma (id,c,typ)
+let pr_var_decl env sigma d =
+ pr_var_decl_skel pr_id env sigma (Context.Named.Declaration.to_tuple d)
let pr_var_list_decl env sigma (l,c,typ) =
hov 0 (pr_var_decl_skel (fun ids -> prlist_with_sep pr_comma pr_id ids) env sigma (l,c,typ))
-let pr_rel_decl env sigma (na,c,typ) =
- let pbody = match c with
- | None -> mt ()
- | Some c ->
+let pr_rel_decl env sigma decl =
+ let open Context.Rel.Declaration in
+ let na = get_name decl in
+ let typ = get_type decl in
+ let pbody = match decl with
+ | LocalAssum _ -> mt ()
+ | LocalDef (_,c,_) ->
(* Force evaluation *)
let pb = pr_lconstr_env env sigma c in
let pb = if isCast c then surround pb else pb in
@@ -293,7 +294,7 @@ let pr_named_context_of env sigma =
hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl)
let pr_named_context env sigma ne_context =
- hv 0 (Context.fold_named_context
+ hv 0 (Context.Named.fold_outside
(fun d pps -> pps ++ ws 2 ++ pr_var_decl env sigma d)
ne_context ~init:(mt ()))
@@ -306,7 +307,7 @@ let pr_rel_context_of env sigma =
(* Prints an env (variables and de Bruijn). Separator: newline *)
let pr_context_unlimited env sigma =
let sign_env =
- Context.fold_named_list_context
+ Context.NamedList.fold
(fun d pps ->
let pidt = pr_var_list_decl env sigma d in
(pps ++ fnl () ++ pidt))
@@ -333,7 +334,7 @@ let pr_context_limit n env sigma =
else
let k = lgsign-n in
let _,sign_env =
- Context.fold_named_list_context
+ Context.NamedList.fold
(fun d (i,pps) ->
if i < k then
(i+1, (pps ++str "."))
@@ -380,16 +381,12 @@ let pr_transparent_state (ids, csts) =
let default_pr_goal gs =
let (g,sigma) = Goal.V82.nf_evar (project gs) (sig_it gs) in
let env = Goal.V82.env sigma g in
- let preamb,thesis,penv,pc =
- mt (), mt (),
- pr_context_of env sigma,
- pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g)
- in
- preamb ++
- str" " ++ hv 0 (penv ++ fnl () ++
- str (emacs_str "") ++
- str "============================" ++ fnl () ++
- thesis ++ str " " ++ pc)
+ let concl = Goal.V82.concl sigma g in
+ let goal =
+ pr_context_of env sigma ++ cut () ++
+ str "============================" ++ cut () ++
+ pr_goal_concl_style_env env sigma concl in
+ str " " ++ v 0 goal
(* display a goal tag *)
let pr_goal_tag g =
@@ -400,7 +397,7 @@ let display_name = false
(* display a goal name *)
let pr_goal_name sigma g =
- if display_name then str " " ++ Pp.surround (pr_id (Evd.evar_ident g sigma))
+ if display_name then str " " ++ Pp.surround (pr_existential_key sigma g)
else mt ()
(* display the conclusion of a goal *)
@@ -420,13 +417,23 @@ let pr_evgl_sign sigma evi =
| None -> [], []
| Some f -> List.filter2 (fun b c -> not b) f (evar_context evi)
in
- let ids = List.rev_map pi1 l in
+ let open Context.Named.Declaration in
+ let ids = List.rev_map get_id l in
let warn =
if List.is_empty ids then mt () else
(str "(" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)")
in
let pc = pr_lconstr_env env sigma evi.evar_concl in
- hov 0 (str"[" ++ ps ++ spc () ++ str"|- " ++ pc ++ str"]" ++ spc () ++ warn)
+ let candidates =
+ match evi.evar_body, evi.evar_candidates with
+ | Evar_empty, Some l ->
+ spc () ++ str "= {" ++
+ prlist_with_sep (fun () -> str "|") (pr_lconstr_env env sigma) l ++ str "}"
+ | _ ->
+ mt ()
+ in
+ hov 0 (str"[" ++ ps ++ spc () ++ str"|- " ++ pc ++ str"]" ++
+ candidates ++ spc () ++ warn)
(* Print an existential variable *)
@@ -473,25 +480,91 @@ let default_pr_subgoal n sigma =
let pr_internal_existential_key ev = str (string_of_existential ev)
-let emacs_print_dependent_evars sigma seeds =
+let print_evar_constraints gl sigma =
+ let pr_env =
+ match gl with
+ | None -> fun e' -> pr_context_of e' sigma
+ | Some g ->
+ let env = Goal.V82.env sigma g in fun e' ->
+ begin
+ if Context.Named.equal (named_context env) (named_context e') then
+ if Context.Rel.equal (rel_context env) (rel_context e') then mt ()
+ else pr_rel_context_of e' sigma ++ str " |-" ++ spc ()
+ else pr_context_of e' sigma ++ str " |-" ++ spc ()
+ end
+ in
+ let pr_evconstr (pbty,env,t1,t2) =
+ let t1 = Evarutil.nf_evar sigma t1
+ and t2 = Evarutil.nf_evar sigma t2 in
+ let env =
+ (** We currently allow evar instances to refer to anonymous de Bruijn
+ indices, so we protect the error printing code in this case by giving
+ names to every de Bruijn variable in the rel_context of the conversion
+ problem. MS: we should rather stop depending on anonymous variables, they
+ can be used to indicate independency. Also, this depends on a strategy for
+ naming/renaming *)
+ Namegen.make_all_name_different env in
+ str" " ++
+ hov 2 (pr_env env ++ pr_lconstr_env env sigma t1 ++ spc () ++
+ str (match pbty with
+ | Reduction.CONV -> "=="
+ | Reduction.CUMUL -> "<=") ++
+ spc () ++ pr_lconstr_env env sigma t2)
+ in
+ let pr_candidate ev evi (candidates,acc) =
+ if Option.has_some evi.evar_candidates then
+ (succ candidates, acc ++ pr_evar sigma (ev,evi) ++ fnl ())
+ else (candidates, acc)
+ in
+ let constraints =
+ let _, cstrs = Evd.extract_all_conv_pbs sigma in
+ if List.is_empty cstrs then mt ()
+ else fnl () ++ str (String.plural (List.length cstrs) "unification constraint")
+ ++ str":" ++ fnl () ++ hov 0 (prlist_with_sep fnl pr_evconstr cstrs)
+ in
+ let candidates, ppcandidates = Evd.fold_undefined pr_candidate sigma (0,mt ()) in
+ constraints ++
+ if candidates > 0 then
+ fnl () ++ str (String.plural candidates "existential") ++
+ str" with candidates:" ++ fnl () ++ hov 0 ppcandidates
+ else mt ()
+
+let should_print_dependent_evars = ref false
+
+let _ =
+ let open Goptions in
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ optname = "Printing Dependent Evars Line";
+ optkey = ["Printing";"Dependent";"Evars";"Line"];
+ optread = (fun () -> !should_print_dependent_evars);
+ optwrite = (fun v -> should_print_dependent_evars := v) }
+
+let print_dependent_evars gl sigma seeds =
+ let constraints = print_evar_constraints gl sigma in
let evars () =
- let evars = Evarutil.gather_dependent_evars sigma seeds in
- let evars =
- Evar.Map.fold begin fun e i s ->
- let e' = pr_internal_existential_key e in
- match i with
- | None -> s ++ str" " ++ e' ++ str " open,"
- | Some i ->
- s ++ str " " ++ e' ++ str " using " ++
- Evar.Set.fold begin fun d s ->
- pr_internal_existential_key d ++ str " " ++ s
- end i (str ",")
- end evars (str "")
+ if !should_print_dependent_evars then
+ let evars = Evarutil.gather_dependent_evars sigma seeds in
+ let evars =
+ Evar.Map.fold begin fun e i s ->
+ let e' = pr_internal_existential_key e in
+ match i with
+ | None -> s ++ str" " ++ e' ++ str " open,"
+ | Some i ->
+ s ++ str " " ++ e' ++ str " using " ++
+ Evar.Set.fold begin fun d s ->
+ pr_internal_existential_key d ++ str " " ++ s
+ end i (str ",")
+ end evars (str "")
in
fnl () ++
str "(dependent evars:" ++ evars ++ str ")" ++ fnl ()
+ else
+ fnl () ++
+ str "(dependent evars: (printing disabled) )" ++ fnl ()
in
- delayed_emacs_cmd evars
+ constraints ++ delayed_emacs_cmd evars
(* Print open subgoals. Checks for uninstantiated existential variables *)
(* spiwack: [seeds] is for printing dependent evars in emacs mode. *)
@@ -550,7 +623,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals
(* Side effect! This has to be made more robust *)
let () =
match close_cmd with
- | Some cmd -> msg_info cmd
+ | Some cmd -> Feedback.msg_info cmd
| None -> ()
in
match goals with
@@ -559,12 +632,12 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals
let exl = Evarutil.non_instantiated sigma in
if Evar.Map.is_empty exl then
(str"No more subgoals."
- ++ emacs_print_dependent_evars sigma seeds)
+ ++ print_dependent_evars None sigma seeds)
else
let pei = pr_evars_int sigma 1 exl in
(str "No more subgoals, but there are non-instantiated existential variables:"
++ fnl () ++ (hov 0 pei)
- ++ emacs_print_dependent_evars sigma seeds ++ fnl () ++
+ ++ print_dependent_evars None sigma seeds ++ fnl () ++
str "You can use Grab Existential Variables.")
end
| [g] when not !Flags.print_emacs && pr_first ->
@@ -572,7 +645,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals
v 0 (
str "1" ++ focused_if_needed ++ str"subgoal" ++ print_extra
++ pr_goal_tag g ++ pr_goal_name sigma g ++ cut () ++ pg
- ++ emacs_print_dependent_evars sigma seeds
+ ++ print_dependent_evars (Some g) sigma seeds
)
| g1::rest ->
let goals = print_multiple_goals g1 rest in
@@ -584,7 +657,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals
++ pr_goal_tag g1
++ pr_goal_name sigma g1 ++ cut ()
++ goals
- ++ emacs_print_dependent_evars sigma seeds
+ ++ print_dependent_evars (Some g1) sigma seeds
)
(**********************************************************************)
@@ -628,19 +701,19 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () =
begin match bgoals,shelf,given_up with
| [] , [] , [] -> pr_subgoals None sigma seeds shelf stack goals
| [] , [] , _ ->
- msg_info (str "No more subgoals, but there are some goals you gave up:");
+ Feedback.msg_info (str "No more subgoals, but there are some goals you gave up:");
fnl ()
++ pr_subgoals ~pr_first:false None bsigma seeds [] [] given_up
++ fnl () ++ str "You need to go back and solve them."
| [] , _ , _ ->
- msg_info (str "All the remaining goals are on the shelf.");
+ Feedback.msg_info (str "All the remaining goals are on the shelf.");
fnl ()
++ pr_subgoals ~pr_first:false None bsigma seeds [] [] shelf
| _ , _, _ ->
let end_cmd =
str "This subproof is complete, but there are some unfocused goals." ++
- (match Proof_global.Bullet.suggest p
- with None -> str"" | Some s -> fnl () ++ str s) ++
+ (let s = Proof_global.Bullet.suggest p in
+ if Pp.is_empty s then s else fnl () ++ s) ++
fnl ()
in
pr_subgoals ~pr_first:false (Some end_cmd) bsigma seeds shelf [] bgoals
@@ -684,38 +757,10 @@ let pr_prim_rule = function
(str"cut " ++ pr_constr t ++
str ";[" ++ cl ++ str"intro " ++ pr_id id ++ str"|idtac]")
- | FixRule (f,n,[],_) ->
- (str"fix " ++ pr_id f ++ str"/" ++ int n)
-
- | FixRule (f,n,others,j) ->
- if not (Int.equal j 0) then msg_warning (strbrk "Unsupported printing of \"fix\"");
- let rec print_mut = function
- | (f,n,ar)::oth ->
- pr_id f ++ str"/" ++ int n ++ str" : " ++ pr_lconstr ar ++ print_mut oth
- | [] -> mt () in
- (str"fix " ++ pr_id f ++ str"/" ++ int n ++
- str" with " ++ print_mut others)
-
- | Cofix (f,[],_) ->
- (str"cofix " ++ pr_id f)
-
- | Cofix (f,others,j) ->
- if not (Int.equal j 0) then msg_warning (strbrk "Unsupported printing of \"fix\"");
- let rec print_mut = function
- | (f,ar)::oth ->
- (pr_id f ++ str" : " ++ pr_lconstr ar ++ print_mut oth)
- | [] -> mt () in
- (str"cofix " ++ pr_id f ++ str" with " ++ print_mut others)
| Refine c ->
str(if Termops.occur_meta c then "refine " else "exact ") ++
Constrextern.with_meta_as_hole pr_constr c
- | Thin ids ->
- (str"clear " ++ pr_sequence pr_id ids)
-
- | Move (id1,id2) ->
- (str"move " ++ pr_id id1 ++ Miscprint.pr_move_location pr_id id2)
-
(* Backwards compatibility *)
let prterm = pr_lconstr
@@ -724,9 +769,14 @@ let prterm = pr_lconstr
(* Printer function for sets of Assumptions.assumptions.
It is used primarily by the Print Assumptions command. *)
+type axiom =
+ | Constant of constant (* An axiom or a constant. *)
+ | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *)
+ | Guarded of constant (* a constant whose (co)fixpoints have been assumed to be guarded *)
+
type context_object =
| Variable of Id.t (* A section variable or a Let definition *)
- | Axiom of constant * (Label.t * Context.rel_context * types) list
+ | Axiom of axiom * (Label.t * Context.Rel.t * types) list
| Opaque of constant (* An opaque constant. *)
| Transparent of constant
@@ -734,19 +784,31 @@ type context_object =
module OrderedContextObject =
struct
type t = context_object
+
+ let compare_axiom x y =
+ match x,y with
+ | Constant k1 , Constant k2 ->
+ con_ord k1 k2
+ | Positive m1 , Positive m2 ->
+ MutInd.CanOrd.compare m1 m2
+ | Guarded k1 , Guarded k2 ->
+ con_ord k1 k2
+ | _ , Constant _ -> 1
+ | _ , Positive _ -> 1
+ | _ -> -1
+
let compare x y =
- match x , y with
- | Variable i1 , Variable i2 -> Id.compare i1 i2
- | Axiom (k1,_) , Axiom (k2, _) -> con_ord k1 k2
- | Opaque k1 , Opaque k2 -> con_ord k1 k2
- | Transparent k1 , Transparent k2 -> con_ord k1 k2
- | Axiom _ , Variable _ -> 1
- | Opaque _ , Variable _
- | Opaque _ , Axiom _ -> 1
- | Transparent _ , Variable _
- | Transparent _ , Axiom _
- | Transparent _ , Opaque _ -> 1
- | _ , _ -> -1
+ match x , y with
+ | Variable i1 , Variable i2 -> Id.compare i1 i2
+ | Variable _ , _ -> -1
+ | _ , Variable _ -> 1
+ | Axiom (k1,_) , Axiom (k2, _) -> compare_axiom k1 k2
+ | Axiom _ , _ -> -1
+ | _ , Axiom _ -> 1
+ | Opaque k1 , Opaque k2 -> con_ord k1 k2
+ | Opaque _ , _ -> -1
+ | _ , Opaque _ -> 1
+ | Transparent k1 , Transparent k2 -> con_ord k1 k2
end
module ContextObjectSet = Set.Make (OrderedContextObject)
@@ -754,7 +816,7 @@ module ContextObjectMap = Map.Make (OrderedContextObject)
let pr_assumptionset env s =
if ContextObjectMap.is_empty s &&
- engagement env = (PredicativeSet, StratifiedType) then
+ engagement env = PredicativeSet then
str "Closed under the global context"
else
let safe_pr_constant env kn =
@@ -765,28 +827,37 @@ let pr_assumptionset env s =
in
let safe_pr_ltype typ =
try str " : " ++ pr_ltype typ
- with e when Errors.noncritical e -> mt ()
+ with e when CErrors.noncritical e -> mt ()
in
let safe_pr_ltype_relctx (rctx, typ) =
let sigma, env = get_current_context () in
let env = Environ.push_rel_context rctx env in
try str " " ++ pr_ltype_env env sigma typ
- with e when Errors.noncritical e -> mt ()
+ with e when CErrors.noncritical e -> mt ()
+ in
+ let pr_axiom env ax typ =
+ match ax with
+ | Constant kn ->
+ safe_pr_constant env kn ++ safe_pr_ltype typ
+ | Positive m ->
+ hov 2 (MutInd.print m ++ spc () ++ strbrk"is positive.")
+ | Guarded kn ->
+ hov 2 (safe_pr_constant env kn ++ spc () ++ strbrk"is positive.")
in
let fold t typ accu =
let (v, a, o, tr) = accu in
match t with
| Variable id ->
- let var = str (Id.to_string id) ++ str " : " ++ pr_ltype typ in
+ let var = pr_id id ++ str " : " ++ pr_ltype typ in
(var :: v, a, o, tr)
- | Axiom (kn,[]) ->
- let ax = safe_pr_constant env kn ++ safe_pr_ltype typ in
+ | Axiom (axiom, []) ->
+ let ax = pr_axiom env axiom typ in
(v, ax :: a, o, tr)
- | Axiom (kn,l) ->
- let ax = safe_pr_constant env kn ++ safe_pr_ltype typ ++
+ | Axiom (axiom,l) ->
+ let ax = pr_axiom env axiom typ ++
cut() ++
prlist_with_sep cut (fun (lbl, ctx, ty) ->
- str " used in " ++ str (Names.Label.to_string lbl) ++
+ str " used in " ++ pr_label lbl ++
str " to prove:" ++ safe_pr_ltype_relctx (ctx,ty))
l in
(v, ax :: a, o, tr)
@@ -839,4 +910,3 @@ let pr_polymorphic b =
let pr_universe_instance evd ctx =
let inst = Univ.UContext.instance ctx in
str"@{" ++ Univ.Instance.pr (Evd.pr_evd_level evd) inst ++ str"}"
-
diff --git a/printing/printer.mli b/printing/printer.mli
index 3424c41d..695ab33b 100644
--- a/printing/printer.mli
+++ b/printing/printer.mli
@@ -10,7 +10,6 @@ open Pp
open Names
open Globnames
open Term
-open Context
open Environ
open Pattern
open Evd
@@ -109,13 +108,13 @@ val pr_pconstructor : env -> pconstructor -> std_ppcmds
val pr_context_unlimited : env -> evar_map -> std_ppcmds
val pr_ne_context_of : std_ppcmds -> env -> evar_map -> std_ppcmds
-val pr_var_decl : env -> evar_map -> named_declaration -> std_ppcmds
-val pr_var_list_decl : env -> evar_map -> named_list_declaration -> std_ppcmds
-val pr_rel_decl : env -> evar_map -> rel_declaration -> std_ppcmds
+val pr_var_decl : env -> evar_map -> Context.Named.Declaration.t -> std_ppcmds
+val pr_var_list_decl : env -> evar_map -> Context.NamedList.Declaration.t -> std_ppcmds
+val pr_rel_decl : env -> evar_map -> Context.Rel.Declaration.t -> std_ppcmds
-val pr_named_context : env -> evar_map -> named_context -> std_ppcmds
+val pr_named_context : env -> evar_map -> Context.Named.t -> std_ppcmds
val pr_named_context_of : env -> evar_map -> std_ppcmds
-val pr_rel_context : env -> evar_map -> rel_context -> std_ppcmds
+val pr_rel_context : env -> evar_map -> Context.Rel.t -> std_ppcmds
val pr_rel_context_of : env -> evar_map -> std_ppcmds
val pr_context_of : env -> evar_map -> std_ppcmds
@@ -162,12 +161,16 @@ val prterm : constr -> std_ppcmds (** = pr_lconstr *)
(** Declarations for the "Print Assumption" command *)
+type axiom =
+ | Constant of constant (* An axiom or a constant. *)
+ | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *)
+ | Guarded of constant (* a constant whose (co)fixpoints have been assumed to be guarded *)
+
type context_object =
- | Variable of Id.t (** A section variable or a Let definition *)
- (** An axiom and the type it inhabits (if an axiom of the empty type) *)
- | Axiom of constant * (Label.t * Context.rel_context * types) list
- | Opaque of constant (** An opaque constant. *)
- | Transparent of constant (** A transparent constant *)
+ | Variable of Id.t (* A section variable or a Let definition *)
+ | Axiom of axiom * (Label.t * Context.Rel.t * types) list
+ | Opaque of constant (* An opaque constant. *)
+ | Transparent of constant
module ContextObjectSet : Set.S with type elt = context_object
module ContextObjectMap : CMap.ExtS
diff --git a/printing/printing.mllib b/printing/printing.mllib
index 652a34fa..bc8f0750 100644
--- a/printing/printing.mllib
+++ b/printing/printing.mllib
@@ -2,12 +2,8 @@ Genprint
Pputils
Ppannotation
Ppconstr
-Ppconstrsig
Printer
Pptactic
-Pptacticsig
Printmod
Prettyp
Ppvernac
-Ppvernacsig
-Richprinter
diff --git a/printing/printmod.ml b/printing/printmod.ml
index c154b0aa..dfa66d43 100644
--- a/printing/printmod.ml
+++ b/printing/printmod.ml
@@ -65,7 +65,6 @@ let get_new_id locals id =
(** Inductive declarations *)
-open Termops
open Reduction
let print_params env sigma params =
@@ -89,7 +88,7 @@ let print_one_inductive env sigma mib ((_,i) as ind) =
else Univ.Instance.empty in
let mip = mib.mind_packets.(i) in
let params = Inductive.inductive_paramdecls (mib,u) in
- let args = extended_rel_list 0 params in
+ let args = Context.Rel.to_extended_list 0 params in
let arity = hnf_prod_applist env (build_ind_type env ((mib,mip),u)) args in
let cstrtypes = Inductive.type_of_constructors (ind,u) (mib,mip) in
let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in
@@ -143,7 +142,7 @@ let print_record env mind mib =
in
let mip = mib.mind_packets.(0) in
let params = Inductive.inductive_paramdecls (mib,u) in
- let args = extended_rel_list 0 params in
+ let args = Context.Rel.to_extended_list 0 params in
let arity = hnf_prod_applist env (build_ind_type env ((mib,mip),u)) args in
let cstrtypes = Inductive.type_of_constructors ((mind,0),u) (mib,mip) in
let cstrtype = hnf_prod_applist env cstrtypes.(0) args in
@@ -248,22 +247,27 @@ let get_typ_expr_alg mtb = match mtb.mod_type_alg with
| _ -> raise Not_found
let nametab_register_modparam mbid mtb =
+ let id = MBId.to_id mbid in
match mtb.mod_type with
- | MoreFunctor _ -> () (* functorial param : nothing to register *)
+ | MoreFunctor _ -> id (* functorial param : nothing to register *)
| NoFunctor struc ->
(* We first try to use the algebraic type expression if any,
via a Declaremods function that converts back to module entries *)
try
- Declaremods.process_module_binding mbid (get_typ_expr_alg mtb)
- with e when Errors.noncritical e ->
+ let () = Declaremods.process_module_binding mbid (get_typ_expr_alg mtb) in
+ id
+ with e when CErrors.noncritical e ->
(* Otherwise, we try to play with the nametab ourselves *)
let mp = MPbound mbid in
- let dir = DirPath.make [MBId.to_id mbid] in
+ let check id = Nametab.exists_dir (DirPath.make [id]) in
+ let id = Namegen.next_ident_away_from id check in
+ let dir = DirPath.make [id] in
nametab_register_dir mp;
- List.iter (nametab_register_body mp dir) struc
+ List.iter (nametab_register_body mp dir) struc;
+ id
let print_body is_impl env mp (l,body) =
- let name = str (Label.to_string l) in
+ let name = pr_label l in
hov 2 (match body with
| SFBmodule _ -> keyword "Module" ++ spc () ++ name
| SFBmodtype _ -> keyword "Module Type" ++ spc () ++ name
@@ -296,7 +300,7 @@ let print_body is_impl env mp (l,body) =
try
let env = Option.get env in
pr_mutual_inductive_body env (MutInd.make2 mp l) mib
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
let keyword =
let open Decl_kinds in
match mib.mind_finite with
@@ -354,7 +358,7 @@ let print_mod_expr env mp locals = function
let rec print_functor fty fatom is_type env mp locals = function
|NoFunctor me -> fatom is_type env mp locals me
|MoreFunctor (mbid,mtb1,me2) ->
- nametab_register_modparam mbid mtb1;
+ let id = nametab_register_modparam mbid mtb1 in
let mp1 = MPbound mbid in
let pr_mtb1 = fty env mp1 locals mtb1 in
let env' = Option.map (Modops.add_module_type mp1 mtb1) env in
@@ -362,7 +366,7 @@ let rec print_functor fty fatom is_type env mp locals = function
let kwd = if is_type then "Funsig" else "Functor" in
hov 2
(keyword kwd ++ spc () ++
- str "(" ++ pr_id (MBId.to_id mbid) ++ str ":" ++ pr_mtb1 ++ str ")" ++
+ str "(" ++ pr_id id ++ str ":" ++ pr_mtb1 ++ str ")" ++
spc() ++ print_functor fty fatom is_type env' mp locals' me2)
let rec print_expression x =
@@ -423,7 +427,7 @@ let print_module with_body mp =
try
if !short then raise ShortPrinting;
unsafe_print_module (Some (Global.env ())) mp with_body me ++ fnl ()
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
unsafe_print_module None mp with_body me ++ fnl ()
let print_modtype kn =
@@ -434,7 +438,7 @@ let print_modtype kn =
(try
if !short then raise ShortPrinting;
print_signature' true (Some (Global.env ())) kn mtb.mod_type
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
print_signature' true None kn mtb.mod_type))
end
diff --git a/printing/richprinter.ml b/printing/richprinter.ml
deleted file mode 100644
index d95e1907..00000000
--- a/printing/richprinter.ml
+++ /dev/null
@@ -1,25 +0,0 @@
-open Richpp
-
-module RichppConstr = Ppconstr.Richpp
-module RichppVernac = Ppvernac.Richpp
-module RichppTactic = Pptactic.Richpp
-
-type rich_pp =
- Ppannotation.t Richpp.located Xml_datatype.gxml
- * Xml_datatype.xml
-
-let get_annotations obj = Pp.Tag.prj obj Ppannotation.tag
-
-let make_richpp pr ast =
- let rich_pp =
- rich_pp get_annotations (pr ast)
- in
- let xml = Ppannotation.(
- xml_of_rich_pp tag_of_annotation attributes_of_annotation rich_pp
- )
- in
- (rich_pp, xml)
-
-let richpp_vernac = make_richpp RichppVernac.pr_vernac
-let richpp_constr = make_richpp RichppConstr.pr_constr_expr
-let richpp_tactic env = make_richpp (RichppTactic.pr_tactic env)
diff --git a/printing/richprinter.mli b/printing/richprinter.mli
deleted file mode 100644
index 261d22c4..00000000
--- a/printing/richprinter.mli
+++ /dev/null
@@ -1,39 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* rich_pp
-
-(** [richpp_constr constr] produces a rich pretty-printing of [constr]. *)
-val richpp_constr : Constrexpr.constr_expr -> rich_pp
-
-(** [richpp_tactic constr] produces a rich pretty-printing of [tactic]. *)
-val richpp_tactic : Environ.env -> Tacexpr.tactic_expr -> rich_pp
diff --git a/proofs/clenv.ml b/proofs/clenv.ml
index 88e1bce9..0a90e0db 100644
--- a/proofs/clenv.ml
+++ b/proofs/clenv.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Nameops
@@ -24,6 +24,7 @@ open Pretype_errors
open Evarutil
open Unification
open Misctypes
+open Sigma.Notations
(* Abbreviations *)
@@ -71,7 +72,7 @@ let clenv_get_type_of ce c = Retyping.get_type_of (cl_env ce) (cl_sigma ce) c
exception NotExtensibleClause
let clenv_push_prod cl =
- let typ = whd_betadeltaiota (cl_env cl) (cl_sigma cl) (clenv_type cl) in
+ let typ = whd_all (cl_env cl) (cl_sigma cl) (clenv_type cl) in
let rec clrec typ = match kind_of_term typ with
| Cast (t,_,_) -> clrec t
| Prod (na,t,u) ->
@@ -108,7 +109,7 @@ let clenv_environments evd bound t =
| (n, Cast (t,_,_)) -> clrec (e,metas) n t
| (n, Prod (na,t1,t2)) ->
let mv = new_meta () in
- let dep = dependent (mkRel 1) t2 in
+ let dep = not (noccurn 1 t2) in
let na' = if dep then na else Anonymous in
let e' = meta_declare mv t1 ~name:na' e in
clrec (e', (mkMeta mv)::metas) (Option.map ((+) (-1)) n)
@@ -119,7 +120,7 @@ let clenv_environments evd bound t =
clrec (evd,[]) bound t
let mk_clenv_from_env env sigma n (c,cty) =
- let evd = create_goal_evar_defs sigma in
+ let evd = clear_metas sigma in
let (evd,args,concl) = clenv_environments evd n cty in
{ templval = mk_freelisted (applist (c,args));
templtyp = mk_freelisted concl;
@@ -335,22 +336,15 @@ let clenv_pose_metas_as_evars clenv dep_mvs =
else
let src = evar_source_of_meta mv clenv.evd in
let src = adjust_meta_source clenv.evd mv src in
- let (evd,evar) = new_evar (cl_env clenv) clenv.evd ~src ty in
+ let evd = Sigma.Unsafe.of_evar_map clenv.evd in
+ let Sigma (evar, evd, _) = new_evar (cl_env clenv) evd ~src ty in
+ let evd = Sigma.to_evar_map evd in
let clenv = clenv_assign mv evar {clenv with evd=evd} in
fold clenv mvs in
fold clenv dep_mvs
(******************************************************************)
-let connect_clenv gls clenv =
- let evd = evars_reset_evd ~with_conv_pbs:true gls.sigma clenv.evd in
- { clenv with
- evd = evd ;
- env = Goal.V82.env evd (sig_it gls) }
-
-(* let connect_clenv_key = Profile.declare_profile "connect_clenv";; *)
-(* let connect_clenv = Profile.profile2 connect_clenv_key connect_clenv *)
-
(* [clenv_fchain mv clenv clenv']
*
* Resolves the value of "mv" (which must be undefined) in clenv to be
@@ -432,6 +426,44 @@ let check_bindings bl =
str " occurs more than once in binding list.")
| [] -> ()
+let explain_no_such_bound_variable evd id =
+ let fold l (n, clb) =
+ let na = match clb with
+ | Cltyp (na, _) -> na
+ | Clval (na, _, _) -> na
+ in
+ if na != Anonymous then out_name na :: l else l
+ in
+ let mvl = List.fold_left fold [] (Evd.meta_list evd) in
+ errorlabstrm "Evd.meta_with_name"
+ (str"No such bound variable " ++ pr_id id ++
+ (if mvl == [] then str " (no bound variables at all in the expression)."
+ else
+ (str" (possible name" ++
+ str (if List.length mvl == 1 then " is: " else "s are: ") ++
+ pr_enum pr_id mvl ++ str").")))
+
+let meta_with_name evd id =
+ let na = Name id in
+ let fold (l1, l2 as l) (n, clb) =
+ let (na',def) = match clb with
+ | Cltyp (na, _) -> (na, false)
+ | Clval (na, _, _) -> (na, true)
+ in
+ if Name.equal na na' then if def then (n::l1,l2) else (n::l1,n::l2)
+ else l
+ in
+ let (mvl, mvnodef) = List.fold_left fold ([], []) (Evd.meta_list evd) in
+ match mvnodef, mvl with
+ | _,[] ->
+ explain_no_such_bound_variable evd id
+ | ([n],_|_,[n]) ->
+ n
+ | _ ->
+ errorlabstrm "Evd.meta_with_name"
+ (str "Binder name \"" ++ pr_id id ++
+ strbrk "\" occurs more than once in clause.")
+
let meta_of_binder clause loc mvs = function
| NamedHyp s -> meta_with_name clause.evd s
| AnonHyp n ->
@@ -459,7 +491,8 @@ let clenv_unify_binding_type clenv c t u =
let evd,c = w_coerce_to_type (cl_env clenv) clenv.evd c t u in
TypeProcessed, { clenv with evd = evd }, c
with
- | PretypeError (_,_,ActualTypeNotCoercible (_,_,NotClean _)) as e ->
+ | PretypeError (_,_,ActualTypeNotCoercible (_,_,
+ (NotClean _ | ConversionFailed _))) as e ->
raise e
| e when precatchable_exception e ->
TypeNotProcessed, clenv, c
@@ -576,7 +609,9 @@ let make_evar_clause env sigma ?len t =
| Cast (t, _, _) -> clrec (sigma, holes) n t
| Prod (na, t1, t2) ->
let store = Typeclasses.set_resolvable Evd.Store.empty false in
- let sigma, ev = new_evar ~store env sigma t1 in
+ let sigma = Sigma.Unsafe.of_evar_map sigma in
+ let Sigma (ev, sigma, _) = new_evar ~store env sigma t1 in
+ let sigma = Sigma.to_evar_map sigma in
let dep = dependent (mkRel 1) t2 in
let hole = {
hole_evar = ev;
@@ -628,7 +663,7 @@ let evar_of_binder holes = function
try
let h = List.nth holes (pred n) in
h.hole_evar
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
errorlabstrm "" (str "No such binder.")
let define_with_type sigma env ev c =
diff --git a/proofs/clenv.mli b/proofs/clenv.mli
index 7ecc26ec..e9236b1d 100644
--- a/proofs/clenv.mli
+++ b/proofs/clenv.mli
@@ -6,6 +6,10 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** This file defines clausenv, which is a deprecated way to handle open terms
+ in the proof engine. Most of the API here is legacy except for the
+ evar-based clauses. *)
+
open Names
open Term
open Environ
@@ -49,7 +53,6 @@ val refresh_undefined_univs : clausenv -> clausenv * Univ.universe_level_subst
(** {6 linking of clenvs } *)
-val connect_clenv : Goal.goal sigma -> clausenv -> clausenv
val clenv_fchain :
?with_univs:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv
diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml
index 8e922599..98b5bc8b 100644
--- a/proofs/clenvtac.ml
+++ b/proofs/clenvtac.ml
@@ -16,7 +16,7 @@ open Logic
open Reduction
open Tacmach
open Clenv
-
+open Proofview.Notations
(* This function put casts around metavariables whose type could not be
* infered by the refiner, that is head of applications, predicates and
@@ -59,6 +59,19 @@ let clenv_pose_dependent_evars with_evars clenv =
(RefinerError (UnresolvedBindings (List.map (meta_name clenv.evd) dep_mvs)));
clenv_pose_metas_as_evars clenv dep_mvs
+(** Use our own fast path, more informative than from Typeclasses *)
+let check_tc evd =
+ let has_resolvable = ref false in
+ let check _ evi =
+ let res = Typeclasses.is_resolvable evi in
+ if res then
+ let () = has_resolvable := true in
+ Typeclasses.is_class_evar evd evi
+ else false
+ in
+ let has_typeclass = Evar.Map.exists check (Evd.undefined_map evd) in
+ (has_typeclass, !has_resolvable)
+
let clenv_refine with_evars ?(with_classes=true) clenv =
(** ppedrot: a Goal.enter here breaks things, because the tactic below may
solve goals by side effects, while the compatibility layer keeps those
@@ -67,9 +80,16 @@ let clenv_refine with_evars ?(with_classes=true) clenv =
let clenv = clenv_pose_dependent_evars with_evars clenv in
let evd' =
if with_classes then
- let evd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars
- ~fail:(not with_evars) clenv.env clenv.evd
- in Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals evd'
+ let (has_typeclass, has_resolvable) = check_tc clenv.evd in
+ let evd' =
+ if has_typeclass then
+ Typeclasses.resolve_typeclasses ~fast_path:false ~filter:Typeclasses.all_evars
+ ~fail:(not with_evars) clenv.env clenv.evd
+ else clenv.evd
+ in
+ if has_resolvable then
+ Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals evd'
+ else evd'
else clenv.evd
in
let clenv = { clenv with evd = evd' } in
@@ -83,10 +103,10 @@ open Unification
let dft = default_unify_flags
let res_pf ?(with_evars=false) ?(with_classes=true) ?(flags=dft ()) clenv =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let clenv gl = clenv_unique_resolver ~flags clenv gl in
clenv_refine with_evars ~with_classes (Tacmach.New.of_old clenv (Proofview.Goal.assume gl))
- end
+ end }
(* [unifyTerms] et [unify] ne semble pas gérer les Meta, en
particulier ne semblent pas vérifier que des instances différentes
@@ -118,12 +138,12 @@ let fail_quick_unif_flags = {
(* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *)
let unify ?(flags=fail_quick_unif_flags) m =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Tacmach.New.pf_env gl in
- let n = Tacmach.New.pf_nf_concl gl in
- let evd = create_goal_evar_defs (Proofview.Goal.sigma gl) in
+ let n = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in
+ let evd = clear_metas (Tacmach.New.project gl) in
try
let evd' = w_unify env evd CONV ~flags m n in
Proofview.Unsafe.tclEVARSADVANCE evd'
- with e when Errors.noncritical e -> Proofview.tclZERO e
- end
+ with e when CErrors.noncritical e -> Proofview.tclZERO e
+ end }
diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli
index 00e74a24..aa091aec 100644
--- a/proofs/clenvtac.mli
+++ b/proofs/clenvtac.mli
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Legacy components of the previous proof engine. *)
+
open Term
open Clenv
open Tacexpr
diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml
index 059ae54c..29cad063 100644
--- a/proofs/evar_refiner.ml
+++ b/proofs/evar_refiner.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Evd
@@ -46,27 +46,16 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma =
let sigma',typed_c =
let flags = {
Pretyping.use_typeclasses = true;
- Pretyping.use_unif_heuristics = true;
+ Pretyping.solve_unification_constraints = true;
Pretyping.use_hook = None;
Pretyping.fail_evar = false;
Pretyping.expand_evars = true } in
try Pretyping.understand_ltac flags
env sigma ltac_var (Pretyping.OfType evi.evar_concl) rawc
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
let loc = Glob_ops.loc_of_glob_constr rawc in
user_err_loc
(loc,"", str "Instance is not well-typed in the environment of " ++
- str (string_of_existential evk))
+ pr_existential_key sigma evk ++ str ".")
in
define_and_solve_constraints evk typed_c env (evars_reset_evd sigma' sigma)
-
-(* vernac command Existential *)
-
-(* Main component of vernac command Existential *)
-let instantiate_pf_com evk com sigma =
- let evi = Evd.find sigma evk in
- let env = Evd.evar_filtered_env evi in
- let rawc = Constrintern.intern_constr env com in
- let ltac_vars = Pretyping.empty_lvar in
- let sigma' = w_refine (evk, evi) (ltac_vars, rawc) sigma in
- sigma'
diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli
index 35a3e5d8..e3778e94 100644
--- a/proofs/evar_refiner.mli
+++ b/proofs/evar_refiner.mli
@@ -13,8 +13,3 @@ open Pretyping
val w_refine : evar * evar_info ->
glob_constr_ltac_closure -> evar_map -> evar_map
-
-val instantiate_pf_com :
- Evd.evar -> Constrexpr.constr_expr -> Evd.evar_map -> Evd.evar_map
-
-(** the instantiate tactic was moved to [tactics/evar_tactics.ml] *)
diff --git a/proofs/goal.ml b/proofs/goal.ml
index 1dd5be0e..111a947a 100644
--- a/proofs/goal.ml
+++ b/proofs/goal.ml
@@ -9,6 +9,8 @@
open Util
open Pp
open Term
+open Sigma.Notations
+open Context.Named.Declaration
(* This module implements the abstract interface to goals *)
(* A general invariant of the module, is that a goal whose associated
@@ -70,10 +72,12 @@ module V82 = struct
Evd.evar_extra = extra }
in
let evi = Typeclasses.mark_unresolvable evi in
- let (evars, evk) = Evarutil.new_pure_evar_full evars evi in
+ let evars = Sigma.Unsafe.of_evar_map evars in
+ let Sigma (evk, evars, _) = Evarutil.new_pure_evar_full evars evi in
+ let evars = Sigma.to_evar_map evars in
let evars = Evd.restore_future_goals evars prev_future_goals prev_principal_goal in
let ctxt = Environ.named_context_of_val hyps in
- let inst = Array.map_of_list (fun (id, _, _) -> mkVar id) ctxt in
+ let inst = Array.map_of_list (mkVar % get_id) ctxt in
let ev = Term.mkEvar (evk,inst) in
(evk, ev, evars)
@@ -89,7 +93,10 @@ module V82 = struct
(* Instantiates a goal with an open term, using name of goal for evk' *)
let partial_solution_to sigma evk evk' c =
let id = Evd.evar_ident evk sigma in
- Evd.rename evk' id (partial_solution sigma evk c)
+ let sigma = partial_solution sigma evk c in
+ match id with
+ | None -> sigma
+ | Some id -> Evd.rename evk' id sigma
(* Parts of the progress tactical *)
let same_goal evars1 gl1 evars2 gl2 =
@@ -123,8 +130,10 @@ module V82 = struct
let new_evi =
{ evi with Evd.evar_hyps = new_hyps; Evd.evar_filter = new_filter } in
let new_evi = Typeclasses.mark_unresolvable new_evi in
- let (new_sigma, evk) = Evarutil.new_pure_evar_full Evd.empty new_evi in
- { Evd.it = evk ; sigma = new_sigma; }
+ let sigma = Sigma.Unsafe.of_evar_map Evd.empty in
+ let Sigma (evk, sigma, _) = Evarutil.new_pure_evar_full sigma new_evi in
+ let sigma = Sigma.to_evar_map sigma in
+ { Evd.it = evk ; sigma = sigma; }
(* Used by the compatibility layer and typeclasses *)
let nf_evar sigma gl =
@@ -139,7 +148,7 @@ module V82 = struct
let env = env sigma gl in
let genv = Global.env () in
let is_proof_var decl =
- try ignore (Environ.lookup_named (Util.pi1 decl) genv); false
+ try ignore (Environ.lookup_named (get_id decl) genv); false
with Not_found -> true in
Environ.fold_named_context_reverse (fun t decl ->
if is_proof_var decl then
diff --git a/proofs/goal.mli b/proofs/goal.mli
index 6152826c..6a79c1f4 100644
--- a/proofs/goal.mli
+++ b/proofs/goal.mli
@@ -6,7 +6,9 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* This module implements the abstract interface to goals *)
+(** This module implements the abstract interface to goals. Most of the code
+ here is useless and should be eventually removed. Consider using
+ {!Proofview.Goal} instead. *)
type goal = Evar.t
@@ -67,7 +69,7 @@ module V82 : sig
val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool
(* Used for congruence closure *)
- val new_goal_with : Evd.evar_map -> goal -> Context.named_context -> goal Evd.sigma
+ val new_goal_with : Evd.evar_map -> goal -> Context.Named.t -> goal Evd.sigma
(* Used by the compatibility layer and typeclasses *)
val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map
diff --git a/proofs/logic.ml b/proofs/logic.ml
index ed3a1df1..65497c80 100644
--- a/proofs/logic.ml
+++ b/proofs/logic.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Nameops
@@ -22,6 +22,7 @@ open Proof_type
open Type_errors
open Retyping
open Misctypes
+open Context.Named.Declaration
type refiner_error =
@@ -58,7 +59,7 @@ let is_unification_error = function
| _ -> false
let catchable_exception = function
- | Errors.UserError _ | TypeError _
+ | CErrors.UserError _ | TypeError _
| RefinerError _ | Indrec.RecursionSchemeError _
| Nametab.GlobalizationError _
(* reduction errors *)
@@ -76,10 +77,10 @@ let with_check = Flags.with_option check
(* [apply_to_hyp sign id f] splits [sign] into [tail::[id,_,_]::head] and
returns [tail::(f head (id,_,_) (rev tail))] *)
-let apply_to_hyp sign id f =
+let apply_to_hyp check sign id f =
try apply_to_hyp sign id f
with Hyp_not_found ->
- if !check then error_no_such_hypothesis id
+ if check then error_no_such_hypothesis id
else sign
let check_typability env sigma c =
@@ -95,12 +96,12 @@ let check_typability env sigma c =
forces the user to give them in order). *)
let clear_hyps env sigma ids sign cl =
- let evdref = ref (Evd.create_goal_evar_defs sigma) in
+ let evdref = ref (Evd.clear_metas sigma) in
let (hyps,cl) = Evarutil.clear_hyps_in_evi env evdref sign cl ids in
(hyps, cl, !evdref)
let clear_hyps2 env sigma ids sign t cl =
- let evdref = ref (Evd.create_goal_evar_defs sigma) in
+ let evdref = ref (Evd.clear_metas sigma) in
let (hyps,t,cl) = Evarutil.clear_hyps2_in_evi env evdref sign t cl ids in
(hyps, t, cl, !evdref)
@@ -160,7 +161,8 @@ let reorder_context env sign ord =
| _ ->
(match ctxt_head with
| [] -> error_no_such_hypothesis (List.hd ord)
- | (x,_,_ as d) :: ctxt ->
+ | d :: ctxt ->
+ let x = get_id d in
if Id.Set.mem x expected then
step ord (Id.Set.remove x expected)
ctxt (push_item x d moved_hyps) ctxt_tail
@@ -175,7 +177,8 @@ let reorder_val_context env sign ord =
-let check_decl_position env sign (x,_,_ as d) =
+let check_decl_position env sign d =
+ let x = get_id d in
let needed = global_vars_set_of_decl env d in
let deps = dependency_closure env (named_context_of_val sign) needed in
if Id.List.mem x deps then
@@ -200,16 +203,17 @@ let move_location_eq m1 m2 = match m1, m2 with
let rec get_hyp_after h = function
| [] -> error_no_such_hypothesis h
- | (hyp,_,_) :: right ->
- if Id.equal hyp h then
- match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveFirst
+ | d :: right ->
+ if Id.equal (get_id d) h then
+ match right with d' ::_ -> MoveBefore (get_id d') | [] -> MoveFirst
else
get_hyp_after h right
let split_sign hfrom hto l =
let rec splitrec left toleft = function
| [] -> error_no_such_hypothesis hfrom
- | (hyp,c,typ) as d :: right ->
+ | d :: right ->
+ let hyp,_,typ = to_tuple d in
if Id.equal hyp hfrom then
(left,right,d, toleft || move_location_eq hto MoveLast)
else
@@ -227,27 +231,28 @@ let hyp_of_move_location = function
| MoveBefore id -> id
| _ -> assert false
-let move_hyp toleft (left,(idfrom,_,_ as declfrom),right) hto =
+let move_hyp toleft (left,declfrom,right) hto =
let env = Global.env() in
- let test_dep (hyp,c,typ as d) (hyp2,c,typ2 as d2) =
+ let test_dep d d2 =
if toleft
- then occur_var_in_decl env hyp2 d
- else occur_var_in_decl env hyp d2
+ then occur_var_in_decl env (get_id d2) d
+ else occur_var_in_decl env (get_id d) d2
in
let rec moverec first middle = function
| [] ->
if match hto with MoveFirst | MoveLast -> false | _ -> true then
error_no_such_hypothesis (hyp_of_move_location hto);
List.rev first @ List.rev middle
- | (hyp,_,_) :: _ as right when move_location_eq hto (MoveBefore hyp) ->
+ | d :: _ as right when move_location_eq hto (MoveBefore (get_id d)) ->
List.rev first @ List.rev middle @ right
- | (hyp,_,_) as d :: right ->
+ | d :: right ->
+ let hyp = get_id d in
let (first',middle') =
if List.exists (test_dep d) middle then
if not (move_location_eq hto (MoveAfter hyp)) then
(first, d::middle)
else
- errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id idfrom ++
+ errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id (get_id declfrom) ++
Miscprint.pr_move_location pr_id hto ++
str (if toleft then ": it occurs in " else ": it depends on ")
++ pr_id hyp ++ str ".")
@@ -271,6 +276,11 @@ let move_hyp toleft (left,(idfrom,_,_ as declfrom),right) hto =
List.fold_left (fun sign d -> push_named_context_val d sign)
right left
+let move_hyp_in_named_context hfrom hto sign =
+ let (left,right,declfrom,toleft) =
+ split_sign hfrom hto (named_context_of_val sign) in
+ move_hyp toleft (left,declfrom,right) hto
+
(**********************************************************************)
@@ -458,7 +468,7 @@ and mk_hdgoals sigma goal goalacc trm =
and mk_arggoals sigma goal goalacc funty allargs =
let foldmap (goalacc, funty, sigma) harg =
- let t = whd_betadeltaiota (Goal.V82.env sigma goal) sigma funty in
+ let t = whd_all (Goal.V82.env sigma goal) sigma funty in
let rec collapse t = match kind_of_term t with
| LetIn (_, c1, _, b) -> collapse (subst1 c1 b)
| _ -> t
@@ -483,12 +493,14 @@ and mk_casegoals sigma goal goalacc p c =
(acc'',lbrty,conclty,sigma,p',c')
-let convert_hyp check sign sigma (id,b,bt as d) =
+let convert_hyp check sign sigma d =
+ let id,b,bt = to_tuple d in
let env = Global.env() in
let reorder = ref [] in
let sign' =
- apply_to_hyp sign id
- (fun _ (_,c,ct) _ ->
+ apply_to_hyp check sign id
+ (fun _ d' _ ->
+ let _,c,ct = to_tuple d' in
let env = Global.env_of_context sign in
if check && not (is_conv env sigma bt ct) then
errorlabstrm "Logic.convert_hyp"
@@ -522,126 +534,23 @@ let prim_refiner r sigma goal =
if replace then
let nexthyp = get_hyp_after id (named_context_of_val sign) in
let sign,t,cl,sigma = clear_hyps2 env sigma (Id.Set.singleton id) sign t cl in
- move_hyp false ([],(id,None,t),named_context_of_val sign)
+ move_hyp false ([], LocalAssum (id,t),named_context_of_val sign)
nexthyp,
t,cl,sigma
else
- (if !check && mem_named_context id (named_context_of_val sign) then
+ (if !check && mem_named_context_val id sign then
errorlabstrm "Logic.prim_refiner"
(str "Variable " ++ pr_id id ++ str " is already declared.");
- push_named_context_val (id,None,t) sign,t,cl,sigma) in
+ push_named_context_val (LocalAssum (id,t)) sign,t,cl,sigma) in
let (sg2,ev2,sigma) =
Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in
- let oterm = Term.mkApp (mkNamedLambda id t ev2 , [| ev1 |]) in
+ let oterm = Term.mkNamedLetIn id ev1 t ev2 in
let sigma = Goal.V82.partial_solution_to sigma goal sg2 oterm in
if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma)
- | FixRule (f,n,rest,j) ->
- let rec check_ind env k cl =
- match kind_of_term (strip_outer_cast cl) with
- | Prod (na,c1,b) ->
- if Int.equal k 1 then
- try
- fst (find_inductive env sigma c1)
- with Not_found ->
- error "Cannot do a fixpoint on a non inductive type."
- else
- check_ind (push_rel (na,None,c1) env) (k-1) b
- | _ -> error "Not enough products."
- in
- let ((sp,_),u) = check_ind env n cl in
- let firsts,lasts = List.chop j rest in
- let all = firsts@(f,n,cl)::lasts in
- let rec mk_sign sign = function
- | (f,n,ar)::oth ->
- let ((sp',_),u') = check_ind env n ar in
- if not (eq_mind sp sp') then
- error "Fixpoints should be on the same mutual inductive declaration.";
- if !check && mem_named_context f (named_context_of_val sign) then
- errorlabstrm "Logic.prim_refiner"
- (str "Name " ++ pr_id f ++ str " already used in the environment");
- mk_sign (push_named_context_val (f,None,ar) sign) oth
- | [] ->
- Evd.Monad.List.map (fun (_,_,c) sigma ->
- let gl,ev,sig' =
- Goal.V82.mk_goal sigma sign c (Goal.V82.extra sigma goal) in
- (gl,ev),sig')
- all sigma
- in
- let (gls_evs,sigma) = mk_sign sign all in
- let (gls,evs) = List.split gls_evs in
- let ids = List.map pi1 all in
- let evs = List.map (Vars.subst_vars (List.rev ids)) evs in
- let indxs = Array.of_list (List.map (fun n -> n-1) (List.map pi2 all)) in
- let funnames = Array.of_list (List.map (fun i -> Name i) ids) in
- let typarray = Array.of_list (List.map pi3 all) in
- let bodies = Array.of_list evs in
- let oterm = Term.mkFix ((indxs,0),(funnames,typarray,bodies)) in
- let sigma = Goal.V82.partial_solution sigma goal oterm in
- (gls,sigma)
-
- | Cofix (f,others,j) ->
- let rec check_is_coind env cl =
- let b = whd_betadeltaiota env sigma cl in
- match kind_of_term b with
- | Prod (na,c1,b) -> check_is_coind (push_rel (na,None,c1) env) b
- | _ ->
- try
- let _ = find_coinductive env sigma b in ()
- with Not_found ->
- error "All methods must construct elements in coinductive types."
- in
- let firsts,lasts = List.chop j others in
- let all = firsts@(f,cl)::lasts in
- List.iter (fun (_,c) -> check_is_coind env c) all;
- let rec mk_sign sign = function
- | (f,ar)::oth ->
- (try
- (let _ = lookup_named_val f sign in
- error "Name already used in the environment.")
- with
- | Not_found ->
- mk_sign (push_named_context_val (f,None,ar) sign) oth)
- | [] ->
- Evd.Monad.List.map (fun (_,c) sigma ->
- let gl,ev,sigma =
- Goal.V82.mk_goal sigma sign c (Goal.V82.extra sigma goal) in
- (gl,ev),sigma)
- all sigma
- in
- let (gls_evs,sigma) = mk_sign sign all in
- let (gls,evs) = List.split gls_evs in
- let (ids,types) = List.split all in
- let evs = List.map (Vars.subst_vars (List.rev ids)) evs in
- let funnames = Array.of_list (List.map (fun i -> Name i) ids) in
- let typarray = Array.of_list types in
- let bodies = Array.of_list evs in
- let oterm = Term.mkCoFix (0,(funnames,typarray,bodies)) in
- let sigma = Goal.V82.partial_solution sigma goal oterm in
- (gls,sigma)
-
| Refine c ->
check_meta_variables c;
let (sgl,cl',sigma,oterm) = mk_refgoals sigma goal [] cl c in
let sgl = List.rev sgl in
let sigma = Goal.V82.partial_solution sigma goal oterm in
(sgl, sigma)
-
- (* And now the structural rules *)
- | Thin ids ->
- let ids = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty ids in
- let (hyps,concl,nsigma) = clear_hyps env sigma ids sign cl in
- let (gl,ev,sigma) =
- Goal.V82.mk_goal nsigma hyps concl (Goal.V82.extra nsigma goal)
- in
- let sigma = Goal.V82.partial_solution_to sigma goal gl ev in
- ([gl], sigma)
-
- | Move (hfrom, hto) ->
- let (left,right,declfrom,toleft) =
- split_sign hfrom hto (named_context_of_val sign) in
- let hyps' =
- move_hyp toleft (left,declfrom,right) hto in
- let (gl,ev,sigma) = mk_goal hyps' cl in
- let sigma = Goal.V82.partial_solution_to sigma goal gl ev in
- ([gl], sigma)
diff --git a/proofs/logic.mli b/proofs/logic.mli
index ed99d3a3..0dba9ef1 100644
--- a/proofs/logic.mli
+++ b/proofs/logic.mli
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Legacy proof engine. Do not use in newly written code. *)
+
open Names
open Term
open Evd
@@ -53,4 +55,7 @@ exception RefinerError of refiner_error
val catchable_exception : exn -> bool
val convert_hyp : bool -> Environ.named_context_val -> evar_map ->
- Context.named_declaration -> Environ.named_context_val
+ Context.Named.Declaration.t -> Environ.named_context_val
+
+val move_hyp_in_named_context : Id.t -> Id.t Misctypes.move_location ->
+ Environ.named_context_val -> Environ.named_context_val
diff --git a/proofs/logic_monad.ml b/proofs/logic_monad.ml
deleted file mode 100644
index 68efa71e..00000000
--- a/proofs/logic_monad.ml
+++ /dev/null
@@ -1,321 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* Errors.errorlabstrm "Some timeout function" (Pp.str"Timeout!")
- | Exception e -> Errors.print e
- | TacticFailure e -> Errors.print e
- | _ -> Pervasives.raise Errors.Unhandled
-end
-
-(** {6 Non-logical layer} *)
-
-(** The non-logical monad is a simple [unit -> 'a] (i/o) monad. The
- operations are simple wrappers around corresponding usual
- operations and require little documentation. *)
-module NonLogical =
-struct
-
- (* The functions in this module follow the pattern that they are
- defined with the form [(); fun ()->...]. This is an optimisation
- which signals to the compiler that the function is usually partially
- applied up to the [();]. Without this annotation, partial
- applications can be significantly slower.
-
- Documentation of this behaviour can be found at:
- https://ocaml.janestreet.com/?q=node/30 *)
-
- include Monad.Make(struct
- type 'a t = unit -> 'a
-
- let return a = (); fun () -> a
- let (>>=) a k = (); fun () -> k (a ()) ()
- let (>>) a k = (); fun () -> a (); k ()
- let map f a = (); fun () -> f (a ())
- end)
-
- type 'a ref = 'a Pervasives.ref
-
- let ignore a = (); fun () -> ignore (a ())
-
- let ref a = (); fun () -> Pervasives.ref a
-
- (** [Pervasives.(:=)] *)
- let (:=) r a = (); fun () -> r := a
-
- (** [Pervasives.(!)] *)
- let (!) = fun r -> (); fun () -> ! r
-
- (** [Pervasives.raise]. Except that exceptions are wrapped with
- {!Exception}. *)
- let raise ?info = fun e -> (); fun () -> Exninfo.raise ?info (Exception e)
-
- (** [try ... with ...] but restricted to {!Exception}. *)
- let catch = fun s h -> ();
- fun () -> try s ()
- with Exception e as src ->
- let (src, info) = Errors.push src in
- h (e, info) ()
-
- let read_line = fun () -> try Pervasives.read_line () with e ->
- let (e, info) = Errors.push e in raise ~info e ()
-
- let print_char = fun c -> (); fun () -> print_char c
-
- let timeout = fun n t -> (); fun () ->
- Control.timeout n t (Exception Timeout)
-
- let make f = (); fun () ->
- try f ()
- with e when Errors.noncritical e ->
- let (e, info) = Errors.push e in
- Util.iraise (Exception e, info)
-
- (** Use the current logger. The buffer is also flushed. *)
- let print_debug s = make (fun _ -> Pp.msg_info s;Pp.pp_flush ())
- let print_info s = make (fun _ -> Pp.msg_info s;Pp.pp_flush ())
- let print_warning s = make (fun _ -> Pp.msg_warning s;Pp.pp_flush ())
- let print_error s = make (fun _ -> Pp.msg_error s;Pp.pp_flush ())
- let print_notice s = make (fun _ -> Pp.msg_notice s;Pp.pp_flush ())
-
- let run = fun x ->
- try x () with Exception e as src ->
- let (src, info) = Errors.push src in
- Util.iraise (e, info)
-end
-
-(** {6 Logical layer} *)
-
-(** The logical monad is a backtracking monad on top of which is
- layered a state monad (which is used to implement all of read/write,
- read only, and write only effects). The state monad being layered on
- top of the backtracking monad makes it so that the state is
- backtracked on failure.
-
- Backtracking differs from regular exception in that, writing (+)
- for exception catching and (>>=) for bind, we require the
- following extra distributivity laws:
-
- x+(y+z) = (x+y)+z
-
- zero+x = x
-
- x+zero = x
-
- (x+y)>>=k = (x>>=k)+(y>>=k) *)
-
-(** A view type for the logical monad, which is a form of list, hence
- we can decompose it with as a list. *)
-type ('a, 'b) list_view =
- | Nil of Exninfo.iexn
- | Cons of 'a * 'b
-
-module type Param = sig
-
- (** Read only *)
- type e
-
- (** Write only *)
- type w
-
- (** [w] must be a monoid *)
- val wunit : w
- val wprod : w -> w -> w
-
- (** Read-write *)
- type s
-
- (** Update-only. Essentially a writer on [u->u]. *)
- type u
-
- (** [u] must be pointed. *)
- val uunit : u
-
-end
-
-
-module Logical (P:Param) =
-struct
-
- (** All three of environment, writer and state are coded as a single
- state-passing-style monad.*)
- type state = {
- rstate : P.e;
- ustate : P.u;
- wstate : P.w;
- sstate : P.s;
- }
-
- (** Double-continuation backtracking monads are reasonable folklore
- for "search" implementations (including the Tac interactive
- prover's tactics). Yet it's quite hard to wrap your head around
- these. I recommand reading a few times the "Backtracking,
- Interleaving, and Terminating Monad Transformers" paper by
- O. Kiselyov, C. Shan, D. Friedman, and A. Sabry. The peculiar
- shape of the monadic type is reminiscent of that of the
- continuation monad transformer.
-
- The paper also contains the rationale for the [split] abstraction.
-
- An explanation of how to derive such a monad from mathematical
- principles can be found in "Kan Extensions for Program
- Optimisation" by Ralf Hinze.
-
- A somewhat concrete view is that the type ['a iolist] is, in fact
- the impredicative encoding of the following stream type:
-
- [type 'a _iolist' = Nil of exn | Cons of 'a*'a iolist'
- and 'a iolist = 'a _iolist NonLogical.t]
-
- Using impredicative encoding avoids intermediate allocation and
- is, empirically, very efficient in Ocaml. It also has the
- practical benefit that the monadic operation are independent of
- the underlying monad, which simplifies the code and side-steps
- the limited inlining of Ocaml.
-
- In that vision, [bind] is simply [concat_map] (though the cps
- version is significantly simpler), [plus] is concatenation, and
- [split] is pattern-matching. *)
- type rich_exn = Exninfo.iexn
-
- type 'a iolist =
- { iolist : 'r. state -> (rich_exn -> 'r NonLogical.t) ->
- ('a -> state -> (rich_exn -> 'r NonLogical.t) -> 'r NonLogical.t) ->
- 'r NonLogical.t }
-
- include Monad.Make(struct
-
- type 'a t = 'a iolist
-
- let return x =
- { iolist = fun s nil cons -> cons x s nil }
-
- let (>>=) m f =
- { iolist = fun s nil cons ->
- m.iolist s nil (fun x s next -> (f x).iolist s next cons) }
-
- let (>>) m f =
- { iolist = fun s nil cons ->
- m.iolist s nil (fun () s next -> f.iolist s next cons) }
-
- let map f m =
- { iolist = fun s nil cons -> m.iolist s nil (fun x s next -> cons (f x) s next) }
-
- end)
-
- let zero e =
- { iolist = fun _ nil cons -> nil e }
-
- let plus m1 m2 =
- { iolist = fun s nil cons -> m1.iolist s (fun e -> (m2 e).iolist s nil cons) cons }
-
- let ignore m =
- { iolist = fun s nil cons -> m.iolist s nil (fun _ s next -> cons () s next) }
-
- let lift m =
- { iolist = fun s nil cons -> NonLogical.(m >>= fun x -> cons x s nil) }
-
- (** State related *)
-
- let get =
- { iolist = fun s nil cons -> cons s.sstate s nil }
-
- let set (sstate : P.s) =
- { iolist = fun s nil cons -> cons () { s with sstate } nil }
-
- let modify (f : P.s -> P.s) =
- { iolist = fun s nil cons -> cons () { s with sstate = f s.sstate } nil }
-
- let current =
- { iolist = fun s nil cons -> cons s.rstate s nil }
-
- let local e m =
- { iolist = fun s nil cons ->
- m.iolist { s with rstate = e } nil
- (fun x s' next -> cons x {s' with rstate = s.rstate} next) }
-
- let put w =
- { iolist = fun s nil cons -> cons () { s with wstate = P.wprod s.wstate w } nil }
-
- let update (f : P.u -> P.u) =
- { iolist = fun s nil cons -> cons () { s with ustate = f s.ustate } nil }
-
- (** List observation *)
-
- let once m =
- { iolist = fun s nil cons -> m.iolist s nil (fun x s _ -> cons x s nil) }
-
- let break f m =
- { iolist = fun s nil cons ->
- m.iolist s nil (fun x s next -> cons x s (fun e -> match f e with None -> next e | Some e -> nil e))
- }
-
- (** For [reflect] and [split] see the "Backtracking, Interleaving,
- and Terminating Monad Transformers" paper. *)
- type 'a reified = ('a, rich_exn -> 'a reified) list_view NonLogical.t
-
- let rec reflect (m : ('a * state) reified) : 'a iolist =
- { iolist = fun s0 nil cons ->
- let next = function
- | Nil e -> nil e
- | Cons ((x, s), l) -> cons x s (fun e -> (reflect (l e)).iolist s0 nil cons)
- in
- NonLogical.(m >>= next)
- }
-
- let split m : ('a, rich_exn -> 'a t) list_view t =
- let rnil e = NonLogical.return (Nil e) in
- let rcons p s l = NonLogical.return (Cons ((p, s), l)) in
- { iolist = fun s nil cons ->
- let open NonLogical in
- m.iolist s rnil rcons >>= begin function
- | Nil e -> cons (Nil e) s nil
- | Cons ((x, s), l) ->
- let l e = reflect (l e) in
- cons (Cons (x, l)) s nil
- end }
-
- let run m r s =
- let s = { wstate = P.wunit; ustate = P.uunit; rstate = r; sstate = s } in
- let rnil e = NonLogical.return (Nil e) in
- let rcons x s l =
- let p = (x, s.sstate, s.wstate, s.ustate) in
- NonLogical.return (Cons (p, l))
- in
- m.iolist s rnil rcons
-
- let repr x = x
-
- end
diff --git a/proofs/logic_monad.mli b/proofs/logic_monad.mli
deleted file mode 100644
index 96655d53..00000000
--- a/proofs/logic_monad.mli
+++ /dev/null
@@ -1,162 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* 'a] (i/o) monad. The
- operations are simple wrappers around corresponding usual
- operations and require little documentation. *)
-module NonLogical : sig
-
- include Monad.S
-
- val ignore : 'a t -> unit t
-
- type 'a ref
-
- val ref : 'a -> 'a ref t
- (** [Pervasives.(:=)] *)
- val (:=) : 'a ref -> 'a -> unit t
- (** [Pervasives.(!)] *)
- val (!) : 'a ref -> 'a t
-
- val read_line : string t
- val print_char : char -> unit t
-
- (** Loggers. The buffer is also flushed. *)
- val print_debug : Pp.std_ppcmds -> unit t
- val print_warning : Pp.std_ppcmds -> unit t
- val print_notice : Pp.std_ppcmds -> unit t
- val print_info : Pp.std_ppcmds -> unit t
- val print_error : Pp.std_ppcmds -> unit t
-
- (** [Pervasives.raise]. Except that exceptions are wrapped with
- {!Exception}. *)
- val raise : ?info:Exninfo.info -> exn -> 'a t
- (** [try ... with ...] but restricted to {!Exception}. *)
- val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t
- val timeout : int -> 'a t -> 'a t
-
- (** Construct a monadified side-effect. Exceptions raised by the argument are
- wrapped with {!Exception}. *)
- val make : (unit -> 'a) -> 'a t
-
- (** [run] performs effects. *)
- val run : 'a t -> 'a
-
-end
-
-
-(** {6 Logical layer} *)
-
-(** The logical monad is a backtracking monad on top of which is
- layered a state monad (which is used to implement all of read/write,
- read only, and write only effects). The state monad being layered on
- top of the backtracking monad makes it so that the state is
- backtracked on failure.
-
- Backtracking differs from regular exception in that, writing (+)
- for exception catching and (>>=) for bind, we require the
- following extra distributivity laws:
-
- x+(y+z) = (x+y)+z
-
- zero+x = x
-
- x+zero = x
-
- (x+y)>>=k = (x>>=k)+(y>>=k) *)
-
-(** A view type for the logical monad, which is a form of list, hence
- we can decompose it with as a list. *)
-type ('a, 'b) list_view =
-| Nil of Exninfo.iexn
-| Cons of 'a * 'b
-
-(** The monad is parametrised in the types of state, environment and
- writer. *)
-module type Param = sig
-
- (** Read only *)
- type e
-
- (** Write only *)
- type w
-
- (** [w] must be a monoid *)
- val wunit : w
- val wprod : w -> w -> w
-
- (** Read-write *)
- type s
-
- (** Update-only. Essentially a writer on [u->u]. *)
- type u
-
- (** [u] must be pointed. *)
- val uunit : u
-
-end
-
-module Logical (P:Param) : sig
-
- include Monad.S
-
- val ignore : 'a t -> unit t
-
- val set : P.s -> unit t
- val get : P.s t
- val modify : (P.s -> P.s) -> unit t
- val put : P.w -> unit t
- val current : P.e t
- val local : P.e -> 'a t -> 'a t
- val update : (P.u -> P.u) -> unit t
-
- val zero : Exninfo.iexn -> 'a t
- val plus : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t
- val split : 'a t -> (('a,(Exninfo.iexn->'a t)) list_view) t
- val once : 'a t -> 'a t
- val break : (Exninfo.iexn -> Exninfo.iexn option) -> 'a t -> 'a t
-
- val lift : 'a NonLogical.t -> 'a t
-
- type 'a reified
-
- val repr : 'a reified -> ('a, Exninfo.iexn -> 'a reified) list_view NonLogical.t
-
- val run : 'a t -> P.e -> P.s -> ('a * P.s * P.w * P.u) reified
-
-end
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index b635cc96..eddbf72a 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.ml
@@ -13,6 +13,17 @@ open Entries
open Environ
open Evd
+let use_unification_heuristics_ref = ref true
+let _ = Goptions.declare_bool_option {
+ Goptions.optsync = true; Goptions.optdepr = false;
+ Goptions.optname = "Solve unification constraints at every \".\"";
+ Goptions.optkey = ["Solve";"Unification";"Constraints"];
+ Goptions.optread = (fun () -> !use_unification_heuristics_ref);
+ Goptions.optwrite = (fun a -> use_unification_heuristics_ref:=a);
+}
+
+let use_unification_heuristics () = !use_unification_heuristics_ref
+
let refining = Proof_global.there_are_pending_proofs
let check_no_pending_proofs = Proof_global.check_no_pending_proof
@@ -39,7 +50,7 @@ let cook_this_proof p =
match p with
| { Proof_global.id;entries=[constr];persistence;universes } ->
(id,(constr,universes,persistence))
- | _ -> Errors.anomaly ~label:"Pfedit.cook_proof" (Pp.str "more than one proof term.")
+ | _ -> CErrors.anomaly ~label:"Pfedit.cook_proof" (Pp.str "more than one proof term.")
let cook_proof () =
cook_this_proof (fst
@@ -59,9 +70,9 @@ let get_universe_binders () =
Proof_global.get_universe_binders ()
exception NoSuchGoal
-let _ = Errors.register_handler begin function
- | NoSuchGoal -> Errors.error "No such goal."
- | _ -> raise Errors.Unhandled
+let _ = CErrors.register_handler begin function
+ | NoSuchGoal -> CErrors.error "No such goal."
+ | _ -> raise CErrors.Unhandled
end
let get_nth_V82_goal i =
let p = Proof_global.give_me_the_proof () in
@@ -71,26 +82,38 @@ let get_nth_V82_goal i =
with Failure _ -> raise NoSuchGoal
let get_goal_context_gen i =
- try
-let { it=goal ; sigma=sigma; } = get_nth_V82_goal i in
-(sigma, Refiner.pf_env { it=goal ; sigma=sigma; })
- with Proof_global.NoCurrentProof -> Errors.error "No focused proof."
+ let { it=goal ; sigma=sigma; } = get_nth_V82_goal i in
+ (sigma, Refiner.pf_env { it=goal ; sigma=sigma; })
let get_goal_context i =
try get_goal_context_gen i
- with NoSuchGoal -> Errors.error "No such goal."
+ with Proof_global.NoCurrentProof -> CErrors.error "No focused proof."
+ | NoSuchGoal -> CErrors.error "No such goal."
let get_current_goal_context () =
try get_goal_context_gen 1
- with NoSuchGoal ->
+ with Proof_global.NoCurrentProof -> CErrors.error "No focused proof."
+ | NoSuchGoal ->
(* spiwack: returning empty evar_map, since if there is no goal, under focus,
there is no accessible evar either *)
- (Evd.empty, Global.env ())
+ let env = Global.env () in
+ (Evd.from_env env, env)
+
+let get_current_context () =
+ try get_goal_context_gen 1
+ with Proof_global.NoCurrentProof ->
+ let env = Global.env () in
+ (Evd.from_env env, env)
+ | NoSuchGoal ->
+ (* No more focused goals ? *)
+ let p = get_pftreestate () in
+ let evd = Proof.in_proof p (fun x -> x) in
+ (evd, Global.env ())
let current_proof_statement () =
match Proof_global.V82.get_current_initial_conclusions () with
| (id,([concl],strength)) -> id,strength,concl
- | _ -> Errors.anomaly ~label:"Pfedit.current_proof_statement" (Pp.str "more than one statement")
+ | _ -> CErrors.anomaly ~label:"Pfedit.current_proof_statement" (Pp.str "more than one statement")
let solve ?with_end_tac gi info_lvl tac pr =
try
@@ -103,24 +126,28 @@ let solve ?with_end_tac gi info_lvl tac pr =
in
let tac = match gi with
| Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i tac
+ | Vernacexpr.SelectList l -> Proofview.tclFOCUSLIST l tac
| Vernacexpr.SelectId id -> Proofview.tclFOCUSID id tac
| Vernacexpr.SelectAll -> tac
- | Vernacexpr.SelectAllParallel ->
- Errors.anomaly(str"SelectAllParallel not handled by Stm")
+ in
+ let tac =
+ if use_unification_heuristics () then
+ Proofview.tclTHEN tac Refine.solve_constraints
+ else tac
in
let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in
let () =
match info_lvl with
| None -> ()
- | Some i -> Pp.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info))
+ | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info))
in
(p,status)
with
- | Proof_global.NoCurrentProof -> Errors.error "No focused proof"
+ | Proof_global.NoCurrentProof -> CErrors.error "No focused proof"
| CList.IndexOutOfRange ->
match gi with
| Vernacexpr.SelectNth i -> let msg = str "No such goal: " ++ int i ++ str "." in
- Errors.errorlabstrm "" msg
+ CErrors.errorlabstrm "" msg
| _ -> assert false
let by tac = Proof_global.with_current_proof (fun _ -> solve (Vernacexpr.SelectNth 1) None tac)
@@ -138,22 +165,24 @@ let next = let n = ref 0 in fun () -> incr n; !n
let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac =
let evd = Evd.from_ctx ctx in
- start_proof id goal_kind evd sign typ (fun _ -> ());
+ let terminator = Proof_global.make_terminator (fun _ -> ()) in
+ start_proof id goal_kind evd sign typ terminator;
try
let status = by tac in
let _,(const,univs,_) = cook_proof () in
delete_current_proof ();
const, status, fst univs
with reraise ->
- let reraise = Errors.push reraise in
+ let reraise = CErrors.push reraise in
delete_current_proof ();
iraise reraise
-let build_by_tactic ?(side_eff=true) env ctx ?(poly=false) typ tac =
+let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac =
let id = Id.of_string ("temporary_proof"^string_of_int (next())) in
let sign = val_of_named_context (named_context env) in
let gk = Global, poly, Proof Theorem in
- let ce, status, univs = build_constant_by_tactic id ctx sign ~goal_kind:gk typ tac in
+ let ce, status, univs =
+ build_constant_by_tactic id sigma sign ~goal_kind:gk typ tac in
let ce =
if side_eff then Safe_typing.inline_private_constants_in_definition_entry env ce
else { ce with
@@ -176,7 +205,7 @@ let refine_by_tactic env sigma ty tac =
try Proof.run_tactic env tac prf
with Logic_monad.TacticFailure e as src ->
(** Catch the inner error of the monad tactic *)
- let (_, info) = Errors.push src in
+ let (_, info) = CErrors.push src in
iraise (e, info)
in
(** Plug back the retrieved sigma *)
@@ -203,7 +232,7 @@ let refine_by_tactic env sigma ty tac =
(* Support for resolution of evars in tactic interpretation, including
resolution by application of tactics *)
-let implicit_tactic = ref None
+let implicit_tactic = Summary.ref None ~name:"implicit-tactic"
let declare_implicit_tactic tac = implicit_tactic := Some tac
@@ -214,12 +243,15 @@ let solve_by_implicit_tactic env sigma evk =
match (!implicit_tactic, snd (evar_source evk sigma)) with
| Some tac, (Evar_kinds.ImplicitArg _ | Evar_kinds.QuestionMark _)
when
- Context.named_context_equal (Environ.named_context_of_val evi.evar_hyps)
+ Context.Named.equal (Environ.named_context_of_val evi.evar_hyps)
(Environ.named_context env) ->
- let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (Errors.UserError ("",Pp.str"Proof is not complete."))) []) in
+ let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (CErrors.UserError ("",Pp.str"Proof is not complete."))) []) in
(try
- let (ans, _, _) =
- build_by_tactic env (Evd.evar_universe_context sigma) evi.evar_concl tac in
- ans
+ let c = Evarutil.nf_evars_universes sigma evi.evar_concl in
+ if Evarutil.has_undefined_evars sigma c then raise Exit;
+ let (ans, _, ctx) =
+ build_by_tactic env (Evd.evar_universe_context sigma) c tac in
+ let sigma = Evd.set_universe_context sigma ctx in
+ sigma, ans
with e when Logic.catchable_exception e -> raise Exit)
| _ -> raise Exit
diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli
index cd899201..ea604e08 100644
--- a/proofs/pfedit.mli
+++ b/proofs/pfedit.mli
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Global proof state. A quite redundant wrapper on {!Proof_global}. *)
+
open Loc
open Names
open Term
@@ -93,6 +95,14 @@ val get_goal_context : int -> Evd.evar_map * env
val get_current_goal_context : unit -> Evd.evar_map * env
+(** [get_current_context ()] returns the context of the
+ current focused goal. If there is no focused goal but there
+ is a proof in progress, it returns the corresponding evar_map.
+ If there is no pending proof then it returns the current global
+ environment and empty evar_map. *)
+
+val get_current_context : unit -> Evd.evar_map * env
+
(** [current_proof_statement] *)
val current_proof_statement :
@@ -157,7 +167,8 @@ val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit
val build_constant_by_tactic :
Id.t -> Evd.evar_universe_context -> named_context_val -> ?goal_kind:goal_kind ->
types -> unit Proofview.tactic ->
- Safe_typing.private_constants Entries.definition_entry * bool * Evd.evar_universe_context
+ Safe_typing.private_constants Entries.definition_entry * bool *
+ Evd.evar_universe_context
val build_by_tactic : ?side_eff:bool -> env -> Evd.evar_universe_context -> ?poly:polymorphic ->
types -> unit Proofview.tactic ->
@@ -179,5 +190,4 @@ val declare_implicit_tactic : unit Proofview.tactic -> unit
val clear_implicit_tactic : unit -> unit
(* Raise Exit if cannot solve *)
-(* FIXME: interface: it may incur some new universes etc... *)
-val solve_by_implicit_tactic : env -> Evd.evar_map -> Evd.evar -> constr
+val solve_by_implicit_tactic : env -> Evd.evar_map -> Evd.evar -> Evd.evar_map * constr
diff --git a/proofs/proof.ml b/proofs/proof.ml
index 0489305a..5c963d53 100644
--- a/proofs/proof.ml
+++ b/proofs/proof.ml
@@ -64,17 +64,17 @@ exception NoSuchGoals of int * int
exception FullyUnfocused
-let _ = Errors.register_handler begin function
+let _ = CErrors.register_handler begin function
| CannotUnfocusThisWay ->
- Errors.error "This proof is focused, but cannot be unfocused this way"
+ CErrors.error "This proof is focused, but cannot be unfocused this way"
| NoSuchGoals (i,j) when Int.equal i j ->
- Errors.errorlabstrm "Focus" Pp.(str"No such goal (" ++ int i ++ str").")
+ CErrors.errorlabstrm "Focus" Pp.(str"No such goal (" ++ int i ++ str").")
| NoSuchGoals (i,j) ->
- Errors.errorlabstrm "Focus" Pp.(
+ CErrors.errorlabstrm "Focus" Pp.(
str"Not every goal in range ["++ int i ++ str","++int j++str"] exist."
)
- | FullyUnfocused -> Errors.error "The proof is not focused"
- | _ -> raise Errors.Unhandled
+ | FullyUnfocused -> CErrors.error "The proof is not focused"
+ | _ -> raise CErrors.Unhandled
end
let check_cond_kind c k =
@@ -300,12 +300,12 @@ exception UnfinishedProof
exception HasShelvedGoals
exception HasGivenUpGoals
exception HasUnresolvedEvar
-let _ = Errors.register_handler begin function
- | UnfinishedProof -> Errors.error "Some goals have not been solved."
- | HasShelvedGoals -> Errors.error "Some goals have been left on the shelf."
- | HasGivenUpGoals -> Errors.error "Some goals have been given up."
- | HasUnresolvedEvar -> Errors.error "Some existential variables are uninstantiated."
- | _ -> raise Errors.Unhandled
+let _ = CErrors.register_handler begin function
+ | UnfinishedProof -> CErrors.error "Some goals have not been solved."
+ | HasShelvedGoals -> CErrors.error "Some goals have been left on the shelf."
+ | HasGivenUpGoals -> CErrors.error "Some goals have been given up."
+ | HasUnresolvedEvar -> CErrors.error "Some existential variables are uninstantiated."
+ | _ -> raise CErrors.Unhandled
end
let return p =
@@ -334,21 +334,30 @@ let compact p =
(*** Tactics ***)
let run_tactic env tac pr =
+ let open Proofview.Notations in
let sp = pr.proofview in
- let (_,tacticced_proofview,(status,to_shelve,give_up),info_trace) =
+ let undef sigma l = List.filter (fun g -> Evd.is_undefined sigma g) l in
+ let tac =
+ tac >>= fun () ->
+ Proofview.tclEVARMAP >>= fun sigma ->
+ (* Already solved goals are not to be counted as shelved. Nor are
+ they to be marked as unresolvable. *)
+ let retrieved = undef sigma (List.rev (Evd.future_goals sigma)) in
+ let sigma = List.fold_left Proofview.Unsafe.mark_as_goal sigma retrieved in
+ Proofview.Unsafe.tclEVARS sigma >>= fun () ->
+ Proofview.tclUNIT retrieved
+ in
+ let (retrieved,proofview,(status,to_shelve,give_up),info_trace) =
Proofview.apply env tac sp
in
- let sigma = Proofview.return tacticced_proofview in
- (* Already solved goals are not to be counted as shelved. Nor are
- they to be marked as unresolvable. *)
- let undef l = List.filter (fun g -> Evd.is_undefined sigma g) l in
- let retrieved = undef (List.rev (Evd.future_goals sigma)) in
- let shelf = (undef pr.shelf)@retrieved@(undef to_shelve) in
+ let sigma = Proofview.return proofview in
+ let to_shelve = undef sigma to_shelve in
+ let shelf = (undef sigma pr.shelf)@retrieved@to_shelve in
let proofview =
List.fold_left
- Proofview.Unsafe.mark_as_goal
- tacticced_proofview
- retrieved
+ Proofview.Unsafe.mark_as_unresolvable
+ proofview
+ to_shelve
in
let given_up = pr.given_up@give_up in
let proofview = Proofview.Unsafe.reset_future_goals proofview in
@@ -387,9 +396,27 @@ module V82 = struct
{ p with proofview = Proofview.V82.grab p.proofview }
+ (* Main component of vernac command Existential *)
let instantiate_evar n com pr =
- let sp = pr.proofview in
- let proofview = Proofview.V82.instantiate_evar n com sp in
+ let tac =
+ Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma ->
+ let (evk, evi) =
+ let evl = Evarutil.non_instantiated sigma in
+ let evl = Evar.Map.bindings evl in
+ if (n <= 0) then
+ CErrors.error "incorrect existential variable index"
+ else if CList.length evl < n then
+ CErrors.error "not so many uninstantiated existential variables"
+ else
+ CList.nth evl (n-1)
+ in
+ let env = Evd.evar_filtered_env evi in
+ let rawc = Constrintern.intern_constr env com in
+ let ltac_vars = Pretyping.empty_lvar in
+ let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in
+ Proofview.Unsafe.tclEVARS sigma
+ end in
+ let ((), proofview, _, _) = Proofview.apply (Global.env ()) tac pr.proofview in
let shelf =
List.filter begin fun g ->
Evd.is_undefined (Proofview.return proofview) g
diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml
index f22cdbcc..e753e972 100644
--- a/proofs/proof_global.ml
+++ b/proofs/proof_global.ml
@@ -23,8 +23,9 @@ open Names
(* Type of proof modes :
- A function [set] to set it *from standard mode*
- A function [reset] to reset the *standard mode* from it *)
+type proof_mode_name = string
type proof_mode = {
- name : string ;
+ name : proof_mode_name ;
set : unit -> unit ;
reset : unit -> unit
}
@@ -33,10 +34,10 @@ let proof_modes = Hashtbl.create 6
let find_proof_mode n =
try Hashtbl.find proof_modes n
with Not_found ->
- Errors.error (Format.sprintf "No proof mode named \"%s\"." n)
+ CErrors.error (Format.sprintf "No proof mode named \"%s\"." n)
let register_proof_mode ({name = n} as m) =
- Hashtbl.add proof_modes n (Ephemeron.create m)
+ Hashtbl.add proof_modes n (CEphemeron.create m)
(* initial mode: standard mode *)
let standard = { name = "No" ; set = (fun ()->()) ; reset = (fun () -> ()) }
@@ -45,6 +46,9 @@ let _ = register_proof_mode standard
(* Default proof mode, to be set at the beginning of proofs. *)
let default_proof_mode = ref (find_proof_mode "No")
+let get_default_proof_mode_name () =
+ (CEphemeron.default !default_proof_mode standard).name
+
let _ =
Goptions.declare_string_option {Goptions.
optsync = true ;
@@ -52,7 +56,7 @@ let _ =
optname = "default proof mode" ;
optkey = ["Default";"Proof";"Mode"] ;
optread = begin fun () ->
- (Ephemeron.default !default_proof_mode standard).name
+ (CEphemeron.default !default_proof_mode standard).name
end;
optwrite = begin fun n ->
default_proof_mode := find_proof_mode n
@@ -83,15 +87,18 @@ type closed_proof = proof_object * proof_terminator
type pstate = {
pid : Id.t;
- terminator : proof_terminator Ephemeron.key;
+ terminator : proof_terminator CEphemeron.key;
endline_tactic : Tacexpr.raw_tactic_expr option;
section_vars : Context.section_context option;
proof : Proof.proof;
strength : Decl_kinds.goal_kind;
- mode : proof_mode Ephemeron.key;
+ mode : proof_mode CEphemeron.key;
universe_binders: universe_binders option;
}
+let make_terminator f = f
+let apply_terminator f = f
+
(* The head of [!pstates] is the actual current proof, the other ones are
to be resumed when the current proof is closed or aborted. *)
let pstates = ref ([] : pstate list)
@@ -103,11 +110,11 @@ let current_proof_mode = ref !default_proof_mode
let update_proof_mode () =
match !pstates with
| { mode = m } :: _ ->
- Ephemeron.iter_opt !current_proof_mode (fun x -> x.reset ());
+ CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ());
current_proof_mode := m;
- Ephemeron.iter_opt !current_proof_mode (fun x -> x.set ())
+ CEphemeron.iter_opt !current_proof_mode (fun x -> x.set ())
| _ ->
- Ephemeron.iter_opt !current_proof_mode (fun x -> x.reset ());
+ CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ());
current_proof_mode := find_proof_mode "No"
(* combinators for the current_proof lists *)
@@ -115,15 +122,15 @@ let push a l = l := a::!l;
update_proof_mode ()
exception NoSuchProof
-let _ = Errors.register_handler begin function
- | NoSuchProof -> Errors.error "No such proof."
- | _ -> raise Errors.Unhandled
+let _ = CErrors.register_handler begin function
+ | NoSuchProof -> CErrors.error "No such proof."
+ | _ -> raise CErrors.Unhandled
end
exception NoCurrentProof
-let _ = Errors.register_handler begin function
- | NoCurrentProof -> Errors.error "No focused proof (No proof-editing in progress)."
- | _ -> raise Errors.Unhandled
+let _ = CErrors.register_handler begin function
+ | NoCurrentProof -> CErrors.error "No focused proof (No proof-editing in progress)."
+ | _ -> raise CErrors.Unhandled
end
(*** Proof Global manipulation ***)
@@ -183,7 +190,7 @@ let check_no_pending_proof () =
if not (there_are_pending_proofs ()) then
()
else begin
- Errors.error (Pp.string_of_ppcmds
+ CErrors.error (Pp.string_of_ppcmds
(str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++
str"Use \"Abort All\" first or complete proof(s)."))
end
@@ -195,7 +202,7 @@ let discard (loc,id) =
let n = List.length !pstates in
discard_gen id;
if Int.equal (List.length !pstates) n then
- Errors.user_err_loc
+ CErrors.user_err_loc
(loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs ())
let discard_current () =
@@ -215,9 +222,9 @@ let set_proof_mode mn =
set_proof_mode (find_proof_mode mn) (get_current_proof_name ())
let activate_proof_mode mode =
- Ephemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ())
-let disactivate_proof_mode mode =
- Ephemeron.iter_opt (find_proof_mode mode) (fun x -> x.reset ())
+ CEphemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ())
+let disactivate_current_proof_mode () =
+ CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ())
(** [start_proof sigma id str goals terminator] starts a proof of name
[id] with goals [goals] (a list of pairs of environment and
@@ -230,7 +237,7 @@ let disactivate_proof_mode mode =
let start_proof sigma id ?pl str goals terminator =
let initial_state = {
pid = id;
- terminator = Ephemeron.create terminator;
+ terminator = CEphemeron.create terminator;
proof = Proof.start sigma goals;
endline_tactic = None;
section_vars = None;
@@ -242,7 +249,7 @@ let start_proof sigma id ?pl str goals terminator =
let start_dependent_proof id ?pl str goals terminator =
let initial_state = {
pid = id;
- terminator = Ephemeron.create terminator;
+ terminator = CEphemeron.create terminator;
proof = Proof.dependent_start goals;
endline_tactic = None;
section_vars = None;
@@ -264,18 +271,19 @@ let _ = Goptions.declare_bool_option
Goptions.optwrite = (fun b -> proof_using_auto_clear := b) }
let set_used_variables l =
+ let open Context.Named.Declaration in
let env = Global.env () in
let ids = List.fold_right Id.Set.add l Id.Set.empty in
let ctx = Environ.keep_hyps env ids in
let ctx_set =
- List.fold_right Id.Set.add (List.map pi1 ctx) Id.Set.empty in
+ List.fold_right Id.Set.add (List.map get_id ctx) Id.Set.empty in
let vars_of = Environ.global_vars_set in
let aux env entry (ctx, all_safe, to_clear as orig) =
match entry with
- | (x,None,_) ->
+ | LocalAssum (x,_) ->
if Id.Set.mem x all_safe then orig
else (ctx, all_safe, (Loc.ghost,x)::to_clear)
- | (x,Some bo, ty) as decl ->
+ | LocalDef (x,bo, ty) as decl ->
if Id.Set.mem x all_safe then orig else
let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in
if Id.Set.subset vars all_safe
@@ -288,7 +296,7 @@ let set_used_variables l =
| [] -> raise NoCurrentProof
| p :: rest ->
if not (Option.is_empty p.section_vars) then
- Errors.error "Used section variables can be declared only once";
+ CErrors.error "Used section variables can be declared only once";
pstates := { p with section_vars = Some ctx} :: rest;
ctx, to_clear
@@ -299,6 +307,11 @@ let get_open_goals () =
(List.map (fun (l1,l2) -> List.length l1 + List.length l2) gll) +
List.length shelf
+let constrain_variables init uctx =
+ let levels = Univ.Instance.levels (Univ.UContext.instance init) in
+ let cstrs = UState.constrain_variables levels uctx in
+ Univ.ContextSet.add_constraints cstrs (UState.context_set uctx)
+
let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
let { pid; section_vars; strength; proof; terminator; universe_binders } =
cur_pstate () in
@@ -329,7 +342,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
if keep_body_ucst_separate ||
not (Safe_typing.empty_private_constants = eff) then
let initunivs = Evd.evar_context_universe_context initial_euctx in
- let ctx = Evd.evar_universe_context_set initunivs universes in
+ let ctx = constrain_variables initunivs universes in
(* For vi2vo compilation proofs are computed now but we need to
* complement the univ constraints of the typ with the ones of
* the body. So we keep the two sets distinct. *)
@@ -338,7 +351,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
(initunivs, typ), ((body, ctx_body), eff)
else
let initunivs = Univ.UContext.empty in
- let ctx = Evd.evar_universe_context_set initunivs universes in
+ let ctx = constrain_variables initunivs universes in
(* Since the proof is computed now, we can simply have 1 set of
* constraints in which we merge the ones for the body and the ones
* for the typ *)
@@ -353,7 +366,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
let initunivs = Evd.evar_context_universe_context initial_euctx in
Future.from_val (initunivs, nf t),
Future.chain ~pure:true p (fun (pt,eff) ->
- (pt,Evd.evar_universe_context_set initunivs (Future.force univs)),eff)
+ (pt,constrain_variables initunivs (Future.force univs)),eff)
in
let entries =
Future.map2 (fun p (_, t) ->
@@ -375,7 +388,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
in
{ id = pid; entries = entries; persistence = strength;
universes = (universes, binders) },
- fun pr_ending -> Ephemeron.get terminator pr_ending
+ fun pr_ending -> CEphemeron.get terminator pr_ending
type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context
@@ -395,7 +408,7 @@ let return_proof ?(allow_partial=false) () =
let evd =
let error s =
let prf = str " (in proof " ++ Id.print pid ++ str ")" in
- raise (Errors.UserError("last tactic before Qed",s ++ prf))
+ raise (CErrors.UserError("last tactic before Qed",s ++ prf))
in
try Proof.return proof with
| Proof.UnfinishedProof ->
@@ -423,11 +436,11 @@ let close_proof ~keep_body_ucst_separate fix_exn =
(** Gets the current terminator without checking that the proof has
been completed. Useful for the likes of [Admitted]. *)
-let get_terminator () = Ephemeron.get ( cur_pstate() ).terminator
+let get_terminator () = CEphemeron.get ( cur_pstate() ).terminator
let set_terminator hook =
match !pstates with
| [] -> raise NoCurrentProof
- | p :: ps -> pstates := { p with terminator = Ephemeron.create hook } :: ps
+ | p :: ps -> pstates := { p with terminator = CEphemeron.create hook } :: ps
@@ -458,7 +471,7 @@ module Bullet = struct
type behavior = {
name : string;
put : Proof.proof -> t -> Proof.proof;
- suggest: Proof.proof -> string option
+ suggest: Proof.proof -> std_ppcmds
}
let behaviors = Hashtbl.create 4
@@ -468,7 +481,7 @@ module Bullet = struct
let none = {
name = "None";
put = (fun x _ -> x);
- suggest = (fun _ -> None)
+ suggest = (fun _ -> mt ())
}
let _ = register_behavior none
@@ -484,36 +497,30 @@ module Bullet = struct
(* give a message only if more informative than the standard coq message *)
let suggest_on_solved_goal sugg =
match sugg with
- | NeedClosingBrace -> Some "Try unfocusing with \"}\"."
- | NoBulletInUse -> None
- | ProofFinished -> None
- | Suggest b -> Some ("Focus next goal with bullet "
- ^ Pp.string_of_ppcmds (Pp.(pr_bullet b))
- ^".")
- | Unfinished b -> Some ("The current bullet "
- ^ Pp.string_of_ppcmds (Pp.(pr_bullet b))
- ^ " is unfinished.")
+ | NeedClosingBrace -> str"Try unfocusing with \"}\"."
+ | NoBulletInUse -> mt ()
+ | ProofFinished -> mt ()
+ | Suggest b -> str"Focus next goal with bullet " ++ pr_bullet b ++ str"."
+ | Unfinished b -> str"The current bullet " ++ pr_bullet b ++ str" is unfinished."
(* give always a message. *)
let suggest_on_error sugg =
match sugg with
- | NeedClosingBrace -> "Try unfocusing with \"}\"."
+ | NeedClosingBrace -> str"Try unfocusing with \"}\"."
| NoBulletInUse -> assert false (* This should never raise an error. *)
- | ProofFinished -> "No more subgoals."
- | Suggest b -> ("Bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b))
- ^ " is mandatory here.")
- | Unfinished b -> ("Current bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b))
- ^ " is not finished.")
+ | ProofFinished -> str"No more subgoals."
+ | Suggest b -> str"Bullet " ++ pr_bullet b ++ str" is mandatory here."
+ | Unfinished b -> str"Current bullet " ++ pr_bullet b ++ str" is not finished."
exception FailedBullet of t * suggestion
let _ =
- Errors.register_handler
+ CErrors.register_handler
(function
| FailedBullet (b,sugg) ->
- let prefix = "Wrong bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) ^ " : " in
- Errors.errorlabstrm "Focus" (str prefix ++ str (suggest_on_error sugg))
- | _ -> raise Errors.Unhandled)
+ let prefix = str"Wrong bullet " ++ pr_bullet b ++ str" : " in
+ CErrors.errorlabstrm "Focus" (prefix ++ suggest_on_error sugg)
+ | _ -> raise CErrors.Unhandled)
(* spiwack: we need only one focus kind as we keep a stack of (distinct!) bullets *)
@@ -610,7 +617,7 @@ module Bullet = struct
let _ = register_behavior strict
end
- (* Current bullet behavior, controled by the option *)
+ (* Current bullet behavior, controlled by the option *)
let current_behavior = ref Strict.strict
let _ =
@@ -626,7 +633,7 @@ module Bullet = struct
current_behavior :=
try Hashtbl.find behaviors n
with Not_found ->
- Errors.error ("Unknown bullet behavior: \"" ^ n ^ "\".")
+ CErrors.error ("Unknown bullet behavior: \"" ^ n ^ "\".")
end
}
@@ -657,21 +664,26 @@ let _ =
let default_goal_selector = ref (Vernacexpr.SelectNth 1)
let get_default_goal_selector () = !default_goal_selector
+let print_range_selector (i, j) =
+ if i = j then string_of_int i
+ else string_of_int i ^ "-" ^ string_of_int j
+
let print_goal_selector = function
| Vernacexpr.SelectAll -> "all"
| Vernacexpr.SelectNth i -> string_of_int i
+ | Vernacexpr.SelectList l -> "[" ^
+ String.concat ", " (List.map print_range_selector l) ^ "]"
| Vernacexpr.SelectId id -> Id.to_string id
- | Vernacexpr.SelectAllParallel -> "par"
let parse_goal_selector = function
| "all" -> Vernacexpr.SelectAll
| i ->
- let err_msg = "A selector must be \"all\" or a natural number." in
+ let err_msg = "The default selector must be \"all\" or a natural number." in
begin try
let i = int_of_string i in
- if i < 0 then Errors.error err_msg;
+ if i < 0 then CErrors.error err_msg;
Vernacexpr.SelectNth i
- with Failure _ -> Errors.error err_msg
+ with Failure _ -> CErrors.error err_msg
end
let _ =
@@ -700,7 +712,7 @@ type state = pstate list
let freeze ~marshallable =
match marshallable with
| `Yes ->
- Errors.anomaly (Pp.str"full marshalling of proof state not supported")
+ CErrors.anomaly (Pp.str"full marshalling of proof state not supported")
| `Shallow -> !pstates
| `No -> !pstates
let unfreeze s = pstates := s; update_proof_mode ()
diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli
index 7fbd183e..59daa296 100644
--- a/proofs/proof_global.mli
+++ b/proofs/proof_global.mli
@@ -16,8 +16,9 @@
- A function [reset] to reset the *standard mode* from it
*)
+type proof_mode_name = string
type proof_mode = {
- name : string ;
+ name : proof_mode_name ;
set : unit -> unit ;
reset : unit -> unit
}
@@ -27,6 +28,7 @@ type proof_mode = {
One mode is already registered - the standard mode - named "No",
It corresponds to Coq default setting are they are set when coqtop starts. *)
val register_proof_mode : proof_mode -> unit
+val get_default_proof_mode_name : unit -> proof_mode_name
val there_are_pending_proofs : unit -> bool
val check_no_pending_proof : unit -> unit
@@ -40,7 +42,7 @@ val discard_all : unit -> unit
(** [set_proof_mode] sets the proof mode to be used after it's called. It is
typically called by the Proof Mode command. *)
-val set_proof_mode : string -> unit
+val set_proof_mode : proof_mode_name -> unit
exception NoCurrentProof
val give_me_the_proof : unit -> Proof.proof
@@ -70,9 +72,12 @@ type proof_ending =
| Proved of Vernacexpr.opacity_flag *
(Vernacexpr.lident * Decl_kinds.theorem_kind option) option *
proof_object
-type proof_terminator = proof_ending -> unit
+type proof_terminator
type closed_proof = proof_object * proof_terminator
+val make_terminator : (proof_ending -> unit) -> proof_terminator
+val apply_terminator : proof_terminator -> proof_ending -> unit
+
(** [start_proof id str goals terminator] starts a proof of name [id]
with goals [goals] (a list of pairs of environment and
conclusion); [str] describes what kind of theorem/definition this
@@ -150,8 +155,8 @@ val get_universe_binders : unit -> universe_binders option
(**********************************************************)
-val activate_proof_mode : string -> unit
-val disactivate_proof_mode : string -> unit
+val activate_proof_mode : proof_mode_name -> unit
+val disactivate_current_proof_mode : unit -> unit
(**********************************************************)
(* *)
@@ -169,7 +174,7 @@ module Bullet : sig
type behavior = {
name : string;
put : Proof.proof -> t -> Proof.proof;
- suggest: Proof.proof -> string option
+ suggest: Proof.proof -> Pp.std_ppcmds
}
(** A registered behavior can then be accessed in Coq
@@ -186,7 +191,7 @@ module Bullet : sig
(** Handles focusing/defocusing with bullets:
*)
val put : Proof.proof -> t -> Proof.proof
- val suggest : Proof.proof -> string option
+ val suggest : Proof.proof -> Pp.std_ppcmds
end
diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml
deleted file mode 100644
index dd2c7b25..00000000
--- a/proofs/proof_type.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* goal list sigma
-
-type prim_rule =
- | Cut of bool * bool * Id.t * types
- | FixRule of Id.t * int * (Id.t * int * constr) list * int
- | Cofix of Id.t * (Id.t * constr) list * int
- | Refine of constr
- | Thin of Id.t list
- | Move of Id.t * Id.t move_location
-
-(** Nowadays, the only rules we'll consider are the primitive rules *)
-
-type rule = prim_rule
-
-(** Ltac traces *)
-
-type ltac_call_kind =
- | LtacMLCall of glob_tactic_expr
- | LtacNotationCall of KerName.t
- | LtacNameCall of ltac_constant
- | LtacAtomCall of glob_atomic_tactic_expr
- | LtacVarCall of Id.t * glob_tactic_expr
- | LtacConstrInterp of glob_constr * Pretyping.ltac_var_map
-
-type ltac_trace = (Loc.t * ltac_call_kind) list
-
-let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make ()
diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli
index aa05f58a..c1207962 100644
--- a/proofs/proof_type.mli
+++ b/proofs/proof_type.mli
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Legacy proof engine. Do not use in newly written code. *)
+
open Evd
open Names
open Term
@@ -19,57 +21,12 @@ open Misctypes
type prim_rule =
| Cut of bool * bool * Id.t * types
- | FixRule of Id.t * int * (Id.t * int * constr) list * int
- | Cofix of Id.t * (Id.t * constr) list * int
| Refine of constr
- | Thin of Id.t list
- | Move of Id.t * Id.t move_location
(** Nowadays, the only rules we'll consider are the primitive rules *)
type rule = prim_rule
-(** The type [goal sigma] is the type of subgoal. It has the following form
-{v it = \{ evar_concl = [the conclusion of the subgoal]
- evar_hyps = [the hypotheses of the subgoal]
- evar_body = Evar_Empty;
- evar_info = \{ pgm : [The Realizer pgm if any]
- lc : [Set of evar num occurring in subgoal] \}\}
- sigma = \{ stamp = [an int chardacterizing the ed field, for quick compare]
- ed : [A set of existential variables depending in the subgoal]
- number of first evar,
- it = \{ evar_concl = [the type of first evar]
- evar_hyps = [the context of the evar]
- evar_body = [the body of the Evar if any]
- evar_info = \{ pgm : [Useless ??]
- lc : [Set of evars occurring
- in the type of evar] \} \};
- ...
- number of last evar,
- it = \{ evar_concl = [the type of evar]
- evar_hyps = [the context of the evar]
- evar_body = [the body of the Evar if any]
- evar_info = \{ pgm : [Useless ??]
- lc : [Set of evars occurring
- in the type of evar] \} \} \} v}
-*)
-
type goal = Goal.goal
type tactic = goal sigma -> goal list sigma
-
-(** Ltac traces *)
-
-(** TODO: Move those definitions somewhere sensible *)
-
-type ltac_call_kind =
- | LtacMLCall of glob_tactic_expr
- | LtacNotationCall of KerName.t
- | LtacNameCall of ltac_constant
- | LtacAtomCall of glob_atomic_tactic_expr
- | LtacVarCall of Id.t * glob_tactic_expr
- | LtacConstrInterp of glob_constr * Pretyping.ltac_var_map
-
-type ltac_trace = (Loc.t * ltac_call_kind) list
-
-val ltac_trace_info : ltac_trace Exninfo.t
diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml
index a69645b1..caa9b328 100644
--- a/proofs/proof_using.ml
+++ b/proofs/proof_using.ml
@@ -10,6 +10,7 @@ open Names
open Environ
open Util
open Vernacexpr
+open Context.Named.Declaration
let to_string e =
let rec aux = function
@@ -33,7 +34,8 @@ let in_nameset =
let rec close_fwd e s =
let s' =
- List.fold_left (fun s (id,b,ty) ->
+ List.fold_left (fun s decl ->
+ let (id,b,ty) = Context.Named.Declaration.to_tuple decl in
let vb = Option.(default Id.Set.empty (map (global_vars_set e) b)) in
let vty = global_vars_set e ty in
let vbty = Id.Set.union vb vty in
@@ -61,13 +63,13 @@ and set_of_id env ty id =
Id.Set.union (global_vars_set env ty) acc)
Id.Set.empty ty
else if Id.to_string id = "All" then
- List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty
+ List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty
else if CList.mem_assoc_f Id.equal id !known_names then
process_expr env (CList.assoc_f Id.equal id !known_names) []
else Id.Set.singleton id
and full_set env =
- List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty
+ List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty
let process_expr env e ty =
let ty_expr = SsSingl(Loc.ghost, Id.of_string "Type") in
@@ -126,7 +128,7 @@ let suggest_Proof_using name env vars ids_typ context_ids =
if S.equal all_needed fwd_typ then valid (str "Type*");
if S.equal all all_needed then valid(str "All");
valid (pr_set false needed);
- msg_info (
+ Feedback.msg_info (
str"The proof of "++ str name ++ spc() ++
str "should start with one of the following commands:"++spc()++
v 0 (
diff --git a/proofs/proof_using.mli b/proofs/proof_using.mli
index 1bf38b69..b2c65412 100644
--- a/proofs/proof_using.mli
+++ b/proofs/proof_using.mli
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Utility code for section variables handling in Proof using... *)
+
val process_expr :
Environ.env -> Vernacexpr.section_subset_expr -> Constr.types list ->
Names.Id.t list
diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib
index 32bf5576..804a5436 100644
--- a/proofs/proofs.mllib
+++ b/proofs/proofs.mllib
@@ -2,18 +2,13 @@ Miscprint
Goal
Evar_refiner
Proof_using
-Proof_type
-Proof_errors
-Logic_monad
-Proofview_monad
Logic
-Proofview
+Refine
Proof
Proof_global
Redexpr
Refiner
Tacmach
Pfedit
-Tactic_debug
Clenv
Clenvtac
diff --git a/proofs/proofview.ml b/proofs/proofview.ml
deleted file mode 100644
index a6d9735f..00000000
--- a/proofs/proofview.ml
+++ /dev/null
@@ -1,1257 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* i+1) solution 0 in
- let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in
- let pruned_solution = Evd.drop_all_defined solution in
- let apply_subst_einfo _ ei =
- Evd.({ ei with
- evar_concl = nf ei.evar_concl;
- evar_hyps = Environ.map_named_val nf ei.evar_hyps;
- evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in
- let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in
- let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in
- msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size));
- new_el, { pv with solution = new_solution; }
-
-
-(** {6 Starting and querying a proof view} *)
-
-type telescope =
- | TNil of Evd.evar_map
- | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope)
-
-let dependent_init =
- (* Goals are created with a store which marks them as unresolvable
- for type classes. *)
- let store = Typeclasses.set_resolvable Evd.Store.empty false in
- (* Goals don't have a source location. *)
- let src = (Loc.ghost,Evar_kinds.GoalEvar) in
- (* Main routine *)
- let rec aux = function
- | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] }
- | TCons (env, sigma, typ, t) ->
- let (sigma, econstr ) = Evarutil.new_evar env sigma ~src ~store typ in
- let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in
- let (gl, _) = Term.destEvar econstr in
- let entry = (econstr, typ) :: ret in
- entry, { solution = sol; comb = gl :: comb; shelf = [] }
- in
- fun t ->
- let entry, v = aux t in
- (* The created goal are not to be shelved. *)
- let solution = Evd.reset_future_goals v.solution in
- entry, { v with solution }
-
-let init =
- let rec aux sigma = function
- | [] -> TNil sigma
- | (env,g)::l -> TCons (env,sigma,g,(fun sigma _ -> aux sigma l))
- in
- fun sigma l -> dependent_init (aux sigma l)
-
-let initial_goals initial = initial
-
-let finished = function
- | {comb = []} -> true
- | _ -> false
-
-let return { solution=defs } = defs
-
-let return_constr { solution = defs } c = Evarutil.nf_evar defs c
-
-let partial_proof entry pv = CList.map (return_constr pv) (CList.map fst entry)
-
-
-(** {6 Focusing commands} *)
-
-(** A [focus_context] represents the part of the proof view which has
- been removed by a focusing action, it can be used to unfocus later
- on. *)
-(* First component is a reverse list of the goals which come before
- and second component is the list of the goals which go after (in
- the expected order). *)
-type focus_context = Evar.t list * Evar.t list
-
-
-(** Returns a stylised view of a focus_context for use by, for
- instance, ide-s. *)
-(* spiwack: the type of [focus_context] will change as we push more
- refined functions to ide-s. This would be better than spawning a
- new nearly identical function everytime. Hence the generic name. *)
-(* In this version: the goals in the context, as a "zipper" (the first
- list is in reversed order). *)
-let focus_context f = f
-
-(** This (internal) function extracts a sublist between two indices,
- and returns this sublist together with its context: if it returns
- [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the
- original list. The focused list has lenght [j-i-1] and contains
- the goals from number [i] to number [j] (both included) the first
- goal of the list being numbered [1]. [focus_sublist i j l] raises
- [IndexOutOfRange] if [i > length l], or [j > length l] or [j <
- i]. *)
-let focus_sublist i j l =
- let (left,sub_right) = CList.goto (i-1) l in
- let (sub, right) =
- try CList.chop (j-i+1) sub_right
- with Failure _ -> raise CList.IndexOutOfRange
- in
- (sub, (left,right))
-
-(** Inverse operation to the previous one. *)
-let unfocus_sublist (left,right) s =
- CList.rev_append left (s@right)
-
-
-(** [focus i j] focuses a proofview on the goals from index [i] to
- index [j] (inclusive, goals are indexed from [1]). I.e. goals
- number [i] to [j] become the only focused goals of the returned
- proofview. It returns the focused proofview, and a context for
- the focus stack. *)
-let focus i j sp =
- let (new_comb, context) = focus_sublist i j sp.comb in
- ( { sp with comb = new_comb } , context )
-
-
-(** [advance sigma g] returns [Some g'] if [g'] is undefined and is
- the current avatar of [g] (for instance [g] was changed by [clear]
- into [g']). It returns [None] if [g] has been (partially)
- solved. *)
-(* spiwack: [advance] is probably performance critical, and the good
- behaviour of its definition may depend sensitively to the actual
- definition of [Evd.find]. Currently, [Evd.find] starts looking for
- a value in the heap of undefined variable, which is small. Hence in
- the most common case, where [advance] is applied to an unsolved
- goal ([advance] is used to figure if a side effect has modified the
- goal) it terminates quickly. *)
-let rec advance sigma g =
- let open Evd in
- let evi = Evd.find sigma g in
- match evi.evar_body with
- | Evar_empty -> Some g
- | Evar_defined v ->
- if Option.default false (Store.get evi.evar_extra Evarutil.cleared) then
- let (e,_) = Term.destEvar v in
- advance sigma e
- else
- None
-
-(** [undefined defs l] is the list of goals in [l] which are still
- unsolved (after advancing cleared goals). *)
-let undefined defs l = CList.map_filter (advance defs) l
-
-(** Unfocuses a proofview with respect to a context. *)
-let unfocus c sp =
- { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) }
-
-
-(** {6 The tactic monad} *)
-
-(** - Tactics are objects which apply a transformation to all the
- subgoals of the current view at the same time. By opposition to
- the old vision of applying it to a single goal. It allows tactics
- such as [shelve_unifiable], tactics to reorder the focused goals,
- or global automation tactic for dependent subgoals (instantiating
- an evar has influences on the other goals of the proof in
- progress, not being able to take that into account causes the
- current eauto tactic to fail on some instances where it could
- succeed). Another benefit is that it is possible to write tactics
- that can be executed even if there are no focused goals.
- - Tactics form a monad ['a tactic], in a sense a tactic can be
- seen as a function (without argument) which returns a value of
- type 'a and modifies the environment (in our case: the view).
- Tactics of course have arguments, but these are given at the
- meta-level as OCaml functions. Most tactics in the sense we are
- used to return [()], that is no really interesting values. But
- some might pass information around. The tactics seen in Coq's
- Ltac are (for now at least) only [unit tactic], the return values
- are kept for the OCaml toolkit. The operation or the monad are
- [Proofview.tclUNIT] (which is the "return" of the tactic monad)
- [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN]
- (which is a specialized bind on unit-returning tactics).
- - Tactics have support for full-backtracking. Tactics can be seen
- having multiple success: if after returning the first success a
- failure is encountered, the tactic can backtrack and use a second
- success if available. The state is backtracked to its previous
- value, except the non-logical state defined in the {!NonLogical}
- module below.
-*)
-(* spiwack: as far as I'm aware this doesn't really relate to
- F. Kirchner and C. Muñoz. *)
-
-module Proof = Logical
-
-(** type of tactics:
-
- tactics can
- - access the environment,
- - report unsafe status, shelved goals and given up goals
- - access and change the current [proofview]
- - backtrack on previous changes of the proofview *)
-type +'a tactic = 'a Proof.t
-
-(** Applies a tactic to the current proofview. *)
-let apply env t sp =
- let open Logic_monad in
- let ans = Proof.repr (Proof.run t false (sp,env)) in
- let ans = Logic_monad.NonLogical.run ans in
- match ans with
- | Nil (e, info) -> iraise (TacticFailure e, info)
- | Cons ((r, (state, _), status, info), _) ->
- let (status, gaveup) = status in
- let status = (status, state.shelf, gaveup) in
- let state = { state with shelf = [] } in
- r, state, status, Trace.to_tree info
-
-
-
-(** {7 Monadic primitives} *)
-
-(** Unit of the tactic monad. *)
-let tclUNIT = Proof.return
-
-(** Bind operation of the tactic monad. *)
-let tclBIND = Proof.(>>=)
-
-(** Interpretes the ";" (semicolon) of Ltac. As a monadic operation,
- it's a specialized "bind". *)
-let tclTHEN = Proof.(>>)
-
-(** [tclIGNORE t] has the same operational content as [t], but drops
- the returned value. *)
-let tclIGNORE = Proof.ignore
-
-module Monad = Proof
-
-
-
-(** {7 Failure and backtracking} *)
-
-
-(** [tclZERO e] fails with exception [e]. It has no success. *)
-let tclZERO ?info e =
- let info = match info with
- | None -> Exninfo.null
- | Some info -> info
- in
- Proof.zero (e, info)
-
-(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever
- the successes of [t1] have been depleted and it failed with [e],
- then it behaves as [t2 e]. In other words, [tclOR] inserts a
- backtracking point. *)
-let tclOR = Proof.plus
-
-(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one
- success or [t2 e] if [t1] fails with [e]. It is analogous to
- [try/with] handler of exception in that it is not a backtracking
- point. *)
-let tclORELSE t1 t2 =
- let open Logic_monad in
- let open Proof in
- split t1 >>= function
- | Nil e -> t2 e
- | Cons (a,t1') -> plus (return a) t1'
-
-(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a]
- succeeds at least once then it behaves as [tclBIND a s] otherwise,
- if [a] fails with [e], then it behaves as [f e]. *)
-let tclIFCATCH a s f =
- let open Logic_monad in
- let open Proof in
- split a >>= function
- | Nil e -> f e
- | Cons (x,a') -> plus (s x) (fun e -> (a' e) >>= fun x' -> (s x'))
-
-(** [tclONCE t] behave like [t] except it has at most one success:
- [tclONCE t] stops after the first success of [t]. If [t] fails
- with [e], [tclONCE t] also fails with [e]. *)
-let tclONCE = Proof.once
-
-exception MoreThanOneSuccess
-let _ = Errors.register_handler begin function
- | MoreThanOneSuccess -> Errors.error "This tactic has more than one success."
- | _ -> raise Errors.Unhandled
-end
-
-(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one
- success. Otherwise it fails. The tactic [t] is run until its first
- success, then a failure with exception [e] is simulated. It [t]
- yields another success, then [tclEXACTLY_ONCE e t] fails with
- [MoreThanOneSuccess] (it is a user error). Otherwise,
- [tclEXACTLY_ONCE e t] succeeds with the first success of
- [t]. Notice that the choice of [e] is relevant, as the presence of
- further successes may depend on [e] (see {!tclOR}). *)
-let tclEXACTLY_ONCE e t =
- let open Logic_monad in
- let open Proof in
- split t >>= function
- | Nil (e, info) -> tclZERO ~info e
- | Cons (x,k) ->
- Proof.split (k (e, Exninfo.null)) >>= function
- | Nil _ -> tclUNIT x
- | _ -> tclZERO MoreThanOneSuccess
-
-
-(** [tclCASE t] wraps the {!Proofview_monad.Logical.split} primitive. *)
-type 'a case =
-| Fail of iexn
-| Next of 'a * (iexn -> 'a tactic)
-let tclCASE t =
- let open Logic_monad in
- let map = function
- | Nil e -> Fail e
- | Cons (x, t) -> Next (x, t)
- in
- Proof.map map (Proof.split t)
-
-let tclBREAK = Proof.break
-
-
-
-(** {7 Focusing tactics} *)
-
-exception NoSuchGoals of int
-
-(* This hook returns a string to be appended to the usual message.
- Primarily used to add a suggestion about the right bullet to use to
- focus the next goal, if applicable. *)
-let nosuchgoals_hook:(int -> string option) ref = ref ((fun n -> None))
-let set_nosuchgoals_hook f = nosuchgoals_hook := f
-
-
-
-(* This uses the hook above *)
-let _ = Errors.register_handler begin function
- | NoSuchGoals n ->
- let suffix:string option = (!nosuchgoals_hook) n in
- Errors.errorlabstrm ""
- (str "No such " ++ str (String.plural n "goal") ++ str "."
- ++ pr_opt str suffix)
- | _ -> raise Errors.Unhandled
-end
-
-(** [tclFOCUS_gen nosuchgoal i j t] applies [t] in a context where
- only the goals numbered [i] to [j] are focused (the rest of the goals
- is restored at the end of the tactic). If the range [i]-[j] is not
- valid, then it [tclFOCUS_gen nosuchgoal i j t] is [nosuchgoal]. *)
-let tclFOCUS_gen nosuchgoal i j t =
- let open Proof in
- Pv.get >>= fun initial ->
- try
- let (focused,context) = focus i j initial in
- Pv.set focused >>
- t >>= fun result ->
- Pv.modify (fun next -> unfocus context next) >>
- return result
- with CList.IndexOutOfRange -> nosuchgoal
-
-let tclFOCUS i j t = tclFOCUS_gen (tclZERO (NoSuchGoals (j+1-i))) i j t
-let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t
-
-(** Like {!tclFOCUS} but selects a single goal by name. *)
-let tclFOCUSID id t =
- let open Proof in
- Pv.get >>= fun initial ->
- try
- let ev = Evd.evar_key id initial.solution in
- try
- let n = CList.index Evar.equal ev initial.comb in
- (* goal is already under focus *)
- let (focused,context) = focus n n initial in
- Pv.set focused >>
- t >>= fun result ->
- Pv.modify (fun next -> unfocus context next) >>
- return result
- with Not_found ->
- (* otherwise, save current focus and work purely on the shelve *)
- Comb.set [ev] >>
- t >>= fun result ->
- Comb.set initial.comb >>
- return result
- with Not_found -> tclZERO (NoSuchGoals 1)
-
-(** {7 Dispatching on goals} *)
-
-exception SizeMismatch of int*int
-let _ = Errors.register_handler begin function
- | SizeMismatch (i,_) ->
- let open Pp in
- let errmsg =
- str"Incorrect number of goals" ++ spc() ++
- str"(expected "++int i++str(String.plural i " tactic") ++ str")."
- in
- Errors.errorlabstrm "" errmsg
- | _ -> raise Errors.Unhandled
-end
-
-(** A variant of [Monad.List.iter] where we iter over the focused list
- of goals. The argument tactic is executed in a focus comprising
- only of the current goal, a goal which has been solved by side
- effect is skipped. The generated subgoals are concatenated in
- order. *)
-let iter_goal i =
- let open Proof in
- Comb.get >>= fun initial ->
- Proof.List.fold_left begin fun (subgoals as cur) goal ->
- Solution.get >>= fun step ->
- match advance step goal with
- | None -> return cur
- | Some goal ->
- Comb.set [goal] >>
- i goal >>
- Proof.map (fun comb -> comb :: subgoals) Comb.get
- end [] initial >>= fun subgoals ->
- Solution.get >>= fun evd ->
- Comb.set CList.(undefined evd (flatten (rev subgoals)))
-
-(** A variant of [Monad.List.fold_left2] where the first list is the
- list of focused goals. The argument tactic is executed in a focus
- comprising only of the current goal, a goal which has been solved
- by side effect is skipped. The generated subgoals are concatenated
- in order. *)
-let fold_left2_goal i s l =
- let open Proof in
- Pv.get >>= fun initial ->
- let err =
- return () >>= fun () -> (* Delay the computation of list lengths. *)
- tclZERO (SizeMismatch (CList.length initial.comb,CList.length l))
- in
- Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a ->
- Solution.get >>= fun step ->
- match advance step goal with
- | None -> return cur
- | Some goal ->
- Comb.set [goal] >>
- i goal a r >>= fun r ->
- Proof.map (fun comb -> (r, comb :: subgoals)) Comb.get
- end (s,[]) initial.comb l >>= fun (r,subgoals) ->
- Solution.get >>= fun evd ->
- Comb.set CList.(undefined evd (flatten (rev subgoals))) >>
- return r
-
-(** Dispatch tacticals are used to apply a different tactic to each
- goal under focus. They come in two flavours: [tclDISPATCH] takes a
- list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL]
- takes a list of ['a tactic] and returns an ['a list tactic].
-
- They both work by applying each of the tactic in a focus
- restricted to the corresponding goal (starting with the first
- goal). In the case of [tclDISPATCHL], the tactic returns a list of
- the same size as the argument list (of tactics), each element
- being the result of the tactic executed in the corresponding goal.
-
- When the length of the tactic list is not the number of goal,
- raises [SizeMismatch (g,t)] where [g] is the number of available
- goals, and [t] the number of tactics passed.
-
- [tclDISPATCHGEN join tacs] generalises both functions as the
- successive results of [tacs] are stored in reverse order in a
- list, and [join] is used to convert the result into the expected
- form. *)
-let tclDISPATCHGEN0 join tacs =
- match tacs with
- | [] ->
- begin
- let open Proof in
- Comb.get >>= function
- | [] -> tclUNIT (join [])
- | comb -> tclZERO (SizeMismatch (CList.length comb,0))
- end
- | [tac] ->
- begin
- let open Proof in
- Pv.get >>= function
- | { comb=[goal] ; solution } ->
- begin match advance solution goal with
- | None -> tclUNIT (join [])
- | Some _ -> Proof.map (fun res -> join [res]) tac
- end
- | {comb} -> tclZERO (SizeMismatch(CList.length comb,1))
- end
- | _ ->
- let iter _ t cur = Proof.map (fun y -> y :: cur) t in
- let ans = fold_left2_goal iter [] tacs in
- Proof.map join ans
-
-let tclDISPATCHGEN join tacs =
- let branch t = InfoL.tag (Info.DBranch) t in
- let tacs = CList.map branch tacs in
- InfoL.tag (Info.Dispatch) (tclDISPATCHGEN0 join tacs)
-
-let tclDISPATCH tacs = tclDISPATCHGEN Pervasives.ignore tacs
-
-let tclDISPATCHL tacs = tclDISPATCHGEN CList.rev tacs
-
-
-(** [extend_to_list startxs rx endxs l] builds a list
- [startxs@[rx,...,rx]@endxs] of the same length as [l]. Raises
- [SizeMismatch] if [startxs@endxs] is already longer than [l]. *)
-let extend_to_list startxs rx endxs l =
- (* spiwack: I use [l] essentially as a natural number *)
- let rec duplicate acc = function
- | [] -> acc
- | _::rest -> duplicate (rx::acc) rest
- in
- let rec tail to_match rest =
- match rest, to_match with
- | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *)
- | _::rest , _::to_match -> tail to_match rest
- | _ , [] -> duplicate endxs rest
- in
- let rec copy pref rest =
- match rest,pref with
- | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *)
- | _::rest, a::pref -> a::(copy pref rest)
- | _ , [] -> tail endxs rest
- in
- copy startxs l
-
-(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r]
- tactic is "repeated" enough time such that every goal has a tactic
- assigned to it ([b] is the list of tactics applied to the first
- goals, [e] to the last goals, and [r] is applied to every goal in
- between). *)
-let tclEXTEND tacs1 rtac tacs2 =
- let open Proof in
- Comb.get >>= fun comb ->
- try
- let tacs = extend_to_list tacs1 rtac tacs2 comb in
- tclDISPATCH tacs
- with SizeMismatch _ ->
- tclZERO (SizeMismatch(
- CList.length comb,
- (CList.length tacs1)+(CList.length tacs2)))
-(* spiwack: failure occurs only when the number of goals is too
- small. Hence we can assume that [rtac] is replicated 0 times for
- any error message. *)
-
-(** [tclEXTEND [] tac []]. *)
-let tclINDEPENDENT tac =
- let open Proof in
- Pv.get >>= fun initial ->
- match initial.comb with
- | [] -> tclUNIT ()
- | [_] -> tac
- | _ ->
- let tac = InfoL.tag (Info.DBranch) tac in
- InfoL.tag (Info.Dispatch) (iter_goal (fun _ -> tac))
-
-
-
-(** {7 Goal manipulation} *)
-
-(** Shelves all the goals under focus. *)
-let shelve =
- let open Proof in
- Comb.get >>= fun initial ->
- Comb.set [] >>
- InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >>
- Shelf.modify (fun gls -> gls @ initial)
-
-
-(** [contained_in_info e evi] checks whether the evar [e] appears in
- the hypotheses, the conclusion or the body of the evar_info
- [evi]. Note: since we want to use it on goals, the body is actually
- supposed to be empty. *)
-let contained_in_info sigma e evi =
- Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi))
-
-(** [depends_on sigma src tgt] checks whether the goal [src] appears
- as an existential variable in the definition of the goal [tgt] in
- [sigma]. *)
-let depends_on sigma src tgt =
- let evi = Evd.find sigma tgt in
- contained_in_info sigma src evi
-
-(** [unifiable sigma g l] checks whether [g] appears in another
- subgoal of [l]. The list [l] may contain [g], but it does not
- affect the result. *)
-let unifiable sigma g l =
- CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l
-
-(** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)]
- where [u] is composed of the unifiable goals, i.e. the goals on
- whose definition other goals of [l] depend, and [n] are the
- non-unifiable goals. *)
-let partition_unifiable sigma l =
- CList.partition (fun g -> unifiable sigma g l) l
-
-(** Shelves the unifiable goals under focus, i.e. the goals which
- appear in other goals under focus (the unfocused goals are not
- considered). *)
-let shelve_unifiable =
- let open Proof in
- Pv.get >>= fun initial ->
- let (u,n) = partition_unifiable initial.solution initial.comb in
- Comb.set n >>
- InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >>
- Shelf.modify (fun gls -> gls @ u)
-
-(** [guard_no_unifiable] fails with error [UnresolvedBindings] if some
- goals are unifiable (see {!shelve_unifiable}) in the current focus. *)
-let guard_no_unifiable =
- let open Proof in
- Pv.get >>= fun initial ->
- let (u,n) = partition_unifiable initial.solution initial.comb in
- match u with
- | [] -> tclUNIT ()
- | gls ->
- let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in
- let l = CList.map (fun id -> Names.Name id) l in
- tclZERO (Logic.RefinerError (Logic.UnresolvedBindings l))
-
-(** [unshelve l p] adds all the goals in [l] at the end of the focused
- goals of p *)
-let unshelve l p =
- (* advance the goals in case of clear *)
- let l = undefined p.solution l in
- { p with comb = p.comb@l }
-
-let with_shelf tac =
- let open Proof in
- Pv.get >>= fun pv ->
- let { shelf; solution } = pv in
- Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >>
- tac >>= fun ans ->
- Pv.get >>= fun npv ->
- let { shelf = gls; solution = sigma } = npv in
- let gls' = Evd.future_goals sigma in
- let fgoals = Evd.future_goals solution in
- let pgoal = Evd.principal_future_goal solution in
- let sigma = Evd.restore_future_goals sigma fgoals pgoal in
- Pv.set { npv with shelf; solution = sigma } >>
- tclUNIT (CList.rev_append gls' gls, ans)
-
-(** [goodmod p m] computes the representative of [p] modulo [m] in the
- interval [[0,m-1]].*)
-let goodmod p m =
- let p' = p mod m in
- (* if [n] is negative [n mod l] is negative of absolute value less
- than [l], so [(n mod l)+l] is the representative of [n] in the
- interval [[0,l-1]].*)
- if p' < 0 then p'+m else p'
-
-let cycle n =
- let open Proof in
- InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >>
- Comb.modify begin fun initial ->
- let l = CList.length initial in
- let n' = goodmod n l in
- let (front,rear) = CList.chop n' initial in
- rear@front
- end
-
-let swap i j =
- let open Proof in
- InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >>
- Comb.modify begin fun initial ->
- let l = CList.length initial in
- let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in
- let i = goodmod i l and j = goodmod j l in
- CList.map_i begin fun k x ->
- match k with
- | k when Int.equal k i -> CList.nth initial j
- | k when Int.equal k j -> CList.nth initial i
- | _ -> x
- end 0 initial
- end
-
-let revgoals =
- let open Proof in
- InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >>
- Comb.modify CList.rev
-
-let numgoals =
- let open Proof in
- Comb.get >>= fun comb ->
- return (CList.length comb)
-
-
-
-(** {7 Access primitives} *)
-
-let tclEVARMAP = Solution.get
-
-let tclENV = Env.get
-
-
-
-(** {7 Put-like primitives} *)
-
-
-let emit_side_effects eff x =
- { x with solution = Evd.emit_side_effects eff x.solution }
-
-let tclEFFECTS eff =
- let open Proof in
- return () >>= fun () -> (* The Global.env should be taken at exec time *)
- Env.set (Global.env ()) >>
- Pv.modify (fun initial -> emit_side_effects eff initial)
-
-let mark_as_unsafe = Status.put false
-
-(** Gives up on the goal under focus. Reports an unsafe status. Proofs
- with given up goals cannot be closed. *)
-let give_up =
- let open Proof in
- Comb.get >>= fun initial ->
- Comb.set [] >>
- mark_as_unsafe >>
- InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >>
- Giveup.put initial
-
-
-
-(** {7 Control primitives} *)
-
-
-module Progress = struct
-
- let eq_constr = Evarutil.eq_constr_univs_test
-
- (** equality function on hypothesis contexts *)
- let eq_named_context_val sigma1 sigma2 ctx1 ctx2 =
- let open Environ in
- let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in
- let eq_named_declaration (i1, c1, t1) (i2, c2, t2) =
- Names.Id.equal i1 i2 && Option.equal (eq_constr sigma1 sigma2) c1 c2
- && (eq_constr sigma1 sigma2) t1 t2
- in List.equal eq_named_declaration c1 c2
-
- let eq_evar_body sigma1 sigma2 b1 b2 =
- let open Evd in
- match b1, b2 with
- | Evar_empty, Evar_empty -> true
- | Evar_defined t1, Evar_defined t2 -> eq_constr sigma1 sigma2 t1 t2
- | _ -> false
-
- let eq_evar_info sigma1 sigma2 ei1 ei2 =
- let open Evd in
- eq_constr sigma1 sigma2 ei1.evar_concl ei2.evar_concl &&
- eq_named_context_val sigma1 sigma2 (ei1.evar_hyps) (ei2.evar_hyps) &&
- eq_evar_body sigma1 sigma2 ei1.evar_body ei2.evar_body
-
- (** Equality function on goals *)
- let goal_equal evars1 gl1 evars2 gl2 =
- let evi1 = Evd.find evars1 gl1 in
- let evi2 = Evd.find evars2 gl2 in
- eq_evar_info evars1 evars2 evi1 evi2
-
-end
-
-let tclPROGRESS t =
- let open Proof in
- Pv.get >>= fun initial ->
- t >>= fun res ->
- Pv.get >>= fun final ->
- (* [*_test] test absence of progress. [quick_test] is approximate
- whereas [exhaustive_test] is complete. *)
- let quick_test =
- initial.solution == final.solution && initial.comb == final.comb
- in
- let exhaustive_test =
- Util.List.for_all2eq begin fun i f ->
- Progress.goal_equal initial.solution i final.solution f
- end initial.comb final.comb
- in
- let test =
- quick_test || exhaustive_test
- in
- if not test then
- tclUNIT res
- else
- tclZERO (Errors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress."))
-
-exception Timeout
-let _ = Errors.register_handler begin function
- | Timeout -> Errors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!")
- | _ -> Pervasives.raise Errors.Unhandled
-end
-
-let tclTIMEOUT n t =
- let open Proof in
- (* spiwack: as one of the monad is a continuation passing monad, it
- doesn't force the computation to be threaded inside the underlying
- (IO) monad. Hence I force it myself by asking for the evaluation of
- a dummy value first, lest [timeout] be called when everything has
- already been computed. *)
- let t = Proof.lift (Logic_monad.NonLogical.return ()) >> t in
- Proof.get >>= fun initial ->
- Proof.current >>= fun envvar ->
- Proof.lift begin
- Logic_monad.NonLogical.catch
- begin
- let open Logic_monad.NonLogical in
- timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r ->
- match r with
- | Logic_monad.Nil e -> return (Util.Inr e)
- | Logic_monad.Cons (r, _) -> return (Util.Inl r)
- end
- begin let open Logic_monad.NonLogical in function (e, info) ->
- match e with
- | Logic_monad.Timeout -> return (Util.Inr (Timeout, info))
- | Logic_monad.TacticFailure e ->
- return (Util.Inr (e, info))
- | e -> Logic_monad.NonLogical.raise ~info e
- end
- end >>= function
- | Util.Inl (res,s,m,i) ->
- Proof.set s >>
- Proof.put m >>
- Proof.update (fun _ -> i) >>
- return res
- | Util.Inr (e, info) -> tclZERO ~info e
-
-let tclTIME s t =
- let pr_time t1 t2 n msg =
- let msg =
- if n = 0 then
- str msg
- else
- str (msg ^ " after ") ++ int n ++ str (String.plural n " backtracking")
- in
- msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++
- System.fmt_time_difference t1 t2 ++ str " " ++ surround msg) in
- let rec aux n t =
- let open Proof in
- tclUNIT () >>= fun () ->
- let tstart = System.get_time() in
- Proof.split t >>= let open Logic_monad in function
- | Nil (e, info) ->
- begin
- let tend = System.get_time() in
- pr_time tstart tend n "failure";
- tclZERO ~info e
- end
- | Cons (x,k) ->
- let tend = System.get_time() in
- pr_time tstart tend n "success";
- tclOR (tclUNIT x) (fun e -> aux (n+1) (k e))
- in aux 0 t
-
-
-
-(** {7 Unsafe primitives} *)
-
-module Unsafe = struct
-
- let tclEVARS evd =
- Pv.modify (fun ps -> { ps with solution = evd })
-
- let tclNEWGOALS gls =
- Pv.modify begin fun step ->
- let gls = undefined step.solution gls in
- { step with comb = step.comb @ gls }
- end
-
- let tclGETGOALS = Comb.get
-
- let tclSETGOALS = Comb.set
-
- let tclEVARSADVANCE evd =
- Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb })
-
- let tclEVARUNIVCONTEXT ctx =
- Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx })
-
- let reset_future_goals p =
- { p with solution = Evd.reset_future_goals p.solution }
-
- let mark_as_goal_evm evd content =
- let info = Evd.find evd content in
- let info =
- { info with Evd.evar_source = match info.Evd.evar_source with
- | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x
- | loc,_ -> loc,Evar_kinds.GoalEvar }
- in
- let info = Typeclasses.mark_unresolvable info in
- Evd.add evd content info
-
- let mark_as_goal p gl =
- { p with solution = mark_as_goal_evm p.solution gl }
-
-end
-
-
-
-(** {7 Notations} *)
-
-module Notations = struct
- let (>>=) = tclBIND
- let (<*>) = tclTHEN
- let (<+>) t1 t2 = tclOR t1 (fun _ -> t2)
-end
-
-open Notations
-
-
-
-(** {6 Goal-dependent tactics} *)
-
-(* To avoid shadowing by the local [Goal] module *)
-module GoalV82 = Goal.V82
-
-let catchable_exception = function
- | Logic_monad.Exception _ -> false
- | e -> Errors.noncritical e
-
-
-module Goal = struct
-
- type 'a t = {
- env : Environ.env;
- sigma : Evd.evar_map;
- concl : Term.constr ;
- self : Evar.t ; (* for compatibility with old-style definitions *)
- }
-
- let assume (gl : 'a t) = (gl :> [ `NF ] t)
-
- let env { env=env } = env
- let sigma { sigma=sigma } = sigma
- let hyps { env=env } = Environ.named_context env
- let concl { concl=concl } = concl
- let extra { sigma=sigma; self=self } = Goal.V82.extra sigma self
-
- let raw_concl { concl=concl } = concl
-
-
- let gmake_with info env sigma goal =
- { env = Environ.reset_with_named_context (Evd.evar_filtered_hyps info) env ;
- sigma = sigma ;
- concl = Evd.evar_concl info ;
- self = goal }
-
- let nf_gmake env sigma goal =
- let info = Evarutil.nf_evar_info sigma (Evd.find sigma goal) in
- let sigma = Evd.add sigma goal info in
- gmake_with info env sigma goal , sigma
-
- let nf_enter f =
- InfoL.tag (Info.Dispatch) begin
- iter_goal begin fun goal ->
- Env.get >>= fun env ->
- tclEVARMAP >>= fun sigma ->
- try
- let (gl, sigma) = nf_gmake env sigma goal in
- tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f gl))
- with e when catchable_exception e ->
- let (e, info) = Errors.push e in
- tclZERO ~info e
- end
- end
-
- let normalize { self } =
- Env.get >>= fun env ->
- tclEVARMAP >>= fun sigma ->
- let (gl,sigma) = nf_gmake env sigma self in
- tclTHEN (Unsafe.tclEVARS sigma) (tclUNIT gl)
-
- let gmake env sigma goal =
- let info = Evd.find sigma goal in
- gmake_with info env sigma goal
-
- let enter f =
- let f gl = InfoL.tag (Info.DBranch) (f gl) in
- InfoL.tag (Info.Dispatch) begin
- iter_goal begin fun goal ->
- Env.get >>= fun env ->
- tclEVARMAP >>= fun sigma ->
- try f (gmake env sigma goal)
- with e when catchable_exception e ->
- let (e, info) = Errors.push e in
- tclZERO ~info e
- end
- end
-
- let goals =
- Env.get >>= fun env ->
- Pv.get >>= fun step ->
- let sigma = step.solution in
- let map goal =
- match advance sigma goal with
- | None -> None (** ppedrot: Is this check really necessary? *)
- | Some goal ->
- let gl =
- tclEVARMAP >>= fun sigma ->
- tclUNIT (gmake env sigma goal)
- in
- Some gl
- in
- tclUNIT (CList.map_filter map step.comb)
-
- (* compatibility *)
- let goal { self=self } = self
-
-end
-
-
-
-(** {6 The refine tactic} *)
-
-module Refine =
-struct
-
- let extract_prefix env info =
- let ctx1 = List.rev (Environ.named_context env) in
- let ctx2 = List.rev (Evd.evar_context info) in
- let rec share l1 l2 accu = match l1, l2 with
- | d1 :: l1, d2 :: l2 ->
- if d1 == d2 then share l1 l2 (d1 :: accu)
- else (accu, d2 :: l2)
- | _ -> (accu, l2)
- in
- share ctx1 ctx2 []
-
- let typecheck_evar ev env sigma =
- let info = Evd.find sigma ev in
- (** Typecheck the hypotheses. *)
- let type_hyp (sigma, env) (na, body, t as decl) =
- let evdref = ref sigma in
- let _ = Typing.sort_of env evdref t in
- let () = match body with
- | None -> ()
- | Some body -> Typing.check env evdref body t
- in
- (!evdref, Environ.push_named decl env)
- in
- let (common, changed) = extract_prefix env info in
- let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in
- let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in
- (** Typecheck the conclusion *)
- let evdref = ref sigma in
- let _ = Typing.sort_of env evdref (Evd.evar_concl info) in
- !evdref
-
- let typecheck_proof c concl env sigma =
- let evdref = ref sigma in
- let () = Typing.check env evdref c concl in
- !evdref
-
- let (pr_constrv,pr_constr) =
- Hook.make ~default:(fun _env _sigma _c -> Pp.str"") ()
-
- let refine ?(unsafe = true) f = Goal.enter begin fun gl ->
- let sigma = Goal.sigma gl in
- let env = Goal.env gl in
- let concl = Goal.concl gl in
- (** Save the [future_goals] state to restore them after the
- refinement. *)
- let prev_future_goals = Evd.future_goals sigma in
- let prev_principal_goal = Evd.principal_future_goal sigma in
- (** Create the refinement term *)
- let (sigma, c) = f (Evd.reset_future_goals sigma) in
- let evs = Evd.future_goals sigma in
- let evkmain = Evd.principal_future_goal sigma in
- (** Check that the introduced evars are well-typed *)
- let fold accu ev = typecheck_evar ev env accu in
- let sigma = if unsafe then sigma else CList.fold_left fold sigma evs in
- (** Check that the refined term is typesafe *)
- let sigma = if unsafe then sigma else typecheck_proof c concl env sigma in
- (** Check that the goal itself does not appear in the refined term *)
- let _ =
- if not (Evarutil.occur_evar_upto sigma gl.Goal.self c) then ()
- else Pretype_errors.error_occur_check env sigma gl.Goal.self c
- in
- (** Proceed to the refinement *)
- let sigma = match evkmain with
- | None -> Evd.define gl.Goal.self c sigma
- | Some evk ->
- let id = Evd.evar_ident gl.Goal.self sigma in
- Evd.rename evk id (Evd.define gl.Goal.self c sigma)
- in
- (** Restore the [future goals] state. *)
- let sigma = Evd.restore_future_goals sigma prev_future_goals prev_principal_goal in
- (** Select the goals *)
- let comb = undefined sigma (CList.rev evs) in
- let sigma = CList.fold_left Unsafe.mark_as_goal_evm sigma comb in
- let open Proof in
- InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)))) >>
- Pv.modify (fun ps -> { ps with solution = sigma; comb; })
- end
-
- (** Useful definitions *)
-
- let with_type env evd c t =
- let my_type = Retyping.get_type_of env evd c in
- let j = Environ.make_judge c my_type in
- let (evd,j') =
- Coercion.inh_conv_coerce_to true (Loc.ghost) env evd j t
- in
- evd , j'.Environ.uj_val
-
- let refine_casted ?unsafe f = Goal.enter begin fun gl ->
- let concl = Goal.concl gl in
- let env = Goal.env gl in
- let f h = let (h, c) = f h in with_type env h c concl in
- refine ?unsafe f
- end
-end
-
-
-
-(** {6 Trace} *)
-
-module Trace = struct
-
- let record_info_trace = InfoL.record_trace
-
- let log m = InfoL.leaf (Info.Msg m)
- let name_tactic m t = InfoL.tag (Info.Tactic m) t
-
- let pr_info ?(lvl=0) info =
- assert (lvl >= 0);
- Info.(print (collapse lvl info))
-
-end
-
-
-
-(** {6 Non-logical state} *)
-
-module NonLogical = Logic_monad.NonLogical
-
-let tclLIFT = Proof.lift
-
-let tclCHECKINTERRUPT =
- tclLIFT (NonLogical.make Control.check_for_interrupt)
-
-
-
-
-
-(*** Compatibility layer with <= 8.2 tactics ***)
-module V82 = struct
- type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma
-
- let tactic tac =
- (* spiwack: we ignore the dependencies between goals here,
- expectingly preserving the semantics of <= 8.2 tactics *)
- (* spiwack: convenience notations, waiting for ocaml 3.12 *)
- let open Proof in
- Pv.get >>= fun ps ->
- try
- let tac gl evd =
- let glsigma =
- tac { Evd.it = gl ; sigma = evd; } in
- let sigma = glsigma.Evd.sigma in
- let g = glsigma.Evd.it in
- ( g, sigma )
- in
- (* Old style tactics expect the goals normalized with respect to evars. *)
- let (initgoals,initevd) =
- Evd.Monad.List.map (fun g s -> GoalV82.nf_evar s g) ps.comb ps.solution
- in
- let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in
- let sgs = CList.flatten goalss in
- let sgs = undefined evd sgs in
- InfoL.leaf (Info.Tactic (fun () -> Pp.str"")) >>
- Pv.set { ps with solution = evd; comb = sgs; }
- with e when catchable_exception e ->
- let (e, info) = Errors.push e in
- tclZERO ~info e
-
-
- (* normalises the evars in the goals, and stores the result in
- solution. *)
- let nf_evar_goals =
- Pv.modify begin fun ps ->
- let map g s = GoalV82.nf_evar s g in
- let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in
- { ps with solution = evd; comb = goals; }
- end
-
- let has_unresolved_evar pv =
- Evd.has_undefined pv.solution
-
- (* Main function in the implementation of Grab Existential Variables.*)
- let grab pv =
- let undef = Evd.undefined_map pv.solution in
- let goals = CList.rev_map fst (Evar.Map.bindings undef) in
- { pv with comb = goals }
-
-
-
- (* Returns the open goals of the proofview together with the evar_map to
- interpret them. *)
- let goals { comb = comb ; solution = solution; } =
- { Evd.it = comb ; sigma = solution }
-
- let top_goals initial { solution=solution; } =
- let goals = CList.map (fun (t,_) -> fst (Term.destEvar t)) initial in
- { Evd.it = goals ; sigma=solution; }
-
- let top_evars initial =
- let evars_of_initial (c,_) =
- Evar.Set.elements (Evd.evars_of_term c)
- in
- CList.flatten (CList.map evars_of_initial initial)
-
- let instantiate_evar n com pv =
- let (evk,_) =
- let evl = Evarutil.non_instantiated pv.solution in
- let evl = Evar.Map.bindings evl in
- if (n <= 0) then
- Errors.error "incorrect existential variable index"
- else if CList.length evl < n then
- Errors.error "not so many uninstantiated existential variables"
- else
- CList.nth evl (n-1)
- in
- { pv with
- solution = Evar_refiner.instantiate_pf_com evk com pv.solution }
-
- let of_tactic t gls =
- try
- let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in
- let (_,final,_,_) = apply (GoalV82.env gls.Evd.sigma gls.Evd.it) t init in
- { Evd.sigma = final.solution ; it = final.comb }
- with Logic_monad.TacticFailure e as src ->
- let (_, info) = Errors.push src in
- iraise (e, info)
-
- let put_status = Status.put
-
- let catchable_exception = catchable_exception
-
- let wrap_exceptions f =
- try f ()
- with e when catchable_exception e ->
- let (e, info) = Errors.push e in tclZERO ~info e
-
-end
diff --git a/proofs/proofview.mli b/proofs/proofview.mli
deleted file mode 100644
index 2157459f..00000000
--- a/proofs/proofview.mli
+++ /dev/null
@@ -1,580 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* Goal.goal list * Evd.evar_map
-
-
-(** {6 Starting and querying a proof view} *)
-
-(** Abstract representation of the initial goals of a proof. *)
-type entry
-
-(** Optimize memory consumption *)
-val compact : entry -> proofview -> entry * proofview
-
-(** Initialises a proofview, the main argument is a list of
- environments (including a [named_context] which are used as
- hypotheses) pair with conclusion types, creating accordingly many
- initial goals. Because a proof does not necessarily starts in an
- empty [evar_map] (indeed a proof can be triggered by an incomplete
- pretyping), [init] takes an additional argument to represent the
- initial [evar_map]. *)
-val init : Evd.evar_map -> (Environ.env * Term.types) list -> entry * proofview
-
-(** A [telescope] is a list of environment and conclusion like in
- {!init}, except that each element may depend on the previous
- goals. The telescope passes the goals in the form of a
- [Term.constr] which represents the goal as an [evar]. The
- [evar_map] is threaded in state passing style. *)
-type telescope =
- | TNil of Evd.evar_map
- | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope)
-
-(** Like {!init}, but goals are allowed to be dependent on one
- another. Dependencies between goals is represented with the type
- [telescope] instead of [list]. Note that the first [evar_map] of
- the telescope plays the role of the [evar_map] argument in
- [init]. *)
-val dependent_init : telescope -> entry * proofview
-
-(** [finished pv] is [true] if and only if [pv] is complete. That is,
- if it has an empty list of focused goals. There could still be
- unsolved subgoaled, but they would then be out of focus. *)
-val finished : proofview -> bool
-
-(** Returns the current [evar] state. *)
-val return : proofview -> Evd.evar_map
-
-val partial_proof : entry -> proofview -> constr list
-val initial_goals : entry -> (constr * types) list
-
-
-
-(** {6 Focusing commands} *)
-
-(** A [focus_context] represents the part of the proof view which has
- been removed by a focusing action, it can be used to unfocus later
- on. *)
-type focus_context
-
-(** Returns a stylised view of a focus_context for use by, for
- instance, ide-s. *)
-(* spiwack: the type of [focus_context] will change as we push more
- refined functions to ide-s. This would be better than spawning a
- new nearly identical function everytime. Hence the generic name. *)
-(* In this version: the goals in the context, as a "zipper" (the first
- list is in reversed order). *)
-val focus_context : focus_context -> Goal.goal list * Goal.goal list
-
-(** [focus i j] focuses a proofview on the goals from index [i] to
- index [j] (inclusive, goals are indexed from [1]). I.e. goals
- number [i] to [j] become the only focused goals of the returned
- proofview. It returns the focused proofview, and a context for
- the focus stack. *)
-val focus : int -> int -> proofview -> proofview * focus_context
-
-(** Unfocuses a proofview with respect to a context. *)
-val unfocus : focus_context -> proofview -> proofview
-
-
-(** {6 The tactic monad} *)
-
-(** - Tactics are objects which apply a transformation to all the
- subgoals of the current view at the same time. By opposition to
- the old vision of applying it to a single goal. It allows tactics
- such as [shelve_unifiable], tactics to reorder the focused goals,
- or global automation tactic for dependent subgoals (instantiating
- an evar has influences on the other goals of the proof in
- progress, not being able to take that into account causes the
- current eauto tactic to fail on some instances where it could
- succeed). Another benefit is that it is possible to write tactics
- that can be executed even if there are no focused goals.
- - Tactics form a monad ['a tactic], in a sense a tactic can be
- seen as a function (without argument) which returns a value of
- type 'a and modifies the environment (in our case: the view).
- Tactics of course have arguments, but these are given at the
- meta-level as OCaml functions. Most tactics in the sense we are
- used to return [()], that is no really interesting values. But
- some might pass information around. The tactics seen in Coq's
- Ltac are (for now at least) only [unit tactic], the return values
- are kept for the OCaml toolkit. The operation or the monad are
- [Proofview.tclUNIT] (which is the "return" of the tactic monad)
- [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN]
- (which is a specialized bind on unit-returning tactics).
- - Tactics have support for full-backtracking. Tactics can be seen
- having multiple success: if after returning the first success a
- failure is encountered, the tactic can backtrack and use a second
- success if available. The state is backtracked to its previous
- value, except the non-logical state defined in the {!NonLogical}
- module below.
-*)
-
-
-(** The abstract type of tactics *)
-type +'a tactic
-
-(** Applies a tactic to the current proofview. Returns a tuple
- [a,pv,(b,sh,gu)] where [a] is the return value of the tactic, [pv]
- is the updated proofview, [b] a boolean which is [true] if the
- tactic has not done any action considered unsafe (such as
- admitting a lemma), [sh] is the list of goals which have been
- shelved by the tactic, and [gu] the list of goals on which the
- tactic has given up. In case of multiple success the first one is
- selected. If there is no success, fails with
- {!Logic_monad.TacticFailure}*)
-val apply : Environ.env -> 'a tactic -> proofview -> 'a
- * proofview
- * (bool*Goal.goal list*Goal.goal list)
- * Proofview_monad.Info.tree
-
-(** {7 Monadic primitives} *)
-
-(** Unit of the tactic monad. *)
-val tclUNIT : 'a -> 'a tactic
-
-(** Bind operation of the tactic monad. *)
-val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
-
-(** Interprets the ";" (semicolon) of Ltac. As a monadic operation,
- it's a specialized "bind". *)
-val tclTHEN : unit tactic -> 'a tactic -> 'a tactic
-
-(** [tclIGNORE t] has the same operational content as [t], but drops
- the returned value. *)
-val tclIGNORE : 'a tactic -> unit tactic
-
-(** Generic monadic combinators for tactics. *)
-module Monad : Monad.S with type +'a t = 'a tactic
-
-(** {7 Failure and backtracking} *)
-
-(** [tclZERO e] fails with exception [e]. It has no success. *)
-val tclZERO : ?info:Exninfo.info -> exn -> 'a tactic
-
-(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever
- the successes of [t1] have been depleted and it failed with [e],
- then it behaves as [t2 e]. In other words, [tclOR] inserts a
- backtracking point. *)
-val tclOR : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic
-
-(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one
- success or [t2 e] if [t1] fails with [e]. It is analogous to
- [try/with] handler of exception in that it is not a backtracking
- point. *)
-val tclORELSE : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic
-
-(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a]
- succeeds at least once then it behaves as [tclBIND a s] otherwise,
- if [a] fails with [e], then it behaves as [f e]. *)
-val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (iexn -> 'b tactic) -> 'b tactic
-
-(** [tclONCE t] behave like [t] except it has at most one success:
- [tclONCE t] stops after the first success of [t]. If [t] fails
- with [e], [tclONCE t] also fails with [e]. *)
-val tclONCE : 'a tactic -> 'a tactic
-
-(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one
- success. Otherwise it fails. The tactic [t] is run until its first
- success, then a failure with exception [e] is simulated. It [t]
- yields another success, then [tclEXACTLY_ONCE e t] fails with
- [MoreThanOneSuccess] (it is a user error). Otherwise,
- [tclEXACTLY_ONCE e t] succeeds with the first success of
- [t]. Notice that the choice of [e] is relevant, as the presence of
- further successes may depend on [e] (see {!tclOR}). *)
-exception MoreThanOneSuccess
-val tclEXACTLY_ONCE : exn -> 'a tactic -> 'a tactic
-
-(** [tclCASE t] splits [t] into its first success and a
- continuation. It is the most general primitive to control
- backtracking. *)
-type 'a case =
- | Fail of iexn
- | Next of 'a * (iexn -> 'a tactic)
-val tclCASE : 'a tactic -> 'a case tactic
-
-(** [tclBREAK p t] is a generalization of [tclONCE t]. Instead of
- stopping after the first success, it succeeds like [t] until a
- failure with an exception [e] such that [p e = Some e'] is raised. At
- which point it drops the remaining successes, failing with [e'].
- [tclONCE t] is equivalent to [tclBREAK (fun e -> Some e) t]. *)
-val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic
-
-
-(** {7 Focusing tactics} *)
-
-(** [tclFOCUS i j t] applies [t] after focusing on the goals number
- [i] to [j] (see {!focus}). The rest of the goals is restored after
- the tactic action. If the specified range doesn't correspond to
- existing goals, fails with [NoSuchGoals] (a user error). this
- exception is caught at toplevel with a default message + a hook
- message that can be customized by [set_nosuchgoals_hook] below.
- This hook is used to add a suggestion about bullets when
- applicable. *)
-exception NoSuchGoals of int
-val set_nosuchgoals_hook: (int -> string option) -> unit
-
-val tclFOCUS : int -> int -> 'a tactic -> 'a tactic
-
-(** [tclFOCUSID x t] applies [t] on a (single) focused goal like
- {!tclFOCUS}. The goal is found by its name rather than its
- number.*)
-val tclFOCUSID : Names.Id.t -> 'a tactic -> 'a tactic
-
-(** [tclTRYFOCUS i j t] behaves like {!tclFOCUS}, except that if the
- specified range doesn't correspond to existing goals, behaves like
- [tclUNIT ()] instead of failing. *)
-val tclTRYFOCUS : int -> int -> unit tactic -> unit tactic
-
-
-(** {7 Dispatching on goals} *)
-
-(** Dispatch tacticals are used to apply a different tactic to each
- goal under focus. They come in two flavours: [tclDISPATCH] takes a
- list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL]
- takes a list of ['a tactic] and returns an ['a list tactic].
-
- They both work by applying each of the tactic in a focus
- restricted to the corresponding goal (starting with the first
- goal). In the case of [tclDISPATCHL], the tactic returns a list of
- the same size as the argument list (of tactics), each element
- being the result of the tactic executed in the corresponding goal.
-
- When the length of the tactic list is not the number of goal,
- raises [SizeMismatch (g,t)] where [g] is the number of available
- goals, and [t] the number of tactics passed. *)
-exception SizeMismatch of int*int
-val tclDISPATCH : unit tactic list -> unit tactic
-val tclDISPATCHL : 'a tactic list -> 'a list tactic
-
-(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r]
- tactic is "repeated" enough time such that every goal has a tactic
- assigned to it ([b] is the list of tactics applied to the first
- goals, [e] to the last goals, and [r] is applied to every goal in
- between). *)
-val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic
-
-(** [tclINDEPENDENT tac] runs [tac] on each goal successively, from
- the first one to the last one. Backtracking in one goal is
- independent of backtracking in another. It is equivalent to
- [tclEXTEND [] tac []]. *)
-val tclINDEPENDENT : unit tactic -> unit tactic
-
-
-(** {7 Goal manipulation} *)
-
-(** Shelves all the goals under focus. The goals are placed on the
- shelf for later use (or being solved by side-effects). *)
-val shelve : unit tactic
-
-(** Shelves the unifiable goals under focus, i.e. the goals which
- appear in other goals under focus (the unfocused goals are not
- considered). *)
-val shelve_unifiable : unit tactic
-
-(** [guard_no_unifiable] fails with error [UnresolvedBindings] if some
- goals are unifiable (see {!shelve_unifiable}) in the current focus. *)
-val guard_no_unifiable : unit tactic
-
-(** [unshelve l p] adds all the goals in [l] at the end of the focused
- goals of p *)
-val unshelve : Goal.goal list -> proofview -> proofview
-
-(** [with_shelf tac] executes [tac] and returns its result together with the set
- of goals shelved by [tac]. The current shelf is unchanged. *)
-val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic
-
-(** If [n] is positive, [cycle n] puts the [n] first goal last. If [n]
- is negative, then it puts the [n] last goals first.*)
-val cycle : int -> unit tactic
-
-(** [swap i j] swaps the position of goals number [i] and [j]
- (negative numbers can be used to address goals from the end. Goals
- are indexed from [1]. For simplicity index [0] corresponds to goal
- [1] as well, rather than raising an error. *)
-val swap : int -> int -> unit tactic
-
-(** [revgoals] reverses the list of focused goals. *)
-val revgoals : unit tactic
-
-(** [numgoals] returns the number of goals under focus. *)
-val numgoals : int tactic
-
-
-(** {7 Access primitives} *)
-
-(** [tclEVARMAP] doesn't affect the proof, it returns the current
- [evar_map]. *)
-val tclEVARMAP : Evd.evar_map tactic
-
-(** [tclENV] doesn't affect the proof, it returns the current
- environment. It is not the environment of a particular goal,
- rather the "global" environment of the proof. The goal-wise
- environment is obtained via {!Proofview.Goal.env}. *)
-val tclENV : Environ.env tactic
-
-
-(** {7 Put-like primitives} *)
-
-(** [tclEFFECTS eff] add the effects [eff] to the current state. *)
-val tclEFFECTS : Safe_typing.private_constants -> unit tactic
-
-(** [mark_as_unsafe] declares the current tactic is unsafe. *)
-val mark_as_unsafe : unit tactic
-
-(** Gives up on the goal under focus. Reports an unsafe status. Proofs
- with given up goals cannot be closed. *)
-val give_up : unit tactic
-
-
-(** {7 Control primitives} *)
-
-(** [tclPROGRESS t] checks the state of the proof after [t]. It it is
- identical to the state before, then [tclePROGRESS t] fails, otherwise
- it succeeds like [t]. *)
-val tclPROGRESS : 'a tactic -> 'a tactic
-
-(** Checks for interrupts *)
-val tclCHECKINTERRUPT : unit tactic
-
-exception Timeout
-(** [tclTIMEOUT n t] can have only one success.
- In case of timeout if fails with [tclZERO Timeout]. *)
-val tclTIMEOUT : int -> 'a tactic -> 'a tactic
-
-(** [tclTIME s t] displays time for each atomic call to t, using s as an
- identifying annotation if present *)
-val tclTIME : string option -> 'a tactic -> 'a tactic
-
-(** {7 Unsafe primitives} *)
-
-(** The primitives in the [Unsafe] module should be avoided as much as
- possible, since they can make the proof state inconsistent. They are
- nevertheless helpful, in particular when interfacing the pretyping and
- the proof engine. *)
-module Unsafe : sig
-
- (** [tclEVARS sigma] replaces the current [evar_map] by [sigma]. If
- [sigma] has new unresolved [evar]-s they will not appear as
- goal. If goals have been solved in [sigma] they will still
- appear as unsolved goals. *)
- val tclEVARS : Evd.evar_map -> unit tactic
-
- (** Like {!tclEVARS} but also checks whether goals have been solved. *)
- val tclEVARSADVANCE : Evd.evar_map -> unit tactic
-
- (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently
- being proved, appending them to the list of focused goals. If a
- goal is already solved, it is not added. *)
- val tclNEWGOALS : Goal.goal list -> unit tactic
-
- (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a
- goal is already solved, it is not set. *)
- val tclSETGOALS : Goal.goal list -> unit tactic
-
- (** [tclGETGOALS] returns the list of goals under focus. *)
- val tclGETGOALS : Goal.goal list tactic
-
- (** Sets the evar universe context. *)
- val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> unit tactic
-
- (** Clears the future goals store in the proof view. *)
- val reset_future_goals : proofview -> proofview
-
- (** Give an evar the status of a goal (changes its source location
- and makes it unresolvable for type classes. *)
- val mark_as_goal : proofview -> Evar.t -> proofview
-end
-
-(** {7 Notations} *)
-
-module Notations : sig
-
- (** {!tclBIND} *)
- val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
- (** {!tclTHEN} *)
- val (<*>) : unit tactic -> 'a tactic -> 'a tactic
- (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *)
- val (<+>) : 'a tactic -> 'a tactic -> 'a tactic
-
-end
-
-
-(** {6 Goal-dependent tactics} *)
-
-module Goal : sig
-
- (** The type of goals. The parameter type is a phantom argument indicating
- whether the data contained in the goal has been normalized w.r.t. the
- current sigma. If it is the case, it is flagged [ `NF ]. You may still
- access the un-normalized data using {!assume} if you known you do not rely
- on the assumption of being normalized, at your own risk. *)
- type 'a t
-
- (** Assume that you do not need the goal to be normalized. *)
- val assume : 'a t -> [ `NF ] t
-
- (** Normalises the argument goal. *)
- val normalize : 'a t -> [ `NF ] t tactic
-
- (** [concl], [hyps], [env] and [sigma] given a goal [gl] return
- respectively the conclusion of [gl], the hypotheses of [gl], the
- environment of [gl] (i.e. the global environment and the
- hypotheses) and the current evar map. *)
- val concl : [ `NF ] t -> Term.constr
- val hyps : [ `NF ] t -> Context.named_context
- val env : 'a t -> Environ.env
- val sigma : 'a t -> Evd.evar_map
- val extra : 'a t -> Evd.Store.t
-
- (** Returns the goal's conclusion even if the goal is not
- normalised. *)
- val raw_concl : 'a t -> Term.constr
-
- (** [nf_enter t] applies the goal-dependent tactic [t] in each goal
- independently, in the manner of {!tclINDEPENDENT} except that
- the current goal is also given as an argument to [t]. The goal
- is normalised with respect to evars. *)
- val nf_enter : ([ `NF ] t -> unit tactic) -> unit tactic
-
- (** Like {!nf_enter}, but does not normalize the goal beforehand. *)
- val enter : ([ `LZ ] t -> unit tactic) -> unit tactic
-
- (** Recover the list of current goals under focus, without evar-normalization *)
- val goals : [ `LZ ] t tactic list tactic
-
- (** Compatibility: avoid if possible *)
- val goal : [ `NF ] t -> Evar.t
-
-end
-
-
-(** {6 The refine tactic} *)
-
-module Refine : sig
-
- (** Printer used to print the constr which refine refines. *)
- val pr_constr :
- (Environ.env -> Evd.evar_map -> Term.constr -> Pp.std_ppcmds) Hook.t
-
- (** {7 Refinement primitives} *)
-
- val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * Constr.t) -> unit tactic
- (** In [refine ?unsafe t], [t] is a term with holes under some
- [evar_map] context. The term [t] is used as a partial solution
- for the current goal (refine is a goal-dependent tactic), the
- new holes created by [t] become the new subgoals. Exception
- raised during the interpretation of [t] are caught and result in
- tactic failures. If [unsafe] is [true] (default) [t] is
- type-checked beforehand. *)
-
- (** {7 Helper functions} *)
-
- val with_type : Environ.env -> Evd.evar_map ->
- Term.constr -> Term.types -> Evd.evar_map * Term.constr
- (** [with_type env sigma c t] ensures that [c] is of type [t]
- inserting a coercion if needed. *)
-
- val refine_casted : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map*Constr.t) -> unit tactic
- (** Like {!refine} except the refined term is coerced to the conclusion of the
- current goal. *)
-
-end
-
-
-(** {6 Trace} *)
-
-module Trace : sig
-
- (** [record_info_trace t] behaves like [t] except the [info] trace
- is stored. *)
- val record_info_trace : 'a tactic -> 'a tactic
-
- val log : Proofview_monad.lazy_msg -> unit tactic
- val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic
-
- val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.std_ppcmds
-
-end
-
-
-(** {6 Non-logical state} *)
-
-(** The [NonLogical] module allows the execution of effects (including
- I/O) in tactics (non-logical side-effects are not discarded at
- failures). *)
-module NonLogical : module type of Logic_monad.NonLogical
-
-(** [tclLIFT c] is a tactic which behaves exactly as [c]. *)
-val tclLIFT : 'a NonLogical.t -> 'a tactic
-
-
-(**/**)
-
-(*** Compatibility layer with <= 8.2 tactics ***)
-module V82 : sig
- type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma
- val tactic : tac -> unit tactic
-
- (* normalises the evars in the goals, and stores the result in
- solution. *)
- val nf_evar_goals : unit tactic
-
- val has_unresolved_evar : proofview -> bool
-
- (* Main function in the implementation of Grab Existential Variables.
- Resets the proofview's goals so that it contains all unresolved evars
- (in chronological order of insertion). *)
- val grab : proofview -> proofview
-
- (* Returns the open goals of the proofview together with the evar_map to
- interpret them. *)
- val goals : proofview -> Evar.t list Evd.sigma
-
- val top_goals : entry -> proofview -> Evar.t list Evd.sigma
-
- (* returns the existential variable used to start the proof *)
- val top_evars : entry -> Evd.evar list
-
- (* Implements the Existential command *)
- val instantiate_evar : int -> Constrexpr.constr_expr -> proofview -> proofview
-
- (* Caution: this function loses quite a bit of information. It
- should be avoided as much as possible. It should work as
- expected for a tactic obtained from {!V82.tactic} though. *)
- val of_tactic : 'a tactic -> tac
-
- (* marks as unsafe if the argument is [false] *)
- val put_status : bool -> unit tactic
-
- (* exception for which it is deemed to be safe to transmute into
- tactic failure. *)
- val catchable_exception : exn -> bool
-
- (* transforms every Ocaml (catchable) exception into a failure in
- the monad. *)
- val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic
-end
diff --git a/proofs/proofview_monad.ml b/proofs/proofview_monad.ml
deleted file mode 100644
index e9bc7761..00000000
--- a/proofs/proofview_monad.ml
+++ /dev/null
@@ -1,275 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* { head = a::head ; opened=[] }
- | a::Seq(b,f)::opened -> { head ; opened=Seq(b,a::f)::opened }
- | [] -> assert false
- let leaf a s = close (opn a s)
-
- (** Returning a forest. It is the responsibility of the library
- builder to close all the tags. *)
- (* spiwack: I may want to close the tags instead, to deal with
- interruptions. *)
- let rec mirror f = List.rev_map mirror_tree f
- and mirror_tree (Seq(a,f)) = Seq(a,mirror f)
-
- let to_tree = function
- | { head ; opened=[] } -> mirror head
- | { head ; opened=_::_} -> assert false
-
-end
-
-
-
-(** {6 State types} *)
-
-(** We typically label nodes of [Trace.tree] with messages to
- print. But we don't want to compute the result. *)
-type lazy_msg = unit -> Pp.std_ppcmds
-let pr_lazy_msg msg = msg ()
-
-(** Info trace. *)
-module Info = struct
-
- (** The type of the tags for [info]. *)
- type tag =
- | Msg of lazy_msg (** A simple message *)
- | Tactic of lazy_msg (** A tactic call *)
- | Dispatch (** A call to [tclDISPATCH]/[tclEXTEND] *)
- | DBranch (** A special marker to delimit individual branch of a dispatch. *)
-
- type state = tag Trace.incr
- type tree = tag Trace.forest
-
-
-
- let pr_in_comments m = Pp.(str"(* "++pr_lazy_msg m++str" *)")
-
- let unbranch = function
- | Trace.Seq (DBranch,brs) -> brs
- | _ -> assert false
-
-
- let is_empty_branch = let open Trace in function
- | Seq(DBranch,[]) -> true
- | _ -> false
-
- (** Dispatch with empty branches are (supposed to be) equivalent to
- [idtac] which need not appear, so they are removed from the
- trace. *)
- let dispatch brs =
- let open Trace in
- if CList.for_all is_empty_branch brs then None
- else Some (Seq(Dispatch,brs))
-
- let constr = let open Trace in function
- | Dispatch -> dispatch
- | t -> fun br -> Some (Seq(t,br))
-
- let rec compress_tree = let open Trace in function
- | Seq(t,f) -> constr t (compress f)
- and compress f =
- CList.map_filter compress_tree f
-
- let rec is_empty = let open Trace in function
- | Seq(Dispatch,brs) -> List.for_all is_empty brs
- | Seq(DBranch,br) -> List.for_all is_empty br
- | _ -> false
-
- (** [with_sep] is [true] when [Tactic m] must be printed with a
- trailing semi-colon. *)
- let rec pr_tree with_sep = let open Trace in function
- | Seq (Msg m,[]) -> pr_in_comments m
- | Seq (Tactic m,_) ->
- let tail = if with_sep then Pp.str";" else Pp.mt () in
- Pp.(pr_lazy_msg m ++ tail)
- | Seq (Dispatch,brs) ->
- let tail = if with_sep then Pp.str";" else Pp.mt () in
- Pp.(pr_dispatch brs++tail)
- | Seq (Msg _,_::_) | Seq (DBranch,_) -> assert false
- and pr_dispatch brs =
- let open Pp in
- let brs = List.map unbranch brs in
- match brs with
- | [br] -> pr_forest br
- | _ ->
- let sep () = spc()++str"|"++spc() in
- let branches = prlist_with_sep sep pr_forest brs in
- str"[>"++spc()++branches++spc()++str"]"
- and pr_forest = function
- | [] -> Pp.mt ()
- | [tr] -> pr_tree false tr
- | tr::l -> Pp.(pr_tree true tr ++ pr_forest l)
-
- let print f =
- pr_forest (compress f)
-
- let rec collapse_tree n t =
- let open Trace in
- match n , t with
- | 0 , t -> [t]
- | _ , (Seq(Tactic _,[]) as t) -> [t]
- | n , Seq(Tactic _,f) -> collapse (pred n) f
- | n , Seq(Dispatch,brs) -> [Seq(Dispatch, (collapse n brs))]
- | n , Seq(DBranch,br) -> [Seq(DBranch, (collapse n br))]
- | _ , (Seq(Msg _,_) as t) -> [t]
- and collapse n f =
- CList.map_append (collapse_tree n) f
-end
-
-
-(** Type of proof views: current [evar_map] together with the list of
- focused goals. *)
-type proofview = {
- solution : Evd.evar_map;
- comb : Goal.goal list;
- shelf : Goal.goal list;
-}
-
-(** {6 Instantiation of the logic monad} *)
-
-(** Parameters of the logic monads *)
-module P = struct
-
- type s = proofview * Environ.env
-
- (** Recording info trace (true) or not. *)
- type e = bool
-
- (** Status (safe/unsafe) * shelved goals * given up *)
- type w = bool * Evar.t list
-
- let wunit = true , []
- let wprod (b1, g1) (b2, g2) = b1 && b2 , g1@g2
-
- type u = Info.state
-
- let uunit = Trace.empty_incr
-
-end
-
-module Logical = Logic_monad.Logical(P)
-
-
-(** {6 Lenses to access to components of the states} *)
-
-module type State = sig
- type t
- val get : t Logical.t
- val set : t -> unit Logical.t
- val modify : (t->t) -> unit Logical.t
-end
-
-module type Writer = sig
- type t
- val put : t -> unit Logical.t
-end
-
-module Pv : State with type t := proofview = struct
- let get = Logical.(map fst get)
- let set p = Logical.modify (fun (_,e) -> (p,e))
- let modify f= Logical.modify (fun (p,e) -> (f p,e))
-end
-
-module Solution : State with type t := Evd.evar_map = struct
- let get = Logical.map (fun {solution} -> solution) Pv.get
- let set s = Pv.modify (fun pv -> { pv with solution = s })
- let modify f = Pv.modify (fun pv -> { pv with solution = f pv.solution })
-end
-
-module Comb : State with type t = Evar.t list = struct
- (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *)
- type t = Evar.t list
- let get = Logical.map (fun {comb} -> comb) Pv.get
- let set c = Pv.modify (fun pv -> { pv with comb = c })
- let modify f = Pv.modify (fun pv -> { pv with comb = f pv.comb })
-end
-
-module Env : State with type t := Environ.env = struct
- let get = Logical.(map snd get)
- let set e = Logical.modify (fun (p,_) -> (p,e))
- let modify f = Logical.modify (fun (p,e) -> (p,f e))
-end
-
-module Status : Writer with type t := bool = struct
- let put s = Logical.put (s, [])
-end
-
-module Shelf : State with type t = Evar.t list = struct
- (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *)
- type t = Evar.t list
- let get = Logical.map (fun {shelf} -> shelf) Pv.get
- let set c = Pv.modify (fun pv -> { pv with shelf = c })
- let modify f = Pv.modify (fun pv -> { pv with shelf = f pv.shelf })
-end
-
-module Giveup : Writer with type t = Evar.t list = struct
- (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *)
- type t = Evar.t list
- let put gs = Logical.put (true, gs)
-end
-
-(** Lens and utilies pertaining to the info trace *)
-module InfoL = struct
- let recording = Logical.current
- let if_recording t =
- let open Logical in
- recording >>= fun r ->
- if r then t else return ()
-
- let record_trace t = Logical.local true t
-
- let raw_update = Logical.update
- let update f = if_recording (raw_update f)
- let opn a = update (Trace.opn a)
- let close = update Trace.close
- let leaf a = update (Trace.leaf a)
-
- let tag a t =
- let open Logical in
- recording >>= fun r ->
- if r then begin
- raw_update (Trace.opn a) >>
- t >>= fun a ->
- raw_update Trace.close >>
- return a
- end else
- t
-end
diff --git a/proofs/proofview_monad.mli b/proofs/proofview_monad.mli
deleted file mode 100644
index 7a6ea10f..00000000
--- a/proofs/proofview_monad.mli
+++ /dev/null
@@ -1,148 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* 'a forest
-
- (** [open a] opens a tag with name [a]. *)
- val opn : 'a -> 'a incr -> 'a incr
-
- (** [close] closes the last open tag. It is the responsibility of
- the user to close all the tags. *)
- val close : 'a incr -> 'a incr
-
- (** [leaf] creates an empty tag with name [a]. *)
- val leaf : 'a -> 'a incr -> 'a incr
-
-end
-
-(** {6 State types} *)
-
-(** We typically label nodes of [Trace.tree] with messages to
- print. But we don't want to compute the result. *)
-type lazy_msg = unit -> Pp.std_ppcmds
-
-(** Info trace. *)
-module Info : sig
-
- (** The type of the tags for [info]. *)
- type tag =
- | Msg of lazy_msg (** A simple message *)
- | Tactic of lazy_msg (** A tactic call *)
- | Dispatch (** A call to [tclDISPATCH]/[tclEXTEND] *)
- | DBranch (** A special marker to delimit individual branch of a dispatch. *)
-
- type state = tag Trace.incr
- type tree = tag Trace.forest
-
- val print : tree -> Pp.std_ppcmds
-
- (** [collapse n t] flattens the first [n] levels of [Tactic] in an
- info trace, effectively forgetting about the [n] top level of
- names (if there are fewer, the last name is kept). *)
- val collapse : int -> tree -> tree
-
-end
-
-(** Type of proof views: current [evar_map] together with the list of
- focused goals. *)
-type proofview = {
- solution : Evd.evar_map;
- comb : Goal.goal list;
- shelf : Goal.goal list;
-}
-
-(** {6 Instantiation of the logic monad} *)
-
-module P : sig
- type s = proofview * Environ.env
-
- (** Status (safe/unsafe) * given up *)
- type w = bool * Evar.t list
-
- val wunit : w
- val wprod : w -> w -> w
-
- (** Recording info trace (true) or not. *)
- type e = bool
-
- type u = Info.state
-
- val uunit : u
-end
-
-module Logical : module type of Logic_monad.Logical(P)
-
-
-(** {6 Lenses to access to components of the states} *)
-
-module type State = sig
- type t
- val get : t Logical.t
- val set : t -> unit Logical.t
- val modify : (t->t) -> unit Logical.t
-end
-
-module type Writer = sig
- type t
- val put : t -> unit Logical.t
-end
-
-(** Lens to the [proofview]. *)
-module Pv : State with type t := proofview
-
-(** Lens to the [evar_map] of the proofview. *)
-module Solution : State with type t := Evd.evar_map
-
-(** Lens to the list of focused goals. *)
-module Comb : State with type t = Evar.t list
-
-(** Lens to the global environment. *)
-module Env : State with type t := Environ.env
-
-(** Lens to the tactic status ([true] if safe, [false] if unsafe) *)
-module Status : Writer with type t := bool
-
-(** Lens to the list of goals which have been shelved during the
- execution of the tactic. *)
-module Shelf : State with type t = Evar.t list
-
-(** Lens to the list of goals which were given up during the execution
- of the tactic. *)
-module Giveup : Writer with type t = Evar.t list
-
-(** Lens and utilies pertaining to the info trace *)
-module InfoL : sig
- (** [record_trace t] behaves like [t] and compute its [info] trace. *)
- val record_trace : 'a Logical.t -> 'a Logical.t
-
- val update : (Info.state -> Info.state) -> unit Logical.t
- val opn : Info.tag -> unit Logical.t
- val close : unit Logical.t
- val leaf : Info.tag -> unit Logical.t
-
- (** [tag a t] opens tag [a] runs [t] then closes the tag. *)
- val tag : Info.tag -> 'a Logical.t -> 'a Logical.t
-end
diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml
index ea21917a..72cb05f1 100644
--- a/proofs/redexpr.ml
+++ b/proofs/redexpr.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -17,7 +17,7 @@ open Genredexpr
open Pattern
open Reductionops
open Tacred
-open Closure
+open CClosure
open RedFlags
open Libobject
open Misctypes
@@ -29,17 +29,22 @@ let cbv_vm env sigma c =
error "vm_compute does not support existential variables.";
Vnorm.cbv_vm env c ctyp
+let warn_native_compute_disabled =
+ CWarnings.create ~name:"native-compute-disabled" ~category:"native-compiler"
+ (fun () ->
+ strbrk "native_compute disabled at configure time; falling back to vm_compute.")
+
let cbv_native env sigma c =
if Coq_config.no_native_compiler then
- let () = msg_warning (str "native_compute disabled at configure time; falling back to vm_compute.") in
- cbv_vm env sigma c
+ (warn_native_compute_disabled ();
+ cbv_vm env sigma c)
else
let ctyp = Retyping.get_type_of env sigma c in
Nativenorm.native_norm env sigma c ctyp
let whd_cbn flags env sigma t =
let (state,_) =
- (whd_state_gen true flags env sigma (t,Reductionops.Stack.empty))
+ (whd_state_gen true true flags env sigma (t,Reductionops.Stack.empty))
in Reductionops.Stack.zip ~refold:true state
let strong_cbn flags =
@@ -141,7 +146,9 @@ let make_flag_constant = function
let make_flag env f =
let red = no_red in
let red = if f.rBeta then red_add red fBETA else red in
- let red = if f.rIota then red_add red fIOTA else red in
+ let red = if f.rMatch then red_add red fMATCH else red in
+ let red = if f.rFix then red_add red fFIX else red in
+ let red = if f.rCofix then red_add red fCOFIX else red in
let red = if f.rZeta then red_add red fZETA else red in
let red =
if f.rDelta then (* All but rConst *)
@@ -158,8 +165,6 @@ let make_flag env f =
f.rConst red
in red
-let is_reference = function PRef _ | PVar _ -> true | _ -> false
-
(* table of custom reductino fonctions, not synchronized,
filled via ML calls to [declare_reduction] *)
let reduction_tab = ref String.Map.empty
@@ -196,7 +201,7 @@ let out_arg = function
let out_with_occurrences (occs,c) =
(Locusops.occurrences_map (List.map out_arg) occs, c)
-let e_red f env evm c = evm, f env evm c
+let e_red f = { e_redfun = fun env evm c -> Sigma.here (f env (Sigma.to_evar_map evm) c) evm }
let head_style = false (* Turn to true to have a semantics where simpl
only reduce at the head when an evaluable reference is given, e.g.
@@ -211,6 +216,11 @@ let contextualize f g = function
e_red (contextually b (l,c) (fun _ -> h))
| None -> e_red g
+let warn_simpl_unfolding_modifiers =
+ CWarnings.create ~name:"simpl-unfolding-modifiers" ~category:"tactics"
+ (fun () ->
+ Pp.strbrk "The legacy simpl ignores constant unfolding modifiers.")
+
let reduction_of_red_expr env =
let make_flag = make_flag env in
let rec reduction_of_red_expr = function
@@ -223,7 +233,7 @@ let reduction_of_red_expr env =
let am = if !simplIsCbn then strong_cbn (make_flag f) else simpl in
let () =
if not (!simplIsCbn || List.is_empty f.rConst) then
- Pp.msg_warning (Pp.strbrk "The legacy simpl does not deal with delta flags.") in
+ warn_simpl_unfolding_modifiers () in
(contextualize (if head_style then whd_am else am) am o,DEFAULTcast)
| Cbv f -> (e_red (cbv_norm_flags (make_flag f)),DEFAULTcast)
| Cbn f ->
diff --git a/proofs/redexpr.mli b/proofs/redexpr.mli
index b9191108..d4c2c4a6 100644
--- a/proofs/redexpr.mli
+++ b/proofs/redexpr.mli
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Interpretation layer of redexprs such as hnf, cbv, etc. *)
+
open Names
open Term
open Pattern
diff --git a/proofs/refine.ml b/proofs/refine.ml
new file mode 100644
index 00000000..3f552706
--- /dev/null
+++ b/proofs/refine.ml
@@ -0,0 +1,162 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(*
+ if d1 == d2 then share l1 l2 (d1 :: accu)
+ else (accu, d2 :: l2)
+ | _ -> (accu, l2)
+ in
+ share ctx1 ctx2 []
+
+let typecheck_evar ev env sigma =
+ let info = Evd.find sigma ev in
+ (** Typecheck the hypotheses. *)
+ let type_hyp (sigma, env) decl =
+ let t = get_type decl in
+ let evdref = ref sigma in
+ let _ = Typing.e_sort_of env evdref t in
+ let () = match decl with
+ | LocalAssum _ -> ()
+ | LocalDef (_,body,_) -> Typing.e_check env evdref body t
+ in
+ (!evdref, Environ.push_named decl env)
+ in
+ let (common, changed) = extract_prefix env info in
+ let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in
+ let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in
+ (** Typecheck the conclusion *)
+ let evdref = ref sigma in
+ let _ = Typing.e_sort_of env evdref (Evd.evar_concl info) in
+ !evdref
+
+let typecheck_proof c concl env sigma =
+ let evdref = ref sigma in
+ let () = Typing.e_check env evdref c concl in
+ !evdref
+
+let (pr_constrv,pr_constr) =
+ Hook.make ~default:(fun _env _sigma _c -> Pp.str"") ()
+
+(* Get the side-effect's constant declarations to update the monad's
+ * environmnent *)
+let add_if_undefined kn cb env =
+ try ignore(Environ.lookup_constant kn env); env
+ with Not_found -> Environ.add_constant kn cb env
+
+(* Add the side effects to the monad's environment, if not already done. *)
+let add_side_effect env = function
+ | { Entries.eff = Entries.SEsubproof (kn, cb, eff_env) } ->
+ add_if_undefined kn cb env
+ | { Entries.eff = Entries.SEscheme (l,_) } ->
+ List.fold_left (fun env (_,kn,cb,eff_env) ->
+ add_if_undefined kn cb env) env l
+
+let add_side_effects env effects =
+ List.fold_left (fun env eff -> add_side_effect env eff) env effects
+
+let make_refine_enter ?(unsafe = true) f =
+ { enter = fun gl ->
+ let gl = Proofview.Goal.assume gl in
+ let sigma = Proofview.Goal.sigma gl in
+ let sigma = Sigma.to_evar_map sigma in
+ let env = Proofview.Goal.env gl in
+ let concl = Proofview.Goal.concl gl in
+ (** Save the [future_goals] state to restore them after the
+ refinement. *)
+ let prev_future_goals = Evd.future_goals sigma in
+ let prev_principal_goal = Evd.principal_future_goal sigma in
+ (** Create the refinement term *)
+ let ((v,c), sigma) = Sigma.run (Evd.reset_future_goals sigma) f in
+ let evs = Evd.future_goals sigma in
+ let evkmain = Evd.principal_future_goal sigma in
+ (** Redo the effects in sigma in the monad's env *)
+ let privates_csts = Evd.eval_side_effects sigma in
+ let sideff = Safe_typing.side_effects_of_private_constants privates_csts in
+ let env = add_side_effects env sideff in
+ (** Check that the introduced evars are well-typed *)
+ let fold accu ev = typecheck_evar ev env accu in
+ let sigma = if unsafe then sigma else CList.fold_left fold sigma evs in
+ (** Check that the refined term is typesafe *)
+ let sigma = if unsafe then sigma else typecheck_proof c concl env sigma in
+ (** Check that the goal itself does not appear in the refined term *)
+ let self = Proofview.Goal.goal gl in
+ let _ =
+ if not (Evarutil.occur_evar_upto sigma self c) then ()
+ else Pretype_errors.error_occur_check env sigma self c
+ in
+ (** Proceed to the refinement *)
+ let sigma = match evkmain with
+ | None -> Evd.define self c sigma
+ | Some evk ->
+ let id = Evd.evar_ident self sigma in
+ let sigma = Evd.define self c sigma in
+ match id with
+ | None -> sigma
+ | Some id -> Evd.rename evk id sigma
+ in
+ (** Restore the [future goals] state. *)
+ let sigma = Evd.restore_future_goals sigma prev_future_goals prev_principal_goal in
+ (** Select the goals *)
+ let comb = CList.map_filter (Proofview.Unsafe.advance sigma) (CList.rev evs) in
+ let sigma = CList.fold_left Proofview.Unsafe.mark_as_goal sigma comb in
+ let trace () = Pp.(hov 2 (str"simple refine"++spc()++ Hook.get pr_constrv env sigma c)) in
+ Proofview.Trace.name_tactic trace (Proofview.tclUNIT v) >>= fun v ->
+ Proofview.Unsafe.tclSETENV (Environ.reset_context env) <*>
+ Proofview.Unsafe.tclEVARS sigma <*>
+ Proofview.Unsafe.tclSETGOALS comb <*>
+ Proofview.tclUNIT v
+ }
+
+let refine_one ?(unsafe = true) f =
+ Proofview.Goal.enter_one (make_refine_enter ~unsafe f)
+
+let refine ?(unsafe = true) f =
+ let f = { run = fun sigma -> let Sigma (c,sigma,p) = f.run sigma in Sigma (((),c),sigma,p) } in
+ Proofview.Goal.enter (make_refine_enter ~unsafe f)
+
+(** Useful definitions *)
+
+let with_type env evd c t =
+ let my_type = Retyping.get_type_of env evd c in
+ let j = Environ.make_judge c my_type in
+ let (evd,j') =
+ Coercion.inh_conv_coerce_to true (Loc.ghost) env evd j t
+ in
+ evd , j'.Environ.uj_val
+
+let refine_casted ?unsafe f = Proofview.Goal.enter { enter = begin fun gl ->
+ let gl = Proofview.Goal.assume gl in
+ let concl = Proofview.Goal.concl gl in
+ let env = Proofview.Goal.env gl in
+ let f = { run = fun h ->
+ let Sigma (c, h, p) = f.run h in
+ let sigma, c = with_type env (Sigma.to_evar_map h) c concl in
+ Sigma (c, Sigma.Unsafe.of_evar_map sigma, p)
+ } in
+ refine ?unsafe f
+end }
+
+(** {7 solve_constraints}
+
+ Ensure no remaining unification problems are left. Run at every "." by default. *)
+
+let solve_constraints =
+ let open Proofview in
+ tclENV >>= fun env -> tclEVARMAP >>= fun sigma ->
+ try let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in
+ Unsafe.tclEVARSADVANCE sigma
+ with e -> tclZERO e
diff --git a/proofs/refine.mli b/proofs/refine.mli
new file mode 100644
index 00000000..a44632ef
--- /dev/null
+++ b/proofs/refine.mli
@@ -0,0 +1,50 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* Evd.evar_map -> Term.constr -> Pp.std_ppcmds) Hook.t
+
+(** {7 Refinement primitives} *)
+
+val refine : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic
+(** In [refine ?unsafe t], [t] is a term with holes under some
+ [evar_map] context. The term [t] is used as a partial solution
+ for the current goal (refine is a goal-dependent tactic), the
+ new holes created by [t] become the new subgoals. Exceptions
+ raised during the interpretation of [t] are caught and result in
+ tactic failures. If [unsafe] is [false] (default is [true]) [t] is
+ type-checked beforehand. *)
+
+val refine_one : ?unsafe:bool -> ('a * Constr.t) Sigma.run -> 'a tactic
+(** A generalization of [refine] which assumes exactly one goal under focus *)
+
+(** {7 Helper functions} *)
+
+val with_type : Environ.env -> Evd.evar_map ->
+ Term.constr -> Term.types -> Evd.evar_map * Term.constr
+(** [with_type env sigma c t] ensures that [c] is of type [t]
+ inserting a coercion if needed. *)
+
+val refine_casted : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic
+(** Like {!refine} except the refined term is coerced to the conclusion of the
+ current goal. *)
+
+(** {7 Unification constraint handling} *)
+
+val solve_constraints : unit tactic
+(** Solve any remaining unification problems, applying heuristics. *)
diff --git a/proofs/refiner.ml b/proofs/refiner.ml
index 14493458..ea8543b0 100644
--- a/proofs/refiner.ml
+++ b/proofs/refiner.ml
@@ -7,13 +7,13 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Evd
open Environ
open Proof_type
open Logic
-
+open Context.Named.Declaration
let sig_it x = x.it
let project x = x.sigma
@@ -57,7 +57,7 @@ let tclIDTAC gls = goal_goal_list gls
(* the message printing identity tactic *)
let tclIDTAC_MESSAGE s gls =
- Pp.msg_info (hov 0 s); pp_flush (); tclIDTAC gls
+ Feedback.msg_info (hov 0 s); tclIDTAC gls
(* General failure tactic *)
let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" (str s)
@@ -197,12 +197,12 @@ let tclNOTSAMEGOAL (tac : tactic) goal =
destruct), this is not detected by this tactical. *)
let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma)
:Proof_type.goal list Evd.sigma =
- let oldhyps:Context.named_context = pf_hyps goal in
+ let oldhyps:Context.Named.t = pf_hyps goal in
let rslt:Proof_type.goal list Evd.sigma = tac goal in
let { it = gls; sigma = sigma; } = rslt in
- let hyps:Context.named_context list =
+ let hyps:Context.Named.t list =
List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in
- let cmp (i1, c1, t1) (i2, c2, t2) = Names.Id.equal i1 i2 in
+ let cmp d1 d2 = Names.Id.equal (get_id d1) (get_id d2) in
let newhyps =
List.map
(fun hypl -> List.subtract cmp hypl oldhyps)
@@ -215,12 +215,13 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma)
List.fold_left
(fun acc lh -> acc ^ (if !frst then (frst:=false;"") else " | ")
^ (List.fold_left
- (fun acc (nm,_,_) -> (Names.Id.to_string nm) ^ " " ^ acc)
+ (fun acc d -> (Names.Id.to_string (get_id d)) ^ " " ^ acc)
"" lh))
"" newhyps in
- pp (str (emacs_str "")
+ Feedback.msg_notice
+ (str (emacs_str "")
++ (hov 0 (str s))
- ++ (str (emacs_str "")) ++ fnl());
+ ++ (str (emacs_str "")));
tclIDTAC goal;;
@@ -239,8 +240,8 @@ let tclORELSE0 t1 t2 g =
try
t1 g
with (* Breakpoint *)
- | e when Errors.noncritical e ->
- let e = Errors.push e in catch_failerror e; t2 g
+ | e when CErrors.noncritical e ->
+ let e = CErrors.push e in catch_failerror e; t2 g
(* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress,
then applies t2 *)
@@ -252,8 +253,8 @@ let tclORELSE t1 t2 = tclORELSE0 (tclPROGRESS t1) t2
let tclORELSE_THEN t1 t2then t2else gls =
match
try Some(tclPROGRESS t1 gls)
- with e when Errors.noncritical e ->
- let e = Errors.push e in catch_failerror e; None
+ with e when CErrors.noncritical e ->
+ let e = CErrors.push e in catch_failerror e; None
with
| None -> t2else gls
| Some sgl ->
@@ -283,12 +284,12 @@ let ite_gen tcal tac_if continue tac_else gl=
try
tac_else gl
with
- e' when Errors.noncritical e' -> iraise e in
+ e' when CErrors.noncritical e' -> iraise e in
try
tcal tac_if0 continue gl
with (* Breakpoint *)
- | e when Errors.noncritical e ->
- let e = Errors.push e in catch_failerror e; tac_else0 e gl
+ | e when CErrors.noncritical e ->
+ let e = CErrors.push e in catch_failerror e; tac_else0 e gl
(* Try the first tactic and, if it succeeds, continue with
the second one, and if it fails, use the third one *)
diff --git a/proofs/refiner.mli b/proofs/refiner.mli
index 13a9be59..6dcafb77 100644
--- a/proofs/refiner.mli
+++ b/proofs/refiner.mli
@@ -6,7 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Context
+(** Legacy proof engine. Do not use in newly written code. *)
+
open Evd
open Proof_type
@@ -16,7 +17,7 @@ val sig_it : 'a sigma -> 'a
val project : 'a sigma -> evar_map
val pf_env : goal sigma -> Environ.env
-val pf_hyps : goal sigma -> named_context
+val pf_hyps : goal sigma -> Context.Named.t
val unpackage : 'a sigma -> evar_map ref * 'a
val repackage : evar_map ref -> 'a -> 'a sigma
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml
index a75b6fa0..330594af 100644
--- a/proofs/tacmach.ml
+++ b/proofs/tacmach.ml
@@ -18,6 +18,8 @@ open Tacred
open Proof_type
open Logic
open Refiner
+open Sigma.Notations
+open Context.Named.Declaration
let re_sig it gc = { it = it; sigma = gc; }
@@ -40,21 +42,22 @@ let pf_hyps = Refiner.pf_hyps
let pf_concl gls = Goal.V82.concl (project gls) (sig_it gls)
let pf_hyps_types gls =
let sign = Environ.named_context (pf_env gls) in
- List.map (fun (id,_,x) -> (id, x)) sign
+ List.map (function LocalAssum (id,x)
+ | LocalDef (id,_,x) -> id, x)
+ sign
-let pf_nth_hyp_id gls n = let (id,c,t) = List.nth (pf_hyps gls) (n-1) in id
+let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> get_id
let pf_last_hyp gl = List.hd (pf_hyps gl)
let pf_get_hyp gls id =
try
- Context.lookup_named id (pf_hyps gls)
+ Context.Named.lookup id (pf_hyps gls)
with Not_found ->
raise (RefinerError (NoSuchHyp id))
let pf_get_hyp_typ gls id =
- let (_,_,ty)= (pf_get_hyp gls id) in
- ty
+ pf_get_hyp gls id |> get_type
let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls)
@@ -70,7 +73,10 @@ let pf_get_new_ids ids gls =
let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id
let pf_reduction_of_red_expr gls re c =
- (fst (reduction_of_red_expr (pf_env gls) re)) (pf_env gls) (project gls) c
+ let (redfun, _) = reduction_of_red_expr (pf_env gls) re in
+ let sigma = Sigma.Unsafe.of_evar_map (project gls) in
+ let Sigma (c, sigma, _) = redfun.e_redfun (pf_env gls) sigma c in
+ (Sigma.to_evar_map sigma, c)
let pf_apply f gls = f (pf_env gls) (project gls)
let pf_eapply f gls x =
@@ -78,7 +84,7 @@ let pf_eapply f gls x =
let pf_reduce = pf_apply
let pf_e_reduce = pf_apply
-let pf_whd_betadeltaiota = pf_reduce whd_betadeltaiota
+let pf_whd_all = pf_reduce whd_all
let pf_hnf_constr = pf_reduce hnf_constr
let pf_nf = pf_reduce simpl
let pf_nf_betaiota = pf_reduce (fun _ -> nf_betaiota)
@@ -95,7 +101,7 @@ let pf_const_value = pf_reduce (fun env _ -> constant_value_in env)
let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind
let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind
-let pf_hnf_type_of gls = compose (pf_whd_betadeltaiota gls) (pf_get_type_of gls)
+let pf_hnf_type_of gls = pf_whd_all gls % pf_get_type_of gls
let pf_is_matching = pf_apply Constr_matching.is_matching_conv
let pf_matches = pf_apply Constr_matching.matches_conv
@@ -115,26 +121,11 @@ let internal_cut_rev_no_check replace id t gl =
let refine_no_check c gl =
refiner (Refine c) gl
-(* This does not check dependencies *)
-let thin_no_check ids gl =
- if List.is_empty ids then tclIDTAC gl else refiner (Thin ids) gl
-
-let move_hyp_no_check id1 id2 gl =
- refiner (Move (id1,id2)) gl
-
-let mutual_fix f n others j gl =
- with_check (refiner (FixRule (f,n,others,j))) gl
-
-let mutual_cofix f others j gl =
- with_check (refiner (Cofix (f,others,j))) gl
-
(* Versions with consistency checks *)
let internal_cut b d t = with_check (internal_cut_no_check b d t)
let internal_cut_rev b d t = with_check (internal_cut_rev_no_check b d t)
let refine c = with_check (refine_no_check c)
-let thin c = with_check (thin_no_check c)
-let move_hyp id id' = with_check (move_hyp_no_check id id')
(* Pretty-printers *)
@@ -158,11 +149,15 @@ let pr_glls glls =
(* Variants of [Tacmach] functions built with the new proof engine *)
module New = struct
+ let project gl =
+ let sigma = Proofview.Goal.sigma gl in
+ Sigma.to_evar_map sigma
+
let pf_apply f gl =
- f (Proofview.Goal.env gl) (Proofview.Goal.sigma gl)
+ f (Proofview.Goal.env gl) (project gl)
let of_old f gl =
- f { Evd.it = Proofview.Goal.goal gl ; sigma = Proofview.Goal.sigma gl }
+ f { Evd.it = Proofview.Goal.goal gl ; sigma = project gl; }
let pf_global id gl =
(** We only check for the existence of an [id] in [hyps] *)
@@ -176,6 +171,9 @@ module New = struct
let pf_unsafe_type_of gl t =
pf_apply unsafe_type_of gl t
+ let pf_get_type_of gl t =
+ pf_apply (Retyping.get_type_of ~lax:true) gl t
+
let pf_type_of gl t =
pf_apply type_of gl t
@@ -192,34 +190,35 @@ module New = struct
next_ident_away id ids
let pf_get_hyp id gl =
- let hyps = Proofview.Goal.hyps gl in
+ let hyps = Proofview.Goal.env gl in
let sign =
- try Context.lookup_named id hyps
+ try Environ.lookup_named id hyps
with Not_found -> raise (RefinerError (NoSuchHyp id))
in
sign
let pf_get_hyp_typ id gl =
- let (_,_,ty) = pf_get_hyp id gl in
- ty
+ pf_get_hyp id gl |> get_type
let pf_hyps_types gl =
let env = Proofview.Goal.env gl in
let sign = Environ.named_context env in
- List.map (fun (id,_,x) -> (id, x)) sign
+ List.map (function LocalAssum (id,x)
+ | LocalDef (id,_,x) -> id, x)
+ sign
let pf_last_hyp gl =
let hyps = Proofview.Goal.hyps gl in
List.hd hyps
- let pf_nf_concl (gl : [ `LZ ] Proofview.Goal.t) =
+ let pf_nf_concl (gl : ([ `LZ ], 'r) Proofview.Goal.t) =
(** We normalize the conclusion just after *)
let gl = Proofview.Goal.assume gl in
let concl = Proofview.Goal.concl gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = project gl in
nf_evar sigma concl
- let pf_whd_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t
+ let pf_whd_all gl t = pf_apply whd_all gl t
let pf_get_type_of gl t = pf_apply Retyping.get_type_of gl t
@@ -228,13 +227,13 @@ module New = struct
let pf_hnf_constr gl t = pf_apply hnf_constr gl t
let pf_hnf_type_of gl t =
- pf_whd_betadeltaiota gl (pf_get_type_of gl t)
+ pf_whd_all gl (pf_get_type_of gl t)
let pf_matches gl pat t = pf_apply Constr_matching.matches_conv gl pat t
- let pf_whd_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t
+ let pf_whd_all gl t = pf_apply whd_all gl t
let pf_compute gl t = pf_apply compute gl t
- let pf_nf_evar gl t = nf_evar (Proofview.Goal.sigma gl) t
+ let pf_nf_evar gl t = nf_evar (project gl) t
end
diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli
index 7e943cb1..59f296f6 100644
--- a/proofs/tacmach.mli
+++ b/proofs/tacmach.mli
@@ -8,7 +8,6 @@
open Names
open Term
-open Context
open Environ
open Evd
open Proof_type
@@ -34,18 +33,18 @@ val apply_sig_tac :
val pf_concl : goal sigma -> types
val pf_env : goal sigma -> env
-val pf_hyps : goal sigma -> named_context
+val pf_hyps : goal sigma -> Context.Named.t
(*i val pf_untyped_hyps : goal sigma -> (Id.t * constr) list i*)
val pf_hyps_types : goal sigma -> (Id.t * types) list
val pf_nth_hyp_id : goal sigma -> int -> Id.t
-val pf_last_hyp : goal sigma -> named_declaration
+val pf_last_hyp : goal sigma -> Context.Named.Declaration.t
val pf_ids_of_hyps : goal sigma -> Id.t list
val pf_global : goal sigma -> Id.t -> constr
val pf_unsafe_type_of : goal sigma -> constr -> types
val pf_type_of : goal sigma -> constr -> evar_map * types
val pf_hnf_type_of : goal sigma -> constr -> types
-val pf_get_hyp : goal sigma -> Id.t -> named_declaration
+val pf_get_hyp : goal sigma -> Id.t -> Context.Named.Declaration.t
val pf_get_hyp_typ : goal sigma -> Id.t -> types
val pf_get_new_id : Id.t -> goal sigma -> Id.t
@@ -64,7 +63,7 @@ val pf_e_reduce :
(env -> evar_map -> constr -> evar_map * constr) ->
goal sigma -> constr -> evar_map * constr
-val pf_whd_betadeltaiota : goal sigma -> constr -> constr
+val pf_whd_all : goal sigma -> constr -> constr
val pf_hnf_constr : goal sigma -> constr -> constr
val pf_nf : goal sigma -> constr -> constr
val pf_nf_betaiota : goal sigma -> constr -> constr
@@ -87,18 +86,12 @@ val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool
val refiner : rule -> tactic
val internal_cut_no_check : bool -> Id.t -> types -> tactic
val refine_no_check : constr -> tactic
-val thin_no_check : Id.t list -> tactic
-val mutual_fix :
- Id.t -> int -> (Id.t * int * constr) list -> int -> tactic
-val mutual_cofix : Id.t -> (Id.t * constr) list -> int -> tactic
(** {6 The most primitive tactics with consistency and type checking } *)
val internal_cut : bool -> Id.t -> types -> tactic
val internal_cut_rev : bool -> Id.t -> types -> tactic
val refine : constr -> tactic
-val thin : Id.t list -> tactic
-val move_hyp : Id.t -> Id.t move_location -> tactic
(** {6 Pretty-printing functions (debug only). } *)
val pr_gls : goal sigma -> Pp.std_ppcmds
@@ -106,36 +99,47 @@ val pr_glls : goal list sigma -> Pp.std_ppcmds
(* Variants of [Tacmach] functions built with the new proof engine *)
module New : sig
- val pf_apply : (env -> evar_map -> 'a) -> 'b Proofview.Goal.t -> 'a
- val pf_global : identifier -> 'a Proofview.Goal.t -> constr
- val of_old : (Proof_type.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a
+ val pf_apply : (env -> evar_map -> 'a) -> ('b, 'r) Proofview.Goal.t -> 'a
+ val pf_global : identifier -> ('a, 'r) Proofview.Goal.t -> constr
+ (** FIXME: encapsulate the level in an existential type. *)
+ val of_old : (Proof_type.goal Evd.sigma -> 'a) -> ([ `NF ], 'r) Proofview.Goal.t -> 'a
- val pf_env : 'a Proofview.Goal.t -> Environ.env
- val pf_concl : [ `NF ] Proofview.Goal.t -> types
+ val project : ('a, 'r) Proofview.Goal.t -> Evd.evar_map
+ val pf_env : ('a, 'r) Proofview.Goal.t -> Environ.env
+ val pf_concl : ([ `NF ], 'r) Proofview.Goal.t -> types
- val pf_unsafe_type_of : 'a Proofview.Goal.t -> Term.constr -> Term.types
- val pf_type_of : 'a Proofview.Goal.t -> Term.constr -> evar_map * Term.types
- val pf_conv_x : 'a Proofview.Goal.t -> Term.constr -> Term.constr -> bool
+ (** WRONG: To be avoided at all costs, it typechecks the term entirely but
+ forgets the universe constraints necessary to retypecheck it *)
+ val pf_unsafe_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.types
- val pf_get_new_id : identifier -> [ `NF ] Proofview.Goal.t -> identifier
- val pf_ids_of_hyps : 'a Proofview.Goal.t -> identifier list
- val pf_hyps_types : 'a Proofview.Goal.t -> (identifier * types) list
+ (** This function does no type inference and expects an already well-typed term.
+ It recomputes its type in the fastest way possible (no conversion is ever involved) *)
+ val pf_get_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.types
- val pf_get_hyp : identifier -> [ `NF ] Proofview.Goal.t -> named_declaration
- val pf_get_hyp_typ : identifier -> [ `NF ] Proofview.Goal.t -> types
- val pf_last_hyp : [ `NF ] Proofview.Goal.t -> named_declaration
+ (** This function entirely type-checks the term and computes its type
+ and the implied universe constraints. *)
+ val pf_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> evar_map * Term.types
+ val pf_conv_x : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.constr -> bool
- val pf_nf_concl : [ `LZ ] Proofview.Goal.t -> types
- val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> pinductive * types
+ val pf_get_new_id : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> identifier
+ val pf_ids_of_hyps : ('a, 'r) Proofview.Goal.t -> identifier list
+ val pf_hyps_types : ('a, 'r) Proofview.Goal.t -> (identifier * types) list
- val pf_hnf_constr : 'a Proofview.Goal.t -> constr -> types
- val pf_hnf_type_of : 'a Proofview.Goal.t -> constr -> types
+ val pf_get_hyp : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> Context.Named.Declaration.t
+ val pf_get_hyp_typ : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> types
+ val pf_last_hyp : ([ `NF ], 'r) Proofview.Goal.t -> Context.Named.Declaration.t
- val pf_whd_betadeltaiota : 'a Proofview.Goal.t -> constr -> constr
- val pf_compute : 'a Proofview.Goal.t -> constr -> constr
+ val pf_nf_concl : ([ `LZ ], 'r) Proofview.Goal.t -> types
+ val pf_reduce_to_quantified_ind : ('a, 'r) Proofview.Goal.t -> types -> pinductive * types
- val pf_matches : 'a Proofview.Goal.t -> constr_pattern -> constr -> patvar_map
+ val pf_hnf_constr : ('a, 'r) Proofview.Goal.t -> constr -> types
+ val pf_hnf_type_of : ('a, 'r) Proofview.Goal.t -> constr -> types
- val pf_nf_evar : 'a Proofview.Goal.t -> constr -> constr
+ val pf_whd_all : ('a, 'r) Proofview.Goal.t -> constr -> constr
+ val pf_compute : ('a, 'r) Proofview.Goal.t -> constr -> constr
+
+ val pf_matches : ('a, 'r) Proofview.Goal.t -> constr_pattern -> constr -> patvar_map
+
+ val pf_nf_evar : ('a, 'r) Proofview.Goal.t -> constr -> constr
end
diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml
deleted file mode 100644
index a4a447e8..00000000
--- a/proofs/tactic_debug.ml
+++ /dev/null
@@ -1,318 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* mt())
-
-let explain_logic_error_no_anomaly = ref (fun e -> mt())
-
-let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl())
-let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl())
-
-(* Prints the goal *)
-
-let db_pr_goal gl =
- let env = Proofview.Goal.env gl in
- let concl = Proofview.Goal.concl gl in
- let penv = print_named_context env in
- let pc = print_constr_env env concl in
- str" " ++ hv 0 (penv ++ fnl () ++
- str "============================" ++ fnl () ++
- str" " ++ pc) ++ fnl ()
-
-let db_pr_goal =
- Proofview.Goal.nf_enter begin fun gl ->
- let pg = db_pr_goal gl in
- Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg))
- end
-
-
-(* Prints the commands *)
-let help () =
- msg_tac_debug (str "Commands: = Continue" ++ fnl() ++
- str " h/? = Help" ++ fnl() ++
- str " r = Run times" ++ fnl() ++
- str " r = Run up to next idtac " ++ fnl() ++
- str " s = Skip" ++ fnl() ++
- str " x = Exit")
-
-(* Prints the goal and the command to be executed *)
-let goal_com tac =
- Proofview.tclTHEN
- db_pr_goal
- (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ Hook.get prtac tac)))
-
-(* [run (new_ref _)] gives us a ref shared among [NonLogical.t]
- expressions. It avoids parametrizing everything over a
- reference. *)
-let skipped = Proofview.NonLogical.run (Proofview.NonLogical.ref 0)
-let skip = Proofview.NonLogical.run (Proofview.NonLogical.ref 0)
-let breakpoint = Proofview.NonLogical.run (Proofview.NonLogical.ref None)
-
-let rec drop_spaces inst i =
- if String.length inst > i && inst.[i] == ' ' then drop_spaces inst (i+1)
- else i
-
-let possibly_unquote s =
- if String.length s >= 2 && s.[0] == '"' && s.[String.length s - 1] == '"' then
- String.sub s 1 (String.length s - 2)
- else
- s
-
-(* (Re-)initialize debugger *)
-let db_initialize =
- let open Proofview.NonLogical in
- (skip:=0) >> (skipped:=0) >> (breakpoint:=None)
-
-let int_of_string s =
- try Proofview.NonLogical.return (int_of_string s)
- with e -> Proofview.NonLogical.raise e
-
-let string_get s i =
- try Proofview.NonLogical.return (String.get s i)
- with e -> Proofview.NonLogical.raise e
-
-(* Gives the number of steps or next breakpoint of a run command *)
-let run_com inst =
- let open Proofview.NonLogical in
- string_get inst 0 >>= fun first_char ->
- if first_char ='r' then
- let i = drop_spaces inst 1 in
- if String.length inst > i then
- let s = String.sub inst i (String.length inst - i) in
- if inst.[0] >= '0' && inst.[0] <= '9' then
- int_of_string s >>= fun num ->
- (if num<0 then invalid_arg "run_com" else return ()) >>
- (skip:=num) >> (skipped:=0)
- else
- breakpoint:=Some (possibly_unquote s)
- else
- invalid_arg "run_com"
- else
- invalid_arg "run_com"
-
-(* Prints the run counter *)
-let run ini =
- let open Proofview.NonLogical in
- if not ini then
- begin
- Proofview.NonLogical.print_notice (str"\b\r\b\r") >>
- !skipped >>= fun skipped ->
- msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl())
- end >>
- !skipped >>= fun x ->
- skipped := x+1
- else
- return ()
-
-(* Prints the prompt *)
-let rec prompt level =
- (* spiwack: avoid overriding by the open below *)
- let runtrue = run true in
- begin
- let open Proofview.NonLogical in
- Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >>
- let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in
- Proofview.NonLogical.catch Proofview.NonLogical.read_line
- begin function (e, info) -> match e with
- | End_of_file -> exit
- | e -> raise ~info e
- end
- >>= fun inst ->
- match inst with
- | "" -> return (DebugOn (level+1))
- | "s" -> return (DebugOff)
- | "x" -> Proofview.NonLogical.print_char '\b' >> exit
- | "h"| "?" ->
- begin
- help () >>
- prompt level
- end
- | _ ->
- Proofview.NonLogical.catch (run_com inst >> runtrue >> return (DebugOn (level+1)))
- begin function (e, info) -> match e with
- | Failure _ | Invalid_argument _ -> prompt level
- | e -> raise ~info e
- end
- end
-
-(* Prints the state and waits for an instruction *)
-(* spiwack: the only reason why we need to take the continuation [f]
- as an argument rather than returning the new level directly seems to
- be that [f] is wrapped in with "explain_logic_error". I don't think
- it serves any purpose in the current design, so we could just drop
- that. *)
-let debug_prompt lev tac f =
- (* spiwack: avoid overriding by the open below *)
- let runfalse = run false in
- let open Proofview.NonLogical in
- let (>=) = Proofview.tclBIND in
- (* What to print and to do next *)
- let newlevel =
- Proofview.tclLIFT !skip >= fun initial_skip ->
- if Int.equal initial_skip 0 then
- Proofview.tclLIFT !breakpoint >= fun breakpoint ->
- if Option.is_empty breakpoint then Proofview.tclTHEN (goal_com tac) (Proofview.tclLIFT (prompt lev))
- else Proofview.tclLIFT(runfalse >> return (DebugOn (lev+1)))
- else Proofview.tclLIFT begin
- (!skip >>= fun s -> skip:=s-1) >>
- runfalse >>
- !skip >>= fun new_skip ->
- (if Int.equal new_skip 0 then skipped:=0 else return ()) >>
- return (DebugOn (lev+1))
- end in
- newlevel >= fun newlevel ->
- (* What to execute *)
- Proofview.tclOR
- (f newlevel)
- begin fun (reraise, info) ->
- Proofview.tclTHEN
- (Proofview.tclLIFT begin
- (skip:=0) >> (skipped:=0) >>
- if Logic.catchable_exception reraise then
- msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ Pervasives.(!) explain_logic_error reraise)
- else return ()
- end)
- (Proofview.tclZERO ~info reraise)
- end
-
-let is_debug db =
- let open Proofview.NonLogical in
- !breakpoint >>= fun breakpoint ->
- match db, breakpoint with
- | DebugOff, _ -> return false
- | _, Some _ -> return false
- | _ ->
- !skip >>= fun skip ->
- return (Int.equal skip 0)
-
-(* Prints a constr *)
-let db_constr debug env c =
- let open Proofview.NonLogical in
- is_debug debug >>= fun db ->
- if db then
- msg_tac_debug (str "Evaluated term: " ++ print_constr_env env c)
- else return ()
-
-(* Prints the pattern rule *)
-let db_pattern_rule debug 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 () ++ Hook.get prmatchrl r)
- end
- else return ()
-
-(* Prints the hypothesis pattern identifier if it exists *)
-let hyp_bound = function
- | Anonymous -> str " (unbound)"
- | Name id -> str " (bound to " ++ pr_id id ++ str ")"
-
-(* Prints a matched hypothesis *)
-let db_matched_hyp debug env (id,_,c) ido =
- let open Proofview.NonLogical in
- is_debug debug >>= fun db ->
- if db then
- msg_tac_debug (str "Hypothesis " ++ pr_id id ++ hyp_bound ido ++
- str " has been matched: " ++ print_constr_env env c)
- else return ()
-
-(* Prints the matched conclusion *)
-let db_matched_concl debug env c =
- let open Proofview.NonLogical in
- is_debug debug >>= fun db ->
- if db then
- msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env c)
- else return ()
-
-(* Prints a success message when the goal has been matched *)
-let db_mc_pattern_success debug =
- let open Proofview.NonLogical in
- is_debug debug >>= fun db ->
- if db then
- msg_tac_debug (str "The goal has been successfully matched!" ++ fnl() ++
- str "Let us execute the right-hand side part..." ++ fnl())
- else return ()
-
-(* Prints a failure message for an hypothesis pattern *)
-let db_hyp_pattern_failure debug env sigma (na,hyp) =
- let open Proofview.NonLogical in
- is_debug debug >>= fun db ->
- if db then
- msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++
- str " cannot match: " ++
- Hook.get prmatchpatt env sigma hyp)
- else return ()
-
-(* Prints a matching failure message for a rule *)
-let db_matching_failure debug =
- let open Proofview.NonLogical in
- is_debug debug >>= fun db ->
- if db then
- msg_tac_debug (str "This rule has failed due to matching errors!" ++ fnl() ++
- str "Let us try the next one...")
- else return ()
-
-(* Prints an evaluation failure message for a rule *)
-let db_eval_failure debug s =
- let open Proofview.NonLogical in
- is_debug debug >>= fun db ->
- if db then
- let s = str "message \"" ++ s ++ str "\"" in
- msg_tac_debug
- (str "This rule has failed due to \"Fail\" tactic (" ++
- s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...")
- else return ()
-
-(* Prints a logic failure message for a rule *)
-let db_logic_failure debug err =
- let open Proofview.NonLogical in
- is_debug debug >>= fun db ->
- if db then
- begin
- msg_tac_debug (Pervasives.(!) explain_logic_error err) >>
- msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++
- str "Let us try the next one...")
- end
- else return ()
-
-let is_breakpoint brkname s = match brkname, s with
- | Some s, MsgString s'::_ -> String.equal s s'
- | _ -> false
-
-let db_breakpoint debug s =
- let open Proofview.NonLogical in
- !breakpoint >>= fun opt_breakpoint ->
- match debug with
- | DebugOn lev when not (CList.is_empty s) && is_breakpoint opt_breakpoint s ->
- breakpoint:=None
- | _ ->
- return ()
diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli
deleted file mode 100644
index 215c5b29..00000000
--- a/proofs/tactic_debug.mli
+++ /dev/null
@@ -1,79 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* Pp.std_ppcmds) Hook.t
-val match_pattern_printer :
- (env -> evar_map -> constr_pattern match_pattern -> Pp.std_ppcmds) Hook.t
-val match_rule_printer :
- ((Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> Pp.std_ppcmds) Hook.t
-
-(** Debug information *)
-type debug_info =
- | DebugOn of int
- | DebugOff
-
-(** Prints the state and waits *)
-val debug_prompt :
- int -> glob_tactic_expr -> (debug_info -> 'a Proofview.tactic) -> 'a Proofview.tactic
-
-(** Initializes debugger *)
-val db_initialize : unit Proofview.NonLogical.t
-
-(** Prints a constr *)
-val db_constr : debug_info -> env -> constr -> unit Proofview.NonLogical.t
-
-(** 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
-
-(** Prints a matched hypothesis *)
-val db_matched_hyp :
- debug_info -> env -> Id.t * constr option * constr -> Name.t -> unit Proofview.NonLogical.t
-
-(** Prints the matched conclusion *)
-val db_matched_concl : debug_info -> env -> constr -> unit Proofview.NonLogical.t
-
-(** Prints a success message when the goal has been matched *)
-val db_mc_pattern_success : debug_info -> unit Proofview.NonLogical.t
-
-(** Prints a failure message for an hypothesis pattern *)
-val db_hyp_pattern_failure :
- debug_info -> env -> evar_map -> Name.t * constr_pattern match_pattern -> unit Proofview.NonLogical.t
-
-(** Prints a matching failure message for a rule *)
-val db_matching_failure : debug_info -> unit Proofview.NonLogical.t
-
-(** Prints an evaluation failure message for a rule *)
-val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t
-
-(** An exception handler *)
-val explain_logic_error: (exn -> Pp.std_ppcmds) ref
-
-(** For use in the Ltac debugger: some exception that are usually
- consider anomalies are acceptable because they are caught later in
- the process that is being debugged. One should not require
- from users that they report these anomalies. *)
-val explain_logic_error_no_anomaly : (exn -> Pp.std_ppcmds) ref
-
-(** Prints a logic failure message for a rule *)
-val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t
-
-(** Prints a logic failure message for a rule *)
-val db_breakpoint : debug_info ->
- Id.t Loc.located message_token list -> unit Proofview.NonLogical.t
diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml
index cc973260..fa6422cd 100644
--- a/stm/asyncTaskQueue.ml
+++ b/stm/asyncTaskQueue.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Pp
open Util
@@ -60,9 +60,7 @@ module Make(T : Task) = struct
type more_data =
| MoreDataUnivLevel of Univ.universe_level list
-
- let request_expiry_of_task (t, c) = T.request_of_task t, c
-
+
let slave_respond (Request r) =
let res = T.perform r in
Response res
@@ -106,7 +104,8 @@ module Make(T : Task) = struct
marshal_err ("unmarshal_more_data: "^s)
let report_status ?(id = !Flags.async_proofs_worker_id) s =
- Pp.feedback ~state_id:Stateid.initial (Feedback.WorkerStatus(id, s))
+ let open Feedback in
+ feedback ~id:(State Stateid.initial) (WorkerStatus(id, s))
module Worker = Spawn.Sync(struct end)
@@ -125,7 +124,7 @@ module Make(T : Task) = struct
"-async-proofs-worker-priority";
Flags.string_of_priority !Flags.async_proofs_worker_priority]
| ("-ideslave"|"-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl
- | ("-async-proofs" |"-toploop" |"-vi2vo"
+ | ("-async-proofs" |"-toploop" |"-vio2vo"
|"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv"
|"-compile" |"-compile-verbose"
|"-async-proofs-worker-priority" |"-worker-id") :: _ :: tl ->
@@ -184,6 +183,13 @@ module Make(T : Task) = struct
let () = Unix.sleep 1 in
kill_if ()
in
+ let kill_if () =
+ try kill_if ()
+ with Sys.Break ->
+ let () = stop_waiting := true in
+ let () = TQueue.broadcast queue in
+ Worker.kill proc
+ in
let _ = Thread.create kill_if () in
try while true do
@@ -223,10 +229,8 @@ module Make(T : Task) = struct
| (Die | TQueue.BeingDestroyed) ->
giveback_exec_token (); kill proc; exit ()
| Sys_error _ | Invalid_argument _ | End_of_file ->
- giveback_exec_token ();
T.on_task_cancellation_or_expiration_or_slave_death !last_task;
- kill proc;
- exit ()
+ giveback_exec_token (); kill proc; exit ()
end
module Pool = WorkerPool.Make(Model)
@@ -294,11 +298,27 @@ module Make(T : Task) = struct
let slave_handshake () =
Pool.worker_handshake (Option.get !slave_ic) (Option.get !slave_oc)
+ let pp_pid pp =
+ (* Breaking all abstraction barriers... very nice *)
+ let get_xml pp = match Richpp.repr pp with
+ | Xml_datatype.Element("_", [], xml) -> xml
+ | _ -> assert false in
+ Richpp.richpp_of_xml (Xml_datatype.Element("_", [],
+ get_xml (Richpp.richpp_of_pp Pp.(str (System.process_id ()^ " "))) @
+ get_xml pp))
+
+ let debug_with_pid = Feedback.(function
+ | { contents = Message(Debug, loc, pp) } as fb ->
+ { fb with contents = Message(Debug,loc,pp_pid pp) }
+ | x -> x)
+
let main_loop () =
+ (* We pass feedback to master *)
let slave_feeder oc fb =
- Marshal.to_channel oc (RespFeedback fb) []; flush oc in
- Pp.set_feeder (fun x -> slave_feeder (Option.get !slave_oc) x);
- Pp.log_via_feedback ();
+ Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc in
+ Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x);
+ Feedback.set_logger Feedback.feedback_logger;
+ (* We ask master to allocate universe identifiers *)
Universes.set_remote_new_univ_level (bufferize (fun () ->
marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel;
match unmarshal_more_data (Option.get !slave_ic) with
@@ -314,7 +334,7 @@ module Make(T : Task) = struct
let response = slave_respond request in
report_status "Idle";
marshal_response (Option.get !slave_oc) response;
- Ephemeron.clear ()
+ CEphemeron.clear ()
with
| MarshalError s ->
pr_err ("Fatal marshal error: " ^ s); flush_all (); exit 2
@@ -337,7 +357,7 @@ module Make(T : Task) = struct
let with_n_workers n f =
let q = create n in
try let rc = f q in destroy q; rc
- with e -> let e = Errors.push e in destroy q; iraise e
+ with e -> let e = CErrors.push e in destroy q; iraise e
let n_workers { active } = Pool.n_workers active
diff --git a/stm/dag.ml b/stm/dag.ml
index 0c7f9f34..99e7c926 100644
--- a/stm/dag.ml
+++ b/stm/dag.ml
@@ -8,15 +8,6 @@
module type S = sig
- module Cluster :
- sig
- type 'd t
- val equal : 'd t -> 'd t -> bool
- val compare : 'd t -> 'd t -> int
- val to_string : 'd t -> string
- val data : 'd t -> 'd
- end
-
type node
module NodeSet : Set.S with type elt = node
@@ -31,45 +22,57 @@ module type S = sig
val del_nodes : ('e,'i,'d) t -> NodeSet.t -> ('e,'i,'d) t
val all_nodes : ('e,'i,'d) t -> NodeSet.t
- val iter : ('e,'i,'d) t ->
- (node -> 'd Cluster.t option -> 'i option ->
- (node * 'e) list -> unit) -> unit
-
- val create_cluster : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t
- val cluster_of : ('e,'i,'d) t -> node -> 'd Cluster.t option
- val del_cluster : ('e,'i,'d) t -> 'd Cluster.t -> ('e,'i,'d) t
-
val get_info : ('e,'i,'d) t -> node -> 'i option
val set_info : ('e,'i,'d) t -> node -> 'i -> ('e,'i,'d) t
val clear_info : ('e,'i,'d) t -> node -> ('e,'i,'d) t
+ module Property :
+ sig
+ type 'd t
+ val equal : 'd t -> 'd t -> bool
+ val compare : 'd t -> 'd t -> int
+ val to_string : 'd t -> string
+ val data : 'd t -> 'd
+ val having_it : 'd t -> NodeSet.t
+ end
+
+ val create_property : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t
+ val property_of : ('e,'i,'d) t -> node -> 'd Property.t list
+ val del_property : ('e,'i,'d) t -> 'd Property.t -> ('e,'i,'d) t
+
+ val iter : ('e,'i,'d) t ->
+ (node -> 'd Property.t list -> 'i option ->
+ (node * 'e) list -> unit) -> unit
+
end
module Make(OT : Map.OrderedType) = struct
-module Cluster =
+module NodeSet = Set.Make(OT)
+
+module Property =
struct
- type 'd t = 'd * int
- let equal (_,i1) (_,i2) = Int.equal i1 i2
- let compare (_,i1) (_,i2) = Int.compare i1 i2
- let to_string (_,i) = string_of_int i
- let data (d,_) = d
+ type 'd t = { data : 'd; uid : int; having_it : NodeSet.t }
+ let equal { uid = i1 } { uid = i2 } = Int.equal i1 i2
+ let compare { uid = i1 } { uid = i2 } = Int.compare i1 i2
+ let to_string { uid = i } = string_of_int i
+ let data { data = d } = d
+ let having_it { having_it } = having_it
end
type node = OT.t
module NodeMap = CMap.Make(OT)
-module NodeSet = Set.Make(OT)
type ('edge,'info,'data) t = {
graph : (node * 'edge) list NodeMap.t;
- clusters : 'data Cluster.t NodeMap.t;
+ properties : 'data Property.t list NodeMap.t;
infos : 'info NodeMap.t;
}
let empty = {
graph = NodeMap.empty;
- clusters = NodeMap.empty;
+ properties = NodeMap.empty;
infos = NodeMap.empty;
}
@@ -94,7 +97,7 @@ let del_edge dag id tgt = { dag with
let del_nodes dag s = {
infos = NodeMap.filter (fun n _ -> not(NodeSet.mem n s)) dag.infos;
- clusters = NodeMap.filter (fun n _ -> not(NodeSet.mem n s)) dag.clusters;
+ properties = NodeMap.filter (fun n _ -> not(NodeSet.mem n s)) dag.properties;
graph = NodeMap.filter (fun n l ->
let drop = NodeSet.mem n s in
if not drop then
@@ -102,20 +105,31 @@ let del_nodes dag s = {
not drop)
dag.graph }
+let map_add_list k v m =
+ try
+ let l = NodeMap.find k m in
+ NodeMap.add k (v::l) m
+ with Not_found -> NodeMap.add k [v] m
+
let clid = ref 1
-let create_cluster dag l data =
+let create_property dag l data =
incr clid;
- { dag with clusters =
- List.fold_right (fun x clusters ->
- NodeMap.add x (data, !clid) clusters) l dag.clusters }
-
-let cluster_of dag id =
- try Some (NodeMap.find id dag.clusters)
- with Not_found -> None
-
-let del_cluster dag c =
- { dag with clusters =
- NodeMap.filter (fun _ c' -> not (Cluster.equal c' c)) dag.clusters }
+ let having_it = List.fold_right NodeSet.add l NodeSet.empty in
+ let property = { Property.data; uid = !clid; having_it } in
+ { dag with properties =
+ List.fold_right (fun x ps -> map_add_list x property ps) l dag.properties }
+
+let property_of dag id =
+ try NodeMap.find id dag.properties
+ with Not_found -> []
+
+let del_property dag c =
+ { dag with properties =
+ NodeMap.filter (fun _ cl -> cl <> [])
+ (NodeMap.map (fun cl ->
+ List.filter (fun c' ->
+ not (Property.equal c' c)) cl)
+ dag.properties) }
let get_info dag id =
try Some (NodeMap.find id dag.infos)
@@ -126,7 +140,7 @@ let set_info dag id info = { dag with infos = NodeMap.add id info dag.infos }
let clear_info dag id = { dag with infos = NodeMap.remove id dag.infos }
let iter dag f =
- NodeMap.iter (fun k v -> f k (cluster_of dag k) (get_info dag k) v) dag.graph
+ NodeMap.iter (fun k v -> f k (property_of dag k) (get_info dag k) v) dag.graph
let all_nodes dag = NodeMap.domain dag.graph
diff --git a/stm/dag.mli b/stm/dag.mli
index 6b4442df..e783cd8e 100644
--- a/stm/dag.mli
+++ b/stm/dag.mli
@@ -7,19 +7,7 @@
(************************************************************************)
module type S = sig
-
- (* A cluster is just a set of nodes. This set holds some data.
- Stm uses this to group nodes contribution to the same proofs and
- that can be evaluated asynchronously *)
- module Cluster :
- sig
- type 'd t
- val equal : 'd t -> 'd t -> bool
- val compare : 'd t -> 'd t -> int
- val to_string : 'd t -> string
- val data : 'd t -> 'd
- end
-
+
type node
module NodeSet : Set.S with type elt = node
@@ -34,19 +22,35 @@ module type S = sig
val del_nodes : ('e,'i,'d) t -> NodeSet.t -> ('e,'i,'d) t
val all_nodes : ('e,'i,'d) t -> NodeSet.t
- val iter : ('e,'i,'d) t ->
- (node -> 'd Cluster.t option -> 'i option ->
- (node * 'e) list -> unit) -> unit
-
- val create_cluster : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t
- val cluster_of : ('e,'i,'d) t -> node -> 'd Cluster.t option
- val del_cluster : ('e,'i,'d) t -> 'd Cluster.t -> ('e,'i,'d) t
-
val get_info : ('e,'i,'d) t -> node -> 'i option
val set_info : ('e,'i,'d) t -> node -> 'i -> ('e,'i,'d) t
val clear_info : ('e,'i,'d) t -> node -> ('e,'i,'d) t
-end
+ (* A property applies to a set of nodes and holds some data.
+ Stm uses this feature to group nodes contributing to the same proofs and
+ to structure proofs in boxes limiting the scope of errors *)
+ module Property :
+ sig
+ type 'd t
+ val equal : 'd t -> 'd t -> bool
+ val compare : 'd t -> 'd t -> int
+ val to_string : 'd t -> string
+ val data : 'd t -> 'd
+ val having_it : 'd t -> NodeSet.t
+ end
+
+ val create_property : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t
+ val property_of : ('e,'i,'d) t -> node -> 'd Property.t list
+ val del_property : ('e,'i,'d) t -> 'd Property.t -> ('e,'i,'d) t
+
+ val iter : ('e,'i,'d) t ->
+ (node -> 'd Property.t list -> 'i option ->
+ (node * 'e) list -> unit) -> unit
+
+ end
-module Make(OT : Map.OrderedType) : S with type node = OT.t
+module Make(OT : Map.OrderedType) : S
+with type node = OT.t
+and type NodeSet.t = Set.Make(OT).t
+and type NodeSet.elt = OT.t
diff --git a/stm/lemmas.ml b/stm/lemmas.ml
index f06abfcc..022c89ad 100644
--- a/stm/lemmas.ml
+++ b/stm/lemmas.ml
@@ -9,7 +9,7 @@
(* Created by Hugo Herbelin from contents related to lemma proofs in
file command.ml, Aug 2009 *)
-open Errors
+open CErrors
open Util
open Flags
open Pp
@@ -31,20 +31,22 @@ open Reductionops
open Constrexpr
open Constrintern
open Impargs
+open Context.Rel.Declaration
type 'a declaration_hook = Decl_kinds.locality -> Globnames.global_reference -> 'a
let mk_hook hook = hook
let call_hook fix_exn hook l c =
try hook l c
- with e when Errors.noncritical e ->
- let e = Errors.push e in
+ with e when CErrors.noncritical e ->
+ let e = CErrors.push e in
iraise (fix_exn e)
(* Support for mutually proved theorems *)
let retrieve_first_recthm = function
| VarRef id ->
- (pi2 (Global.lookup_named id),variable_opacity id)
+ let open Context.Named.Declaration in
+ (get_value (Global.lookup_named id),variable_opacity id)
| ConstRef cst ->
let cb = Global.lookup_constant cst in
(Global.body_of_constant_body cb, is_opaque cb)
@@ -77,7 +79,7 @@ let adjust_guardness_conditions const = function
List.fold_left (fun e (_,c,cb,_) -> add c cb e) env l)
env (Safe_typing.side_effects_of_private_constants eff) in
let indexes =
- search_guard Loc.ghost env
+ search_guard Loc.ghost env
possible_indexes fixdecls in
(mkFix ((indexes,0),fixdecls), ctx), eff
| _ -> (body, ctx), eff) }
@@ -104,20 +106,21 @@ let find_mutually_recursive_statements thms =
(* Cofixpoint or fixpoint w/o explicit decreasing argument *)
| None | Some (None, CStructRec) ->
let whnf_hyp_hds = map_rel_context_in_env
- (fun env c -> fst (whd_betadeltaiota_stack env Evd.empty c))
+ (fun env c -> fst (whd_all_stack env Evd.empty c))
(Global.env()) hyps in
let ind_hyps =
- List.flatten (List.map_i (fun i (_,b,t) ->
+ List.flatten (List.map_i (fun i decl ->
+ let t = get_type decl in
match kind_of_term t with
| Ind ((kn,_ as ind),u) when
let mind = Global.lookup_mind kn in
- mind.mind_finite <> Decl_kinds.CoFinite && Option.is_empty b ->
+ mind.mind_finite <> Decl_kinds.CoFinite && is_local_assum decl ->
[ind,x,i]
| _ ->
[]) 0 (List.rev whnf_hyp_hds)) in
let ind_ccl =
let cclenv = push_rel_context hyps (Global.env()) in
- let whnf_ccl,_ = whd_betadeltaiota_stack cclenv Evd.empty ccl in
+ let whnf_ccl,_ = whd_all_stack cclenv Evd.empty ccl in
match kind_of_term whnf_ccl with
| Ind ((kn,_ as ind),u) when
let mind = Global.lookup_mind kn in
@@ -147,7 +150,7 @@ let find_mutually_recursive_statements thms =
assert (List.is_empty rest);
(* One occ. of common coind ccls and no common inductive hyps *)
if not (List.is_empty common_same_indhyp) then
- if_verbose msg_info (str "Assuming mutual coinductive statements.");
+ if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements.");
flush_all ();
indccl, true, []
| [], _::_ ->
@@ -155,7 +158,7 @@ let find_mutually_recursive_statements thms =
| ind :: _ ->
if List.distinct_f ind_ord (List.map pi1 ind)
then
- if_verbose msg_info
+ if_verbose Feedback.msg_info
(strbrk
("Coinductive statements do not follow the order of "^
"definition, assuming the proof to be by induction."));
@@ -207,8 +210,8 @@ let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook =
definition_message id;
Option.iter (Universes.register_universe_binders r) pl;
call_hook (fun exn -> exn) hook l r
- with e when Errors.noncritical e ->
- let e = Errors.push e in
+ with e when CErrors.noncritical e ->
+ let e = CErrors.push e in
iraise (fix_exn e)
let default_thm_id = Id.of_string "Unnamed_thm"
@@ -249,10 +252,14 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,
| Some body ->
let body = norm body in
let k = Kindops.logical_kind_of_goal_kind kind in
- let body_i = match kind_of_term body with
+ let rec body_i t = match kind_of_term t with
| Fix ((nv,0),decls) -> mkFix ((nv,i),decls)
| CoFix (0,decls) -> mkCoFix (i,decls)
+ | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, body_i t2)
+ | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t)
+ | App (t, args) -> mkApp (body_i t, args)
| _ -> anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr body) in
+ let body_i = body_i body in
match locality with
| Discharge ->
let const = definition_entry ~types:t_i ~opaque:opaq ~poly:p
@@ -298,13 +305,16 @@ let save_anonymous_with_strength ?export_seff proof kind save_ident =
(* Admitted *)
+let warn_let_as_axiom =
+ CWarnings.create ~name:"let-as-axiom" ~category:"vernacular"
+ (fun id -> strbrk "Let definition" ++ spc () ++ pr_id id ++
+ spc () ++ strbrk "declared as an axiom.")
+
let admit (id,k,e) pl hook () =
let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in
let () = match k with
| Global, _, _ -> ()
- | Local, _, _ | Discharge, _, _ ->
- msg_warning (str "Let definition" ++ spc () ++ pr_id id ++ spc () ++
- str "declared as an axiom.")
+ | Local, _, _ | Discharge, _, _ -> warn_let_as_axiom id
in
let () = assumption_message id in
Option.iter (Universes.register_universe_binders (ConstRef kn)) pl;
@@ -329,10 +339,11 @@ let check_exist =
)
let universe_proof_terminator compute_guard hook =
- let open Proof_global in function
+ let open Proof_global in
+ make_terminator begin function
| Admitted (id,k,pe,(ctx,pl)) ->
admit (id,k,pe) pl (hook (Some ctx)) ();
- Pp.feedback Feedback.AddedAxiom
+ Feedback.feedback Feedback.AddedAxiom
| Proved (opaque,idopt,proof) ->
let is_opaque, export_seff, exports = match opaque with
| Vernacexpr.Transparent -> false, true, []
@@ -347,12 +358,16 @@ let universe_proof_terminator compute_guard hook =
save_anonymous_with_strength ~export_seff proof kind id
end;
check_exist exports
+ end
let standard_proof_terminator compute_guard hook =
universe_proof_terminator compute_guard (fun _ -> hook)
-let start_proof id ?pl kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook =
- let terminator = standard_proof_terminator compute_guard hook in
+let start_proof id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook =
+ let terminator = match terminator with
+ | None -> standard_proof_terminator compute_guard hook
+ | Some terminator -> terminator compute_guard hook
+ in
let sign =
match sign with
| Some sign -> sign
@@ -361,8 +376,11 @@ let start_proof id ?pl kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook =
!start_hook c;
Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator
-let start_proof_univs id ?pl kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook =
- let terminator = universe_proof_terminator compute_guard hook in
+let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook =
+ let terminator = match terminator with
+ | None -> universe_proof_terminator compute_guard hook
+ | Some terminator -> terminator compute_guard hook
+ in
let sign =
match sign with
| Some sign -> sign
@@ -392,7 +410,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook =
| Anonymous -> Tactics.intro) (List.rev ids) in
let init_tac,guard = match recguard with
| Some (finite,guard,init_tac) ->
- let rec_tac = Proofview.V82.tactic (rec_tac_initializer finite guard thms snl) in
+ let rec_tac = rec_tac_initializer finite guard thms snl in
Some (match init_tac with
| None ->
if Flags.is_auto_intros () then
@@ -422,7 +440,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook =
let body,opaq = retrieve_first_recthm ref in
let subst = Evd.evar_universe_context_subst ctx in
let norm c = Universes.subst_opt_univs_constr subst c in
- let ctx = Evd.evar_universe_context_set (*FIXME*) Univ.UContext.empty ctx in
+ let ctx = UState.context_set (*FIXME*) ctx in
let body = Option.map norm body in
List.map_i (save_remaining_recthms kind norm ctx body opaq) 1 other_thms in
let thms_data = (strength,ref,imps)::other_thms_data in
@@ -431,7 +449,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook =
call_hook (fun exn -> exn) hook strength ref) thms_data in
start_proof_univs id ?pl kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard
-let start_proof_com kind thms hook =
+let start_proof_com ?inference_hook kind thms hook =
let env0 = Global.env () in
let levels = Option.map snd (fst (List.hd thms)) in
let evdref = ref (match levels with
@@ -441,8 +459,10 @@ let start_proof_com kind thms hook =
let thms = List.map (fun (sopt,(bl,t,guard)) ->
let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in
let t', imps' = interp_type_evars_impls ~impls env evdref t in
- evdref := solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref);
- let ids = List.map pi1 ctx in
+ let flags = all_and_fail_flags in
+ let flags = { flags with use_hook = inference_hook } in
+ evdref := solve_remaining_evars flags env !evdref (Evd.empty,!evdref);
+ let ids = List.map get_name ctx in
(compute_proof_name (pi1 kind) sopt,
(nf_evar !evdref (it_mkProd_or_LetIn t' ctx),
(ids, imps @ lift_implicits (List.length ids) imps'),
@@ -451,6 +471,11 @@ let start_proof_com kind thms hook =
let recguard,thms,snl = look_for_possibly_mutual_statements thms in
let evd, nf = Evarutil.nf_evars_and_universes !evdref in
let thms = List.map (fun (n, (t, info)) -> (n, (nf t, info))) thms in
+ let () =
+ match levels with
+ | None -> ()
+ | Some l -> ignore (Evd.universe_context evd ?names:l)
+ in
let evd =
if pi2 kind then evd
else (* We fix the variables to ensure they won't be lowered to Set *)
@@ -461,6 +486,18 @@ let start_proof_com kind thms hook =
(* Saving a proof *)
+let keep_admitted_vars = ref true
+
+let _ =
+ let open Goptions in
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ optname = "keep section variables in admitted proofs";
+ optkey = ["Keep"; "Admitted"; "Variables"];
+ optread = (fun () -> !keep_admitted_vars);
+ optwrite = (fun b -> keep_admitted_vars := b) }
+
let save_proof ?proof = function
| Vernacexpr.Admitted ->
let pe =
@@ -474,14 +511,18 @@ let save_proof ?proof = function
error "Admitted requires an explicit statement";
let typ = Option.get const_entry_type in
let ctx = Evd.evar_context_universe_context (fst universes) in
- Admitted(id, k, (const_entry_secctx, pi2 k, (typ, ctx), None), universes)
+ let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in
+ Admitted(id, k, (sec_vars, pi2 k, (typ, ctx), None), universes)
| None ->
+ let pftree = Pfedit.get_pftreestate () in
let id, k, typ = Pfedit.current_proof_statement () in
+ let universes = Proof.initial_euctx pftree in
(* This will warn if the proof is complete *)
- let pproofs, universes =
+ let pproofs, _univs =
Proof_global.return_proof ~allow_partial:true () in
let sec_vars =
- match Pfedit.get_used_variables(), pproofs with
+ if not !keep_admitted_vars then None
+ else match Pfedit.get_used_variables(), pproofs with
| Some _ as x, _ -> x
| None, (pproof, _) :: _ ->
let env = Global.env () in
@@ -490,11 +531,12 @@ let save_proof ?proof = function
Some (Environ.keep_hyps env (Idset.union ids_typ ids_def))
| _ -> None in
let names = Pfedit.get_universe_binders () in
- let binders, ctx = Evd.universe_context ?names (Evd.from_ctx universes) in
+ let evd = Evd.from_ctx universes in
+ let binders, ctx = Evd.universe_context ?names evd in
Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None),
(universes, Some binders))
in
- Proof_global.get_terminator() pe
+ Proof_global.apply_terminator (Proof_global.get_terminator ()) pe
| Vernacexpr.Proved (is_opaque,idopt) ->
let (proof_obj,terminator) =
match proof with
@@ -504,12 +546,10 @@ let save_proof ?proof = function
in
(* if the proof is given explicitly, nothing has to be deleted *)
if Option.is_empty proof then Pfedit.delete_current_proof ();
- terminator (Proof_global.Proved (is_opaque,idopt,proof_obj))
+ Proof_global.(apply_terminator terminator (Proved (is_opaque,idopt,proof_obj)))
(* Miscellaneous *)
let get_current_context () =
- try Pfedit.get_current_goal_context ()
- with e when Logic.catchable_exception e ->
- let env = Global.env () in
- (Evd.from_env env, env)
+ Pfedit.get_current_context ()
+
diff --git a/stm/lemmas.mli b/stm/lemmas.mli
index 16e54e31..39c089be 100644
--- a/stm/lemmas.mli
+++ b/stm/lemmas.mli
@@ -9,8 +9,6 @@
open Names
open Term
open Decl_kinds
-open Constrexpr
-open Vernacexpr
open Pfedit
type 'a declaration_hook
@@ -24,16 +22,20 @@ val call_hook :
val set_start_hook : (types -> unit) -> unit
val start_proof : Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map ->
+ ?terminator:(lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) ->
?sign:Environ.named_context_val -> types ->
?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards ->
unit declaration_hook -> unit
val start_proof_univs : Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map ->
+ ?terminator:(lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator) ->
?sign:Environ.named_context_val -> types ->
?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards ->
(Evd.evar_universe_context option -> unit declaration_hook) -> unit
-val start_proof_com : goal_kind -> Vernacexpr.proof_expr list ->
+val start_proof_com :
+ ?inference_hook:Pretyping.inference_hook ->
+ goal_kind -> Vernacexpr.proof_expr list ->
unit declaration_hook -> unit
val start_proof_with_initialization :
@@ -43,6 +45,11 @@ val start_proof_with_initialization :
(types * (Name.t list * Impargs.manual_explicitation list))) list
-> int list option -> unit declaration_hook -> unit
+val universe_proof_terminator :
+ Proof_global.lemma_possible_guards ->
+ (Evd.evar_universe_context option -> unit declaration_hook) ->
+ Proof_global.proof_terminator
+
val standard_proof_terminator :
Proof_global.lemma_possible_guards -> unit declaration_hook ->
Proof_global.proof_terminator
@@ -60,4 +67,3 @@ val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> uni
and the current global env *)
val get_current_context : unit -> Evd.evar_map * Environ.env
-
diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml
new file mode 100644
index 00000000..8162fc3b
--- /dev/null
+++ b/stm/proofBlockDelimiter.ml
@@ -0,0 +1,184 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* Goal.goal -> Goal.goal list -> bool
+val is_focused_goal_simple : Stateid.t -> [ `Simple of Goal.goal list | `Not ]
+
+type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ]
+
+val crawl :
+ document_view -> ?init:document_node option ->
+ ('a -> document_node -> 'a until) -> 'a ->
+ static_block_declaration option
+
+val unit_val : Stm.DynBlockData.t
+val of_bullet_val : Vernacexpr.bullet -> Stm.DynBlockData.t
+val to_bullet_val : Stm.DynBlockData.t -> Vernacexpr.bullet
+val of_vernac_expr_val : Vernacexpr.vernac_expr -> Stm.DynBlockData.t
+val to_vernac_expr_val : Stm.DynBlockData.t -> Vernacexpr.vernac_expr
+
+end = struct
+
+let unit_tag = DynBlockData.create "unit"
+let unit_val = DynBlockData.Easy.inj () unit_tag
+
+let of_bullet_val, to_bullet_val = DynBlockData.Easy.make_dyn "bullet"
+let of_vernac_expr_val, to_vernac_expr_val = DynBlockData.Easy.make_dyn "vernac_expr"
+
+let simple_goal sigma g gs =
+ let open Evar in
+ let open Evd in
+ let open Evarutil in
+ let evi = Evd.find sigma g in
+ Set.is_empty (evars_of_term evi.evar_concl) &&
+ Set.is_empty (evars_of_filtered_evar_info (nf_evar_info sigma evi)) &&
+ not (List.exists (Proofview.depends_on sigma g) gs)
+
+let is_focused_goal_simple id =
+ match state_of_id id with
+ | `Expired | `Error _ | `Valid None -> `Not
+ | `Valid (Some { proof }) ->
+ let proof = Proof_global.proof_of_state proof in
+ let focused, r1, r2, r3, sigma = Proof.proof proof in
+ let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in
+ if List.for_all (fun x -> simple_goal sigma x rest) focused
+ then `Simple focused
+ else `Not
+
+type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ]
+
+let crawl { entry_point; prev_node } ?(init=Some entry_point) f acc =
+ let rec crawl node acc =
+ match node with
+ | None -> None
+ | Some node ->
+ match f acc node with
+ | `Stop -> None
+ | `Found x -> Some x
+ | `Cont acc -> crawl (prev_node node) acc in
+ crawl init acc
+
+end
+
+include Util
+
+(* ****************** - foo - bar - baz *********************************** *)
+
+let static_bullet ({ entry_point; prev_node } as view) =
+ match entry_point.ast with
+ | Vernacexpr.VernacBullet b ->
+ let base = entry_point.indentation in
+ let last_tac = prev_node entry_point in
+ crawl view ~init:last_tac (fun prev node ->
+ if node.indentation < base then `Stop else
+ if node.indentation > base then `Cont node else
+ match node.ast with
+ | Vernacexpr.VernacBullet b' when b = b' ->
+ `Found { block_stop = entry_point.id; block_start = prev.id;
+ dynamic_switch = node.id; carry_on_data = of_bullet_val b }
+ | _ -> `Stop) entry_point
+ | _ -> assert false
+
+let dynamic_bullet { dynamic_switch = id; carry_on_data = b } =
+ match is_focused_goal_simple id with
+ | `Simple focused ->
+ `ValidBlock {
+ base_state = id;
+ goals_to_admit = focused;
+ recovery_command = Some (Vernacexpr.VernacBullet (to_bullet_val b))
+ }
+ | `Not -> `Leaks
+
+let () = register_proof_block_delimiter
+ "bullet" static_bullet dynamic_bullet
+
+(* ******************** { block } ***************************************** *)
+
+let static_curly_brace ({ entry_point; prev_node } as view) =
+ assert(entry_point.ast = Vernacexpr.VernacEndSubproof);
+ crawl view (fun (nesting,prev) node ->
+ match node.ast with
+ | Vernacexpr.VernacSubproof _ when nesting = 0 ->
+ `Found { block_stop = entry_point.id; block_start = prev.id;
+ dynamic_switch = node.id; carry_on_data = unit_val }
+ | Vernacexpr.VernacSubproof _ ->
+ `Cont (nesting - 1,node)
+ | Vernacexpr.VernacEndSubproof ->
+ `Cont (nesting + 1,node)
+ | _ -> `Cont (nesting,node)) (-1, entry_point)
+
+let dynamic_curly_brace { dynamic_switch = id } =
+ match is_focused_goal_simple id with
+ | `Simple focused ->
+ `ValidBlock {
+ base_state = id;
+ goals_to_admit = focused;
+ recovery_command = Some Vernacexpr.VernacEndSubproof
+ }
+ | `Not -> `Leaks
+
+let () = register_proof_block_delimiter
+ "curly" static_curly_brace dynamic_curly_brace
+
+(* ***************** par: ************************************************* *)
+
+let static_par { entry_point; prev_node } =
+ match prev_node entry_point with
+ | None -> None
+ | Some { id = pid } ->
+ Some { block_stop = entry_point.id; block_start = pid;
+ dynamic_switch = pid; carry_on_data = unit_val }
+
+let dynamic_par { dynamic_switch = id } =
+ match is_focused_goal_simple id with
+ | `Simple focused ->
+ `ValidBlock {
+ base_state = id;
+ goals_to_admit = focused;
+ recovery_command = None;
+ }
+ | `Not -> `Leaks
+
+let () = register_proof_block_delimiter "par" static_par dynamic_par
+
+(* ***************** simple indentation *********************************** *)
+
+let static_indent ({ entry_point; prev_node } as view) =
+ Printf.eprintf "@%d\n" (Stateid.to_int entry_point.id);
+ match prev_node entry_point with
+ | None -> None
+ | Some last_tac ->
+ if last_tac.indentation <= entry_point.indentation then None
+ else
+ crawl view ~init:(Some last_tac) (fun prev node ->
+ if node.indentation >= last_tac.indentation then `Cont node
+ else
+ `Found { block_stop = entry_point.id; block_start = node.id;
+ dynamic_switch = node.id;
+ carry_on_data = of_vernac_expr_val entry_point.ast }
+ ) last_tac
+
+let dynamic_indent { dynamic_switch = id; carry_on_data = e } =
+ Printf.eprintf "%s\n" (Stateid.to_string id);
+ match is_focused_goal_simple id with
+ | `Simple [] -> `Leaks
+ | `Simple focused ->
+ let but_last = List.tl (List.rev focused) in
+ `ValidBlock {
+ base_state = id;
+ goals_to_admit = but_last;
+ recovery_command = Some (to_vernac_expr_val e);
+ }
+ | `Not -> `Leaks
+
+let () = register_proof_block_delimiter "indent" static_indent dynamic_indent
+
diff --git a/stm/proofBlockDelimiter.mli b/stm/proofBlockDelimiter.mli
new file mode 100644
index 00000000..a55032a4
--- /dev/null
+++ b/stm/proofBlockDelimiter.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* Goal.goal -> Goal.goal list -> bool
+val is_focused_goal_simple : Stateid.t -> [ `Simple of Goal.goal list | `Not ]
+
+type 'a until = [ `Stop | `Found of Stm.static_block_declaration | `Cont of 'a ]
+
+(* Simpler function to crawl the document backward to detect the block.
+ * ?init is the entry point of the document view if not given *)
+val crawl :
+ Stm.document_view -> ?init:Stm.document_node option ->
+ ('a -> Stm.document_node -> 'a until) -> 'a ->
+ Stm.static_block_declaration option
+
+(* Dummy value for static_block_declaration when no real value is needed *)
+val unit_val : Stm.DynBlockData.t
+
+(* Bullets *)
+val of_bullet_val : Vernacexpr.bullet -> Stm.DynBlockData.t
+val to_bullet_val : Stm.DynBlockData.t -> Vernacexpr.bullet
+
diff --git a/stm/spawned.ml b/stm/spawned.ml
index c6df8726..c5bd5f6f 100644
--- a/stm/spawned.ml
+++ b/stm/spawned.ml
@@ -13,19 +13,6 @@ let prerr_endline s = if !Flags.debug then begin pr_err s end else ()
type chandescr = AnonPipe | Socket of string * int * int
-let handshake cin cout =
- try
- match input_value cin with
- | Hello(v, pid) when v = proto_version ->
- prerr_endline (Printf.sprintf "Handshake with %d OK" pid);
- output_value cout (Hello (proto_version,Unix.getpid ())); flush cout
- | _ -> raise (Failure "handshake protocol")
- with
- | Failure s | Invalid_argument s | Sys_error s ->
- pr_err ("Handshake failed: " ^ s); raise (Failure "handshake")
- | End_of_file ->
- pr_err "Handshake failed: End_of_file"; raise (Failure "handshake")
-
let open_bin_connection h pr pw =
let open Unix in
let _, cout = open_connection (ADDR_INET (inet_addr_of_string h,pr)) in
@@ -59,7 +46,7 @@ let control_channel = ref None
let channels = ref None
let init_channels () =
- if !channels <> None then Errors.anomaly(Pp.str "init_channels called twice");
+ if !channels <> None then CErrors.anomaly(Pp.str "init_channels called twice");
let () = match !main_channel with
| None -> ()
| Some (Socket(mh,mpr,mpw)) ->
@@ -78,7 +65,7 @@ let init_channels () =
| Some (Socket (ch, cpr, cpw)) ->
controller ch cpr cpw
| Some AnonPipe ->
- Errors.anomaly (Pp.str "control channel cannot be a pipe")
+ CErrors.anomaly (Pp.str "control channel cannot be a pipe")
let get_channels () =
match !channels with
diff --git a/stm/stm.ml b/stm/stm.ml
index d8b2de4a..b4331dc4 100644
--- a/stm/stm.ml
+++ b/stm/stm.ml
@@ -8,16 +8,21 @@
let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr
-let prerr_endline s = if false then begin pr_err s end else ()
-let prerr_debug s = if !Flags.debug then begin pr_err s end else ()
+let prerr_endline s = if false then begin pr_err (s ()) end else ()
+let prerr_debug s = if !Flags.debug then begin pr_err (s ()) end else ()
+
+(* Opening ppvernac below aliases Richpp, see PR#185 *)
+let pp_to_richpp = Richpp.richpp_of_pp
+let str_to_richpp = Richpp.richpp_of_string
open Vernacexpr
-open Errors
+open CErrors
open Pp
open Names
open Util
open Ppvernac
open Vernac_classifier
+open Feedback
module Hooks = struct
@@ -27,28 +32,25 @@ let with_fail, with_fail_hook = Hook.make ()
let state_computed, state_computed_hook = Hook.make
~default:(fun state_id ~in_cache ->
- feedback ~state_id Feedback.Processed) ()
+ feedback ~id:(State state_id) Processed) ()
let state_ready, state_ready_hook = Hook.make
~default:(fun state_id -> ()) ()
-let forward_feedback, forward_feedback_hook = Hook.make
- ~default:(function
- | { Feedback.id = Feedback.Edit edit_id; route; contents } ->
- feedback ~edit_id ~route contents
- | { Feedback.id = Feedback.State state_id; route; contents } ->
- feedback ~state_id ~route contents) ()
+let forward_feedback, forward_feedback_hook =
+ let m = Mutex.create () in
+ Hook.make ~default:(function
+ | { id = id; route; contents } ->
+ try Mutex.lock m; feedback ~id:id ~route contents; Mutex.unlock m
+ with e -> Mutex.unlock m; raise e) ()
let parse_error, parse_error_hook = Hook.make
- ~default:(function
- | Feedback.Edit edit_id -> fun loc msg ->
- feedback ~edit_id (Feedback.ErrorMsg (loc, string_of_ppcmds msg))
- | Feedback.State state_id -> fun loc msg ->
- feedback ~state_id (Feedback.ErrorMsg (loc, string_of_ppcmds msg))) ()
+ ~default:(fun id loc msg ->
+ feedback ~id (Message(Error, Some loc, pp_to_richpp msg))) ()
let execution_error, execution_error_hook = Hook.make
~default:(fun state_id loc msg ->
- feedback ~state_id (Feedback.ErrorMsg (loc, string_of_ppcmds msg))) ()
+ feedback ~id:(State state_id) (Message(Error, Some loc, pp_to_richpp msg))) ()
let unreachable_state, unreachable_state_hook = Hook.make
~default:(fun _ _ -> ()) ()
@@ -80,8 +82,28 @@ let interactive () =
let async_proofs_workers_extra_env = ref [||]
-type ast = { verbose : bool; loc : Loc.t; mutable expr : vernac_expr }
-let pr_ast { expr } = pr_vernac expr
+type aast = {
+ verbose : bool;
+ loc : Loc.t;
+ indentation : int;
+ strlen : int;
+ mutable expr : vernac_expr; (* mutable: Proof using hinted by aux file *)
+}
+let pr_ast { expr; indentation } = int indentation ++ str " " ++ pr_vernac expr
+
+let default_proof_mode () = Proof_global.get_default_proof_mode_name ()
+
+(* Commands piercing opaque *)
+let may_pierce_opaque = function
+ | { expr = VernacPrint _ } -> true
+ | { expr = VernacExtend (("Extraction",_), _) } -> true
+ | { expr = VernacExtend (("SeparateExtraction",_), _) } -> true
+ | { expr = VernacExtend (("ExtractionLibrary",_), _) } -> true
+ | { expr = VernacExtend (("RecursiveExtractionLibrary",_), _) } -> true
+ | { expr = VernacExtend (("ExtractionConstant",_), _) } -> true
+ | { expr = VernacExtend (("ExtractionInlinedConstant",_), _) } -> true
+ | { expr = VernacExtend (("ExtractionInductive",_), _) } -> true
+ | _ -> false
(* Wrapper for Vernacentries.interp to set the feedback id *)
let vernac_interp ?proof id ?route { verbose; loc; expr } =
@@ -89,34 +111,48 @@ let vernac_interp ?proof id ?route { verbose; loc; expr } =
| VernacResetName _ | VernacResetInitial | VernacBack _
| VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _
| VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true
- | VernacTime el | VernacRedirect (_,el) -> List.for_all (fun (_,e) -> internal_command e) el
+ | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> internal_command e
| _ -> false in
if internal_command expr then begin
- prerr_endline ("ignoring " ^ string_of_ppcmds(pr_vernac expr))
+ prerr_endline (fun () -> "ignoring " ^ Pp.string_of_ppcmds(pr_vernac expr))
end else begin
- set_id_for_feedback ?route (Feedback.State id);
+ set_id_for_feedback ?route (State id);
Aux_file.record_in_aux_set_at loc;
- prerr_endline ("interpreting " ^ string_of_ppcmds(pr_vernac expr));
+ prerr_endline (fun () -> "interpreting " ^ Pp.string_of_ppcmds(pr_vernac expr));
try Hooks.(call interp ?verbosely:(Some verbose) ?proof (loc, expr))
with e ->
- let e = Errors.push e in
+ let e = CErrors.push e in
iraise Hooks.(call_process_error_once e)
end
(* Wrapper for Vernac.parse_sentence to set the feedback id *)
-let vernac_parse ?newtip ?route eid s =
+let indentation_of_string s =
+ let len = String.length s in
+ let rec aux n i precise =
+ if i >= len then 0, precise, len
+ else
+ match s.[i] with
+ | ' ' | '\t' -> aux (succ n) (succ i) precise
+ | '\n' | '\r' -> aux 0 (succ i) true
+ | _ -> n, precise, len in
+ aux 0 0 false
+
+let vernac_parse ?(indlen_prev=fun() -> 0) ?newtip ?route eid s =
let feedback_id =
- if Option.is_empty newtip then Feedback.Edit eid
- else Feedback.State (Option.get newtip) in
+ if Option.is_empty newtip then Edit eid
+ else State (Option.get newtip) in
+ let indentation, precise, strlen = indentation_of_string s in
+ let indentation =
+ if precise then indentation else indlen_prev () + indentation in
set_id_for_feedback ?route feedback_id;
let pa = Pcoq.Gram.parsable (Stream.of_string s) in
Flags.with_option Flags.we_are_parsing (fun () ->
try
match Pcoq.Gram.entry_parse Pcoq.main_entry pa with
| None -> raise (Invalid_argument "vernac_parse")
- | Some ast -> ast
- with e when Errors.noncritical e ->
- let (e, info) = Errors.push e in
+ | Some (loc, ast) -> indentation, strlen, loc, ast
+ with e when CErrors.noncritical e ->
+ let (e, info) = CErrors.push e in
let loc = Option.default Loc.ghost (Loc.get_loc info) in
Hooks.(call parse_error feedback_id loc (iprint (e, info)));
iraise (e, info))
@@ -124,13 +160,13 @@ let vernac_parse ?newtip ?route eid s =
let pr_open_cur_subgoals () =
try Printer.pr_open_subgoals ()
- with Proof_global.NoCurrentProof -> str""
+ with Proof_global.NoCurrentProof -> Pp.str ""
let update_global_env () =
if Proof_global.there_are_pending_proofs () then
Proof_global.update_global_env ()
-module Vcs_ = Vcs.Make(Stateid)
+module Vcs_ = Vcs.Make(Stateid.Self)
type future_proof = Proof_global.closed_proof_output Future.computation
type proof_mode = string
type depth = int
@@ -140,22 +176,27 @@ type branch_type =
| `Proof of proof_mode * depth
| `Edit of
proof_mode * Stateid.t * Stateid.t * vernac_qed_type * Vcs_.Branch.t ]
+(* TODO 8.7 : split commands and tactics, since this type is too messy now *)
type cmd_t = {
- ctac : bool; (* is a tactic, needed by the 8.4 semantics of Undo *)
- ceff : bool; (* is a side-effecting command *)
- cast : ast;
+ ctac : bool; (* is a tactic *)
+ ceff : bool; (* is a side-effecting command in the middle of a proof *)
+ cast : aast;
cids : Id.t list;
- cqueue : [ `MainQueue | `TacQueue of cancel_switch | `QueryQueue of cancel_switch ] }
-type fork_t = ast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Id.t list
+ cblock : proof_block_name option;
+ cqueue : [ `MainQueue
+ | `TacQueue of solving_tac * anon_abstracting_tac * cancel_switch
+ | `QueryQueue of cancel_switch
+ | `SkipQueue ] }
+type fork_t = aast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Id.t list
type qed_t = {
- qast : ast;
+ qast : aast;
keep : vernac_qed_type;
mutable fproof : (future_proof * cancel_switch) option;
brname : Vcs_.Branch.t;
brinfo : branch_type Vcs_.branch_info
}
-type seff_t = ast option
-type alias_t = Stateid.t * ast
+type seff_t = aast option
+type alias_t = Stateid.t * aast
type transaction =
| Cmd of cmd_t
| Fork of fork_t
@@ -167,40 +208,69 @@ type step =
[ `Cmd of cmd_t
| `Fork of fork_t * Stateid.t option
| `Qed of qed_t * Stateid.t
- | `Sideff of [ `Ast of ast * Stateid.t | `Id of Stateid.t ]
+ | `Sideff of [ `Ast of aast * Stateid.t | `Id of Stateid.t ]
| `Alias of alias_t ]
type visit = { step : step; next : Stateid.t }
+let mkTransTac cast cblock cqueue =
+ Cmd { ctac = true; cast; cblock; cqueue; cids = []; ceff = false }
+let mkTransCmd cast cids ceff cqueue =
+ Cmd { ctac = false; cast; cblock = None; cqueue; cids; ceff }
(* Parts of the system state that are morally part of the proof state *)
let summary_pstate = [ Evarutil.meta_counter_summary_name;
- Evarutil.evar_counter_summary_name;
+ Evd.evar_counter_summary_name;
"program-tcc-table" ]
-type state = {
- system : States.state;
- proof : Proof_global.state;
- shallow : bool
+type cached_state =
+ | Empty
+ | Error of Exninfo.iexn
+ | Valid of state
+and state = { (* TODO: inline records in OCaml 4.03 *)
+ system : States.state; (* summary + libstack *)
+ proof : Proof_global.state; (* proof state *)
+ shallow : bool (* is the state trimmed down (libstack) *)
}
type branch = Vcs_.Branch.t * branch_type Vcs_.branch_info
type backup = { mine : branch; others : branch list }
-type 'vcs state_info = { (* Make private *)
- mutable n_reached : int;
- mutable n_goals : int;
- mutable state : state option;
+type 'vcs state_info = { (* TODO: Make this record private to VCS *)
+ mutable n_reached : int; (* debug cache: how many times was computed *)
+ mutable n_goals : int; (* open goals: indentation *)
+ mutable state : cached_state; (* state value *)
mutable vcs_backup : 'vcs option * backup option;
}
let default_info () =
- { n_reached = 0; n_goals = 0; state = None; vcs_backup = None,None }
+ { n_reached = 0; n_goals = 0; state = Empty; vcs_backup = None,None }
+
+module DynBlockData : Dyn.S = Dyn.Make(struct end)
+
+(* Clusters of nodes implemented as Dag properties. While Dag and Vcs impose
+ * no constraint on properties, here we impose boxes to be non overlapping.
+ * Such invariant makes sense for the current kinds of boxes (proof blocks and
+ * entire proofs) but may make no sense and dropped/refined in the future.
+ * Such invariant is useful to detect broken proof block detection code *)
+type box =
+ | ProofTask of pt
+ | ProofBlock of static_block_declaration * proof_block_name
+and pt = { (* TODO: inline records in OCaml 4.03 *)
+ lemma : Stateid.t;
+ qed : Stateid.t;
+}
+and static_block_declaration = {
+ block_start : Stateid.t;
+ block_stop : Stateid.t;
+ dynamic_switch : Stateid.t;
+ carry_on_data : DynBlockData.t;
+}
(* Functions that work on a Vcs with a specific branch type *)
module Vcs_aux : sig
- val proof_nesting : (branch_type, 't,'i) Vcs_.t -> int
+ val proof_nesting : (branch_type, 't,'i,'c) Vcs_.t -> int
val find_proof_at_depth :
- (branch_type, 't, 'i) Vcs_.t -> int ->
+ (branch_type, 't, 'i,'c) Vcs_.t -> int ->
Vcs_.Branch.t * branch_type Vcs_.branch_info
exception Expired
- val visit : (branch_type, transaction,'i) Vcs_.t -> Vcs_.Dag.node -> visit
+ val visit : (branch_type, transaction,'i,'c) Vcs_.t -> Vcs_.Dag.node -> visit
end = struct (* {{{ *)
@@ -216,7 +286,7 @@ end = struct (* {{{ *)
let find_proof_at_depth vcs pl =
try List.find (function
| _, { Vcs_.kind = `Proof(m, n) } -> Int.equal n pl
- | _, { Vcs_.kind = `Edit _ } -> anomaly(str"find_proof_at_depth")
+ | _, { Vcs_.kind = `Edit _ } -> anomaly(Pp.str "find_proof_at_depth")
| _ -> false)
(List.map (fun h -> h, Vcs_.get_branch vcs h) (Vcs_.branches vcs))
with Not_found -> failwith "find_proof_at_depth"
@@ -224,9 +294,9 @@ end = struct (* {{{ *)
exception Expired
let visit vcs id =
if Stateid.equal id Stateid.initial then
- anomaly(str"Visiting the initial state id")
+ anomaly(Pp.str "Visiting the initial state id")
else if Stateid.equal id Stateid.dummy then
- anomaly(str"Visiting the dummy state id")
+ anomaly(Pp.str "Visiting the dummy state id")
else
try
match Vcs_.Dag.from_node (Vcs_.dag vcs) id with
@@ -242,7 +312,7 @@ end = struct (* {{{ *)
| [n, Sideff (Some x); p, Noop]
| [p, Noop; n, Sideff (Some x)]-> { step = `Sideff(`Ast (x,p)); next = n }
| [n, Sideff (Some x)]-> {step = `Sideff(`Ast (x,Stateid.dummy)); next=n}
- | _ -> anomaly (str ("Malformed VCS at node "^Stateid.to_string id))
+ | _ -> anomaly (Pp.str ("Malformed VCS at node "^Stateid.to_string id))
with Not_found -> raise Expired
end (* }}} *)
@@ -264,7 +334,7 @@ module VCS : sig
pos : id;
}
- type vcs = (branch_type, transaction, vcs state_info) Vcs_.t
+ type vcs = (branch_type, transaction, vcs state_info, box) Vcs_.t
val init : id -> unit
@@ -278,30 +348,32 @@ module VCS : sig
val rewrite_merge : id -> ours:transaction -> at:id -> Branch.t -> unit
val delete_branch : Branch.t -> unit
val commit : id -> transaction -> unit
- val mk_branch_name : ast -> Branch.t
+ val mk_branch_name : aast -> Branch.t
val edit_branch : Branch.t
val branch : ?root:id -> ?pos:id -> Branch.t -> branch_type -> unit
val reset_branch : Branch.t -> id -> unit
- val reachable : id -> Vcs_.NodeSet.t
+ val reachable : id -> Stateid.Set.t
val cur_tip : unit -> id
val get_info : id -> vcs state_info
- val reached : id -> bool -> unit
+ val reached : id -> unit
val goals : id -> int -> unit
- val set_state : id -> state -> unit
- val get_state : id -> state option
+ val set_state : id -> cached_state -> unit
+ val get_state : id -> cached_state
(* cuts from start -> stop, raising Expired if some nodes are not there *)
- val slice : start:id -> stop:id -> vcs
- val nodes_in_slice : start:id -> stop:id -> Stateid.t list
+ val slice : block_start:id -> block_stop:id -> vcs
+ val nodes_in_slice : block_start:id -> block_stop:id -> Stateid.t list
- val create_cluster : id list -> qed:id -> start:id -> unit
- val cluster_of : id -> (id * id) option
- val delete_cluster_of : id -> unit
+ val create_proof_task_box : id list -> qed:id -> block_start:id -> unit
+ val create_proof_block : static_block_declaration -> string -> unit
+ val box_of : id -> box list
+ val delete_boxes_of : id -> unit
+ val proof_task_box_of : id -> pt option
val proof_nesting : unit -> int
val checkout_shallowest_proof_branch : unit -> unit
- val propagate_sideff : ast option -> unit
+ val propagate_sideff : replay:aast option -> unit
val gc : unit -> unit
@@ -317,7 +389,6 @@ end = struct (* {{{ *)
include Vcs_
exception Expired = Vcs_aux.Expired
- module StateidSet = Set.Make(Stateid)
open Printf
let print_dag vcs () =
@@ -325,21 +396,21 @@ end = struct (* {{{ *)
"stm_" ^ Str.global_replace (Str.regexp " ") "_" (System.process_id ()) in
let string_of_transaction = function
| Cmd { cast = t } | Fork (t, _,_,_) ->
- (try string_of_ppcmds (pr_ast t) with _ -> "ERR")
+ (try Pp.string_of_ppcmds (pr_ast t) with _ -> "ERR")
| Sideff (Some t) ->
sprintf "Sideff(%s)"
- (try string_of_ppcmds (pr_ast t) with _ -> "ERR")
+ (try Pp.string_of_ppcmds (pr_ast t) with _ -> "ERR")
| Sideff None -> "EnvChange"
| Noop -> " "
| Alias (id,_) -> sprintf "Alias(%s)" (Stateid.to_string id)
| Qed { qast } -> string_of_ppcmds (pr_ast qast) in
let is_green id =
match get_info vcs id with
- | Some { state = Some _ } -> true
+ | Some { state = Valid _ } -> true
| _ -> false in
let is_red id =
match get_info vcs id with
- | Some s -> Int.equal s.n_reached ~-1
+ | Some { state = Error _ } -> true
| _ -> false in
let head = current_branch vcs in
let heads =
@@ -359,8 +430,6 @@ end = struct (* {{{ *)
let edge tr =
sprintf "<%s>"
(quote (string_of_transaction tr)) in
- let ids = ref StateidSet.empty in
- let clus = Hashtbl.create 13 in
let node_info id =
match get_info vcs id with
| None -> ""
@@ -373,39 +442,71 @@ end = struct (* {{{ *)
let nodefmt oc id =
fprintf oc "%s [label=%s,style=filled,fillcolor=%s];\n"
(node id) (node_info id) (color id) in
- let add_to_clus_or_ids from cf =
- match cf with
- | None -> ids := StateidSet.add from !ids; false
- | Some c -> Hashtbl.replace clus c
- (try let n = Hashtbl.find clus c in from::n
- with Not_found -> [from]); true in
+
+ let ids = ref Stateid.Set.empty in
+ let boxes = ref [] in
+ (* Fill in *)
+ Dag.iter graph (fun from _ _ l ->
+ ids := Stateid.Set.add from !ids;
+ List.iter (fun box -> boxes := box :: !boxes)
+ (Dag.property_of graph from);
+ List.iter (fun (dest, _) ->
+ ids := Stateid.Set.add dest !ids;
+ List.iter (fun box -> boxes := box :: !boxes)
+ (Dag.property_of graph dest))
+ l);
+ boxes := CList.sort_uniquize Dag.Property.compare !boxes;
+
let oc = open_out fname_dot in
output_string oc "digraph states {\n";
Dag.iter graph (fun from cf _ l ->
- let c1 = add_to_clus_or_ids from cf in
List.iter (fun (dest, trans) ->
- let c2 = add_to_clus_or_ids dest (Dag.cluster_of graph dest) in
- fprintf oc "%s -> %s [xlabel=%s,labelfloat=%b];\n"
- (node from) (node dest) (edge trans) (c1 && c2)) l
+ fprintf oc "%s -> %s [xlabel=%s,labelfloat=true];\n"
+ (node from) (node dest) (edge trans)) l
);
- StateidSet.iter (nodefmt oc) !ids;
- Hashtbl.iter (fun c nodes ->
- fprintf oc "subgraph cluster_%s {\n" (Dag.Cluster.to_string c);
- List.iter (nodefmt oc) nodes;
- fprintf oc "color=blue; }\n"
- ) clus;
+
+ let contains b1 b2 =
+ Stateid.Set.subset
+ (Dag.Property.having_it b2) (Dag.Property.having_it b1) in
+ let same_box = Dag.Property.equal in
+ let outerboxes boxes =
+ List.filter (fun b ->
+ not (List.exists (fun b1 ->
+ not (same_box b1 b) && contains b1 b) boxes)
+ ) boxes in
+ let rec rec_print b =
+ boxes := CList.remove same_box b !boxes;
+ let sub_boxes = List.filter (contains b) (outerboxes !boxes) in
+ fprintf oc "subgraph cluster_%s {\n" (Dag.Property.to_string b);
+ List.iter rec_print sub_boxes;
+ Stateid.Set.iter (fun id ->
+ if Stateid.Set.mem id !ids then begin
+ ids := Stateid.Set.remove id !ids;
+ nodefmt oc id
+ end)
+ (Dag.Property.having_it b);
+ match Dag.Property.data b with
+ | ProofBlock ({ dynamic_switch = id }, lbl) ->
+ fprintf oc "label=\"%s (test:%s)\";\n" lbl (Stateid.to_string id);
+ fprintf oc "color=red; }\n"
+ | ProofTask _ -> fprintf oc "color=blue; }\n"
+ in
+ List.iter rec_print (outerboxes !boxes);
+ Stateid.Set.iter (nodefmt oc) !ids;
+
List.iteri (fun i (b,id) ->
let shape = if Branch.equal head b then "box3d" else "box" in
fprintf oc "b%d -> %s;\n" i (node id);
fprintf oc "b%d [shape=%s,label=\"%s\"];\n" i shape
(Branch.to_string b);
) heads;
+
output_string oc "}\n";
close_out oc;
ignore(Sys.command
("dot -Tpdf -Gcharset=latin1 " ^ fname_dot ^ " -o" ^ fname_ps))
- type vcs = (branch_type, transaction, vcs state_info) t
+ type vcs = (branch_type, transaction, vcs state_info, box) t
let vcs : vcs ref = ref (empty Stateid.dummy)
let init id =
@@ -442,13 +543,12 @@ end = struct (* {{{ *)
| Some x -> x
| None -> raise Vcs_aux.Expired
let set_state id s =
- (get_info id).state <- Some s;
+ (get_info id).state <- s;
if Flags.async_proofs_is_master () then Hooks.(call state_ready id)
let get_state id = (get_info id).state
- let reached id b =
+ let reached id =
let info = get_info id in
- if b then info.n_reached <- info.n_reached + 1
- else info.n_reached <- -1
+ info.n_reached <- info.n_reached + 1
let goals id n = (get_info id).n_goals <- n
let cur_tip () = get_branch_pos (current_branch ())
@@ -466,14 +566,14 @@ end = struct (* {{{ *)
let branch, mode = match Vcs_aux.find_proof_at_depth !vcs pl with
| h, { Vcs_.kind = `Proof (m, _) } -> h, m | _ -> assert false in
checkout branch;
- prerr_endline ("mode:" ^ mode);
+ prerr_endline (fun () -> "mode:" ^ mode);
Proof_global.activate_proof_mode mode
with Failure _ ->
checkout Branch.master;
- Proof_global.disactivate_proof_mode "Classic"
+ Proof_global.disactivate_current_proof_mode ()
(* copies the transaction on every open branch *)
- let propagate_sideff t =
+ let propagate_sideff ~replay:t =
List.iter (fun b ->
checkout b;
let id = new_node () in
@@ -482,54 +582,91 @@ end = struct (* {{{ *)
let visit id = Vcs_aux.visit !vcs id
- let nodes_in_slice ~start ~stop =
+ let nodes_in_slice ~block_start ~block_stop =
let rec aux id =
- if Stateid.equal id start then [] else
+ if Stateid.equal id block_start then [] else
match visit id with
| { next = n; step = `Cmd x } -> (id,Cmd x) :: aux n
| { next = n; step = `Alias x } -> (id,Alias x) :: aux n
| { next = n; step = `Sideff (`Ast (x,_)) } ->
(id,Sideff (Some x)) :: aux n
- | _ -> anomaly(str("Cannot slice from "^ Stateid.to_string start ^
- " to "^Stateid.to_string stop))
- in aux stop
+ | _ -> anomaly(str("Cannot slice from "^ Stateid.to_string block_start ^
+ " to "^Stateid.to_string block_stop))
+ in aux block_stop
- let slice ~start ~stop =
- let l = nodes_in_slice ~start ~stop in
+ let slice ~block_start ~block_stop =
+ let l = nodes_in_slice ~block_start ~block_stop in
let copy_info v id =
Vcs_.set_info v id
- { (get_info id) with state = None; vcs_backup = None,None } in
+ { (get_info id) with state = Empty; vcs_backup = None,None } in
let copy_info_w_state v id =
Vcs_.set_info v id { (get_info id) with vcs_backup = None,None } in
- let v = Vcs_.empty start in
- let v = copy_info v start in
+ let copy_proof_blockes v =
+ let nodes = Vcs_.Dag.all_nodes (Vcs_.dag v) in
+ let props =
+ Stateid.Set.fold (fun n pl -> Vcs_.property_of !vcs n @ pl) nodes [] in
+ let props = CList.sort_uniquize Vcs_.Dag.Property.compare props in
+ List.fold_left (fun v p ->
+ Vcs_.create_property v
+ (Stateid.Set.elements (Vcs_.Dag.Property.having_it p))
+ (Vcs_.Dag.Property.data p)) v props
+ in
+ let v = Vcs_.empty block_start in
+ let v = copy_info v block_start in
let v = List.fold_right (fun (id,tr) v ->
let v = Vcs_.commit v id tr in
let v = copy_info v id in
v) l v in
(* Stm should have reached the beginning of proof *)
- assert (not (Option.is_empty (get_info start).state));
+ assert (match (get_info block_start).state with Valid _ -> true | _ -> false);
(* We put in the new dag the most recent state known to master *)
let rec fill id =
- if (get_info id).state = None then fill (Vcs_aux.visit v id).next
- else copy_info_w_state v id in
- fill stop
-
- let nodes_in_slice ~start ~stop =
- List.rev (List.map fst (nodes_in_slice ~start ~stop))
-
- let create_cluster l ~qed ~start = vcs := create_cluster !vcs l (qed,start)
- let cluster_of id = Option.map Dag.Cluster.data (cluster_of !vcs id)
- let delete_cluster_of id =
- Option.iter (fun x -> vcs := delete_cluster !vcs x) (Vcs_.cluster_of !vcs id)
+ match (get_info id).state with
+ | Empty | Error _ -> fill (Vcs_aux.visit v id).next
+ | Valid _ -> copy_info_w_state v id in
+ let v = fill block_stop in
+ (* We put in the new dag the first state (since Qed shall run on it,
+ * see check_task_aux) *)
+ let v = copy_info_w_state v block_start in
+ copy_proof_blockes v
+
+ let nodes_in_slice ~block_start ~block_stop =
+ List.rev (List.map fst (nodes_in_slice ~block_start ~block_stop))
+
+ let topo_invariant l =
+ let all = List.fold_right Stateid.Set.add l Stateid.Set.empty in
+ List.for_all
+ (fun x ->
+ let props = property_of !vcs x in
+ let sets = List.map Dag.Property.having_it props in
+ List.for_all (fun s -> Stateid.Set.(subset s all || subset all s)) sets)
+ l
+
+ let create_proof_task_box l ~qed ~block_start:lemma =
+ if not (topo_invariant l) then anomaly (str "overlapping boxes");
+ vcs := create_property !vcs l (ProofTask { qed; lemma })
+ let create_proof_block ({ block_start; block_stop} as decl) name =
+ let l = nodes_in_slice ~block_start ~block_stop in
+ if not (topo_invariant l) then anomaly (str "overlapping boxes");
+ vcs := create_property !vcs l (ProofBlock (decl, name))
+ let box_of id = List.map Dag.Property.data (property_of !vcs id)
+ let delete_boxes_of id =
+ List.iter (fun x -> vcs := delete_property !vcs x) (property_of !vcs id)
+ let proof_task_box_of id =
+ match
+ CList.map_filter (function ProofTask x -> Some x | _ -> None) (box_of id)
+ with
+ | [] -> None
+ | [x] -> Some x
+ | _ -> anomaly (str "node with more than 1 proof task box")
let gc () =
let old_vcs = !vcs in
let new_vcs, erased_nodes = gc old_vcs in
- Vcs_.NodeSet.iter (fun id ->
+ Stateid.Set.iter (fun id ->
match (Vcs_aux.visit old_vcs id).step with
| `Qed ({ fproof = Some (_, cancel_switch) }, _)
- | `Cmd { cqueue = `TacQueue cancel_switch }
+ | `Cmd { cqueue = `TacQueue (_,_,cancel_switch) }
| `Cmd { cqueue = `QueryQueue cancel_switch } ->
cancel_switch := true
| _ -> ())
@@ -583,7 +720,10 @@ end = struct (* {{{ *)
end (* }}} *)
let state_of_id id =
- try `Valid (VCS.get_info id).state
+ try match (VCS.get_info id).state with
+ | Valid s -> `Valid (Some s)
+ | Error (e,_) -> `Error e
+ | Empty -> `Valid None
with VCS.Expired -> `Expired
@@ -603,9 +743,10 @@ module State : sig
val install_cached : Stateid.t -> unit
val is_cached : ?cache:Summary.marshallable -> Stateid.t -> bool
+ val is_cached_and_valid : ?cache:Summary.marshallable -> Stateid.t -> bool
- val exn_on : Stateid.t -> ?valid:Stateid.t -> iexn -> iexn
+ val exn_on : Stateid.t -> valid:Stateid.t -> iexn -> iexn
(* to send states across worker/master *)
type frozen_state
val get_cached : Stateid.t -> frozen_state
@@ -634,10 +775,9 @@ end = struct (* {{{ *)
States.unfreeze system; Proof_global.unfreeze proof
(* hack to make futures functional *)
- let in_t, out_t = Dyn.create "state4future"
let () = Future.set_freeze
- (fun () -> in_t (freeze_global_state `No, !cur_id))
- (fun t -> let s,i = out_t t in unfreeze_global_state s; cur_id := i)
+ (fun () -> Obj.magic (freeze_global_state `No, !cur_id))
+ (fun t -> let s,i = Obj.magic t in unfreeze_global_state s; cur_id := i)
type frozen_state = state
type proof_part =
@@ -649,51 +789,60 @@ end = struct (* {{{ *)
proof,
Summary.project_summary (States.summary_of_state system) summary_pstate
- let freeze marshallable id = VCS.set_state id (freeze_global_state marshallable)
+ let freeze marshallable id =
+ VCS.set_state id (Valid (freeze_global_state marshallable))
+ let freeze_invalid id iexn = VCS.set_state id (Error iexn)
- let is_cached ?(cache=`No) id =
+ let is_cached ?(cache=`No) id only_valid =
if Stateid.equal id !cur_id then
try match VCS.get_info id with
- | { state = None } when cache = `Yes -> freeze `No id; true
- | { state = None } when cache = `Shallow -> freeze `Shallow id; true
+ | { state = Empty } when cache = `Yes -> freeze `No id; true
+ | { state = Empty } when cache = `Shallow -> freeze `Shallow id; true
| _ -> true
with VCS.Expired -> false
else
try match VCS.get_info id with
- | { state = Some _ } -> true
- | _ -> false
+ | { state = Empty } -> false
+ | { state = Valid _ } -> true
+ | { state = Error _ } -> not only_valid
with VCS.Expired -> false
+ let is_cached_and_valid ?cache id = is_cached ?cache id true
+ let is_cached ?cache id = is_cached ?cache id false
+
let install_cached id =
- if Stateid.equal id !cur_id then () else (* optimization *)
- let s =
- match VCS.get_info id with
- | { state = Some s } -> s
- | _ -> anomaly (str "unfreezing a non existing state") in
- unfreeze_global_state s; cur_id := id
+ match VCS.get_info id with
+ | { state = Valid s } ->
+ if Stateid.equal id !cur_id then () (* optimization *)
+ else begin unfreeze_global_state s; cur_id := id end
+ | { state = Error ie } -> cur_id := id; Exninfo.iraise ie
+ | _ ->
+ (* coqc has a 1 slot cache and only for valid states *)
+ if interactive () = `No && Stateid.equal id !cur_id then ()
+ else anomaly (str "installing a non cached state")
let get_cached id =
try match VCS.get_info id with
- | { state = Some s } -> s
+ | { state = Valid s } -> s
| _ -> anomaly (str "not a cached state")
with VCS.Expired -> anomaly (str "not a cached state (expired)")
let assign id what =
- if VCS.get_state id <> None then () else
+ if VCS.get_state id <> Empty then () else
try match what with
| `Full s ->
let s =
try
let prev = (VCS.visit id).next in
- if is_cached prev
+ if is_cached_and_valid prev
then { s with proof =
Proof_global.copy_terminators
~src:(get_cached prev).proof ~tgt:s.proof }
else s
with VCS.Expired -> s in
- VCS.set_state id s
+ VCS.set_state id (Valid s)
| `Proof(ontop,(pstate,counters)) ->
- if is_cached ontop then
+ if is_cached_and_valid ontop then
let s = get_cached ontop in
let s = { s with proof =
Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in
@@ -702,17 +851,17 @@ end = struct (* {{{ *)
(Summary.surgery_summary
(States.summary_of_state s.system)
counters) } in
- VCS.set_state id s
+ VCS.set_state id (Valid s)
with VCS.Expired -> ()
- let exn_on id ?valid (e, info) =
+ let exn_on id ~valid (e, info) =
match Stateid.get info with
| Some _ -> (e, info)
| None ->
let loc = Option.default Loc.ghost (Loc.get_loc info) in
let (e, info) = Hooks.(call_process_error_once (e, info)) in
Hooks.(call execution_error id loc (iprint (e, info)));
- (e, Stateid.add info ?valid id)
+ (e, Stateid.add info ~valid id)
let same_env { system = s1 } { system = s2 } =
let s1 = States.summary_of_state s1 in
@@ -724,12 +873,12 @@ end = struct (* {{{ *)
let define ?safe_id ?(redefine=false) ?(cache=`No) ?(feedback_processed=true)
f id
=
- feedback ~state_id:id Feedback.(ProcessingIn !Flags.async_proofs_worker_id);
+ feedback ~id:(State id) (ProcessingIn !Flags.async_proofs_worker_id);
let str_id = Stateid.to_string id in
if is_cached id && not redefine then
anomaly (str"defining state "++str str_id++str" twice");
try
- prerr_endline("defining "^str_id^" (cache="^
+ prerr_endline (fun () -> "defining "^str_id^" (cache="^
if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)");
let good_id = match safe_id with None -> !cur_id | Some id -> id in
fix_exn_ref := exn_on id ~valid:good_id;
@@ -737,24 +886,27 @@ end = struct (* {{{ *)
fix_exn_ref := (fun x -> x);
if cache = `Yes then freeze `No id
else if cache = `Shallow then freeze `Shallow id;
- prerr_endline ("setting cur id to "^str_id);
+ prerr_endline (fun () -> "setting cur id to "^str_id);
cur_id := id;
if feedback_processed then
Hooks.(call state_computed id ~in_cache:false);
- VCS.reached id true;
+ VCS.reached id;
if Proof_global.there_are_pending_proofs () then
VCS.goals id (Proof_global.get_open_goals ())
with e ->
- let (e, info) = Errors.push e in
+ let (e, info) = CErrors.push e in
let good_id = !cur_id in
cur_id := Stateid.dummy;
- VCS.reached id false;
- Hooks.(call unreachable_state id (e, info));
- match Stateid.get info, safe_id with
- | None, None -> iraise (exn_on id ~valid:good_id (e, info))
- | None, Some good_id -> iraise (exn_on id ~valid:good_id (e, info))
- | Some _, None -> iraise (e, info)
- | Some (_,at), Some id -> iraise (e, Stateid.add info ~valid:id at)
+ VCS.reached id;
+ let ie =
+ match Stateid.get info, safe_id with
+ | None, None -> (exn_on id ~valid:good_id (e, info))
+ | None, Some good_id -> (exn_on id ~valid:good_id (e, info))
+ | Some _, None -> (e, info)
+ | Some (_,at), Some id -> (e, Stateid.add info ~valid:id at) in
+ if cache = `Yes || cache = `Shallow then freeze_invalid id ie;
+ Hooks.(call unreachable_state id ie);
+ Exninfo.iraise ie
end (* }}} *)
@@ -830,7 +982,7 @@ end = struct (* {{{ *)
let back_safe () =
let id =
fold_until (fun n (id,_,_,_,_) ->
- if n >= 0 && State.is_cached id then `Stop id else `Cont (succ n))
+ if n >= 0 && State.is_cached_and_valid id then `Stop id else `Cont (succ n))
0 (VCS.get_branch_pos (VCS.current_branch ())) in
backto id
@@ -840,8 +992,6 @@ end = struct (* {{{ *)
| VernacResetInitial ->
VtStm (VtBack Stateid.initial, true), VtNow
| VernacResetName (_,name) ->
- msg_warning
- (str"Reset not implemented for automatically generated constants");
let id = VCS.get_branch_pos (VCS.current_branch ()) in
(try
let oid =
@@ -891,8 +1041,8 @@ end = struct (* {{{ *)
| _ -> VtUnknown, VtNow
with
| Not_found ->
- msg_warning(str"undo_vernac_classifier: going back to the initial state.");
- VtStm (VtBack Stateid.initial, true), VtNow
+ CErrors.errorlabstrm "undo_vernac_classifier"
+ (str "Cannot undo")
end (* }}} *)
@@ -925,10 +1075,78 @@ let record_pb_time proof_name loc time =
end
exception RemoteException of std_ppcmds
-let _ = Errors.register_handler (function
+let _ = CErrors.register_handler (function
| RemoteException ppcmd -> ppcmd
| _ -> raise Unhandled)
+(****************** proof structure for error recovery ************************)
+(******************************************************************************)
+
+type document_node = {
+ indentation : int;
+ ast : Vernacexpr.vernac_expr;
+ id : Stateid.t;
+}
+
+type document_view = {
+ entry_point : document_node;
+ prev_node : document_node -> document_node option;
+}
+
+type static_block_detection =
+ document_view -> static_block_declaration option
+
+type recovery_action = {
+ base_state : Stateid.t;
+ goals_to_admit : Goal.goal list;
+ recovery_command : Vernacexpr.vernac_expr option;
+}
+
+type dynamic_block_error_recovery =
+ static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ]
+
+let proof_block_delimiters = ref []
+
+let register_proof_block_delimiter name static dynamic =
+ if List.mem_assoc name !proof_block_delimiters then
+ CErrors.errorlabstrm "STM" (str "Duplicate block delimiter " ++ str name);
+ proof_block_delimiters := (name, (static,dynamic)) :: !proof_block_delimiters
+
+let mk_doc_node id = function
+ | { step = `Cmd { ctac; cast = { indentation; expr }}; next } when ctac ->
+ Some { indentation; ast = expr; id }
+ | { step = `Sideff (`Ast ({ indentation; expr }, _)); next } ->
+ Some { indentation; ast = expr; id }
+ | _ -> None
+let prev_node { id } =
+ let id = (VCS.visit id).next in
+ mk_doc_node id (VCS.visit id)
+let cur_node id = mk_doc_node id (VCS.visit id)
+
+let is_block_name_enabled name =
+ match !Flags.async_proofs_tac_error_resilience with
+ | `None -> false
+ | `All -> true
+ | `Only l -> List.mem name l
+
+let detect_proof_block id name =
+ let name = match name with None -> "indent" | Some x -> x in
+ if is_block_name_enabled name &&
+ (Flags.async_proofs_is_master () || Flags.async_proofs_is_worker ())
+ then (
+ match cur_node id with
+ | None -> ()
+ | Some entry_point -> try
+ let static, _ = List.assoc name !proof_block_delimiters in
+ begin match static { prev_node; entry_point } with
+ | None -> ()
+ | Some ({ block_start; block_stop } as decl) ->
+ VCS.create_proof_block decl name
+ end
+ with Not_found ->
+ CErrors.errorlabstrm "STM"
+ (str "Unknown proof block delimiter " ++ str name)
+ )
(****************************** THE SCHEDULER *********************************)
(******************************************************************************)
@@ -1034,7 +1252,7 @@ end = struct (* {{{ *)
try Some (ReqBuildProof ({
Stateid.exn_info = t_exn_info;
stop = t_stop;
- document = VCS.slice ~start:t_start ~stop:t_stop;
+ document = VCS.slice ~block_start:t_start ~block_stop:t_stop;
loc = t_loc;
uuid = t_uuid;
name = t_name }, t_drop, t_states))
@@ -1046,7 +1264,7 @@ end = struct (* {{{ *)
List.iter (fun (id,s) -> State.assign id s) l; `End
| `Fresh, BuildProof { t_assign; t_loc; t_name; t_states; t_drop },
RespBuiltProof (pl, time) ->
- feedback (Feedback.InProgress ~-1);
+ feedback (InProgress ~-1);
t_assign (`Val pl);
record_pb_time t_name t_loc time;
if !Flags.async_proofs_full || t_drop
@@ -1054,7 +1272,7 @@ end = struct (* {{{ *)
else `End
| `Fresh, BuildProof { t_assign; t_loc; t_name; t_states },
RespError { e_error_at; e_safe_id = valid; e_msg; e_safe_states } ->
- feedback (Feedback.InProgress ~-1);
+ feedback (InProgress ~-1);
let info = Stateid.add ~valid Exninfo.null e_error_at in
let e = (RemoteException e_msg, info) in
t_assign (`Exn e);
@@ -1070,7 +1288,7 @@ end = struct (* {{{ *)
let e = (RemoteException (strbrk s), info) in
t_assign (`Exn e);
Hooks.(call execution_error start Loc.ghost (strbrk s));
- feedback (Feedback.InProgress ~-1)
+ feedback (InProgress ~-1)
let build_proof_here ~drop_pt (id,valid) loc eop =
Future.create (State.exn_on id ~valid) (fun () ->
@@ -1081,7 +1299,7 @@ end = struct (* {{{ *)
Aux_file.record_in_aux_at loc "proof_build_time"
(Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1));
let p = Proof_global.return_proof ~allow_partial:drop_pt () in
- if drop_pt then Pp.feedback ~state_id:id Feedback.Complete;
+ if drop_pt then feedback ~id:(State id) Complete;
p)
let perform_buildp { Stateid.exn_info; stop; document; loc } drop my_states =
@@ -1105,30 +1323,31 @@ end = struct (* {{{ *)
Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in
vernac_interp stop
~proof:(pobject, terminator)
- { verbose = false; loc;
+ { verbose = false; loc; indentation = 0; strlen = 0;
expr = (VernacEndProof (Proved (Opaque None,None))) }) in
ignore(Future.join checked_proof);
end;
RespBuiltProof(proof,time)
with
- | e when Errors.noncritical e || e = Stack_overflow ->
- let (e, info) = Errors.push e in
+ | e when CErrors.noncritical e || e = Stack_overflow ->
+ let (e, info) = CErrors.push e in
(* This can happen if the proof is broken. The error has also been
* signalled as a feedback, hence we can silently recover *)
let e_error_at, e_safe_id = match Stateid.get info with
| Some (safe, err) -> err, safe
| None -> Stateid.dummy, Stateid.dummy in
let e_msg = iprint (e, info) in
- prerr_endline "failed with the following exception:";
- prerr_endline (string_of_ppcmds e_msg);
- let e_safe_states = List.filter State.is_cached my_states in
+ prerr_endline (fun () -> "failed with the following exception:");
+ prerr_endline (fun () -> string_of_ppcmds e_msg);
+ let e_safe_states = List.filter State.is_cached_and_valid my_states in
RespError { e_error_at; e_safe_id; e_msg; e_safe_states }
let perform_states query =
if query = [] then [] else
- let is_tac = function
- | VernacSolve _ | VernacFocus _ | VernacUnfocus | VernacBullet _ -> true
- | _ -> false in
+ let is_tac e = match classify_vernac e with
+ | VtProofStep _, _ -> true
+ | _ -> false
+ in
let initial =
let rec aux id =
try match VCS.visit id with { next } -> aux next
@@ -1138,19 +1357,19 @@ end = struct (* {{{ *)
let prev =
try
let { next = prev; step } = VCS.visit id in
- if State.is_cached prev && List.mem prev seen
+ if State.is_cached_and_valid prev && List.mem prev seen
then Some (prev, State.get_cached prev, step)
else None
with VCS.Expired -> None in
let this =
- if State.is_cached id then Some (State.get_cached id) else None in
+ if State.is_cached_and_valid id then Some (State.get_cached id) else None in
match prev, this with
| _, None -> None
| Some (prev, o, `Cmd { cast = { expr }}), Some n
when is_tac expr && State.same_env o n -> (* A pure tactic *)
Some (id, `Proof (prev, State.proof_part_of_frozen n))
| Some _, Some s ->
- msg_warning (str "STM: sending back a fat state");
+ msg_debug (str "STM: sending back a fat state");
Some (id, `Full s)
| _, Some s -> Some (id, `Full s) in
let rec aux seen = function
@@ -1173,7 +1392,7 @@ end = struct (* {{{ *)
"The system state could not be sent to the worker process. "^
"Falling back to local, lazy, evaluation."));
t_assign(`Comp(build_proof_here ~drop_pt t_exn_info t_loc t_stop));
- feedback (Feedback.InProgress ~-1)
+ feedback (InProgress ~-1)
end (* }}} *)
@@ -1183,7 +1402,7 @@ and Slaves : sig
(* (eventually) remote calls *)
val build_proof :
loc:Loc.t -> drop_pt:bool ->
- exn_info:(Stateid.t * Stateid.t) -> start:Stateid.t -> stop:Stateid.t ->
+ exn_info:(Stateid.t * Stateid.t) -> block_start:Stateid.t -> block_stop:Stateid.t ->
name:string -> future_proof * cancel_switch
(* blocking function that waits for the task queue to be empty *)
@@ -1221,8 +1440,8 @@ end = struct (* {{{ *)
let check_task_aux extra name l i =
let { Stateid.stop; document; loc; name = r_name }, drop = List.nth l i in
- msg_info(
- str(Printf.sprintf "Checking task %d (%s%s) of %s" i r_name extra name));
+ Flags.if_verbose msg_info
+ (str(Printf.sprintf "Checking task %d (%s%s) of %s" i r_name extra name));
VCS.restore document;
let start =
let rec aux cur =
@@ -1245,15 +1464,15 @@ end = struct (* {{{ *)
* looking at the ones that happen to be present in the current env *)
Reach.known_state ~cache:`No start;
vernac_interp stop ~proof
- { verbose = false; loc;
+ { verbose = false; loc; indentation = 0; strlen = 0;
expr = (VernacEndProof (Proved (Opaque None,None))) };
`OK proof
end
with e ->
- let (e, info) = Errors.push e in
+ let (e, info) = CErrors.push e in
(try match Stateid.get info with
| None ->
- pperrnl (
+ msg_error (
str"File " ++ str name ++ str ": proof of " ++ str r_name ++
spc () ++ iprint (e, info))
| Some (_, cur) ->
@@ -1263,12 +1482,12 @@ end = struct (* {{{ *)
| { step = `Qed ( { qast = { loc } }, _) }
| { step = `Sideff (`Ast ( { loc }, _)) } ->
let start, stop = Loc.unloc loc in
- pperrnl (
+ msg_error (
str"File " ++ str name ++ str ": proof of " ++ str r_name ++
str ": chars " ++ int start ++ str "-" ++ int stop ++
spc () ++ iprint (e, info))
| _ ->
- pperrnl (
+ msg_error (
str"File " ++ str name ++ str ": proof of " ++ str r_name ++
spc () ++ iprint (e, info))
with e ->
@@ -1328,7 +1547,6 @@ end = struct (* {{{ *)
let set_perspective idl =
ProofTask.set_perspective idl;
TaskQueue.broadcast (Option.get !queue);
- let open Stateid in
let open ProofTask in
let overlap s1 s2 =
List.exists (fun x -> CList.mem_f Stateid.equal x s2) s1 in
@@ -1343,7 +1561,7 @@ end = struct (* {{{ *)
BuildProof { t_states = s2 } -> overlap_rel s1 s2
| _ -> 0)
- let build_proof ~loc ~drop_pt ~exn_info ~start ~stop ~name:pname =
+ let build_proof ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name:pname =
let id, valid as t_exn_info = exn_info in
let cancel_switch = ref false in
if TaskQueue.n_workers (Option.get !queue) = 0 then
@@ -1352,21 +1570,21 @@ end = struct (* {{{ *)
Future.create_delegate ~blocking:true ~name:pname (State.exn_on id ~valid) in
let t_uuid = Future.uuid f in
let task = ProofTask.(BuildProof {
- t_exn_info; t_start = start; t_stop = stop; t_drop = drop_pt;
+ t_exn_info; t_start = block_start; t_stop = block_stop; t_drop = drop_pt;
t_assign = assign; t_loc = loc; t_uuid; t_name = pname;
- t_states = VCS.nodes_in_slice ~start ~stop }) in
+ t_states = VCS.nodes_in_slice ~block_start ~block_stop }) in
TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch);
f, cancel_switch
end else
- ProofTask.build_proof_here ~drop_pt t_exn_info loc stop, cancel_switch
+ ProofTask.build_proof_here ~drop_pt t_exn_info loc block_stop, cancel_switch
else
let f, t_assign = Future.create_delegate ~name:pname (State.exn_on id ~valid) in
let t_uuid = Future.uuid f in
- feedback (Feedback.InProgress 1);
+ feedback (InProgress 1);
let task = ProofTask.(BuildProof {
- t_exn_info; t_start = start; t_stop = stop; t_assign; t_drop = drop_pt;
+ t_exn_info; t_start = block_start; t_stop = block_stop; t_assign; t_drop = drop_pt;
t_loc = loc; t_uuid; t_name = pname;
- t_states = VCS.nodes_in_slice ~start ~stop }) in
+ t_states = VCS.nodes_in_slice ~block_start ~block_stop }) in
TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch);
f, cancel_switch
@@ -1385,7 +1603,7 @@ end = struct (* {{{ *)
| Some (ReqBuildProof (r, b, _)) -> Some(r, b)
| _ -> None)
tasks in
- prerr_endline (Printf.sprintf "dumping %d tasks\n" (List.length reqs));
+ prerr_endline (fun () -> Printf.sprintf "dumping %d tasks\n" (List.length reqs));
reqs
let reset_task_queue () = TaskQueue.clear (Option.get !queue)
@@ -1399,10 +1617,11 @@ and TacTask : sig
t_state : Stateid.t;
t_state_fb : Stateid.t;
t_assign : output Future.assignement -> unit;
- t_ast : ast;
+ t_ast : int * aast;
t_goal : Goal.goal;
t_kill : unit -> unit;
t_name : string }
+ exception NoProgress
include AsyncTaskQueue.Task with type task := task
@@ -1416,7 +1635,7 @@ end = struct (* {{{ *)
t_state : Stateid.t;
t_state_fb : Stateid.t;
t_assign : output Future.assignement -> unit;
- t_ast : ast;
+ t_ast : int * aast;
t_goal : Goal.goal;
t_kill : unit -> unit;
t_name : string }
@@ -1425,13 +1644,15 @@ end = struct (* {{{ *)
r_state : Stateid.t;
r_state_fb : Stateid.t;
r_document : VCS.vcs option;
- r_ast : ast;
+ r_ast : int * aast;
r_goal : Goal.goal;
r_name : string }
type response =
| RespBuiltSubProof of output
| RespError of std_ppcmds
+ | RespNoProgress
+ exception NoProgress
let name = ref "tacworker"
let extra_env () = [||]
@@ -1445,7 +1666,7 @@ end = struct (* {{{ *)
r_state_fb = t_state_fb;
r_document =
if age <> `Fresh then None
- else Some (VCS.slice ~start:t_state ~stop:t_state);
+ else Some (VCS.slice ~block_start:t_state ~block_stop:t_state);
r_ast = t_ast;
r_goal = t_goal;
r_name = t_name }
@@ -1454,9 +1675,13 @@ end = struct (* {{{ *)
let use_response _ { t_assign; t_state; t_state_fb; t_kill } resp =
match resp with
| RespBuiltSubProof o -> t_assign (`Val o); `Stay ((),[])
+ | RespNoProgress ->
+ let e = (NoProgress, Exninfo.null) in
+ t_assign (`Exn e);
+ t_kill ();
+ `Stay ((),[])
| RespError msg ->
- let info = Stateid.add ~valid:t_state Exninfo.null t_state_fb in
- let e = (RemoteException msg, info) in
+ let e = (RemoteException msg, Exninfo.null) in
t_assign (`Exn e);
t_kill ();
`Stay ((),[])
@@ -1469,36 +1694,37 @@ end = struct (* {{{ *)
| Some { t_kill } -> t_kill ()
| _ -> ()
+ let command_focus = Proof.new_focus_kind ()
+ let focus_cond = Proof.no_cond command_focus
+
let perform { r_state = id; r_state_fb; r_document = vcs; r_ast; r_goal } =
Option.iter VCS.restore vcs;
try
Reach.known_state ~cache:`No id;
- let t, uc = Future.purify (fun () ->
+ Future.purify (fun () ->
let _,_,_,_,sigma0 = Proof.proof (Proof_global.give_me_the_proof ()) in
let g = Evd.find sigma0 r_goal in
if not (
Evarutil.is_ground_term sigma0 Evd.(evar_concl g) &&
- List.for_all (fun (_,bo,ty) ->
- Evarutil.is_ground_term sigma0 ty &&
- Option.cata (Evarutil.is_ground_term sigma0) true bo)
- Evd.(evar_context g))
+ List.for_all (Context.Named.Declaration.for_all (Evarutil.is_ground_term sigma0))
+ Evd.(evar_context g))
then
- Errors.errorlabstrm "Stm" (strbrk("the par: goal selector supports ground "^
+ CErrors.errorlabstrm "STM" (strbrk("the par: goal selector supports ground "^
"goals only"))
else begin
- vernac_interp r_state_fb r_ast;
+ let (i, ast) = r_ast in
+ Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p);
+ vernac_interp r_state_fb ast;
let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in
match Evd.(evar_body (find sigma r_goal)) with
- | Evd.Evar_empty -> Errors.errorlabstrm "Stm" (str "no progress")
+ | Evd.Evar_empty -> RespNoProgress
| Evd.Evar_defined t ->
let t = Evarutil.nf_evar sigma t in
if Evarutil.is_ground_term sigma t then
- t, Evd.evar_universe_context sigma
- else Errors.errorlabstrm "Stm" (str"The solution is not ground")
+ RespBuiltSubProof (t, Evd.evar_universe_context sigma)
+ else CErrors.errorlabstrm "STM" (str"The solution is not ground")
end) ()
- in
- RespBuiltSubProof (t,uc)
- with e when Errors.noncritical e -> RespError (Errors.print e)
+ with e when CErrors.noncritical e -> RespError (CErrors.print e)
let name_of_task { t_name } = t_name
let name_of_request { r_name } = r_name
@@ -1508,19 +1734,22 @@ end (* }}} *)
and Partac : sig
val vernac_interp :
- cancel_switch -> int -> Stateid.t -> Stateid.t -> ast -> unit
+ solve:bool -> abstract:bool -> cancel_switch ->
+ int -> Stateid.t -> Stateid.t -> aast ->
+ unit
end = struct (* {{{ *)
module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask)
- let vernac_interp cancel nworkers safe_id id { verbose; loc; expr = e } =
- let e, etac, time, fail =
+ let vernac_interp ~solve ~abstract cancel nworkers safe_id id
+ { indentation; verbose; loc; expr = e; strlen }
+ =
+ let e, time, fail =
let rec find time fail = function
- | VernacSolve(_,_,re,b) -> re, b, time, fail
- | VernacTime [_,e] | VernacRedirect (_,[_,e]) -> find true fail e
+ | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> find true fail e
| VernacFail e -> find time true e
- | _ -> errorlabstrm "Stm" (str"unsupported") in find false false e in
+ | _ -> e, time, fail in find false false e in
Hooks.call Hooks.with_fail fail (fun () ->
(if time then System.with_time false else (fun x -> x)) (fun () ->
ignore(TaskQueue.with_n_workers nworkers (fun queue ->
@@ -1532,51 +1761,58 @@ end = struct (* {{{ *)
Future.create_delegate
~name:(Printf.sprintf "subgoal %d" i)
(State.exn_on id ~valid:safe_id) in
- let t_ast =
- { verbose;loc;expr = VernacSolve(SelectNth i,None,e,etac) } in
+ let t_ast = (i, { indentation; verbose; loc; expr = e; strlen }) in
let t_name = Goal.uid g in
TaskQueue.enqueue_task queue
({ t_state = safe_id; t_state_fb = id;
t_assign = assign; t_ast; t_goal = g; t_name;
- t_kill = (fun () -> TaskQueue.cancel_all queue) }, cancel);
- Goal.uid g,f)
+ t_kill = (fun () -> if solve then TaskQueue.cancel_all queue) },
+ cancel);
+ g,f)
1 goals in
TaskQueue.join queue;
let assign_tac : unit Proofview.tactic =
- Proofview.V82.tactic (fun gl ->
- let open Tacmach in
- let sigma, g = project gl, sig_it gl in
- let gid = Goal.uid g in
- let f =
- try List.assoc gid res
- with Not_found -> Errors.anomaly(str"Partac: wrong focus") in
- if Future.is_over f then
+ Proofview.(Goal.nf_enter { Goal.enter = fun g ->
+ let gid = Goal.goal g in
+ let f =
+ try List.assoc gid res
+ with Not_found -> CErrors.anomaly(str"Partac: wrong focus") in
+ if not (Future.is_over f) then
+ (* One has failed and cancelled the others, but not this one *)
+ if solve then Tacticals.New.tclZEROMSG
+ (str"Interrupted by the failure of another goal")
+ else tclUNIT ()
+ else
+ let open Notations in
+ try
let pt, uc = Future.join f in
- prerr_endline (string_of_ppcmds(hov 0 (
- str"g=" ++ str gid ++ spc () ++
+ prerr_endline (fun () -> string_of_ppcmds(hov 0 (
+ str"g=" ++ int (Evar.repr gid) ++ spc () ++
str"t=" ++ (Printer.pr_constr pt) ++ spc () ++
str"uc=" ++ Evd.pr_evar_universe_context uc)));
- let sigma = Goal.V82.partial_solution sigma g pt in
- let sigma = Evd.merge_universe_context sigma uc in
- re_sig [] sigma
- else (* One has failed and cancelled the others, but not this one *)
- re_sig [g] sigma) in
+ (if abstract then Tactics.tclABSTRACT None else (fun x -> x))
+ (V82.tactic (Refiner.tclPUSHEVARUNIVCONTEXT uc) <*>
+ Tactics.exact_no_check pt)
+ with TacTask.NoProgress ->
+ if solve then Tacticals.New.tclSOLVE [] else tclUNIT ()
+ })
+ in
Proof.run_tactic (Global.env()) assign_tac p)))) ())
end (* }}} *)
and QueryTask : sig
- type task = { t_where : Stateid.t; t_for : Stateid.t ; t_what : ast }
+ type task = { t_where : Stateid.t; t_for : Stateid.t ; t_what : aast }
include AsyncTaskQueue.Task with type task := task
end = struct (* {{{ *)
type task =
- { t_where : Stateid.t; t_for : Stateid.t ; t_what : ast }
+ { t_where : Stateid.t; t_for : Stateid.t ; t_what : aast }
type request =
- { r_where : Stateid.t ; r_for : Stateid.t ; r_what : ast; r_doc : VCS.vcs }
+ { r_where : Stateid.t ; r_for : Stateid.t ; r_what : aast; r_doc : VCS.vcs }
type response = unit
let name = ref "queryworker"
@@ -1588,7 +1824,7 @@ end = struct (* {{{ *)
try Some {
r_where = t_where;
r_for = t_for;
- r_doc = VCS.slice ~start:t_where ~stop:t_where;
+ r_doc = VCS.slice ~block_start:t_where ~block_stop:t_where;
r_what = t_what }
with VCS.Expired -> None
@@ -1608,11 +1844,11 @@ end = struct (* {{{ *)
Reach.known_state ~cache:`No r_where;
try
vernac_interp r_for { r_what with verbose = true };
- feedback ~state_id:r_for Feedback.Processed
- with e when Errors.noncritical e ->
- let e = Errors.push e in
- let msg = string_of_ppcmds (iprint e) in
- feedback ~state_id:r_for (Feedback.ErrorMsg (Loc.ghost, msg))
+ feedback ~id:(State r_for) Processed
+ with e when CErrors.noncritical e ->
+ let e = CErrors.push e in
+ let msg = pp_to_richpp (iprint e) in
+ feedback ~id:(State r_for) (Message (Error, None, msg))
let name_of_task { t_what } = string_of_ppcmds (pr_ast t_what)
let name_of_request { r_what } = string_of_ppcmds (pr_ast r_what)
@@ -1622,7 +1858,7 @@ end (* }}} *)
and Query : sig
val init : unit -> unit
- val vernac_interp : cancel_switch -> Stateid.t -> Stateid.t -> ast -> unit
+ val vernac_interp : cancel_switch -> Stateid.t -> Stateid.t -> aast -> unit
end = struct (* {{{ *)
@@ -1633,7 +1869,7 @@ end = struct (* {{{ *)
let vernac_interp switch prev id q =
assert(TaskQueue.n_workers (Option.get !queue) > 0);
TaskQueue.enqueue_task (Option.get !queue)
- QueryTask.({ QueryTask.t_where = prev; t_for = id; t_what = q }, switch)
+ QueryTask.({ t_where = prev; t_for = id; t_what = q }, switch)
let init () = queue := Some (TaskQueue.create
(if !Flags.async_proofs_full then 1 else 0))
@@ -1659,12 +1895,18 @@ let async_policy () =
(!compilation_mode = BuildVio || !async_proofs_mode <> APoff)
let delegate name =
- let time = get_hint_bp_time name in
- time >= 1.0 || !Flags.compilation_mode = Flags.BuildVio
- || !Flags.async_proofs_full
+ get_hint_bp_time name >= !Flags.async_proofs_delegation_threshold
+ || !Flags.compilation_mode = Flags.BuildVio
+ || !Flags.async_proofs_full
+
+let warn_deprecated_nested_proofs =
+ CWarnings.create ~name:"deprecated-nested-proofs" ~category:"deprecated"
+ (fun () ->
+ strbrk ("Nested proofs are deprecated and will "^
+ "stop working in a future Coq version"))
let collect_proof keep cur hd brkind id =
- prerr_endline ("Collecting proof ending at "^Stateid.to_string id);
+ prerr_endline (fun () -> "Collecting proof ending at "^Stateid.to_string id);
let no_name = "" in
let name = function
| [] -> no_name
@@ -1684,16 +1926,20 @@ let collect_proof keep cur hd brkind id =
let has_proof_no_using = function
| Some (_, { expr = VernacProof(_,None) }) -> true
| _ -> false in
- let may_pierce_opaque = function
- | { expr = VernacPrint (PrintName _) } -> true
- | _ -> false in
+ let too_complex_to_delegate = function
+ | { expr = (VernacDeclareModule _
+ | VernacDefineModule _
+ | VernacDeclareModuleType _
+ | VernacInclude _) } -> true
+ | { expr = (VernacRequire _ | VernacImport _) } -> true
+ | ast -> may_pierce_opaque ast in
let parent = function Some (p, _) -> p | None -> assert false in
let is_empty = function `Async(_,_,[],_,_) | `MaybeASync(_,_,[],_,_) -> true | _ -> false in
let rec collect last accn id =
let view = VCS.visit id in
match view.step with
| (`Sideff (`Ast(x,_)) | `Cmd { cast = x })
- when may_pierce_opaque x -> `Sync(no_name,None,`Print)
+ when too_complex_to_delegate x -> `Sync(no_name,None,`Print)
| `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next
| `Sideff (`Ast(x,_)) -> collect (Some (id,x)) (id::accn) view.next
(* An Alias could jump everywhere... we hope we can ignore it*)
@@ -1707,7 +1953,7 @@ let collect_proof keep cur hd brkind id =
let name = name ids in
`ASync (parent last,proof_using_ast last,accn,name,delegate name)
| `Fork((_, hd', GuaranteesOpacity, ids), _) when
- has_proof_no_using last && not (State.is_cached (parent last)) &&
+ has_proof_no_using last && not (State.is_cached_and_valid (parent last)) &&
!Flags.compilation_mode = Flags.BuildVio ->
assert (VCS.Branch.equal hd hd'||VCS.Branch.equal hd VCS.edit_branch);
(try
@@ -1723,8 +1969,7 @@ let collect_proof keep cur hd brkind id =
let name = name ids in
`MaybeASync (parent last, None, accn, name, delegate name)
| `Sideff _ ->
- Pp.(msg_warning (strbrk ("Nested proofs are deprecated and will "^
- "stop working in the next Coq version")));
+ warn_deprecated_nested_proofs ();
`Sync (no_name,None,`NestedProof)
| _ -> `Sync (no_name,None,`Unknown) in
let make_sync why = function
@@ -1743,7 +1988,7 @@ let collect_proof keep cur hd brkind id =
let rc = collect (Some cur) [] id in
if is_empty rc then make_sync `AlreadyEvaluated rc
else if (keep == VtKeep || keep == VtKeepAsAxiom) &&
- (not(State.is_cached id) || !Flags.async_proofs_full)
+ (not(State.is_cached_and_valid id) || !Flags.async_proofs_full)
then check_policy rc
else make_sync `AlreadyEvaluated rc
@@ -1761,7 +2006,7 @@ let string_of_reason = function
| `NoPU_NoHint_NoES -> "no 'Proof using..', no .aux file, inside a section"
| `Unknown -> "unsupported case"
-let log_string s = prerr_debug ("STM: " ^ s)
+let log_string s = prerr_debug (fun () -> "STM: " ^ s)
let log_processing_async id name = log_string Printf.(sprintf
"%s: proof %s: asynch" (Stateid.to_string id) name
)
@@ -1773,6 +2018,71 @@ let log_processing_sync id name reason = log_string Printf.(sprintf
let wall_clock_last_fork = ref 0.0
let known_state ?(redefine_qed=false) ~cache id =
+
+ let error_absorbing_tactic id blockname exn =
+ (* We keep the static/dynamic part of block detection separate, since
+ the static part could be performed earlier. As of today there is
+ no advantage in doing so since no UI can exploit such piece of info *)
+ detect_proof_block id blockname;
+
+ let boxes = VCS.box_of id in
+ let valid_boxes = CList.map_filter (function
+ | ProofBlock ({ block_stop } as decl, name) when Stateid.equal block_stop id ->
+ Some (decl, name)
+ | _ -> None) boxes in
+ assert(List.length valid_boxes < 2);
+ if valid_boxes = [] then iraise exn
+ else
+ let decl, name = List.hd valid_boxes in
+ try
+ let _, dynamic_check = List.assoc name !proof_block_delimiters in
+ match dynamic_check decl with
+ | `Leaks -> iraise exn
+ | `ValidBlock { base_state; goals_to_admit; recovery_command } -> begin
+ let tac =
+ let open Proofview.Notations in
+ Proofview.Goal.nf_enter { enter = fun gl ->
+ if CList.mem_f Evar.equal
+ (Proofview.Goal.goal gl) goals_to_admit then
+ Proofview.give_up else Proofview.tclUNIT ()
+ } in
+ match (VCS.get_info base_state).state with
+ | Valid { proof } ->
+ Proof_global.unfreeze proof;
+ Proof_global.with_current_proof (fun _ p ->
+ feedback ~id:(State id) Feedback.AddedAxiom;
+ fst (Pfedit.solve Vernacexpr.SelectAll None tac p), ());
+ Option.iter (fun expr -> vernac_interp id {
+ verbose = true; loc = Loc.ghost; expr; indentation = 0;
+ strlen = 0 })
+ recovery_command
+ | _ -> assert false
+ end
+ with Not_found ->
+ CErrors.errorlabstrm "STM"
+ (str "Unknown proof block delimiter " ++ str name)
+ in
+
+ (* Absorb tactic errors from f () *)
+ let resilient_tactic id blockname f =
+ if !Flags.async_proofs_tac_error_resilience = `None ||
+ (Flags.async_proofs_is_master () &&
+ !Flags.async_proofs_mode = Flags.APoff)
+ then f ()
+ else
+ try f ()
+ with e when CErrors.noncritical e ->
+ let ie = CErrors.push e in
+ error_absorbing_tactic id blockname ie in
+ (* Absorb errors from f x *)
+ let resilient_command f x =
+ if not !Flags.async_proofs_cmd_error_resilience ||
+ (Flags.async_proofs_is_master () &&
+ !Flags.async_proofs_mode = Flags.APoff)
+ then f x
+ else
+ try f x
+ with e when CErrors.noncritical e -> () in
(* ugly functions to process nested lemmas, i.e. hard to reproduce
* side effects *)
@@ -1782,18 +2092,18 @@ let known_state ?(redefine_qed=false) ~cache id =
let inject_non_pstate (s,l) =
Summary.unfreeze_summary s; Lib.unfreeze l; update_global_env ()
in
- let rec pure_cherry_pick_non_pstate id = Future.purify (fun id ->
- prerr_endline ("cherry-pick non pstate " ^ Stateid.to_string id);
- reach id;
+ let rec pure_cherry_pick_non_pstate safe_id id = Future.purify (fun id ->
+ prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id);
+ reach ~safe_id id;
cherry_pick_non_pstate ()) id
(* traverses the dag backward from nodes being already calculated *)
- and reach ?(redefine_qed=false) ?(cache=cache) id =
- prerr_endline ("reaching: " ^ Stateid.to_string id);
+ and reach ?safe_id ?(redefine_qed=false) ?(cache=cache) id =
+ prerr_endline (fun () -> "reaching: " ^ Stateid.to_string id);
if not redefine_qed && State.is_cached ~cache id then begin
- State.install_cached id;
Hooks.(call state_computed id ~in_cache:true);
- prerr_endline ("reached (cache)")
+ prerr_endline (fun () -> "reached (cache)");
+ State.install_cached id
end else
let step, cache_step, feedback_processed =
let view = VCS.visit id in
@@ -1801,46 +2111,58 @@ let known_state ?(redefine_qed=false) ~cache id =
| `Alias (id,_) -> (fun () ->
reach view.next; reach id
), cache, true
- | `Cmd { cast = x; cqueue = `TacQueue cancel } -> (fun () ->
- reach ~cache:`Shallow view.next;
- Hooks.(call tactic_being_run true);
- Partac.vernac_interp
- cancel !Flags.async_proofs_n_tacworkers view.next id x;
- Hooks.(call tactic_being_run false)
+ | `Cmd { cast = x; cqueue = `SkipQueue } -> (fun () ->
+ reach view.next), cache, true
+ | `Cmd { cast = x; cqueue = `TacQueue (solve,abstract,cancel); cblock } ->
+ (fun () ->
+ resilient_tactic id cblock (fun () ->
+ reach ~cache:`Shallow view.next;
+ Hooks.(call tactic_being_run true);
+ Partac.vernac_interp ~solve ~abstract
+ cancel !Flags.async_proofs_n_tacworkers view.next id x;
+ Hooks.(call tactic_being_run false))
), cache, true
| `Cmd { cast = x; cqueue = `QueryQueue cancel }
when Flags.async_proofs_is_master () -> (fun () ->
reach view.next;
Query.vernac_interp cancel view.next id x
), cache, false
- | `Cmd { cast = x; ceff = eff; ctac } -> (fun () ->
- reach view.next;
- if ctac then Hooks.(call tactic_being_run true);
+ | `Cmd { cast = x; ceff = eff; ctac = true; cblock } -> (fun () ->
+ resilient_tactic id cblock (fun () ->
+ reach view.next;
+ Hooks.(call tactic_being_run true);
+ vernac_interp id x;
+ Hooks.(call tactic_being_run false));
+ if eff then update_global_env ()
+ ), (if eff then `Yes else cache), true
+ | `Cmd { cast = x; ceff = eff } -> (fun () ->
+ resilient_command reach view.next;
vernac_interp id x;
- if ctac then Hooks.(call tactic_being_run false);
- if eff then update_global_env ()), cache, true
+ if eff then update_global_env ()
+ ), (if eff then `Yes else cache), true
| `Fork ((x,_,_,_), None) -> (fun () ->
- reach view.next; vernac_interp id x;
+ resilient_command reach view.next;
+ vernac_interp id x;
wall_clock_last_fork := Unix.gettimeofday ()
), `Yes, true
- | `Fork ((x,_,_,_), Some prev) -> (fun () ->
+ | `Fork ((x,_,_,_), Some prev) -> (fun () -> (* nested proof *)
reach ~cache:`Shallow prev;
reach view.next;
(try vernac_interp id x;
- with e when Errors.noncritical e ->
- let (e, info) = Errors.push e in
+ with e when CErrors.noncritical e ->
+ let (e, info) = CErrors.push e in
let info = Stateid.add info ~valid:prev id in
iraise (e, info));
wall_clock_last_fork := Unix.gettimeofday ()
), `Yes, true
| `Qed ({ qast = x; keep; brinfo; brname } as qed, eop) ->
let rec aux = function
- | `ASync (start, pua, nodes, name, delegate) -> (fun () ->
+ | `ASync (block_start, pua, nodes, name, delegate) -> (fun () ->
assert(keep == VtKeep || keep == VtKeepAsAxiom);
let drop_pt = keep == VtKeepAsAxiom in
- let stop, exn_info, loc = eop, (id, eop), x.loc in
+ let block_stop, exn_info, loc = eop, (id, eop), x.loc in
log_processing_async id name;
- VCS.create_cluster nodes ~qed:id ~start;
+ VCS.create_proof_task_box nodes ~qed:id ~block_start;
begin match brinfo, qed.fproof with
| { VCS.kind = `Edit _ }, None -> assert false
| { VCS.kind = `Edit (_,_,_, okeep, _) }, Some (ofp, cancel) ->
@@ -1854,19 +2176,22 @@ let known_state ?(redefine_qed=false) ~cache id =
^"the proof's statement to avoid that."));
let fp, cancel =
Slaves.build_proof
- ~loc ~drop_pt ~exn_info ~start ~stop ~name in
+ ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name in
Future.replace ofp fp;
- qed.fproof <- Some (fp, cancel)
+ qed.fproof <- Some (fp, cancel);
+ (* We don't generate a new state, but we still need
+ * to install the right one *)
+ State.install_cached id
| { VCS.kind = `Proof _ }, Some _ -> assert false
| { VCS.kind = `Proof _ }, None ->
- reach ~cache:`Shallow start;
+ reach ~cache:`Shallow block_start;
let fp, cancel =
if delegate then
Slaves.build_proof
- ~loc ~drop_pt ~exn_info ~start ~stop ~name
+ ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name
else
ProofTask.build_proof_here
- ~drop_pt exn_info loc stop, ref false
+ ~drop_pt exn_info loc block_stop, ref false
in
qed.fproof <- Some (fp, cancel);
let proof =
@@ -1874,7 +2199,7 @@ let known_state ?(redefine_qed=false) ~cache id =
if not delegate then ignore(Future.compute fp);
reach view.next;
vernac_interp id ~proof x;
- feedback ~state_id:id Feedback.Incomplete
+ feedback ~id:(State id) Incomplete
| { VCS.kind = `Master }, _ -> assert false
end;
Proof_global.discard_all ()
@@ -1921,15 +2246,15 @@ let known_state ?(redefine_qed=false) ~cache id =
), cache, true
| `Sideff (`Id origin) -> (fun () ->
reach view.next;
- inject_non_pstate (pure_cherry_pick_non_pstate origin);
+ inject_non_pstate (pure_cherry_pick_non_pstate view.next origin);
), cache, true
in
let cache_step =
if !Flags.async_proofs_cache = Some Flags.Force then `Yes
else cache_step in
- State.define
+ State.define ?safe_id
~cache:cache_step ~redefine:redefine_qed ~feedback_processed step id;
- prerr_endline ("reached: "^ Stateid.to_string id) in
+ prerr_endline (fun () -> "reached: "^ Stateid.to_string id) in
reach ~redefine_qed id
end (* }}} *)
@@ -1944,7 +2269,7 @@ let init () =
Backtrack.record ();
Slaves.init ();
if Flags.async_proofs_is_master () then begin
- prerr_endline "Initializing workers";
+ prerr_endline (fun () -> "Initializing workers");
Query.init ();
let opts = match !Flags.async_proofs_private_flags with
| None -> []
@@ -1963,7 +2288,7 @@ let observe id =
Reach.known_state ~cache:(interactive ()) id;
VCS.print ()
with e ->
- let e = Errors.push e in
+ let e = CErrors.push e in
VCS.print ();
VCS.restore vcs;
iraise e
@@ -1996,9 +2321,9 @@ let rec join_admitted_proofs id =
let join () =
finish ();
wait ();
- prerr_endline "Joining the environment";
+ prerr_endline (fun () -> "Joining the environment");
Global.join_safe_environment ();
- prerr_endline "Joining Admitted proofs";
+ prerr_endline (fun () -> "Joining Admitted proofs");
join_admitted_proofs (VCS.get_branch_pos (VCS.current_branch ()));
VCS.print ();
VCS.print ()
@@ -2011,28 +2336,26 @@ let check_task name (tasks,rcbackup) i =
let vcs = VCS.backup () in
try
let rc = Future.purify (Slaves.check_task name tasks) i in
- pperr_flush ();
VCS.restore vcs;
rc
- with e when Errors.noncritical e -> VCS.restore vcs; false
+ with e when CErrors.noncritical e -> VCS.restore vcs; false
let info_tasks (tasks,_) = Slaves.info_tasks tasks
let finish_tasks name u d p (t,rcbackup as tasks) =
RemoteCounter.restore rcbackup;
let finish_task u (_,_,i) =
let vcs = VCS.backup () in
let u = Future.purify (Slaves.finish_task name u d p t) i in
- pperr_flush ();
VCS.restore vcs;
u in
try
let u, a, _ = List.fold_left finish_task u (info_tasks tasks) in
(u,a,true), p
with e ->
- let e = Errors.push e in
- pperrnl (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e);
+ let e = CErrors.push e in
+ msg_error (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e);
exit 1
-let merge_proof_branch ?valid ?id qast keep brname =
+let merge_proof_branch ~valid ?id qast keep brname =
let brinfo = VCS.get_branch brname in
let qed fproof = { qast; keep; brname; brinfo; fproof } in
match brinfo with
@@ -2041,7 +2364,7 @@ let merge_proof_branch ?valid ?id qast keep brname =
let id = VCS.new_node ?id () in
VCS.merge id ~ours:(Qed (qed None)) brname;
VCS.delete_branch brname;
- if keep <> VtDrop then VCS.propagate_sideff None;
+ VCS.propagate_sideff None;
`Ok
| { VCS.kind = `Edit (mode, qed_id, master_id, _,_) } ->
let ofp =
@@ -2055,12 +2378,12 @@ let merge_proof_branch ?valid ?id qast keep brname =
VCS.checkout VCS.Branch.master;
`Unfocus qed_id
| { VCS.kind = `Master } ->
- iraise (State.exn_on ?valid Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null))
+ iraise (State.exn_on ~valid Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null))
(* When tty is true, this code also does some of the job of the user interface:
jump back to a state that is valid *)
let handle_failure (e, info) vcs tty =
- if e = Errors.Drop then iraise (e, info) else
+ if e = CErrors.Drop then iraise (e, info) else
match Stateid.get info with
| None ->
VCS.restore vcs;
@@ -2072,9 +2395,9 @@ let handle_failure (e, info) vcs tty =
end;
VCS.print ();
anomaly(str"error with no safe_id attached:" ++ spc() ++
- Errors.iprint_no_report (e, info))
+ CErrors.iprint_no_report (e, info))
| Some (safe_id, id) ->
- prerr_endline ("Failed at state " ^ Stateid.to_string id);
+ prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id);
VCS.restore vcs;
if tty && interactive () = `Yes then begin
(* We stay on a valid state *)
@@ -2085,38 +2408,37 @@ let handle_failure (e, info) vcs tty =
VCS.print ();
iraise (e, info)
-let snapshot_vio ldir long_f_dot_v =
+let snapshot_vio ldir long_f_dot_vo =
finish ();
if List.length (VCS.branches ()) > 1 then
- Errors.errorlabstrm "stm" (str"Cannot dump a vio with open proofs");
- Library.save_library_to ~todo:(dump_snapshot ()) ldir long_f_dot_v
+ CErrors.errorlabstrm "stm" (str"Cannot dump a vio with open proofs");
+ Library.save_library_to ~todo:(dump_snapshot ()) ldir long_f_dot_vo
(Global.opaque_tables ())
let reset_task_queue = Slaves.reset_task_queue
(* Document building *)
-let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
- let warn_if_pos a b =
- if b then msg_warning(pr_ast a ++ str" should not be part of a script") in
- let v, x = expr, { verbose = verbose; loc; expr } in
- prerr_endline ("{{{ processing: "^ string_of_ppcmds (pr_ast x));
+let process_transaction ?(newtip=Stateid.fresh ()) ~tty
+ ({ verbose; loc; expr } as x) c =
+ prerr_endline (fun () -> "{{{ processing: "^ string_of_ppcmds (pr_ast x));
let vcs = VCS.backup () in
try
let head = VCS.current_branch () in
VCS.checkout head;
let rc = begin
- prerr_endline (" classified as: " ^ string_of_vernac_classification c);
+ prerr_endline (fun () ->
+ " classified as: " ^ string_of_vernac_classification c);
match c with
(* PG stuff *)
| VtStm(VtPG,false), VtNow -> vernac_interp Stateid.dummy x; `Ok
| VtStm(VtPG,_), _ -> anomaly(str "PG command in script or VtLater")
(* Joining various parts of the document *)
- | VtStm (VtJoinDocument, b), VtNow -> warn_if_pos x b; join (); `Ok
- | VtStm (VtFinish, b), VtNow -> warn_if_pos x b; finish (); `Ok
- | VtStm (VtWait, b), VtNow -> warn_if_pos x b; finish (); wait (); `Ok
+ | VtStm (VtJoinDocument, b), VtNow -> join (); `Ok
+ | VtStm (VtFinish, b), VtNow -> finish (); `Ok
+ | VtStm (VtWait, b), VtNow -> finish (); wait (); `Ok
| VtStm (VtPrintDag, b), VtNow ->
- warn_if_pos x b; VCS.print ~now:true (); `Ok
- | VtStm (VtObserve id, b), VtNow -> warn_if_pos x b; observe id; `Ok
+ VCS.print ~now:true (); `Ok
+ | VtStm (VtObserve id, b), VtNow -> observe id; `Ok
| VtStm ((VtObserve _ | VtFinish | VtJoinDocument
|VtPrintDag |VtWait),_), VtLater ->
anomaly(str"classifier: join actions cannot be classified as VtLater")
@@ -2125,9 +2447,10 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
| VtStm (VtBack oid, true), w ->
let id = VCS.new_node ~id:newtip () in
let { mine; others } = Backtrack.branches_of oid in
+ let valid = VCS.get_branch_pos head in
List.iter (fun branch ->
if not (List.mem_assoc branch (mine::others)) then
- ignore(merge_proof_branch x VtDrop branch))
+ ignore(merge_proof_branch ~valid x VtDrop branch))
(VCS.branches ());
VCS.checkout_shallowest_proof_branch ();
let head = VCS.current_branch () in
@@ -2141,7 +2464,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
VCS.commit id (Alias (oid,x));
Backtrack.record (); if w == VtNow then finish (); `Ok
| VtStm (VtBack id, false), VtNow ->
- prerr_endline ("undo to state " ^ Stateid.to_string id);
+ prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id);
Backtrack.backto id;
VCS.checkout_shallowest_proof_branch ();
Reach.known_state ~cache:(interactive ()) id; `Ok
@@ -2152,22 +2475,26 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
| VtQuery (false,(report_id,route)), VtNow when tty = true ->
finish ();
(try Future.purify (vernac_interp report_id ~route)
- { verbose = true; loc; expr }
- with e when Errors.noncritical e ->
- let e = Errors.push e in
- iraise (State.exn_on report_id e)); `Ok
+ {x with verbose = true }
+ with e when CErrors.noncritical e ->
+ let e = CErrors.push e in
+ iraise (State.exn_on ~valid:Stateid.dummy report_id e)); `Ok
| VtQuery (false,(report_id,route)), VtNow ->
(try vernac_interp report_id ~route x
with e ->
- let e = Errors.push e in
- iraise (State.exn_on report_id e)); `Ok
+ let e = CErrors.push e in
+ iraise (State.exn_on ~valid:Stateid.dummy report_id e)); `Ok
| VtQuery (true,(report_id,_)), w ->
assert(Stateid.equal report_id Stateid.dummy);
let id = VCS.new_node ~id:newtip () in
let queue =
if !Flags.async_proofs_full then `QueryQueue (ref false)
+ else if Flags.(!compilation_mode = BuildVio) &&
+ VCS.((get_branch head).kind = `Master) &&
+ may_pierce_opaque x
+ then `SkipQueue
else `MainQueue in
- VCS.commit id (Cmd {ctac=false;ceff=false;cast = x; cids = []; cqueue = queue });
+ VCS.commit id (mkTransCmd x [] false queue);
Backtrack.record (); if w == VtNow then finish (); `Ok
| VtQuery (false,_), VtLater ->
anomaly(str"classifier: VtQuery + VtLater must imply part_of_script")
@@ -2190,7 +2517,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
anomaly(str"VtProofMode must be executed VtNow")
| VtProofMode mode, VtNow ->
let id = VCS.new_node ~id:newtip () in
- VCS.commit id (Cmd {ctac=false;ceff=false;cast = x;cids=[];cqueue = `MainQueue});
+ VCS.commit id (mkTransCmd x [] false `MainQueue);
List.iter
(fun bn -> match VCS.get_branch bn with
| { VCS.root; kind = `Master; pos } -> ()
@@ -2205,14 +2532,21 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
Backtrack.record ();
finish ();
`Ok
- | VtProofStep paral, w ->
+ | VtProofStep { parallel; proof_block_detection = cblock }, w ->
let id = VCS.new_node ~id:newtip () in
- let queue = if paral then `TacQueue (ref false) else `MainQueue in
- VCS.commit id (Cmd {ctac = true;ceff = false;cast = x;cids = [];cqueue = queue });
+ let queue =
+ match parallel with
+ | `Yes(solve,abstract) -> `TacQueue (solve, abstract, ref false)
+ | `No -> `MainQueue in
+ VCS.commit id (mkTransTac x cblock queue);
+ (* Static proof block detection delayed until an error really occurs.
+ If/when and UI will make something useful with this piece of info,
+ detection should occur here.
+ detect_proof_block id cblock; *)
Backtrack.record (); if w == VtNow then finish (); `Ok
| VtQed keep, w ->
- let valid = if tty then Some(VCS.get_branch_pos head) else None in
- let rc = merge_proof_branch ?valid ~id:newtip x keep head in
+ let valid = VCS.get_branch_pos head in
+ let rc = merge_proof_branch ~valid ~id:newtip x keep head in
VCS.checkout_shallowest_proof_branch ();
Backtrack.record (); if w == VtNow then finish ();
rc
@@ -2222,15 +2556,22 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
vernac_interp (VCS.get_branch_pos head) x; `Ok
| VtSideff l, w ->
+ let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in
let id = VCS.new_node ~id:newtip () in
VCS.checkout VCS.Branch.master;
- VCS.commit id (Cmd {ctac=false;ceff=true;cast=x;cids=l;cqueue=`MainQueue});
- VCS.propagate_sideff (Some x);
+ VCS.commit id (mkTransCmd x l in_proof `MainQueue);
+ (* We can't replay a Definition since universes may be differently
+ * inferred. This holds in Coq >= 8.5 *)
+ let replay = match x.expr with
+ | VernacDefinition(_, _, DefineBody _) -> None
+ | _ -> Some x in
+ VCS.propagate_sideff ~replay;
VCS.checkout_shallowest_proof_branch ();
Backtrack.record (); if w == VtNow then finish (); `Ok
(* Unknown: we execute it, check for open goals and propagate sideeff *)
| VtUnknown, VtNow ->
+ let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in
let id = VCS.new_node ~id:newtip () in
let head_id = VCS.get_branch_pos head in
Reach.known_state ~cache:`Yes head_id; (* ensure it is ok *)
@@ -2240,17 +2581,22 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
Reach.known_state ~cache:(interactive ()) mid;
vernac_interp id x;
(* Vernac x may or may not start a proof *)
- if VCS.Branch.equal head VCS.Branch.master &&
- Proof_global.there_are_pending_proofs ()
- then begin
+ if not in_proof && Proof_global.there_are_pending_proofs () then
+ begin
let bname = VCS.mk_branch_name x in
- VCS.commit id (Fork (x,bname,Doesn'tGuaranteeOpacity,[]));
- VCS.branch bname (`Proof ("Classic", VCS.proof_nesting () + 1));
- Proof_global.activate_proof_mode "Classic";
+ let opacity_of_produced_term =
+ match x.expr with
+ (* This AST is ambiguous, hence we check it dynamically *)
+ | VernacInstance (false, _,_ , None, _) -> GuaranteesOpacity
+ | _ -> Doesn'tGuaranteeOpacity in
+ VCS.commit id (Fork (x,bname,opacity_of_produced_term,[]));
+ let proof_mode = default_proof_mode () in
+ VCS.branch bname (`Proof (proof_mode, VCS.proof_nesting () + 1));
+ Proof_global.activate_proof_mode proof_mode;
end else begin
- VCS.commit id (Cmd {ctac = false; ceff = true;
- cast = x; cids = []; cqueue = `MainQueue});
- VCS.propagate_sideff (Some x);
+ VCS.commit id (mkTransCmd x [] in_proof `MainQueue);
+ (* We hope it can be replayed, but we can't really know *)
+ VCS.propagate_sideff ~replay:(Some x);
VCS.checkout_shallowest_proof_branch ();
end in
State.define ~safe_id:head_id ~cache:`Yes step id;
@@ -2260,49 +2606,56 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
anomaly(str"classifier: VtUnknown must imply VtNow")
end in
(* Proof General *)
- begin match v with
+ begin match expr with
| VernacStm (PGLast _) ->
if not (VCS.Branch.equal head VCS.Branch.master) then
vernac_interp Stateid.dummy
- { verbose = true; loc = Loc.ghost;
+ { verbose = true; loc = Loc.ghost; indentation = 0; strlen = 0;
expr = VernacShow (ShowGoal OpenSubgoals) }
| _ -> ()
end;
- prerr_endline "processed }}}";
+ prerr_endline (fun () -> "processed }}}");
VCS.print ();
rc
with e ->
- let e = Errors.push e in
+ let e = CErrors.push e in
handle_failure e vcs tty
-let print_ast id =
- try
- match VCS.visit id with
- | { step = `Cmd { cast = { loc; expr } } }
- | { step = `Fork (({ loc; expr }, _, _, _), _) }
- | { step = `Qed ({ qast = { loc; expr } }, _) } ->
- let xml =
- try Texmacspp.tmpp expr loc
- with e -> Xml_datatype.PCData ("ERROR " ^ Printexc.to_string e) in
- xml;
- | _ -> Xml_datatype.PCData "ERROR"
- with _ -> Xml_datatype.PCData "ERROR"
+let get_ast id =
+ match VCS.visit id with
+ | { step = `Cmd { cast = { loc; expr } } }
+ | { step = `Fork (({ loc; expr }, _, _, _), _) }
+ | { step = `Qed ({ qast = { loc; expr } }, _) } ->
+ Some (expr, loc)
+ | _ -> None
let stop_worker n = Slaves.cancel_worker n
+(* You may need to know the len + indentation of previous command to compute
+ * the indentation of the current one.
+ * Eg. foo. bar.
+ * Here bar is indented of the indentation of foo + its strlen (4) *)
+let ind_len_of id =
+ if Stateid.equal id Stateid.initial then 0
+ else match (VCS.visit id).step with
+ | `Cmd { ctac = true; cast = { indentation; strlen } } ->
+ indentation + strlen
+ | _ -> 0
+
let add ~ontop ?newtip ?(check=ignore) verb eid s =
let cur_tip = VCS.cur_tip () in
- if Stateid.equal ontop cur_tip then begin
- let _, ast as loc_ast = vernac_parse ?newtip eid s in
- check(loc_ast);
- let clas = classify_vernac ast in
- match process_transaction ?newtip ~tty:false verb clas loc_ast with
- | `Ok -> VCS.cur_tip (), `NewTip
- | `Unfocus qed_id -> qed_id, `Unfocus (VCS.cur_tip ())
- end else begin
+ if not (Stateid.equal ontop cur_tip) then
(* For now, arbitrary edits should be announced with edit_at *)
- anomaly(str"Not yet implemented, the GUI should not try this")
- end
+ anomaly(str"Not yet implemented, the GUI should not try this");
+ let indentation, strlen, loc, ast =
+ vernac_parse ~indlen_prev:(fun () -> ind_len_of ontop) ?newtip eid s in
+ CWarnings.set_current_loc loc;
+ check(loc,ast);
+ let clas = classify_vernac ast in
+ let aast = { verbose = verb; indentation; strlen; loc; expr = ast } in
+ match process_transaction ?newtip ~tty:false aast clas with
+ | `Ok -> VCS.cur_tip (), `NewTip
+ | `Unfocus qed_id -> qed_id, `Unfocus (VCS.cur_tip ())
let set_perspective id_list = Slaves.set_perspective id_list
@@ -2312,20 +2665,21 @@ type focus = {
tip : Stateid.t
}
-let query ~at ?(report_with=(Stateid.dummy,Feedback.default_route)) s =
+let query ~at ?(report_with=(Stateid.dummy,default_route)) s =
Future.purify (fun s ->
if Stateid.equal at Stateid.dummy then finish ()
else Reach.known_state ~cache:`Yes at;
let newtip, route = report_with in
- let _, ast as loc_ast = vernac_parse ~newtip ~route 0 s in
+ let indentation, strlen, loc, ast = vernac_parse ~newtip ~route 0 s in
+ CWarnings.set_current_loc loc;
let clas = classify_vernac ast in
+ let aast = { verbose = true; indentation; strlen; loc; expr = ast } in
match clas with
| VtStm (w,_), _ ->
- ignore(process_transaction
- ~tty:false true (VtStm (w,false), VtNow) loc_ast)
+ ignore(process_transaction ~tty:false aast (VtStm (w,false), VtNow))
| _ ->
ignore(process_transaction
- ~tty:false true (VtQuery (false,report_with), VtNow) loc_ast))
+ ~tty:false aast (VtQuery (false,report_with), VtNow)))
s
let edit_at id =
@@ -2350,7 +2704,7 @@ let edit_at id =
| _ -> assert false
in
let is_ancestor_of_cur_branch id =
- Vcs_.NodeSet.mem id
+ Stateid.Set.mem id
(VCS.reachable (VCS.get_branch_pos (VCS.current_branch ()))) in
let has_failed qed_id =
match VCS.visit qed_id with
@@ -2365,13 +2719,13 @@ let edit_at id =
| { next } -> master_for_br root next in
let reopen_branch start at_id mode qed_id tip old_branch =
let master_id, cancel_switch, keep =
- (* Hum, this should be the real start_id in the clusted and not next *)
+ (* Hum, this should be the real start_id in the cluster and not next *)
match VCS.visit qed_id with
| { step = `Qed ({ fproof = Some (_,cs); keep },_) } -> start, cs, keep
- | _ -> anomaly (str "Cluster not ending with Qed") in
+ | _ -> anomaly (str "ProofTask not ending with Qed") in
VCS.branch ~root:master_id ~pos:id
VCS.edit_branch (`Edit (mode, qed_id, master_id, keep, old_branch));
- VCS.delete_cluster_of id;
+ VCS.delete_boxes_of id;
cancel_switch := true;
Reach.known_state ~cache:(interactive ()) id;
VCS.checkout_shallowest_proof_branch ();
@@ -2385,14 +2739,14 @@ let edit_at id =
let { mine = brname, brinfo; others } = Backtrack.branches_of id in
List.iter (fun (name,{ VCS.kind = k; root; pos }) ->
if not(VCS.Branch.equal name VCS.Branch.master) &&
- Vcs_.NodeSet.mem root ancestors then
+ Stateid.Set.mem root ancestors then
VCS.branch ~root ~pos name k)
others;
VCS.reset_branch VCS.Branch.master (master_for_br brinfo.VCS.root id);
VCS.branch ~root:brinfo.VCS.root ~pos:brinfo.VCS.pos
(Option.default brname bn)
(no_edit brinfo.VCS.kind);
- VCS.delete_cluster_of id;
+ VCS.delete_boxes_of id;
VCS.gc ();
VCS.print ();
if not !Flags.async_proofs_full then
@@ -2407,14 +2761,14 @@ let edit_at id =
| Some{ mine = bn, { VCS.kind = `Proof(m,_) }} -> Some(m,bn)
| Some{ mine = _, { VCS.kind = `Edit(m,_,_,_,bn) }} -> Some (m,bn)
| _ -> None in
- match focused, VCS.cluster_of id, branch_info with
+ match focused, VCS.proof_task_box_of id, branch_info with
| _, Some _, None -> assert false
- | false, Some (qed_id,start), Some(mode,bn) ->
+ | false, Some { qed = qed_id ; lemma = start }, Some(mode,bn) ->
let tip = VCS.cur_tip () in
if has_failed qed_id && is_pure qed_id && not !Flags.async_proofs_never_reopen_branch
then reopen_branch start id mode qed_id tip bn
else backto id (Some bn)
- | true, Some (qed_id,_), Some(mode,bn) ->
+ | true, Some { qed = qed_id }, Some(mode,bn) ->
if on_cur_branch id then begin
assert false
end else if is_ancestor_of_cur_branch id then begin
@@ -2439,14 +2793,14 @@ let edit_at id =
VCS.print ();
rc
with e ->
- let (e, info) = Errors.push e in
+ let (e, info) = CErrors.push e in
match Stateid.get info with
| None ->
VCS.print ();
anomaly (str ("edit_at "^Stateid.to_string id^": ") ++
- Errors.print_no_report e)
+ CErrors.print_no_report e)
| Some (_, id) ->
- prerr_endline ("Failed at state " ^ Stateid.to_string id);
+ prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id);
VCS.restore vcs;
VCS.print ();
iraise (e, info)
@@ -2457,9 +2811,10 @@ let restore d = VCS.restore d
(*********************** TTY API (PG, coqtop, coqc) ***************************)
(******************************************************************************)
-let interp verb (_,e as lexpr) =
+let interp verb (loc,e) =
let clas = classify_vernac e in
- let rc = process_transaction ~tty:true verb clas lexpr in
+ let aast = { verbose = verb; indentation = 0; strlen = 0; loc; expr = e } in
+ let rc = process_transaction ~tty:true aast clas in
if rc <> `Ok then anomaly(str"tty loop can't be mixed with the STM protocol");
if interactive () = `Yes ||
(!Flags.async_proofs_mode = Flags.APoff &&
@@ -2472,7 +2827,7 @@ let interp verb (_,e as lexpr) =
| _ -> not !Flags.coqtop_ui in
try finish ~print_goals ()
with e ->
- let e = Errors.push e in
+ let e = CErrors.push e in
handle_failure e vcs true
let finish () = finish ()
diff --git a/stm/stm.mli b/stm/stm.mli
index ad89eb71..b8a2a385 100644
--- a/stm/stm.mli
+++ b/stm/stm.mli
@@ -9,6 +9,7 @@
open Vernacexpr
open Names
open Feedback
+open Loc
(** state-transaction-machine interface *)
@@ -19,7 +20,9 @@ open Feedback
The sentence [s] is parsed in the state [ontop].
If [newtip] is provided, then the returned state id is guaranteed to be
[newtip] *)
-val add : ontop:Stateid.t -> ?newtip:Stateid.t -> ?check:(located_vernac_expr -> unit) ->
+val add :
+ ontop:Stateid.t -> ?newtip:Stateid.t ->
+ ?check:(vernac_expr located -> unit) ->
bool -> edit_id -> string ->
Stateid.t * [ `NewTip | `Unfocus of Stateid.t ]
@@ -75,7 +78,9 @@ val get_current_state : unit -> Stateid.t
(* Misc *)
val init : unit -> unit
-val print_ast : Stateid.t -> Xml_datatype.xml
+
+(* This returns the node at that position *)
+val get_ast : Stateid.t -> (Vernacexpr.vernac_expr * Loc.t) option
(* Filename *)
val set_compilation_hints : string -> unit
@@ -93,6 +98,82 @@ module ProofTask : AsyncTaskQueue.Task
module TacTask : AsyncTaskQueue.Task
module QueryTask : AsyncTaskQueue.Task
+(** document structure customization *************************************** **)
+
+(* A proof block delimiter defines a syntactic delimiter for sub proofs
+ that, when contain an error, do not impact the rest of the proof.
+ While checking a proof, if an error occurs in a (valid) block then
+ processing can skip the entire block and go on to give feedback
+ on the rest of the proof.
+
+ static_block_detection and dynamic_block_validation are run when
+ the closing block marker is parsed/executed respectively.
+
+ static_block_detection is for example called when "}" is parsed and
+ declares a block containing all proof steps between it and the matching
+ "{".
+
+ dynamic_block_validation is called when an error "crosses" the "}" statement.
+ Depending on the nature of the goal focused by "{" the block may absorb the
+ error or not. For example if the focused goal occurs in the type of
+ another goal, then the block is leaky.
+ Note that one can design proof commands that need no dynamic validation.
+
+ Example of document:
+
+ .. { tac1. tac2. } ..
+
+ Corresponding DAG:
+
+ .. (3) <-- { -- (4) <-- tac1 -- (5) <-- tac2 -- (6) <-- } -- (7) ..
+
+ Declaration of block [-------------------------------------------]
+
+ start = 5 the first state_id that could fail in the block
+ stop = 7 the node that may absorb the error
+ dynamic_switch = 4 dynamic check on this node
+ carry_on_data = () no need to carry extra data from static to dynamic
+ checks
+*)
+
+module DynBlockData : Dyn.S
+
+type static_block_declaration = {
+ block_start : Stateid.t;
+ block_stop : Stateid.t;
+ dynamic_switch : Stateid.t;
+ carry_on_data : DynBlockData.t;
+}
+
+type document_node = {
+ indentation : int;
+ ast : Vernacexpr.vernac_expr;
+ id : Stateid.t;
+}
+
+type document_view = {
+ entry_point : document_node;
+ prev_node : document_node -> document_node option;
+}
+
+type static_block_detection =
+ document_view -> static_block_declaration option
+
+type recovery_action = {
+ base_state : Stateid.t;
+ goals_to_admit : Goal.goal list;
+ recovery_command : Vernacexpr.vernac_expr option;
+}
+
+type dynamic_block_error_recovery =
+ static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ]
+
+val register_proof_block_delimiter :
+ Vernacexpr.proof_block_name ->
+ static_block_detection ->
+ dynamic_block_error_recovery ->
+ unit
+
(** customization ********************************************************** **)
(* From the master (or worker, but beware that to install the hook
@@ -119,14 +200,15 @@ type state = {
proof : Proof_global.state;
shallow : bool
}
-val state_of_id : Stateid.t -> [ `Valid of state option | `Expired ]
+val state_of_id :
+ Stateid.t -> [ `Valid of state option | `Expired | `Error of exn ]
(** read-eval-print loop compatible interface ****************************** **)
(* Adds a new line to the document. It replaces the core of Vernac.interp.
- [finish] is called as the last bit of this function is the system
+ [finish] is called as the last bit of this function if the system
is running interactively (-emacs or coqtop). *)
-val interp : bool -> located_vernac_expr -> unit
+val interp : bool -> vernac_expr located -> unit
(* Queries for backward compatibility *)
val current_proof_depth : unit -> int
@@ -134,7 +216,7 @@ val get_all_proof_names : unit -> Id.t list
val get_current_proof_name : unit -> Id.t option
val show_script : ?proof:Proof_global.closed_proof -> unit -> unit
-(** Reverse dependency hooks *)
+(* Hooks to be set by other Coq components in order to break file cycles *)
val process_error_hook : Future.fix_exn Hook.t
val interp_hook : (?verbosely:bool -> ?proof:Proof_global.closed_proof ->
Loc.t * Vernacexpr.vernac_expr -> unit) Hook.t
diff --git a/stm/stm.mllib b/stm/stm.mllib
index 92b3a869..939ee187 100644
--- a/stm/stm.mllib
+++ b/stm/stm.mllib
@@ -7,6 +7,6 @@ Vernac_classifier
Lemmas
CoqworkmgrApi
AsyncTaskQueue
-Texmacspp
Stm
+ProofBlockDelimiter
Vio_checking
diff --git a/stm/tQueue.ml b/stm/tQueue.ml
index ee121c46..a0b08778 100644
--- a/stm/tQueue.ml
+++ b/stm/tQueue.ml
@@ -87,7 +87,7 @@ let broadcast { lock = m; cond = c } =
Mutex.unlock m
let push { queue = q; lock = m; cond = c; release } x =
- if release then Errors.anomaly(Pp.str
+ if release then CErrors.anomaly(Pp.str
"TQueue.push while being destroyed! Only 1 producer/destroyer allowed");
Mutex.lock m;
PriorityQueue.push q x;
diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml
deleted file mode 100644
index 85cb4570..00000000
--- a/stm/texmacspp.ml
+++ /dev/null
@@ -1,770 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* (List.filter (fun (a,_) -> a = attr) attrs)
- | _ -> [])
- xml_list in
- match List.flatten attrs_list with
- | [] -> (attr, "")
- | l -> (List.hd l)
-
-let backstep_loc xmllist =
- let start_att = get_fst_attr_in_xml_list "begin" xmllist in
- let stop_att = get_fst_attr_in_xml_list "end" (List.rev xmllist) in
- [start_att ; stop_att]
-
-let compare_begin_att xml1 xml2 =
- let att1 = get_fst_attr_in_xml_list "begin" [xml1] in
- let att2 = get_fst_attr_in_xml_list "begin" [xml2] in
- match att1, att2 with
- | (_, s1), (_, s2) when s1 == "" || s2 == "" -> 0
- | (_, s1), (_, s2) when int_of_string s1 > int_of_string s2 -> 1
- | (_, s1), (_, s2) when int_of_string s1 < int_of_string s2 -> -1
- | _ -> 0
-
-let xmlBeginSection loc name = xmlWithLoc loc "beginsection" ["name", name] []
-
-let xmlEndSegment loc name = xmlWithLoc loc "endsegment" ["name", name] []
-
-let xmlThm typ name loc xml =
- xmlWithLoc loc "theorem" ["type", typ; "name", name] xml
-
-let xmlDef typ name loc xml =
- xmlWithLoc loc "definition" ["type", typ; "name", name] xml
-
-let xmlNotation attr name loc xml =
- xmlWithLoc loc "notation" (("name", name) :: attr) xml
-
-let xmlReservedNotation attr name loc =
- xmlWithLoc loc "reservednotation" (("name", name) :: attr) []
-
-let xmlCst name ?(attr=[]) loc =
- xmlWithLoc loc "constant" (("name", name) :: attr) []
-
-let xmlOperator name ?(attr=[]) ?(pprules=[]) loc =
- xmlWithLoc loc "operator"
- (("name", name) :: List.map (fun (a,b) -> "format"^a,b) pprules @ attr) []
-
-let xmlApply loc ?(attr=[]) xml = xmlWithLoc loc "apply" attr xml
-
-let xmlToken loc ?(attr=[]) xml = xmlWithLoc loc "token" attr xml
-
-let xmlTyped xml = Element("typed", (backstep_loc xml), xml)
-
-let xmlReturn ?(attr=[]) xml = Element("return", attr, xml)
-
-let xmlCase xml = Element("case", [], xml)
-
-let xmlScrutinee ?(attr=[]) xml = Element("scrutinee", attr, xml)
-
-let xmlWith xml = Element("with", [], xml)
-
-let xmlAssign id xml = Element("assign", ["target",string_of_id id], [xml])
-
-let xmlInductive kind loc xml = xmlWithLoc loc "inductive" ["kind",kind] xml
-
-let xmlCoFixpoint xml = Element("cofixpoint", [], xml)
-
-let xmlFixpoint xml = Element("fixpoint", [], xml)
-
-let xmlCheck loc xml = xmlWithLoc loc "check" [] xml
-
-let xmlAssumption kind loc xml = xmlWithLoc loc "assumption" ["kind",kind] xml
-
-let xmlComment loc xml = xmlWithLoc loc "comment" [] xml
-
-let xmlCanonicalStructure attr loc = xmlWithLoc loc "canonicalstructure" attr []
-
-let xmlQed ?(attr=[]) loc = xmlWithLoc loc "qed" attr []
-
-let xmlPatvar id loc = xmlWithLoc loc "patvar" ["id", id] []
-
-let xmlReference ref =
- let name = Libnames.string_of_reference ref in
- let i, j = Loc.unloc (Libnames.loc_of_reference ref) in
- let b, e = string_of_int i, string_of_int j in
- Element("reference",["name", name; "begin", b; "end", e] ,[])
-
-let xmlRequire loc ?(attr=[]) xml = xmlWithLoc loc "require" attr xml
-let xmlImport loc ?(attr=[]) xml = xmlWithLoc loc "import" attr xml
-
-let xmlAddLoadPath loc ?(attr=[]) xml = xmlWithLoc loc "addloadpath" attr xml
-let xmlRemoveLoadPath loc ?(attr=[]) = xmlWithLoc loc "removeloadpath" attr
-let xmlAddMLPath loc ?(attr=[]) = xmlWithLoc loc "addmlpath" attr
-
-let xmlExtend loc xml = xmlWithLoc loc "extend" [] xml
-
-let xmlScope loc action ?(attr=[]) name xml =
- xmlWithLoc loc "scope" (["name",name;"action",action] @ attr) xml
-
-let xmlProofMode loc name = xmlWithLoc loc "proofmode" ["name",name] []
-
-let xmlProof loc xml = xmlWithLoc loc "proof" [] xml
-
-let xmlRawTactic name rtac =
- Element("rawtactic", ["name",name],
- [PCData (Pp.string_of_ppcmds (Pptactic.pr_raw_tactic rtac))])
-
-let xmlSectionSubsetDescr name ssd =
- Element("sectionsubsetdescr",["name",name],
- [PCData (Proof_using.to_string ssd)])
-
-let xmlDeclareMLModule loc s =
- xmlWithLoc loc "declarexmlmodule" []
- (List.map (fun x -> Element("path",["value",x],[])) s)
-
-(* tactics *)
-let xmlLtac loc xml = xmlWithLoc loc "ltac" [] xml
-
-(* toplevel commands *)
-let xmlGallina loc xml = xmlWithLoc loc "gallina" [] xml
-
-let xmlTODO loc x =
- xmlWithLoc loc "todo" [] [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))]
-
-let string_of_name n =
- match n with
- | Anonymous -> "_"
- | Name id -> Id.to_string id
-
-let string_of_glob_sort s =
- match s with
- | GProp -> "Prop"
- | GSet -> "Set"
- | GType _ -> "Type"
-
-let string_of_cast_sort c =
- match c with
- | CastConv _ -> "CastConv"
- | CastVM _ -> "CastVM"
- | CastNative _ -> "CastNative"
- | CastCoerce -> "CastCoerce"
-
-let string_of_case_style s =
- match s with
- | LetStyle -> "Let"
- | IfStyle -> "If"
- | LetPatternStyle -> "LetPattern"
- | MatchStyle -> "Match"
- | RegularStyle -> "Regular"
-
-let attribute_of_syntax_modifier sm =
-match sm with
- | SetItemLevel (sl, NumLevel n) ->
- List.map (fun s -> ("itemlevel", s)) sl @ ["level", string_of_int n]
- | SetItemLevel (sl, NextLevel) ->
- List.map (fun s -> ("itemlevel", s)) sl @ ["level", "next"]
- | SetLevel i -> ["level", string_of_int i]
- | SetAssoc a ->
- begin match a with
- | NonA -> ["",""]
- | RightA -> ["associativity", "right"]
- | LeftA -> ["associativity", "left"]
- end
- | SetEntryType (s, _) -> ["entrytype", s]
- | SetOnlyParsing v -> ["compat", Flags.pr_version v]
- | SetFormat (system, (loc, s)) ->
- let start, stop = unlock loc in
- ["format-"^system, s; "begin", start; "end", stop]
-
-let string_of_assumption_kind l a many =
- match l, a, many with
- | (Discharge, Logical, true) -> "Hypotheses"
- | (Discharge, Logical, false) -> "Hypothesis"
- | (Discharge, Definitional, true) -> "Variables"
- | (Discharge, Definitional, false) -> "Variable"
- | (Global, Logical, true) -> "Axioms"
- | (Global, Logical, false) -> "Axiom"
- | (Global, Definitional, true) -> "Parameters"
- | (Global, Definitional, false) -> "Parameter"
- | (Local, Logical, true) -> "Local Axioms"
- | (Local, Logical, false) -> "Local Axiom"
- | (Local, Definitional, true) -> "Local Parameters"
- | (Local, Definitional, false) -> "Local Parameter"
- | (Global, Conjectural, _) -> "Conjecture"
- | ((Discharge | Local), Conjectural, _) -> assert false
-
-let rec pp_bindlist bl =
- let tlist =
- List.flatten
- (List.map
- (fun (loc_names, _, e) ->
- let names =
- (List.map
- (fun (loc, name) ->
- xmlCst (string_of_name name) loc) loc_names) in
- match e with
- | CHole _ -> names
- | _ -> names @ [pp_expr e])
- bl) in
- match tlist with
- | [e] -> e
- | l -> xmlTyped l
-and pp_decl_notation ((_, s), ce, sc) = (* don't know what it is for now *)
- Element ("decl_notation", ["name", s], [pp_expr ce])
-and pp_local_binder lb = (* don't know what it is for now *)
- match lb with
- | LocalRawDef ((_, nam), ce) ->
- let attrs = ["name", string_of_name nam] in
- pp_expr ~attr:attrs ce
- | LocalRawAssum (namll, _, ce) ->
- let ppl =
- List.map (fun (loc, nam) -> (xmlCst (string_of_name nam) loc)) namll in
- xmlTyped (ppl @ [pp_expr ce])
-and pp_local_decl_expr lde = (* don't know what it is for now *)
- match lde with
- | AssumExpr (_, ce) -> pp_expr ce
- | DefExpr (_, ce, _) -> pp_expr ce
-and pp_inductive_expr ((_, ((l, id),_)), lbl, ceo, _, cl_or_rdexpr) =
- (* inductive_expr *)
- let b,e = Loc.unloc l in
- let location = ["begin", string_of_int b; "end", string_of_int e] in
- [Element ("lident", ["name", Id.to_string id] @ location, [])] @ (* inductive name *)
- begin match cl_or_rdexpr with
- | Constructors coel -> List.map (fun (_, (_, ce)) -> pp_expr ce) coel
- | RecordDecl (_, ldewwwl) ->
- List.map (fun (((_, x), _), _) -> pp_local_decl_expr x) ldewwwl
- end @
- begin match ceo with (* don't know what it is for now *)
- | Some ce -> [pp_expr ce]
- | None -> []
- end @
- (List.map pp_local_binder lbl)
-and pp_recursion_order_expr optid roe = (* don't know what it is for now *)
- let attrs =
- match optid with
- | None -> []
- | Some (loc, id) ->
- let start, stop = unlock loc in
- ["begin", start; "end", stop ; "name", Id.to_string id] in
- let kind, expr =
- match roe with
- | CStructRec -> "struct", []
- | CWfRec e -> "rec", [pp_expr e]
- | CMeasureRec (e, None) -> "mesrec", [pp_expr e]
- | CMeasureRec (e, Some rel) -> "mesrec", [pp_expr e] @ [pp_expr rel] in
- Element ("recursion_order", ["kind", kind] @ attrs, expr)
-and pp_fixpoint_expr (((loc, id), pl), (optid, roe), lbl, ce, ceo) =
- (* fixpoint_expr *)
- let start, stop = unlock loc in
- let id = Id.to_string id in
- [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @
- (* fixpoint name *)
- [pp_recursion_order_expr optid roe] @
- (List.map pp_local_binder lbl) @
- [pp_expr ce] @
- begin match ceo with (* don't know what it is for now *)
- | Some ce -> [pp_expr ce]
- | None -> []
- end
-and pp_cofixpoint_expr (((loc, id), pl), lbl, ce, ceo) = (* cofixpoint_expr *)
- (* Nota: it is like fixpoint_expr without (optid, roe)
- * so could be merged if there is no more differences *)
- let start, stop = unlock loc in
- let id = Id.to_string id in
- [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @
- (* cofixpoint name *)
- (List.map pp_local_binder lbl) @
- [pp_expr ce] @
- begin match ceo with (* don't know what it is for now *)
- | Some ce -> [pp_expr ce]
- | None -> []
- end
-and pp_lident (loc, id) = xmlCst (Id.to_string id) loc
-and pp_simple_binder (idl, ce) = List.map pp_lident idl @ [pp_expr ce]
-and pp_cases_pattern_expr cpe =
- match cpe with
- | CPatAlias (loc, cpe, id) ->
- xmlApply loc
- (xmlOperator "alias" ~attr:["name", string_of_id id] loc ::
- [pp_cases_pattern_expr cpe])
- | CPatCstr (loc, ref, cpel1, cpel2) ->
- xmlApply loc
- (xmlOperator "reference"
- ~attr:["name", Libnames.string_of_reference ref] loc ::
- [Element ("impargs", [], (List.map pp_cases_pattern_expr cpel1));
- Element ("args", [], (List.map pp_cases_pattern_expr cpel2))])
- | CPatAtom (loc, optr) ->
- let attrs = match optr with
- | None -> []
- | Some r -> ["name", Libnames.string_of_reference r] in
- xmlApply loc (xmlOperator "atom" ~attr:attrs loc :: [])
- | CPatOr (loc, cpel) ->
- xmlApply loc (xmlOperator "or" loc :: List.map pp_cases_pattern_expr cpel)
- | CPatNotation (loc, n, (subst_constr, subst_rec), cpel) ->
- xmlApply loc
- (xmlOperator "notation" loc ::
- [xmlOperator n loc;
- Element ("subst", [],
- [Element ("subterms", [],
- List.map pp_cases_pattern_expr subst_constr);
- Element ("recsubterms", [],
- List.map
- (fun (cpel) ->
- Element ("recsubterm", [],
- List.map pp_cases_pattern_expr cpel))
- subst_rec)]);
- Element ("args", [], (List.map pp_cases_pattern_expr cpel))])
- | CPatPrim (loc, tok) -> pp_token loc tok
- | CPatRecord (loc, rcl) ->
- xmlApply loc
- (xmlOperator "record" loc ::
- List.map (fun (r, cpe) ->
- Element ("field",
- ["reference", Libnames.string_of_reference r],
- [pp_cases_pattern_expr cpe]))
- rcl)
- | CPatDelimiters (loc, delim, cpe) ->
- xmlApply loc
- (xmlOperator "delimiter" ~attr:["name", delim] loc ::
- [pp_cases_pattern_expr cpe])
-and pp_case_expr (e, (name, pat)) =
- match name, pat with
- | None, None -> xmlScrutinee [pp_expr e]
- | Some (loc, name), None ->
- let start, stop= unlock loc in
- xmlScrutinee ~attr:["name", string_of_name name;
- "begin", start; "end", stop] [pp_expr e]
- | Some (loc, name), Some p ->
- let start, stop= unlock loc in
- xmlScrutinee ~attr:["name", string_of_name name;
- "begin", start; "end", stop]
- [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e]
- | None, Some p ->
- xmlScrutinee [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e]
-and pp_branch_expr_list bel =
- xmlWith
- (List.map
- (fun (_, cpel, e) ->
- let ppcepl =
- List.map pp_cases_pattern_expr (List.flatten (List.map snd cpel)) in
- let ppe = [pp_expr e] in
- xmlCase (ppcepl @ ppe))
- bel)
-and pp_token loc tok =
- let tokstr =
- match tok with
- | String s -> PCData s
- | Numeral n -> PCData (to_string n) in
- xmlToken loc [tokstr]
-and pp_local_binder_list lbl =
- let l = (List.map pp_local_binder lbl) in
- Element ("recurse", (backstep_loc l), l)
-and pp_const_expr_list cel =
- let l = List.map pp_expr cel in
- Element ("recurse", (backstep_loc l), l)
-and pp_expr ?(attr=[]) e =
- match e with
- | CRef (r, _) ->
- xmlCst ~attr
- (Libnames.string_of_reference r) (Libnames.loc_of_reference r)
- | CProdN (loc, bl, e) ->
- xmlApply loc
- (xmlOperator "forall" loc :: [pp_bindlist bl] @ [pp_expr e])
- | CApp (loc, (_, hd), args) ->
- xmlApply ~attr loc (pp_expr hd :: List.map (fun (e,_) -> pp_expr e) args)
- | CAppExpl (loc, (_, r, _), args) ->
- xmlApply ~attr loc
- (xmlCst (Libnames.string_of_reference r)
- (Libnames.loc_of_reference r) :: List.map pp_expr args)
- | CNotation (loc, notation, ([],[],[])) ->
- xmlOperator notation loc
- | CNotation (loc, notation, (args, cell, lbll)) ->
- let fmts = Notation.find_notation_extra_printing_rules notation in
- let oper = xmlOperator notation loc ~pprules:fmts in
- let cels = List.map pp_const_expr_list cell in
- let lbls = List.map pp_local_binder_list lbll in
- let args = List.map pp_expr args in
- xmlApply loc (oper :: (List.sort compare_begin_att (args @ cels @ lbls)))
- | CSort(loc, s) ->
- xmlOperator (string_of_glob_sort s) loc
- | CDelimiters (loc, scope, ce) ->
- xmlApply loc (xmlOperator "delimiter" ~attr:["name", scope] loc ::
- [pp_expr ce])
- | CPrim (loc, tok) -> pp_token loc tok
- | CGeneralization (loc, kind, _, e) ->
- let kind= match kind with
- | Explicit -> "explicit"
- | Implicit -> "implicit" in
- xmlApply loc
- (xmlOperator "generalization" ~attr:["kind", kind] loc :: [pp_expr e])
- | CCast (loc, e, tc) ->
- begin match tc with
- | CastConv t | CastVM t |CastNative t ->
- xmlApply loc
- (xmlOperator ":" loc ~attr:["kind", (string_of_cast_sort tc)] ::
- [pp_expr e; pp_expr t])
- | CastCoerce ->
- xmlApply loc
- (xmlOperator ":" loc ~attr:["kind", "CastCoerce"] ::
- [pp_expr e])
- end
- | CEvar (loc, ek, cel) ->
- let ppcel = List.map (fun (id,e) -> xmlAssign id (pp_expr e)) cel in
- xmlApply loc
- (xmlOperator "evar" loc ~attr:["id", string_of_id ek] ::
- ppcel)
- | CPatVar (loc, id) -> xmlPatvar (string_of_id id) loc
- | CHole (loc, _, _, _) -> xmlCst ~attr "_" loc
- | CIf (loc, test, (_, ret), th, el) ->
- let return = match ret with
- | None -> []
- | Some r -> [xmlReturn [pp_expr r]] in
- xmlApply loc
- (xmlOperator "if" loc ::
- return @ [pp_expr th] @ [pp_expr el])
- | CLetTuple (loc, names, (_, ret), value, body) ->
- let return = match ret with
- | None -> []
- | Some r -> [xmlReturn [pp_expr r]] in
- xmlApply loc
- (xmlOperator "lettuple" loc ::
- return @
- (List.map (fun (loc, var) -> xmlCst (string_of_name var) loc) names) @
- [pp_expr value; pp_expr body])
- | CCases (loc, sty, ret, cel, bel) ->
- let return = match ret with
- | None -> []
- | Some r -> [xmlReturn [pp_expr r]] in
- xmlApply loc
- (xmlOperator "match" loc ~attr:["style", (string_of_case_style sty)] ::
- (return @
- [Element ("scrutinees", [], List.map pp_case_expr cel)] @
- [pp_branch_expr_list bel]))
- | CRecord (_, _, _) -> assert false
- | CLetIn (loc, (varloc, var), value, body) ->
- xmlApply loc
- (xmlOperator "let" loc ::
- [xmlCst (string_of_name var) varloc; pp_expr value; pp_expr body])
- | CLambdaN (loc, bl, e) ->
- xmlApply loc
- (xmlOperator "lambda" loc :: [pp_bindlist bl] @ [pp_expr e])
- | CCoFix (_, _, _) -> assert false
- | CFix (loc, lid, fel) ->
- xmlApply loc
- (xmlOperator "fix" loc ::
- List.flatten (List.map
- (fun (a,b,cl,c,d) -> pp_fixpoint_expr ((a,None),b,cl,c,Some d))
- fel))
-
-let pp_comment (c) =
- match c with
- | CommentConstr e -> [pp_expr e]
- | CommentString s -> [Element ("string", [], [PCData s])]
- | CommentInt i -> [PCData (string_of_int i)]
-
-let rec tmpp v loc =
- match v with
- (* Control *)
- | VernacLoad (verbose,f) ->
- xmlWithLoc loc "load" ["verbose",string_of_bool verbose;"file",f] []
- | VernacTime l ->
- xmlApply loc (Element("time",[],[]) ::
- List.map (fun(loc,e) ->tmpp e loc) l)
- | VernacRedirect (s, l) ->
- xmlApply loc (Element("redirect",["path", s],[]) ::
- List.map (fun(loc,e) ->tmpp e loc) l)
- | VernacTimeout (s,e) ->
- xmlApply loc (Element("timeout",["val",string_of_int s],[]) ::
- [tmpp e loc])
- | VernacFail e -> xmlApply loc (Element("fail",[],[]) :: [tmpp e loc])
- | VernacError _ -> xmlWithLoc loc "error" [] []
-
- (* Syntax *)
- | VernacTacticNotation _ as x ->
- xmlLtac loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))]
-
- | VernacSyntaxExtension (_, ((_, name), sml)) ->
- let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in
- xmlReservedNotation attrs name loc
-
- | VernacOpenCloseScope (_,(true,name)) -> xmlScope loc "open" name []
- | VernacOpenCloseScope (_,(false,name)) -> xmlScope loc "close" name []
- | VernacDelimiters (name,Some tag) ->
- xmlScope loc "delimit" name ~attr:["delimiter",tag] []
- | VernacDelimiters (name,None) ->
- xmlScope loc "undelimit" name ~attr:[] []
- | VernacBindScope (name,l) ->
- xmlScope loc "bind" name
- (List.map (function
- | ByNotation(loc,name,None) -> xmlNotation [] name loc []
- | ByNotation(loc,name,Some d) ->
- xmlNotation ["delimiter",d] name loc []
- | AN ref -> xmlReference ref) l)
- | VernacInfix (_,((_,name),sml),ce,sn) ->
- let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in
- let sc_attr =
- match sn with
- | Some scope -> ["scope", scope]
- | None -> [] in
- xmlNotation (sc_attr @ attrs) name loc [pp_expr ce]
- | VernacNotation (_, ce, (lstr, sml), sn) ->
- let name = snd lstr in
- let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in
- let sc_attr =
- match sn with
- | Some scope -> ["scope", scope]
- | None -> [] in
- xmlNotation (sc_attr @ attrs) name loc [pp_expr ce]
- | VernacNotationAddFormat _ as x -> xmlTODO loc x
- | VernacUniverse _
- | VernacConstraint _
- | VernacPolymorphic (_, _) as x -> xmlTODO loc x
- (* Gallina *)
- | VernacDefinition (ldk, ((_,id),_), de) ->
- let l, dk =
- match ldk with
- | Some l, dk -> (l, dk)
- | None, dk -> (Global, dk) in (* Like in ppvernac.ml, l 585 *)
- let e =
- match de with
- | ProveBody (_, ce) -> ce
- | DefineBody (_, Some _, ce, None) -> ce
- | DefineBody (_, None , ce, None) -> ce
- | DefineBody (_, Some _, ce, Some _) -> ce
- | DefineBody (_, None , ce, Some _) -> ce in
- let str_dk = Kindops.string_of_definition_kind (l, false, dk) in
- let str_id = Id.to_string id in
- (xmlDef str_dk str_id loc [pp_expr e])
- | VernacStartTheoremProof (tk, [ Some ((_,id),_), ([], statement, None) ], b) ->
- let str_tk = Kindops.string_of_theorem_kind tk in
- let str_id = Id.to_string id in
- (xmlThm str_tk str_id loc [pp_expr statement])
- | VernacStartTheoremProof _ as x -> xmlTODO loc x
- | VernacEndProof pe ->
- begin
- match pe with
- | Admitted -> xmlQed loc
- | Proved (_, Some ((_, id), Some tk)) ->
- let nam = Id.to_string id in
- let typ = Kindops.string_of_theorem_kind tk in
- xmlQed ~attr:["name", nam; "type", typ] loc
- | Proved (_, Some ((_, id), None)) ->
- let nam = Id.to_string id in
- xmlQed ~attr:["name", nam] loc
- | Proved _ -> xmlQed loc
- end
- | VernacExactProof _ as x -> xmlTODO loc x
- | VernacAssumption ((l, a), _, sbwcl) ->
- let binders = List.map (fun (_, (id, c)) -> (List.map fst id, c)) sbwcl in
- let many =
- List.length (List.flatten (List.map fst binders)) > 1 in
- let exprs =
- List.flatten (List.map pp_simple_binder binders) in
- let l = match l with Some x -> x | None -> Decl_kinds.Global in
- let kind = string_of_assumption_kind l a many in
- xmlAssumption kind loc exprs
- | VernacInductive (_, _, iednll) ->
- let kind =
- let (_, _, _, k, _),_ = List.hd iednll in
- begin
- match k with
- | Record -> "Record"
- | Structure -> "Structure"
- | Inductive_kw -> "Inductive"
- | CoInductive -> "CoInductive"
- | Class _ -> "Class"
- | Variant -> "Variant"
- end in
- let exprs =
- List.flatten (* should probably not be flattened *)
- (List.map
- (fun (ie, dnl) -> (pp_inductive_expr ie) @
- (List.map pp_decl_notation dnl)) iednll) in
- xmlInductive kind loc exprs
- | VernacFixpoint (_, fednll) ->
- let exprs =
- List.flatten (* should probably not be flattened *)
- (List.map
- (fun (fe, dnl) -> (pp_fixpoint_expr fe) @
- (List.map pp_decl_notation dnl)) fednll) in
- xmlFixpoint exprs
- | VernacCoFixpoint (_, cfednll) ->
- (* Nota: it is like VernacFixpoint without so could be merged *)
- let exprs =
- List.flatten (* should probably not be flattened *)
- (List.map
- (fun (cfe, dnl) -> (pp_cofixpoint_expr cfe) @
- (List.map pp_decl_notation dnl)) cfednll) in
- xmlCoFixpoint exprs
- | VernacScheme _ as x -> xmlTODO loc x
- | VernacCombinedScheme _ as x -> xmlTODO loc x
-
- (* Gallina extensions *)
- | VernacBeginSection (_, id) -> xmlBeginSection loc (Id.to_string id)
- | VernacEndSegment (_, id) -> xmlEndSegment loc (Id.to_string id)
- | VernacNameSectionHypSet _ as x -> xmlTODO loc x
- | VernacRequire (from, import, l) ->
- let import = match import with
- | None -> []
- | Some true -> ["export","true"]
- | Some false -> ["import","true"]
- in
- let from = match from with
- | None -> []
- | Some r -> ["from", Libnames.string_of_reference r]
- in
- xmlRequire loc ~attr:(from @ import) (List.map (fun ref ->
- xmlReference ref) l)
- | VernacImport (true,l) ->
- xmlImport loc ~attr:["export","true"] (List.map (fun ref ->
- xmlReference ref) l)
- | VernacImport (false,l) ->
- xmlImport loc (List.map (fun ref ->
- xmlReference ref) l)
- | VernacCanonical r ->
- let attr =
- match r with
- | AN (Qualid (_, q)) -> ["qualid", string_of_qualid q]
- | AN (Ident (_, id)) -> ["id", Id.to_string id]
- | ByNotation (_, s, _) -> ["notation", s] in
- xmlCanonicalStructure attr loc
- | VernacCoercion _ as x -> xmlTODO loc x
- | VernacIdentityCoercion _ as x -> xmlTODO loc x
-
- (* Type classes *)
- | VernacInstance _ as x -> xmlTODO loc x
-
- | VernacContext _ as x -> xmlTODO loc x
-
- | VernacDeclareInstances _ as x -> xmlTODO loc x
-
- | VernacDeclareClass _ as x -> xmlTODO loc x
-
- (* Modules and Module Types *)
- | VernacDeclareModule _ as x -> xmlTODO loc x
- | VernacDefineModule _ as x -> xmlTODO loc x
- | VernacDeclareModuleType _ as x -> xmlTODO loc x
- | VernacInclude _ as x -> xmlTODO loc x
-
- (* Solving *)
-
- | (VernacSolve _ | VernacSolveExistential _) as x ->
- xmlLtac loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))]
-
- (* Auxiliary file and library management *)
- | VernacAddLoadPath (recf,name,None) ->
- xmlAddLoadPath loc ~attr:["rec",string_of_bool recf;"path",name] []
- | VernacAddLoadPath (recf,name,Some dp) ->
- xmlAddLoadPath loc ~attr:["rec",string_of_bool recf;"path",name]
- [PCData (Names.DirPath.to_string dp)]
- | VernacRemoveLoadPath name -> xmlRemoveLoadPath loc ~attr:["path",name] []
- | VernacAddMLPath (recf,name) ->
- xmlAddMLPath loc ~attr:["rec",string_of_bool recf;"path",name] []
- | VernacDeclareMLModule sl -> xmlDeclareMLModule loc sl
- | VernacChdir _ as x -> xmlTODO loc x
-
- (* State management *)
- | VernacWriteState _ as x -> xmlTODO loc x
- | VernacRestoreState _ as x -> xmlTODO loc x
-
- (* Resetting *)
- | VernacResetName _ as x -> xmlTODO loc x
- | VernacResetInitial as x -> xmlTODO loc x
- | VernacBack _ as x -> xmlTODO loc x
- | VernacBackTo _ -> PCData "VernacBackTo"
-
- (* Commands *)
- | VernacDeclareTacticDefinition _ as x -> xmlTODO loc x
- | VernacCreateHintDb _ as x -> xmlTODO loc x
- | VernacRemoveHints _ as x -> xmlTODO loc x
- | VernacHints _ as x -> xmlTODO loc x
- | VernacSyntacticDefinition ((_, name), (idl, ce), _, _) ->
- let name = Id.to_string name in
- let attrs = List.map (fun id -> ("id", Id.to_string id)) idl in
- xmlNotation attrs name loc [pp_expr ce]
- | VernacDeclareImplicits _ as x -> xmlTODO loc x
- | VernacArguments _ as x -> xmlTODO loc x
- | VernacArgumentsScope _ as x -> xmlTODO loc x
- | VernacReserve _ as x -> xmlTODO loc x
- | VernacGeneralizable _ as x -> xmlTODO loc x
- | VernacSetOpacity _ as x -> xmlTODO loc x
- | VernacSetStrategy _ as x -> xmlTODO loc x
- | VernacUnsetOption _ as x -> xmlTODO loc x
- | VernacSetOption _ as x -> xmlTODO loc x
- | VernacAddOption _ as x -> xmlTODO loc x
- | VernacRemoveOption _ as x -> xmlTODO loc x
- | VernacMemOption _ as x -> xmlTODO loc x
- | VernacPrintOption _ as x -> xmlTODO loc x
- | VernacCheckMayEval (_,_,e) -> xmlCheck loc [pp_expr e]
- | VernacGlobalCheck _ as x -> xmlTODO loc x
- | VernacDeclareReduction _ as x -> xmlTODO loc x
- | VernacPrint _ as x -> xmlTODO loc x
- | VernacSearch _ as x -> xmlTODO loc x
- | VernacLocate _ as x -> xmlTODO loc x
- | VernacRegister _ as x -> xmlTODO loc x
- | VernacComments (cl) ->
- xmlComment loc (List.flatten (List.map pp_comment cl))
- | VernacNop as x -> xmlTODO loc x
-
- (* Stm backdoor *)
- | VernacStm _ as x -> xmlTODO loc x
-
- (* Proof management *)
- | VernacGoal _ as x -> xmlTODO loc x
- | VernacAbort _ as x -> xmlTODO loc x
- | VernacAbortAll -> PCData "VernacAbortAll"
- | VernacRestart as x -> xmlTODO loc x
- | VernacUndo _ as x -> xmlTODO loc x
- | VernacUndoTo _ as x -> xmlTODO loc x
- | VernacBacktrack _ as x -> xmlTODO loc x
- | VernacFocus _ as x -> xmlTODO loc x
- | VernacUnfocus as x -> xmlTODO loc x
- | VernacUnfocused as x -> xmlTODO loc x
- | VernacBullet _ as x -> xmlTODO loc x
- | VernacSubproof _ as x -> xmlTODO loc x
- | VernacEndSubproof as x -> xmlTODO loc x
- | VernacShow _ as x -> xmlTODO loc x
- | VernacCheckGuard as x -> xmlTODO loc x
- | VernacProof (tac,using) ->
- let tac = Option.map (xmlRawTactic "closingtactic") tac in
- let using = Option.map (xmlSectionSubsetDescr "using") using in
- xmlProof loc (Option.List.(cons tac (cons using [])))
- | VernacProofMode name -> xmlProofMode loc name
-
- (* Toplevel control *)
- | VernacToplevelControl _ as x -> xmlTODO loc x
-
- (* For extension *)
- | VernacExtend _ as x ->
- xmlExtend loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))]
-
- (* Flags *)
- | VernacProgram e -> xmlApply loc (Element("program",[],[]) :: [tmpp e loc])
- | VernacLocal (b,e) ->
- xmlApply loc (Element("local",["flag",string_of_bool b],[]) ::
- [tmpp e loc])
-
-let tmpp v loc =
- match tmpp v loc with
- | Element("ltac",_,_) as x -> x
- | xml -> xmlGallina loc [xml]
diff --git a/stm/texmacspp.mli b/stm/texmacspp.mli
deleted file mode 100644
index 858847fb..00000000
--- a/stm/texmacspp.mli
+++ /dev/null
@@ -1,12 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(*