diff options
Diffstat (limited to 'plugins/quote')
| -rw-r--r-- | plugins/quote/g_quote.ml4 | 1 | ||||
| -rw-r--r-- | plugins/quote/quote.ml | 89 | ||||
| -rw-r--r-- | plugins/quote/vo.itarget | 1 |
3 files changed, 55 insertions, 36 deletions
diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index 980f03db33..c43d7d0b5b 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open API open Ltac_plugin open Names open Misctypes diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index c649cfb2c6..15d0f5f37c 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -101,6 +101,7 @@ (*i*) +open API open CErrors open Util open Names @@ -118,7 +119,8 @@ open Proofview.Notations the constants are loaded in the environment *) let constant dir s = - EConstr.of_constr (Coqlib.gen_constant "Quote" ("quote"::dir) s) + EConstr.of_constr @@ Universes.constr_of_global @@ + Coqlib.coq_reference "Quote" ("quote"::dir) s let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm") let coq_Node_vm = lazy (constant ["Quote"] "Node_vm") @@ -167,8 +169,8 @@ exchange ?1 and ?2 in the example above) module ConstrSet = Set.Make( struct - type t = Constr.constr - let compare = constr_ord + type t = Term.constr + let compare = Term.compare end) type inversion_scheme = { @@ -183,7 +185,7 @@ type inversion_scheme = { goal [gl]. This function uses the auxiliary functions [i_can't_do_that], [decomp_term], [compute_lhs] and [compute_rhs]. *) -let i_can't_do_that () = error "Quote: not a simple fixpoint" +let i_can't_do_that () = user_err Pp.(str "Quote: not a simple fixpoint") let decomp_term sigma c = EConstr.kind sigma (Termops.strip_outer_cast sigma c) @@ -385,7 +387,7 @@ let rec sort_subterm gl l = | h::t -> insert h (sort_subterm gl t) module Constrhash = Hashtbl.Make - (struct type t = Constr.constr + (struct type t = Term.constr let equal = Term.eq_constr let hash = Term.hash_constr end) @@ -422,7 +424,7 @@ let quote_terms env sigma ivs lc = | None -> begin match ivs.constant_lhs with | Some c_lhs -> subst_meta [1, c] c_lhs - | None -> anomaly (Pp.str "invalid inversion scheme for quote") + | None -> anomaly (Pp.str "invalid inversion scheme for quote.") end | Some var_lhs -> begin match ivs.constant_lhs with @@ -455,40 +457,57 @@ let quote_terms env sigma ivs lc = term. Ring for example needs that, but Ring doesn't use Quote yet. *) +let pf_constrs_of_globals l = + let rec aux l acc = + match l with + [] -> Proofview.tclUNIT (List.rev acc) + | hd :: tl -> + Tacticals.New.pf_constr_of_global hd >>= fun g -> aux tl (g :: acc) + in aux l [] + let quote f lid = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let f = Tacmach.New.pf_global f gl in - let cl = List.map (fun id -> EConstr.to_constr sigma (Tacmach.New.pf_global id gl)) lid in - let ivs = compute_ivs f cl gl in - let concl = Proofview.Goal.concl gl in - let quoted_terms = quote_terms env sigma ivs [concl] in - let (p, vm) = match quoted_terms with + Proofview.Goal.enter begin fun gl -> + let fg = Tacmach.New.pf_global f gl in + let clg = List.map (fun id -> Tacmach.New.pf_global id gl) lid in + Tacticals.New.pf_constr_of_global fg >>= fun f -> + pf_constrs_of_globals clg >>= fun cl -> + Proofview.Goal.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let ivs = compute_ivs f (List.map (EConstr.to_constr sigma) cl) gl in + let concl = Proofview.Goal.concl gl in + let quoted_terms = quote_terms env sigma ivs [concl] in + let (p, vm) = match quoted_terms with | [p], vm -> (p,vm) | _ -> assert false - in - match ivs.variable_lhs with - | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast - | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast - end } + in + 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 { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let f = Tacmach.New.pf_global f gl in - let cl = List.map (fun id -> EConstr.to_constr sigma (Tacmach.New.pf_global id gl)) lid in - let ivs = compute_ivs f cl gl in - let quoted_terms = quote_terms env sigma ivs [c] in - let (p, vm) = match quoted_terms with - | [p], vm -> (p,vm) - | _ -> assert false - in - match ivs.variable_lhs with - | None -> cont (mkApp (f, [| p |])) - | Some _ -> cont (mkApp (f, [| vm; p |])) - end } + Proofview.Goal.enter begin fun gl -> + let fg = Tacmach.New.pf_global f gl in + let clg = List.map (fun id -> Tacmach.New.pf_global id gl) lid in + Tacticals.New.pf_constr_of_global fg >>= fun f -> + pf_constrs_of_globals clg >>= fun cl -> + Proofview.Goal.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let cl = List.map (EConstr.to_constr sigma) cl in + let ivs = compute_ivs f cl gl in + let quoted_terms = quote_terms env sigma ivs [c] in + let (p, vm) = match quoted_terms with + | [p], vm -> (p,vm) + | _ -> assert false + in + match ivs.variable_lhs with + | None -> cont (mkApp (f, [| p |])) + | Some _ -> cont (mkApp (f, [| vm; p |])) + end + end (*i diff --git a/plugins/quote/vo.itarget b/plugins/quote/vo.itarget deleted file mode 100644 index 7a44fc5aa6..0000000000 --- a/plugins/quote/vo.itarget +++ /dev/null @@ -1 +0,0 @@ -Quote.vo
\ No newline at end of file |