From 5da0f107cb3332d5cd87fc352aef112f6b74fc97 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 13 Apr 2016 16:31:01 +0200 Subject: Moving Ftactic and Geninterp to the engine folder. --- tactics/ftactic.ml | 106 -------------------------------------------------- tactics/ftactic.mli | 79 ------------------------------------- tactics/geninterp.ml | 35 ----------------- tactics/geninterp.mli | 27 ------------- tactics/tactics.mllib | 2 - 5 files changed, 249 deletions(-) delete mode 100644 tactics/ftactic.ml delete mode 100644 tactics/ftactic.mli delete mode 100644 tactics/geninterp.ml delete mode 100644 tactics/geninterp.mli (limited to 'tactics') diff --git a/tactics/ftactic.ml b/tactics/ftactic.ml deleted file mode 100644 index 588709873e..0000000000 --- a/tactics/ftactic.ml +++ /dev/null @@ -1,106 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* b t) : b t = m >>= function -| Uniform x -> f x -| Depends l -> - let f arg = f arg >>= function - | Uniform x -> - (** We dispatch the uniform result on each goal under focus, as we know - that the [m] argument was actually dependent. *) - Proofview.Goal.goals >>= fun l -> - let ans = List.map (fun _ -> x) l in - Proofview.tclUNIT ans - | Depends l -> Proofview.tclUNIT l - in - Proofview.tclDISPATCHL (List.map f l) >>= fun l -> - Proofview.tclUNIT (Depends (List.concat l)) - -let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l) -let set_sigma r = - let Sigma.Sigma (ans, sigma, _) = r in - Proofview.Unsafe.tclEVARS (Sigma.to_evar_map sigma) >>= fun () -> ans - -let nf_enter f = - bind goals - (fun gl -> - gl >>= fun gl -> - Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> f.enter nfgl)) - -let nf_s_enter f = - bind goals - (fun gl -> - gl >>= fun gl -> - Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter nfgl))) - -let enter f = - bind goals - (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f.enter gl)) - -let s_enter f = - bind goals - (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter gl))) - -let with_env t = - t >>= function - | Uniform a -> - Proofview.tclENV >>= fun env -> Proofview.tclUNIT (Uniform (env,a)) - | Depends l -> - Proofview.Goal.goals >>= fun gs -> - Proofview.Monad.(List.map (map Proofview.Goal.env) gs) >>= fun envs -> - Proofview.tclUNIT (Depends (List.combine envs l)) - -let lift (type a) (t:a Proofview.tactic) : a t = - Proofview.tclBIND t (fun x -> Proofview.tclUNIT (Uniform x)) - -(** If the tactic returns unit, we can focus on the goals if necessary. *) -let run m k = m >>= function -| Uniform v -> k v -| Depends l -> - let tacs = List.map k l in - Proofview.tclDISPATCH tacs - -let (>>=) = bind - -let (<*>) = fun m n -> bind m (fun () -> n) - -module Self = -struct - type 'a t = 'a focus Proofview.tactic - let return = return - let (>>=) = bind - let (>>) = (<*>) - let map f x = x >>= fun a -> return (f a) -end - -module Ftac = Monad.Make(Self) -module List = Ftac.List - -module Notations = -struct - let (>>=) = bind - let (<*>) = fun m n -> bind m (fun () -> n) -end diff --git a/tactics/ftactic.mli b/tactics/ftactic.mli deleted file mode 100644 index 19041f1698..0000000000 --- a/tactics/ftactic.mli +++ /dev/null @@ -1,79 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a t -(** The unit of the monad. *) - -val bind : 'a t -> ('a -> 'b t) -> 'b t -(** The bind of the monad. *) - -(** {5 Operations} *) - -val lift : 'a Proofview.tactic -> 'a t -(** Transform a tactic into a focussing tactic. The resulting tactic is not - focussed. *) - -val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic -(** Given a continuation producing a tactic, evaluates the focussing tactic. If - the tactic has not focussed, then the continuation is evaluated once. - Otherwise it is called in each of the currently focussed goals. *) - -(** {5 Focussing} *) - -val nf_enter : ([ `NF ], 'a t) enter -> 'a t -(** Enter a goal. The resulting tactic is focussed. *) - -val enter : ([ `LZ ], 'a t) enter -> 'a t -(** Enter a goal, without evar normalization. The resulting tactic is - focussed. *) - -val s_enter : ([ `LZ ], 'a t) s_enter -> 'a t -(** Enter a goal and put back an evarmap. The resulting tactic is focussed. *) - -val nf_s_enter : ([ `NF ], 'a t) s_enter -> 'a t -(** Enter a goal, without evar normalization and put back an evarmap. The - resulting tactic is focussed. *) - -val with_env : 'a t -> (Environ.env*'a) t -(** [with_env t] returns, in addition to the return type of [t], an - environment, which is the global environment if [t] does not focus on - goals, or the local goal environment if [t] focuses on goals. *) - -(** {5 Notations} *) - -val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -(** Notation for {!bind}. *) - -val (<*>) : unit t -> 'a t -> 'a t -(** Sequence. *) - -(** {5 List operations} *) - -module List : Monad.ListS with type 'a t := 'a t - -(** {5 Notations} *) - -module Notations : -sig - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val (<*>) : unit t -> 'a t -> 'a t -end diff --git a/tactics/geninterp.ml b/tactics/geninterp.ml deleted file mode 100644 index 0080758000..0000000000 --- a/tactics/geninterp.ml +++ /dev/null @@ -1,35 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'glb -> 'top Ftactic.t - -module InterpObj = -struct - type ('raw, 'glb, 'top) obj = ('glb, 'top) interp_fun - let name = "interp" - let default _ = None -end - -module Interp = Register(InterpObj) - -let interp = Interp.obj -let register_interp0 = Interp.register0 - -let generic_interp ist (GenArg (Glbwit wit, v)) = - let open Ftactic.Notations in - interp wit ist v >>= fun ans -> - Ftactic.return (Val.Dyn (val_tag (topwit wit), ans)) diff --git a/tactics/geninterp.mli b/tactics/geninterp.mli deleted file mode 100644 index 0992db7a29..0000000000 --- a/tactics/geninterp.mli +++ /dev/null @@ -1,27 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'glb -> 'top Ftactic.t - -val interp : ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun - -val generic_interp : (glob_generic_argument, Val.t) interp_fun - -val register_interp0 : - ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun -> unit diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index ab8069225d..48722f655a 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -1,5 +1,3 @@ -Ftactic -Geninterp Dnet Dn Btermdn -- cgit v1.2.3 From 011ac2d7db53f0df2849985ef9cc044574c0ddb0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 13 Apr 2016 16:44:42 +0200 Subject: Switching to an untyped toplevel representation for Ltac values. --- tactics/auto.ml | 2 +- tactics/taccoerce.ml | 29 ++++++++++++++--------------- tactics/taccoerce.mli | 2 ++ 3 files changed, 17 insertions(+), 16 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index fc6ff03b4b..d7ce0d4c1a 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -156,7 +156,7 @@ let conclPattern concl pat tac = constr_bindings env sigma >>= fun constr_bindings -> let open Genarg in let open Geninterp in - let inj c = Val.Dyn (val_tag (topwit Constrarg.wit_constr), c) in + let inj c = Val.inject (val_tag (topwit Constrarg.wit_constr)) c in let fold id c accu = Id.Map.add id (inj c) accu in let lfun = Id.Map.fold fold constr_bindings Id.Map.empty in let ist = { lfun; extra = TacStore.empty } in diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index 358f6d6468..298257e45d 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -24,13 +24,18 @@ let (wit_constr_context : (Empty.t, Empty.t, constr) Genarg.genarg_type) = let (wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) Genarg.genarg_type) = Genarg.create_arg "constr_under_binders" +(** All the types considered here are base types *) +let val_tag wit = match val_tag wit with +| Val.Base t -> t +| _ -> assert false + let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> let Val.Dyn (t, _) = v in match Val.eq t (val_tag wit) with | None -> false | Some Refl -> true -let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> +let prj : type a. a Val.typ -> Val.t -> a option = fun t v -> let Val.Dyn (t', x) = v in match Val.eq t t' with | None -> None @@ -74,23 +79,17 @@ let to_int v = Some (out_gen (topwit wit_int) v) else None -let to_list v = - let v = normalize v in - let Val.Dyn (tag, v) = v in - match tag with - | Val.List t -> Some (List.map (fun x -> Val.Dyn (t, x)) v) - | _ -> None +let to_list v = prj Val.list_tag v -let of_list t v = Val.Dyn (Val.List t, v) +let of_list t v = Val.Dyn (Val.list_tag, List.map (fun v -> Val.inject t v) v) -let to_option v = - let v = normalize v in - let Val.Dyn (tag, v) = v in - match tag with - | Val.Opt t -> Some (Option.map (fun x -> Val.Dyn (t, x)) v) - | _ -> None +let to_option v = prj Val.opt_tag v + +let of_option t v = Val.Dyn (Val.opt_tag, Option.map (fun v -> Val.inject t v) v) + +let to_pair v = prj Val.pair_tag v -let of_option t v = Val.Dyn (Val.Opt t, v) +let of_pair t1 t2 (v1, v2) = Val.Dyn (Val.pair_tag, (Val.inject t1 v1, Val.inject t2 v2)) end diff --git a/tactics/taccoerce.mli b/tactics/taccoerce.mli index 87137fd2e7..75a3b347d6 100644 --- a/tactics/taccoerce.mli +++ b/tactics/taccoerce.mli @@ -44,6 +44,8 @@ sig val of_list : 'a Val.tag -> 'a list -> t val to_option : t -> t option option val of_option : 'a Val.tag -> 'a option -> t + val to_pair : t -> (t * t) option + val of_pair : 'a Val.tag -> 'b Val.tag -> ('a * 'b) -> t end (** {5 Coercion functions} *) -- cgit v1.2.3 From 8ad2627de29639b21473783195905dca6bb1c6ae Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 14 Apr 2016 18:33:28 +0200 Subject: Getting rid of the Geninterp.generic_interp function. --- tactics/auto.ml | 4 +++- tactics/autorewrite.ml | 4 ++-- 2 files changed, 5 insertions(+), 3 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index d7ce0d4c1a..46f484bf06 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -160,7 +160,9 @@ let conclPattern concl pat tac = let fold id c accu = Id.Map.add id (inj c) accu in let lfun = Id.Map.fold fold constr_bindings Id.Map.empty in let ist = { lfun; extra = TacStore.empty } in - Ftactic.run (Geninterp.generic_interp ist tac) (fun _ -> Proofview.tclUNIT ()) + match tac with + | GenArg (Glbwit wit, tac) -> + Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) end } (***********************************************************) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 4816f8a452..950eeef520 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -106,9 +106,9 @@ let one_base general_rewrite_maybe_in tac_main bas = let lrul = List.map (fun h -> let tac = match h.rew_tac with | None -> Proofview.tclUNIT () - | Some tac -> + | Some (Genarg.GenArg (Genarg.Glbwit wit, tac)) -> let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in - Ftactic.run (Geninterp.generic_interp ist tac) (fun _ -> Proofview.tclUNIT ()) + Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) in (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> -- cgit v1.2.3 From de4b9b68445d9f3e48da789404cbdfcd89214585 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 18 Apr 2016 14:39:34 +0200 Subject: Moving the Val module to Geninterp. --- tactics/taccoerce.ml | 9 +++++++-- tactics/taccoerce.mli | 1 + 2 files changed, 8 insertions(+), 2 deletions(-) (limited to 'tactics') diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index 298257e45d..a03c529cc0 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -14,15 +14,20 @@ open Misctypes open Genarg open Stdarg open Constrarg +open Geninterp exception CannotCoerceTo of string let (wit_constr_context : (Empty.t, Empty.t, constr) Genarg.genarg_type) = - Genarg.create_arg "constr_context" + let wit = Genarg.create_arg "constr_context" in + let () = register_val0 wit None in + wit (* includes idents known to be bound and references *) let (wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) Genarg.genarg_type) = - Genarg.create_arg "constr_under_binders" + let wit = Genarg.create_arg "constr_under_binders" in + let () = register_val0 wit None in + wit (** All the types considered here are base types *) let val_tag wit = match val_tag wit with diff --git a/tactics/taccoerce.mli b/tactics/taccoerce.mli index 75a3b347d6..82e1910f7d 100644 --- a/tactics/taccoerce.mli +++ b/tactics/taccoerce.mli @@ -12,6 +12,7 @@ open Term open Misctypes open Pattern open Genarg +open Geninterp (** Coercions from highest level generic arguments to actual data used by Ltac interpretation. Those functions examinate dynamic types and try to return -- cgit v1.2.3 From 2aae561fe772a08b03ea8a96ee28372408bf233a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 20 Apr 2016 15:15:35 +0200 Subject: Removing the Value.of_* API for parameterized types. Although still working, it is now bad practice to use it, and it is not widely spread anyway. --- tactics/taccoerce.ml | 6 ------ tactics/taccoerce.mli | 3 --- 2 files changed, 9 deletions(-) (limited to 'tactics') diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index a03c529cc0..a6e7af16e9 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -86,16 +86,10 @@ let to_int v = let to_list v = prj Val.list_tag v -let of_list t v = Val.Dyn (Val.list_tag, List.map (fun v -> Val.inject t v) v) - let to_option v = prj Val.opt_tag v -let of_option t v = Val.Dyn (Val.opt_tag, Option.map (fun v -> Val.inject t v) v) - let to_pair v = prj Val.pair_tag v -let of_pair t1 t2 (v1, v2) = Val.Dyn (Val.pair_tag, (Val.inject t1 v1, Val.inject t2 v2)) - end let is_variable env id = diff --git a/tactics/taccoerce.mli b/tactics/taccoerce.mli index 82e1910f7d..7a963f95f3 100644 --- a/tactics/taccoerce.mli +++ b/tactics/taccoerce.mli @@ -42,11 +42,8 @@ sig val of_int : int -> t val to_int : t -> int option val to_list : t -> t list option - val of_list : 'a Val.tag -> 'a list -> t val to_option : t -> t option option - val of_option : 'a Val.tag -> 'a option -> t val to_pair : t -> (t * t) option - val of_pair : 'a Val.tag -> 'b Val.tag -> ('a * 'b) -> t end (** {5 Coercion functions} *) -- cgit v1.2.3 From 4740e82e4af6d38e9cc55dfe1a05db87f73bf1e6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 20 Apr 2016 15:23:41 +0200 Subject: Removing external uses of Val.inject and making Geninterp.interp return Val.t --- tactics/auto.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index 46f484bf06..6b58baa997 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -156,7 +156,10 @@ let conclPattern concl pat tac = constr_bindings env sigma >>= fun constr_bindings -> let open Genarg in let open Geninterp in - let inj c = Val.inject (val_tag (topwit Constrarg.wit_constr)) c in + let inj c = match val_tag (topwit Constrarg.wit_constr) with + | Val.Base tag -> Val.Dyn (tag, c) + | _ -> assert false + in let fold id c accu = Id.Map.add id (inj c) accu in let lfun = Id.Map.fold fold constr_bindings Id.Map.empty in let ist = { lfun; extra = TacStore.empty } in -- cgit v1.2.3 From 8d3f0b614d7b2fb30f6e87b48a4fc5c0d286e49c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 4 May 2016 14:30:48 +0200 Subject: Normalizing the names of dynamic types to follow a typ_* scheme. --- tactics/taccoerce.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'tactics') diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index a6e7af16e9..d53c1cc04a 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -84,11 +84,11 @@ let to_int v = Some (out_gen (topwit wit_int) v) else None -let to_list v = prj Val.list_tag v +let to_list v = prj Val.typ_list v -let to_option v = prj Val.opt_tag v +let to_option v = prj Val.typ_opt v -let to_pair v = prj Val.pair_tag v +let to_pair v = prj Val.typ_pair v end -- cgit v1.2.3