From 3810bb564bf191d04c4b457f4a59cdf17f460785 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 4 Feb 2022 10:15:43 +0100 Subject: [PATCH 01/38] add Term.Db constructor --- dune | 4 ++-- src/core/eval.ml | 2 ++ src/core/infer.ml | 1 + src/core/libMeta.ml | 1 + src/core/libTerm.ml | 1 + src/core/print.ml | 1 + src/core/sign.ml | 3 +++ src/core/term.ml | 3 +++ src/core/term.mli | 1 + src/export/dk.ml | 1 + src/export/hrs.ml | 1 + src/export/xtc.ml | 3 +++ src/tool/lcr.ml | 5 +++++ src/tool/sr.ml | 2 ++ 14 files changed, 27 insertions(+), 2 deletions(-) diff --git a/dune b/dune index 5ae40ae33..e4d4dac92 100644 --- a/dune +++ b/dune @@ -1,4 +1,4 @@ ; Add project-wide flags here. (env - (dev (flags :standard)) - (release (flags :standard))) + (dev (flags :standard -w -37)) + (release (flags :standard -w -37))) diff --git a/src/core/eval.ml b/src/core/eval.ml index 500ab8a96..5bd05b0c8 100644 --- a/src/core/eval.ml +++ b/src/core/eval.ml @@ -55,6 +55,7 @@ let snf : (term -> term) -> (term -> term) = fun whnf -> let h = whnf t in if Logger.log_enabled () then log_eval "whnf %a = %a" term t term h; match h with + | Db _ -> assert false | Vari _ | Type | Kind @@ -415,6 +416,7 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = walk tr stk cursor vars_id id_vars in match t with + | Db _ -> assert false | Symb(s) -> let cons = TC.Symb(s.sym_path, s.sym_name, List.length args) in begin diff --git a/src/core/infer.ml b/src/core/infer.ml index 2b7728e97..06f15b5c3 100644 --- a/src/core/infer.ml +++ b/src/core/infer.ml @@ -91,6 +91,7 @@ and force : problem -> octxt -> term -> term -> term * bool = and infer_aux : problem -> octxt -> term -> term * term * bool = fun pb c t -> match unfold t with + | Db _ -> assert false | Patt _ -> assert false | TEnv _ -> assert false | Kind -> assert false diff --git a/src/core/libMeta.ml b/src/core/libMeta.ml index 7b1b85026..88e3093d4 100644 --- a/src/core/libMeta.ml +++ b/src/core/libMeta.ml @@ -89,6 +89,7 @@ let iter : bool -> (meta -> unit) -> ctxt -> term -> unit = fun b f c -> in let rec iter t = match unfold t with + | Db _ -> assert false | Patt _ | TEnv _ | Wild diff --git a/src/core/libTerm.ml b/src/core/libTerm.ml index f4d6c65dc..146cd41cc 100644 --- a/src/core/libTerm.ml +++ b/src/core/libTerm.ml @@ -42,6 +42,7 @@ let iter : (term -> unit) -> term -> unit = fun action -> let t = unfold t in action t; match t with + | Db _ -> assert false | Wild | Plac _ | TRef(_) diff --git a/src/core/print.ml b/src/core/print.ml index dbc5d91ea..f7f172874 100644 --- a/src/core/print.ml +++ b/src/core/print.ml @@ -206,6 +206,7 @@ and term : term pp = fun ppf t -> | _ -> assert false in match unfold t with + | Db _ -> assert false | Appl(_,_) -> assert false (* Application is handled separately, unreachable. *) | Wild -> out ppf "_" diff --git a/src/core/sign.ml b/src/core/sign.ml index 6189ac9ac..d42bf0118 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -91,6 +91,7 @@ let link : t -> unit = fun sign -> let link_term mk_Appl = let rec link_term t = match unfold t with + | Db _ -> assert false | Vari _ | Type | Kind -> t @@ -176,6 +177,7 @@ let unlink : t -> unit = fun sign -> | Wild -> assert false | TRef _ -> assert false | TEnv(_,ts) -> Array.iter unlink_term ts + | Db _ -> assert false | Patt _ | Vari _ | Type @@ -272,6 +274,7 @@ let read : string -> t = fun fname -> in let rec reset_term t = match unfold t with + | Db _ -> assert false | Vari _ | Type | Kind -> () diff --git a/src/core/term.ml b/src/core/term.ml index 4fe22b374..41710b7c7 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -65,6 +65,7 @@ type term = | TRef of term option ref (** Reference cell (used in surface matching). *) | LLet of term * term * tbinder (** [LLet(a, t, u)] is [let x : a ≔ t in u] (with [x] bound in [u]). *) + | Db of int (** Bound variable as de Bruijn index. *) (** {b NOTE} that a wildcard "_" of the concrete (source code) syntax may have a different representation depending on the application. For instance, the @@ -233,6 +234,7 @@ let minimize_impl : bool list -> bool list = module Raw = struct let rec term : term pp = fun ppf t -> match t with + | Db _ -> assert false | Vari v -> var ppf v | Type -> out ppf "TYPE" | Kind -> out ppf "KIND" @@ -715,6 +717,7 @@ let _TE_None : tebox = Bindlib.box TE_None let lift : (tbox -> tbox -> tbox) -> term -> tbox = fun mk_appl -> let rec lift t = match unfold t with + | Db _ -> assert false | Vari x -> _Vari x | Type -> _Type | Kind -> _Kind diff --git a/src/core/term.mli b/src/core/term.mli index 88dd8ede5..6d779fe40 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -64,6 +64,7 @@ type term = private | TRef of term option ref (** Reference cell (used in surface matching). *) | LLet of term * term * tbinder (** [LLet(a, t, u)] is [let x : a ≔ t in u] (with [x] bound in [u]). *) + | Db of int (** Bound variable as de Bruijn index. *) (** {b NOTE} that a wildcard "_" of the concrete (source code) syntax may have a different representation depending on the application. For instance, the diff --git a/src/export/dk.ml b/src/export/dk.ml index 6e0f3d64f..874ae131a 100644 --- a/src/export/dk.ml +++ b/src/export/dk.ml @@ -119,6 +119,7 @@ let tenv : term_env pp = fun ppf te -> let rec term : bool -> term pp = fun b ppf t -> match unfold t with + | Db _ -> assert false | Vari v -> tvar ppf v | Type -> out ppf "Type" | Kind -> assert false diff --git a/src/export/hrs.ml b/src/export/hrs.ml index cb372af12..fb7ad2e62 100644 --- a/src/export/hrs.ml +++ b/src/export/hrs.ml @@ -20,6 +20,7 @@ let print_term : bool -> term pp = fun lhs -> let rec pp ppf t = match unfold t with (* Forbidden cases. *) + | Db _ -> assert false | Meta(_,_) -> assert false | Plac _ -> assert false | TRef(_) -> assert false diff --git a/src/export/xtc.ml b/src/export/xtc.ml index 5c23de43e..1b8e9df2b 100644 --- a/src/export/xtc.ml +++ b/src/export/xtc.ml @@ -32,6 +32,7 @@ let status : sym -> symb_status = fun s -> let rec print_term : int -> string -> term pp = fun i s ppf t -> match unfold t with (* Forbidden cases. *) + | Db _ -> assert false | Meta(_,_) -> assert false | Plac _ -> assert false | TRef(_) -> assert false @@ -60,6 +61,7 @@ let rec print_term : int -> string -> term pp = fun i s ppf t -> and print_type : int -> string -> term pp = fun i s ppf t -> match unfold t with (* Forbidden cases. *) + | Db _ -> assert false | Meta(_,_) -> assert false | Plac _ -> assert false | TRef(_) -> assert false @@ -116,6 +118,7 @@ let get_vars : sym -> rule -> (string * Term.term) list = fun s r -> let var_list : tvar list ref = ref [] in let rec subst_patt v t = match t with + | Db _ -> assert false | Type | Kind | TEnv (_, _) diff --git a/src/tool/lcr.ml b/src/tool/lcr.ml index 3ce5470eb..227a6f087 100644 --- a/src/tool/lcr.ml +++ b/src/tool/lcr.ml @@ -78,6 +78,7 @@ let replace : term -> subterm_pos -> term -> term = fun t p u -> let occurs : int -> term -> bool = fun i -> let rec occ t = match unfold t with + | Db _ -> assert false | Patt(None,_,_) -> assert false | Patt(Some j,_,_) -> i=j | Vari _ | Symb _ -> false @@ -97,6 +98,7 @@ let occurs : int -> term -> bool = fun i -> let shift : term -> term = let rec shift : term -> tbox = fun t -> match unfold t with + | Db _ -> assert false | Vari x -> _Vari x | Type -> _Type | Kind -> _Kind @@ -133,6 +135,7 @@ let apply_subs : subs -> term -> term = fun s t -> let rec apply_subs t = (*if Logger.log_enabled() then log_cp "%a" term t;*) match unfold t with + | Db _ -> assert false | Patt(None, _, _) -> assert false | Patt(Some i,_,[||]) -> begin try IntMap.find i s with Not_found -> t end @@ -172,6 +175,7 @@ let iter_subterms_from_pos : subterm_pos -> iter = | Vari _ -> iter_args p t | Abst(a,b) | Prod(a,b) -> iter (0::p) a; let _,b = Bindlib.unbind b in iter (1::p) b + | Db _ -> assert false | Appl _ -> assert false | Type -> assert false | Kind -> assert false @@ -201,6 +205,7 @@ let iter_subterms_eq : iter = iter_subterms_from_pos [] let iter_subterms : iter = fun pos f t -> (*if Logger.log_enabled() then log_cp "iter_subterms %a" term t;*) match unfold t with + | Db _ -> assert false | Symb _ | Patt _ | Vari _ -> () diff --git a/src/tool/sr.ml b/src/tool/sr.ml index 4c6912699..c08538812 100644 --- a/src/tool/sr.ml +++ b/src/tool/sr.ml @@ -55,6 +55,7 @@ let patt_to_tenv : tevar array -> term -> tbox = fun vars -> _Abst (trans a) (Bindlib.bind_var x (trans b)) | Appl(t,u) -> _Appl (trans t) (trans u) | Patt(i,_,a) -> _TEnv (_TE_Vari (get_te i)) (Array.map trans a) + | Db _ -> assert false | Type -> assert false (* Cannot appear in LHS. *) | Kind -> assert false (* Cannot appear in LHS. *) | Prod(_,_) -> assert false (* Cannot appear in LHS. *) @@ -86,6 +87,7 @@ let symb_to_tenv let ts = List.map symb_to_tenv ts in let (h, ts) = match h with + | Db _ -> assert false | Symb(f) when List.memq f syms -> let i = try Hashtbl.find htbl f.sym_name with Not_found -> From 2dfeb714a9b73feb8c42cc05620e2eb814c6d32c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 8 Feb 2022 17:13:21 +0100 Subject: [PATCH 02/38] remove Bindlib from terms (but not rhs) --- src/core/eval.ml | 15 +- src/core/inverse.ml | 8 +- src/core/print.ml | 5 +- src/core/sign.ml | 10 +- src/core/term.ml | 513 +++++++++++++++++++++++++++++++++----- src/core/term.mli | 126 +++++++++- src/core/unif.ml | 2 +- src/export/dk.ml | 4 +- src/handle/rewrite.ml | 16 +- src/parsing/scope.ml | 17 +- src/parsing/scope.mli | 4 +- src/parsing/syntax.ml | 2 +- src/pure/pure.ml | 2 +- src/tool/lcr.ml | 5 +- src/tool/sr.ml | 15 +- src/tool/tree_graphviz.ml | 2 +- 16 files changed, 622 insertions(+), 124 deletions(-) diff --git a/src/core/eval.ml b/src/core/eval.ml index 5bd05b0c8..75078a5bb 100644 --- a/src/core/eval.ml +++ b/src/core/eval.ml @@ -301,7 +301,7 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = | Leaf(rhs_subst, (act, xvars)) -> (* Apply the RHS substitution *) (* Allocate an environment where to place terms coming from the pattern variables for the action. *) - let env_len = Bindlib.mbinder_arity act in + let env_len = OldBindlib.mbinder_arity act in assert (List.length rhs_subst = env_len - xvars); let env = Array.make env_len TE_None in (* Retrieve terms needed in the action from the [vars] array. *) @@ -310,11 +310,6 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = | TE_Vari(_) -> assert false | TE_Some(_) -> env.(slot) <- bound.(pos) | TE_None -> - if Array.length xs = 0 then - let t = unfold vars.(pos) in - let b = Bindlib.raw_mbinder [||] [||] 0 of_tvar (fun _ -> t) - in env.(slot) <- TE_Some(b) - else let xs = Array.map (fun e -> IntMap.find e id_vars) xs in env.(slot) <- TE_Some(binds xs lift vars.(pos)) in @@ -323,10 +318,9 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = for i = env_len - xvars to env_len - 1 do let mt = LibMeta.make cfg.problem cfg.context mk_Type in let t = LibMeta.make cfg.problem cfg.context mt in - let b = Bindlib.raw_mbinder [||] [||] 0 of_tvar (fun _ -> t) in - env.(i) <- TE_Some(b) + env.(i) <- TE_Some(binds [||] lift t) done; - Some (Bindlib.msubst act env, stk) + Some (OldBindlib.msubst act env, stk) | Cond({ok; cond; fail}) -> let next = match cond with @@ -346,7 +340,8 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = in (* Ensure there are no variables from [forbidden] in [b]. *) let no_forbidden b = - not (IntMap.exists (fun _ x -> Bindlib.occur x b) forbidden) + not (IntMap.exists (fun _ x -> Bindlib.occur_tmbinder x b) + forbidden) in (* We first attempt to match [vars.(i)] directly. *) let b = Bindlib.bind_mvar allowed (lift vars.(i)) in diff --git a/src/core/inverse.ml b/src/core/inverse.ml index 4ddd9217e..11672d804 100644 --- a/src/core/inverse.ml +++ b/src/core/inverse.ml @@ -35,8 +35,8 @@ let const_graph : sym -> (sym * sym) list = fun s -> begin match get_args l1 with | Symb s0, _ -> - let n = Bindlib.mbinder_arity rule.rhs in - let r = Bindlib.msubst rule.rhs (Array.make n TE_None) in + let n = OldBindlib.mbinder_arity rule.rhs in + let r = OldBindlib.msubst rule.rhs (Array.make n TE_None) in begin match get_args r with | Symb s1, _ -> add s0 s1 l @@ -76,8 +76,8 @@ let prod_graph : sym -> (sym * sym * sym * bool) list = fun s -> begin match get_args l1 with | Symb s0, [_;_] -> - let n = Bindlib.mbinder_arity rule.rhs in - let r = Bindlib.msubst rule.rhs (Array.make n TE_None) in + let n = OldBindlib.mbinder_arity rule.rhs in + let r = OldBindlib.msubst rule.rhs (Array.make n TE_None) in begin match r with | Prod(a,b) -> diff --git a/src/core/print.ml b/src/core/print.ml index f7f172874..696a0d64c 100644 --- a/src/core/print.ml +++ b/src/core/print.ml @@ -89,7 +89,8 @@ let sym : sym pp = fun ppf s -> else out ppf "%a.%a" path p uid n | Some alias -> out ppf "%a.%a" uid alias uid n -let var : 'a Bindlib.var pp = fun ppf x -> uid ppf (Bindlib.name_of x) +let var : tvar pp = fun ppf x -> uid ppf (Bindlib.name_of x) +let tevar : tevar pp = fun ppf x -> uid ppf (OldBindlib.name_of x) (** Exception raised when trying to convert a term into a nat. *) exception Not_a_nat @@ -202,7 +203,7 @@ and term : term pp = fun ppf t -> if Array.length ts > 0 then out ppf ".[%a]" (Array.pp func ";") ts in let term_env ppf te = match te with - | TE_Vari(m) -> var ppf m + | TE_Vari(x) -> string ppf (OldBindlib.name_of x) | _ -> assert false in match unfold t with diff --git a/src/core/sign.ml b/src/core/sign.ml index d42bf0118..d82e8d358 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -114,9 +114,9 @@ let link : t -> unit = fun sign -> and link_term = link_term mk_Appl in let link_rule r = let lhs = List.map link_lhs r.lhs in - let (xs, rhs) = Bindlib.unmbind r.rhs in - let rhs = lift (link_term rhs) in - let rhs = Bindlib.unbox (Bindlib.bind_mvar xs rhs) in + let (xs, rhs) = OldBindlib.unmbind r.rhs in + let rhs = old_lift (link_term rhs) in + let rhs = OldBindlib.unbox (OldBindlib.bind_mvar xs rhs) in {r with lhs ; rhs} in let f _ s = @@ -185,7 +185,7 @@ let unlink : t -> unit = fun sign -> and unlink_binder b = unlink_term (snd (Bindlib.unbind b)) in let unlink_rule r = List.iter unlink_term r.lhs; - let (_, rhs) = Bindlib.unmbind r.rhs in + let (_, rhs) = OldBindlib.unmbind r.rhs in unlink_term rhs in let f _ s = @@ -292,7 +292,7 @@ let read : string -> t = fun fname -> and reset_binder b = reset_term (snd (Bindlib.unbind b)) in let reset_rule r = List.iter reset_term r.lhs; - reset_term (snd (Bindlib.unmbind r.rhs)) + reset_term (snd (OldBindlib.unmbind r.rhs)) in let reset_sym s = shallow_reset_sym s; diff --git a/src/core/term.ml b/src/core/term.ml index 41710b7c7..31f875cf2 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -11,6 +11,8 @@ open Timed open Lplib open Base open Common open Debug +module OldBindlib = Bindlib + let log_term = Logger.make 'm' "term" "term building" let log_term = log_term.pp @@ -78,7 +80,7 @@ type term = rewriting rules (see {!field:Term.rhs}) with the number of variables that are not in the LHS. In decision trees, a RHS is stored in every leaf since they correspond to matched rules. *) -and rhs = (term_env, term) Bindlib.mbinder +and rhs = (term_env, term) OldBindlib.mbinder (** Representation of a decision tree (used for rewriting). *) and dtree = (rhs * int) Tree_type.dtree @@ -213,65 +215,336 @@ and sym = ; meta_arity : int (** Arity (environment size). *) ; meta_value : tmbinder option ref (** Definition. *) } -and tbinder = (term, term) Bindlib.binder - -and tmbinder = (term, term) Bindlib.mbinder +and tbinder = string * term -and tvar = term Bindlib.var +and tmbinder = string array * term -and tevar = term_env Bindlib.var +and tvar = int * string -type tbox = term Bindlib.box - -type tebox = term_env Bindlib.box - -(** Minimize [impl] to enforce our invariant (see {!type:Terms.sym}). *) -let minimize_impl : bool list -> bool list = - let rec rem_false l = match l with false::l -> rem_false l | _ -> l in - fun l -> List.rev (rem_false (List.rev l)) +and tevar = term_env OldBindlib.var (** Printing functions for debug. *) module Raw = struct let rec term : term pp = fun ppf t -> match t with - | Db _ -> assert false + | Db k -> out ppf "`%d" k | Vari v -> var ppf v | Type -> out ppf "TYPE" | Kind -> out ppf "KIND" | Symb s -> sym ppf s - | Prod(a,b) -> - if Bindlib.binder_constant b then - let _, b = Bindlib.unbind b in out ppf "(%a → %a)" term a term b - else out ppf "(Π %a)" binder (a,b) - | Abst(a,b) -> out ppf "(λ %a)" binder (a,b) + | Prod(a,(n,b)) -> out ppf "(Π %s: %a, %a)" n term a term b + | Abst(a,(n,b)) -> out ppf "(λ %s: %a, %a)" n term a term b | Appl(a,b) -> out ppf "(%a %a)" term a term b - | Meta(m,ts) -> out ppf "?%a%a" meta m terms ts + | Meta(m,ts) -> out ppf "?%d%a" m.meta_key terms ts | Patt(i,s,ts) -> out ppf "$%a_%s%a" (D.option D.int) i s terms ts | Plac(_) -> out ppf "_" | TEnv(te,ts) -> out ppf "<%a>%a" tenv te terms ts | Wild -> out ppf "_" | TRef r -> out ppf "&%a" (Option.pp term) !r - | LLet(a,t,u) -> - let x, u = Bindlib.unbind u in - out ppf "let %a: %a ≔ %a in %a" var x term a term t term u + | LLet(a,t,(n,b)) -> + out ppf "let %s : %a ≔ %a in %a" n term a term t term b +and var : tvar pp = fun ppf (i,n) -> out ppf "#%d_%s" i n +and sym : sym pp = fun ppf s -> string ppf s.sym_name and terms : term array pp = fun ppf ts -> - (*if Array.length ts > 0 then*) D.array term ppf ts -and var : tvar pp = fun ppf v -> out ppf "%s" (Bindlib.name_of v) -and binder : (term * tbinder) pp = fun ppf (a,b) -> - let x, b = Bindlib.unbind b in - out ppf "%a: %a, %a" var x term a term b -and meta : meta pp = fun ppf m -> - out ppf "%d" m.meta_key -and sym : sym pp = fun ppf s -> out ppf "%s" s.sym_name + if Array.length ts > 0 then D.array term ppf ts and tenv : term_env pp = fun ppf te -> match te with - | TE_Vari v -> out ppf "%s" (Bindlib.name_of v) - | TE_Some mb -> - let vs, b = Bindlib.unmbind mb in - out ppf "%a,%a" (D.array var) vs term b + | TE_Vari v -> out ppf "%s" (OldBindlib.name_of v) + | TE_Some (ns,b) -> out ppf "%a, %a" (Array.pp string " ") ns term b | TE_None -> () end +module Bindlib = struct + +(** [unfold t] repeatedly unfolds the definition of the surface constructor of + [t], until a significant {!type:term} constructor is found. The term that + is returned cannot be an instantiated metavariable or term environment nor + a reference cell ({!constructor:TRef} constructor). Note that the returned + value is physically equal to [t] if no unfolding was performed. *) +let rec unfold : term -> term = fun t -> + match t with + | Meta(m, ts) -> + begin + match !(m.meta_value) with + | None -> t + | Some(b) -> unfold (msubst b ts) + end + | TRef(r) -> + begin + match !r with + | None -> t + | Some(v) -> unfold v + end + | _ -> t + +(** [msubst b vs] substitutes the variables bound by [b] with the values [vs]. + Note that the length of the [vs] array should match the arity of the + multiple binder [b]. *) +and msubst : tmbinder -> term array -> term = fun (ns,t) vs -> + let n = Array.length ns in + assert (Array.length vs = n); + if n = 0 then t else + let rec msubst i t = + match unfold t with + | Db k -> if k < i + n then vs.(k-i) else t + | Appl(a,b) -> (*FIXME: mk_Appl*) Appl(msubst i a, msubst i b) + | Abst(a,(n,u)) -> Abst(msubst i a, (n, msubst (i+1) u)) + | Prod(a,(n,u)) -> Prod(msubst i a, (n, msubst (i+1) u)) + | LLet(a,t,(n,u)) -> LLet(msubst i a, msubst i t, (n, msubst (i+1) u)) + | Meta(m,ts) -> Meta(m, Array.map (msubst i) ts) + | Patt(j,n,ts) -> Patt(j,n, Array.map (msubst i) ts) + | TEnv(te,ts) -> TEnv(te, Array.map (msubst i) ts) + | _ -> t + in msubst 1 t + +let msubst3 : + (tmbinder * tmbinder * tmbinder) -> term array -> term * term * term = + fun (b1, b2, b3) ts -> msubst b1 ts, msubst b2 ts, msubst b3 ts + +(** [subst b v] substitutes the variable bound by [b] with the value [v]. *) +let subst : tbinder -> term -> term = fun (_,t) v -> + let rec subst i t = + (*if Logger.log_enabled() then + log_term "subst [%d≔%a] %a" i Raw.term v Raw.term t;*) + match unfold t with + | Db k -> if k = i then v else t + | Appl(a,b) -> (*FIXME: mk_Appl*) Appl(subst i a, subst i b) + | Abst(a,(n,u)) -> Abst(subst i a, (n, subst (i+1) u)) + | Prod(a,(n,u)) -> Prod(subst i a, (n ,subst (i+1) u)) + | LLet(a,t,(n,u)) -> LLet(subst i a, subst i t, (n, subst (i+1) u)) + | Meta(m,ts) -> Meta(m, Array.map (subst i) ts) + | Patt(j,n,ts) -> Patt(j,n, Array.map (subst i) ts) + | TEnv(te,ts) -> TEnv(te, Array.map (subst i) ts) + | _ -> t + in + let r = subst 1 t in + if Logger.log_enabled() then + log_term "@[subst [1≔%a]@ %a =@ %a@]" + Raw.term v Raw.term t Raw.term r; + r + +(** [new_var _ name] creates a new unique variable using [name]. *) +let new_var : (tvar -> term) -> string -> tvar = + let open Stdlib in let n = ref 0 in + fun _ name -> incr n; !n, name + +let mkfree : tvar -> term = fun x -> Vari x + +(** [new_mvar names] creates a new array of new unique variables using + [names]. *) +let new_mvar : string array -> tvar array = Array.map (new_var mkfree) + +(** [name_of x] returns a printable name for variable [x]. *) +let name_of : tvar -> string = fun (_,n) -> n + +(** [unbind b] substitutes the binder [b] using a fresh variable. The variable + and the result of the substitution are returned. Note that the name of the + fresh variable is based on that of the binder. The [mkfree] function used + to create the fresh variable is that of the variable that was bound by [b] + at its construction (see [new_var] and [bind_var]). *) +let unbind : tbinder -> tvar * term = fun ((name,_) as b) -> + let x = new_var mkfree name in x, subst b (Vari x) + +(** [unbind2 f g] is similar to [unbind f], but it substitutes two binders [f] + and [g] at once using the same fresh variable. The name of the variable is + based on that of the binder [f]. Similarly, the [mkfree] syntactic wrapper + that is used for the fresh variable is the one that was given for creating + the variable that was bound to construct [f] (see [bind_var] and [new_var] + for details on this process). In particular, the use of [unbind2] may lead + to unexpected results if the binders [f] and [g] were not built using free + variables created with the same [mkfree]. *) +let unbind2 : tbinder -> tbinder -> tvar * term * term = + fun ((name1,_) as b1) b2 -> + let x = new_var mkfree name1 in x, subst b1 (Vari x), subst b2 (Vari x) + +(** [unmbind b] substitutes the multiple binder [b] with fresh variables. This + function is analogous to [unbind] for binders. Note that the names used to + create the fresh variables are based on those of the multiple binder. The + syntactic wrapper (of [mkfree]) that is used to build the variables is the + one that was given when creating the multiple variables that were bound in + [b] (see [new_mvar] and [bind_mvar]). *) +let unmbind : tmbinder -> tvar array * term = fun ((names,_) as b) -> + let xs = + Array.init (Array.length names) (fun i -> new_var mkfree names.(i)) in + xs, msubst b (Array.map mkfree xs) + +(** [unmbind2 f g] is similar to [unmbind f], but it substitutes two multiple + binder [f] and [g] at once, using the same fresh variables. Note that the + two binders must have the same arity. This function may have an unexpected + results in some cases (see the documentation of [unbind2]). *) +let unmbind2 : tmbinder -> tmbinder -> tvar array * term * term + = fun ((names,_) as b1) b2 -> + let xs = + Array.init (Array.length names) (fun i -> new_var mkfree names.(i)) in + let ts = Array.map mkfree xs in + xs, msubst b1 ts, msubst b2 ts + +(** Type of a term under construction. Using this representation, + the free variable of the term can be bound easily. *) +type 'a box = 'a + +(** [box e] injects the value [e] into the [term box] type, assuming that it + is closed. Thus, if [e] contains variables, then they will not be + considered free. This means that no variable of [e] will be available for + binding. *) +let box : 'a -> 'a box = fun t -> t + +(** [box_apply f ba] applies the function [f] to a boxed argument [ba]. It is + equivalent to [apply_box (box f) ba], but is more efficient. *) +let box_apply : ('a -> 'b) -> 'a box -> 'b box = fun x -> x + +(** [box_apply2 f ba bb] applies the function [f] to two boxed arguments [ba] + and [bb]. It is equivalent to [apply_box (apply_box (box f) ba) bb] but it + is more efficient. *) +let box_apply2 : ('a -> 'b -> 'c) -> 'a box -> 'b box -> 'c box = fun x -> x + +(** [bind_var x b] binds the variable [x] in [b], producing a boxed binder. *) +let bind_var : tvar -> term box -> tbinder box = fun ((_,n) as x) -> + let rec bind i t = + (*if Logger.log_enabled() then + log_term "bind_var %a %d %a" Raw.var x i Raw.term t;*) + match unfold t with + | Vari y when y == x -> Db i + | Appl(a,b) -> Appl(bind i a, bind i b) + | Abst(a,(n,u)) -> Abst(bind i a, (n, bind (i+1) u)) + | Prod(a,(n,u)) -> Prod(bind i a, (n, bind (i+1) u)) + | LLet(a,t,(n,u)) -> LLet(bind i a, bind i t, (n, bind (i+1) u)) + | Meta(m,ts) -> Meta(m, Array.map (bind i) ts) + | Patt(j,n,ts) -> Patt(j,n, Array.map (bind i) ts) + | TEnv(te,ts) -> TEnv(te, Array.map (bind i) ts) + | _ -> t + in fun t -> + let r = bind 1 t in + if Logger.log_enabled() then + log_term "@[bind_var %a@ %a =@ %a@]" + Raw.var x Raw.term t Raw.term r; + n, r + +(** [bind_mvar xs b] binds the variables of [xs] in [b] to get a boxed binder. + It is the equivalent of [bind_var] for multiple variables. *) +let bind_mvar : tvar array -> term box -> tmbinder box = fun xs -> + let open Stdlib in let open Extra in + let map = ref IntMap.empty in + Array.iteri (fun i (ki,_) -> map := IntMap.add ki i !map) xs; + let rec bind i t = + match unfold t with + | Vari (key,_) -> + (match IntMap.find_opt key !map with Some k -> Db (i+k) | None -> t) + | Appl(a,b) -> Appl(bind i a, bind i b) + | Abst(a,(n,u)) -> Abst(bind i a, (n, bind (i+1) u)) + | Prod(a,(n,u)) -> Prod(bind i a, (n, bind (i+1) u)) + | LLet(a,t,(n,u)) -> LLet(bind i a, bind i t, (n, bind (i+1) u)) + | Meta(m,ts) -> Meta(m, Array.map (bind i) ts) + | Patt(j,n,ts) -> Patt(j,n, Array.map (bind i) ts) + | TEnv(te,ts) -> TEnv(te, Array.map (bind i) ts) + | _ -> t + in fun t -> + if Array.length xs = 0 then [||], t + else Array.map name_of xs, bind 1 t + +let bind_mvar3 : tvar array -> (term box * term box * term box) + -> tmbinder box * tmbinder box * tmbinder box = fun xs (t1, t2, t3) -> + bind_mvar xs t1, bind_mvar xs t2, bind_mvar xs t3 + +(** [unbox e] can be called when the construction of a term is finished (e.g., + when the desired variables have all been bound). *) +let unbox : 'a box -> 'a = fun x -> x + +(** [box_array bs] shifts the [array] type of [bs] into the [box]. *) +let box_array : 'a box array -> 'a array box = fun x -> x + +(** [box_apply3] is similar to [box_apply2]. *) +let box_apply3 : ('a -> 'b -> 'c -> 'd) + -> 'a box -> 'b box -> 'c box -> 'd box = fun x -> x + +(** [box_pair ba bb] is the same as [box_apply2 (fun a b -> (a,b)) ba bb]. *) +let box_pair : 'a box -> 'b box -> ('a * 'b) box = fun x y -> x,y + +(** [box_triple] is similar to [box_pair], but for triples. *) +let box_triple : 'a box -> 'b box -> 'c box -> ('a * 'b * 'c) box = + fun x y z -> x,y,z + +(** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to + compare variables using [Pervasive.compare]. *) +let compare_vars : tvar -> tvar -> int = fun (i,_) (j,_) -> Stdlib.compare i j + +(** [eq_vars x y] safely computes the equality of [x] and [y]. Note that it is + unsafe to compare variables with the polymorphic equality function. *) +let eq_vars : tvar -> tvar -> bool = fun x y -> compare_vars x y = 0 + +(** [binder_occur b] tests whether the bound variable occurs in [b]. *) +let binder_occur : tbinder -> bool = fun (_,t) -> + let rec check i t = + (*if Logger.log_enabled() then + log_term "binder_occur %d %a" i Raw.term t;*) + match unfold t with + | Db k when k = i -> raise Exit + | Appl(a,b) -> check i a; check i b + | Abst(a,(_,u)) + | Prod(a,(_,u)) -> check i a; check (i+1) u + | LLet(a,t,(_,u)) -> check i a; check i t; check (i+1) u + | Meta(_,ts) + | Patt(_,_,ts) + | TEnv(_,ts) -> Array.iter (check i) ts + | _ -> () + in + let r = try check 1 t; false with Exit -> true in + if Logger.log_enabled() then + log_term "binder_occur 1 %a = %b" Raw.term t r; + r + +(** [binder_constant b] tests whether the [binder] [b] is constant (i.e., its + bound variable does not occur). *) +let binder_constant : tbinder -> bool = fun b -> not (binder_occur b) + +(** [mbinder_arity b] gives the arity of the [mbinder]. *) +let mbinder_arity : tmbinder -> int = fun (names,_) -> Array.length names + +(** [is_closed b] checks whether the [box] [b] is closed. *) +let is_closed : term box -> bool = + let rec check t = + match unfold t with + | Vari _ -> raise Exit + | Appl(a,b) -> check a; check b + | Abst(a,(_,u)) + | Prod(a,(_,u)) -> check a; check u + | LLet(a,t,(_,u)) -> check a; check t; check u + | Meta(_,ts) + | Patt(_,_,ts) + | TEnv(_,ts) -> Array.iter check ts + | _ -> () + in fun t -> try check t; true with Exit -> false + +let is_closed_tmbinder : tmbinder box -> bool = fun (_,t) -> is_closed t + +(** [occur x b] tells whether variable [x] occurs in the [box] [b]. *) +let occur : tvar -> term box -> bool = fun x -> + let rec check t = + match unfold t with + | Vari y when y == x -> raise Exit + | Appl(a,b) -> check a; check b + | Abst(a,(_,u)) + | Prod(a,(_,u)) -> check a; check u + | LLet(a,t,(_,u)) -> check a; check t; check u + | Meta(_,ts) + | Patt(_,_,ts) + | TEnv(_,ts) -> Array.iter check ts + | _ -> () + in fun t -> try check t; false with Exit -> true + +let occur_tmbinder : tvar -> tmbinder box -> bool = fun x (_,t) -> occur x t + +end + +type tbox = term Bindlib.box + +type tebox = term_env Bindlib.box + +(** Minimize [impl] to enforce our invariant (see {!type:Terms.sym}). *) +let minimize_impl : bool list -> bool list = + let rec rem_false l = match l with false::l -> rem_false l | _ -> l in + fun l -> List.rev (rem_false (List.rev l)) + (** Typing context associating a [Bindlib] variable to a type and possibly a definition. The typing environment [x1:A1,..,xn:An] is represented by the list [xn:An;..;x1:A1] in reverse order (last added variable comes @@ -310,7 +583,7 @@ let new_tvar_ind : string -> int -> tvar = fun s i -> let of_tevar : tevar -> term_env = fun x -> TE_Vari(x) (** [new_tevar s] creates a new [tevar] with name [s]. *) -let new_tevar : string -> tevar = Bindlib.new_var of_tevar +let new_tevar : string -> tevar = OldBindlib.new_var of_tevar (** Sets and maps of symbols. *) module Sym = struct @@ -421,6 +694,7 @@ let is_symb : sym -> term -> bool = fun s t -> let cmp : term cmp = let rec cmp t t' = match unfold t, unfold t' with + | Db i, Db j -> Stdlib.compare i j | Vari x, Vari x' -> Bindlib.compare_vars x x' | Type, Type | Kind, Kind @@ -439,15 +713,15 @@ let cmp : term cmp = | TRef r, TRef r' -> Stdlib.compare r r' | LLet(a,t,u), LLet(a',t',u') -> lex3 cmp cmp cmp_binder (a,t,u) (a',t',u') - | t, t' -> cmp_tag (*cmp_map Stdlib.compare prec*) t t' + | t, t' -> cmp_tag t t' and cmp_binder t t' = let (_,t,t') = Bindlib.unbind2 t t' in cmp t t' and cmp_mbinder t t' = let (_,t,t') = Bindlib.unmbind2 t t' in cmp t t' and cmp_tenv e e' = match e, e' with - | TE_Vari v, TE_Vari v' -> Bindlib.compare_vars v v' + | TE_Vari v, TE_Vari v' -> OldBindlib.compare_vars v v' | TE_None, TE_None -> 0 | TE_Some t, TE_Some t' -> cmp_mbinder t t' - | _ -> cmp_tag (*cmp_map Stdlib.compare prec_tenv*) e e' + | _ -> cmp_tag e e' in cmp (** [get_args t] decomposes the {!type:term} [t] into a pair [(h,args)], where @@ -621,7 +895,7 @@ let add_args_map : term -> (term -> term) -> term list -> term = fun t f ts -> (** [_Vari x] injects the free variable [x] into the {!type:tbox} type so that it may be available for binding. *) -let _Vari : tvar -> tbox = Bindlib.box_var +let _Vari : tvar -> tbox = fun x -> Vari x (** [_Type] injects the constructor [Type] into the {!type:tbox} type. *) let _Type : tbox = Bindlib.box Type @@ -705,45 +979,152 @@ let _LLet : tbox -> tbox -> tbinder Bindlib.box -> tbox = (** [_TE_Vari x] injects a term environment variable [x] into the {!type:tbox} type so that it may be available for binding. *) -let _TE_Vari : tevar -> tebox = Bindlib.box_var +let _TE_Vari : tevar -> tebox = fun x -> TE_Vari x (** [_TE_None] injects the constructor [TE_None] into the {!type:tbox} type.*) let _TE_None : tebox = Bindlib.box TE_None -(** [lift mk_appl t] lifts the {!type:term} [t] to the type {!type:tbox}, - using the function [mk_appl] in the case of an application. This has the - effect of gathering its free variables, making them available for binding. - Bound variable names are automatically updated in the process. *) -let lift : (tbox -> tbox -> tbox) -> term -> tbox = fun mk_appl -> - let rec lift t = +module Old = struct + +type tbox = term OldBindlib.box +type tebox = term_env OldBindlib.box + +let _Db : int -> tbox = fun k -> OldBindlib.box (Db k) + +(** [_Vari x] injects the free variable [x] into the {!type:tbox} type so that + it may be available for binding. *) +let _Vari : tvar -> tbox = fun x -> OldBindlib.box (Vari x) + +(** [_Type] injects the constructor [Type] into the {!type:tbox} type. *) +let _Type : tbox = OldBindlib.box Type + +(** [_Kind] injects the constructor [Kind] into the {!type:tbox} type. *) +let _Kind : tbox = OldBindlib.box Kind + +(** [_Symb s] injects the constructor [Symb(s)] into the {!type:tbox} type. As + symbols are closed object they do not require lifting. *) +let _Symb : sym -> tbox = fun s -> OldBindlib.box (Symb s) + +(** [_Appl t u] lifts an application node to the {!type:tbox} type given boxed + terms [t] and [u]. *) +let _Appl : tbox -> tbox -> tbox = + OldBindlib.box_apply2 (fun t u -> mk_Appl (t,u)) + +(** [_Appl_not_canonical t u] lifts an application node to the {!type:tbox} + type given boxed terms [t] and [u], without putting it in canonical form + wrt. C and AC symbols. WARNING: to use in scoping of rewrite rule LHS only + as it breaks some invariants. *) +let _Appl_not_canonical : tbox -> tbox -> tbox = + OldBindlib.box_apply2 (fun t u -> Appl (t,u)) + +(** [_Appl_list a [b1;...;bn]] returns (... ((a b1) b2) ...) bn. *) +let _Appl_list : tbox -> tbox list -> tbox = List.fold_left _Appl + +(** [_Appl_Symb f ts] returns the same result that + _Appl_l ist (_Symb [f]) [ts]. *) +let _Appl_Symb : sym -> tbox list -> tbox = fun f ts -> + _Appl_list (_Symb f) ts + +(** [_Prod a b] lifts a dependent product node to the {!type:tbox} type, given + a boxed term [a] for the domain of the product, and a boxed binder [b] for + its codomain. *) +let _Prod : tbox -> tbinder OldBindlib.box -> tbox = + OldBindlib.box_apply2 (fun a b -> Prod(a,b)) + +let impl : term -> term -> term = fun a b -> + let v = new_tvar "_" in mk_Prod(a, Bindlib.bind_var v b) + +let _Impl : tbox -> tbox -> tbox = OldBindlib.box_apply2 impl + +(** [_Abst a t] lifts an abstraction node to the {!type:tbox} type, given a + boxed term [a] for the domain type, and a boxed binder [t]. *) +let _Abst : tbox -> tbinder OldBindlib.box -> tbox = + OldBindlib.box_apply2 (fun a t -> Abst(a,t)) + +(** [_Meta m ts] lifts the metavariable [m] to the {!type:tbox} type given its + environment [ts]. As for symbols in {!val:_Symb}, metavariables are closed + objects so they do not require lifting. *) +let _Meta : meta -> tbox array -> tbox = fun m ts -> + OldBindlib.box_apply (fun ts -> Meta(m,ts)) (OldBindlib.box_array ts) + +(** [_Meta_full m ts] is similar to [_Meta m ts] but works with a metavariable + that is boxed. This is useful in very rare cases, when metavariables need + to be able to contain free term environment variables. Using this function + in bad places is harmful for efficiency but not unsound. *) +let _Meta_full : meta OldBindlib.box -> tbox array -> tbox = fun m ts -> + OldBindlib.box_apply2 (fun m ts -> Meta(m,ts)) m (OldBindlib.box_array ts) + +(** [_Patt i n ts] lifts a pattern variable to the {!type:tbox} type. *) +let _Patt : int option -> string -> tbox array -> tbox = fun i n ts -> + OldBindlib.box_apply (fun ts -> Patt(i,n,ts)) (OldBindlib.box_array ts) + +(** [_TEnv te ts] lifts a term environment to the {!type:tbox} type. *) +let _TEnv : tebox -> tbox array -> tbox = fun te ts -> + OldBindlib.box_apply2 (fun te ts -> mk_TEnv(te,ts)) + te (OldBindlib.box_array ts) + +(** [_Wild] injects the constructor [Wild] into the {!type:tbox} type. *) +let _Wild : tbox = OldBindlib.box Wild + +let _Plac : bool -> tbox = fun b -> OldBindlib.box (mk_Plac b) + +(** [_TRef r] injects the constructor [TRef(r)] into the {!type:tbox} type. It + should be the case that [!r] is [None]. *) +let _TRef : term option ref -> tbox = fun r -> OldBindlib.box (TRef(r)) + +(** [_LLet t a u] lifts let binding [let x := t : a in u]. *) +let _LLet : tbox -> tbox -> tbinder OldBindlib.box -> tbox = + OldBindlib.box_apply3 (fun a t u -> mk_LLet(a, t, u)) + +(** [_TE_Vari x] injects a term environment variable [x] into the {!type:tbox} + type so that it may be available for binding. *) +let _TE_Vari : tevar -> tebox = OldBindlib.box_var + +(** [_TE_None] injects the constructor [TE_None] into the {!type:tbox} type.*) +let _TE_None : tebox = OldBindlib.box TE_None + +let lift : (tbox -> tbox -> tbox) -> term -> term OldBindlib.box = + fun mk_appl -> + let rec lift : term -> term OldBindlib.box = fun t -> match unfold t with - | Db _ -> assert false - | Vari x -> _Vari x - | Type -> _Type - | Kind -> _Kind - | Symb _ -> Bindlib.box t - | Prod(a,b) -> _Prod (lift a) (lift_binder b) - | Abst(a,t) -> _Abst (lift a) (lift_binder t) - | Appl(t,u) -> mk_appl (lift t) (lift u) - | Meta(r,m) -> _Meta r (Array.map lift m) - | Patt(i,n,m) -> _Patt i n (Array.map lift m) - | TEnv(te,m) -> _TEnv (lift_term_env te) (Array.map lift m) - | Wild -> _Wild - | Plac b -> _Plac b - | TRef r -> _TRef r + | Prod(a,b) -> _Prod (lift a) (lift_binder b) + | Abst(a,b) -> _Abst (lift a) (lift_binder b) + | Appl(a,b) -> mk_appl (lift a) (lift b) + | Meta(m,ts) -> _Meta m (Array.map lift ts) + | Patt(i,n,ts) -> _Patt i n (Array.map lift ts) + | TEnv(te,ts) -> _TEnv (lift_term_env te) (Array.map lift ts) | LLet(a,t,u) -> _LLet (lift a) (lift t) (lift_binder u) + | Wild + | Plac _ + | TRef _ + | Db _ + | Vari _ + | Type + | Kind + | Symb _ -> OldBindlib.box t (* We do not use [Bindlib.box_binder] here because it is possible for a free variable to disappear from a term through metavariable instantiation. As a consequence we must traverse the whole term, even when we find a closed binder, so that the metadata on nested binders is also updated. *) and lift_binder b = - let x, t = Bindlib.unbind b in Bindlib.bind_var x (lift t) + let x,t = Bindlib.unbind b in + OldBindlib.box (Bindlib.bind_var x (OldBindlib.unbox (lift t))) and lift_term_env : term_env -> tebox = function | TE_Vari x -> _TE_Vari x | TE_None -> _TE_None | TE_Some _ -> assert false (* Unreachable. *) in lift +end + +let old_lift = Old.lift Old._Appl + +(** [lift mk_appl t] lifts the {!type:term} [t] to the type {!type:tbox}, + using the function [mk_appl] in the case of an application. This has the + effect of gathering its free variables, making them available for binding. + Bound variable names are automatically updated in the process. *) +let lift : (tbox -> tbox -> tbox) -> term -> tbox = fun _ t -> t + (** [lift t] lifts the {!type:term} [t] to the type {!type:tbox}. This has the effect of gathering its free variables, making them available for binding. Bound variable names are automatically updated in the process. *) @@ -778,13 +1159,13 @@ type cp_pos = Pos.popt * term * term * subterm_pos * term LHS counterparts. This is a more convenient way of representing terms when analysing confluence or termination. *) let term_of_rhs : rule -> term = fun r -> - let fn i x = - let (name, arity) = (Bindlib.name_of x, r.arities.(i)) in + let f i tevar = + let (name, arity) = (OldBindlib.name_of tevar, r.arities.(i)) in let vars = Array.init arity (new_tvar_ind "x") in let p = _Patt (Some i) name (Array.map _Vari vars) in TE_Some(Bindlib.unbox (Bindlib.bind_mvar vars p)) in - Bindlib.msubst r.rhs (Array.mapi fn r.vars) + OldBindlib.msubst r.rhs (Array.mapi f r.vars) (** Type of a symbol and a rule. *) type sym_rule = sym * rule diff --git a/src/core/term.mli b/src/core/term.mli index 6d779fe40..36851595e 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -11,6 +11,8 @@ open Timed open Lplib open Base open Common +module OldBindlib = Bindlib + (** {3 Term (and symbol) representation} *) (** Representation of a possibly qualified identifier. *) @@ -40,6 +42,12 @@ type prop = | Assoc of bool (** Associative left if [true], right if [false]. *) | AC of bool (** Associative and commutative. *) +type tbinder + +type tmbinder + +type tvar + (** Representation of a term (or types) in a general sense. Values of the type are also used, for example, in the representation of patterns or rewriting rules. Specific constructors are included for such applications, and they @@ -77,7 +85,7 @@ type term = private rewriting rules (see {!field:Term.rhs}) with the number of variables that are not in the LHS. In decision trees, a RHS is stored in every leaf since they correspond to matched rules. *) -and rhs = (term_env, term) Bindlib.mbinder +and rhs = (term_env, term) OldBindlib.mbinder (** Representation of a decision tree (used for rewriting). *) and dtree = (rhs * int) Tree_type.dtree @@ -199,6 +207,8 @@ and sym = (** Actual "term with environment" (used to instantiate a RHS). *) | TE_None (** Dummy term environment (used during matching). *) + and tevar = term_env OldBindlib.var + (** The {!constructor:TEnv}[(te,env)] constructor intuitively corresponds to a term [te] with free variables together with an explicit environment [env]. Note that the binding of the environment actually occurs in [te], when the @@ -233,18 +243,120 @@ and sym = ; meta_arity : int (** Arity (environment size). *) ; meta_value : tmbinder option ref (** Definition. *) } -and tbinder = (term, term) Bindlib.binder +module Bindlib : sig + +(** [subst b v] substitutes the variable bound by [b] with the value [v]. *) +val subst : tbinder -> term -> term + +(** [msubst b vs] substitutes the variables bound by [b] with the values [vs]. + Note that the length of the [vs] array should match the arity of the + multiple binder [b]. *) +val msubst : tmbinder -> term array -> term +val msubst3 : + (tmbinder * tmbinder * tmbinder) -> term array -> term * term * term + +(** [new_var _ name] creates a new unique variable using [name]. *) +val new_var : (tvar -> term) -> string -> tvar + +(** [new_mvar names] creates a new array of new unique variables using + [names]. *) +val new_mvar : string array -> tvar array + +(** [name_of x] returns a printable name for variable [x]. *) +val name_of : tvar -> string + +(** [unbind b] substitutes the binder [b] using a fresh variable. The variable + and the result of the substitution are returned. Note that the name of the + fresh variable is based on that of the binder. The [mkfree] function used + to create the fresh variable is that of the variable that was bound by [b] + at its construction (see [new_var] and [bind_var]). *) +val unbind : tbinder -> tvar * term + +(** [unbind2 f g] is similar to [unbind f], but it substitutes two binders [f] + and [g] at once using the same fresh variable. The name of the variable is + based on that of the binder [f]. Similarly, the [mkfree] syntactic wrapper + that is used for the fresh variable is the one that was given for creating + the variable that was bound to construct [f] (see [bind_var] and [new_var] + for details on this process). In particular, the use of [unbind2] may lead + to unexpected results if the binders [f] and [g] were not built using free + variables created with the same [mkfree]. *) +val unbind2 : tbinder -> tbinder -> tvar * term * term + +(** [unmbind b] substitutes the multiple binder [b] with fresh variables. This + function is analogous to [unbind] for binders. Note that the names used to + create the fresh variables are based on those of the multiple binder. The + syntactic wrapper (of [mkfree]) that is used to build the variables is the + one that was given when creating the multiple variables that were bound in + [b] (see [new_mvar] and [bind_mvar]). *) +val unmbind : tmbinder -> tvar array * term + +(** Type of a term under construction. Using this representation, + the free variable of the term can be bound easily. *) +type 'a box = 'a + +(** [box e] injects the value [e] into the [term box] type, assuming that it + is closed. Thus, if [e] contains variables, then they will not be + considered free. This means that no variable of [e] will be available for + binding. *) +val box : 'a -> 'a box + +(** [box_apply f ba] applies the function [f] to a boxed argument [ba]. It is + equivalent to [apply_box (box f) ba], but is more efficient. *) +val box_apply : ('a -> 'b) -> 'a box -> 'b box + +(** [bind_var x b] binds the variable [x] in [b], producing a boxed binder. *) +val bind_var : tvar -> term box -> tbinder box + +(** [bind_mvar xs b] binds the variables of [xs] in [b] to get a boxed binder. + It is the equivalent of [bind_var] for multiple variables. *) +val bind_mvar : tvar array -> term box -> tmbinder box +val bind_mvar3 : tvar array -> (term box * term box * term box) + -> tmbinder box * tmbinder box * tmbinder box + +(** [unbox e] can be called when the construction of a term is finished (e.g., + when the desired variables have all been bound). *) +val unbox : 'a box -> 'a + +(** [box_pair ba bb] is the same as [box_apply2 (fun a b -> (a,b)) ba bb]. *) +val box_pair : 'a box -> 'b box -> ('a * 'b) box + +(** [box_triple] is similar to [box_pair], but for triples. *) +val box_triple : 'a box -> 'b box -> 'c box -> ('a * 'b * 'c) box + +(** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to + compare variables using [Pervasive.compare]. *) +val compare_vars : tvar -> tvar -> int + +(** [eq_vars x y] safely computes the equality of [x] and [y]. Note that it is + unsafe to compare variables with the polymorphic equality function. *) +val eq_vars : tvar -> tvar -> bool + +(** [binder_occur b] tests whether the bound variable occurs in [b]. *) +val binder_occur : tbinder -> bool + +(** [binder_constant b] tests whether the [binder] [b] is constant (i.e., its + bound variable does not occur). *) +val binder_constant : tbinder -> bool + +(** [mbinder_arity b] gives the arity of the [mbinder]. *) +val mbinder_arity : tmbinder -> int + +(** [is_closed b] checks whether the [box] [b] is closed. *) +val is_closed : term box -> bool +val is_closed_tmbinder : tmbinder box -> bool + +(** [occur x b] tells whether variable [x] occurs in the [box] [b]. *) +val occur : tvar -> term box -> bool +val occur_tmbinder : tvar -> tmbinder box -> bool -and tmbinder = (term, term) Bindlib.mbinder - -and tvar = term Bindlib.var - -and tevar = term_env Bindlib.var +end type tbox = term Bindlib.box type tebox = term_env Bindlib.box +val old_lift : term -> term OldBindlib.box + (** Minimize [impl] to enforce our invariant (see {!type:Term.sym}). *) val minimize_impl : bool list -> bool list diff --git a/src/core/unif.ml b/src/core/unif.ml index 2558536cc..41826d133 100644 --- a/src/core/unif.ml +++ b/src/core/unif.ml @@ -120,7 +120,7 @@ let instantiate : problem -> ctxt -> meta -> term array -> term -> bool = fun p c m ts u -> if Logger.log_enabled () then log_unif "try instantiate"; match instantiation c m ts u with - | Some b when Bindlib.is_closed b -> + | Some b when Bindlib.is_closed_tmbinder b -> let do_instantiate() = if Logger.log_enabled () then log_unif (red "%a ≔ %a") meta m term u; diff --git a/src/export/dk.ml b/src/export/dk.ml index 874ae131a..1f63aca9a 100644 --- a/src/export/dk.ml +++ b/src/export/dk.ml @@ -109,7 +109,7 @@ let cmp : decl cmp = cmp_map (Lplib.Option.cmp Pos.cmp) pos_of_decl (** Translation of terms. *) let tvar : tvar pp = fun ppf v -> ident ppf (Bindlib.name_of v) -let tevar : tevar pp = fun ppf v -> ident ppf (Bindlib.name_of v) +let tevar : tevar pp = fun ppf v -> ident ppf (OldBindlib.name_of v) let tenv : term_env pp = fun ppf te -> match te with @@ -196,7 +196,7 @@ let sym_decl : sym pp = fun ppf s -> ident s.sym_name (term true) d let rule_decl : (Path.t * string * rule) pp = fun ppf (p, n, r) -> - let xs, rhs = Bindlib.unmbind r.rhs in + let xs, rhs = OldBindlib.unmbind r.rhs in out ppf "[%a] %a%a --> %a.@." (Array.pp tevar ", ") xs qid (p, n) (List.pp (prefix " " (term false)) "") r.lhs (term true) rhs diff --git a/src/handle/rewrite.ml b/src/handle/rewrite.ml index ffd8f8c02..81128a93f 100644 --- a/src/handle/rewrite.ml +++ b/src/handle/rewrite.ml @@ -336,7 +336,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> let bound = let triple = Bindlib.box_triple (lift t) (lift_not_canonical l) (lift r) in - Bindlib.unbox (Bindlib.bind_mvar vars triple) + Bindlib.unbox (Bindlib.bind_mvar3 vars triple) in (* Extract the term from the goal type (get “u” from “P u”). *) @@ -360,7 +360,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> term g_term term l in (* Build the required data from that substitution. *) - let (t, l, r) = Bindlib.msubst bound sigma in + let (t, l, r) = Bindlib.msubst3 bound sigma in let pred_bind = bind_pattern l g_term in (pred_bind, Bindlib.subst pred_bind r, t, l, r) @@ -383,7 +383,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> term match_p term l in (* Build the data from the substitution. *) - let (t, l, r) = Bindlib.msubst bound sigma in + let (t, l, r) = Bindlib.msubst3 bound sigma in let pred_bind = bind_pattern l g_term in (pred_bind, Bindlib.subst pred_bind r, t, l, r) @@ -406,7 +406,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> term match_p term l in (* Build the data from the substitution. *) - let (t, l, r) = Bindlib.msubst bound sigma in + let (t, l, r) = Bindlib.msubst3 bound sigma in let p_x = bind_pattern l match_p in let p_r = Bindlib.subst p_x r in let pred_bind = bind_pattern match_p g_term in @@ -457,7 +457,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> (* Build t, l, using the substitution we found. Note that r *) (* corresponds to the value we get by applying rewrite to *) (* id val. *) - let (t,l,r) = Bindlib.msubst bound sigma in + let (t,l,r) = Bindlib.msubst3 bound sigma in (* The RHS of the pattern, i.e. the pattern with id replaced *) (* by the result of rewriting id_val. *) @@ -519,7 +519,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> fatal pos "The term [%a] does not match the LHS [%a]" term s term l in - let (t,l,r) = Bindlib.msubst bound sigma in + let (t,l,r) = Bindlib.msubst3 bound sigma in (* First we work in [id_val], that is, we substitute all the occurrences of [l] in [id_val] with [r]. *) @@ -586,7 +586,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> "The value of X, [%a], does not match the LHS, [%a]" term id_val term l in - let (t,l,r) = Bindlib.msubst bound sigma in + let (t,l,r) = Bindlib.msubst3 bound sigma in (* Now to do some term building. *) let p_x = bind_pattern l p in @@ -622,7 +622,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> "The value of [%a], [%a], in [%a] does not match [%a]." var id term id_val term q term l in - let (t,l,r) = Bindlib.msubst bound sigma in + let (t,l,r) = Bindlib.msubst3 bound sigma in (* Rewrite in id. *) let id_bind = bind_pattern l id_val in diff --git a/src/parsing/scope.ml b/src/parsing/scope.ml index 9c13c721b..64ba2c7a2 100644 --- a/src/parsing/scope.ml +++ b/src/parsing/scope.ml @@ -170,6 +170,12 @@ let _ = assert (valid "case_ex02_intro1"); assert (valid "case_ex02_intro10") +let pp_env : env Base.pp = + let open Base in + let def ppf t = out ppf " ≔ %a" term t in + let elt ppf (s, (_,a,t)) = out ppf "%s: %a%a" s term a (Option.pp def) t in + (D.list elt) + (** [scope ~typ md ss env t] turns a parser-level term [t] into an actual term. The variables of the environment [env] may appear in [t], and the scoping mode [md] changes the behaviour related to certain @@ -186,7 +192,8 @@ let rec scope : ?typ:bool -> int -> mode -> sig_state -> env -> p_term -> and scope_parsed : ?typ:bool -> int -> mode -> sig_state -> env -> p_term -> tbox = fun ?(typ=false) k md ss env t -> - if Logger.log_enabled () then log_scop "%a%a" D.depth k Pretty.term t; + if Logger.log_enabled () then + log_scop "%a%a@ %a" D.depth k pp_env env Pretty.term t; (* Extract the spine. *) let p_head, args = Syntax.p_get_args t in (* Check that LHS pattern variables are applied to no argument. *) @@ -556,10 +563,10 @@ type pre_rule = (** Head symbol of the LHS. *) ; pr_lhs : term list (** Arguments of the LHS. *) - ; pr_vars : term_env Bindlib.mvar + ; pr_vars : term_env OldBindlib.mvar (** Pattern variables that appear in the RHS. The last [pr_xvars_nb] variables do not appear in the LHS. *) - ; pr_rhs : tbox + ; pr_rhs : term OldBindlib.box (** Body of the RHS, should only be unboxed once. *) ; pr_names : (int, string) Hashtbl.t (** Gives the original name (if any) of pattern variable at given index. *) @@ -573,7 +580,7 @@ let rule_of_pre_rule : pre_rule loc -> rule = fun { elt = pr; pos = rule_pos } -> let {pr_lhs; pr_vars; pr_rhs; pr_arities; pr_xvars_nb; _} = pr in { lhs = pr_lhs - ; rhs = Bindlib.(unbox (bind_mvar pr_vars pr_rhs)) + ; rhs = OldBindlib.(unbox (bind_mvar pr_vars pr_rhs)) ; arity = List.length pr_lhs ; arities = pr_arities ; vars = pr_vars @@ -639,7 +646,7 @@ let scope_rule : bool -> sig_state -> p_rule -> pre_rule loc = M_RHS{ m_rhs_prv = is_private pr_sym; m_rhs_data = htbl_vars; m_rhs_new_metas = new_problem() } in - let pr_rhs = scope 0 mode ss Env.empty p_rhs in + let pr_rhs = old_lift (scope 0 mode ss Env.empty p_rhs) in let prerule = (* We put everything together to build the pre-rule. *) let pr_arities = diff --git a/src/parsing/scope.mli b/src/parsing/scope.mli index 91d2cb6c8..01b654d10 100644 --- a/src/parsing/scope.mli +++ b/src/parsing/scope.mli @@ -24,10 +24,10 @@ type pre_rule = (** Head symbol of the LHS. *) ; pr_lhs : term list (** Arguments of the LHS. *) - ; pr_vars : term_env Bindlib.mvar + ; pr_vars : term_env OldBindlib.mvar (** Pattern variables that appear in the RHS. The last [pr_xvars_nb] variables do not appear in the LHS. *) - ; pr_rhs : tbox + ; pr_rhs : term OldBindlib.box (** Body of the RHS, should only be unboxed once. *) ; pr_names : (int, string) Hashtbl.t (** Gives the original name (if any) of pattern variable at given index. *) diff --git a/src/parsing/syntax.ml b/src/parsing/syntax.ml index deb23ebda..ecde52602 100644 --- a/src/parsing/syntax.ml +++ b/src/parsing/syntax.ml @@ -108,7 +108,7 @@ module P = struct let iden : string -> p_term = qiden [] (** [var v] builds a [P_Iden] from [Bindlib.name_of v]. *) - let var : Term.tvar -> p_term = fun v -> iden (Bindlib.name_of v) + let var : Term.tvar -> p_term = fun v -> iden (Term.Bindlib.name_of v) (** [patt s ts] builds a [P_Patt] "$s[ts]". *) let patt : string -> p_term array option -> p_term = fun s ts -> diff --git a/src/pure/pure.ml b/src/pure/pure.ml index 779717acf..cec88b1a1 100644 --- a/src/pure/pure.ml +++ b/src/pure/pure.ml @@ -104,7 +104,7 @@ let string_of_goal : Proof.goal -> goal = res in let open Print in - let env_elt (s,(_,t,_)) = s, to_string term (Bindlib.unbox t) in + let env_elt (s,(_,t,_)) = s, to_string term (Term.Bindlib.unbox t) in let ctx_elt (x,a,_) = to_string var x, to_string term a in fun g -> match g with diff --git a/src/tool/lcr.ml b/src/tool/lcr.ml index 227a6f087..5d693fc3b 100644 --- a/src/tool/lcr.ml +++ b/src/tool/lcr.ml @@ -47,7 +47,7 @@ let is_definable : sym -> bool = fun s -> (** [rule_of_def s d] creates the rule [s --> d]. *) let rule_of_def : sym -> term -> rule = fun s d -> - let rhs = Bindlib.unbox (Bindlib.bind_mvar [||] (Bindlib.box d)) in + let rhs = OldBindlib.unbox (OldBindlib.bind_mvar [||] (OldBindlib.box d)) in {lhs=[]; rhs; arity=0; arities=[||]; vars=[||]; xvars_nb=0; rule_pos=s.sym_pos} @@ -456,7 +456,8 @@ let typability_constraints : Pos.popt -> term -> subs option = fun pos t -> match get_args_len l with | Symb s, lhs, arity -> let vars = [||] and rule_pos = Some (new_rule_id()) in - let rhs = Bindlib.unbox (Bindlib.bind_mvar vars (Bindlib.box r)) in + let rhs = OldBindlib.unbox + (OldBindlib.bind_mvar vars (OldBindlib.box r)) in let r = {lhs; rhs; arity; arities=[||]; vars; xvars_nb=0; rule_pos} in Some (s,r) | _ -> None diff --git a/src/tool/sr.ml b/src/tool/sr.ml index c08538812..f78bebbc4 100644 --- a/src/tool/sr.ml +++ b/src/tool/sr.ml @@ -137,20 +137,21 @@ let check_rule : Scope.pre_rule Pos.loc -> rule = fun ({pos; elt} as pr) -> (* Check that the variables of the RHS are in the LHS. *) if pr_xvars_nb <> 0 then (let xvars = Array.drop (Array.length vars - pr_xvars_nb) vars in - fatal pos "Unknown pattern variables: %a" (Array.pp var ",") xvars); + fatal pos "Unknown pattern variables: %a" (Array.pp tevar ",") xvars); let arity = List.length lhs in if Logger.log_enabled () then begin (* The unboxing here could be harmful since it leads to [pr_rhs] being unboxed twice. However things should be fine here since the result is only used for printing. *) - let rhs = Bindlib.(unbox (bind_mvar vars pr_rhs)) in + let rhs = OldBindlib.(unbox (bind_mvar vars pr_rhs)) in let naive_rule = {lhs; rhs; arity; arities; vars; xvars_nb = 0; rule_pos = pos} in log_subj (Color.red "%a") sym_rule (s, naive_rule); end; (* Replace [Patt] nodes of LHS with corresponding elements of [vars]. *) - let lhs_vars = _Appl_Symb s (List.map (patt_to_tenv vars) lhs) in + let lhs_vars = old_lift + (_Appl_Symb s (List.map (patt_to_tenv vars) lhs)) in let p = new_problem() in let metas = let f i _ = @@ -162,14 +163,14 @@ let check_rule : Scope.pre_rule Pos.loc -> rule = fun ({pos; elt} as pr) -> in (* Substitute them in the LHS and in the RHS. *) let lhs_with_metas, rhs_with_metas = - let lhs_rhs = Bindlib.box_pair lhs_vars pr_rhs in - let b = Bindlib.unbox (Bindlib.bind_mvar vars lhs_rhs) in + let lhs_rhs = OldBindlib.box_pair lhs_vars pr_rhs in + let b = OldBindlib.unbox (OldBindlib.bind_mvar vars lhs_rhs) in let meta_to_tenv m = let xs = Array.init m.meta_arity (new_tvar_ind "x") in let ts = Array.map _Vari xs in TE_Some(Bindlib.unbox (Bindlib.bind_mvar xs (_Meta m ts))) in - Bindlib.msubst b (Array.map meta_to_tenv metas) + OldBindlib.msubst b (Array.map meta_to_tenv metas) in if Logger.log_enabled () then log_subj "replace pattern variables by metavariables:@ %a ↪ %a" @@ -274,5 +275,5 @@ let check_rule : Scope.pre_rule Pos.loc -> rule = fun ({pos; elt} as pr) -> let rhs = symb_to_tenv pr symbols htbl rhs_with_metas in (* TODO environment minimisation ? *) (* Construct the rule. *) - let rhs = Bindlib.unbox (Bindlib.bind_mvar vars rhs) in + let rhs = OldBindlib.unbox (OldBindlib.bind_mvar vars (old_lift rhs)) in { lhs ; rhs ; arity ; arities ; vars; xvars_nb = 0; rule_pos = pos } diff --git a/src/tool/tree_graphviz.ml b/src/tool/tree_graphviz.ml index e5945e01c..be95430d0 100644 --- a/src/tool/tree_graphviz.ml +++ b/src/tool/tree_graphviz.ml @@ -52,7 +52,7 @@ let to_dot : Format.formatter -> sym -> unit = fun ppf s -> incr node_count; match t with | Leaf(_,(a,_)) -> - let _, acte = Bindlib.unmbind a in + let _, acte = OldBindlib.unmbind a in out ppf "@ %d [label=\"%a\"];" !node_count Print.term acte; out ppf "@ %d -- %d [label=<%a>];" father_l !node_count dotterm swon From 3434aac637dd812e5af75100fb53374e8868c1ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 8 Feb 2022 18:20:52 +0100 Subject: [PATCH 03/38] change definition of Term.dtree to rule Tree_type.dtree --- src/core/eval.ml | 10 +++++----- src/core/term.ml | 7 ++----- src/core/term.mli | 7 ++----- src/core/tree.ml | 17 ++++++++--------- src/core/tree_type.ml | 28 +++++++++++++--------------- src/tool/tree_graphviz.ml | 6 +++--- 6 files changed, 33 insertions(+), 42 deletions(-) diff --git a/src/core/eval.ml b/src/core/eval.ml index 75078a5bb..0a6b95ff9 100644 --- a/src/core/eval.ml +++ b/src/core/eval.ml @@ -298,11 +298,11 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = let open Tree_type in match tree with | Fail -> None - | Leaf(rhs_subst, (act, xvars)) -> (* Apply the RHS substitution *) + | Leaf(rhs_subst, r) -> (* Apply the RHS substitution *) (* Allocate an environment where to place terms coming from the pattern variables for the action. *) - let env_len = OldBindlib.mbinder_arity act in - assert (List.length rhs_subst = env_len - xvars); + let env_len = Array.length r.vars in + assert (List.length rhs_subst = env_len - r.xvars_nb); let env = Array.make env_len TE_None in (* Retrieve terms needed in the action from the [vars] array. *) let f (pos, (slot, xs)) = @@ -315,12 +315,12 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = in List.iter f rhs_subst; (* Complete the array with fresh meta-variables if needed. *) - for i = env_len - xvars to env_len - 1 do + for i = env_len - r.xvars_nb to env_len - 1 do let mt = LibMeta.make cfg.problem cfg.context mk_Type in let t = LibMeta.make cfg.problem cfg.context mt in env.(i) <- TE_Some(binds [||] lift t) done; - Some (OldBindlib.msubst act env, stk) + Some (OldBindlib.msubst r.rhs env, stk) | Cond({ok; cond; fail}) -> let next = match cond with diff --git a/src/core/term.ml b/src/core/term.ml index 31f875cf2..0a4bfbda2 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -76,14 +76,11 @@ type term = the {!constructor:Patt} constructor to represend wildcards of the concrete syntax. They are thus considered to be fresh, unused pattern variables. *) -(** Representation of a rewriting rule RHS (or action) as given in the type of - rewriting rules (see {!field:Term.rhs}) with the number of variables that - are not in the LHS. In decision trees, a RHS is stored in every leaf since - they correspond to matched rules. *) +(** Representation of a rewriting rule RHS. *) and rhs = (term_env, term) OldBindlib.mbinder (** Representation of a decision tree (used for rewriting). *) -and dtree = (rhs * int) Tree_type.dtree +and dtree = rule Tree_type.dtree (** Representation of a user-defined symbol. Symbols carry a "mode" indicating whether they may be given rewriting rules or a definition. Invariants must diff --git a/src/core/term.mli b/src/core/term.mli index 36851595e..debd6ba3c 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -81,14 +81,11 @@ type term = private the {!constructor:Patt} constructor to represend wildcards of the concrete syntax. They are thus considered to be fresh, unused pattern variables. *) -(** Representation of a rewriting rule RHS (or action) as given in the type of - rewriting rules (see {!field:Term.rhs}) with the number of variables that - are not in the LHS. In decision trees, a RHS is stored in every leaf since - they correspond to matched rules. *) +(** Representation of a rewriting rule RHS. *) and rhs = (term_env, term) OldBindlib.mbinder (** Representation of a decision tree (used for rewriting). *) -and dtree = (rhs * int) Tree_type.dtree +and dtree = rule Tree_type.dtree (** Representation of a user-defined symbol. Symbols carry a "mode" indicating whether they may be given rewriting rules or a definition. Invariants must diff --git a/src/core/tree.ml b/src/core/tree.ml index cfa86ebdf..a2a81a8f4 100644 --- a/src/core/tree.ml +++ b/src/core/tree.ml @@ -39,7 +39,7 @@ let log = log.pp portion [S─∘─Z] is made possible by a swap. *) (** Representation of a tree (see {!type:Tree_type.tree}). *) -type tree = (rhs * int) Tree_type.tree +type tree = rule Tree_type.tree (** {1 Conditions for decision trees} @@ -222,8 +222,8 @@ module CM = struct type clause = { c_lhs : term array (** Left hand side of a rule. *) - ; c_rhs : rhs * int - (** Right hand side of a rule. *) + ; c_rhs : rule + (** Right hand side of a rule, and number of extra variables. *) ; c_subst : rhs_substit (** Substitution of RHS variables. *) ; xvars_nb : int @@ -281,10 +281,9 @@ module CM = struct (** [of_rules rs] transforms rewriting rules [rs] into a clause matrix. *) let of_rules : rule list -> t = fun rs -> - let r2r {lhs; rhs; xvars_nb; _} = + let r2r ({lhs; xvars_nb; _} as c_rhs) = let c_lhs = Array.of_list lhs in - { c_lhs; c_rhs = (rhs, xvars_nb); cond_pool = CP.empty; c_subst = [] - ; xvars_nb } + { c_lhs; c_rhs; cond_pool = CP.empty; c_subst = []; xvars_nb } in let size = (* Get length of longest rule *) if rs = [] then 0 else @@ -640,15 +639,15 @@ end [vi] contains variables that may appear free in patterns. [slot] is the number of subterms that must be memorised. *) let harvest : - term array -> rhs * int -> rhs_substit -> int VarMap.t -> int -> tree = - fun lhs rhs subst vi slot -> + term array -> rule -> rhs_substit -> int VarMap.t -> int -> tree = + fun lhs r subst vi slot -> let default_node store child = Node { swap = 0 ; store ; children = TCMap.empty ; abstraction = None ; product = None ; default = Some(child) } in let rec loop lhs subst slot = match lhs with - | [] -> Leaf(subst, rhs) + | [] -> Leaf(subst, r) | Patt(Some(i),_,e)::ts -> let subst = (slot, (i, Array.map (CM.index_var vi) e)) :: subst diff --git a/src/core/tree_type.ml b/src/core/tree_type.ml index 6cb5981f3..415aab1d4 100644 --- a/src/core/tree_type.ml +++ b/src/core/tree_type.ml @@ -75,28 +75,26 @@ type rhs_substit = (int * (int * int array)) list (** Representation of a tree. The definition relies on parameters since module {!module:Term} depends on the current module, and that would thus produce - a dependency cycle. However it should be understood that parameter [`rhs] - will only be instantiated with - [(Term.term_env, Term.term) Bindlib.mbinder] (i.e., the representation - of a RHS). *) -type 'rhs tree = + a dependency cycle. However it should be understood that parameter ['a] + will only be instantiated with [Term.rule]. *) +type 'a tree = | Fail (** Empty decision tree, used when there are no rewriting rules. *) - | Leaf of rhs_substit * 'rhs + | Leaf of rhs_substit * 'a (** The value [Leaf(m, rhs)] stores the RHS [rhs] of the rewriting rule that can be applied upon reaching the leaf. The association list [m] is used to construct the environment of the RHS. Note that we do not need to use a map here since we only need to insert at the head, and iterate over the elements of the structure. *) | Cond of - { ok : 'rhs tree + { ok : 'a tree (** Branch to follow if the condition is verified. *) ; cond : tree_cond (** The condition to test. *) - ; fail : 'rhs tree + ; fail : 'a tree (** Branch to follow if the condition is not verified. *) } (** Conditional branching according to a condition. *) - | Eos of 'rhs tree * 'rhs tree + | Eos of 'a tree * 'a tree (** End of stack node, branches on left tree if the stack is finished, on the right if it isn't. Required when there are rules with a lower arity than some other rule above and when {!field:Term.sym.sym_mstrat} is @@ -108,13 +106,13 @@ type 'rhs tree = ; store : bool (** Whether to store the current term. Stored terms might be used in the right hand side, are for constraint checks. *) - ; children : 'rhs tree TCMap.t + ; children : 'a tree TCMap.t (** Subtrees representing the matching of available constructors. *) - ; abstraction : (int * 'rhs tree) option + ; abstraction : (int * 'a tree) option (** Specialisation by an abstraction with the involved free variable. *) - ; product : (int * 'rhs tree) option + ; product : (int * 'a tree) option (** Specialisation by product with the involved free variable. *) - ; default : 'rhs tree option + ; default : 'a tree option (** When the available patterns contain a wildcard, this subtree is used as a last resort (if none of the [children] match). *) } (** Arbitrarily branching node allowing to perform switches (a switch is the @@ -152,7 +150,7 @@ let rec tree_capacity : 'r tree -> int = fun tr -> the capacity, see {!val:Tree_type.tree_capacity}. Laziness allows to (sometimes) avoid creating several times the same trees when the rules are not given in one go. *) -type 'rhs dtree = int Lazy.t * 'rhs tree Lazy.t +type 'a dtree = int Lazy.t * 'a tree Lazy.t (** [empty_dtree] is the empty decision tree. *) -let empty_dtree : 'rhs dtree = (lazy 0, lazy Fail) +let empty_dtree : 'a dtree = (lazy 0, lazy Fail) diff --git a/src/tool/tree_graphviz.ml b/src/tool/tree_graphviz.ml index be95430d0..cf85cc700 100644 --- a/src/tool/tree_graphviz.ml +++ b/src/tool/tree_graphviz.ml @@ -51,9 +51,9 @@ let to_dot : Format.formatter -> sym -> unit = fun ppf s -> let rec write_tree father_l swon t = incr node_count; match t with - | Leaf(_,(a,_)) -> - let _, acte = OldBindlib.unmbind a in - out ppf "@ %d [label=\"%a\"];" !node_count Print.term acte; + | Leaf(_,r) -> + let _, rhs = OldBindlib.unmbind r.rhs in + out ppf "@ %d [label=\"%a\"];" !node_count Print.term rhs; out ppf "@ %d -- %d [label=<%a>];" father_l !node_count dotterm swon | Node({swap; children; store; abstraction=abs; default; product}) -> From 49ec8abb93f6b1d6a2da2340b47ebe50421fd3b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 09:58:36 +0100 Subject: [PATCH 04/38] remove Bindlib on rhs --- src/common/debug.ml | 4 + src/common/logger.ml | 8 + src/common/logger.mli | 3 + src/core/env.ml | 16 +- src/core/eval.ml | 25 +- src/core/infer.ml | 21 +- src/core/inverse.ml | 8 +- src/core/print.ml | 16 +- src/core/sign.ml | 11 +- src/core/term.ml | 388 +++++++++++------------------- src/core/term.mli | 11 +- src/core/unif.ml | 80 +++--- src/export/dk.ml | 19 +- src/export/hrs.ml | 12 +- src/export/xtc.ml | 19 +- src/handle/command.ml | 44 ++-- src/handle/inductive.ml | 33 ++- src/handle/tactic.ml | 43 +++- src/handle/why3_tactic.ml | 26 +- src/lplib/extra.ml | 2 +- src/parsing/scope.ml | 171 +++++-------- src/parsing/scope.mli | 24 +- src/tool/lcr.ml | 13 +- src/tool/sr.ml | 207 ++++++---------- src/tool/sr.mli | 5 +- src/tool/tree_graphviz.ml | 3 +- tests/OK/rewrite1.lp | 3 +- tests/regressions/dtrees.expected | 8 +- tests/rewriting.ml | 14 +- 29 files changed, 522 insertions(+), 715 deletions(-) diff --git a/src/common/debug.ml b/src/common/debug.ml index 313fcea56..638162a4a 100644 --- a/src/common/debug.ml +++ b/src/common/debug.ml @@ -46,6 +46,10 @@ module D = struct out ppf "]" end + let hashtbl : 'a pp -> 'b pp -> ('a, 'b) Hashtbl.t pp = fun key elt -> + let tbl ppf = Hashtbl.iter (fun k v -> out ppf "%a,%a; " key k elt v) in + fun ppf -> out ppf "[%a]" tbl + let map : (('key -> 'elt -> unit) -> 'map -> unit) -> 'key pp -> string -> 'elt pp -> string -> 'map pp = fun iter key sep1 elt sep2 ppf m -> diff --git a/src/common/logger.ml b/src/common/logger.ml index b9708e753..548cf79a3 100644 --- a/src/common/logger.ml +++ b/src/common/logger.ml @@ -102,3 +102,11 @@ let reset_loggers ?(default=Stdlib.(! default_loggers)) () = (** [log_summary ()] gives the keys and descriptions for logging options. *) let log_summary () = List.map (fun d -> (d.logger_key, d.logger_desc)) Stdlib.(!loggers) + +(** [set_debug_in b c f x] sets [c] logger to [b] for evaluating [f x]. *) +let set_debug_in : bool -> char -> ('a -> 'b) -> 'a -> 'b = fun b c f x -> + let is_activated = String.contains (get_activated_loggers()) in + let v = is_activated c in + let s = String.make 1 c in + set_debug b s; + try let r = f x in set_debug v s; r with e -> set_debug v s; raise e diff --git a/src/common/logger.mli b/src/common/logger.mli index ea98251ec..38367eb97 100644 --- a/src/common/logger.mli +++ b/src/common/logger.mli @@ -31,3 +31,6 @@ val reset_loggers : ?default:string -> unit -> unit (** [log_summary ()] gives the keys and descriptions for logging options. *) val log_summary : unit -> (char * string) list + +(** [set_debug_in b c f x] sets [c] logger to [b] for evaluating [f x]. *) +val set_debug_in : bool -> char -> ('a -> 'b) -> 'a -> 'b diff --git a/src/core/env.ml b/src/core/env.ml index 314360d36..afc5b812f 100644 --- a/src/core/env.ml +++ b/src/core/env.ml @@ -16,9 +16,9 @@ type t = env let empty : env = [] (** [add v a t env] extends the environment [env] by mapping the string - [Bindlib.name_of v] to [(v,a,t)]. *) -let add : tvar -> tbox -> tbox option -> env -> env = fun v a t env -> - (Bindlib.name_of v, (v, a, t)) :: env + [n] to [(v,a,t)]. *) +let add : string -> tvar -> tbox -> tbox option -> env -> env = + fun n v a t env -> (n, (v, a, t)) :: env (** [find n env] returns the Bindlib variable associated to the variable name [n] in the environment [env]. If none is found, [Not_found] is raised. *) @@ -106,7 +106,7 @@ let of_prod : ctxt -> string -> term -> env * term = fun c s t -> try match_prod c t (fun a b -> let name = Stdlib.(incr i; s ^ string_of_int !i) in let x, b = LibTerm.unbind_name name b in - build_env (add x (lift a) None env) b) + build_env (add name x (lift a) None env) b) with Invalid_argument _ -> env, t in build_env [] t @@ -123,7 +123,7 @@ let of_prod_nth : ctxt -> int -> term -> env * term = fun c n t -> if i >= n then env, t else match_prod c t (fun a b -> let x, b = Bindlib.unbind b in - build_env (i+1) (add x (lift a) None env) b) + build_env (i+1) (add (Bindlib.name_of x) x (lift a) None env) b) in build_env 0 [] t (** [of_prod_using c xs t] is similar to [of_prod s c n t] where [n = @@ -136,6 +136,8 @@ let of_prod_using : ctxt -> tvar array -> term -> env * term = fun c xs t -> let rec build_env i env t = if i >= n then env, t else match_prod c t (fun a b -> - let env = add xs.(i) (lift a) None env in - build_env (i+1) env (Bindlib.subst b (mk_Vari(xs.(i))))) + let xi = xs.(i) in + let name = Bindlib.name_of xi in + let env = add name xi (lift a) None env in + build_env (i+1) env (Bindlib.subst b (mk_Vari xi))) in build_env 0 [] t diff --git a/src/core/eval.ml b/src/core/eval.ml index 0a6b95ff9..1e2f90e49 100644 --- a/src/core/eval.ml +++ b/src/core/eval.ml @@ -287,7 +287,7 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = fun cfg tree stk -> let (lazy capacity, lazy tree) = tree in let vars = Array.make capacity mk_Kind in (* dummy terms *) - let bound = Array.make capacity TE_None in + let bound = Array.make capacity None in (* [walk tree stk cursor vars_id id_vars] where [stk] is the stack of terms to match and [cursor] the cursor indicating where to write in the [vars] array described in {!module:Term} as the environment of the RHS during @@ -301,26 +301,25 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = | Leaf(rhs_subst, r) -> (* Apply the RHS substitution *) (* Allocate an environment where to place terms coming from the pattern variables for the action. *) - let env_len = Array.length r.vars in - assert (List.length rhs_subst = env_len - r.xvars_nb); - let env = Array.make env_len TE_None in + assert (List.length rhs_subst = r.vars_nb); + let env_len = r.vars_nb + r.xvars_nb in + let env = Array.make env_len None in (* Retrieve terms needed in the action from the [vars] array. *) let f (pos, (slot, xs)) = match bound.(pos) with - | TE_Vari(_) -> assert false - | TE_Some(_) -> env.(slot) <- bound.(pos) - | TE_None -> + | Some(_) -> env.(slot) <- bound.(pos) + | None -> let xs = Array.map (fun e -> IntMap.find e id_vars) xs in - env.(slot) <- TE_Some(binds xs lift vars.(pos)) + env.(slot) <- Some(binds xs lift vars.(pos)) in List.iter f rhs_subst; (* Complete the array with fresh meta-variables if needed. *) - for i = env_len - r.xvars_nb to env_len - 1 do + for i = r.vars_nb to env_len - 1 do let mt = LibMeta.make cfg.problem cfg.context mk_Type in let t = LibMeta.make cfg.problem cfg.context mt in - env.(i) <- TE_Some(binds [||] lift t) + env.(i) <- Some(binds [||] lift t) done; - Some (OldBindlib.msubst r.rhs env, stk) + Some (subst_patt env r.rhs, stk) | Cond({ok; cond; fail}) -> let next = match cond with @@ -346,12 +345,12 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = (* We first attempt to match [vars.(i)] directly. *) let b = Bindlib.bind_mvar allowed (lift vars.(i)) in if no_forbidden b - then (bound.(i) <- TE_Some(Bindlib.unbox b); ok) else + then (bound.(i) <- Some(Bindlib.unbox b); ok) else (* As a last resort we try matching the SNF. *) let b = Bindlib.bind_mvar allowed (lift (snf (whnf cfg) vars.(i))) in if no_forbidden b - then (bound.(i) <- TE_Some(Bindlib.unbox b); ok) + then (bound.(i) <- Some(Bindlib.unbox b); ok) else fail in walk next stk cursor vars_id id_vars diff --git a/src/core/infer.ml b/src/core/infer.ml index 06f15b5c3..f399c4066 100644 --- a/src/core/infer.ml +++ b/src/core/infer.ml @@ -216,7 +216,6 @@ and infer_aux : problem -> octxt -> term -> term * term * bool = let u, cu_u = force pb c u domain in return (cu_t' || cu_u) t u range ) - and infer : problem -> octxt -> term -> term * term * bool = fun pb c t -> if Logger.log_enabled () then log "Infer [%a]" term t; let t, t_ty, cu = infer_aux pb c t in @@ -231,32 +230,28 @@ and infer : problem -> octxt -> term -> term * term * bool = fun pb c t -> Otherwise, the term [λ a: _, λ b: _, b] will be transformed to [λ _: ?1, λ b: ?2, b] whereas it should be [λ a: ?1.[], λ b: ?2.[a], b] *) -(** [noexn f cs c args] initialises {!val:constraints} to [cs], - calls [f c args] and returns [Some(r,cs)] where [r] is the value of - the call to [f] and [cs] is the list of constraints gathered by - [f]. Function [f] may raise [NotTypable], in which case [None] is - returned. *) +(** [noexn f p c arg] returns [Some r] if [f p c arg] returns [r], and [None] + if [f p c arg] raises [NotTypable]. *) let noexn : (problem -> octxt -> 'a -> 'b) -> problem -> ctxt -> 'a -> 'b option = - fun f pb c args -> - try - Some (f pb (c, Ctxt.box_context c) args) + fun f p c arg -> + try Some (f p (c, Ctxt.box_context c) arg) with NotTypable -> None let infer_noexn pb c t : (term * term) option = if Logger.log_enabled () then - log "Top infer %a%a" ctxt c term t; + log (Color.blu "Top infer %a%a") ctxt c term t; let infer pb c t = let (t,t_ty,_) = infer pb c t in (t, t_ty) in noexn infer pb c t let check_noexn pb c t a : term option = - if Logger.log_enabled () then log "Top check \"%a\"" typing - (c, t, a); + if Logger.log_enabled () then + log (Color.blu "Top check %a") typing (c, t, a); let force pb c (t, a) = fst (force pb c t a) in noexn force pb c (t, a) let check_sort_noexn pb c t : (term * term) option = if Logger.log_enabled () then - log "Top check sort %a%a" ctxt c term t; + log (Color.blu "Top check sort %a%a") ctxt c term t; let type_enforce pb c t = let (t, s, _) = type_enforce pb c t in (t, s) in noexn type_enforce pb c t diff --git a/src/core/inverse.ml b/src/core/inverse.ml index 11672d804..580420aa4 100644 --- a/src/core/inverse.ml +++ b/src/core/inverse.ml @@ -35,10 +35,8 @@ let const_graph : sym -> (sym * sym) list = fun s -> begin match get_args l1 with | Symb s0, _ -> - let n = OldBindlib.mbinder_arity rule.rhs in - let r = OldBindlib.msubst rule.rhs (Array.make n TE_None) in begin - match get_args r with + match get_args rule.rhs with | Symb s1, _ -> add s0 s1 l | _ -> l end @@ -76,10 +74,8 @@ let prod_graph : sym -> (sym * sym * sym * bool) list = fun s -> begin match get_args l1 with | Symb s0, [_;_] -> - let n = OldBindlib.mbinder_arity rule.rhs in - let r = OldBindlib.msubst rule.rhs (Array.make n TE_None) in begin - match r with + match rule.rhs with | Prod(a,b) -> begin match get_args a with diff --git a/src/core/print.ml b/src/core/print.ml index 696a0d64c..ee4a54a6a 100644 --- a/src/core/print.ml +++ b/src/core/print.ml @@ -138,6 +138,7 @@ and term : term pp = fun ppf t -> and appl ppf t = pp `Appl ppf t and func ppf t = pp `Func ppf t and pp p ppf t = + if Logger.log_enabled() then log_prnt "%a" Raw.term t; let (h, args) = get_args t in let pp_appl h args = match args with @@ -259,7 +260,7 @@ and term : term pp = fun ppf t -> func ppf (cleanup t) (*let term ppf t = out ppf "<%a printed %a>" Term.term t term t*) -(*let term = Term.term*) +(*let term = Raw.term*) let rec prod : (term * bool list) pp = fun ppf (t, impl) -> match unfold t, impl with @@ -295,16 +296,17 @@ let typing : constr pp = fun ppf (ctx, t, u) -> out ppf "@[%a%a : %a@]" ctxt ctx term t term u let constr : constr pp = fun ppf (ctx, t, u) -> - out ppf "@[%a%a ≡ %a@]" ctxt ctx term t term u + out ppf "@[%a%a@ ≡ %a@]" ctxt ctx term t term u -let constrs : constr list pp = List.pp constr "; " +let constrs : constr list pp = fun ppf cs -> + let pp_sep ppf () = out ppf "@ ;" in + out ppf "@[[%a]@]" (Format.pp_print_list ~pp_sep constr) cs (* for debug only *) let metaset : MetaSet.t pp = - D.iter ~sep:(fun fmt () -> out fmt ",@ ") MetaSet.iter meta + D.iter ~sep:(fun ppf () -> out ppf ",") MetaSet.iter meta let problem : problem pp = fun ppf p -> out ppf - "{ recompute=%b;@ metas={%a};@ to_solve=[%a];@ unsolved=[%a] }" - !p.recompute metaset !p.metas constrs !p.to_solve constrs - !p.unsolved + "{ recompute=%b;@ metas={%a};@ to_solve=%a;@ unsolved=%a }" + !p.recompute metaset !p.metas constrs !p.to_solve constrs !p.unsolved diff --git a/src/core/sign.ml b/src/core/sign.ml index d82e8d358..f006aad53 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -114,9 +114,7 @@ let link : t -> unit = fun sign -> and link_term = link_term mk_Appl in let link_rule r = let lhs = List.map link_lhs r.lhs in - let (xs, rhs) = OldBindlib.unmbind r.rhs in - let rhs = old_lift (link_term rhs) in - let rhs = OldBindlib.unbox (OldBindlib.bind_mvar xs rhs) in + let rhs = link_term r.rhs in {r with lhs ; rhs} in let f _ s = @@ -185,8 +183,7 @@ let unlink : t -> unit = fun sign -> and unlink_binder b = unlink_term (snd (Bindlib.unbind b)) in let unlink_rule r = List.iter unlink_term r.lhs; - let (_, rhs) = OldBindlib.unmbind r.rhs in - unlink_term rhs + unlink_term r.rhs in let f _ s = unlink_term !(s.sym_type); @@ -292,7 +289,7 @@ let read : string -> t = fun fname -> and reset_binder b = reset_term (snd (Bindlib.unbind b)) in let reset_rule r = List.iter reset_term r.lhs; - reset_term (snd (OldBindlib.unmbind r.rhs)) + reset_term r.rhs in let reset_sym s = shallow_reset_sym s; @@ -323,7 +320,7 @@ let read = rule does not correspond to a symbol of signature [sign], it is stored in its dependencies. /!\ does not update the decision tree or the critical pairs. *) -let add_rule : t -> sym -> rule -> unit = fun sign sym r -> +let add_rule : t -> sym_rule -> unit = fun sign (sym,r) -> sym.sym_rules := !(sym.sym_rules) @ [r]; if sym.sym_path <> sign.sign_path then let sm = Path.Map.find sym.sym_path !(sign.sign_deps) in diff --git a/src/core/term.ml b/src/core/term.ml index 0a4bfbda2..2e2b75f0a 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -77,7 +77,7 @@ type term = syntax. They are thus considered to be fresh, unused pattern variables. *) (** Representation of a rewriting rule RHS. *) -and rhs = (term_env, term) OldBindlib.mbinder +and rhs = term (** Representation of a decision tree (used for rewriting). *) and dtree = rule Tree_type.dtree @@ -134,36 +134,23 @@ and sym = ; arity : int (** Required number of arguments to be applicable. *) ; arities : int array (** Arities of the pattern variables bound in the RHS. *) - ; vars : tevar array - (** Bindlib variables used to build [rhs]. The last [xvars_nb] variables - appear only in [rhs]. *) + ; vars_nb : int (** Number of variables in [lhs]. *) ; xvars_nb : int (** Number of variables in [rhs] but not in [lhs]. *) ; rule_pos : Pos.popt (** Position of the rule in the source file. *) } -(** {b NOTE} The second parameter of {!constructor:Patt} holds an array of - terms. This is essential for variables binding: using an array of variables - would NOT suffice. *) - (** {b NOTE} {!field:arity} gives the number of arguments contained in the - LHS. As a consequence, it is always equal to [List.length r.lhs] and it - gives the minimal number of arguments required to match the LHS. *) + LHS. It is always equal to [List.length r.lhs] and gives the minimal number + of arguments required to match the LHS. *) (** {b NOTE} For generated rules, {!field:rule_pos} may not be valid positions in the source. These virtual positions are however important for exporting lambdapi files to other formats. *) -(** The RHS (or action) or a rewriting rule is represented by a term, in which - (higher-order) variables representing "terms with environments" (see the - {!type:term_env} type) are bound. To effectively apply the rewriting rule, - these bound variables must be substituted using "terms with environments" - that are constructed when matching the LHS of the rule. *) - (** All variables of rewriting rules that appear in the RHS must appear in the - LHS. This constraint is checked in {!module:Sr}.In the case of unification - rules, we allow variables to appear only in the RHS. In that case, these - variables are replaced by fresh meta-variables each time the rule is used. - The last {!field:terms.rule.xvars} variables of {!field:terms.rule.vars} - are such RHS-only variables. *) + LHS. This constraint is checked in {!module:Sr}. In the case of unification + rules, we allow variables to appear only in the RHS. In that case, these + variables are replaced by fresh meta-variables each time the rule is + used. *) (** Representation of a "term with environment", which intuitively corresponds to a term with bound variables (or a "higher-order" term) represented with @@ -220,10 +207,34 @@ and tvar = int * string and tevar = term_env OldBindlib.var -(** Printing functions for debug. *) -module Raw = struct -let rec term : term pp = fun ppf t -> +module Bindlib = struct + +(** [unfold t] repeatedly unfolds the definition of the surface constructor + of [t], until a significant {!type:term} constructor is found. The term + that is returned cannot be an instantiated metavariable or term + environment nor a reference cell ({!constructor:TRef} constructor). Note + that the returned value is physically equal to [t] if no unfolding was + performed. {b NOTE} that {!val:unfold} must (almost) always be called + before matching over a value of type {!type:term}. *) +let rec unfold : term -> term = fun t -> match t with + | Meta(m, ts) -> + begin + match !(m.meta_value) with + | None -> t + | Some(b) -> unfold (msubst b ts) + end + | TRef(r) -> + begin + match !r with + | None -> t + | Some(v) -> unfold v + end + | _ -> t + +(** Printing functions for debug. *) +and term : term pp = fun ppf t -> + match unfold t with | Db k -> out ppf "`%d" k | Vari v -> var ppf v | Type -> out ppf "TYPE" @@ -235,44 +246,33 @@ let rec term : term pp = fun ppf t -> | Meta(m,ts) -> out ppf "?%d%a" m.meta_key terms ts | Patt(i,s,ts) -> out ppf "$%a_%s%a" (D.option D.int) i s terms ts | Plac(_) -> out ppf "_" - | TEnv(te,ts) -> out ppf "<%a>%a" tenv te terms ts + | TEnv _ -> assert false | Wild -> out ppf "_" | TRef r -> out ppf "&%a" (Option.pp term) !r | LLet(a,t,(n,b)) -> out ppf "let %s : %a ≔ %a in %a" n term a term t term b -and var : tvar pp = fun ppf (i,n) -> out ppf "#%d_%s" i n +and var : tvar pp = fun ppf (i,n) -> out ppf "%s%d" n i and sym : sym pp = fun ppf s -> string ppf s.sym_name and terms : term array pp = fun ppf ts -> if Array.length ts > 0 then D.array term ppf ts -and tenv : term_env pp = fun ppf te -> - match te with - | TE_Vari v -> out ppf "%s" (OldBindlib.name_of v) - | TE_Some (ns,b) -> out ppf "%a, %a" (Array.pp string " ") ns term b - | TE_None -> () -end -module Bindlib = struct - -(** [unfold t] repeatedly unfolds the definition of the surface constructor of - [t], until a significant {!type:term} constructor is found. The term that - is returned cannot be an instantiated metavariable or term environment nor - a reference cell ({!constructor:TRef} constructor). Note that the returned - value is physically equal to [t] if no unfolding was performed. *) -let rec unfold : term -> term = fun t -> - match t with - | Meta(m, ts) -> - begin - match !(m.meta_value) with - | None -> t - | Some(b) -> unfold (msubst b ts) - end - | TRef(r) -> - begin - match !r with - | None -> t - | Some(v) -> unfold v - end - | _ -> t +(** [lift l t] updates indices when [t] is moved under [l] binders. *) +and lift : int -> term -> term = fun l t -> + let rec lift i t = + match unfold t with + | Db k -> if k < i then t else Db (k+l) + | Appl(a,b) -> (*FIXME: mk_Appl*) Appl(lift i a, lift i b) + | Abst(a,(n,u)) -> Abst(lift i a, (n, lift (i+1) u)) + | Prod(a,(n,u)) -> Prod(lift i a, (n ,lift (i+1) u)) + | LLet(a,t,(n,u)) -> LLet(lift i a, lift i t, (n, lift (i+1) u)) + | Meta(m,ts) -> Meta(m, Array.map (lift i) ts) + | Patt(j,n,ts) -> Patt(j,n, Array.map (lift i) ts) + | TEnv(te,ts) -> TEnv(te, Array.map (lift i) ts) + | _ -> t + in + let r = lift 1 t in + if Logger.log_enabled() then log_term "lift %d %a = %a" l term t term r; + r (** [msubst b vs] substitutes the variables bound by [b] with the values [vs]. Note that the length of the [vs] array should match the arity of the @@ -280,19 +280,27 @@ let rec unfold : term -> term = fun t -> and msubst : tmbinder -> term array -> term = fun (ns,t) vs -> let n = Array.length ns in assert (Array.length vs = n); - if n = 0 then t else + (* [msubst i t] replaces [Db(i+j)] by [lift (i-1) vs.(n-j-1)] + for all [0 <= j < n]. *) let rec msubst i t = - match unfold t with - | Db k -> if k < i + n then vs.(k-i) else t - | Appl(a,b) -> (*FIXME: mk_Appl*) Appl(msubst i a, msubst i b) - | Abst(a,(n,u)) -> Abst(msubst i a, (n, msubst (i+1) u)) - | Prod(a,(n,u)) -> Prod(msubst i a, (n, msubst (i+1) u)) - | LLet(a,t,(n,u)) -> LLet(msubst i a, msubst i t, (n, msubst (i+1) u)) - | Meta(m,ts) -> Meta(m, Array.map (msubst i) ts) - | Patt(j,n,ts) -> Patt(j,n, Array.map (msubst i) ts) - | TEnv(te,ts) -> TEnv(te, Array.map (msubst i) ts) - | _ -> t - in msubst 1 t + if Logger.log_enabled() then + log_term "msubst %d %a %a" i (D.array term) vs term t; + match unfold t with + | Db k -> let j = k-i in + if j<0 then t else (assert(j (*FIXME: mk_Appl*) Appl(msubst i a, msubst i b) + | Abst(a,(n,u)) -> Abst(msubst i a, (n, msubst (i+1) u)) + | Prod(a,(n,u)) -> Prod(msubst i a, (n, msubst (i+1) u)) + | LLet(a,t,(n,u)) -> LLet(msubst i a, msubst i t, (n, msubst (i+1) u)) + | Meta(m,ts) -> Meta(m, Array.map (msubst i) ts) + | Patt(j,n,ts) -> Patt(j,n, Array.map (msubst i) ts) + | TEnv(te,ts) -> TEnv(te, Array.map (msubst i) ts) + | _ -> t + in + let r = if n = 0 then t else msubst 1 t in + if Logger.log_enabled() then + log_term "msubst %a %a = %a" term t (D.array term) vs term r; + r let msubst3 : (tmbinder * tmbinder * tmbinder) -> term array -> term * term * term = @@ -302,9 +310,9 @@ let msubst3 : let subst : tbinder -> term -> term = fun (_,t) v -> let rec subst i t = (*if Logger.log_enabled() then - log_term "subst [%d≔%a] %a" i Raw.term v Raw.term t;*) + log_term "subst [%d≔%a] %a" i term v term t;*) match unfold t with - | Db k -> if k = i then v else t + | Db k -> if k = i then lift (i-1) v else t | Appl(a,b) -> (*FIXME: mk_Appl*) Appl(subst i a, subst i b) | Abst(a,(n,u)) -> Abst(subst i a, (n, subst (i+1) u)) | Prod(a,(n,u)) -> Prod(subst i a, (n ,subst (i+1) u)) @@ -316,14 +324,12 @@ let subst : tbinder -> term -> term = fun (_,t) v -> in let r = subst 1 t in if Logger.log_enabled() then - log_term "@[subst [1≔%a]@ %a =@ %a@]" - Raw.term v Raw.term t Raw.term r; + log_term "subst %a [%a] = %a" term t term v term r; r (** [new_var _ name] creates a new unique variable using [name]. *) let new_var : (tvar -> term) -> string -> tvar = - let open Stdlib in let n = ref 0 in - fun _ name -> incr n; !n, name + let open Stdlib in let n = ref 0 in fun _ name -> incr n; !n, name let mkfree : tvar -> term = fun x -> Vari x @@ -332,7 +338,7 @@ let mkfree : tvar -> term = fun x -> Vari x let new_mvar : string array -> tvar array = Array.map (new_var mkfree) (** [name_of x] returns a printable name for variable [x]. *) -let name_of : tvar -> string = fun (_,n) -> n +let name_of : tvar -> string = fun (_i,n) -> n (*^ string_of_int i*) (** [unbind b] substitutes the binder [b] using a fresh variable. The variable and the result of the substitution are returned. Note that the name of the @@ -398,8 +404,7 @@ let box_apply2 : ('a -> 'b -> 'c) -> 'a box -> 'b box -> 'c box = fun x -> x (** [bind_var x b] binds the variable [x] in [b], producing a boxed binder. *) let bind_var : tvar -> term box -> tbinder box = fun ((_,n) as x) -> let rec bind i t = - (*if Logger.log_enabled() then - log_term "bind_var %a %d %a" Raw.var x i Raw.term t;*) + (*if Logger.log_enabled() then log_term "bind_var %d %a" i term t;*) match unfold t with | Vari y when y == x -> Db i | Appl(a,b) -> Appl(bind i a, bind i b) @@ -411,19 +416,23 @@ let bind_var : tvar -> term box -> tbinder box = fun ((_,n) as x) -> | TEnv(te,ts) -> TEnv(te, Array.map (bind i) ts) | _ -> t in fun t -> - let r = bind 1 t in + let b = bind 1 t in if Logger.log_enabled() then - log_term "@[bind_var %a@ %a =@ %a@]" - Raw.var x Raw.term t Raw.term r; - n, r + log_term "bind_var %a %a = %a" var x term t term b; + n, b (** [bind_mvar xs b] binds the variables of [xs] in [b] to get a boxed binder. It is the equivalent of [bind_var] for multiple variables. *) -let bind_mvar : tvar array -> term box -> tmbinder box = fun xs -> +let bind_mvar : tvar array -> term box -> tmbinder box = fun xs t -> + let n = Array.length xs in + if n = 0 then [||], t else let open Stdlib in let open Extra in + (*if Logger.log_enabled() then + log_term "bind_mvar %a" (D.array var) xs;*) let map = ref IntMap.empty in - Array.iteri (fun i (ki,_) -> map := IntMap.add ki i !map) xs; + Array.iteri (fun i (ki,_) -> map := IntMap.add ki (n-1-i) !map) xs; let rec bind i t = + (*if Logger.log_enabled() then log_term "bind_mvar %d %a" i term t;*) match unfold t with | Vari (key,_) -> (match IntMap.find_opt key !map with Some k -> Db (i+k) | None -> t) @@ -435,9 +444,11 @@ let bind_mvar : tvar array -> term box -> tmbinder box = fun xs -> | Patt(j,n,ts) -> Patt(j,n, Array.map (bind i) ts) | TEnv(te,ts) -> TEnv(te, Array.map (bind i) ts) | _ -> t - in fun t -> - if Array.length xs = 0 then [||], t - else Array.map name_of xs, bind 1 t + in + let b = bind 1 t in + if Logger.log_enabled() then + log_term "bind_mvar %a %a = %a" (D.array var) xs term t term b; + Array.map name_of xs, b let bind_mvar3 : tvar array -> (term box * term box * term box) -> tmbinder box * tmbinder box * tmbinder box = fun xs (t1, t2, t3) -> @@ -473,7 +484,7 @@ let eq_vars : tvar -> tvar -> bool = fun x y -> compare_vars x y = 0 let binder_occur : tbinder -> bool = fun (_,t) -> let rec check i t = (*if Logger.log_enabled() then - log_term "binder_occur %d %a" i Raw.term t;*) + log_term "binder_occur %d %a" i term t;*) match unfold t with | Db k when k = i -> raise Exit | Appl(a,b) -> check i a; check i b @@ -487,7 +498,7 @@ let binder_occur : tbinder -> bool = fun (_,t) -> in let r = try check 1 t; false with Exit -> true in if Logger.log_enabled() then - log_term "binder_occur 1 %a = %b" Raw.term t r; + log_term "binder_occur 1 %a = %b" term t r; r (** [binder_constant b] tests whether the [binder] [b] is constant (i.e., its @@ -537,6 +548,14 @@ type tbox = term Bindlib.box type tebox = term_env Bindlib.box +let unfold = Bindlib.unfold + +(** Printing functions for debug. *) +module Raw = struct + let sym = Bindlib.sym + let term = Bindlib.term +end + (** Minimize [impl] to enforce our invariant (see {!type:Terms.sym}). *) let minimize_impl : bool list -> bool list = let rec rem_false l = match l with false::l -> rem_false l | _ -> l in @@ -648,30 +667,6 @@ let is_private : sym -> bool = fun s -> s.sym_expo = Privat let is_modulo : sym -> bool = fun s -> match s.sym_prop with Assoc _ | Commu | AC _ -> true | _ -> false -(** [unfold t] repeatedly unfolds the definition of the surface constructor of - [t], until a significant {!type:term} constructor is found. The term that - is returned cannot be an instantiated metavariable or term environment nor - a reference cell ({!constructor:TRef} constructor). Note that the returned - value is physically equal to [t] if no unfolding was performed. *) -let rec unfold : term -> term = fun t -> - match t with - | Meta(m, ts) -> - begin - match !(m.meta_value) with - | None -> t - | Some(b) -> unfold (Bindlib.msubst b ts) - end - | TRef(r) -> - begin - match !r with - | None -> t - | Some(v) -> unfold v - end - | _ -> t - -(** {b NOTE} that {!val:unfold} must (almost) always be called before matching - over a value of type {!type:term}. *) - (** [is_abst t] returns [true] iff [t] is of the form [Abst(_)]. *) let is_abst : term -> bool = fun t -> match unfold t with Abst(_) -> true | _ -> false @@ -759,7 +754,7 @@ let mk_Kind = Kind let mk_Symb x = Symb x let mk_Prod (a,b) = Prod (a,b) let mk_Abst (a,b) = Abst (a,b) -let mk_Meta (m,ts) = Meta (m,ts) +let mk_Meta (m,ts) = (*assert (m.meta_arity = Array.length ts);*) Meta (m,ts) let mk_Patt (i,s,ts) = Patt (i,s,ts) let mk_Wild = Wild let mk_Plac b = Plac b @@ -981,141 +976,6 @@ let _TE_Vari : tevar -> tebox = fun x -> TE_Vari x (** [_TE_None] injects the constructor [TE_None] into the {!type:tbox} type.*) let _TE_None : tebox = Bindlib.box TE_None -module Old = struct - -type tbox = term OldBindlib.box -type tebox = term_env OldBindlib.box - -let _Db : int -> tbox = fun k -> OldBindlib.box (Db k) - -(** [_Vari x] injects the free variable [x] into the {!type:tbox} type so that - it may be available for binding. *) -let _Vari : tvar -> tbox = fun x -> OldBindlib.box (Vari x) - -(** [_Type] injects the constructor [Type] into the {!type:tbox} type. *) -let _Type : tbox = OldBindlib.box Type - -(** [_Kind] injects the constructor [Kind] into the {!type:tbox} type. *) -let _Kind : tbox = OldBindlib.box Kind - -(** [_Symb s] injects the constructor [Symb(s)] into the {!type:tbox} type. As - symbols are closed object they do not require lifting. *) -let _Symb : sym -> tbox = fun s -> OldBindlib.box (Symb s) - -(** [_Appl t u] lifts an application node to the {!type:tbox} type given boxed - terms [t] and [u]. *) -let _Appl : tbox -> tbox -> tbox = - OldBindlib.box_apply2 (fun t u -> mk_Appl (t,u)) - -(** [_Appl_not_canonical t u] lifts an application node to the {!type:tbox} - type given boxed terms [t] and [u], without putting it in canonical form - wrt. C and AC symbols. WARNING: to use in scoping of rewrite rule LHS only - as it breaks some invariants. *) -let _Appl_not_canonical : tbox -> tbox -> tbox = - OldBindlib.box_apply2 (fun t u -> Appl (t,u)) - -(** [_Appl_list a [b1;...;bn]] returns (... ((a b1) b2) ...) bn. *) -let _Appl_list : tbox -> tbox list -> tbox = List.fold_left _Appl - -(** [_Appl_Symb f ts] returns the same result that - _Appl_l ist (_Symb [f]) [ts]. *) -let _Appl_Symb : sym -> tbox list -> tbox = fun f ts -> - _Appl_list (_Symb f) ts - -(** [_Prod a b] lifts a dependent product node to the {!type:tbox} type, given - a boxed term [a] for the domain of the product, and a boxed binder [b] for - its codomain. *) -let _Prod : tbox -> tbinder OldBindlib.box -> tbox = - OldBindlib.box_apply2 (fun a b -> Prod(a,b)) - -let impl : term -> term -> term = fun a b -> - let v = new_tvar "_" in mk_Prod(a, Bindlib.bind_var v b) - -let _Impl : tbox -> tbox -> tbox = OldBindlib.box_apply2 impl - -(** [_Abst a t] lifts an abstraction node to the {!type:tbox} type, given a - boxed term [a] for the domain type, and a boxed binder [t]. *) -let _Abst : tbox -> tbinder OldBindlib.box -> tbox = - OldBindlib.box_apply2 (fun a t -> Abst(a,t)) - -(** [_Meta m ts] lifts the metavariable [m] to the {!type:tbox} type given its - environment [ts]. As for symbols in {!val:_Symb}, metavariables are closed - objects so they do not require lifting. *) -let _Meta : meta -> tbox array -> tbox = fun m ts -> - OldBindlib.box_apply (fun ts -> Meta(m,ts)) (OldBindlib.box_array ts) - -(** [_Meta_full m ts] is similar to [_Meta m ts] but works with a metavariable - that is boxed. This is useful in very rare cases, when metavariables need - to be able to contain free term environment variables. Using this function - in bad places is harmful for efficiency but not unsound. *) -let _Meta_full : meta OldBindlib.box -> tbox array -> tbox = fun m ts -> - OldBindlib.box_apply2 (fun m ts -> Meta(m,ts)) m (OldBindlib.box_array ts) - -(** [_Patt i n ts] lifts a pattern variable to the {!type:tbox} type. *) -let _Patt : int option -> string -> tbox array -> tbox = fun i n ts -> - OldBindlib.box_apply (fun ts -> Patt(i,n,ts)) (OldBindlib.box_array ts) - -(** [_TEnv te ts] lifts a term environment to the {!type:tbox} type. *) -let _TEnv : tebox -> tbox array -> tbox = fun te ts -> - OldBindlib.box_apply2 (fun te ts -> mk_TEnv(te,ts)) - te (OldBindlib.box_array ts) - -(** [_Wild] injects the constructor [Wild] into the {!type:tbox} type. *) -let _Wild : tbox = OldBindlib.box Wild - -let _Plac : bool -> tbox = fun b -> OldBindlib.box (mk_Plac b) - -(** [_TRef r] injects the constructor [TRef(r)] into the {!type:tbox} type. It - should be the case that [!r] is [None]. *) -let _TRef : term option ref -> tbox = fun r -> OldBindlib.box (TRef(r)) - -(** [_LLet t a u] lifts let binding [let x := t : a in u]. *) -let _LLet : tbox -> tbox -> tbinder OldBindlib.box -> tbox = - OldBindlib.box_apply3 (fun a t u -> mk_LLet(a, t, u)) - -(** [_TE_Vari x] injects a term environment variable [x] into the {!type:tbox} - type so that it may be available for binding. *) -let _TE_Vari : tevar -> tebox = OldBindlib.box_var - -(** [_TE_None] injects the constructor [TE_None] into the {!type:tbox} type.*) -let _TE_None : tebox = OldBindlib.box TE_None - -let lift : (tbox -> tbox -> tbox) -> term -> term OldBindlib.box = - fun mk_appl -> - let rec lift : term -> term OldBindlib.box = fun t -> - match unfold t with - | Prod(a,b) -> _Prod (lift a) (lift_binder b) - | Abst(a,b) -> _Abst (lift a) (lift_binder b) - | Appl(a,b) -> mk_appl (lift a) (lift b) - | Meta(m,ts) -> _Meta m (Array.map lift ts) - | Patt(i,n,ts) -> _Patt i n (Array.map lift ts) - | TEnv(te,ts) -> _TEnv (lift_term_env te) (Array.map lift ts) - | LLet(a,t,u) -> _LLet (lift a) (lift t) (lift_binder u) - | Wild - | Plac _ - | TRef _ - | Db _ - | Vari _ - | Type - | Kind - | Symb _ -> OldBindlib.box t - (* We do not use [Bindlib.box_binder] here because it is possible for a free - variable to disappear from a term through metavariable instantiation. As - a consequence we must traverse the whole term, even when we find a closed - binder, so that the metadata on nested binders is also updated. *) - and lift_binder b = - let x,t = Bindlib.unbind b in - OldBindlib.box (Bindlib.bind_var x (OldBindlib.unbox (lift t))) - and lift_term_env : term_env -> tebox = function - | TE_Vari x -> _TE_Vari x - | TE_None -> _TE_None - | TE_Some _ -> assert false (* Unreachable. *) - in lift - -end - -let old_lift = Old.lift Old._Appl - (** [lift mk_appl t] lifts the {!type:term} [t] to the type {!type:tbox}, using the function [mk_appl] in the case of an application. This has the effect of gathering its free variables, making them available for binding. @@ -1155,17 +1015,37 @@ type cp_pos = Pos.popt * term * term * subterm_pos * term substituted using [Patt] constructors. They are thus represented as their LHS counterparts. This is a more convenient way of representing terms when analysing confluence or termination. *) -let term_of_rhs : rule -> term = fun r -> - let f i tevar = - let (name, arity) = (OldBindlib.name_of tevar, r.arities.(i)) in - let vars = Array.init arity (new_tvar_ind "x") in - let p = _Patt (Some i) name (Array.map _Vari vars) in - TE_Some(Bindlib.unbox (Bindlib.bind_mvar vars p)) - in - OldBindlib.msubst r.rhs (Array.mapi f r.vars) +let term_of_rhs : rule -> term = fun r -> r.rhs (** Type of a symbol and a rule. *) type sym_rule = sym * rule let lhs : sym_rule -> term = fun (s, r) -> add_args (mk_Symb s) r.lhs let rhs : sym_rule -> term = fun (_, r) -> term_of_rhs r + +(** Patt substitution. *) +let subst_patt : tmbinder option array -> term -> term = fun env -> + let rec subst_patt t = + match unfold t with + | Patt(Some i,n,ts) when 0 <= i && i < Array.length env -> + begin match env.(i) with + | Some b -> Bindlib.msubst b (Array.map subst_patt ts) + | None -> mk_Patt(Some i,n,Array.map subst_patt ts) + end + | Patt(i,n,ts) -> mk_Patt(i, n, Array.map subst_patt ts) + | Prod(a,(n,b)) -> mk_Prod(subst_patt a, (n, subst_patt b)) + | Abst(a,(n,b)) -> mk_Abst(subst_patt a, (n, subst_patt b)) + | Appl(a,b) -> mk_Appl(subst_patt a, subst_patt b) + | Meta(m,ts) -> mk_Meta(m, Array.map subst_patt ts) + | TEnv _ -> assert false + | LLet(a,t,(n,b)) -> + mk_LLet(subst_patt a, subst_patt t, (n, subst_patt b)) + | Wild + | Plac _ + | TRef _ + | Db _ + | Vari _ + | Type + | Kind + | Symb _ -> t + in subst_patt diff --git a/src/core/term.mli b/src/core/term.mli index debd6ba3c..60f0cb9fc 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -82,7 +82,7 @@ type term = private syntax. They are thus considered to be fresh, unused pattern variables. *) (** Representation of a rewriting rule RHS. *) -and rhs = (term_env, term) OldBindlib.mbinder +and rhs = term (** Representation of a decision tree (used for rewriting). *) and dtree = rule Tree_type.dtree @@ -135,9 +135,7 @@ and sym = ; arity : int (** Required number of arguments to be applicable. *) ; arities : int array (** Arities of the pattern variables bound in the RHS. *) - ; vars : tevar array - (** Bindlib variables used to build [rhs]. The last [xvars_nb] variables - appear only in [rhs]. *) + ; vars_nb : int (** Number of variables in [lhs]. *) ; xvars_nb : int (** Number of variables in [rhs] but not in [lhs]. *) ; rule_pos : Pos.popt (** Position of the rule in the source file. *) } @@ -352,8 +350,6 @@ type tbox = term Bindlib.box type tebox = term_env Bindlib.box -val old_lift : term -> term OldBindlib.box - (** Minimize [impl] to enforce our invariant (see {!type:Term.sym}). *) val minimize_impl : bool list -> bool list @@ -637,3 +633,6 @@ type sym_rule = sym * rule val lhs : sym_rule -> term val rhs : sym_rule -> term + +(** Patt substitution. *) +val subst_patt : tmbinder option array -> term -> term diff --git a/src/core/unif.ml b/src/core/unif.ml index 41826d133..185b04fb5 100644 --- a/src/core/unif.ml +++ b/src/core/unif.ml @@ -8,8 +8,8 @@ open LibTerm open Print (** Logging function for unification. *) -let log_unif = Logger.make 'u' "unif" "unification" -let log_unif = log_unif.pp +let logger = Logger.make 'u' "unif" "unification" +let log = logger.pp (** Given a meta [m] of type [Πx1:a1,..,Πxn:an,b], [set_to_prod p m] sets [m] to a product term of the form [Πy:m1[x1;..;xn],m2[x1;..;xn;y]] with [m1] @@ -25,14 +25,14 @@ let set_to_prod : problem -> meta -> unit = fun p m -> let a = _Meta m1 xs in (* codomain *) let y = new_tvar "y" in - let env' = Env.add y (_Meta m1 xs) None env in + let env' = Env.add "y" y (_Meta m1 xs) None env in let u2 = Env.to_prod env' (lift s) in let m2 = LibMeta.fresh p u2 (n+1) in let b = Bindlib.bind_var y (_Meta m2 (Array.append xs [|_Vari y|])) in (* result *) let r = _Prod a b in if Logger.log_enabled () then - log_unif (red "%a ≔ %a") meta m term (Bindlib.unbox r); + log (red "%a ≔ %a") meta m term (Bindlib.unbox r); LibMeta.set p m (Bindlib.unbox (Bindlib.bind_mvar vs r)) (** [type_app c a ts] returns [Some u] where [u] is a type of [add_args x ts] @@ -46,7 +46,7 @@ let rec type_app : ctxt -> term -> term list -> term option = fun c a ts -> (** [add_constr p c] adds the constraint [c] into [p.to_solve]. *) let add_constr : problem -> constr -> unit = fun p c -> - if Logger.log_enabled () then log_unif (mag "add %a") constr c; + if Logger.log_enabled () then log (mag "add %a") constr c; p := {!p with to_solve = c::!p.to_solve} (** [add_unif_rule_constr p (c,t,u)] adds to [p] the constraint [(c,t,u)] @@ -71,7 +71,7 @@ let add_unif_rule_constr : problem -> constr -> unit = fun p (c,t,u) -> ⊢ s ≡ t] with the user-defined unification rules. *) let try_unif_rules : problem -> ctxt -> term -> term -> bool = fun p c s t -> - if Logger.log_enabled () then log_unif "check unif_rules"; + if Logger.log_enabled () then log "check unif_rules"; let exception No_match in let open Unif_rule in try @@ -84,11 +84,11 @@ let try_unif_rules : problem -> ctxt -> term -> term -> bool = if reduced != start then reduced else raise No_match in let cs = List.map (fun (t,u) -> (c,t,u)) (unpack rhs) in - if Logger.log_enabled () then log_unif "rewrites to:%a" constrs cs; + if Logger.log_enabled () then log "rewrites to:%a" constrs cs; List.iter (add_unif_rule_constr p) cs; true with No_match -> - if Logger.log_enabled () then log_unif "found no unif_rule"; + if Logger.log_enabled () then log "found no unif_rule"; false (** [instantiable c m ts u] tells whether, in a problem [m[ts]=u], [m] can @@ -108,7 +108,8 @@ let instantiation : | Some(vs, map) -> if LibMeta.occurs m c u then None else let u = Eval.simplify (Ctxt.to_let c (sym_to_var map u)) in - Some (Bindlib.bind_mvar vs (lift u)) + Some (Logger.set_debug_in false 'm' + (Bindlib.bind_mvar vs) (lift u)) (** Checking type or not during meta instanciation. *) let do_type_check = Stdlib.ref true @@ -118,25 +119,27 @@ let do_type_check = Stdlib.ref true metavariables of [p]. *) let instantiate : problem -> ctxt -> meta -> term array -> term -> bool = fun p c m ts u -> - if Logger.log_enabled () then log_unif "try instantiate"; + if Logger.log_enabled () then log "try instantiate"; match instantiation c m ts u with | Some b when Bindlib.is_closed_tmbinder b -> let do_instantiate() = - if Logger.log_enabled () then - log_unif (red "%a ≔ %a") meta m term u; + if Logger.log_enabled () then log (red "%a ≔ %a") meta m term u; LibMeta.set p m (Bindlib.unbox b); p := {!p with recompute = true}; true in if Stdlib.(!do_type_check) then begin - if Logger.log_enabled () then log_unif "check typing"; + if Logger.log_enabled () then log "check typing"; let typ_mts = match type_app c !(m.meta_type) (Array.to_list ts) with | Some a -> a | None -> assert false in - if Infer.check_noexn p c u typ_mts <> None then do_instantiate() - else (if Logger.log_enabled () then log_unif "typing failed"; false) + let r = + Logger.set_debug_in false 'i' (Infer.check_noexn p c u) typ_mts + in + if r <> None then do_instantiate() + else (if Logger.log_enabled () then log "typing failed"; false) end else do_instantiate() | i -> @@ -144,10 +147,10 @@ let instantiate : problem -> ctxt -> meta -> term array -> term -> bool = begin match i with | None -> - if LibMeta.occurs m c u then log_unif "occur check failed" - else log_unif "arguments are not distinct variables: %a" + if LibMeta.occurs m c u then log "occur check failed" + else log "arguments are not distinct variables: %a" (Array.pp term "; ") ts - | Some _ -> log_unif "not closed" + | Some _ -> log "not closed" end; false @@ -158,9 +161,9 @@ let instantiate : problem -> ctxt -> meta -> term array -> term -> bool = let add_to_unsolved : problem -> ctxt -> term -> term -> unit = fun p c t1 t2 -> if Eval.pure_eq_modulo c t1 t2 then - (if Logger.log_enabled () then log_unif "equivalent terms") + (if Logger.log_enabled () then log "equivalent terms") else if not (try_unif_rules p c t1 t2) then - (if Logger.log_enabled () then log_unif "move to unsolved"; + (if Logger.log_enabled () then log "move to unsolved"; p := {!p with unsolved = (c,t1,t2)::!p.unsolved}) (** [decompose p c ts1 ts2] tries to decompose a problem of the form [h ts1 ≡ @@ -168,7 +171,7 @@ let add_to_unsolved : problem -> ctxt -> term -> term -> unit = [t1;..;tn]] and [ts2 = [u1;..;un]]. *) let decompose : problem -> ctxt -> term list -> term list -> unit = fun p c ts1 ts2 -> - if Logger.log_enabled () && ts1 <> [] then log_unif "decompose"; + if Logger.log_enabled () && ts1 <> [] then log "decompose"; List.iter2 (fun a b -> add_constr p (c,a,b)) ts1 ts2 (** For a problem of the form [h1 ≡ h2] with [h1 = m[ts]], [h2 = Πx:_,_] (or @@ -177,7 +180,7 @@ let decompose : problem -> ctxt -> term list -> term list -> unit = [p]. *) let imitate_prod : problem -> ctxt -> meta -> term -> term -> unit = fun p c m h1 h2 -> - if Logger.log_enabled () then log_unif "imitate_prod %a" meta m; + if Logger.log_enabled () then log "imitate_prod %a" meta m; set_to_prod p m; add_constr p (c,h1,h2) (** For a problem [m[vs] ≡ s(ts)] in context [c], where [vs] are distinct @@ -192,7 +195,7 @@ let imitate_inj : -> bool = fun p c m vs us s ts -> if Logger.log_enabled () then - log_unif "imitate_inj %a ≡ %a" term (add_args (mk_Meta(m,vs)) us) + log "imitate_inj %a ≡ %a" term (add_args (mk_Meta(m,vs)) us) term (add_args (mk_Symb s) ts); let exception Cannot_imitate in try @@ -219,7 +222,7 @@ let imitate_inj : | _ -> raise Cannot_imitate in build (List.length ts) [] !(s.sym_type) in - if Logger.log_enabled () then log_unif (red "%a ≔ %a") meta m term t; + if Logger.log_enabled () then log (red "%a ≔ %a") meta m term t; LibMeta.set p m (binds vars lift t); true with Cannot_imitate | Invalid_argument _ -> false @@ -245,13 +248,13 @@ let imitate_lam_cond : term -> term list -> bool = fun h ts -> a new metavariable of arity [n+1] and type [Πx1:a1,..,Πxn:an,Πx:m2[x1,..,xn],TYPE], and do as in the previous case. *) let imitate_lam : problem -> ctxt -> meta -> unit = fun p c m -> - if Logger.log_enabled () then log_unif "imitate_lam %a" meta m; + if Logger.log_enabled () then log "imitate_lam %a" meta m; let n = m.meta_arity in let env, t = Env.of_prod_nth c n !(m.meta_type) in let of_prod a b = let x,b = LibTerm.unbind_name "x" b in let a = lift a in - let env' = Env.add x a None env in + let env' = Env.add "x" x a None env in x, a, env', lift b in let x, a, env', b = @@ -269,7 +272,7 @@ let imitate_lam : problem -> ctxt -> meta -> unit = fun p c m -> let m2 = LibMeta.fresh p tm2 n in let a = _Meta m2 (Env.to_tbox env) in let x = new_tvar "x" in - let env' = Env.add x a None env in + let env' = Env.add "x" x a None env in let tm3 = Env.to_prod env' _Type in let m3 = LibMeta.fresh p tm3 (n+1) in let b = _Meta m3 (Env.to_tbox env') in @@ -283,19 +286,19 @@ let imitate_lam : problem -> ctxt -> meta -> unit = fun p c m -> let xu1 = _Abst a (Bindlib.bind_var x u1) in let v = Bindlib.bind_mvar (Env.vars env) xu1 in if Logger.log_enabled () then - log_unif (red "%a ≔ %a") meta m term (Bindlib.unbox xu1); + log (red "%a ≔ %a") meta m term (Bindlib.unbox xu1); LibMeta.set p m (Bindlib.unbox v) (** [inverse_opt s ts v] returns [Some(t, inverse s v)] if [ts=[t]], [s] is injective and [inverse s v] does not fail, and [None] otherwise. *) let inverse_opt : sym -> term list -> term -> (term * term) option = fun s ts v -> - if Logger.log_enabled () then log_unif "try inverse %a" sym s; + if Logger.log_enabled () then log "try inverse %a" sym s; try match ts with | [t] when is_injective s -> Some (t, Inverse.inverse s v) | _ -> raise Not_found - with Not_found -> if Logger.log_enabled () then log_unif "failed"; None + with Not_found -> if Logger.log_enabled () then log "failed"; None (** Exception raised when a constraint is not solvable. *) exception Unsolvable @@ -319,7 +322,7 @@ let inverse : problem -> ctxt -> term -> sym -> term list -> term -> unit = match unfold t2 with | Prod _ when is_constant s -> error t1 t2 | _ -> - if Logger.log_enabled () then log_unif "move to unsolved"; + if Logger.log_enabled () then log "move to unsolved"; p := {!p with unsolved = (c, t1, t2)::!p.unsolved} (** [sym_sym_whnf p c t1 s1 ts1 t2 s2 ts2 p] handles the case [s1(ts1) = @@ -347,11 +350,12 @@ let solve : problem -> unit = fun p -> while !p.to_solve <> [] || (!p.recompute && !p.unsolved <> []) do match !p.to_solve with | [] -> - if Logger.log_enabled () then log_unif "recompute"; + if Logger.log_enabled () then log "recompute"; p := {!p with to_solve = !p.unsolved; unsolved = []; recompute = false} | (c,t1,t2)::to_solve -> (*if Logger.log_enabled () then - log_unif "%d constraints" (1 + List.length to_solve);*) + log "%d constraints" (1 + List.length to_solve);*) + if Logger.log_enabled() then log "solve problem %a" problem p; (* We remove the first constraint from [p] for not looping. *) p := {!p with to_solve}; @@ -359,7 +363,7 @@ let solve : problem -> unit = fun p -> (* We first try without normalizing wrt user-defined rules. *) let t1 = Eval.whnf ~tags:[`NoRw] c t1 and t2 = Eval.whnf ~tags:[`NoRw] c t2 in - if Logger.log_enabled () then log_unif (gre "solve %a") constr (c,t1,t2); + if Logger.log_enabled () then log (gre "solve %a") constr (c,t1,t2); let h1, ts1 = get_args t1 and h2, ts2 = get_args t2 in match h1, h2 with @@ -369,7 +373,7 @@ let solve : problem -> unit = fun p -> | Prod(a1,b1), Prod(a2,b2) | Abst(a1,b1), Abst(a2,b2) -> (* [ts1] and [ts2] must be empty because of typing or normalization. *) - if Logger.log_enabled () then log_unif "decompose"; + if Logger.log_enabled () then log "decompose"; add_constr p (c,a1,a2); let (x,b1,b2) = Bindlib.unbind2 b1 b2 in let c' = (x,a1,None)::c in @@ -414,9 +418,9 @@ let solve : problem -> unit = fun p -> | _ -> (* We normalize wrt user-defined rules and try again. *) - if Logger.log_enabled () then log_unif "whnf"; + if Logger.log_enabled () then log "whnf"; let t1 = Eval.whnf c t1 and t2 = Eval.whnf c t2 in - if Logger.log_enabled () then log_unif (gre "solve %a") constr (c,t1,t2); + if Logger.log_enabled () then log (gre "solve %a") constr (c,t1,t2); let h1, ts1 = get_args t1 and h2, ts2 = get_args t2 in match h1, h2 with @@ -426,7 +430,7 @@ let solve : problem -> unit = fun p -> | Prod(a1,b1), Prod(a2,b2) | Abst(a1,b1), Abst(a2,b2) -> (* [ts1] and [ts2] must be empty because of typing or normalization. *) - if Logger.log_enabled () then log_unif "decompose"; + if Logger.log_enabled () then log "decompose"; add_constr p (c,a1,a2); let (x,b1,b2) = Bindlib.unbind2 b1 b2 in let c' = (x,a1,None)::c in diff --git a/src/export/dk.ml b/src/export/dk.ml index 1f63aca9a..45eb365e1 100644 --- a/src/export/dk.ml +++ b/src/export/dk.ml @@ -117,6 +117,7 @@ let tenv : term_env pp = fun ppf te -> | TE_Some _ -> assert false | TE_None -> assert false +(** [term b ppf t] prints term [t]. Print abstraction domains if [b]. *) let rec term : bool -> term pp = fun b ppf t -> match unfold t with | Db _ -> assert false @@ -139,9 +140,10 @@ let rec term : bool -> term pp = fun b ppf t -> | LLet(a,t,u) -> let x,u = Bindlib.unbind u in out ppf "((%a : %a := %a) => %a)" tvar x (term b) a (term b) t (term b) u - | Patt(_,s,[||]) -> ident ppf s - | Patt(_,s,ts) -> - out ppf "(%a%a)" ident s (Array.pp (prefix " " (term b)) "") ts + | Patt(None,_,_) -> assert false + | Patt(Some i,_,[||]) -> int ppf i + | Patt(Some i,_,ts) -> + out ppf "(%d%a)" i (Array.pp (prefix " " (term b)) "") ts | TEnv(te, [||]) -> tenv ppf te | TEnv(te, ts) -> out ppf "%a%a" tenv te (Array.pp (prefix " " (term b)) "") ts @@ -196,10 +198,13 @@ let sym_decl : sym pp = fun ppf s -> ident s.sym_name (term true) d let rule_decl : (Path.t * string * rule) pp = fun ppf (p, n, r) -> - let xs, rhs = OldBindlib.unmbind r.rhs in - out ppf "[%a] %a%a --> %a.@." - (Array.pp tevar ", ") xs qid (p, n) - (List.pp (prefix " " (term false)) "") r.lhs (term true) rhs + let rec var ppf i = + if i < 0 then () + else if i = 0 then out ppf "0" + else out ppf "%a,%d" var (i-1) i + in + out ppf "[%a] %a%a --> %a.@." var (r.vars_nb - 1) qid (p, n) + (List.pp (prefix " " (term false)) "") r.lhs (term true) r.rhs let decl : decl pp = fun ppf decl -> match decl with diff --git a/src/export/hrs.ml b/src/export/hrs.ml index fb7ad2e62..0eb2623cd 100644 --- a/src/export/hrs.ml +++ b/src/export/hrs.ml @@ -31,10 +31,11 @@ let print_term : bool -> term pp = fun lhs -> | Vari(x) -> out ppf "%a" var x | Type -> out ppf "TYPE" | Symb(s) -> print_sym ppf s - | Patt(i,n,ts) -> - if ts = [||] then out ppf "$%s" n else + | Patt(None,_,_) -> assert false + | Patt(Some i,n,ts) -> + if ts = [||] then out ppf "$%d" i else pp ppf (Array.fold_left (fun t u -> mk_Appl(t,u)) - (mk_Patt(i,n,[||])) ts) + (mk_Patt(Some i,n,[||])) ts) | Appl(t,u) -> out ppf "app(%a,%a)" pp t pp u | Abst(a,t) -> let (x, t) = Bindlib.unbind t in @@ -55,7 +56,10 @@ let print_rule : Format.formatter -> term -> term -> unit = let names = Stdlib.ref ns in let fn t = match t with - | Patt(_,n,_) -> Stdlib.(names := StrSet.add ("$" ^ n) !names) + | Patt(None,_,_) -> assert false + | Patt(Some i,_,_) -> + let name = Format.sprintf "$%d" i in + Stdlib.(names := StrSet.add name !names) | Abst(_,b) -> let (x, _) = Bindlib.unbind b in Stdlib.(names := StrSet.add (Bindlib.name_of x) !names) diff --git a/src/export/xtc.ml b/src/export/xtc.ml index 1b8e9df2b..0bc19c2c4 100644 --- a/src/export/xtc.ml +++ b/src/export/xtc.ml @@ -46,10 +46,12 @@ let rec print_term : int -> string -> term pp = fun i s ppf t -> | Vari(x) -> out ppf "v_%a@." var x | Symb(s) -> out ppf "@.%a@.@." print_sym s - | Patt(j,n,ts) -> - if ts = [||] then out ppf "%s_%i_%s@." s i n else + | Patt(None,_,_) -> assert false + | Patt(Some j,n,ts) -> + if ts = [||] then out ppf "%s_%i_%i@." s i j else print_term i s ppf - (Array.fold_left (fun t u -> mk_Appl(t,u)) (mk_Patt(j,n,[||])) ts) + (Array.fold_left + (fun t u -> mk_Appl(t,u)) (mk_Patt(Some j,n,[||])) ts) | Appl(t,u) -> out ppf "@.%a%a@." (print_term i s) t (print_term i s) u | Abst(a,t) -> @@ -114,7 +116,7 @@ let print_tl_rule : Format.formatter -> int -> sym -> rule -> unit = in the form of a pair containing the name of the variable and its type, inferred by the solver. *) let get_vars : sym -> rule -> (string * Term.term) list = fun s r -> - let rule_ctx : tvar option array = Array.make (Array.length r.vars) None in + let rule_ctx : tvar option array = Array.make r.vars_nb None in let var_list : tvar list ref = ref [] in let rec subst_patt v t = match t with @@ -134,14 +136,11 @@ let get_vars : sym -> rule -> (string * Term.term) list = fun s r -> let (x,t2) = Bindlib.unbind b in mk_Abst(subst_patt v t1, bind x lift (subst_patt v t2)) | Appl (t1, t2) -> mk_Appl(subst_patt v t1, subst_patt v t2) - | Patt (None, x, a) -> - let v_i = new_tvar x in - var_list := v_i :: !var_list; - Array.fold_left (fun acc t -> mk_Appl(acc,t)) (mk_Vari v_i) a - | Patt (Some(i), x, a) -> + | Patt (None, _, _) -> assert false + | Patt (Some(i), _, a) -> if v.(i) = None then - (let v_i = new_tvar x in + (let v_i = new_tvar (string_of_int i) in var_list := v_i :: !var_list; v.(i) <- Some(v_i)); let v_i = diff --git a/src/handle/command.ml b/src/handle/command.ml index 45a37f857..b80e6979c 100644 --- a/src/handle/command.ml +++ b/src/handle/command.ml @@ -121,23 +121,6 @@ let handle_modifiers : p_modifier list -> prop * expo * match_strat = in (prop, expo, strat) -(** [check_rule ss syms r] checks rule [r] and returns the head symbol of the - lhs and the rule itself. *) -let check_rule : sig_state -> p_rule -> sym_rule = fun ss r -> - Console.out 3 (Color.cya "%a") Pos.pp r.pos; - Console.out 4 "%a" (Pretty.rule "rule") r; - let pr = scope_rule false ss r in - let s = pr.elt.pr_sym in - if !(s.sym_def) <> None then - fatal pr.pos "No rewriting rule can be given on a defined symbol."; - s, Tool.Sr.check_rule pr - -(** [handle_rule ss syms r] checks rule [r], adds it in [ss] and returns the - head symbol of the lhs and the rule itself. *) -let add_rule : sig_state -> sym_rule -> unit = fun ss ((s,r) as x) -> - Sign.add_rule ss.signature s r; - Console.out 2 (Color.red "rule %a") sym_rule x - (** [handle_inductive_symbol ss e p strat x xs a] handles the command [e p strat symbol x xs : a] with [ss] as the signature state. On success, an updated signature state and the new symbol are returned. *) @@ -202,10 +185,11 @@ let get_proof_data : compiler -> sig_state -> p_command -> cmd_output = | P_open(ps) -> (List.fold_left handle_open ss ps, None, None) | P_rules(rs) -> (* Scope rules, and check that they preserve typing. Return the list of - rules [srs] and also a map [map] mapping every symbol defined by a rule + rules [srs] and also a [map] mapping every symbol defined by a rule of [srs] to its defining rules. *) - let handle_rule (srs, map) r = - let (s,r) as sr = check_rule ss r in + let handle_rule (srs, map) pr = + let sr = scope_rule false ss pr in + let (s,r) as sr = Tool.Sr.check_rule pr.pos sr in let h = function Some rs -> Some(r::rs) | None -> Some[r] in sr::srs, SymMap.update s h map in @@ -234,13 +218,12 @@ let get_proof_data : compiler -> sig_state -> p_command -> cmd_output = let s = find_sym ~prt:true ~prv:true ss qid in Console.out 2 "notation %a %a" sym s notation n; (add_notation ss s n, None, None) - | P_unif_rule(h) -> - (* Approximately same processing as rules without SR checking. *) - let pur = scope_rule true ss h in - let urule = Scope.rule_of_pre_rule pur in - Sign.add_rule ss.signature Unif_rule.equiv urule; + | P_unif_rule(pr) -> + (* Approximately same processing as rules without SR/LCR checking. *) + let (_,r) as sr = scope_rule true ss pr in + Sign.add_rule ss.signature sr; Tree.update_dtree Unif_rule.equiv []; - Console.out 2 "unif_rule %a" unif_rule urule; + Console.out 2 "unif_rule %a" unif_rule r; (ss, None, None) | P_inductive(ms, params, p_ind_list) -> @@ -322,9 +305,14 @@ let get_proof_data : compiler -> sig_state -> p_command -> cmd_output = ind_sym_list_rev rec_typ_list_rev in (* Add recursor rules in the signature. *) + let add_rule pr = + let r = scope_rule false ss pr in + let r = Tool.Sr.check_rule pos r in + Sign.add_rule ss.signature r; + Console.out 2 (Color.red "rule %a") sym_rule r + in with_no_wrn - (Inductive.iter_rec_rules pos ind_list vs ind_pred_map) - (fun r -> add_rule ss (check_rule ss r)); + (Inductive.iter_rec_rules pos ind_list vs ind_pred_map) add_rule; List.iter (fun s -> Tree.update_dtree s []) rec_sym_list; (* Store the inductive structure in the signature *) let ind_nb_types = List.length ind_list in diff --git a/src/handle/inductive.ml b/src/handle/inductive.ml index 502ad80a7..0518e6f77 100644 --- a/src/handle/inductive.ml +++ b/src/handle/inductive.ml @@ -43,41 +43,52 @@ let prf_of : config -> tvar -> tbox list -> tbox -> tbox = fun c p ts t -> let gen_safe_prefixes : inductive -> string * string * string = let letter c = match c with 'a' | 'p' | 'x' -> true | _ -> false in fun ind_list -> + let open Extra in let clashing_names = + let rec add_name_from_type set t = + match unfold t with + | Prod(_,b) -> + let x,b = Bindlib.unbind b in + add_name_from_type (StrSet.add (Bindlib.name_of x) set) b + | _ -> set + in let add_name_from_sym set sym = let s = sym.sym_name in - if s <> "" && letter s.[0] then Extra.StrSet.add s set else set + let set = if s <> "" && letter s.[0] then StrSet.add s set else set in + add_name_from_type set !(sym.sym_type) in let add_names_from_ind set (ind_sym, cons_sym_list) = let set = add_name_from_sym set ind_sym in List.fold_left add_name_from_sym set cons_sym_list in - List.fold_left add_names_from_ind Extra.StrSet.empty ind_list + List.fold_left add_names_from_ind StrSet.empty ind_list in - let a_str = Extra.get_safe_prefix "a" clashing_names in - let p_str = Extra.get_safe_prefix "p" clashing_names in - let x_str = Extra.get_safe_prefix "x" clashing_names in + let a_str = get_safe_prefix "a" clashing_names in + let p_str = get_safe_prefix "p" clashing_names in + let x_str = get_safe_prefix "x" clashing_names in a_str, p_str, x_str (** Type of maps associating to every inductive type some data useful for generating the induction principles. *) type data = { ind_var : tvar (** predicate variable *) ; ind_type : tbox (** predicate variable type *) - ; ind_conclu : tbox (** induction principle conlusion *) } + ; ind_conclu : tbox (** induction principle conclusion *) } type ind_pred_map = (sym * data) list (** [ind_typ_with_codom pos ind_sym ind_env codom s a] assumes that [a] is of the form [Π(i1:a1),...,Π(in:an), TYPE]. It then generates a [tbox] similar to this type except that [TYPE] is replaced by [codom [i1;...;in]]. The - string [s] is used as prefix for the variables [ik]. *) + string [x_str] is used as prefix for the variables [ik]. *) let ind_typ_with_codom : popt -> sym -> Env.t -> (tbox list -> tbox) -> string -> term -> tbox = - fun pos ind_sym env codom s a -> + fun pos ind_sym env codom x_str a -> + let i = Stdlib.ref (-1) in let rec aux : tvar list -> term -> tbox = fun xs a -> match get_args a with | (Type, _) -> codom (List.rev_map _Vari xs) | (Prod(a,b), _) -> - let (x,b) = LibTerm.unbind_name s b in + let name = Stdlib.(incr i; x_str ^ string_of_int (!i)) in + let (x,b) = LibTerm.unbind_name name b in _Prod (lift a) (Bindlib.bind_var x (aux (x::xs) b)) | _ -> fatal pos "The type of %a is not supported" sym ind_sym in @@ -180,6 +191,7 @@ let fold_cons_type (codom : 'var list -> 'a -> tvar -> term list -> 'c) : 'c = + let i = Stdlib.ref (-1) in let rec fold : 'var list -> 'a -> term -> 'c = fun xs acc t -> match get_args t with | (Symb(s), ts) -> @@ -189,7 +201,8 @@ let fold_cons_type else fatal pos "%a is not a constructor of %a" sym cons_sym sym ind_sym | (Prod(t,u), _) -> - let x, u = LibTerm.unbind_name x_str u in + let name = Stdlib.(incr i; x_str ^ string_of_int (!i)) in + let x, u = LibTerm.unbind_name name u in let x = inj_var (List.length xs) x in begin let env, b = Env.of_prod [] "y" t in diff --git a/src/handle/tactic.ml b/src/handle/tactic.ml index f71df1b92..9584d2d64 100644 --- a/src/handle/tactic.ml +++ b/src/handle/tactic.ml @@ -195,9 +195,9 @@ let handle : let assume n = if n <= 0 then ps else - let idopt = Some (Pos.none "y") in + let idopt k = Some (Pos.none (Format.sprintf "y%d" k)) in let rec mk_idopts acc k = - if k <= 0 then acc else mk_idopts (idopt::acc) (k-1) in + if k <= 0 then acc else mk_idopts (idopt(n-k)::acc) (k-1) in let t = P.abst_list (mk_idopts [] n) P.wild in let p = new_problem() in tac_refine pos ps gt gs p (scope t) @@ -227,8 +227,22 @@ let handle : List.iter (Option.iter check) idopts; (* Check that the given identifiers are pairwise distinct. *) Syntax.check_distinct idopts; - let p = new_problem() in - tac_refine pos ps gt gs p (scope (P.abst_list idopts P.wild)) + let p = new_problem() and t = P.abst_list idopts P.wild in + let ps = tac_refine pos ps gt gs p (scope t) in + (* Rename assumed variables. *) + begin match ps.proof_goals with + | Typ gt::gs -> + let rec rename env idopts = + match env, idopts with + | x::env, None::idopts -> x::rename env idopts + | (_,v)::env, Some n::idopts -> (n.elt,v)::rename env idopts + | env, [] -> env + | [], _ -> assert false + in + let goal_hyps = rename gt.goal_hyps (List.rev idopts) in + {ps with proof_goals = Typ{gt with goal_hyps}::gs} + | _ -> assert false + end | P_tac_generalize {elt=id; pos=idpos} -> (* From a goal [e1,id:a,e2 ⊢ ?[e1,id,e2] : u], generate a new goal [e1 ⊢ ?m[e1] : Π id:a, Π e2, u], and refine [?[e]] with [?m[e1] id e2]. *) @@ -265,7 +279,7 @@ let handle : let m1 = LibMeta.fresh p (Env.to_prod env bt) n in (* Refine the focused goal. *) let v = new_tvar id.elt in - let env' = Env.add v bt None env in + let env' = Env.add id.elt v bt None env in let m2 = LibMeta.fresh p (Env.to_prod env' (lift gt.goal_type)) (n+1) in @@ -299,7 +313,7 @@ let handle : tac_refine pos ps gt gs p (Rewrite.rewrite ss p pos gt l2r pat (scope eq)) | P_tac_sym -> - let cfg = Rewrite.get_eq_config ss pos in + (*let cfg = Rewrite.get_eq_config ss pos in let (a,l,r), vs = Rewrite.get_eq_data cfg pos gt.goal_type in let n = Array.length vs in (* We first do [n] times the [assume] tactic. *) @@ -311,6 +325,23 @@ let handle : if n = 0 then a,l,r else fst (Rewrite.get_eq_data cfg pos gt.goal_type) in + let p = new_problem() in + let prf = + let mt = + mk_Appl(mk_Symb cfg.symb_P, + add_args (mk_Symb cfg.symb_eq) [a; r; l]) in + let meta_term = LibMeta.make p (Env.to_ctxt gt.goal_hyps) mt in + (* The proofterm is [eqind a r l M (λx,eq a l x) (refl a l)]. *) + Rewrite.swap cfg a r l meta_term + in + tac_refine pos ps gt gs p prf*) + let cfg = Rewrite.get_eq_config ss pos in + let (a,l,r), vs = Rewrite.get_eq_data cfg pos gt.goal_type in + let n = Array.length vs in + if n > 0 then fatal pos "Not an equality"; + (* We then apply symmetry. *) + begin match ps.proof_goals with + | Typ gt::gs -> let p = new_problem() in let prf = let mt = diff --git a/src/handle/why3_tactic.ml b/src/handle/why3_tactic.ml index 7bdd08f51..ebb51f841 100644 --- a/src/handle/why3_tactic.ml +++ b/src/handle/why3_tactic.ml @@ -183,19 +183,19 @@ let translate_term : config -> cnst_table -> TyTable.t -> term -> | (Symb(s), [t]) when s == cfg.symb_P -> Some (translate_prop tbl ty_tbl t) | _ -> None -(** [encode ss pos hs g] translates the hypotheses [hs] and the goal [g] +(** [encode ss pos env g] translates the environment [env] and the goal [g] into Why3 terms, to construct a Why3 task. *) let encode : Sig_state.t -> Pos.popt -> Env.env -> term -> Why3.Task.task = - fun ss pos hs g -> + fun ss pos env g -> let cfg = get_config ss pos in - let (constants, types, hypothesis) = + let (constants, types, hyps) = let translate_hyp (tbl,ty_tbl, map) (name, (_, hyp, _)) = match translate_term cfg tbl ty_tbl (Bindlib.unbox hyp) with | Some(tbl, ty_tbl, why3_hyp) -> (tbl, ty_tbl, StrMap.add name why3_hyp map) | None -> (tbl, ty_tbl , map) in - List.fold_left translate_hyp ([], TyTable.empty, StrMap.empty) hs + List.fold_left translate_hyp ([], TyTable.empty, StrMap.empty) env in (* Translate the goal term. *) let (tbl, ty_tbl, why3_term) = @@ -218,7 +218,7 @@ let encode : Sig_state.t -> Pos.popt -> Env.env -> term -> Why3.Task.task = let axiom = Why3.Decl.create_prsymbol (Why3.Ident.id_fresh name) in Why3.Task.add_prop_decl tsk Why3.Decl.Paxiom axiom t in - let tsk = StrMap.fold fn hypothesis tsk in + let tsk = StrMap.fold fn hyps tsk in (* Add the goal itself. *) let goal = Why3.Decl.create_prsymbol (Why3.Ident.id_fresh "main_goal") in (* Return the task that contains the encoded lambdapi formula in Why3. *) @@ -262,20 +262,20 @@ let run_task : Why3.Task.task -> Pos.popt -> string -> bool = let call = Why3.Driver.prove_task ~limit ~command driver tsk in Why3.Call_provers.((wait_on_call call).pr_answer = Valid) -(** [handle ss pos prover_name g] runs the Why3 prover corresponding - to the name [prover_name] (if given or a default one otherwise) - on the goal [g]. - If the prover succeeded to prove the goal, then this is reflected by a new - axiom that is added to signature [ss]. *) +(** [handle ss pos prover_name g] returns a proof term for [g] by calling + [prover_name]. It runs the Why3 prover corresponding to the name + [prover_name] (if given or a default one otherwise) on the goal [g]. If the + prover succeeds to prove the goal, then this is reflected by a new axiom + that is added to the signature [ss]. *) let handle : Sig_state.t -> Pos.popt -> string option -> Proof.goal_typ -> term = - fun ss pos prover_name {goal_meta = m; goal_hyps = hyps; goal_type = trm} -> + fun ss pos prover_name {goal_meta = m; goal_hyps = env; goal_type = trm} -> (* Get the name of the prover. *) let prover_name = Option.get !default_prover prover_name in if Logger.log_enabled () then log_why3 "running with prover \"%s\"" prover_name; (* Encode the goal in Why3. *) - let tsk = encode ss pos hyps trm in + let tsk = encode ss pos env trm in (* Run the task with the prover named [prover_name]. *) if not (run_task tsk pos prover_name) then fatal pos "\"%s\" did not find a proof" prover_name; @@ -289,6 +289,6 @@ let handle : if Logger.log_enabled () then log_why3 "axiom %a created" uid axiom_name; (* Return the variable terms of each item in the context. *) - let terms = List.rev_map (fun (_, (x, _, _)) -> mk_Vari x) hyps in + let terms = List.rev_map (fun (_, (x, _, _)) -> mk_Vari x) env in (* Apply the instance of the axiom with context. *) add_args (mk_Symb a) terms diff --git a/src/lplib/extra.ml b/src/lplib/extra.ml index 0296f5ffd..e9e40a41e 100644 --- a/src/lplib/extra.ml +++ b/src/lplib/extra.ml @@ -26,7 +26,7 @@ let get_safe_prefix : string -> StrSet.t -> string = else acc in let res = StrSet.fold f set (-1) in - head ^ string_of_int (res + 1) + if res = -1 then head else head ^ string_of_int (res + 1) (** [time f x] times the application of [f] to [x], and returns the evaluation time in seconds together with the result of the application. *) diff --git a/src/parsing/scope.ml b/src/parsing/scope.ml index 64ba2c7a2..b1b40b5fb 100644 --- a/src/parsing/scope.ml +++ b/src/parsing/scope.ml @@ -7,6 +7,8 @@ open Common open Error open Pos open Debug open Syntax open Core open Term open Env open Sig_state open Print +let term = Raw.term + (** Logging function for term scoping. *) let log_scop = Logger.make 'o' "scop" "term scoping" let log_scop = log_scop.pp @@ -76,7 +78,7 @@ type mode = | M_RHS of { m_rhs_prv : bool (** True if private symbols are allowed. *) - ; m_rhs_data : (string, tevar) Hashtbl.t + ; m_rhs_data : (string, int) Hashtbl.t (** Environment for variables that we know to be bound in the RHS. *) ; mutable m_rhs_new_metas : problem (** Metavariables generated during scoping. *) } @@ -87,13 +89,13 @@ type mode = variables only in the RHS. It is initialised to the number of (distinct) variables in the LHS and incremented each time a variable of the RHS that was not in the LHS is scoped. *) - ; mutable m_urhs_xvars : (string * tevar) list + ; m_urhs_xvars : (string, int) Hashtbl.t (** Variables scoped that were not in the LHS. This field is only used in unification rules and is updated imperatively for each new variable scoped. A couple [(n, v)] is the name of the variable with the variable itself. The name is needed to ensure that two variables with the same name are scoped as the same variable. *) - ; m_urhs_data : (string, tevar) Hashtbl.t } + ; m_urhs_data : (string, int) Hashtbl.t } (** Scoping mode for unification rule right-hand sides. During scoping, we always have [m_urhs_vars_nb = m_lhs_size + length m_urhs_xvars]. *) @@ -128,7 +130,7 @@ let fresh_patt : lhs_data -> string option -> tbox array -> tbox = Hashtbl.add data.m_lhs_indices name i; Hashtbl.add data.m_lhs_names i name; i in - _Patt (Some i) (string_of_int i) ts + _Patt (Some i) name ts | None -> let i = fresh_index () in _Patt (Some i) (string_of_int i) ts @@ -193,7 +195,7 @@ and scope_parsed : ?typ:bool -> int -> mode -> sig_state -> env -> p_term -> tbox = fun ?(typ=false) k md ss env t -> if Logger.log_enabled () then - log_scop "%a%a@ %a" D.depth k pp_env env Pretty.term t; + log_scop "%a<= %a@ %a" D.depth k pp_env env Pretty.term t; (* Extract the spine. *) let p_head, args = Syntax.p_get_args t in (* Check that LHS pattern variables are applied to no argument. *) @@ -233,7 +235,7 @@ and scope_parsed : (* Scope and insert the (implicit) arguments. *) add_impl k md ss env t.pos h impl args |> D.log_and_return - (fun e -> log_scop "%agot %a" D.depth k term (Bindlib.unbox e)) + (fun e -> log_scop "%a=> %a" D.depth k term (Bindlib.unbox e)) (** [add_impl md ss env loc h impl args] scopes [args] and returns the application of [h] to the scoped arguments. [impl] is a boolean list @@ -315,7 +317,7 @@ and scope_binder : ?typ:bool -> int -> mode -> sig_state -> having an integer suffix with leading zeros \ are not allowed for bound variable names." id; let v = new_tvar id in - let env = Env.add v a None env in + let env = Env.add id v a None env in let t = aux env idopts in cons a (Bindlib.bind_var v t) in aux env idopts @@ -351,14 +353,9 @@ and scope_head : end | (P_Wild, M_URHS(data)) -> - let x = - let name = string_of_int data.m_urhs_vars_nb in - let x = new_tevar name in - data.m_urhs_vars_nb <- data.m_urhs_vars_nb + 1; - data.m_urhs_xvars <- (name, x) :: data.m_urhs_xvars; - x - in - _TEnv (_TE_Vari x) (Env.to_tbox env) + let i = data.m_urhs_vars_nb in + data.m_urhs_vars_nb <- data.m_urhs_vars_nb + 1; + _Patt (Some i) "_" (Env.to_tbox env) | (P_Wild, M_LHS data) -> fresh_patt data None (Env.to_tbox env) | (P_Wild, M_Patt) -> _Wild | (P_Wild, (M_RHS _|M_Term _)) -> _Plac typ @@ -412,7 +409,7 @@ and scope_head : end; fresh_patt d (Option.map (fun id -> id.elt) id) ts | (P_Patt(id,ts), M_URHS(r)) -> - let x = + let i = match id with | None -> fatal t.pos "Wildcard pattern not allowed in a URHS." | Some {elt=id;_} -> @@ -420,22 +417,22 @@ and scope_head : try Hashtbl.find r.m_urhs_data id with Not_found -> (* Search in variables already declared in RHS. *) - try List.assoc id r.m_urhs_xvars + try Hashtbl.find r.m_urhs_xvars id with Not_found -> - let name = string_of_int r.m_urhs_vars_nb in - let x = new_tevar name in + let i = r.m_urhs_vars_nb in + Hashtbl.add r.m_urhs_xvars id i; r.m_urhs_vars_nb <- r.m_urhs_vars_nb + 1; - r.m_urhs_xvars <- (id, x) :: r.m_urhs_xvars; - x + i in let ts = match ts with | None -> [||] (* $M stands for $M[] *) | Some ts -> Array.map (scope (k+1) md ss env) ts in - _TEnv (_TE_Vari x) ts + let name = match id with Some {elt;_} -> elt | None -> assert false in + _Patt (Some i) name ts | (P_Patt(id,ts), M_RHS(r)) -> - let x = + let i = match id with | None -> fatal t.pos "Wildcard pattern not allowed in a RHS." | Some(id) -> @@ -448,7 +445,8 @@ and scope_head : | None -> [||] (* $M stands for $M[] *) | Some ts -> Array.map (scope (k+1) md ss env) ts in - _TEnv (_TE_Vari x) ts + let name = match id with Some {elt;_} -> elt | None -> assert false in + _Patt (Some i) name ts | (P_Patt(_,_), _) -> fatal t.pos "Pattern variables are only allowed in rewriting rules." @@ -472,7 +470,7 @@ and scope_head : let a = scope_binder ~typ:true (k+1) md ss _Prod env xs a in let t = scope_binder (k+1) md ss _Abst env xs (Some(t)) in let v = new_tvar x.elt in - let u = scope ~typ (k+1) md ss (Env.add v a (Some(t)) env) u in + let u = scope ~typ (k+1) md ss (Env.add x.elt v a (Some(t)) env) u in if not (Bindlib.occur v u) then wrn x.pos "Useless let-binding (%s is not bound)." x.elt; _LLet a t (Bindlib.bind_var v u) @@ -483,8 +481,8 @@ and scope_head : (* Evade the addition of implicit arguments inside the wrap *) | (P_Wrap ({ elt = (P_Iden _ | P_Abst _); _ } as id), _) -> - scope_head ~typ (k+1) md ss env id - | (P_Wrap t, _) -> scope ~typ (k+1) md ss env t + scope_head ~typ k md ss env id + | (P_Wrap t, _) -> scope ~typ k md ss env t | (P_Expl(_), _) -> fatal t.pos "Explicit argument not allowed here." @@ -557,40 +555,10 @@ let patt_vars : p_term -> (string * int) list * string list = in patt_vars ([],[]) -(** Representation of a rewriting rule prior to SR-checking. *) -type pre_rule = - { pr_sym : sym - (** Head symbol of the LHS. *) - ; pr_lhs : term list - (** Arguments of the LHS. *) - ; pr_vars : term_env OldBindlib.mvar - (** Pattern variables that appear in the RHS. The last [pr_xvars_nb] - variables do not appear in the LHS. *) - ; pr_rhs : term OldBindlib.box - (** Body of the RHS, should only be unboxed once. *) - ; pr_names : (int, string) Hashtbl.t - (** Gives the original name (if any) of pattern variable at given index. *) - ; pr_arities : int array - (** Gives the arity of all the pattern variables in field [pr_vars]. *) - ; pr_xvars_nb : int - (** Number of variables that appear in the RHS but not in the LHS. *) } - -(** [rule_of_pre_rule r] converts a pre-rewrite rule into a rewrite rule. *) -let rule_of_pre_rule : pre_rule loc -> rule = - fun { elt = pr; pos = rule_pos } -> - let {pr_lhs; pr_vars; pr_rhs; pr_arities; pr_xvars_nb; _} = pr in - { lhs = pr_lhs - ; rhs = OldBindlib.(unbox (bind_mvar pr_vars pr_rhs)) - ; arity = List.length pr_lhs - ; arities = pr_arities - ; vars = pr_vars - ; xvars_nb = pr_xvars_nb - ; rule_pos } - (** [scope_rule ur ss r] turns a parser-level rewriting rule [r], or a unification rule if [ur] is true, into a pre-rewriting rule. *) -let scope_rule : bool -> sig_state -> p_rule -> pre_rule loc = - fun ur ss { elt = (p_lhs, p_rhs); pos } -> +let scope_rule : bool -> sig_state -> p_rule -> sym_rule = + fun ur ss { elt = (p_lhs, p_rhs); pos = rule_pos } -> (* Compute the set of pattern variables on both sides. *) let (pvs_lhs, nl) = patt_vars p_lhs in (* NOTE to reject non-left-linear rules check [nl = []] here. *) @@ -605,7 +573,7 @@ let scope_rule : bool -> sig_state -> p_rule -> pre_rule loc = in List.iter check_arity pvs_rhs; (* Scope the LHS and get the reserved index for named pattern variables. *) - let (pr_lhs, lhs_indices, lhs_arities, pr_names, lhs_size) = + let (lhs, lhs_indices, lhs_arities, vars_nb) = let mode = M_LHS{ m_lhs_prv = is_private (get_root ss [] p_lhs) ; m_lhs_indices = Hashtbl.create 7 @@ -614,16 +582,23 @@ let scope_rule : bool -> sig_state -> p_rule -> pre_rule loc = ; m_lhs_size = 0 ; m_lhs_in_env = nl @ List.map fst pvs_rhs } in - let pr_lhs = scope 0 mode ss Env.empty p_lhs in + let lhs = scope 0 mode ss Env.empty p_lhs in match mode with - | M_LHS{ m_lhs_indices; m_lhs_names; m_lhs_size; m_lhs_arities; _} -> - (Bindlib.unbox pr_lhs, m_lhs_indices, m_lhs_arities, m_lhs_names, - m_lhs_size) - | _ -> assert false + | M_LHS{ m_lhs_indices; m_lhs_size; m_lhs_arities; m_lhs_names; + m_lhs_in_env; _ } -> let open D in + if Logger.log_enabled() then + log_scop "@[lhs_size %d@ lhs_indices %a@ lhs_arities %a\ + @ lhs_names %a@ lhs_in_env %a@]" m_lhs_size + (hashtbl string int) m_lhs_indices + (hashtbl int int) m_lhs_arities + (hashtbl int string) m_lhs_names + (list string) m_lhs_in_env; + (lhs, m_lhs_indices, m_lhs_arities, m_lhs_size) + | _ -> assert false in (* Check the head symbol and build the actual LHS. *) - let (pr_sym, pr_lhs) = - let (h, args) = get_args pr_lhs in + let (sym, lhs) = + let (h, args) = get_args lhs in match h with | Symb(s) -> if is_constant s then fatal p_lhs.pos "Constant LHS head symbol."; @@ -632,54 +607,32 @@ let scope_rule : bool -> sig_state -> p_rule -> pre_rule loc = (s, args) | _ -> fatal p_lhs.pos "No head symbol in LHS." in + if Timed.(!(sym.sym_def)) <> None then + fatal rule_pos "No rewriting rule can be given on a defined symbol."; (* Create the pattern variables that can be bound in the RHS. *) - let pr_vars = - Array.init lhs_size (fun i -> new_tevar (string_of_int i)) in let mode = - let htbl_vars = Hashtbl.create (Hashtbl.length lhs_indices) in - let fn k i = Hashtbl.add htbl_vars k pr_vars.(i) in - Hashtbl.iter fn lhs_indices; if ur then - M_URHS{ m_urhs_data = htbl_vars ; m_urhs_vars_nb = Array.length pr_vars - ; m_urhs_xvars = [] } + M_URHS{ m_urhs_data = lhs_indices + ; m_urhs_vars_nb = vars_nb + ; m_urhs_xvars = Hashtbl.create 7 } else - M_RHS{ m_rhs_prv = is_private pr_sym; m_rhs_data = htbl_vars; - m_rhs_new_metas = new_problem() } + M_RHS{ m_rhs_prv = is_private sym + ; m_rhs_data = lhs_indices + ; m_rhs_new_metas = new_problem() } in - let pr_rhs = old_lift (scope 0 mode ss Env.empty p_rhs) in - let prerule = - (* We put everything together to build the pre-rule. *) - let pr_arities = - let fn i = - try Hashtbl.find lhs_arities i - with Not_found -> assert false (* Unreachable. *) - in - Array.init lhs_size fn - in - if ur then (* Unification rule. *) - (* We scope the RHS and retrieve variables not occurring in the LHS. *) - let xvars = - match mode with - | M_URHS{m_urhs_xvars;_} -> m_urhs_xvars - | _ -> assert false (* Guarded by the [if ur] *) - in - (* Add RHS-only variables to [pr_vars] and get index of the first - one. *) - let (pr_vars, pr_xvars_nb) = - (* If there is no variable introduced in RHS, do nothing (typically - while scoping regular rewriting rules.) *) - if Stdlib.(xvars = []) then (pr_vars, 0) else - let xvars = Array.of_list (List.map snd xvars) in - (Array.append pr_vars xvars, Array.length xvars) - in - (* We put everything together to build the pre-rule. *) - { pr_sym ; pr_lhs ; pr_vars ; pr_rhs ; pr_arities - ; pr_names ; pr_xvars_nb } - else (* Rewrite rule. *) - { pr_sym ; pr_lhs ; pr_vars ; pr_rhs ; pr_arities - ; pr_names ; pr_xvars_nb=0 } + let rhs = scope 0 mode ss Env.empty p_rhs in + let arities = + let f i = try Hashtbl.find lhs_arities i with Not_found -> assert false in + Array.init vars_nb f + in + let xvars_nb = + match mode with + | M_URHS{m_urhs_vars_nb; _} -> m_urhs_vars_nb - vars_nb + | _ -> 0 in - Pos.make pos prerule + let arity = List.length lhs in + let r = {lhs; rhs; arity; arities; vars_nb; xvars_nb; rule_pos} in + (sym,r) (** [scope_pattern ss env t] turns a parser-level term [t] into an actual term that will correspond to selection pattern (rewrite tactic). *) diff --git a/src/parsing/scope.mli b/src/parsing/scope.mli index 01b654d10..47edf423e 100644 --- a/src/parsing/scope.mli +++ b/src/parsing/scope.mli @@ -4,7 +4,6 @@ open Core open Sig_state open Term open Env open Syntax -open Common open Pos (** [scope ~typ ~mok prv expo ss env p t] turns a pterm [t] into a term in the signature state [ss] and environment [env] (for bound @@ -18,30 +17,9 @@ val scope_term : ?mok:(int -> meta option) -> bool -> sig_state -> env -> p_term -> term -(** Representation of a rewriting rule prior to SR-checking. *) -type pre_rule = - { pr_sym : sym - (** Head symbol of the LHS. *) - ; pr_lhs : term list - (** Arguments of the LHS. *) - ; pr_vars : term_env OldBindlib.mvar - (** Pattern variables that appear in the RHS. The last [pr_xvars_nb] - variables do not appear in the LHS. *) - ; pr_rhs : term OldBindlib.box - (** Body of the RHS, should only be unboxed once. *) - ; pr_names : (int, string) Hashtbl.t - (** Gives the original name (if any) of pattern variable at given index. *) - ; pr_arities : int array - (** Gives the arity of all the pattern variables in field [pr_vars]. *) - ; pr_xvars_nb : int - (** Number of variables that appear in the RHS but not in the LHS. *) } - -(** [rule_of_pre_rule r] converts a pre-rewrite rule into a rewrite rule. *) -val rule_of_pre_rule : pre_rule loc -> rule - (** [scope_rule ur ss r] turns a parser-level rewriting rule [r], or a unification rule if [ur] is true, into a pre-rewriting rule. *) -val scope_rule : bool -> sig_state -> p_rule -> pre_rule loc +val scope_rule : bool -> sig_state -> p_rule -> sym_rule (** [scope_rw_patt ss env t] turns a parser-level rewrite tactic specification [s] into an actual rewrite specification (possibly containing variables of diff --git a/src/tool/lcr.ml b/src/tool/lcr.ml index 5d693fc3b..b3ed8597d 100644 --- a/src/tool/lcr.ml +++ b/src/tool/lcr.ml @@ -46,9 +46,8 @@ let is_definable : sym -> bool = fun s -> && not s.sym_opaq (** [rule_of_def s d] creates the rule [s --> d]. *) -let rule_of_def : sym -> term -> rule = fun s d -> - let rhs = OldBindlib.unbox (OldBindlib.bind_mvar [||] (OldBindlib.box d)) in - {lhs=[]; rhs; arity=0; arities=[||]; vars=[||]; xvars_nb=0; +let rule_of_def : sym -> term -> rule = fun s rhs -> + {lhs=[]; rhs; arity=0; arities=[||]; vars_nb=0; xvars_nb=0; rule_pos=s.sym_pos} (** [replace t p u] replaces the subterm of [t] at position [p] by [u]. *) @@ -452,13 +451,11 @@ let typability_constraints : Pos.popt -> term -> subs option = fun pos t -> | _ -> t in (* Function converting a pair of terms into a rule, if possible. *) - let rule_of_terms : term -> term -> sym_rule option = fun l r -> + let rule_of_terms : term -> term -> sym_rule option = fun l rhs -> match get_args_len l with | Symb s, lhs, arity -> - let vars = [||] and rule_pos = Some (new_rule_id()) in - let rhs = OldBindlib.unbox - (OldBindlib.bind_mvar vars (OldBindlib.box r)) in - let r = {lhs; rhs; arity; arities=[||]; vars; xvars_nb=0; rule_pos} in + let r = {lhs; rhs; arity; arities=[||]; vars_nb=0; xvars_nb=0; + rule_pos=Some (new_rule_id())} in Some (s,r) | _ -> None in diff --git a/src/tool/sr.ml b/src/tool/sr.ml index f78bebbc4..f7e214ba7 100644 --- a/src/tool/sr.ml +++ b/src/tool/sr.ml @@ -4,7 +4,6 @@ open Lplib open Timed open Common open Error open Core open Term open Print -open Parsing (** Logging function for typing. *) let log_subj = Logger.make 's' "subj" "subject-reduction" @@ -38,82 +37,42 @@ let build_meta_type : problem -> int -> term = fun p k -> done; Bindlib.unbox !res -(** [patt_to_tenv vars t] converts pattern variables of [t] into corresponding - term environment variables of [vars]. The index [i] in [Patt(Some(i),_,_)] - indicates the index of the corresponding variable in [vars]. *) -let patt_to_tenv : tevar array -> term -> tbox = fun vars -> - let get_te i = - match i with - | None -> assert false (* Cannot appear in LHS. *) - | Some(i) -> try vars.(i) with Invalid_argument(_) -> assert false - in - let rec trans t = - match unfold t with - | Vari(x) -> _Vari x - | Symb(s) -> _Symb s - | Abst(a,b) -> let (x, b) = Bindlib.unbind b in - _Abst (trans a) (Bindlib.bind_var x (trans b)) - | Appl(t,u) -> _Appl (trans t) (trans u) - | Patt(i,_,a) -> _TEnv (_TE_Vari (get_te i)) (Array.map trans a) - | Db _ -> assert false - | Type -> assert false (* Cannot appear in LHS. *) - | Kind -> assert false (* Cannot appear in LHS. *) - | Prod(_,_) -> assert false (* Cannot appear in LHS. *) - | LLet(_,_,_) -> assert false (* Cannot appear in LHS. *) - | Plac _ -> assert false (* Cannot appear in LHS. *) - | Meta(_,_) -> assert false (* Cannot appear in LHS. *) - | TEnv(_,_) -> assert false (* Cannot appear in LHS. *) - | Wild -> assert false (* Cannot appear in LHS. *) - | TRef(_) -> assert false (* Cannot appear in LHS. *) - in - trans - -(** Mapping of pattern variable names to their reserved index. *) -type index_tbl = (string, int) Hashtbl.t - -(** [symb_to_tenv pr syms htbl t] builds a RHS for the pre-rule [pr]. The term - [t] is expected to be a version of the RHS of [pr] whose term environments - have been replaced by function symbols of [syms]. This function builds the - reverse transformation, replacing symbols by the term environment variable - they stand for. Here, [htbl] should give the index in the RHS environment - for the symbols of [syms] that have corresponding [term_env] variable. The - pre-rule [pr] is provided to give access to these variables and also their - expected arities. *) -let symb_to_tenv - : Scope.pre_rule Pos.loc -> sym list -> index_tbl -> term -> tbox = - fun {elt={pr_vars=vars;pr_arities=arities;_};pos} syms htbl t -> - let rec symb_to_tenv t = +(** [symb_to_patt pos map t] replaces in [t] every symbol [f] such that + [SymMap.find f map = Some i] by [Patt(i,_,_)]. *) +let symb_to_patt : Pos.popt -> (int * int) option SymMap.t -> term -> tbox = + fun pos map -> + let rec symb_to_patt t = let (h, ts) = get_args t in - let ts = List.map symb_to_tenv ts in + let ts = List.map symb_to_patt ts in let (h, ts) = match h with - | Db _ -> assert false - | Symb(f) when List.memq f syms -> - let i = - try Hashtbl.find htbl f.sym_name with Not_found -> + | Symb(f) -> + begin match SymMap.find_opt f map with + | Some None -> (* A symbol may also come from a metavariable that appeared in the type of a metavariable that was replaced by a symbol. We do not have concrete examples of that happening yet. *) fatal pos "Introduced symbol [%s] cannot be removed." f.sym_name - in - let (ts1, ts2) = List.cut ts arities.(i) in - (_TEnv (_TE_Vari vars.(i)) (Array.of_list ts1), ts2) - | Symb(s) -> (_Symb s, ts) + | Some (Some (i, arity)) -> + let (ts1, ts2) = List.cut ts arity in + (_Patt (Some i) (string_of_int i) (Array.of_list ts1), ts2) + | None -> (_Symb f, ts) + end | Vari(x) -> (_Vari x, ts) | Type -> (_Type , ts) | Kind -> (_Kind , ts) | Abst(a,b) -> let (x, t) = Bindlib.unbind b in - let b = Bindlib.bind_var x (symb_to_tenv t) in - (_Abst (symb_to_tenv a) b, ts) + let b = Bindlib.bind_var x (symb_to_patt t) in + (_Abst (symb_to_patt a) b, ts) | Prod(a,b) -> let (x, t) = Bindlib.unbind b in - let b = Bindlib.bind_var x (symb_to_tenv t) in - (_Prod (symb_to_tenv a) b, ts) + let b = Bindlib.bind_var x (symb_to_patt t) in + (_Prod (symb_to_patt a) b, ts) | LLet(a,t,b) -> let (x, u) = Bindlib.unbind b in - let b = Bindlib.bind_var x (symb_to_tenv u) in - (_LLet (symb_to_tenv a) (symb_to_tenv t) b, ts) + let b = Bindlib.bind_var x (symb_to_patt u) in + (_LLet (symb_to_patt a) (symb_to_patt t) b, ts) | Meta(_,_) -> fatal pos "A metavariable could not be instantiated in the RHS." | Plac _ -> @@ -123,55 +82,37 @@ let symb_to_tenv | Patt(_,_,_) -> assert false (* Cannot appear in RHS. *) | Wild -> assert false (* Cannot appear in RHS. *) | TRef(_) -> assert false (* Cannot appear in RHS. *) + | Db _ -> assert false in _Appl_list h ts in - symb_to_tenv t + symb_to_patt -(** [check_rule r] checks whether the pre-rule [r] is well-typed in - signature state [ss] and then construct the corresponding rule. Note that - [Fatal] is raised in case of error. *) -let check_rule : Scope.pre_rule Pos.loc -> rule = fun ({pos; elt} as pr) -> - let Scope.{pr_sym = s; pr_lhs = lhs; pr_vars = vars; pr_rhs; - pr_arities = arities; pr_xvars_nb; _} = elt in +(** [check_rule r] checks whether the rule [r] preserves typing. *) +let check_rule : Pos.popt -> sym_rule -> sym_rule = + fun pos ((s, ({lhs; rhs; arities; vars_nb; xvars_nb; _} as r)) as sr) -> (* Check that the variables of the RHS are in the LHS. *) - if pr_xvars_nb <> 0 then - (let xvars = Array.drop (Array.length vars - pr_xvars_nb) vars in - fatal pos "Unknown pattern variables: %a" (Array.pp tevar ",") xvars); - let arity = List.length lhs in - if Logger.log_enabled () then - begin - (* The unboxing here could be harmful since it leads to [pr_rhs] being - unboxed twice. However things should be fine here since the result is - only used for printing. *) - let rhs = OldBindlib.(unbox (bind_mvar vars pr_rhs)) in - let naive_rule = - {lhs; rhs; arity; arities; vars; xvars_nb = 0; rule_pos = pos} in - log_subj (Color.red "%a") sym_rule (s, naive_rule); - end; - (* Replace [Patt] nodes of LHS with corresponding elements of [vars]. *) - let lhs_vars = old_lift - (_Appl_Symb s (List.map (patt_to_tenv vars) lhs)) in + assert (xvars_nb = 0); + if Logger.log_enabled () then log_subj (Color.red "%a") sym_rule sr; + (* Create a metavariable for each LHS pattern variable. *) let p = new_problem() in let metas = - let f i _ = - let arity = arities.(i) in - (*FIXME: build_meta_type should take a sort as argument as some pattern - variables are types and thus of sort KIND! *) - LibMeta.fresh p (build_meta_type p arity) arity - in Array.mapi f vars + Array.init vars_nb + (fun i -> + let arity = arities.(i) in + (*FIXME: build_meta_type should take a sort as argument as some + pattern variables are types and thus of sort KIND! *) + LibMeta.fresh p (build_meta_type p arity) arity) in - (* Substitute them in the LHS and in the RHS. *) - let lhs_with_metas, rhs_with_metas = - let lhs_rhs = OldBindlib.box_pair lhs_vars pr_rhs in - let b = OldBindlib.unbox (OldBindlib.bind_mvar vars lhs_rhs) in - let meta_to_tenv m = - let xs = Array.init m.meta_arity (new_tvar_ind "x") in - let ts = Array.map _Vari xs in - TE_Some(Bindlib.unbox (Bindlib.bind_mvar xs (_Meta m ts))) - in - OldBindlib.msubst b (Array.map meta_to_tenv metas) + (* Replace Patt's by Meta's. *) + let f m = + let xs = Array.init m.meta_arity (new_tvar_ind "x") in + let ts = Array.map _Vari xs in + Some(Bindlib.unbox (Bindlib.bind_mvar xs (_Meta m ts))) in + let su = Array.map f metas in + let lhs_with_metas = subst_patt su (add_args (mk_Symb s) lhs) + and rhs_with_metas = subst_patt su rhs in if Logger.log_enabled () then log_subj "replace pattern variables by metavariables:@ %a ↪ %a" term lhs_with_metas term rhs_with_metas; @@ -179,36 +120,33 @@ let check_rule : Scope.pre_rule Pos.loc -> rule = fun ({pos; elt} as pr) -> match Infer.infer_noexn p [] lhs_with_metas with | None -> fatal pos "The LHS is not typable." | Some (lhs_with_metas, ty_lhs) -> - (* Try to simplify constraints. Don't check typing when instantiating - a metavariable. *) + (* Try to simplify constraints. *) if not (Unif.solve_noexn ~type_check:false p) then fatal pos "The LHS is not typable."; let norm_constr (c,t,u) = (c, Eval.snf [] t, Eval.snf [] u) in let lhs_constrs = List.map norm_constr !p.unsolved in if Logger.log_enabled () then - log_subj "@[LHS type: %a@ LHS constraints: %a@ %a ↪ %a@]" + log_subj "@[LHS type: %a@ LHS constraints: %a@ rule: %a ↪ %a@]" term ty_lhs constrs lhs_constrs term lhs_with_metas term rhs_with_metas; - (* We instantiate all the uninstantiated metavariables of the LHS (including - those appearing in the types of these metavariables) using fresh function - symbols. We also keep a list of those symbols. *) - let symbols = - let symbols = Stdlib.ref [] in - let rec instantiate m = + (* Instantiate all uninstantiated metavariables by fresh symbols. *) + (*let symbols = + let symbols = Stdlib.ref SymSet.empty in + let rec instantiate i m = match !(m.meta_value) with | Some _ -> (* Instantiate recursively the meta-variables of the definition. *) let t = mk_Meta(m, Array.make m.meta_arity mk_Kind) in - LibMeta.iter true instantiate [] t + LibMeta.iter true (instantiate None) [] t | None -> (* Instantiate recursively the meta-variables of the type. *) - LibMeta.iter true instantiate [] !(m.meta_type); - (* Instantiation of [m]. *) + LibMeta.iter true (instantiate None) [] !(m.meta_type); + (* Create a new symbol. *) let s = let name = Pos.none @@ Printf.sprintf "$%d" m.meta_key in Term.create_sym (Sign.current_path()) Privat Defin Eager false name !(m.meta_type) [] in - Stdlib.(symbols := s :: !symbols); + Stdlib.(symbols := SymSet.add s !symbols); (* Build a definition for [m]. *) let xs = Array.init m.meta_arity (new_tvar_ind "x") in let s = _Symb s in @@ -217,12 +155,35 @@ let check_rule : Scope.pre_rule Pos.loc -> rule = fun ({pos; elt} as pr) -> in Array.iter instantiate metas; Stdlib.(!symbols) + in*) + let map = Stdlib.ref SymMap.empty + and m2s = Stdlib.ref MetaMap.empty in + let instantiate m = + match !(m.meta_value) with + | Some _ -> assert false + | None -> + let s = + let name = Pos.none @@ Printf.sprintf "$%d" m.meta_key in + Term.create_sym (Sign.current_path()) + Privat Defin Eager false name !(m.meta_type) [] + in + Stdlib.(map := SymMap.add s None !map; m2s := MetaMap.add m s !m2s); + let xs = Array.init m.meta_arity (new_tvar_ind "x") in + let s = _Symb s in + let def = Array.fold_left (fun t x -> _Appl t (_Vari x)) s xs in + m.meta_value := Some(Bindlib.unbox (Bindlib.bind_mvar xs def)) + in + MetaSet.iter instantiate !p.metas; + let f i m = + match MetaMap.find_opt m Stdlib.(!m2s) with + | Some s -> Stdlib.(map := SymMap.add s (Some (i, arities.(i))) !map) + | None -> () in + Array.iteri f metas; if Logger.log_enabled () then log_subj "replace LHS metavariables by function symbols:@ %a ↪ %a" term lhs_with_metas term rhs_with_metas; - (* TODO complete the constraints into a set of rewriting rule on - the function symbols of [symbols]. *) + (* TODO complete the constraints into a set of rewriting rules. *) (* Compute the constraints for the RHS to have the same type as the LHS. *) let p = new_problem() in match Infer.check_noexn p [] rhs_with_metas ty_lhs with @@ -266,14 +227,6 @@ let check_rule : Scope.pre_rule Pos.loc -> rule = fun ({pos; elt} as pr) -> List.iter (fatal_msg "Cannot solve %a@." constr) cs; fatal pos "Unable to prove type preservation." end; - (* We build a map allowing to find a variable index from its key. *) - let htbl : index_tbl = Hashtbl.create (Array.length vars) in - Array.iteri - (fun i m -> Hashtbl.add htbl (Printf.sprintf "$%d" m.meta_key) i) - metas; - (* Replace metavariable symbols by term_env variables, and bind them. *) - let rhs = symb_to_tenv pr symbols htbl rhs_with_metas in - (* TODO environment minimisation ? *) - (* Construct the rule. *) - let rhs = OldBindlib.unbox (OldBindlib.bind_mvar vars (old_lift rhs)) in - { lhs ; rhs ; arity ; arities ; vars; xvars_nb = 0; rule_pos = pos } + (* Replace metavariable symbols by Patt's. *) + let rhs = symb_to_patt pos Stdlib.(!map) rhs_with_metas in + s, {r with rhs} diff --git a/src/tool/sr.mli b/src/tool/sr.mli index 2ebb9e111..434347fda 100644 --- a/src/tool/sr.mli +++ b/src/tool/sr.mli @@ -1,10 +1,9 @@ (** Checking that a rule preserves typing (subject reduction property). *) -open Core +open Core open Term open Common -open Parsing (** [check_rule r] checks whether the pre-rule [r] is well-typed in signature state [ss] and then construct the corresponding rule. Note that [Fatal] is raised in case of error. *) -val check_rule : Scope.pre_rule Pos.loc -> Term.rule +val check_rule : Pos.popt -> sym_rule -> sym_rule diff --git a/src/tool/tree_graphviz.ml b/src/tool/tree_graphviz.ml index cf85cc700..87f14cf97 100644 --- a/src/tool/tree_graphviz.ml +++ b/src/tool/tree_graphviz.ml @@ -52,8 +52,7 @@ let to_dot : Format.formatter -> sym -> unit = fun ppf s -> incr node_count; match t with | Leaf(_,r) -> - let _, rhs = OldBindlib.unmbind r.rhs in - out ppf "@ %d [label=\"%a\"];" !node_count Print.term rhs; + out ppf "@ %d [label=\"%a\"];" !node_count Print.term r.rhs; out ppf "@ %d -- %d [label=<%a>];" father_l !node_count dotterm swon | Node({swap; children; store; abstraction=abs; default; product}) -> diff --git a/tests/OK/rewrite1.lp b/tests/OK/rewrite1.lp index 68507f961..364c83a1b 100644 --- a/tests/OK/rewrite1.lp +++ b/tests/OK/rewrite1.lp @@ -154,8 +154,7 @@ opaque symbol addcomm : Π n m, P (eq nat (add n m) (add m n)) assume n m; refine nat_ind (λ (n:N), eq nat (add n m) (add m n)) _ _ n { // Case Z - simplify; - generalize m; symmetry; refine add0r y } + simplify; symmetry; refine add0r m } { // Case S simplify; assume k ih; diff --git a/tests/regressions/dtrees.expected b/tests/regressions/dtrees.expected index 9d2581dcf..7c06ff7a8 100644 --- a/tests/regressions/dtrees.expected +++ b/tests/regressions/dtrees.expected @@ -25,7 +25,7 @@ graph { 1 -- 2 [label=<*>]; 3 [label="0" shape="box"]; 2 -- 3 [label=<*>]; - 4 [label="$1 ≡ pair $2 $4"]; + 4 [label="$p ≡ pair $f $s"]; 3 -- 4 [label=<*>]; 5 [label="2"]; 0 -- 5 [label=2>]; @@ -33,7 +33,7 @@ graph { 5 -- 6 [label=0>]; 7 [label="0" shape="box"]; 6 -- 7 [label=<*>]; - 8 [label="($0 ≡ z) ; ($1 ≡ z)"]; + 8 [label="($x ≡ z) ; ($y ≡ z)"]; 7 -- 8 [label=<*>]; 9 [label="0" shape="box"]; 0 -- 9 [label=2>]; @@ -41,7 +41,7 @@ graph { 9 -- 10 [label=<*>]; 11 [label="0" shape="box"]; 10 -- 11 [label=<*>]; - 12 [label="$1 ≡ pair $4 $2"]; + 12 [label="$p ≡ pair $f $s"]; 11 -- 12 [label=<*>]; 13 [label="2"]; 0 -- 13 [label=<Πv0>]; @@ -53,7 +53,7 @@ graph { 15 -- 16 [label=<*>]; 17 [label="0" shape="box"]; 16 -- 17 [label=<✓>]; - 18 [label="($0 ≡ T $3) ; (($1 ≡ T $4) ; ($2 ≡ arrow $4 $3))"]; + 18 [label="($b ≡ T $eb) ; (($a ≡ T $ea) ; ($c ≡ arrow $ea $eb))"]; 17 -- 18 [label=<*>]; 19 [label=]; 16 -- 19 [label="!"]; diff --git a/tests/rewriting.ml b/tests/rewriting.ml index 9446249d2..7472d21fc 100644 --- a/tests/rewriting.ml +++ b/tests/rewriting.ml @@ -30,12 +30,12 @@ let sig_state, a = add_sym sig_state "A" let parse_rule s = let r = Parser.Lp.parse_string "rewrite_test rule" s |> Stream.next in let r = match r.elt with Syntax.P_rules [r] -> r | _ -> assert false in - Scope.scope_rule false sig_state r |> Scope.rule_of_pre_rule + Scope.scope_rule false sig_state r let arrow_matching () = (* Matching on a product. *) - let rule = parse_rule "rule C (A → A) ↪ Ok;" in - Sign.add_rule sig_state.signature c rule; + let (c, _) as rule = parse_rule "rule C (A → A) ↪ Ok;" in + Sign.add_rule sig_state.signature rule; Tree.update_dtree c []; let lhs = parse_term "C (A → A)" |> scope_term sig_state in Alcotest.(check bool) @@ -47,8 +47,8 @@ let arrow_matching () = let arrow_matching = Timed.pure_apply arrow_matching let prod_matching () = - let rule = parse_rule "rule C (Π _: _, A) ↪ Ok;" in - Sign.add_rule sig_state.signature c rule; + let (c,_) as rule = parse_rule "rule C (Π _: _, A) ↪ Ok;" in + Sign.add_rule sig_state.signature rule; Tree.update_dtree c []; let lhs = parse_term "C (A → A)" |> scope_term sig_state in Alcotest.(check bool) @@ -60,8 +60,8 @@ let prod_matching = Timed.pure_apply prod_matching let arrow_default () = (* Assert that a product can be considered as a default case. *) - let rule = parse_rule "rule C _ ↪ Ok;" in - Sign.add_rule sig_state.signature c rule; + let (c,_) as rule = parse_rule "rule C _ ↪ Ok;" in + Sign.add_rule sig_state.signature rule; Tree.update_dtree c []; let lhs = parse_term "C (A → A)" |> scope_term sig_state in Alcotest.(check bool) From 7efc5db5087b98423b99f2e99fff775a7ffdcd0a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 10:52:53 +0100 Subject: [PATCH 05/38] remove TEnv --- src/core/ctxt.ml | 1 - src/core/eval.ml | 14 ++--- src/core/infer.ml | 3 +- src/core/libMeta.ml | 1 - src/core/libTerm.ml | 2 - src/core/print.ml | 9 +-- src/core/sign.ml | 9 +-- src/core/term.ml | 126 +++++++----------------------------------- src/core/term.mli | 59 ++------------------ src/export/dk.ml | 12 +--- src/export/hrs.ml | 3 +- src/export/xtc.ml | 9 +-- src/handle/rewrite.ml | 4 +- src/tool/lcr.ml | 21 ++----- src/tool/sr.ml | 5 +- 15 files changed, 51 insertions(+), 227 deletions(-) diff --git a/src/core/ctxt.ml b/src/core/ctxt.ml index e21d620ce..5e4ad36d6 100644 --- a/src/core/ctxt.ml +++ b/src/core/ctxt.ml @@ -81,7 +81,6 @@ let rec unfold : ctxt -> term -> term = fun ctx t -> | None -> t | Some(b) -> unfold ctx (Bindlib.msubst b ts) end - | TEnv(TE_Some(b), ts) -> unfold ctx (Bindlib.msubst b ts) | TRef(r) -> begin match !r with diff --git a/src/core/eval.ml b/src/core/eval.ml index 1e2f90e49..4815e099d 100644 --- a/src/core/eval.ml +++ b/src/core/eval.ml @@ -55,7 +55,6 @@ let snf : (term -> term) -> (term -> term) = fun whnf -> let h = whnf t in if Logger.log_enabled () then log_eval "whnf %a = %a" term t term h; match h with - | Db _ -> assert false | Vari _ | Type | Kind @@ -69,7 +68,7 @@ let snf : (term -> term) -> (term -> term) = fun whnf -> | Meta(m,ts) -> mk_Meta(m, Array.map snf ts) | Patt(i,n,ts) -> mk_Patt(i,n,Array.map snf ts) | Plac _ -> assert false - | TEnv(_,_) -> assert false + | Db _ -> assert false | Wild -> assert false | TRef(_) -> assert false in snf @@ -136,7 +135,7 @@ let eq_modulo : (config -> term -> term) -> config -> term -> term -> bool = | Patt(None,_,_), _ | _, Patt(None,_,_) -> assert false | Patt(Some i,_,ts), Patt(Some j,_,us) -> if i=j then eq cfg (List.add_array2 ts us l) else raise Exit - | TEnv _, _| _, TEnv _ -> assert false + | Db i, Db j -> if i=j then eq cfg l else raise Exit | Kind, Kind | Type, Type -> eq cfg l | Vari x, Vari y -> if Bindlib.eq_vars x y then eq cfg l else raise Exit @@ -153,8 +152,8 @@ let eq_modulo : (config -> term -> term) -> config -> term -> term -> bool = (* cases of failure *) | Kind, _ | _, Kind | Type, _ | _, Type -> raise Exit - | ((Symb f, (Vari _|Meta _|Prod _|Abst _)) - | ((Vari _|Meta _|Prod _|Abst _), Symb f)) when is_constant f -> + | ((Symb f, (Vari _|Meta _|Prod _|Abst _|Db _)) + | ((Vari _|Meta _|Prod _|Abst _|Db _), Symb f)) when is_constant f -> raise Exit | _ -> let a = whnf cfg a and b = whnf cfg b in @@ -163,7 +162,7 @@ let eq_modulo : (config -> term -> term) -> config -> term -> term -> bool = | Patt(None,_,_), _ | _, Patt(None,_,_) -> assert false | Patt(Some i,_,ts), Patt(Some j,_,us) -> if i=j then eq cfg (List.add_array2 ts us l) else raise Exit - | TEnv _, _| _, TEnv _ -> assert false + | Db i, Db j -> if i=j then eq cfg l else raise Exit | Kind, Kind | Type, Type -> eq cfg l | Vari x, Vari y when Bindlib.eq_vars x y -> eq cfg l @@ -410,7 +409,6 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = walk tr stk cursor vars_id id_vars in match t with - | Db _ -> assert false | Symb(s) -> let cons = TC.Symb(s.sym_path, s.sym_name, List.length args) in begin @@ -455,7 +453,7 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = | TRef(_) -> assert false (* Should be reduced by [whnf_stk]. *) | Appl(_) -> assert false (* Should be reduced by [whnf_stk]. *) | LLet(_) -> assert false (* Should be reduced by [whnf_stk]. *) - | TEnv(_) -> assert false (* Should not appear in terms. *) + | Db _ -> assert false | Wild -> assert false (* Should not appear in terms. *) in walk tree stk 0 VarMap.empty IntMap.empty diff --git a/src/core/infer.ml b/src/core/infer.ml index f399c4066..51c92c644 100644 --- a/src/core/infer.ml +++ b/src/core/infer.ml @@ -91,9 +91,8 @@ and force : problem -> octxt -> term -> term -> term * bool = and infer_aux : problem -> octxt -> term -> term * term * bool = fun pb c t -> match unfold t with - | Db _ -> assert false | Patt _ -> assert false - | TEnv _ -> assert false + | Db _ -> assert false | Kind -> assert false | Wild -> assert false | TRef _ -> assert false diff --git a/src/core/libMeta.ml b/src/core/libMeta.ml index 88e3093d4..3b0c2ca6f 100644 --- a/src/core/libMeta.ml +++ b/src/core/libMeta.ml @@ -91,7 +91,6 @@ let iter : bool -> (meta -> unit) -> ctxt -> term -> unit = fun b f c -> match unfold t with | Db _ -> assert false | Patt _ - | TEnv _ | Wild | TRef _ | Type diff --git a/src/core/libTerm.ml b/src/core/libTerm.ml index 146cd41cc..c5126f026 100644 --- a/src/core/libTerm.ml +++ b/src/core/libTerm.ml @@ -51,7 +51,6 @@ let iter : (term -> unit) -> term -> unit = fun action -> | Kind | Symb(_) -> () | Patt(_,_,ts) - | TEnv(_,ts) | Meta(_,ts) -> Array.iter iter ts | Prod(a,b) | Abst(a,b) -> iter a; iter (Bindlib.subst b mk_Kind) @@ -153,7 +152,6 @@ let sym_to_var : tvar StrMap.t -> term -> term = fun map -> | Appl(a,b) -> mk_Appl(to_var a, to_var b) | Meta(m,ts) -> mk_Meta(m, Array.map to_var ts) | Patt _ -> assert false - | TEnv _ -> assert false | TRef _ -> assert false | _ -> t and to_var_binder b = diff --git a/src/core/print.ml b/src/core/print.ml index ee4a54a6a..7c5678bda 100644 --- a/src/core/print.ml +++ b/src/core/print.ml @@ -90,7 +90,6 @@ let sym : sym pp = fun ppf s -> | Some alias -> out ppf "%a.%a" uid alias uid n let var : tvar pp = fun ppf x -> uid ppf (Bindlib.name_of x) -let tevar : tevar pp = fun ppf x -> uid ppf (OldBindlib.name_of x) (** Exception raised when trying to convert a term into a nat. *) exception Not_a_nat @@ -202,13 +201,7 @@ and term : term pp = fun ppf t -> and head wrap ppf t = let env ppf ts = if Array.length ts > 0 then out ppf ".[%a]" (Array.pp func ";") ts in - let term_env ppf te = - match te with - | TE_Vari(x) -> string ppf (OldBindlib.name_of x) - | _ -> assert false - in match unfold t with - | Db _ -> assert false | Appl(_,_) -> assert false (* Application is handled separately, unreachable. *) | Wild -> out ppf "_" @@ -224,7 +217,7 @@ and term : term pp = fun ppf t -> | Meta(m,e) -> out ppf "%a%a" meta m env e | Plac(_) -> out ppf "_" | Patt(_,n,e) -> out ppf "$%a%a" uid n env e - | TEnv(t,e) -> out ppf "$%a%a" term_env t env e + | Db _ -> assert false (* Product and abstraction (only them can be wrapped). *) | Abst(a,b) -> if wrap then out ppf "("; diff --git a/src/core/sign.ml b/src/core/sign.ml index f006aad53..d0dddfac9 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -91,7 +91,6 @@ let link : t -> unit = fun sign -> let link_term mk_Appl = let rec link_term t = match unfold t with - | Db _ -> assert false | Vari _ | Type | Kind -> t @@ -101,7 +100,7 @@ let link : t -> unit = fun sign -> | LLet(a,t,b) -> mk_LLet(link_term a, link_term t, link_binder b) | Appl(a,b) -> mk_Appl(link_term a, link_term b) | Patt(i,n,ts)-> mk_Patt(i, n, Array.map link_term ts) - | TEnv(te,ts) -> mk_TEnv(te, Array.map link_term ts) + | Db _ -> assert false | Meta _ -> assert false | Plac _ -> assert false | Wild -> assert false @@ -174,7 +173,6 @@ let unlink : t -> unit = fun sign -> | Plac _ -> assert false | Wild -> assert false | TRef _ -> assert false - | TEnv(_,ts) -> Array.iter unlink_term ts | Db _ -> assert false | Patt _ | Vari _ @@ -271,7 +269,6 @@ let read : string -> t = fun fname -> in let rec reset_term t = match unfold t with - | Db _ -> assert false | Vari _ | Type | Kind -> () @@ -280,9 +277,9 @@ let read : string -> t = fun fname -> | Abst(a,b) -> reset_term a; reset_binder b | LLet(a,t,b) -> reset_term a; reset_term t; reset_binder b | Appl(a,b) -> reset_term a; reset_term b - | Patt(_,_,ts) - | TEnv(_,ts) -> Array.iter reset_term ts + | Patt(_,_,ts) -> Array.iter reset_term ts | TRef r -> unsafe_reset r; Option.iter reset_term !r + | Db _ -> assert false | Wild -> assert false | Meta _ -> assert false | Plac _ -> assert false diff --git a/src/core/term.ml b/src/core/term.ml index 2e2b75f0a..7d1dc2800 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -11,8 +11,6 @@ open Timed open Lplib open Base open Common open Debug -module OldBindlib = Bindlib - let log_term = Logger.make 'm' "term" "term building" let log_term = log_term.pp @@ -59,15 +57,13 @@ type term = | Appl of term * term (** Term application. *) | Meta of meta * term array (** Metavariable application. *) | Patt of int option * string * term array - (** Pattern variable application (only used in rewriting rules LHS). *) - | TEnv of term_env * term array - (** Term environment (only used in rewriting rules RHS). *) + (** Pattern variable application (only used in rewriting rules). *) + | Db of int (** Bound variable as de Bruijn index. *) | Wild | Plac of bool | TRef of term option ref (** Reference cell (used in surface matching). *) | LLet of term * term * tbinder (** [LLet(a, t, u)] is [let x : a ≔ t in u] (with [x] bound in [u]). *) - | Db of int (** Bound variable as de Bruijn index. *) (** {b NOTE} that a wildcard "_" of the concrete (source code) syntax may have a different representation depending on the application. For instance, the @@ -152,38 +148,17 @@ and sym = variables are replaced by fresh meta-variables each time the rule is used. *) -(** Representation of a "term with environment", which intuitively corresponds - to a term with bound variables (or a "higher-order" term) represented with - the {!constructor:TE_Some} constructor. Other constructors are included so - that "terms with environments" can be bound in the RHS of rewriting rules. - This is purely technical. *) - and term_env = - | TE_Vari of tevar - (** Free "term with environment" variable (used to build a RHS). *) - | TE_Some of tmbinder - (** Actual "term with environment" (used to instantiate a RHS). *) - | TE_None - (** Dummy term environment (used during matching). *) - -(** The {!constructor:TEnv}[(te,env)] constructor intuitively corresponds to a - term [te] with free variables together with an explicit environment [env]. - Note that the binding of the environment actually occurs in [te], when the - constructor is of the form {!constructor:TE_Some}[(b)]. Indeed, [te] holds - a multiple binder [b] that binds every free variables of the term at once. - We then apply the substitution by performing a Bindlib substitution of [b] - with the environment [env]. *) - (** During evaluation, we only try to apply rewriting rules when we reduce the - application of a symbol [s] to a list of argument [ts]. At this point, the - symbol [s] contains every rule [r] that can potentially be applied in its - {!field:sym_rules} field. To check if a rule [r] applies, we match the - elements of [r.lhs] with those of [ts] while building an environment [env] - of type {!type:term_env array}. During this process, a pattern of the form - {!constructor:Patt}[(Some i,s,e)] matched against a term [u] will results - in [env.(i)] being set to [u]. If all terms of [ts] can be matched against - corresponding patterns, then environment [env] is fully constructed and it - can hence be substituted in [r.rhs] with [Bindlib.msubst r.rhs env] to get - the result of the application of the rule. *) + application of a symbol [s] to a list of argument [ts]. At this point, the + symbol [s] contains every rule [r] that can potentially be applied in its + {!field:sym_rules} field. To check if a rule [r] applies, we match the + elements of [r.lhs] with those of [ts] while building an environment [env]. + During this process, a pattern of + the form {!constructor:Patt}[(Some i,s,e)] matched against a term [u] will + results in [env.(i)] being set to [u]. If all terms of [ts] can be matched + against corresponding patterns, then environment [env] is fully constructed + and it can hence be substituted in [r.rhs] with [Bindlib.msubst r.rhs env] + to get the result of the application of the rule. *) (** {3 Metavariables and related functions} *) @@ -205,8 +180,6 @@ and tmbinder = string array * term and tvar = int * string -and tevar = term_env OldBindlib.var - module Bindlib = struct (** [unfold t] repeatedly unfolds the definition of the surface constructor @@ -246,7 +219,6 @@ and term : term pp = fun ppf t -> | Meta(m,ts) -> out ppf "?%d%a" m.meta_key terms ts | Patt(i,s,ts) -> out ppf "$%a_%s%a" (D.option D.int) i s terms ts | Plac(_) -> out ppf "_" - | TEnv _ -> assert false | Wild -> out ppf "_" | TRef r -> out ppf "&%a" (Option.pp term) !r | LLet(a,t,(n,b)) -> @@ -267,7 +239,6 @@ and lift : int -> term -> term = fun l t -> | LLet(a,t,(n,u)) -> LLet(lift i a, lift i t, (n, lift (i+1) u)) | Meta(m,ts) -> Meta(m, Array.map (lift i) ts) | Patt(j,n,ts) -> Patt(j,n, Array.map (lift i) ts) - | TEnv(te,ts) -> TEnv(te, Array.map (lift i) ts) | _ -> t in let r = lift 1 t in @@ -294,7 +265,6 @@ and msubst : tmbinder -> term array -> term = fun (ns,t) vs -> | LLet(a,t,(n,u)) -> LLet(msubst i a, msubst i t, (n, msubst (i+1) u)) | Meta(m,ts) -> Meta(m, Array.map (msubst i) ts) | Patt(j,n,ts) -> Patt(j,n, Array.map (msubst i) ts) - | TEnv(te,ts) -> TEnv(te, Array.map (msubst i) ts) | _ -> t in let r = if n = 0 then t else msubst 1 t in @@ -319,7 +289,6 @@ let subst : tbinder -> term -> term = fun (_,t) v -> | LLet(a,t,(n,u)) -> LLet(subst i a, subst i t, (n, subst (i+1) u)) | Meta(m,ts) -> Meta(m, Array.map (subst i) ts) | Patt(j,n,ts) -> Patt(j,n, Array.map (subst i) ts) - | TEnv(te,ts) -> TEnv(te, Array.map (subst i) ts) | _ -> t in let r = subst 1 t in @@ -371,17 +340,6 @@ let unmbind : tmbinder -> tvar array * term = fun ((names,_) as b) -> Array.init (Array.length names) (fun i -> new_var mkfree names.(i)) in xs, msubst b (Array.map mkfree xs) -(** [unmbind2 f g] is similar to [unmbind f], but it substitutes two multiple - binder [f] and [g] at once, using the same fresh variables. Note that the - two binders must have the same arity. This function may have an unexpected - results in some cases (see the documentation of [unbind2]). *) -let unmbind2 : tmbinder -> tmbinder -> tvar array * term * term - = fun ((names,_) as b1) b2 -> - let xs = - Array.init (Array.length names) (fun i -> new_var mkfree names.(i)) in - let ts = Array.map mkfree xs in - xs, msubst b1 ts, msubst b2 ts - (** Type of a term under construction. Using this representation, the free variable of the term can be bound easily. *) type 'a box = 'a @@ -413,7 +371,6 @@ let bind_var : tvar -> term box -> tbinder box = fun ((_,n) as x) -> | LLet(a,t,(n,u)) -> LLet(bind i a, bind i t, (n, bind (i+1) u)) | Meta(m,ts) -> Meta(m, Array.map (bind i) ts) | Patt(j,n,ts) -> Patt(j,n, Array.map (bind i) ts) - | TEnv(te,ts) -> TEnv(te, Array.map (bind i) ts) | _ -> t in fun t -> let b = bind 1 t in @@ -442,7 +399,6 @@ let bind_mvar : tvar array -> term box -> tmbinder box = fun xs t -> | LLet(a,t,(n,u)) -> LLet(bind i a, bind i t, (n, bind (i+1) u)) | Meta(m,ts) -> Meta(m, Array.map (bind i) ts) | Patt(j,n,ts) -> Patt(j,n, Array.map (bind i) ts) - | TEnv(te,ts) -> TEnv(te, Array.map (bind i) ts) | _ -> t in let b = bind 1 t in @@ -492,8 +448,7 @@ let binder_occur : tbinder -> bool = fun (_,t) -> | Prod(a,(_,u)) -> check i a; check (i+1) u | LLet(a,t,(_,u)) -> check i a; check i t; check (i+1) u | Meta(_,ts) - | Patt(_,_,ts) - | TEnv(_,ts) -> Array.iter (check i) ts + | Patt(_,_,ts) -> Array.iter (check i) ts | _ -> () in let r = try check 1 t; false with Exit -> true in @@ -518,8 +473,7 @@ let is_closed : term box -> bool = | Prod(a,(_,u)) -> check a; check u | LLet(a,t,(_,u)) -> check a; check t; check u | Meta(_,ts) - | Patt(_,_,ts) - | TEnv(_,ts) -> Array.iter check ts + | Patt(_,_,ts) -> Array.iter check ts | _ -> () in fun t -> try check t; true with Exit -> false @@ -535,8 +489,7 @@ let occur : tvar -> term box -> bool = fun x -> | Prod(a,(_,u)) -> check a; check u | LLet(a,t,(_,u)) -> check a; check t; check u | Meta(_,ts) - | Patt(_,_,ts) - | TEnv(_,ts) -> Array.iter check ts + | Patt(_,_,ts) -> Array.iter check ts | _ -> () in fun t -> try check t; false with Exit -> true @@ -546,8 +499,6 @@ end type tbox = term Bindlib.box -type tebox = term_env Bindlib.box - let unfold = Bindlib.unfold (** Printing functions for debug. *) @@ -595,12 +546,6 @@ let new_tvar : string -> tvar = Bindlib.new_var of_tvar let new_tvar_ind : string -> int -> tvar = fun s i -> new_tvar (Escape.add_prefix s (string_of_int i)) -(** [of_tevar x] injects the [Bindlib] variable [x] in a {!type:term_env}. *) -let of_tevar : tevar -> term_env = fun x -> TE_Vari(x) - -(** [new_tevar s] creates a new [tevar] with name [s]. *) -let new_tevar : string -> tevar = OldBindlib.new_var of_tevar - (** Sets and maps of symbols. *) module Sym = struct type t = sym @@ -683,38 +628,26 @@ let is_symb : sym -> term -> bool = fun s t -> match unfold t with Symb(r) -> r == s | _ -> false (** Total order on terms. *) -let cmp : term cmp = - let rec cmp t t' = +let rec cmp : term cmp = fun t t' -> match unfold t, unfold t' with - | Db i, Db j -> Stdlib.compare i j | Vari x, Vari x' -> Bindlib.compare_vars x x' | Type, Type | Kind, Kind | Wild, Wild -> 0 | Symb s, Symb s' -> Sym.compare s s' - | Prod(t,u), Prod(t',u') - | Abst(t,u), Abst(t',u') -> lex cmp cmp_binder (t,u) (t',u') + | Prod(t,(_,u)), Prod(t',(_,u')) + | Abst(t,(_,u)), Abst(t',(_,u')) -> lex cmp cmp (t,u) (t',u') | Appl(t,u), Appl(t',u') -> lex cmp cmp (u,t) (u',t') | Meta(m,ts), Meta(m',ts') -> lex Meta.compare (Array.cmp cmp) (m,ts) (m',ts') | Patt(i,s,ts), Patt(i',s',ts') -> lex3 Stdlib.compare Stdlib.compare (Array.cmp cmp) (i,s,ts) (i',s',ts') - | TEnv(e,ts), TEnv(e',ts') -> - lex cmp_tenv (Array.cmp cmp) (e,ts) (e',ts') + | Db i, Db j -> Stdlib.compare i j | TRef r, TRef r' -> Stdlib.compare r r' - | LLet(a,t,u), LLet(a',t',u') -> - lex3 cmp cmp cmp_binder (a,t,u) (a',t',u') + | LLet(a,t,(_,u)), LLet(a',t',(_,u')) -> + lex3 cmp cmp cmp (a,t,u) (a',t',u') | t, t' -> cmp_tag t t' - and cmp_binder t t' = let (_,t,t') = Bindlib.unbind2 t t' in cmp t t' - and cmp_mbinder t t' = let (_,t,t') = Bindlib.unmbind2 t t' in cmp t t' - and cmp_tenv e e' = - match e, e' with - | TE_Vari v, TE_Vari v' -> OldBindlib.compare_vars v v' - | TE_None, TE_None -> 0 - | TE_Some t, TE_Some t' -> cmp_mbinder t t' - | _ -> cmp_tag e e' - in cmp (** [get_args t] decomposes the {!type:term} [t] into a pair [(h,args)], where [h] is the head term of [t] and [args] is the list of arguments applied to @@ -763,11 +696,6 @@ let mk_TRef x = TRef x let mk_LLet (a,t,u) = if Bindlib.binder_constant u then Bindlib.subst u Kind else LLet (a,t,u) -let mk_TEnv (te,ts) = - match te with - | TE_Some mb -> Bindlib.msubst mb ts - | _ -> TEnv (te,ts) - (* We make the equality of terms modulo commutative and associative-commutative symbols syntactic by always ordering arguments in increasing order and by putting them in a comb form. @@ -950,10 +878,6 @@ let _Meta_full : meta Bindlib.box -> tbox array -> tbox = fun m ts -> let _Patt : int option -> string -> tbox array -> tbox = fun i n ts -> Bindlib.box_apply (fun ts -> Patt(i,n,ts)) (Bindlib.box_array ts) -(** [_TEnv te ts] lifts a term environment to the {!type:tbox} type. *) -let _TEnv : tebox -> tbox array -> tbox = fun te ts -> - Bindlib.box_apply2 (fun te ts -> mk_TEnv(te,ts)) te (Bindlib.box_array ts) - (** [_Wild] injects the constructor [Wild] into the {!type:tbox} type. *) let _Wild : tbox = Bindlib.box Wild @@ -969,13 +893,6 @@ let _TRef : term option ref -> tbox = fun r -> let _LLet : tbox -> tbox -> tbinder Bindlib.box -> tbox = Bindlib.box_apply3 (fun a t u -> mk_LLet(a, t, u)) -(** [_TE_Vari x] injects a term environment variable [x] into the {!type:tbox} - type so that it may be available for binding. *) -let _TE_Vari : tevar -> tebox = fun x -> TE_Vari x - -(** [_TE_None] injects the constructor [TE_None] into the {!type:tbox} type.*) -let _TE_None : tebox = Bindlib.box TE_None - (** [lift mk_appl t] lifts the {!type:term} [t] to the type {!type:tbox}, using the function [mk_appl] in the case of an application. This has the effect of gathering its free variables, making them available for binding. @@ -1037,7 +954,6 @@ let subst_patt : tmbinder option array -> term -> term = fun env -> | Abst(a,(n,b)) -> mk_Abst(subst_patt a, (n, subst_patt b)) | Appl(a,b) -> mk_Appl(subst_patt a, subst_patt b) | Meta(m,ts) -> mk_Meta(m, Array.map subst_patt ts) - | TEnv _ -> assert false | LLet(a,t,(n,b)) -> mk_LLet(subst_patt a, subst_patt t, (n, subst_patt b)) | Wild diff --git a/src/core/term.mli b/src/core/term.mli index 60f0cb9fc..6aafa38c6 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -11,8 +11,6 @@ open Timed open Lplib open Base open Common -module OldBindlib = Bindlib - (** {3 Term (and symbol) representation} *) (** Representation of a possibly qualified identifier. *) @@ -62,9 +60,8 @@ type term = private | Appl of term * term (** Term application. *) | Meta of meta * term array (** Metavariable application. *) | Patt of int option * string * term array - (** Pattern variable application (only used in rewriting rules LHS). *) - | TEnv of term_env * term array - (** Term environment (only used in rewriting rules RHS). *) + (** Pattern variable application (only used in rewriting rules). *) + | Db of int (** Bound variable as de Bruijn index. *) | Wild (** Wildcard (only used for surface matching, never in LHS). *) | Plac of bool (** [Plac b] is a placeholder, or hole, for not given terms. Boolean @@ -72,7 +69,6 @@ type term = private | TRef of term option ref (** Reference cell (used in surface matching). *) | LLet of term * term * tbinder (** [LLet(a, t, u)] is [let x : a ≔ t in u] (with [x] bound in [u]). *) - | Db of int (** Bound variable as de Bruijn index. *) (** {b NOTE} that a wildcard "_" of the concrete (source code) syntax may have a different representation depending on the application. For instance, the @@ -177,12 +173,6 @@ and sym = value of [r.arity] is always equal to [List.length r.lhs] and it gives the minimal number of arguments required to match the LHS of the rule. *) -(** The RHS (or action) or a rewriting rule is represented by a term, in which - (higher-order) variables representing "terms with environments" (see the - {!type:term_env} type) are bound. To effectively apply the rewriting rule, - these bound variables must be substituted using "terms with environments" - that are constructed when matching the LHS of the rule. *) - (** All variables of rewriting rules that appear in the RHS must appear in the LHS. This constraint is checked in {!module:Tool.Sr}.In the case of unification rules, we allow variables to appear only in the RHS. In that @@ -190,34 +180,12 @@ and sym = rule is used. The last {!field:Term.rule.xvars_nb} variables of {!field:Term.rule.vars} are such RHS-only variables. *) -(** Representation of a "term with environment", which intuitively corresponds - to a term with bound variables (or a "higher-order" term) represented with - the {!constructor:TE_Some} constructor. Other constructors are included so - that "terms with environments" can be bound in the RHS of rewriting rules. - This is purely technical. *) - and term_env = - | TE_Vari of tevar - (** Free "term with environment" variable (used to build a RHS). *) - | TE_Some of tmbinder - (** Actual "term with environment" (used to instantiate a RHS). *) - | TE_None (** Dummy term environment (used during matching). *) - - and tevar = term_env OldBindlib.var - -(** The {!constructor:TEnv}[(te,env)] constructor intuitively corresponds to a - term [te] with free variables together with an explicit environment [env]. - Note that the binding of the environment actually occurs in [te], when the - constructor is of the form {!constructor:TE_Some}[(b)]. Indeed, [te] holds - a multiple binder [b] that binds every free variables of the term at once. - We then apply the substitution by performing a Bindlib substitution of [b] - with the environment [env]. *) - (** During evaluation, we only try to apply rewriting rules when we reduce the application of a symbol [s] to a list of argument [ts]. At this point, the symbol [s] contains every rule [r] that can potentially be applied in its {!field:sym_rules} field. To check if a rule [r] applies, we match the - elements of [r.lhs] with those of [ts] while building an environment [env] - of type [{!type:Term.term_env} array]. During this process, a pattern of + elements of [r.lhs] with those of [ts] while building an environment [env]. + During this process, a pattern of the form {!constructor:Patt}[(Some i,s,e)] matched against a term [u] will results in [env.(i)] being set to [u]. If all terms of [ts] can be matched against corresponding patterns, then environment [env] is fully constructed @@ -348,8 +316,6 @@ end type tbox = term Bindlib.box -type tebox = term_env Bindlib.box - (** Minimize [impl] to enforce our invariant (see {!type:Term.sym}). *) val minimize_impl : bool list -> bool list @@ -388,12 +354,6 @@ val new_tvar : string -> tvar (** [new_tvar_ind s i] creates a new [tvar] of name [s ^ string_of_int i]. *) val new_tvar_ind : string -> int -> tvar -(** [of_tevar x] injects the [Bindlib] variable [x] in a {!type:term_env}. *) -val of_tevar : tevar -> term_env - -(** [new_tevar s] creates a new [tevar] with name [s]. *) -val new_tevar : string -> tevar - (** Sets and maps of symbols. *) module Sym : Map.OrderedType with type t = sym module SymSet : Set.S with type elt = sym @@ -495,7 +455,6 @@ val mk_Abst : term * tbinder -> term val mk_Appl : term * term -> term val mk_Meta : meta * term array -> term val mk_Patt : int option * string * term array -> term -val mk_TEnv : term_env * term array -> term val mk_Wild : term val mk_Plac : bool -> term val mk_TRef : term option ref -> term @@ -572,9 +531,6 @@ val _Meta_full : meta Bindlib.box -> tbox array -> tbox (** [_Patt i n ar] lifts a pattern variable to the {!type:tbox} type. *) val _Patt : int option -> string -> tbox array -> tbox -(** [_TEnv te ar] lifts a term environment to the {!type:tbox} type. *) -val _TEnv : tebox -> tbox array -> tbox - (** [_Wild] injects the constructor [Wild] into the {!type:tbox} type. *) val _Wild : tbox @@ -588,13 +544,6 @@ val _TRef : term option ref -> tbox (** [_LVal t a u] lifts val binding [val x := t : a in u]. *) val _LLet : tbox -> tbox -> tbinder Bindlib.box -> tbox -(** [_TE_Vari x] injects a term environment variable [x] into the {!type:tbox} - type so that it may be available for binding. *) -val _TE_Vari : tevar -> tebox - -(** [_TE_None] injects the constructor [TE_None] into the {!type:tbox} type.*) -val _TE_None : tebox - (** [lift t] lifts the {!type:term} [t] to the {!type:tbox} type. This has the effect of gathering its free variables, making them available for binding. Bound variable names are automatically updated in the process. *) diff --git a/src/export/dk.ml b/src/export/dk.ml index 45eb365e1..216b2b433 100644 --- a/src/export/dk.ml +++ b/src/export/dk.ml @@ -109,18 +109,10 @@ let cmp : decl cmp = cmp_map (Lplib.Option.cmp Pos.cmp) pos_of_decl (** Translation of terms. *) let tvar : tvar pp = fun ppf v -> ident ppf (Bindlib.name_of v) -let tevar : tevar pp = fun ppf v -> ident ppf (OldBindlib.name_of v) - -let tenv : term_env pp = fun ppf te -> - match te with - | TE_Vari v -> tevar ppf v - | TE_Some _ -> assert false - | TE_None -> assert false (** [term b ppf t] prints term [t]. Print abstraction domains if [b]. *) let rec term : bool -> term pp = fun b ppf t -> match unfold t with - | Db _ -> assert false | Vari v -> tvar ppf v | Type -> out ppf "Type" | Kind -> assert false @@ -144,9 +136,7 @@ let rec term : bool -> term pp = fun b ppf t -> | Patt(Some i,_,[||]) -> int ppf i | Patt(Some i,_,ts) -> out ppf "(%d%a)" i (Array.pp (prefix " " (term b)) "") ts - | TEnv(te, [||]) -> tenv ppf te - | TEnv(te, ts) -> - out ppf "%a%a" tenv te (Array.pp (prefix " " (term b)) "") ts + | Db _ -> assert false | TRef _ -> assert false | Wild -> assert false | Meta _ -> assert false diff --git a/src/export/hrs.ml b/src/export/hrs.ml index 0eb2623cd..932b6b410 100644 --- a/src/export/hrs.ml +++ b/src/export/hrs.ml @@ -20,11 +20,10 @@ let print_term : bool -> term pp = fun lhs -> let rec pp ppf t = match unfold t with (* Forbidden cases. *) - | Db _ -> assert false | Meta(_,_) -> assert false | Plac _ -> assert false | TRef(_) -> assert false - | TEnv(_,_) -> assert false + | Db _ -> assert false | Wild -> assert false | Kind -> assert false (* Printing of atoms. *) diff --git a/src/export/xtc.ml b/src/export/xtc.ml index 0bc19c2c4..048476e49 100644 --- a/src/export/xtc.ml +++ b/src/export/xtc.ml @@ -32,11 +32,10 @@ let status : sym -> symb_status = fun s -> let rec print_term : int -> string -> term pp = fun i s ppf t -> match unfold t with (* Forbidden cases. *) - | Db _ -> assert false | Meta(_,_) -> assert false | Plac _ -> assert false | TRef(_) -> assert false - | TEnv(_,_) -> assert false + | Db _ -> assert false | Wild -> assert false | Kind -> assert false (* [TYPE] and products are necessarily at type level *) @@ -63,11 +62,10 @@ let rec print_term : int -> string -> term pp = fun i s ppf t -> and print_type : int -> string -> term pp = fun i s ppf t -> match unfold t with (* Forbidden cases. *) - | Db _ -> assert false | Meta(_,_) -> assert false | Plac _ -> assert false | TRef(_) -> assert false - | TEnv(_,_) -> assert false + | Db _ -> assert false | Wild -> assert false | Kind -> assert false (* Variables are necessarily at object level *) @@ -120,10 +118,9 @@ let get_vars : sym -> rule -> (string * Term.term) list = fun s r -> let var_list : tvar list ref = ref [] in let rec subst_patt v t = match t with - | Db _ -> assert false | Type | Kind - | TEnv (_, _) + | Db _ | Meta (_, _) | Plac _ | TRef _ diff --git a/src/handle/rewrite.ml b/src/handle/rewrite.ml index 81128a93f..19349038c 100644 --- a/src/handle/rewrite.ml +++ b/src/handle/rewrite.ml @@ -165,7 +165,7 @@ let matches : term -> term -> bool = | Wild -> assert false | Meta _ -> assert false | Patt _ -> assert false - | TEnv _ -> assert false + | Db _ -> assert false | Plac _ -> assert false | Appl _ -> assert false | Prod _ -> assert false @@ -273,7 +273,7 @@ let bind_pattern : term -> term -> tbinder = fun p t -> let x, body = Bindlib.unbind body in _LLet (replace typ) (replace def) (Bindlib.bind_var x (replace body)) | Meta(m,ts) -> _Meta m (Array.map replace ts) - | TEnv _ -> assert false + | Db _ -> assert false | Wild -> assert false | TRef _ -> assert false | Patt _ -> assert false diff --git a/src/tool/lcr.ml b/src/tool/lcr.ml index b3ed8597d..f823dd847 100644 --- a/src/tool/lcr.ml +++ b/src/tool/lcr.ml @@ -77,7 +77,6 @@ let replace : term -> subterm_pos -> term -> term = fun t p u -> let occurs : int -> term -> bool = fun i -> let rec occ t = match unfold t with - | Db _ -> assert false | Patt(None,_,_) -> assert false | Patt(Some j,_,_) -> i=j | Vari _ | Symb _ -> false @@ -86,7 +85,7 @@ let occurs : int -> term -> bool = fun i -> | Type -> assert false | Kind -> assert false | Meta _ -> assert false - | TEnv _ -> assert false + | Db _ -> assert false | Wild -> assert false | Plac _ -> assert false | TRef _ -> assert false @@ -97,7 +96,6 @@ let occurs : int -> term -> bool = fun i -> let shift : term -> term = let rec shift : term -> tbox = fun t -> match unfold t with - | Db _ -> assert false | Vari x -> _Vari x | Type -> _Type | Kind -> _Kind @@ -108,17 +106,13 @@ let shift : term -> term = | Meta(m,ts) -> _Meta m (Array.map shift ts) | Patt(None,_,_) -> assert false | Patt(Some i,n,ts) -> _Patt (Some(-i-1)) (n ^ "'") (Array.map shift ts) - | TEnv(te,ts) -> _TEnv (shift_tenv te) (Array.map shift ts) + | Db _ -> assert false | Wild -> _Wild | Plac b -> _Plac b | TRef r -> _TRef r | LLet(a,t,b) -> _LLet (shift a) (shift t) (shift_binder b) and shift_binder b = let x, t = Bindlib.unbind b in Bindlib.bind_var x (shift t) - and shift_tenv : term_env -> tebox = function - | TE_Vari x -> _TE_Vari x - | TE_None -> _TE_None - | TE_Some _ -> assert false in fun t -> Bindlib.unbox (shift t) (** Type for pattern variable substitutions. *) @@ -134,7 +128,6 @@ let apply_subs : subs -> term -> term = fun s t -> let rec apply_subs t = (*if Logger.log_enabled() then log_cp "%a" term t;*) match unfold t with - | Db _ -> assert false | Patt(None, _, _) -> assert false | Patt(Some i,_,[||]) -> begin try IntMap.find i s with Not_found -> t end @@ -151,7 +144,7 @@ let apply_subs : subs -> term -> term = fun s t -> let x,b = Bindlib.unbind b in mk_LLet (apply_subs a, apply_subs t, bind x lift (apply_subs b)) | Meta(m,ts) -> mk_Meta (m, Array.map apply_subs ts) - | TEnv(te,ts) -> mk_TEnv (te, Array.map apply_subs ts) + | Db _ -> assert false | TRef _ -> assert false | Wild -> assert false | Plac _ -> assert false @@ -174,12 +167,11 @@ let iter_subterms_from_pos : subterm_pos -> iter = | Vari _ -> iter_args p t | Abst(a,b) | Prod(a,b) -> iter (0::p) a; let _,b = Bindlib.unbind b in iter (1::p) b - | Db _ -> assert false | Appl _ -> assert false | Type -> assert false | Kind -> assert false | Meta _ -> assert false - | TEnv _ -> assert false + | Db _ -> assert false | Wild -> assert false | Plac _ -> assert false | TRef _ -> assert false @@ -204,7 +196,6 @@ let iter_subterms_eq : iter = iter_subterms_from_pos [] let iter_subterms : iter = fun pos f t -> (*if Logger.log_enabled() then log_cp "iter_subterms %a" term t;*) match unfold t with - | Db _ -> assert false | Symb _ | Patt _ | Vari _ -> () @@ -217,7 +208,7 @@ let iter_subterms : iter = fun pos f t -> | Type -> assert false | Kind -> assert false | Meta _ -> assert false - | TEnv _ -> assert false + | Db _ -> assert false | Wild -> assert false | Plac _ -> assert false | TRef _ -> assert false @@ -252,7 +243,7 @@ let unif : Pos.popt -> term -> term -> term IntMap.t option = | Type, Type | Kind, Kind -> unif s l | Meta _, _ | _, Meta _ -> assert false - | TEnv _, _ | _, TEnv _ -> assert false + | Db _, _ | _, Db _ -> assert false | Wild, _ | _, Wild -> assert false | Plac _, _ | _, Plac _ -> assert false | TRef _, _ | _, TRef _ -> assert false diff --git a/src/tool/sr.ml b/src/tool/sr.ml index f7e214ba7..e301821c7 100644 --- a/src/tool/sr.ml +++ b/src/tool/sr.ml @@ -76,13 +76,12 @@ let symb_to_patt : Pos.popt -> (int * int) option SymMap.t -> term -> tbox = | Meta(_,_) -> fatal pos "A metavariable could not be instantiated in the RHS." | Plac _ -> - fatal pos "A placeholder hasn't been instantiated in the RHS." - | TEnv(_,_) -> assert false (* TEnv have been replaced in [t]. *) + fatal pos "A placeholder hasn't been instantiated in the RHS." + | Db _ -> assert false | Appl(_,_) -> assert false (* Cannot appear in RHS. *) | Patt(_,_,_) -> assert false (* Cannot appear in RHS. *) | Wild -> assert false (* Cannot appear in RHS. *) | TRef(_) -> assert false (* Cannot appear in RHS. *) - | Db _ -> assert false in _Appl_list h ts in From 084ef7a2b9f44dd941bac4ec78fe364b6acd13ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 10:54:44 +0100 Subject: [PATCH 06/38] remove bindlib from dependencies --- dune-project | 1 - lambdapi.opam | 1 - src/core/dune | 2 +- 3 files changed, 1 insertion(+), 3 deletions(-) diff --git a/dune-project b/dune-project index 4f3821a3e..6964c1b96 100644 --- a/dune-project +++ b/dune-project @@ -55,7 +55,6 @@ the Why3 platform.") (sedlex (>= 2.2)) (alcotest :with-test) (alt-ergo :with-test) (alt-ergo (<= 2.4.0)) - (bindlib (>= 5.0.1)) (timed (>= 1.0)) (pratter (>= 1.2)) (why3 (>= 1.4.0)) diff --git a/lambdapi.opam b/lambdapi.opam index 8ff15eb41..e028c1a60 100644 --- a/lambdapi.opam +++ b/lambdapi.opam @@ -53,7 +53,6 @@ depends: [ "alcotest" {with-test} "alt-ergo" {with-test} "alt-ergo" {<= "2.4.0"} - "bindlib" {>= "5.0.1"} "timed" {>= "1.0"} "pratter" {>= "1.2"} "why3" {>= "1.4.0"} diff --git a/src/core/dune b/src/core/dune index d0f25c063..3f3f39156 100644 --- a/src/core/dune +++ b/src/core/dune @@ -10,4 +10,4 @@ (public_name lambdapi.core) (synopsis "LambdaPi interactive theorem prover [core]") (modules :standard) - (libraries lambdapi.common lambdapi.lplib pratter bindlib why3)) + (libraries lambdapi.common lambdapi.lplib pratter why3)) From b522ac7eea24405fc63746ee16880db28b44ba37 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 11:06:22 +0100 Subject: [PATCH 07/38] remove mkfree --- src/core/term.ml | 44 ++++++++++++++------------------------------ src/core/term.mli | 25 ++++++------------------- 2 files changed, 20 insertions(+), 49 deletions(-) diff --git a/src/core/term.ml b/src/core/term.ml index 7d1dc2800..34205ae17 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -296,49 +296,36 @@ let subst : tbinder -> term -> term = fun (_,t) v -> log_term "subst %a [%a] = %a" term t term v term r; r -(** [new_var _ name] creates a new unique variable using [name]. *) -let new_var : (tvar -> term) -> string -> tvar = - let open Stdlib in let n = ref 0 in fun _ name -> incr n; !n, name +(** [new_var name] creates a new unique variable of name [name]. *) +let new_var : string -> tvar = + let open Stdlib in let n = ref 0 in fun name -> incr n; !n, name -let mkfree : tvar -> term = fun x -> Vari x - -(** [new_mvar names] creates a new array of new unique variables using +(** [new_mvar names] creates an array of new unique variables of name [names]. *) -let new_mvar : string array -> tvar array = Array.map (new_var mkfree) +let new_mvar : string array -> tvar array = Array.map new_var -(** [name_of x] returns a printable name for variable [x]. *) +(** [name_of x] returns the name of variable [x]. *) let name_of : tvar -> string = fun (_i,n) -> n (*^ string_of_int i*) (** [unbind b] substitutes the binder [b] using a fresh variable. The variable and the result of the substitution are returned. Note that the name of the - fresh variable is based on that of the binder. The [mkfree] function used - to create the fresh variable is that of the variable that was bound by [b] - at its construction (see [new_var] and [bind_var]). *) + fresh variable is based on that of the binder. *) let unbind : tbinder -> tvar * term = fun ((name,_) as b) -> - let x = new_var mkfree name in x, subst b (Vari x) + let x = new_var name in x, subst b (Vari x) (** [unbind2 f g] is similar to [unbind f], but it substitutes two binders [f] and [g] at once using the same fresh variable. The name of the variable is - based on that of the binder [f]. Similarly, the [mkfree] syntactic wrapper - that is used for the fresh variable is the one that was given for creating - the variable that was bound to construct [f] (see [bind_var] and [new_var] - for details on this process). In particular, the use of [unbind2] may lead - to unexpected results if the binders [f] and [g] were not built using free - variables created with the same [mkfree]. *) + based on that of the binder [f]. *) let unbind2 : tbinder -> tbinder -> tvar * term * term = fun ((name1,_) as b1) b2 -> - let x = new_var mkfree name1 in x, subst b1 (Vari x), subst b2 (Vari x) + let x = new_var name1 in x, subst b1 (Vari x), subst b2 (Vari x) (** [unmbind b] substitutes the multiple binder [b] with fresh variables. This function is analogous to [unbind] for binders. Note that the names used to - create the fresh variables are based on those of the multiple binder. The - syntactic wrapper (of [mkfree]) that is used to build the variables is the - one that was given when creating the multiple variables that were bound in - [b] (see [new_mvar] and [bind_mvar]). *) + create the fresh variables are based on those of the multiple binder. *) let unmbind : tmbinder -> tvar array * term = fun ((names,_) as b) -> - let xs = - Array.init (Array.length names) (fun i -> new_var mkfree names.(i)) in - xs, msubst b (Array.map mkfree xs) + let xs = Array.init (Array.length names) (fun i -> new_var names.(i)) in + xs, msubst b (Array.map (fun x -> Vari x) xs) (** Type of a term under construction. Using this representation, the free variable of the term can be bound easily. *) @@ -536,11 +523,8 @@ end module VarSet = Set.Make(Var) module VarMap = Map.Make(Var) -(** [of_tvar x] injects the [Bindlib] variable [x] in a term. *) -let of_tvar : tvar -> term = fun x -> Vari(x) - (** [new_tvar s] creates a new [tvar] of name [s]. *) -let new_tvar : string -> tvar = Bindlib.new_var of_tvar +let new_tvar : string -> tvar = Bindlib.new_var (** [new_tvar_ind s i] creates a new [tvar] of name [s ^ string_of_int i]. *) let new_tvar_ind : string -> int -> tvar = fun s i -> diff --git a/src/core/term.mli b/src/core/term.mli index 6aafa38c6..380714fb9 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -218,10 +218,10 @@ val msubst : tmbinder -> term array -> term val msubst3 : (tmbinder * tmbinder * tmbinder) -> term array -> term * term * term -(** [new_var _ name] creates a new unique variable using [name]. *) -val new_var : (tvar -> term) -> string -> tvar +(** [new_var name] creates a new unique variable of name [name]. *) +val new_var : string -> tvar -(** [new_mvar names] creates a new array of new unique variables using +(** [new_mvar names] creates an array of new unique variables of name [names]. *) val new_mvar : string array -> tvar array @@ -230,27 +230,17 @@ val name_of : tvar -> string (** [unbind b] substitutes the binder [b] using a fresh variable. The variable and the result of the substitution are returned. Note that the name of the - fresh variable is based on that of the binder. The [mkfree] function used - to create the fresh variable is that of the variable that was bound by [b] - at its construction (see [new_var] and [bind_var]). *) + fresh variable is based on that of the binder. *) val unbind : tbinder -> tvar * term (** [unbind2 f g] is similar to [unbind f], but it substitutes two binders [f] and [g] at once using the same fresh variable. The name of the variable is - based on that of the binder [f]. Similarly, the [mkfree] syntactic wrapper - that is used for the fresh variable is the one that was given for creating - the variable that was bound to construct [f] (see [bind_var] and [new_var] - for details on this process). In particular, the use of [unbind2] may lead - to unexpected results if the binders [f] and [g] were not built using free - variables created with the same [mkfree]. *) + based on that of the binder [f]. *) val unbind2 : tbinder -> tbinder -> tvar * term * term (** [unmbind b] substitutes the multiple binder [b] with fresh variables. This function is analogous to [unbind] for binders. Note that the names used to - create the fresh variables are based on those of the multiple binder. The - syntactic wrapper (of [mkfree]) that is used to build the variables is the - one that was given when creating the multiple variables that were bound in - [b] (see [new_mvar] and [bind_mvar]). *) + create the fresh variables are based on those of the multiple binder. *) val unmbind : tmbinder -> tvar array * term (** Type of a term under construction. Using this representation, @@ -345,9 +335,6 @@ module Var : Map.OrderedType with type t = tvar module VarSet : Set.S with type elt = tvar module VarMap : Map.S with type key = tvar -(** [of_tvar x] injects the [Bindlib] variable [x] in a term. *) -val of_tvar : tvar -> term - (** [new_tvar s] creates a new [tvar] of name [s]. *) val new_tvar : string -> tvar From 23c7397f2bf8ebb2323d1fbcebf3e020b23b32b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 12:25:05 +0100 Subject: [PATCH 08/38] remove new_mvar and do not export new_var --- src/core/term.ml | 4 ---- src/core/term.mli | 7 ------- 2 files changed, 11 deletions(-) diff --git a/src/core/term.ml b/src/core/term.ml index 34205ae17..981110f72 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -300,10 +300,6 @@ let subst : tbinder -> term -> term = fun (_,t) v -> let new_var : string -> tvar = let open Stdlib in let n = ref 0 in fun name -> incr n; !n, name -(** [new_mvar names] creates an array of new unique variables of name - [names]. *) -let new_mvar : string array -> tvar array = Array.map new_var - (** [name_of x] returns the name of variable [x]. *) let name_of : tvar -> string = fun (_i,n) -> n (*^ string_of_int i*) diff --git a/src/core/term.mli b/src/core/term.mli index 380714fb9..0887d3db4 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -218,13 +218,6 @@ val msubst : tmbinder -> term array -> term val msubst3 : (tmbinder * tmbinder * tmbinder) -> term array -> term * term * term -(** [new_var name] creates a new unique variable of name [name]. *) -val new_var : string -> tvar - -(** [new_mvar names] creates an array of new unique variables of name - [names]. *) -val new_mvar : string array -> tvar array - (** [name_of x] returns a printable name for variable [x]. *) val name_of : tvar -> string From 6730df057c35f0f836c940fcdacca084059f7e0a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 15:36:59 +0100 Subject: [PATCH 09/38] remove box type --- src/core/ctxt.ml | 21 ++-- src/core/env.ml | 40 ++++---- src/core/eval.ml | 25 ++--- src/core/infer.ml | 34 +++---- src/core/inverse.ml | 4 +- src/core/libMeta.ml | 19 ++-- src/core/libTerm.ml | 2 +- src/core/print.ml | 2 +- src/core/sig_state.ml | 3 +- src/core/sign.ml | 2 +- src/core/term.ml | 196 ++++++-------------------------------- src/core/term.mli | 143 +++------------------------ src/core/unif.ml | 52 +++++----- src/export/xtc.ml | 2 +- src/handle/command.ml | 7 +- src/handle/inductive.ml | 51 +++++----- src/handle/proof.ml | 4 +- src/handle/rewrite.ml | 99 ++++++++++--------- src/handle/tactic.ml | 23 ++--- src/handle/why3_tactic.ml | 2 +- src/parsing/scope.ml | 108 ++++++++++----------- src/pure/pure.ml | 2 +- src/tool/lcr.ml | 50 +++++----- src/tool/sr.ml | 51 +++++----- 24 files changed, 330 insertions(+), 612 deletions(-) diff --git a/src/core/ctxt.ml b/src/core/ctxt.ml index 5e4ad36d6..a75b52296 100644 --- a/src/core/ctxt.ml +++ b/src/core/ctxt.ml @@ -27,39 +27,38 @@ let to_prod : ctxt -> term -> term * int = fun ctx t -> let f (t,c) (x,a,v) = let b = Bindlib.bind_var x t in match v with - | None -> _Prod (lift a) b, c + 1 - | Some v -> _LLet (lift a) (lift v) b, c + | None -> mk_Prod (a, b), c + 1 + | Some v -> mk_LLet (a, v, b), c in - let t, c = List.fold_left f (lift t, 0) ctx in - Bindlib.unbox t, c + List.fold_left f (t, 0) ctx (** [to_prod_box bctx t] is similar to [to_prod bctx t] but operates on boxed contexts and terms. *) -let to_prod_box : bctxt -> tbox -> tbox * int = fun bctx t -> +let to_prod_box : bctxt -> term -> term * int = fun bctx t -> let f (t, c) (x, a) = let b = Bindlib.bind_var x t in - (_Prod a b, c + 1) + (mk_Prod(a,b), c + 1) in List.fold_left f (t, 0) bctx (** [box_context ctx] lifts context [ctx] to a boxed context. *) let box_context : ctxt -> bctxt = List.filter_map - (fun (x, t, u) -> if u = None then Some (x, lift t) else None) + (fun (x, t, u) -> if u = None then Some (x, t) else None) (** [to_abst ctx t] builds a sequence of abstractions over the context [ctx], in the term [t]. *) let to_abst : ctxt -> term -> term = fun ctx t -> - let f t (x, a, _) = _Abst (lift a) (Bindlib.bind_var x t) in - Bindlib.unbox (List.fold_left f (lift t) ctx) + let f t (x, a, _) = mk_Abst (a, Bindlib.bind_var x t) in + List.fold_left f t ctx (** [to_let ctx t] adds the defined variables of [ctx] on top of [t]. *) let to_let : ctxt -> term -> term = fun ctx t -> let f t = function | _, _, None -> t - | x, a, Some u -> _LLet (lift a) (lift u) (Bindlib.bind_var x t) + | x, a, Some u -> mk_LLet (a, u, Bindlib.bind_var x t) in - Bindlib.unbox (List.fold_left f (lift t) ctx) + List.fold_left f t ctx (** [sub ctx vs] returns the sub-context of [ctx] made of the variables of [vs]. *) diff --git a/src/core/env.ml b/src/core/env.ml index afc5b812f..befa27575 100644 --- a/src/core/env.ml +++ b/src/core/env.ml @@ -8,7 +8,7 @@ open Term implemented by a map as the order is important. The structure is similar to then one of {!type:Term.ctxt}, a tuple [(x,a,t)] is a variable [x], its type [a] and possibly its definition [t] *) -type env = (string * (tvar * tbox * tbox option)) list +type env = (string * (tvar * term * term option)) list type t = env @@ -17,7 +17,7 @@ let empty : env = [] (** [add v a t env] extends the environment [env] by mapping the string [n] to [(v,a,t)]. *) -let add : string -> tvar -> tbox -> tbox option -> env -> env = +let add : string -> tvar -> term -> term option -> env -> env = fun n v a t env -> (n, (v, a, t)) :: env (** [find n env] returns the Bindlib variable associated to the variable name @@ -32,32 +32,28 @@ let mem : string -> env -> bool = List.mem_assoc are the variables of the environment [env] (from left to right), and whose body is the term [t]. By calling [to_prod [(xn,an,None);⋯;(x1,a1,None)] t] you obtain a term of the form [Πx1:a1,..,Πxn:an,t]. *) -let to_prod_box : env -> tbox -> tbox = fun env t -> +let to_prod : env -> term -> term = fun env t -> let add_prod t (_,(x,a,u)) = let b = Bindlib.bind_var x t in match u with - | Some u -> _LLet a u b - | None -> _Prod a b + | Some u -> mk_LLet (a, u, b) + | None -> mk_Prod (a, b) in List.fold_left add_prod t env -(** [to_prod] is an “unboxed” version of [to_prod_box]. *) -let to_prod : env -> tbox -> term = fun env t -> - Bindlib.unbox (to_prod_box env t) - (** [to_abst env t] builds a sequence of abstractions or let bindings, depending on the definition of the elements in the environment whose domains are the variables of the environment [env] (from left to right), and which body is the term [t]: [to_abst [(xn,an,None);..;(x1,a1,None)] t = λx1:a1,..,λxn:an,t]. *) -let to_abst : env -> tbox -> term = fun env t -> +let to_abst : env -> term -> term = fun env t -> let add_abst t (_,(x,a,u)) = let b = Bindlib.bind_var x t in match u with - | Some u -> _LLet a u b - | None -> _Abst a b + | Some u -> mk_LLet (a, u, b) + | None -> mk_Abst (a, b) in - Bindlib.unbox (List.fold_left add_abst t env) + List.fold_left add_abst t env (** [vars env] extracts the array of the {e not defined} Bindlib variables in [env]. Note that the order is reversed: [vars [(xn,an);..;(x1,a1)] = @@ -67,21 +63,19 @@ let vars : env -> tvar array = fun env -> Array.of_list (List.filter_rev_map f env) (** [appl t env] applies [t] to the variables of [env]. *) -let appl : tbox -> env -> tbox = fun t env -> - List.fold_right (fun (_,(x,_,_)) t -> _Appl t (_Vari x)) env t +let appl : term -> env -> term = fun t env -> + List.fold_right (fun (_,(x,_,_)) t -> mk_Appl (t, mk_Vari x)) env t (** [to_tbox env] extracts the array of the {e not defined} variables in [env] and injects them in the [tbox] type. This is the same as [Array.map _Vari (vars env)]. Note that the order is reversed: [to_tbox [(xn,an);..;(x1,a1)] = [|x1;..;xn|]]. *) -let to_tbox : env -> tbox array = fun env -> - let f (_, (x, _, u)) = if u = None then Some(_Vari x) else None in +let to_tbox : env -> term array = fun env -> + let f (_, (x, _, u)) = if u = None then Some(mk_Vari x) else None in Array.of_list (List.filter_rev_map f env) (** [to_ctxt e] converts an environment into a context. *) -let to_ctxt : env -> ctxt = - List.map - (fun (_,(v,a,t)) -> (v, Bindlib.unbox a, Option.map Bindlib.unbox t)) +let to_ctxt : env -> ctxt = List.map snd (** [match_prod c t f] returns [f a b] if [t] matches [Prod(a,b)] possibly after reduction. @@ -106,7 +100,7 @@ let of_prod : ctxt -> string -> term -> env * term = fun c s t -> try match_prod c t (fun a b -> let name = Stdlib.(incr i; s ^ string_of_int !i) in let x, b = LibTerm.unbind_name name b in - build_env (add name x (lift a) None env) b) + build_env (add name x a None env) b) with Invalid_argument _ -> env, t in build_env [] t @@ -123,7 +117,7 @@ let of_prod_nth : ctxt -> int -> term -> env * term = fun c n t -> if i >= n then env, t else match_prod c t (fun a b -> let x, b = Bindlib.unbind b in - build_env (i+1) (add (Bindlib.name_of x) x (lift a) None env) b) + build_env (i+1) (add (Bindlib.name_of x) x a None env) b) in build_env 0 [] t (** [of_prod_using c xs t] is similar to [of_prod s c n t] where [n = @@ -138,6 +132,6 @@ let of_prod_using : ctxt -> tvar array -> term -> env * term = fun c xs t -> else match_prod c t (fun a b -> let xi = xs.(i) in let name = Bindlib.name_of xi in - let env = add name xi (lift a) None env in + let env = add name xi a None env in build_env (i+1) env (Bindlib.subst b (mk_Vari xi))) in build_env 0 [] t diff --git a/src/core/eval.ml b/src/core/eval.ml index 4815e099d..6d067b7ad 100644 --- a/src/core/eval.ml +++ b/src/core/eval.ml @@ -44,7 +44,7 @@ let hnf : (term -> term) -> (term -> term) = fun whnf -> let rec hnf t = match whnf t with | Abst(a,t) -> - let x, t = Bindlib.unbind t in mk_Abst(a, bind x lift (hnf t)) + let x, t = Bindlib.unbind t in mk_Abst(a, Bindlib.bind_var x (hnf t)) | t -> t in hnf @@ -61,9 +61,11 @@ let snf : (term -> term) -> (term -> term) = fun whnf -> | Symb _ -> h | LLet(_,t,b) -> snf (Bindlib.subst b t) | Prod(a,b) -> - let x, b = Bindlib.unbind b in mk_Prod(snf a, bind x lift (snf b)) + let x, b = Bindlib.unbind b in + mk_Prod(snf a, Bindlib.bind_var x (snf b)) | Abst(a,b) -> - let x, b = Bindlib.unbind b in mk_Abst(snf a, bind x lift (snf b)) + let x, b = Bindlib.unbind b in + mk_Abst(snf a, Bindlib.bind_var x (snf b)) | Appl(t,u) -> mk_Appl(snf t, snf u) | Meta(m,ts) -> mk_Meta(m, Array.map snf ts) | Patt(i,n,ts) -> mk_Patt(i,n,Array.map snf ts) @@ -309,14 +311,14 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = | Some(_) -> env.(slot) <- bound.(pos) | None -> let xs = Array.map (fun e -> IntMap.find e id_vars) xs in - env.(slot) <- Some(binds xs lift vars.(pos)) + env.(slot) <- Some(Bindlib.bind_mvar xs vars.(pos)) in List.iter f rhs_subst; (* Complete the array with fresh meta-variables if needed. *) for i = r.vars_nb to env_len - 1 do let mt = LibMeta.make cfg.problem cfg.context mk_Type in let t = LibMeta.make cfg.problem cfg.context mt in - env.(i) <- Some(binds [||] lift t) + env.(i) <- Some(Bindlib.bind_mvar [||] t) done; Some (subst_patt env r.rhs, stk) | Cond({ok; cond; fail}) -> @@ -342,14 +344,13 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = forbidden) in (* We first attempt to match [vars.(i)] directly. *) - let b = Bindlib.bind_mvar allowed (lift vars.(i)) in + let b = Bindlib.bind_mvar allowed vars.(i) in if no_forbidden b - then (bound.(i) <- Some(Bindlib.unbox b); ok) else + then (bound.(i) <- Some b; ok) else (* As a last resort we try matching the SNF. *) - let b = Bindlib.bind_mvar allowed - (lift (snf (whnf cfg) vars.(i))) in + let b = Bindlib.bind_mvar allowed (snf (whnf cfg) vars.(i)) in if no_forbidden b - then (bound.(i) <- Some(Bindlib.unbox b); ok) + then (bound.(i) <- Some b; ok) else fail in walk next stk cursor vars_id id_vars @@ -523,7 +524,7 @@ let rec simplify : term -> term = fun t -> match get_args (whnf ~tags [] t) with | Prod(a,b), _ -> let x, b = Bindlib.unbind b in - mk_Prod (simplify a, bind x lift (simplify b)) + mk_Prod (simplify a, Bindlib.bind_var x (simplify b)) | h, ts -> add_args_map h (whnf ~tags []) ts let simplify = @@ -551,7 +552,7 @@ let unfold_sym : sym -> term -> term = | _ -> h in add_args h args and unfold_sym_binder b = - let x, b = Bindlib.unbind b in bind x lift (unfold_sym b) + let x, b = Bindlib.unbind b in Bindlib.bind_var x (unfold_sym b) in unfold_sym in fun s -> diff --git a/src/core/infer.ml b/src/core/infer.ml index 51c92c644..7e3369905 100644 --- a/src/core/infer.ml +++ b/src/core/infer.ml @@ -15,9 +15,7 @@ type octxt = ctxt * bctxt let boxed = snd let classic = fst let extend (cctx, bctx) v ?def ty = - ((v, ty, def) :: cctx, if def <> None then bctx else (v, lift ty) :: bctx) - -let unbox = Bindlib.unbox + ((v, ty, def) :: cctx, if def <> None then bctx else (v, ty) :: bctx) (** Exception that may be raised by type inference. *) exception NotTypable @@ -80,9 +78,9 @@ and force : problem -> octxt -> term -> term -> term * bool = match unfold te with | Plac true -> unif pb c ty mk_Type; - (unbox (LibMeta.bmake pb (boxed c) _Type), true) + (LibMeta.bmake pb (boxed c) mk_Type, true) | Plac false -> - (unbox (LibMeta.bmake pb (boxed c) (lift ty)), true) + (LibMeta.bmake pb (boxed c) ty, true) | _ -> let (t, a, cui) = infer pb c te in let t, cu = coerce pb c t a ty in @@ -102,12 +100,12 @@ and infer_aux : problem -> octxt -> term -> term * term * bool = (t, a, false) | Symb s -> (t, !(s.sym_type), false) | Plac true -> - let m = LibMeta.bmake pb (boxed c) _Type in - (unbox m, mk_Type, true) + let m = LibMeta.bmake pb (boxed c) mk_Type in + (m, mk_Type, true) | Plac false -> - let mt = LibMeta.bmake pb (boxed c) _Type in + let mt = LibMeta.bmake pb (boxed c) mk_Type in let m = LibMeta.bmake pb (boxed c) mt in - (unbox m, unbox mt, true) + (m, mt, true) (* All metavariables inserted are typed. *) | (Meta (m, ts)) as t -> let cu = Stdlib.ref false in @@ -145,12 +143,12 @@ and infer_aux : problem -> octxt -> term -> term * term * bool = term u; raise NotTypable | _ -> () ); - let u_ty = Bindlib.(u_ty |> lift |> bind_var x |> unbox) in + let u_ty = Bindlib.bind_var x u_ty in let top_ty = mk_LLet (t_ty, t, u_ty) in let cu = cu_t_ty || cu_t || cu_u in let top = if cu then - let u = Bindlib.(u |> lift |> bind_var x |> unbox) in + let u = Bindlib.bind_var x u in mk_LLet(t_ty, t, u) else top in @@ -161,12 +159,12 @@ and infer_aux : problem -> octxt -> term -> term * term * bool = let (x, b) = Bindlib.unbind b in let c = extend c x dom in let b, range, cu_b = infer pb c b in - let range = Bindlib.(lift range |> bind_var x |> unbox) in + let range = Bindlib.bind_var x range in let top_ty = mk_Prod (dom, range) in let cu = cu_b || cu_dom in let top = if cu then - let b = Bindlib.(lift b |> bind_var x |> unbox) in + let b = Bindlib.bind_var x b in mk_Abst (dom, b) else top in @@ -180,7 +178,7 @@ and infer_aux : problem -> octxt -> term -> term * term * bool = let cu = cu_b || cu_dom in let top = if cu then - let b = Bindlib.(lift b |> bind_var x |> unbox) in + let b = Bindlib.bind_var x b in mk_Prod (dom, b) else top in @@ -199,16 +197,12 @@ and infer_aux : problem -> octxt -> term -> term * term * bool = return cu_u t u range | Meta (_, _) -> let u, u_ty, cu_u = infer pb c u in - let range = - unbox (LibMeta.bmake_codomain pb (boxed c) (lift u_ty)) - in + let range = LibMeta.bmake_codomain pb (boxed c) u_ty in unif pb c t_ty (mk_Prod (u_ty, range)); return cu_u t u range | t_ty -> - let domain = LibMeta.bmake pb (boxed c) _Type in + let domain = LibMeta.bmake pb (boxed c) mk_Type in let range = LibMeta.bmake_codomain pb (boxed c) domain in - let domain = unbox domain - and range = unbox range in let t, cu_t' = coerce pb c t t_ty (mk_Prod (domain, range)) in if Logger.log_enabled () then log "Appl-default arg [%a]" term u; diff --git a/src/core/inverse.ml b/src/core/inverse.ml index 580420aa4..f80dd083e 100644 --- a/src/core/inverse.ml +++ b/src/core/inverse.ml @@ -129,9 +129,7 @@ let rec inverse : sym -> term -> term = fun s v -> let t2 = let x, b = Bindlib.unbind b in let b = inverse s2 b in - if occ then - Bindlib.unbox (_Abst (lift a) (Bindlib.bind_var x (lift b))) - else b + if occ then mk_Abst (a, Bindlib.bind_var x b) else b in add_args (mk_Symb s0) [t1;t2] | _ -> raise Not_found diff --git a/src/core/libMeta.ml b/src/core/libMeta.ml index 3b0c2ca6f..3621e30d4 100644 --- a/src/core/libMeta.ml +++ b/src/core/libMeta.ml @@ -26,10 +26,8 @@ let fresh : problem -> term -> int -> meta = type becomes valid at unboxing. The boxed metavariable should be unboxed at most once, otherwise its type may be rendered invalid in some contexts. *) -let fresh_box: problem -> tbox -> int -> meta Bindlib.box = - fun p a n -> - let m = fresh p mk_Kind n in - Bindlib.box_apply (fun a -> m.meta_type := a; m) a +let fresh_box: problem -> term -> int -> meta = fun p a n -> + let m = fresh p mk_Kind n in m.meta_type := a; m (** [set p m v] sets the metavariable [m] of [p] to [v]. WARNING: No specific check is performed, so this function may lead to cyclic terms. To use with @@ -51,27 +49,26 @@ let make : problem -> ctxt -> term -> term = a fresh {e boxed} metavariable in {e boxed} context [bctx] of {e boxed} type [a]. It is the same as [lift (make p c b)] (provided that [bctx] is boxed [c] and [a] is boxed [b]), but more efficient. *) -let bmake : problem -> bctxt -> tbox -> tbox = +let bmake : problem -> bctxt -> term -> term = fun p bctx a -> let (a, k) = Ctxt.to_prod_box bctx a in let m = fresh_box p a k in - let get_var (x, _) = _Vari x in - _Meta_full m (Array.of_list (List.rev_map get_var bctx)) + let get_var (x, _) = mk_Vari x in + mk_Meta (m, Array.of_list (List.rev_map get_var bctx)) (** [make_codomain p ctx a] creates a fresh metavariable term of type [Type] in the context [ctx] extended with a fresh variable of type [a], and updates [p] with generated metavariables. *) let make_codomain : problem -> ctxt -> term -> tbinder = fun p ctx a -> let x = new_tvar "x" in - bind x lift (make p ((x, a, None) :: ctx) mk_Type) + Bindlib.bind_var x (make p ((x, a, None) :: ctx) mk_Type) (** [bmake_codomain p bctx a] is [make_codomain p bctx a] but on boxed terms. *) -let bmake_codomain : problem -> bctxt -> tbox -> tbinder Bindlib.box = +let bmake_codomain : problem -> bctxt -> term -> tbinder = fun p bctx a -> let x = new_tvar "x" in - let b = bmake p ((x, a) :: bctx) _Type in - Bindlib.bind_var x b + Bindlib.bind_var x (bmake p ((x, a) :: bctx) mk_Type) (** [iter b f c t] applies the function [f] to every metavariable of [t] and, if [x] is a variable of [t] mapped to [v] in the context [c], then to every diff --git a/src/core/libTerm.ml b/src/core/libTerm.ml index c5126f026..537447ff9 100644 --- a/src/core/libTerm.ml +++ b/src/core/libTerm.ml @@ -155,5 +155,5 @@ let sym_to_var : tvar StrMap.t -> term -> term = fun map -> | TRef _ -> assert false | _ -> t and to_var_binder b = - let (x,b) = Bindlib.unbind b in bind x lift (to_var b) + let (x,b) = Bindlib.unbind b in Bindlib.bind_var x (to_var b) in fun t -> if StrMap.is_empty map then t else to_var t diff --git a/src/core/print.ml b/src/core/print.ml index 7c5678bda..a25efd22c 100644 --- a/src/core/print.ml +++ b/src/core/print.ml @@ -250,7 +250,7 @@ and term : term pp = fun ppf t -> out ppf " %a%a" bvar (b,x) abstractions t | t -> out ppf ", %a" func t in - func ppf (cleanup t) + func ppf t (*let term ppf t = out ppf "<%a printed %a>" Term.term t term t*) (*let term = Raw.term*) diff --git a/src/core/sig_state.ml b/src/core/sig_state.ml index 79527ec77..c7b0ae0ec 100644 --- a/src/core/sig_state.ml +++ b/src/core/sig_state.ml @@ -49,8 +49,7 @@ let add_symbol : sig_state -> expo -> prop -> match_strat -> bool -> strloc -> term -> bool list -> term option -> sig_state * sym = fun ss expo prop mstrat opaq id typ impl def -> let sym = - Sign.add_symbol ss.signature expo prop mstrat opaq id - (cleanup typ) impl in + Sign.add_symbol ss.signature expo prop mstrat opaq id typ impl in begin match def with | Some t -> sym.sym_def := Some (cleanup t) diff --git a/src/core/sign.ml b/src/core/sign.ml index d0dddfac9..2ab218cc5 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -106,7 +106,7 @@ let link : t -> unit = fun sign -> | Wild -> assert false | TRef _ -> assert false and link_binder b = - let (x,t) = Bindlib.unbind b in bind x lift (link_term t) + let (x,t) = Bindlib.unbind b in Bindlib.bind_var x (link_term t) in link_term in let link_lhs = link_term mk_Appl_not_canonical diff --git a/src/core/term.ml b/src/core/term.ml index 981110f72..64a802d8c 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -323,27 +323,8 @@ let unmbind : tmbinder -> tvar array * term = fun ((names,_) as b) -> let xs = Array.init (Array.length names) (fun i -> new_var names.(i)) in xs, msubst b (Array.map (fun x -> Vari x) xs) -(** Type of a term under construction. Using this representation, - the free variable of the term can be bound easily. *) -type 'a box = 'a - -(** [box e] injects the value [e] into the [term box] type, assuming that it - is closed. Thus, if [e] contains variables, then they will not be - considered free. This means that no variable of [e] will be available for - binding. *) -let box : 'a -> 'a box = fun t -> t - -(** [box_apply f ba] applies the function [f] to a boxed argument [ba]. It is - equivalent to [apply_box (box f) ba], but is more efficient. *) -let box_apply : ('a -> 'b) -> 'a box -> 'b box = fun x -> x - -(** [box_apply2 f ba bb] applies the function [f] to two boxed arguments [ba] - and [bb]. It is equivalent to [apply_box (apply_box (box f) ba) bb] but it - is more efficient. *) -let box_apply2 : ('a -> 'b -> 'c) -> 'a box -> 'b box -> 'c box = fun x -> x - (** [bind_var x b] binds the variable [x] in [b], producing a boxed binder. *) -let bind_var : tvar -> term box -> tbinder box = fun ((_,n) as x) -> +let bind_var : tvar -> term -> tbinder = fun ((_,n) as x) -> let rec bind i t = (*if Logger.log_enabled() then log_term "bind_var %d %a" i term t;*) match unfold t with @@ -363,7 +344,7 @@ let bind_var : tvar -> term box -> tbinder box = fun ((_,n) as x) -> (** [bind_mvar xs b] binds the variables of [xs] in [b] to get a boxed binder. It is the equivalent of [bind_var] for multiple variables. *) -let bind_mvar : tvar array -> term box -> tmbinder box = fun xs t -> +let bind_mvar : tvar array -> term -> tmbinder = fun xs t -> let n = Array.length xs in if n = 0 then [||], t else let open Stdlib in let open Extra in @@ -389,28 +370,10 @@ let bind_mvar : tvar array -> term box -> tmbinder box = fun xs t -> log_term "bind_mvar %a %a = %a" (D.array var) xs term t term b; Array.map name_of xs, b -let bind_mvar3 : tvar array -> (term box * term box * term box) - -> tmbinder box * tmbinder box * tmbinder box = fun xs (t1, t2, t3) -> +let bind_mvar3 : tvar array -> (term * term * term) + -> tmbinder * tmbinder * tmbinder = fun xs (t1, t2, t3) -> bind_mvar xs t1, bind_mvar xs t2, bind_mvar xs t3 -(** [unbox e] can be called when the construction of a term is finished (e.g., - when the desired variables have all been bound). *) -let unbox : 'a box -> 'a = fun x -> x - -(** [box_array bs] shifts the [array] type of [bs] into the [box]. *) -let box_array : 'a box array -> 'a array box = fun x -> x - -(** [box_apply3] is similar to [box_apply2]. *) -let box_apply3 : ('a -> 'b -> 'c -> 'd) - -> 'a box -> 'b box -> 'c box -> 'd box = fun x -> x - -(** [box_pair ba bb] is the same as [box_apply2 (fun a b -> (a,b)) ba bb]. *) -let box_pair : 'a box -> 'b box -> ('a * 'b) box = fun x y -> x,y - -(** [box_triple] is similar to [box_pair], but for triples. *) -let box_triple : 'a box -> 'b box -> 'c box -> ('a * 'b * 'c) box = - fun x y z -> x,y,z - (** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to compare variables using [Pervasive.compare]. *) let compare_vars : tvar -> tvar -> int = fun (i,_) (j,_) -> Stdlib.compare i j @@ -446,8 +409,8 @@ let binder_constant : tbinder -> bool = fun b -> not (binder_occur b) (** [mbinder_arity b] gives the arity of the [mbinder]. *) let mbinder_arity : tmbinder -> int = fun (names,_) -> Array.length names -(** [is_closed b] checks whether the [box] [b] is closed. *) -let is_closed : term box -> bool = +(** [is_closed t] checks whether [t] is closed. *) +let is_closed : term -> bool = let rec check t = match unfold t with | Vari _ -> raise Exit @@ -460,10 +423,10 @@ let is_closed : term box -> bool = | _ -> () in fun t -> try check t; true with Exit -> false -let is_closed_tmbinder : tmbinder box -> bool = fun (_,t) -> is_closed t +let is_closed_tmbinder : tmbinder -> bool = fun (_,t) -> is_closed t -(** [occur x b] tells whether variable [x] occurs in the [box] [b]. *) -let occur : tvar -> term box -> bool = fun x -> +(** [occur x t] tells whether variable [x] occurs in [t]. *) +let occur : tvar -> term -> bool = fun x -> let rec check t = match unfold t with | Vari y when y == x -> raise Exit @@ -476,12 +439,10 @@ let occur : tvar -> term box -> bool = fun x -> | _ -> () in fun t -> try check t; false with Exit -> true -let occur_tmbinder : tvar -> tmbinder box -> bool = fun x (_,t) -> occur x t +let occur_tmbinder : tvar -> tmbinder -> bool = fun x (_,t) -> occur x t end -type tbox = term Bindlib.box - let unfold = Bindlib.unfold (** Printing functions for debug. *) @@ -505,7 +466,7 @@ type ctxt = (tvar * term * term option) list lifting terms several times. Definitions are not included because these contexts are used to create meta variables types, which do not use [let] definitions. *) -type bctxt = (tvar * tbox) list +type bctxt = (tvar * term) list (** Type of unification constraints. *) type constr = ctxt * term * term @@ -666,6 +627,7 @@ let mk_Type = Type let mk_Kind = Kind let mk_Symb x = Symb x let mk_Prod (a,b) = Prod (a,b) +let mk_Impl (a,b) = let x = new_tvar "_" in Prod(a, Bindlib.bind_var x b) let mk_Abst (a,b) = Abst (a,b) let mk_Meta (m,ts) = (*assert (m.meta_arity = Array.length ts);*) Meta (m,ts) let mk_Patt (i,s,ts) = Patt (i,s,ts) @@ -791,113 +753,6 @@ let add_args : term -> term list -> term = fun t ts -> let add_args_map : term -> (term -> term) -> term list -> term = fun t f ts -> List.fold_left (fun t u -> mk_Appl(t, f u)) t ts -(** {3 Smart constructors and lifting (related to [Bindlib])} *) - -(** [_Vari x] injects the free variable [x] into the {!type:tbox} type so that - it may be available for binding. *) -let _Vari : tvar -> tbox = fun x -> Vari x - -(** [_Type] injects the constructor [Type] into the {!type:tbox} type. *) -let _Type : tbox = Bindlib.box Type - -(** [_Kind] injects the constructor [Kind] into the {!type:tbox} type. *) -let _Kind : tbox = Bindlib.box Kind - -(** [_Symb s] injects the constructor [Symb(s)] into the {!type:tbox} type. As - symbols are closed object they do not require lifting. *) -let _Symb : sym -> tbox = fun s -> Bindlib.box (Symb s) - -(** [_Appl t u] lifts an application node to the {!type:tbox} type given boxed - terms [t] and [u]. *) -let _Appl : tbox -> tbox -> tbox = - Bindlib.box_apply2 (fun t u -> mk_Appl (t,u)) - -(** [_Appl_not_canonical t u] lifts an application node to the {!type:tbox} - type given boxed terms [t] and [u], without putting it in canonical form - wrt. C and AC symbols. WARNING: to use in scoping of rewrite rule LHS only - as it breaks some invariants. *) -let _Appl_not_canonical : tbox -> tbox -> tbox = - Bindlib.box_apply2 (fun t u -> Appl (t,u)) - -(** [_Appl_list a [b1;...;bn]] returns (... ((a b1) b2) ...) bn. *) -let _Appl_list : tbox -> tbox list -> tbox = List.fold_left _Appl - -(** [_Appl_Symb f ts] returns the same result that - _Appl_l ist (_Symb [f]) [ts]. *) -let _Appl_Symb : sym -> tbox list -> tbox = fun f ts -> - _Appl_list (_Symb f) ts - -(** [_Prod a b] lifts a dependent product node to the {!type:tbox} type, given - a boxed term [a] for the domain of the product, and a boxed binder [b] for - its codomain. *) -let _Prod : tbox -> tbinder Bindlib.box -> tbox = - Bindlib.box_apply2 (fun a b -> Prod(a,b)) - -let _Impl : tbox -> tbox -> tbox = - let v = new_tvar "_" in fun a b -> _Prod a (Bindlib.bind_var v b) - -(** [_Abst a t] lifts an abstraction node to the {!type:tbox} type, given a - boxed term [a] for the domain type, and a boxed binder [t]. *) -let _Abst : tbox -> tbinder Bindlib.box -> tbox = - Bindlib.box_apply2 (fun a t -> Abst(a,t)) - -(** [_Meta m ts] lifts the metavariable [m] to the {!type:tbox} type given its - environment [ts]. As for symbols in {!val:_Symb}, metavariables are closed - objects so they do not require lifting. *) -let _Meta : meta -> tbox array -> tbox = fun m ts -> - Bindlib.box_apply (fun ts -> Meta(m,ts)) (Bindlib.box_array ts) - -(** [_Meta_full m ts] is similar to [_Meta m ts] but works with a metavariable - that is boxed. This is useful in very rare cases, when metavariables need - to be able to contain free term environment variables. Using this function - in bad places is harmful for efficiency but not unsound. *) -let _Meta_full : meta Bindlib.box -> tbox array -> tbox = fun m ts -> - Bindlib.box_apply2 (fun m ts -> Meta(m,ts)) m (Bindlib.box_array ts) - -(** [_Patt i n ts] lifts a pattern variable to the {!type:tbox} type. *) -let _Patt : int option -> string -> tbox array -> tbox = fun i n ts -> - Bindlib.box_apply (fun ts -> Patt(i,n,ts)) (Bindlib.box_array ts) - -(** [_Wild] injects the constructor [Wild] into the {!type:tbox} type. *) -let _Wild : tbox = Bindlib.box Wild - -let _Plac : bool -> tbox = fun b -> - Bindlib.box (mk_Plac b) - -(** [_TRef r] injects the constructor [TRef(r)] into the {!type:tbox} type. It - should be the case that [!r] is [None]. *) -let _TRef : term option ref -> tbox = fun r -> - Bindlib.box (TRef(r)) - -(** [_LLet t a u] lifts let binding [let x := t : a in u]. *) -let _LLet : tbox -> tbox -> tbinder Bindlib.box -> tbox = - Bindlib.box_apply3 (fun a t u -> mk_LLet(a, t, u)) - -(** [lift mk_appl t] lifts the {!type:term} [t] to the type {!type:tbox}, - using the function [mk_appl] in the case of an application. This has the - effect of gathering its free variables, making them available for binding. - Bound variable names are automatically updated in the process. *) -let lift : (tbox -> tbox -> tbox) -> term -> tbox = fun _ t -> t - -(** [lift t] lifts the {!type:term} [t] to the type {!type:tbox}. This has the - effect of gathering its free variables, making them available for binding. - Bound variable names are automatically updated in the process. *) -let lift = lift _Appl -and lift_not_canonical = lift _Appl_not_canonical - -(** [bind v lift t] creates a tbinder by binding [v] in [lift t]. *) -let bind : tvar -> (term -> tbox) -> term -> tbinder = - fun v lift t -> Bindlib.unbox (Bindlib.bind_var v (lift t)) -let binds : tvar array -> (term -> tbox) -> term -> tmbinder = - fun vs lift t -> Bindlib.unbox (Bindlib.bind_mvar vs (lift t)) - -(** [cleanup t] builds a copy of the {!type:term} [t] where every instantiated - metavariable, instantiated term environment, and reference cell has been - eliminated using {!val:unfold}. Another effect of the function is that the - the names of bound variables are updated. This is useful to avoid any form - of "visual capture" while printing terms. *) -let cleanup : term -> term = fun t -> Bindlib.unbox (lift_not_canonical t) - (** Positions in terms in reverse order. The i-th argument of a constructor has position i-1. *) type subterm_pos = int list @@ -907,18 +762,11 @@ let subterm_pos : subterm_pos pp = fun ppf l -> D.(list int) ppf (List.rev l) (** Type of critical pair positions (pos,l,r,p,l_p). *) type cp_pos = Pos.popt * term * term * subterm_pos * term -(** [term_of_rhs r] converts the RHS (right hand side) of the rewriting rule - [r] into a term. The bound higher-order variables of the original RHS are - substituted using [Patt] constructors. They are thus represented as their - LHS counterparts. This is a more convenient way of representing terms when - analysing confluence or termination. *) -let term_of_rhs : rule -> term = fun r -> r.rhs - (** Type of a symbol and a rule. *) type sym_rule = sym * rule let lhs : sym_rule -> term = fun (s, r) -> add_args (mk_Symb s) r.lhs -let rhs : sym_rule -> term = fun (_, r) -> term_of_rhs r +let rhs : sym_rule -> term = fun (_, r) -> r.rhs (** Patt substitution. *) let subst_patt : tmbinder option array -> term -> term = fun env -> @@ -945,3 +793,21 @@ let subst_patt : tmbinder option array -> term -> term = fun env -> | Kind | Symb _ -> t in subst_patt + +(** [cleanup t] unfold all metas and TRef's in [t]. *) +let rec cleanup : term -> term = fun t -> + match unfold t with + | Patt(i,n,ts) -> mk_Patt(i, n, Array.map cleanup ts) + | Prod(a,(n,b)) -> mk_Prod(cleanup a, (n, cleanup b)) + | Abst(a,(n,b)) -> mk_Abst(cleanup a, (n, cleanup b)) + | Appl(a,b) -> mk_Appl(cleanup a, cleanup b) + | Meta(m,ts) -> mk_Meta(m, Array.map cleanup ts) + | LLet(a,t,(n,b)) -> mk_LLet(cleanup a, cleanup t, (n, cleanup b)) + | Wild -> assert false + | Plac _ -> assert false + | TRef _ -> assert false + | Vari _ -> assert false + | Db _ + | Type + | Kind + | Symb _ -> t diff --git a/src/core/term.mli b/src/core/term.mli index 0887d3db4..1c3d51256 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -236,38 +236,14 @@ val unbind2 : tbinder -> tbinder -> tvar * term * term create the fresh variables are based on those of the multiple binder. *) val unmbind : tmbinder -> tvar array * term -(** Type of a term under construction. Using this representation, - the free variable of the term can be bound easily. *) -type 'a box = 'a - -(** [box e] injects the value [e] into the [term box] type, assuming that it - is closed. Thus, if [e] contains variables, then they will not be - considered free. This means that no variable of [e] will be available for - binding. *) -val box : 'a -> 'a box - -(** [box_apply f ba] applies the function [f] to a boxed argument [ba]. It is - equivalent to [apply_box (box f) ba], but is more efficient. *) -val box_apply : ('a -> 'b) -> 'a box -> 'b box - (** [bind_var x b] binds the variable [x] in [b], producing a boxed binder. *) -val bind_var : tvar -> term box -> tbinder box +val bind_var : tvar -> term -> tbinder (** [bind_mvar xs b] binds the variables of [xs] in [b] to get a boxed binder. It is the equivalent of [bind_var] for multiple variables. *) -val bind_mvar : tvar array -> term box -> tmbinder box -val bind_mvar3 : tvar array -> (term box * term box * term box) - -> tmbinder box * tmbinder box * tmbinder box - -(** [unbox e] can be called when the construction of a term is finished (e.g., - when the desired variables have all been bound). *) -val unbox : 'a box -> 'a - -(** [box_pair ba bb] is the same as [box_apply2 (fun a b -> (a,b)) ba bb]. *) -val box_pair : 'a box -> 'b box -> ('a * 'b) box - -(** [box_triple] is similar to [box_pair], but for triples. *) -val box_triple : 'a box -> 'b box -> 'c box -> ('a * 'b * 'c) box +val bind_mvar : tvar array -> term -> tmbinder +val bind_mvar3 : tvar array -> (term * term * term) + -> tmbinder * tmbinder * tmbinder (** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to compare variables using [Pervasive.compare]. *) @@ -288,17 +264,15 @@ val binder_constant : tbinder -> bool val mbinder_arity : tmbinder -> int (** [is_closed b] checks whether the [box] [b] is closed. *) -val is_closed : term box -> bool -val is_closed_tmbinder : tmbinder box -> bool +val is_closed : term -> bool +val is_closed_tmbinder : tmbinder -> bool (** [occur x b] tells whether variable [x] occurs in the [box] [b]. *) -val occur : tvar -> term box -> bool -val occur_tmbinder : tvar -> tmbinder box -> bool +val occur : tvar -> term -> bool +val occur_tmbinder : tvar -> tmbinder -> bool end -type tbox = term Bindlib.box - (** Minimize [impl] to enforce our invariant (see {!type:Term.sym}). *) val minimize_impl : bool list -> bool list @@ -317,7 +291,7 @@ type ctxt = (tvar * term * term option) list lifting terms several times. Definitions are not included because these contexts are used to create meta variables types, which do not use [let] definitions. *) -type bctxt = (tvar * tbox) list +type bctxt = (tvar * term) list (** Type of unification constraints. *) type constr = ctxt * term * term @@ -431,6 +405,7 @@ val mk_Type : term val mk_Kind : term val mk_Symb : sym -> term val mk_Prod : term * tbinder -> term +val mk_Impl : term * term -> term val mk_Abst : term * tbinder -> term val mk_Appl : term * term -> term val mk_Meta : meta * term array -> term @@ -453,94 +428,6 @@ val add_args : term -> term list -> term more efficient. *) val add_args_map : term -> (term -> term) -> term list -> term -(** {3 Smart constructors and lifting (related to [Bindlib])} *) - -(** [_Vari x] injects the free variable [x] into the {!type:tbox} type so that - it may be available for binding. *) -val _Vari : tvar -> tbox - -(** [_Type] injects the constructor [Type] into the {!type:tbox} type. *) -val _Type : tbox - -(** [_Kind] injects the constructor [Kind] into the {!type:tbox} type. *) -val _Kind : tbox - -(** [_Symb s] injects the constructor [Symb(s)] into the {!type:tbox} type. As - symbols are closed object they do not require lifting. *) -val _Symb : sym -> tbox - -(** [_Appl t u] lifts an application node to the {!type:tbox} type given boxed - terms [t] and [u]. *) -val _Appl : tbox -> tbox -> tbox - -(** [_Appl_not_canonical t u] lifts an application node to the {!type:tbox} - type given boxed terms [t] and [u], without putting it in canonical form - wrt. C and AC symbols. WARNING: to use in scoping of rewrite rule LHS only - as it breaks some invariants. *) -val _Appl_not_canonical : tbox -> tbox -> tbox - -(** [_Appl_list a [b1;...;bn]] returns (... ((a b1) b2) ...) bn. *) -val _Appl_list : tbox -> tbox list -> tbox - -(** [_Appl_Symb f ts] returns the same result that - _Appl_l ist (_Symb [f]) [ts]. *) -val _Appl_Symb : sym -> tbox list -> tbox - -(** [_Prod a b] lifts a dependent product node to the {!type:tbox} type, given - a boxed term [a] for the domain of the product, and a boxed binder [b] for - its codomain. *) -val _Prod : tbox -> tbinder Bindlib.box -> tbox - -val _Impl : tbox -> tbox -> tbox - -(** [_Abst a t] lifts an abstraction node to the {!type:tbox} type, given a - boxed term [a] for the domain type, and a boxed binder [t]. *) -val _Abst : tbox -> tbinder Bindlib.box -> tbox - -(** [_Meta m ar] lifts the metavariable [m] to the {!type:tbox} type given its - environment [ar]. As for symbols in {!val:_Symb}, metavariables are closed - objects so they do not require lifting. *) -val _Meta : meta -> tbox array -> tbox - -(** [_Meta_full m ar] is similar to [_Meta m ar] but works with a metavariable - that is boxed. This is useful in very rare cases, when metavariables need - to be able to contain free term environment variables. Using this function - in bad places is harmful for efficiency but not unsound. *) -val _Meta_full : meta Bindlib.box -> tbox array -> tbox - -(** [_Patt i n ar] lifts a pattern variable to the {!type:tbox} type. *) -val _Patt : int option -> string -> tbox array -> tbox - -(** [_Wild] injects the constructor [Wild] into the {!type:tbox} type. *) -val _Wild : tbox - -(** [_Plac] injects the constructor [Plac] into the {!type:tbox} type. *) -val _Plac : bool -> tbox - -(** [_TRef r] injects the constructor [TRef(r)] into the {!type:tbox} type. It - should be the case that [!r] is [None]. *) -val _TRef : term option ref -> tbox - -(** [_LVal t a u] lifts val binding [val x := t : a in u]. *) -val _LLet : tbox -> tbox -> tbinder Bindlib.box -> tbox - -(** [lift t] lifts the {!type:term} [t] to the {!type:tbox} type. This has the - effect of gathering its free variables, making them available for binding. - Bound variable names are automatically updated in the process. *) -val lift : term -> tbox -val lift_not_canonical : term -> tbox - -(** [bind v lift t] creates a tbinder by binding [v] in [lift t]. *) -val bind : tvar -> (term -> tbox) -> term -> tbinder -val binds : tvar array -> (term -> tbox) -> term -> tmbinder - -(** [cleanup t] builds a copy of the {!type:term} [t] where every instantiated - metavariable, instantiated term environment, and reference cell has been - eliminated using {!val:unfold}. Another effect of the function is that the - the names of bound variables are updated. This is useful to avoid any form - of "visual capture" while printing terms. *) -val cleanup : term -> term - (** Positions in terms in reverse order. The i-th argument of a constructor has position i-1. *) type subterm_pos = int list @@ -550,13 +437,6 @@ val subterm_pos : subterm_pos pp (** Type of critical pair positions (pos,l,r,p,l_p). *) type cp_pos = Pos.popt * term * term * subterm_pos * term -(** [term_of_rhs r] converts the RHS (right hand side) of the rewriting rule - [r] into a term. The bound higher-order variables of the original RHS are - substituted using [Patt] constructors. They are thus represented as their - LHS counterparts. This is a more convenient way of representing terms when - analysing confluence or termination. *) -val term_of_rhs : rule -> term - (** Type of a symbol and a rule. *) type sym_rule = sym * rule @@ -565,3 +445,6 @@ val rhs : sym_rule -> term (** Patt substitution. *) val subst_patt : tmbinder option array -> term -> term + +(** [cleanup t] unfold all metas and TRef's in [t]. *) +val cleanup : term -> term diff --git a/src/core/unif.ml b/src/core/unif.ml index 185b04fb5..4d64b1779 100644 --- a/src/core/unif.ml +++ b/src/core/unif.ml @@ -18,22 +18,22 @@ let set_to_prod : problem -> meta -> unit = fun p m -> let n = m.meta_arity in let env, s = Env.of_prod_nth [] n !(m.meta_type) in let vs = Env.vars env in - let xs = Array.map _Vari vs in + let xs = Array.map mk_Vari vs in (* domain *) - let u1 = Env.to_prod env _Type in + let u1 = Env.to_prod env mk_Type in let m1 = LibMeta.fresh p u1 n in - let a = _Meta m1 xs in + let a = mk_Meta (m1, xs) in (* codomain *) let y = new_tvar "y" in - let env' = Env.add "y" y (_Meta m1 xs) None env in - let u2 = Env.to_prod env' (lift s) in + let env' = Env.add "y" y (mk_Meta (m1, xs)) None env in + let u2 = Env.to_prod env' s in let m2 = LibMeta.fresh p u2 (n+1) in - let b = Bindlib.bind_var y (_Meta m2 (Array.append xs [|_Vari y|])) in + let b = Bindlib.bind_var y (mk_Meta (m2, Array.append xs [|mk_Vari y|])) in (* result *) - let r = _Prod a b in + let r = mk_Prod (a, b) in if Logger.log_enabled () then - log (red "%a ≔ %a") meta m term (Bindlib.unbox r); - LibMeta.set p m (Bindlib.unbox (Bindlib.bind_mvar vs r)) + log (red "%a ≔ %a") meta m term r; + LibMeta.set p m (Bindlib.bind_mvar vs r) (** [type_app c a ts] returns [Some u] where [u] is a type of [add_args x ts] in context [c] where [x] is any term of type [a] if [x] can be applied to @@ -101,15 +101,14 @@ let instantiable : ctxt -> meta -> term array -> term -> bool = be instantiated and returns the corresponding instantiation, simplified. It does not check whether the instantiation is closed though. *) let instantiation : - ctxt -> meta -> term array -> term -> tmbinder Bindlib.box option = + ctxt -> meta -> term array -> term -> tmbinder option = fun c m ts u -> match nl_distinct_vars c ts with | None -> None | Some(vs, map) -> if LibMeta.occurs m c u then None else let u = Eval.simplify (Ctxt.to_let c (sym_to_var map u)) in - Some (Logger.set_debug_in false 'm' - (Bindlib.bind_mvar vs) (lift u)) + Some (Logger.set_debug_in false 'm' (Bindlib.bind_mvar vs) u) (** Checking type or not during meta instanciation. *) let do_type_check = Stdlib.ref true @@ -124,7 +123,7 @@ let instantiate : problem -> ctxt -> meta -> term array -> term -> bool = | Some b when Bindlib.is_closed_tmbinder b -> let do_instantiate() = if Logger.log_enabled () then log (red "%a ≔ %a") meta m term u; - LibMeta.set p m (Bindlib.unbox b); + LibMeta.set p m b; p := {!p with recompute = true}; true in if Stdlib.(!do_type_check) then @@ -216,14 +215,14 @@ let imitate_inj : if i <= 0 then add_args (mk_Symb s) (List.rev acc) else match unfold t with | Prod(a,b) -> - let m = LibMeta.fresh p (Env.to_prod env (lift a)) k in + let m = LibMeta.fresh p (Env.to_prod env a) k in let u = mk_Meta (m,vs) in build (i-1) (u::acc) (Bindlib.subst b u) | _ -> raise Cannot_imitate in build (List.length ts) [] !(s.sym_type) in if Logger.log_enabled () then log (red "%a ≔ %a") meta m term t; - LibMeta.set p m (binds vars lift t); true + LibMeta.set p m (Bindlib.bind_mvar vars t); true with Cannot_imitate | Invalid_argument _ -> false (** [imitate_lam_cond h ts] tells whether [ts] is headed by a variable not @@ -233,7 +232,7 @@ let imitate_lam_cond : term -> term list -> bool = fun h ts -> | [] -> false | e :: _ -> match unfold e with - | Vari x -> not (Bindlib.occur x (lift h)) + | Vari x -> not (Bindlib.occur x h) | _ -> false (** For a problem of the form [Appl(m[ts],[Vari x;_]) ≡ _], where [m] is a @@ -253,9 +252,8 @@ let imitate_lam : problem -> ctxt -> meta -> unit = fun p c m -> let env, t = Env.of_prod_nth c n !(m.meta_type) in let of_prod a b = let x,b = LibTerm.unbind_name "x" b in - let a = lift a in let env' = Env.add "x" x a None env in - x, a, env', lift b + x, a, env', b in let x, a, env', b = match Eval.whnf c t with @@ -268,26 +266,26 @@ let imitate_lam : problem -> ctxt -> meta -> unit = fun p c m -> | _ -> assert false end | _ -> - let tm2 = Env.to_prod env _Type in + let tm2 = Env.to_prod env mk_Type in let m2 = LibMeta.fresh p tm2 n in - let a = _Meta m2 (Env.to_tbox env) in + let a = mk_Meta (m2, Env.to_tbox env) in let x = new_tvar "x" in let env' = Env.add "x" x a None env in - let tm3 = Env.to_prod env' _Type in + let tm3 = Env.to_prod env' mk_Type in let m3 = LibMeta.fresh p tm3 (n+1) in - let b = _Meta m3 (Env.to_tbox env') in - let u = Bindlib.unbox (_Prod a (Bindlib.bind_var x b)) in + let b = mk_Meta (m3, Env.to_tbox env') in + let u = mk_Prod (a, Bindlib.bind_var x b) in add_constr p (Env.to_ctxt env, u, t); x, a, env', b in let tm1 = Env.to_prod env' b in let m1 = LibMeta.fresh p tm1 (n+1) in - let u1 = _Meta m1 (Env.to_tbox env') in - let xu1 = _Abst a (Bindlib.bind_var x u1) in + let u1 = mk_Meta (m1, Env.to_tbox env') in + let xu1 = mk_Abst (a, Bindlib.bind_var x u1) in let v = Bindlib.bind_mvar (Env.vars env) xu1 in if Logger.log_enabled () then - log (red "%a ≔ %a") meta m term (Bindlib.unbox xu1); - LibMeta.set p m (Bindlib.unbox v) + log (red "%a ≔ %a") meta m term xu1; + LibMeta.set p m v (** [inverse_opt s ts v] returns [Some(t, inverse s v)] if [ts=[t]], [s] is injective and [inverse s v] does not fail, and [None] otherwise. *) diff --git a/src/export/xtc.ml b/src/export/xtc.ml index 048476e49..ed2bb436a 100644 --- a/src/export/xtc.ml +++ b/src/export/xtc.ml @@ -131,7 +131,7 @@ let get_vars : sym -> rule -> (string * Term.term) list = fun s r -> | Symb (_) -> t | Abst (t1, b) -> let (x,t2) = Bindlib.unbind b in - mk_Abst(subst_patt v t1, bind x lift (subst_patt v t2)) + mk_Abst(subst_patt v t1, Bindlib.bind_var x (subst_patt v t2)) | Appl (t1, t2) -> mk_Appl(subst_patt v t1, subst_patt v t2) | Patt (None, _, _) -> assert false | Patt (Some(i), _, a) -> diff --git a/src/handle/command.ml b/src/handle/command.ml index b80e6979c..3bec4dfb4 100644 --- a/src/handle/command.ml +++ b/src/handle/command.ml @@ -28,10 +28,11 @@ let _ = register "0" expected_zero_type; let expected_succ_type ss _pos = let typ_0 = - try lift !((StrMap.find "0" ss.builtins).sym_type) - with Not_found -> _Meta (LibMeta.fresh (new_problem()) mk_Type 0) [||] + try !((StrMap.find "0" ss.builtins).sym_type) + with Not_found -> + mk_Meta (LibMeta.fresh (new_problem()) mk_Type 0, [||]) in - Bindlib.unbox (_Impl typ_0 typ_0) + mk_Impl (typ_0, typ_0) in register "+1" expected_succ_type diff --git a/src/handle/inductive.ml b/src/handle/inductive.ml index 0518e6f77..780654d12 100644 --- a/src/handle/inductive.ml +++ b/src/handle/inductive.ml @@ -36,8 +36,8 @@ let get_config : Sig_state.t -> Pos.popt -> config = fun ss pos -> (** [prf_of p c ts t] returns the term [c.symb_prf (p t1 ... tn t)] where ts = [ts1;...;tsn]. *) -let prf_of : config -> tvar -> tbox list -> tbox -> tbox = fun c p ts t -> - _Appl_Symb c.symb_prf [_Appl (_Appl_list (_Vari p) ts) t] +let prf_of : config -> tvar -> term list -> term -> term = fun c p ts t -> + mk_Appl (mk_Symb c.symb_prf, mk_Appl (add_args (mk_Vari p) ts, t)) (** compute safe prefixes for predicate and constructor argument variables. *) let gen_safe_prefixes : inductive -> string * string * string = @@ -71,25 +71,25 @@ let gen_safe_prefixes : inductive -> string * string * string = (** Type of maps associating to every inductive type some data useful for generating the induction principles. *) type data = { ind_var : tvar (** predicate variable *) - ; ind_type : tbox (** predicate variable type *) - ; ind_conclu : tbox (** induction principle conclusion *) } + ; ind_type : term (** predicate variable type *) + ; ind_conclu : term (** induction principle conclusion *) } type ind_pred_map = (sym * data) list (** [ind_typ_with_codom pos ind_sym ind_env codom s a] assumes that [a] is of - the form [Π(i1:a1),...,Π(in:an), TYPE]. It then generates a [tbox] similar + the form [Π(i1:a1),...,Π(in:an), TYPE]. It then generates a [term] similar to this type except that [TYPE] is replaced by [codom [i1;...;in]]. The string [x_str] is used as prefix for the variables [ik]. *) let ind_typ_with_codom : - popt -> sym -> Env.t -> (tbox list -> tbox) -> string -> term -> tbox = + popt -> sym -> Env.t -> (term list -> term) -> string -> term -> term = fun pos ind_sym env codom x_str a -> let i = Stdlib.ref (-1) in - let rec aux : tvar list -> term -> tbox = fun xs a -> + let rec aux : tvar list -> term -> term = fun xs a -> match get_args a with - | (Type, _) -> codom (List.rev_map _Vari xs) + | (Type, _) -> codom (List.rev_map mk_Vari xs) | (Prod(a,b), _) -> let name = Stdlib.(incr i; x_str ^ string_of_int (!i)) in let (x,b) = LibTerm.unbind_name name b in - _Prod (lift a) (Bindlib.bind_var x (aux (x::xs) b)) + mk_Prod (a, Bindlib.bind_var x (aux (x::xs) b)) | _ -> fatal pos "The type of %a is not supported" sym ind_sym in aux (List.map (fun (_,(v,_,_)) -> v) env) a @@ -116,15 +116,16 @@ let create_ind_pred_map : (* predicate variable *) let ind_var = new_tvar_ind p_str i in (* predicate type *) - let codom ts = _Impl (_Appl_Symb ind_sym ts) (_Symb c.symb_Prop) in + let codom ts = + mk_Impl (add_args (mk_Symb ind_sym) ts, mk_Symb c.symb_Prop) in let a = snd (Env.of_prod_using [] vs !(ind_sym.sym_type)) in let ind_type = ind_typ_with_codom pos ind_sym env codom x_str a in (* predicate conclusion *) let codom ts = let x = new_tvar x_str in let t = Bindlib.bind_var x - (prf_of c ind_var (List.remove_heads arity ts) (_Vari x)) in - _Prod (_Appl_Symb ind_sym ts) t + (prf_of c ind_var (List.remove_heads arity ts) (mk_Vari x)) in + mk_Prod (add_args (mk_Symb ind_sym) ts, t) in let ind_conclu = ind_typ_with_codom pos ind_sym env codom x_str a in (ind_sym, {ind_var; ind_type; ind_conclu}) @@ -241,26 +242,26 @@ let gen_rec_types : (* [case_of ind_sym cons_sym] creates the clause for the constructor [cons_sym] in the induction principle of [ind_sym]. *) - let case_of : sym -> sym -> tbox = fun ind_sym cons_sym -> - (* 'var = tvar, 'a = unit, 'aux = unit, 'c = tbox *) + let case_of : sym -> sym -> term = fun ind_sym cons_sym -> + (* 'var = tvar, 'a = unit, 'aux = unit, 'c = term *) (* the accumulator is not used *) let inj_var _ x = x in let init = () in (* aux computes the induction hypothesis *) let aux env _ p ts x = - let v = Env.appl (_Vari x) env in - let v = prf_of c p (List.map lift (List.remove_heads n ts)) v in - Env.to_prod_box env v + let v = Env.appl (mk_Vari x) env in + let v = prf_of c p (List.remove_heads n ts) v in + Env.to_prod env v in let acc_rec_dom _ _ _ = () in let rec_dom t x v next = - _Prod (lift t) (Bindlib.bind_var x (_Impl v next)) + mk_Prod (t, Bindlib.bind_var x (mk_Impl (v, next))) in let acc_nonrec_dom _ _ = () in - let nonrec_dom t x next = _Prod (lift t) (Bindlib.bind_var x next) in + let nonrec_dom t x next = mk_Prod (t, Bindlib.bind_var x next) in let codom xs _ p ts = - prf_of c p (List.map lift (List.remove_heads n ts)) - (_Appl_Symb cons_sym (List.rev_map _Vari xs)) + prf_of c p (List.remove_heads n ts) + (add_args (mk_Symb cons_sym) (List.rev_map mk_Vari xs)) in fold_cons_type pos ind_pred_map x_str ind_sym vs cons_sym inj_var init aux acc_rec_dom rec_dom acc_nonrec_dom nonrec_dom codom @@ -269,17 +270,17 @@ let gen_rec_types : (* Generates an induction principle for each type. *) let gen_rec_type (_, d) = let add_clause_cons ind_sym cons_sym t = - _Impl (case_of ind_sym cons_sym) t + mk_Impl (case_of ind_sym cons_sym, t) in let add_clauses_ind (ind_sym, cons_sym_list) t = List.fold_right (add_clause_cons ind_sym) cons_sym_list t in let rec_typ = List.fold_right add_clauses_ind ind_list d.ind_conclu in let add_quantifier t (_,d) = - _Prod d.ind_type (Bindlib.bind_var d.ind_var t) in + mk_Prod (d.ind_type, Bindlib.bind_var d.ind_var t) in let rec_typ = List.fold_left add_quantifier rec_typ ind_pred_map in - let rec_typ = Env.to_prod_box env rec_typ in - Bindlib.unbox rec_typ + let rec_typ = Env.to_prod env rec_typ in + rec_typ in List.map gen_rec_type ind_pred_map diff --git a/src/handle/proof.ml b/src/handle/proof.ml index cb9794f14..24467d3e9 100644 --- a/src/handle/proof.ml +++ b/src/handle/proof.ml @@ -59,9 +59,7 @@ module Goal = struct (** [hyps ppf g] prints on [ppf] the hypotheses of the goal [g]. *) let hyps : goal pp = - let env_elt ppf (s,(_,t,_)) = - out ppf "%a: %a" uid s term (Bindlib.unbox t) - in + let env_elt ppf (s,(_,t,_)) = out ppf "%a: %a" uid s term t in let ctx_elt ppf (x,a,t) = out ppf "%a: %a" var x term a; match t with diff --git a/src/handle/rewrite.ml b/src/handle/rewrite.ml index 19349038c..ad07abd28 100644 --- a/src/handle/rewrite.ml +++ b/src/handle/rewrite.ml @@ -55,12 +55,12 @@ let _ = (* [Π (a:U), T a → T a → Prop] *) let symb_T = Builtin.get pos map "T" in let symb_P = Builtin.get pos map "P" in - let term_U = lift (get_domain_of_type symb_T) in - let term_Prop = lift (get_domain_of_type symb_P) in + let term_U = get_domain_of_type symb_T in + let term_Prop = get_domain_of_type symb_P in let a = new_tvar "a" in - let term_T_a = _Appl (_Symb symb_T) (_Vari a) in - let impls = _Impl term_T_a (_Impl term_T_a term_Prop) in - Bindlib.unbox (_Prod term_U (Bindlib.bind_var a impls)) + let term_T_a = mk_Appl (mk_Symb symb_T, mk_Vari a) in + let impls = mk_Impl (term_T_a, mk_Impl (term_T_a, term_Prop)) in + mk_Prod (term_U, Bindlib.bind_var a impls) in register_builtin "eq" expected_eq_type; let expected_refl_type pos map = @@ -68,41 +68,42 @@ let _ = let symb_T = Builtin.get pos map "T" in let symb_P = Builtin.get pos map "P" in let symb_eq = Builtin.get pos map "eq" in - let term_U = lift (get_domain_of_type symb_T) in + let term_U = get_domain_of_type symb_T in let a = new_tvar "a" in let x = new_tvar "x" in - let appl_eq = _Appl (_Symb symb_eq) (_Vari a) in - let appl_eq = _Appl (_Appl appl_eq (_Vari x)) (_Vari x) in - let appl = _Appl (_Symb symb_P) appl_eq in - let term_T_a = _Appl (_Symb symb_T) (_Vari a) in - let prod = _Prod term_T_a (Bindlib.bind_var x appl) in - Bindlib.unbox (_Prod term_U (Bindlib.bind_var a prod)) + let appl_eq = mk_Appl (mk_Symb symb_eq, mk_Vari a) in + let appl_eq = mk_Appl (mk_Appl (appl_eq, mk_Vari x), mk_Vari x) in + let appl = mk_Appl (mk_Symb symb_P, appl_eq) in + let term_T_a = mk_Appl (mk_Symb symb_T, mk_Vari a) in + let prod = mk_Prod (term_T_a, Bindlib.bind_var x appl) in + mk_Prod (term_U, Bindlib.bind_var a prod) in register_builtin "refl" expected_refl_type; let expected_eqind_type pos map = (* [Π (a:U) (x y:T a), P (eq x y) → Π (p:T a→Prop), P (p y) → P (p x)] *) let symb_T = Builtin.get pos map "T" in - let term_T = _Symb symb_T in + let term_T = mk_Symb symb_T in let symb_P = Builtin.get pos map "P" in - let term_P = _Symb symb_P in + let term_P = mk_Symb symb_P in let symb_eq = Builtin.get pos map "eq" in - let term_eq = _Symb symb_eq in - let term_U = lift (get_domain_of_type symb_T) in - let term_Prop = lift (get_domain_of_type symb_P) in + let term_eq = mk_Symb symb_eq in + let term_U = get_domain_of_type symb_T in + let term_Prop = get_domain_of_type symb_P in let a = new_tvar "a" in let x = new_tvar "x" in let y = new_tvar "y" in let p = new_tvar "p" in - let term_T_a = _Appl term_T (_Vari a) in - let term_P_p_x = _Appl term_P (_Appl (_Vari p) (_Vari x)) in - let term_P_p_y = _Appl term_P (_Appl (_Vari p) (_Vari y)) in - let impl = _Impl term_P_p_y term_P_p_x in - let prod = _Prod (_Impl term_T_a term_Prop) (Bindlib.bind_var p impl) in - let eq = _Appl (_Appl (_Appl term_eq (_Vari a)) (_Vari x)) (_Vari y) in - let impl = _Impl (_Appl term_P eq) prod in - let prod = _Prod term_T_a (Bindlib.bind_var y impl) in - let prod = _Prod term_T_a (Bindlib.bind_var x prod) in - Bindlib.unbox (_Prod term_U (Bindlib.bind_var a prod)) + let term_T_a = mk_Appl (term_T, mk_Vari a) in + let term_P_p_x = mk_Appl (term_P, mk_Appl (mk_Vari p, mk_Vari x)) in + let term_P_p_y = mk_Appl (term_P, mk_Appl (mk_Vari p, mk_Vari y)) in + let impl = mk_Impl (term_P_p_y, term_P_p_x) in + let prod = + mk_Prod (mk_Impl (term_T_a, term_Prop), Bindlib.bind_var p impl) in + let eq = add_args term_eq [mk_Vari a; mk_Vari x; mk_Vari y] in + let impl = mk_Impl (mk_Appl(term_P, eq), prod) in + let prod = mk_Prod (term_T_a, Bindlib.bind_var y impl) in + let prod = mk_Prod (term_T_a, Bindlib.bind_var x prod) in + mk_Prod (term_U, Bindlib.bind_var a prod) in register_builtin "eqind" expected_eqind_type @@ -208,7 +209,7 @@ let matches : term -> term -> bool = let matching_subs : to_subst -> term -> term array option = fun (xs,p) t -> (* We replace [xs] by fresh [TRef]'s. *) let ts = Array.map (fun _ -> mk_TRef(ref None)) xs in - let p = Bindlib.msubst (binds xs lift_not_canonical p) ts in + let p = Bindlib.msubst (Bindlib.bind_mvar xs p) ts in if matches p t then Some(Array.map unfold ts) else None (** [find_subst (xs,p) t] tries to find the first instance of a subterm of [t] @@ -259,28 +260,28 @@ let find_subterm_matching : term -> term -> bool = fun p t -> [p] by a fresh variable, and returns the binder on this variable. *) let bind_pattern : term -> term -> tbinder = fun p t -> let z = new_tvar "z" in - let rec replace : term -> tbox = fun t -> - if matches p t then _Vari z else + let rec replace : term -> term = fun t -> + if matches p t then mk_Vari z else match unfold t with - | Appl(t,u) -> _Appl (replace t) (replace u) + | Appl(t,u) -> mk_Appl (replace t, replace u) | Prod(a,b) -> let x,b = Bindlib.unbind b in - _Prod (replace a) (Bindlib.bind_var x (replace b)) + mk_Prod (replace a, Bindlib.bind_var x (replace b)) | Abst(a,b) -> let x,b = Bindlib.unbind b in - _Abst (replace a) (Bindlib.bind_var x (replace b)) + mk_Abst (replace a, Bindlib.bind_var x (replace b)) | LLet(typ, def, body) -> let x, body = Bindlib.unbind body in - _LLet (replace typ) (replace def) (Bindlib.bind_var x (replace body)) - | Meta(m,ts) -> _Meta m (Array.map replace ts) + mk_LLet (replace typ, replace def, Bindlib.bind_var x (replace body)) + | Meta(m,ts) -> mk_Meta (m, Array.map replace ts) | Db _ -> assert false | Wild -> assert false | TRef _ -> assert false | Patt _ -> assert false | Plac _ -> assert false - | _ -> lift t + | _ -> t in - Bindlib.(unbox (bind_var z (replace t))) + Bindlib.bind_var z (replace t) (** [swap cfg a r l t] returns a term of type [P (eq a l r)] from a term [t] of type [P (eq a r l)]. *) @@ -290,7 +291,7 @@ let swap : eq_config -> term -> term -> term -> term -> term = let pred = let x = new_tvar "x" in let pred = add_args (mk_Symb cfg.symb_eq) [a; l; mk_Vari x] in - mk_Abst(mk_Appl(mk_Symb cfg.symb_T, a), bind x lift pred) + mk_Abst(mk_Appl(mk_Symb cfg.symb_T, a), Bindlib.bind_var x pred) in (* We build the proof term. *) let refl_a_l = add_args (mk_Symb cfg.symb_refl) [a; l] in @@ -333,11 +334,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> let (t, l, r) = if l2r then (t, l, r) else (swap cfg a l r t, r, l) in (* Bind the variables in this new witness. *) - let bound = - let triple = - Bindlib.box_triple (lift t) (lift_not_canonical l) (lift r) in - Bindlib.unbox (Bindlib.bind_mvar3 vars triple) - in + let bound = Bindlib.bind_mvar3 vars (t,l,r) in (* Extract the term from the goal type (get “u” from “P u”). *) let g_term = @@ -413,7 +410,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> let new_term = Bindlib.subst pred_bind p_r in let (x, p_x) = Bindlib.unbind p_x in let pred = Bindlib.subst pred_bind p_x in - let pred_bind = bind x lift pred in + let pred_bind = Bindlib.bind_var x pred in (pred_bind, new_term, t, l, r) | Some(Rw_IdInTerm(p)) -> @@ -440,7 +437,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> fatal pos "The pattern [%a] does not match [%a]." term p term l in - let pat = bind id lift_not_canonical p_refs in + let pat = Bindlib.bind_var id p_refs in (* The LHS of the pattern, i.e. the pattern with id replaced by *) (* id_val. *) let pat_l = Bindlib.subst pat id_val in @@ -474,7 +471,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> (* [l_x] is the pattern with [id] replaced by the variable X *) (* that we use for building the predicate. *) let (x, l_x) = Bindlib.unbind pat in - let pred_bind = bind x lift (Bindlib.subst pred_bind_l l_x) in + let pred_bind = Bindlib.bind_var x (Bindlib.subst pred_bind_l l_x) in (pred_bind, new_term, t, l, r) (* Combinational patterns. *) @@ -500,7 +497,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> let id_val = id_val.(0) in (* [pat] is the full value of the pattern, with the wildcards now replaced by subterms of the goal and [id]. *) - let pat = bind id lift_not_canonical p_refs in + let pat = Bindlib.bind_var id p_refs in let pat_l = Bindlib.subst pat id_val in (* We then try to match the wildcards in [s] with subterms of @@ -550,7 +547,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> (* The last step to build the predicate is to substitute [l_x] everywhere we find [pat_l] and bind that x. *) let pred = Bindlib.subst pred_bind_l l_x in - (bind x lift pred, new_term, t, l, r) + (Bindlib.bind_var x pred, new_term, t, l, r) | Some(Rw_TermAsIdInTerm(s,p)) -> (* This pattern is essentially a let clause. We first match the value @@ -594,7 +591,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> let pred_bind = bind_pattern p g_term in let new_term = Bindlib.subst pred_bind p_r in let (x, p_x) = Bindlib.unbind p_x in - let pred_bind = bind x lift (Bindlib.subst pred_bind p_x) in + let pred_bind = Bindlib.bind_var x (Bindlib.subst pred_bind p_x) in (pred_bind, new_term, t, l, r) | Some(Rw_InIdInTerm(q)) -> @@ -612,7 +609,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> term q term g_term in let id_val = id_val.(0) in - let pat = bind id lift_not_canonical q_refs in + let pat = Bindlib.bind_var id q_refs in let pat_l = Bindlib.subst pat id_val in let sigma = match find_subst (vars,l) id_val with @@ -634,7 +631,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> let pred_bind_l = bind_pattern pat_l g_term in let new_term = Bindlib.subst pred_bind_l r_val in let l_x = Bindlib.subst pat id_x in - let pred_bind = bind x lift (Bindlib.subst pred_bind_l l_x) in + let pred_bind = Bindlib.bind_var x (Bindlib.subst pred_bind_l l_x) in (pred_bind, new_term, t, l, r) in diff --git a/src/handle/tactic.ml b/src/handle/tactic.ml index 9584d2d64..efa90be64 100644 --- a/src/handle/tactic.ml +++ b/src/handle/tactic.ml @@ -45,8 +45,8 @@ let add_axiom : Sig_state.t -> popt -> meta -> Sig_state.t = metavariable. *) let meta_value = let vars = Array.init m.meta_arity (new_tvar_ind "x") in - let ax = _Appl_Symb sym (Array.to_list vars |> List.map _Vari) in - Bindlib.(bind_mvar vars ax |> unbox) + let ax = add_args (mk_Symb sym) (List.map mk_Vari (Array.to_list vars)) in + Bindlib.bind_mvar vars ax in LibMeta.set (new_problem()) m meta_value; ss @@ -112,7 +112,7 @@ let tac_refine : | Some t -> if Logger.log_enabled () then log_tact (Color.red "%a ≔ %a") meta gt.goal_meta term t; - LibMeta.set p gt.goal_meta (binds (Env.vars gt.goal_hyps) lift t); + LibMeta.set p gt.goal_meta (Bindlib.bind_mvar (Env.vars gt.goal_hyps) t); (* Convert the metas and constraints of [p] not in [gs] into new goals. *) if Logger.log_enabled () then log_tact "%a" problem p; tac_solve pos {ps with proof_goals = Proof.add_goals_of_problem p gs} @@ -250,10 +250,10 @@ let handle : try let p = new_problem() in let e2, x, e1 = List.split (fun (s,_) -> s = id) env in - let u = lift gt.goal_type in - let q = Env.to_prod_box [x] (Env.to_prod_box e2 u) in + let u = gt.goal_type in + let q = Env.to_prod [x] (Env.to_prod e2 u) in let m = LibMeta.fresh p (Env.to_prod e1 q) (List.length e1) in - let me1 = Bindlib.unbox (_Meta m (Env.to_tbox e1)) in + let me1 = mk_Meta (m, Env.to_tbox e1) in let t = List.fold_left (fun t (_,(v,_,_)) -> mk_Appl(t, mk_Vari v)) me1 (x::e2) @@ -275,16 +275,13 @@ let handle : | Some t -> (* Create a new goal of type [t]. *) let n = List.length env in - let bt = lift t in - let m1 = LibMeta.fresh p (Env.to_prod env bt) n in + let m1 = LibMeta.fresh p (Env.to_prod env t) n in (* Refine the focused goal. *) let v = new_tvar id.elt in - let env' = Env.add id.elt v bt None env in - let m2 = - LibMeta.fresh p (Env.to_prod env' (lift gt.goal_type)) (n+1) - in + let env' = Env.add id.elt v t None env in + let m2 = LibMeta.fresh p (Env.to_prod env' gt.goal_type) (n+1) in let ts = Env.to_tbox env in - let u = Bindlib.unbox (_Meta m2 (Array.append ts [|_Meta m1 ts|])) in + let u = mk_Meta (m2, Array.append ts [|mk_Meta (m1, ts)|]) in tac_refine pos ps gt gs p u end | P_tac_induction -> tac_induction pos ps gt gs diff --git a/src/handle/why3_tactic.ml b/src/handle/why3_tactic.ml index ebb51f841..482c9ce25 100644 --- a/src/handle/why3_tactic.ml +++ b/src/handle/why3_tactic.ml @@ -190,7 +190,7 @@ let encode : Sig_state.t -> Pos.popt -> Env.env -> term -> Why3.Task.task = let cfg = get_config ss pos in let (constants, types, hyps) = let translate_hyp (tbl,ty_tbl, map) (name, (_, hyp, _)) = - match translate_term cfg tbl ty_tbl (Bindlib.unbox hyp) with + match translate_term cfg tbl ty_tbl hyp with | Some(tbl, ty_tbl, why3_hyp) -> (tbl, ty_tbl, StrMap.add name why3_hyp map) | None -> (tbl, ty_tbl , map) diff --git a/src/parsing/scope.ml b/src/parsing/scope.ml index b1b40b5fb..84eb889ee 100644 --- a/src/parsing/scope.ml +++ b/src/parsing/scope.ml @@ -22,17 +22,17 @@ let log_scop = log_scop.pp is true, protected symbols from external modules are allowed (protected symbols from current modules are always allowed). If [prv] is true, private symbols are allowed. *) -let find_qid : bool -> bool -> sig_state -> env -> p_qident -> tbox = +let find_qid : bool -> bool -> sig_state -> env -> p_qident -> term = fun prt prv ss env qid -> if Logger.log_enabled () then log_scop "find_qid %a" Pretty.qident qid; let (mp, s) = qid.elt in (* Check for variables in the environment first. *) try if mp <> [] then raise Not_found; (* Variables cannot be qualified. *) - _Vari (Env.find s env) + mk_Vari (Env.find s env) with Not_found -> (* Check for symbols. *) - _Symb (find_sym ~prt ~prv ss qid) + mk_Symb (find_sym ~prt ~prv ss qid) (** [get_root ss env t] returns the symbol at the root of the term [t]. *) let get_root : sig_state -> Env.t -> p_term -> sym = fun ss env t -> @@ -100,7 +100,7 @@ type mode = always have [m_urhs_vars_nb = m_lhs_size + length m_urhs_xvars]. *) (** [scope_iden md ss env qid] scopes [qid] as a symbol. *) -let scope_iden : mode -> sig_state -> env -> p_qident -> tbox = +let scope_iden : mode -> sig_state -> env -> p_qident -> term = fun md ss env qid -> let prt = match md with M_LHS _ -> true | _ -> false and prv = @@ -114,7 +114,7 @@ let scope_iden : mode -> sig_state -> env -> p_qident -> tbox = (** [fresh_patt name ts] creates a unique pattern variable applied to [ts]. [name] is used as suffix if distinct from [None]. *) -let fresh_patt : lhs_data -> string option -> tbox array -> tbox = +let fresh_patt : lhs_data -> string option -> term array -> term = fun data nopt ts -> let fresh_index () = let i = data.m_lhs_size in @@ -130,10 +130,10 @@ let fresh_patt : lhs_data -> string option -> tbox array -> tbox = Hashtbl.add data.m_lhs_indices name i; Hashtbl.add data.m_lhs_names i name; i in - _Patt (Some i) name ts + mk_Patt (Some i, name, ts) | None -> let i = fresh_index () in - _Patt (Some i) (string_of_int i) ts + mk_Patt (Some i, string_of_int i, ts) (** [is_invalid_bindlib_id s] says whether [s] can be safely used as variable name in Bindlib. Indeed, because Bindlib converts any suffix consisting of @@ -185,14 +185,14 @@ let pp_env : env Base.pp = into symbols according to [find_qid]. If [typ] is true, then [t] must be a type (defaults to false). *) let rec scope : ?typ:bool -> int -> mode -> sig_state -> env -> p_term -> - tbox = + term = fun ?(typ=false) k md ss env t -> scope_parsed ~typ k md ss env (Pratt.parse ss env t) (** [scope_parsed ~typ md ss env t] turns a parser-level, Pratt-parsed term [t] into an actual term. *) and scope_parsed : - ?typ:bool -> int -> mode -> sig_state -> env -> p_term -> tbox = + ?typ:bool -> int -> mode -> sig_state -> env -> p_term -> term = fun ?(typ=false) k md ss env t -> if Logger.log_enabled () then log_scop "%a<= %a@ %a" D.depth k pp_env env Pretty.term t; @@ -219,7 +219,7 @@ and scope_parsed : | P_Iden (_, false) -> (* We avoid unboxing if [h] is not closed (and hence not a symbol). *) if Bindlib.is_closed h then - match Bindlib.unbox h with + match h with | Symb s -> s.sym_impl | _ -> [] else [] @@ -234,19 +234,18 @@ and scope_parsed : in (* Scope and insert the (implicit) arguments. *) add_impl k md ss env t.pos h impl args - |> D.log_and_return - (fun e -> log_scop "%a=> %a" D.depth k term (Bindlib.unbox e)) + |> D.log_and_return (fun e -> log_scop "%a=> %a" D.depth k term e) (** [add_impl md ss env loc h impl args] scopes [args] and returns the application of [h] to the scoped arguments. [impl] is a boolean list described the implicit arguments. Implicit arguments are added as underscores before scoping. *) and add_impl : int -> mode -> sig_state -> - Env.t -> popt -> tbox -> bool list -> p_term list -> tbox = + Env.t -> popt -> term -> bool list -> p_term list -> term = fun k md ss env loc h impl args -> - let appl = match md with M_LHS _ -> _Appl_not_canonical | _ -> _Appl in - let appl_p_term t u = appl t (scope_parsed (k+1) md ss env u) in - let appl_meta t = appl t (scope_head (k+1) md ss env P.wild) in + let appl = match md with M_LHS _ -> mk_Appl_not_canonical | _ -> mk_Appl in + let appl_p_term t u = appl (t, scope_parsed (k+1) md ss env u) in + let appl_meta t = appl (t, scope_head (k+1) md ss env P.wild) in match impl, args with (* The remaining arguments are all explicit. *) | [], _ -> List.fold_left appl_p_term h args @@ -273,12 +272,12 @@ and add_impl : int -> mode -> sig_state -> (** [scope_domain md ss env t] scopes [t] as the domain of an abstraction or product. *) -and scope_domain : int -> mode -> sig_state -> env -> p_term option -> tbox = +and scope_domain : int -> mode -> sig_state -> env -> p_term option -> term = fun k md ss env a -> match a, md with | (Some {elt=P_Wild;_}|None), M_LHS data -> fresh_patt data None (Env.to_tbox env) - | (Some {elt=P_Wild;_}|None), _ -> _Plac true + | (Some {elt=P_Wild;_}|None), _ -> mk_Plac true | Some a, _ -> scope ~typ:true k md ss env a (** [scope_binder ~typ mode ss cons env params_list t] scopes [t] in @@ -289,8 +288,8 @@ and scope_domain : int -> mode -> sig_state -> env -> p_term option -> tbox = appear in the body. [typ] indicates if we scope a type (default is false). *) and scope_binder : ?typ:bool -> int -> mode -> sig_state -> - (tbox -> tbinder Bindlib.box -> tbox) -> Env.t -> p_params list -> - p_term option -> tbox = + (term * tbinder -> term) -> Env.t -> p_params list -> + p_term option -> term = fun ?(typ=false) k md ss cons env params_list t -> let rec scope_params_list env params_list = match params_list with @@ -298,7 +297,7 @@ and scope_binder : ?typ:bool -> int -> mode -> sig_state -> begin match t with | Some t -> scope ~typ (k+1) md ss env t - | None -> _Plac true + | None -> mk_Plac true end | (idopts,typopt,_implicit)::params_list -> let dom = scope_domain (k+1) md ss env typopt in @@ -310,7 +309,7 @@ and scope_binder : ?typ:bool -> int -> mode -> sig_state -> | None::idopts -> let v = new_tvar "_" in let t = aux env idopts in - cons a (Bindlib.bind_var v t) + cons (a, Bindlib.bind_var v t) | Some {elt=id;pos}::idopts -> if is_invalid_bindlib_id id then fatal pos "\"%s\": Escaped identifiers or regular identifiers \ @@ -319,24 +318,24 @@ and scope_binder : ?typ:bool -> int -> mode -> sig_state -> let v = new_tvar id in let env = Env.add id v a None env in let t = aux env idopts in - cons a (Bindlib.bind_var v t) + cons (a, Bindlib.bind_var v t) in aux env idopts in scope_params_list env params_list (** [scope_head ~typ md ss env t] scopes [t] as term head. *) and scope_head : - ?typ:bool -> int -> mode -> sig_state -> env -> p_term -> tbox = + ?typ:bool -> int -> mode -> sig_state -> env -> p_term -> term = fun ?(typ=false) k md ss env t -> match (t.elt, md) with | (P_Type, M_LHS(_)) -> fatal t.pos "TYPE is not allowed in a LHS." - | (P_Type, _) -> _Type + | (P_Type, _) -> mk_Type | (P_Iden(qid,_), _) -> scope_iden md ss env qid | (P_NLit(0), _) -> begin match Builtin.get_opt ss "0" with - | Some s -> _Symb s + | Some s -> mk_Symb s | None -> scope_iden md ss env {t with elt=([],"0")} end | (P_NLit(n), _) -> @@ -345,9 +344,9 @@ and scope_head : | Some sym_z -> match Builtin.get_opt ss "+1" with | Some sym_s -> - let z = _Symb sym_z and s = _Symb sym_s in + let z = mk_Symb sym_z and s = mk_Symb sym_s in let rec unsugar_nat_lit acc n = - if n <= 0 then acc else unsugar_nat_lit (_Appl s acc) (n-1) in + if n <= 0 then acc else unsugar_nat_lit (mk_Appl(s,acc)) (n-1) in unsugar_nat_lit z n | None -> scope_iden md ss env {t with elt=([], string_of_int n)} end @@ -355,10 +354,10 @@ and scope_head : | (P_Wild, M_URHS(data)) -> let i = data.m_urhs_vars_nb in data.m_urhs_vars_nb <- data.m_urhs_vars_nb + 1; - _Patt (Some i) "_" (Env.to_tbox env) + mk_Patt (Some i, "_", Env.to_tbox env) | (P_Wild, M_LHS data) -> fresh_patt data None (Env.to_tbox env) - | (P_Wild, M_Patt) -> _Wild - | (P_Wild, (M_RHS _|M_Term _)) -> _Plac typ + | (P_Wild, M_Patt) -> mk_Wild + | (P_Wild, (M_RHS _|M_Term _)) -> mk_Plac typ | (P_Meta({elt;pos} as mk,ts), M_Term {m_term_meta_of_key;_}) -> ( match m_term_meta_of_key elt with @@ -366,13 +365,13 @@ and scope_head : fatal pos "Metavariable %a not found among generated variables: \ metavariables can only be created by the system." Pretty.meta_ident mk - | Some m -> _Meta m (Array.map (scope (k + 1) md ss env) ts)) + | Some m -> mk_Meta (m, Array.map (scope (k + 1) md ss env) ts)) | (P_Meta(_), _) -> fatal t.pos "Metavariables are not allowed here." | (P_Patt(id,ts), M_LHS(d)) -> (* Check that [ts] are variables. *) let scope_var t = - match unfold (Bindlib.unbox (scope (k+1) md ss env t)) with + match unfold (scope (k+1) md ss env t) with | Vari(x) -> x | _ -> fatal t.pos "Only bound variables are allowed in the \ environment of pattern variables." @@ -394,7 +393,7 @@ and scope_head : var vs.(j) done done; - Array.map _Vari vs + Array.map mk_Vari vs in begin match id with @@ -430,7 +429,7 @@ and scope_head : | Some ts -> Array.map (scope (k+1) md ss env) ts in let name = match id with Some {elt;_} -> elt | None -> assert false in - _Patt (Some i) name ts + mk_Patt (Some i, name, ts) | (P_Patt(id,ts), M_RHS(r)) -> let i = match id with @@ -446,7 +445,7 @@ and scope_head : | Some ts -> Array.map (scope (k+1) md ss env) ts in let name = match id with Some {elt;_} -> elt | None -> assert false in - _Patt (Some i) name ts + mk_Patt (Some i, name, ts) | (P_Patt(_,_), _) -> fatal t.pos "Pattern variables are only allowed in rewriting rules." @@ -455,25 +454,26 @@ and scope_head : | (P_Arro(_,_), M_Patt) -> fatal t.pos "Arrows are not allowed in patterns." | (P_Arro(a,b), _) -> - _Impl (scope ~typ:true (k+1) md ss env a) - (scope ~typ:true (k+1) md ss env b) + mk_Impl (scope ~typ:true (k+1) md ss env a, + scope ~typ:true (k+1) md ss env b) | (P_Abst(_,_), M_Patt) -> fatal t.pos "Abstractions are not allowed in patterns." - | (P_Abst(xs,t), _) -> scope_binder k md ss _Abst env xs (Some(t)) + | (P_Abst(xs,t), _) -> scope_binder k md ss mk_Abst env xs (Some(t)) | (P_Prod(_,_), M_Patt) -> fatal t.pos "Dependent products are not allowed in patterns." - | (P_Prod(xs,b), _) -> scope_binder ~typ:true k md ss _Prod env xs (Some(b)) + | (P_Prod(xs,b), _) -> + scope_binder ~typ:true k md ss mk_Prod env xs (Some(b)) | (P_LLet(x,xs,a,t,u), (M_Term _|M_URHS _|M_RHS _)) -> - let a = scope_binder ~typ:true (k+1) md ss _Prod env xs a in - let t = scope_binder (k+1) md ss _Abst env xs (Some(t)) in + let a = scope_binder ~typ:true (k+1) md ss mk_Prod env xs a in + let t = scope_binder (k+1) md ss mk_Abst env xs (Some(t)) in let v = new_tvar x.elt in let u = scope ~typ (k+1) md ss (Env.add x.elt v a (Some(t)) env) u in if not (Bindlib.occur v u) then wrn x.pos "Useless let-binding (%s is not bound)." x.elt; - _LLet a t (Bindlib.bind_var v u) + mk_LLet (a, t, Bindlib.bind_var v u) | (P_LLet(_), M_LHS(_)) -> fatal t.pos "Let-bindings are not allowed in a LHS." | (P_LLet(_), M_Patt) -> @@ -487,7 +487,7 @@ and scope_head : | (P_Expl(_), _) -> fatal t.pos "Explicit argument not allowed here." let scope = - let open Stdlib in let r = ref _Kind in fun ?(typ=false) k md ss env t -> + let open Stdlib in let r = ref mk_Kind in fun ?(typ=false) k md ss env t -> Debug.(record_time Scoping (fun () -> r := scope ~typ k md ss env t)); !r (** [scope ~typ ~mok prv expo ss env p t] turns a pterm [t] into a term in @@ -501,7 +501,7 @@ let scope_term : ?typ:bool -> ?mok:(int -> meta option) -> bool -> sig_state -> env -> p_term -> term = fun ?(typ=false) ?(mok=fun _ -> None) m_term_prv ss env t -> let md = M_Term {m_term_meta_of_key=mok; m_term_prv} in - Bindlib.unbox (scope ~typ 0 md ss env t) + scope ~typ 0 md ss env t (** [patt_vars t] returns a couple [(pvs,nl)]. The first compoment [pvs] is an association list giving the arity of all the “pattern variables” appearing @@ -637,7 +637,7 @@ let scope_rule : bool -> sig_state -> p_rule -> sym_rule = (** [scope_pattern ss env t] turns a parser-level term [t] into an actual term that will correspond to selection pattern (rewrite tactic). *) let scope_pattern : sig_state -> env -> p_term -> term = fun ss env t -> - Bindlib.unbox (scope 0 M_Patt ss env t) + scope 0 M_Patt ss env t (** [scope_rw_patt ss env t] turns a parser-level rewrite tactic specification [s] into an actual rewrite specification (possibly containing variables of @@ -649,19 +649,19 @@ let scope_rw_patt : sig_state -> env -> p_rw_patt -> (term, tbinder) rw_patt = | Rw_InTerm(t) -> Rw_InTerm(scope_pattern ss env t) | Rw_InIdInTerm(x,t) -> let v = new_tvar x.elt in - let t = scope_pattern ss ((x.elt,(v, _Kind, None))::env) t in - Rw_InIdInTerm(bind v lift_not_canonical t) + let t = scope_pattern ss ((x.elt,(v, mk_Kind, None))::env) t in + Rw_InIdInTerm(Bindlib.bind_var v t) | Rw_IdInTerm(x,t) -> let v = new_tvar x.elt in - let t = scope_pattern ss ((x.elt,(v, _Kind, None))::env) t in - Rw_IdInTerm(bind v lift_not_canonical t) + let t = scope_pattern ss ((x.elt,(v, mk_Kind, None))::env) t in + Rw_IdInTerm(Bindlib.bind_var v t) | Rw_TermInIdInTerm(u,(x,t)) -> let u = scope_pattern ss env u in let v = new_tvar x.elt in - let t = scope_pattern ss ((x.elt,(v, _Kind, None))::env) t in - Rw_TermInIdInTerm(u, bind v lift_not_canonical t) + let t = scope_pattern ss ((x.elt,(v, mk_Kind, None))::env) t in + Rw_TermInIdInTerm(u, Bindlib.bind_var v t) | Rw_TermAsIdInTerm(u,(x,t)) -> let u = scope_pattern ss env u in let v = new_tvar x.elt in - let t = scope_pattern ss ((x.elt,(v, _Kind, None))::env) t in - Rw_TermAsIdInTerm(u, bind v lift_not_canonical t) + let t = scope_pattern ss ((x.elt,(v, mk_Kind, None))::env) t in + Rw_TermAsIdInTerm(u, Bindlib.bind_var v t) diff --git a/src/pure/pure.ml b/src/pure/pure.ml index cec88b1a1..832775947 100644 --- a/src/pure/pure.ml +++ b/src/pure/pure.ml @@ -104,7 +104,7 @@ let string_of_goal : Proof.goal -> goal = res in let open Print in - let env_elt (s,(_,t,_)) = s, to_string term (Term.Bindlib.unbox t) in + let env_elt (s,(_,t,_)) = s, to_string term t in let ctx_elt (x,a,_) = to_string var x, to_string term a in fun g -> match g with diff --git a/src/tool/lcr.ml b/src/tool/lcr.ml index f823dd847..35e161ef5 100644 --- a/src/tool/lcr.ml +++ b/src/tool/lcr.ml @@ -93,27 +93,25 @@ let occurs : int -> term -> bool = fun i -> in occ (** [shift t] replaces in [t] every pattern index i by -i-1. *) -let shift : term -> term = - let rec shift : term -> tbox = fun t -> - match unfold t with - | Vari x -> _Vari x - | Type -> _Type - | Kind -> _Kind - | Symb _ -> Bindlib.box t - | Prod(a,b) -> _Prod (shift a) (shift_binder b) - | Abst(a,b) -> _Abst (shift a) (shift_binder b) - | Appl(a,b) -> _Appl (shift a) (shift b) - | Meta(m,ts) -> _Meta m (Array.map shift ts) - | Patt(None,_,_) -> assert false - | Patt(Some i,n,ts) -> _Patt (Some(-i-1)) (n ^ "'") (Array.map shift ts) - | Db _ -> assert false - | Wild -> _Wild - | Plac b -> _Plac b - | TRef r -> _TRef r - | LLet(a,t,b) -> _LLet (shift a) (shift t) (shift_binder b) - and shift_binder b = - let x, t = Bindlib.unbind b in Bindlib.bind_var x (shift t) - in fun t -> Bindlib.unbox (shift t) +let rec shift : term -> term = fun t -> + match unfold t with + | Vari _ + | Type + | Kind + | Symb _ + | Wild + | Plac _ + | TRef _ -> t + | Prod(a,b) -> mk_Prod (shift a, shift_binder b) + | Abst(a,b) -> mk_Abst (shift a, shift_binder b) + | Appl(a,b) -> mk_Appl (shift a, shift b) + | Meta(m,ts) -> mk_Meta (m, Array.map shift ts) + | Patt(None,_,_) -> assert false + | Patt(Some i,n,ts) -> mk_Patt (Some(-i-1), n ^ "'", Array.map shift ts) + | Db _ -> assert false + | LLet(a,t,b) -> mk_LLet (shift a, shift t, shift_binder b) +and shift_binder b = + let x, t = Bindlib.unbind b in Bindlib.bind_var x (shift t) (** Type for pattern variable substitutions. *) type subs = term IntMap.t @@ -136,13 +134,13 @@ let apply_subs : subs -> term -> term = fun s t -> | Appl(u,v) -> mk_Appl (apply_subs u, apply_subs v) | Abst(a,b) -> let x,b = Bindlib.unbind b in - mk_Abst (apply_subs a, bind x lift (apply_subs b)) + mk_Abst (apply_subs a, Bindlib.bind_var x (apply_subs b)) | Prod(a,b) -> let x,b = Bindlib.unbind b in - mk_Prod (apply_subs a, bind x lift (apply_subs b)) + mk_Prod (apply_subs a, Bindlib.bind_var x (apply_subs b)) | LLet(a,t,b) -> let x,b = Bindlib.unbind b in - mk_LLet (apply_subs a, apply_subs t, bind x lift (apply_subs b)) + mk_LLet (apply_subs a, apply_subs t, Bindlib.bind_var x (apply_subs b)) | Meta(m,ts) -> mk_Meta (m, Array.map apply_subs ts) | Db _ -> assert false | TRef _ -> assert false @@ -403,7 +401,7 @@ let typability_constraints : Pos.popt -> term -> subs option = fun pos t -> | Symb _ | Vari _ -> t | Abst(a,b) -> let x,b = Bindlib.unbind b in - mk_Abst(patt_to_meta a, bind x lift_not_canonical (patt_to_meta b)) + mk_Abst(patt_to_meta a, Bindlib.bind_var x (patt_to_meta b)) | _ -> assert false in let t = patt_to_meta t in @@ -417,7 +415,7 @@ let typability_constraints : Pos.popt -> term -> subs option = fun pos t -> let i,n = MetaMap.find m !m2p in let s = create_sym (Sign.current_path()) Public Defin Eager false (Pos.none n) mk_Kind [] in - let t = Bindlib.unbox (Bindlib.bind_mvar [||] (_Symb s)) in + let t = Bindlib.bind_mvar [||] (mk_Symb s) in Timed.(m.meta_value := Some t); s2p := SymMap.add s i !s2p with Not_found -> () diff --git a/src/tool/sr.ml b/src/tool/sr.ml index e301821c7..7e055b4e0 100644 --- a/src/tool/sr.ml +++ b/src/tool/sr.ml @@ -16,30 +16,27 @@ let log_subj = log_subj.pp let build_meta_type : problem -> int -> term = fun p k -> assert (k >= 0); let xs = Array.init k (new_tvar_ind "x") in - let ts = Array.map _Vari xs in + let ts = Array.map mk_Vari xs in (* We create the types for the “Mi” metavariables. *) - let ty_m = Array.make (k+1) _Type in + let ty_m = Array.make (k+1) mk_Type in for i = 0 to k do for j = (i-1) downto 0 do - ty_m.(i) <- _Prod ty_m.(j) (Bindlib.bind_var xs.(j) ty_m.(i)) + ty_m.(i) <- mk_Prod (ty_m.(j), Bindlib.bind_var xs.(j) ty_m.(i)) done done; (* We create the “Ai” terms and the “Mi” metavariables. *) - let f i = - let m = LibMeta.fresh p (Bindlib.unbox ty_m.(i)) i in - _Meta m (Array.sub ts 0 i) - in + let f i = mk_Meta (LibMeta.fresh p ty_m.(i) i, Array.sub ts 0 i) in let a = Array.init (k+1) f in (* We finally construct our type. *) let res = ref a.(k) in for i = k - 1 downto 0 do - res := _Prod a.(i) (Bindlib.bind_var xs.(i) !res) + res := mk_Prod (a.(i), Bindlib.bind_var xs.(i) !res) done; - Bindlib.unbox !res + !res (** [symb_to_patt pos map t] replaces in [t] every symbol [f] such that [SymMap.find f map = Some i] by [Patt(i,_,_)]. *) -let symb_to_patt : Pos.popt -> (int * int) option SymMap.t -> term -> tbox = +let symb_to_patt : Pos.popt -> (int * int) option SymMap.t -> term -> term = fun pos map -> let rec symb_to_patt t = let (h, ts) = get_args t in @@ -55,24 +52,24 @@ let symb_to_patt : Pos.popt -> (int * int) option SymMap.t -> term -> tbox = fatal pos "Introduced symbol [%s] cannot be removed." f.sym_name | Some (Some (i, arity)) -> let (ts1, ts2) = List.cut ts arity in - (_Patt (Some i) (string_of_int i) (Array.of_list ts1), ts2) - | None -> (_Symb f, ts) + (mk_Patt (Some i, string_of_int i, Array.of_list ts1), ts2) + | None -> (mk_Symb f, ts) end - | Vari(x) -> (_Vari x, ts) - | Type -> (_Type , ts) - | Kind -> (_Kind , ts) + | Vari(x) -> (mk_Vari x, ts) + | Type -> (mk_Type , ts) + | Kind -> (mk_Kind , ts) | Abst(a,b) -> let (x, t) = Bindlib.unbind b in let b = Bindlib.bind_var x (symb_to_patt t) in - (_Abst (symb_to_patt a) b, ts) + (mk_Abst (symb_to_patt a, b), ts) | Prod(a,b) -> let (x, t) = Bindlib.unbind b in let b = Bindlib.bind_var x (symb_to_patt t) in - (_Prod (symb_to_patt a) b, ts) + (mk_Prod (symb_to_patt a, b), ts) | LLet(a,t,b) -> let (x, u) = Bindlib.unbind b in let b = Bindlib.bind_var x (symb_to_patt u) in - (_LLet (symb_to_patt a) (symb_to_patt t) b, ts) + (mk_LLet (symb_to_patt a, symb_to_patt t, b), ts) | Meta(_,_) -> fatal pos "A metavariable could not be instantiated in the RHS." | Plac _ -> @@ -83,7 +80,7 @@ let symb_to_patt : Pos.popt -> (int * int) option SymMap.t -> term -> tbox = | Wild -> assert false (* Cannot appear in RHS. *) | TRef(_) -> assert false (* Cannot appear in RHS. *) in - _Appl_list h ts + add_args h ts in symb_to_patt @@ -106,8 +103,8 @@ let check_rule : Pos.popt -> sym_rule -> sym_rule = (* Replace Patt's by Meta's. *) let f m = let xs = Array.init m.meta_arity (new_tvar_ind "x") in - let ts = Array.map _Vari xs in - Some(Bindlib.unbox (Bindlib.bind_mvar xs (_Meta m ts))) + let ts = Array.map mk_Vari xs in + Some(Bindlib.bind_mvar xs (mk_Meta (m, ts))) in let su = Array.map f metas in let lhs_with_metas = subst_patt su (add_args (mk_Symb s) lhs) @@ -148,9 +145,9 @@ let check_rule : Pos.popt -> sym_rule -> sym_rule = Stdlib.(symbols := SymSet.add s !symbols); (* Build a definition for [m]. *) let xs = Array.init m.meta_arity (new_tvar_ind "x") in - let s = _Symb s in - let def = Array.fold_left (fun t x -> _Appl t (_Vari x)) s xs in - m.meta_value := Some(Bindlib.unbox (Bindlib.bind_mvar xs def)) + let s = mk_Symb s in + let def = Array.fold_left (fun t x -> _Appl t (mk_Vari x)) s xs in + m.meta_value := Some(Bindlib.bind_mvar xs def) in Array.iter instantiate metas; Stdlib.(!symbols) @@ -168,9 +165,9 @@ let check_rule : Pos.popt -> sym_rule -> sym_rule = in Stdlib.(map := SymMap.add s None !map; m2s := MetaMap.add m s !m2s); let xs = Array.init m.meta_arity (new_tvar_ind "x") in - let s = _Symb s in - let def = Array.fold_left (fun t x -> _Appl t (_Vari x)) s xs in - m.meta_value := Some(Bindlib.unbox (Bindlib.bind_mvar xs def)) + let s = mk_Symb s in + let def = Array.fold_left (fun t x -> mk_Appl (t, mk_Vari x)) s xs in + m.meta_value := Some(Bindlib.bind_mvar xs def) in MetaSet.iter instantiate !p.metas; let f i m = From 170ca776789cd22c2d86934d73fd01ee332ca592 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 17:06:18 +0100 Subject: [PATCH 10/38] remove bind_mvar3 --- src/core/term.ml | 4 ---- src/core/term.mli | 2 -- src/handle/rewrite.ml | 2 +- 3 files changed, 1 insertion(+), 7 deletions(-) diff --git a/src/core/term.ml b/src/core/term.ml index 64a802d8c..70d234d1b 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -370,10 +370,6 @@ let bind_mvar : tvar array -> term -> tmbinder = fun xs t -> log_term "bind_mvar %a %a = %a" (D.array var) xs term t term b; Array.map name_of xs, b -let bind_mvar3 : tvar array -> (term * term * term) - -> tmbinder * tmbinder * tmbinder = fun xs (t1, t2, t3) -> - bind_mvar xs t1, bind_mvar xs t2, bind_mvar xs t3 - (** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to compare variables using [Pervasive.compare]. *) let compare_vars : tvar -> tvar -> int = fun (i,_) (j,_) -> Stdlib.compare i j diff --git a/src/core/term.mli b/src/core/term.mli index 1c3d51256..8c65c5815 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -242,8 +242,6 @@ val bind_var : tvar -> term -> tbinder (** [bind_mvar xs b] binds the variables of [xs] in [b] to get a boxed binder. It is the equivalent of [bind_var] for multiple variables. *) val bind_mvar : tvar array -> term -> tmbinder -val bind_mvar3 : tvar array -> (term * term * term) - -> tmbinder * tmbinder * tmbinder (** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to compare variables using [Pervasive.compare]. *) diff --git a/src/handle/rewrite.ml b/src/handle/rewrite.ml index ad07abd28..5c4e453d7 100644 --- a/src/handle/rewrite.ml +++ b/src/handle/rewrite.ml @@ -334,7 +334,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> let (t, l, r) = if l2r then (t, l, r) else (swap cfg a l r t, r, l) in (* Bind the variables in this new witness. *) - let bound = Bindlib.bind_mvar3 vars (t,l,r) in + let bound = let bind = Bindlib.bind_mvar vars in bind t, bind l, bind r in (* Extract the term from the goal type (get “u” from “P u”). *) let g_term = From 28e25084bc38522efc7a7255d6f0572d57a89a5a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 17:35:49 +0100 Subject: [PATCH 11/38] Env: rename to_tbox into to_terms --- src/core/env.ml | 10 +++++----- src/core/unif.ml | 6 +++--- src/handle/tactic.ml | 4 ++-- src/parsing/scope.ml | 6 +++--- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/core/env.ml b/src/core/env.ml index befa27575..43805dd49 100644 --- a/src/core/env.ml +++ b/src/core/env.ml @@ -66,11 +66,11 @@ let vars : env -> tvar array = fun env -> let appl : term -> env -> term = fun t env -> List.fold_right (fun (_,(x,_,_)) t -> mk_Appl (t, mk_Vari x)) env t -(** [to_tbox env] extracts the array of the {e not defined} variables in [env] - and injects them in the [tbox] type. This is the same as [Array.map _Vari - (vars env)]. Note that the order is reversed: [to_tbox [(xn,an);..;(x1,a1)] - = [|x1;..;xn|]]. *) -let to_tbox : env -> term array = fun env -> +(** [to_terms env] extracts the array of the {e not defined} variables in + [env] and injects them in the [tbox] type. This is the same as [Array.map + _Vari (vars env)]. Note that the order is reversed: [to_terms + [(xn,an);..;(x1,a1)] = [|x1;..;xn|]]. *) +let to_terms : env -> term array = fun env -> let f (_, (x, _, u)) = if u = None then Some(mk_Vari x) else None in Array.of_list (List.filter_rev_map f env) diff --git a/src/core/unif.ml b/src/core/unif.ml index 4d64b1779..770159933 100644 --- a/src/core/unif.ml +++ b/src/core/unif.ml @@ -268,19 +268,19 @@ let imitate_lam : problem -> ctxt -> meta -> unit = fun p c m -> | _ -> let tm2 = Env.to_prod env mk_Type in let m2 = LibMeta.fresh p tm2 n in - let a = mk_Meta (m2, Env.to_tbox env) in + let a = mk_Meta (m2, Env.to_terms env) in let x = new_tvar "x" in let env' = Env.add "x" x a None env in let tm3 = Env.to_prod env' mk_Type in let m3 = LibMeta.fresh p tm3 (n+1) in - let b = mk_Meta (m3, Env.to_tbox env') in + let b = mk_Meta (m3, Env.to_terms env') in let u = mk_Prod (a, Bindlib.bind_var x b) in add_constr p (Env.to_ctxt env, u, t); x, a, env', b in let tm1 = Env.to_prod env' b in let m1 = LibMeta.fresh p tm1 (n+1) in - let u1 = mk_Meta (m1, Env.to_tbox env') in + let u1 = mk_Meta (m1, Env.to_terms env') in let xu1 = mk_Abst (a, Bindlib.bind_var x u1) in let v = Bindlib.bind_mvar (Env.vars env) xu1 in if Logger.log_enabled () then diff --git a/src/handle/tactic.ml b/src/handle/tactic.ml index efa90be64..f9e1469f1 100644 --- a/src/handle/tactic.ml +++ b/src/handle/tactic.ml @@ -253,7 +253,7 @@ let handle : let u = gt.goal_type in let q = Env.to_prod [x] (Env.to_prod e2 u) in let m = LibMeta.fresh p (Env.to_prod e1 q) (List.length e1) in - let me1 = mk_Meta (m, Env.to_tbox e1) in + let me1 = mk_Meta (m, Env.to_terms e1) in let t = List.fold_left (fun t (_,(v,_,_)) -> mk_Appl(t, mk_Vari v)) me1 (x::e2) @@ -280,7 +280,7 @@ let handle : let v = new_tvar id.elt in let env' = Env.add id.elt v t None env in let m2 = LibMeta.fresh p (Env.to_prod env' gt.goal_type) (n+1) in - let ts = Env.to_tbox env in + let ts = Env.to_terms env in let u = mk_Meta (m2, Array.append ts [|mk_Meta (m1, ts)|]) in tac_refine pos ps gt gs p u end diff --git a/src/parsing/scope.ml b/src/parsing/scope.ml index 84eb889ee..a5a6adc11 100644 --- a/src/parsing/scope.ml +++ b/src/parsing/scope.ml @@ -276,7 +276,7 @@ and scope_domain : int -> mode -> sig_state -> env -> p_term option -> term = fun k md ss env a -> match a, md with | (Some {elt=P_Wild;_}|None), M_LHS data -> - fresh_patt data None (Env.to_tbox env) + fresh_patt data None (Env.to_terms env) | (Some {elt=P_Wild;_}|None), _ -> mk_Plac true | Some a, _ -> scope ~typ:true k md ss env a @@ -354,8 +354,8 @@ and scope_head : | (P_Wild, M_URHS(data)) -> let i = data.m_urhs_vars_nb in data.m_urhs_vars_nb <- data.m_urhs_vars_nb + 1; - mk_Patt (Some i, "_", Env.to_tbox env) - | (P_Wild, M_LHS data) -> fresh_patt data None (Env.to_tbox env) + mk_Patt (Some i, "_", Env.to_terms env) + | (P_Wild, M_LHS data) -> fresh_patt data None (Env.to_terms env) | (P_Wild, M_Patt) -> mk_Wild | (P_Wild, (M_RHS _|M_Term _)) -> mk_Plac typ From 02ec00b74e397865d1de0ac92356544d1d0a281b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 17:37:36 +0100 Subject: [PATCH 12/38] remove fresh_box --- src/core/libMeta.ml | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/src/core/libMeta.ml b/src/core/libMeta.ml index 3621e30d4..976d4e45c 100644 --- a/src/core/libMeta.ml +++ b/src/core/libMeta.ml @@ -18,17 +18,6 @@ let fresh : problem -> term -> int -> meta = meta_value = ref None } in p := {!p with metas = MetaSet.add m !p.metas}; m -(** [fresh_box p a n] is the boxed counterpart of [fresh_meta]. It is - only useful in the rare cases where the type of a metavariable - contains a free term variable environment. This should only happens - when scoping the rewriting rules, use this function with care. - The metavariable is created immediately with a dummy type, and the - type becomes valid at unboxing. The boxed metavariable should be - unboxed at most once, otherwise its type may be rendered invalid in - some contexts. *) -let fresh_box: problem -> term -> int -> meta = fun p a n -> - let m = fresh p mk_Kind n in m.meta_type := a; m - (** [set p m v] sets the metavariable [m] of [p] to [v]. WARNING: No specific check is performed, so this function may lead to cyclic terms. To use with care. *) @@ -52,7 +41,7 @@ let make : problem -> ctxt -> term -> term = let bmake : problem -> bctxt -> term -> term = fun p bctx a -> let (a, k) = Ctxt.to_prod_box bctx a in - let m = fresh_box p a k in + let m = fresh p a k in let get_var (x, _) = mk_Vari x in mk_Meta (m, Array.of_list (List.rev_map get_var bctx)) From 3a8d502da75b32f5b2e8082e0298dfa27e1d689c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 17:45:11 +0100 Subject: [PATCH 13/38] cli: Term.* -> CLT.* --- src/cli/init.ml | 8 +++++--- src/cli/install.ml | 16 +++++++++------- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/src/cli/init.ml b/src/cli/init.ml index 5de3c05f2..af4967a2b 100644 --- a/src/cli/init.ml +++ b/src/cli/init.ml @@ -3,6 +3,8 @@ open Common open Error open Format open Parsing +module CLT = Cmdliner.Term + let write_file : string -> (formatter -> unit) -> unit = fun fn pp -> let oc = open_out fn in let ppf = formatter_of_out_channel oc in @@ -54,7 +56,7 @@ let run : Path.t -> unit = fun root_path -> in Error.handle_exceptions run -let root_path : Path.t Term.t = +let root_path : Path.t CLT.t = let doc = "Defines the root path of the package. It is the module path under which \ the package will be registered and installed (if desired), and it will \ @@ -69,5 +71,5 @@ let root_path : Path.t Term.t = let cmd = let doc = "Create a new Lambdapi package to get started with a project." in - Term.(const run $ root_path), - Term.info "init" ~doc + CLT.(const run $ root_path), + CLT.info "init" ~doc diff --git a/src/cli/install.ml b/src/cli/install.ml index 1f1d31d33..89888c3e6 100644 --- a/src/cli/install.ml +++ b/src/cli/install.ml @@ -2,6 +2,8 @@ open Cmdliner open Common open Library open Error open Parsing +module CLT = Cmdliner.Term + let run_command : bool -> string -> unit = fun dry_run cmd -> if dry_run then Console.out 1 "%s" cmd else match Sys.command cmd with @@ -85,14 +87,14 @@ let run_uninstall : Config.t -> bool -> string -> unit = in Error.handle_exceptions run -let dry_run : bool Term.t = +let dry_run : bool CLT.t = let doc = "Do not install anything, only print the command that would be executed \ if the option was not given." in Arg.(value & flag & info ["dry-run"] ~doc) -let pkg_file : string Term.t = +let pkg_file : string CLT.t = let doc = Printf.sprintf "Path to the package configuration file $(b,%s) corresponding to the \ @@ -100,7 +102,7 @@ let pkg_file : string Term.t = in Arg.(required & pos 0 (some non_dir_file) None & info [] ~docv:"FILE" ~doc) -let files : string list Term.t = +let files : string list CLT.t = let doc = Printf.sprintf "Source file with the [%s] extension (or with the [%s] extension when \ @@ -112,10 +114,10 @@ let files : string list Term.t = let install_cmd = let doc = "Install the given files under the library root." in - Term.(const run_install $ Config.minimal $ dry_run $ files), - Term.info "install" ~doc + CLT.(const run_install $ Config.minimal $ dry_run $ files), + CLT.info "install" ~doc let uninstall_cmd = let doc = "Uninstall the files corresponding to the given package file." in - Term.(const run_uninstall $ Config.minimal $ dry_run $ pkg_file), - Term.info "uninstall" ~doc + CLT.(const run_uninstall $ Config.minimal $ dry_run $ pkg_file), + CLT.info "uninstall" ~doc From 74aefe98efa9a70e7f36dcbf5044c3c8be7fe0c4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 18:05:48 +0100 Subject: [PATCH 14/38] remove bctxt --- src/core/ctxt.ml | 14 ----------- src/core/infer.ml | 58 +++++++++++++++++++-------------------------- src/core/libMeta.ml | 18 -------------- src/core/term.ml | 6 ----- src/core/term.mli | 6 ----- 5 files changed, 24 insertions(+), 78 deletions(-) diff --git a/src/core/ctxt.ml b/src/core/ctxt.ml index a75b52296..dcbf15c61 100644 --- a/src/core/ctxt.ml +++ b/src/core/ctxt.ml @@ -32,20 +32,6 @@ let to_prod : ctxt -> term -> term * int = fun ctx t -> in List.fold_left f (t, 0) ctx -(** [to_prod_box bctx t] is similar to [to_prod bctx t] but operates on boxed - contexts and terms. *) -let to_prod_box : bctxt -> term -> term * int = fun bctx t -> - let f (t, c) (x, a) = - let b = Bindlib.bind_var x t in - (mk_Prod(a,b), c + 1) - in - List.fold_left f (t, 0) bctx - -(** [box_context ctx] lifts context [ctx] to a boxed context. *) -let box_context : ctxt -> bctxt = - List.filter_map - (fun (x, t, u) -> if u = None then Some (x, t) else None) - (** [to_abst ctx t] builds a sequence of abstractions over the context [ctx], in the term [t]. *) let to_abst : ctxt -> term -> term = fun ctx t -> diff --git a/src/core/infer.ml b/src/core/infer.ml index 7e3369905..f5a830c99 100644 --- a/src/core/infer.ml +++ b/src/core/infer.ml @@ -10,31 +10,23 @@ open Print let log = Logger.make 'i' "infr" "type inference/checking" let log = log.pp -(* Optimised context *) -type octxt = ctxt * bctxt -let boxed = snd -let classic = fst -let extend (cctx, bctx) v ?def ty = - ((v, ty, def) :: cctx, if def <> None then bctx else (v, ty) :: bctx) - (** Exception that may be raised by type inference. *) exception NotTypable (** [unif pb c a b] solves the unification problem [c ⊢ a ≡ b]. Current implementation collects constraints in {!val:constraints} then solves them at the end of type checking. *) -let unif : problem -> octxt -> term -> term -> unit = +let unif : problem -> ctxt -> term -> term -> unit = fun pb c a b -> - if not (Eval.pure_eq_modulo (classic c) a b) then + if not (Eval.pure_eq_modulo c a b) then (* NOTE: eq_modulo is used because the unification algorithm counts on the fact that no constraint is added in some cases (see test "245b.lp"). We may however want to reduce the number of calls to [eq_modulo]. *) begin if Logger.log_enabled () then - log (Color.yel "add constraint %a") constr - (classic c, a, b); - pb := {!pb with to_solve = (classic c, a, b) :: !pb.to_solve} + log (Color.yel "add constraint %a") constr (c, a, b); + pb := {!pb with to_solve = (c, a, b) :: !pb.to_solve} end (** {1 Handling coercions} *) @@ -53,7 +45,7 @@ let coerce pb c t a b = unif pb c a b; (t, false) (** [type_enforce pb c a] returns a tuple [(a',s)] where [a'] is refined term [a] and [s] is a sort (Type or Kind) such that [a'] is of type [s]. *) -let rec type_enforce : problem -> octxt -> term -> term * term * bool = +let rec type_enforce : problem -> ctxt -> term -> term * term * bool = fun pb c a -> if Logger.log_enabled () then log "Type enforce [%a]" term a; let a, s, cui = infer pb c a in @@ -71,22 +63,22 @@ let rec type_enforce : problem -> octxt -> term -> term * term * bool = (** [force pb c t a] returns a term [t'] such that [t'] has type [a], and [t'] is the refinement of [t]. *) -and force : problem -> octxt -> term -> term -> term * bool = +and force : problem -> ctxt -> term -> term -> term * bool = fun pb c te ty -> if Logger.log_enabled () then log "Force [%a] of [%a]" term te term ty; match unfold te with | Plac true -> unif pb c ty mk_Type; - (LibMeta.bmake pb (boxed c) mk_Type, true) + (LibMeta.make pb c mk_Type, true) | Plac false -> - (LibMeta.bmake pb (boxed c) ty, true) + (LibMeta.make pb c ty, true) | _ -> let (t, a, cui) = infer pb c te in let t, cu = coerce pb c t a ty in (t, cu || cui) -and infer_aux : problem -> octxt -> term -> term * term * bool = +and infer_aux : problem -> ctxt -> term -> term * term * bool = fun pb c t -> match unfold t with | Patt _ -> assert false @@ -96,15 +88,15 @@ and infer_aux : problem -> octxt -> term -> term * term * bool = | TRef _ -> assert false | Type -> (mk_Type, mk_Kind, false) | Vari x -> - let a = try Ctxt.type_of x (classic c) with Not_found -> assert false in + let a = try Ctxt.type_of x c with Not_found -> assert false in (t, a, false) | Symb s -> (t, !(s.sym_type), false) | Plac true -> - let m = LibMeta.bmake pb (boxed c) mk_Type in + let m = LibMeta.make pb c mk_Type in (m, mk_Type, true) | Plac false -> - let mt = LibMeta.bmake pb (boxed c) mk_Type in - let m = LibMeta.bmake pb (boxed c) mt in + let mt = LibMeta.make pb c mk_Type in + let m = LibMeta.make pb c mt in (m, mt, true) (* All metavariables inserted are typed. *) | (Meta (m, ts)) as t -> @@ -133,7 +125,7 @@ and infer_aux : problem -> octxt -> term -> term * term * bool = let t, cu_t = force pb c t t_ty in (* Unbind [u] and get new context with [x: t_ty ≔ t] *) let (x, u) = Bindlib.unbind u in - let c = extend c x ~def:t t_ty in + let c = (x, t_ty, Some t)::c in (* Infer type of [u'] and refine it. *) let u, u_ty, cu_u = infer pb c u in ( match unfold u_ty with @@ -157,7 +149,7 @@ and infer_aux : problem -> octxt -> term -> term * term * bool = (* Domain must by of type Type (and not Kind) *) let dom, cu_dom = force pb c dom mk_Type in let (x, b) = Bindlib.unbind b in - let c = extend c x dom in + let c = (x,dom,None)::c in let b, range, cu_b = infer pb c b in let range = Bindlib.bind_var x range in let top_ty = mk_Prod (dom, range) in @@ -173,7 +165,7 @@ and infer_aux : problem -> octxt -> term -> term * term * bool = (* Domain must by of type Type (and not Kind) *) let dom, cu_dom = force pb c dom mk_Type in let (x, b) = Bindlib.unbind b in - let c = extend c x dom in + let c = (x,dom,None)::c in let b, b_s, cu_b = type_enforce pb c b in let cu = cu_b || cu_dom in let top = @@ -189,7 +181,7 @@ and infer_aux : problem -> octxt -> term -> term * term * bool = let ty = Bindlib.subst range u and cu = cu_t || m in if cu then (mk_Appl (t, u), ty, cu) else (top, ty, cu) in - match Eval.whnf (classic c) t_ty with + match Eval.whnf c t_ty with | Prod (dom, range) -> if Logger.log_enabled () then log "Appl-prod arg [%a]" term u; @@ -197,19 +189,19 @@ and infer_aux : problem -> octxt -> term -> term * term * bool = return cu_u t u range | Meta (_, _) -> let u, u_ty, cu_u = infer pb c u in - let range = LibMeta.bmake_codomain pb (boxed c) u_ty in + let range = LibMeta.make_codomain pb c u_ty in unif pb c t_ty (mk_Prod (u_ty, range)); return cu_u t u range | t_ty -> - let domain = LibMeta.bmake pb (boxed c) mk_Type in - let range = LibMeta.bmake_codomain pb (boxed c) domain in + let domain = LibMeta.make pb c mk_Type in + let range = LibMeta.make_codomain pb c domain in let t, cu_t' = coerce pb c t t_ty (mk_Prod (domain, range)) in if Logger.log_enabled () then log "Appl-default arg [%a]" term u; let u, cu_u = force pb c u domain in return (cu_t' || cu_u) t u range ) -and infer : problem -> octxt -> term -> term * term * bool = fun pb c t -> +and infer : problem -> ctxt -> term -> term * term * bool = fun pb c t -> if Logger.log_enabled () then log "Infer [%a]" term t; let t, t_ty, cu = infer_aux pb c t in if Logger.log_enabled () then @@ -225,11 +217,9 @@ and infer : problem -> octxt -> term -> term * term * bool = fun pb c t -> (** [noexn f p c arg] returns [Some r] if [f p c arg] returns [r], and [None] if [f p c arg] raises [NotTypable]. *) -let noexn : (problem -> octxt -> 'a -> 'b) -> problem -> ctxt -> 'a -> - 'b option = - fun f p c arg -> - try Some (f p (c, Ctxt.box_context c) arg) - with NotTypable -> None +let noexn : + (problem -> ctxt -> 'a -> 'b) -> problem -> ctxt -> 'a -> 'b option = + fun f p c arg -> try Some (f p c arg) with NotTypable -> None let infer_noexn pb c t : (term * term) option = if Logger.log_enabled () then diff --git a/src/core/libMeta.ml b/src/core/libMeta.ml index 976d4e45c..395f294da 100644 --- a/src/core/libMeta.ml +++ b/src/core/libMeta.ml @@ -34,17 +34,6 @@ let make : problem -> ctxt -> term -> term = let get_var (x,_,d) = if d = None then Some (mk_Vari x) else None in mk_Meta(m, Array.of_list (List.filter_rev_map get_var ctx)) -(** [bmake p bctx a] is the boxed version of {!make}: it creates - a fresh {e boxed} metavariable in {e boxed} context [bctx] of {e - boxed} type [a]. It is the same as [lift (make p c b)] (provided that - [bctx] is boxed [c] and [a] is boxed [b]), but more efficient. *) -let bmake : problem -> bctxt -> term -> term = - fun p bctx a -> - let (a, k) = Ctxt.to_prod_box bctx a in - let m = fresh p a k in - let get_var (x, _) = mk_Vari x in - mk_Meta (m, Array.of_list (List.rev_map get_var bctx)) - (** [make_codomain p ctx a] creates a fresh metavariable term of type [Type] in the context [ctx] extended with a fresh variable of type [a], and updates [p] with generated metavariables. *) @@ -52,13 +41,6 @@ let make_codomain : problem -> ctxt -> term -> tbinder = fun p ctx a -> let x = new_tvar "x" in Bindlib.bind_var x (make p ((x, a, None) :: ctx) mk_Type) -(** [bmake_codomain p bctx a] is [make_codomain p bctx a] but on boxed - terms. *) -let bmake_codomain : problem -> bctxt -> term -> tbinder = - fun p bctx a -> - let x = new_tvar "x" in - Bindlib.bind_var x (bmake p ((x, a) :: bctx) mk_Type) - (** [iter b f c t] applies the function [f] to every metavariable of [t] and, if [x] is a variable of [t] mapped to [v] in the context [c], then to every metavariable of [v], and to the type of every metavariable recursively if diff --git a/src/core/term.ml b/src/core/term.ml index 70d234d1b..e5c6b6fdb 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -458,12 +458,6 @@ let minimize_impl : bool list -> bool list = first). *) type ctxt = (tvar * term * term option) list -(** Typing context with lifted terms. Used to optimise type checking and avoid - lifting terms several times. Definitions are not included because these - contexts are used to create meta variables types, which do not use [let] - definitions. *) -type bctxt = (tvar * term) list - (** Type of unification constraints. *) type constr = ctxt * term * term diff --git a/src/core/term.mli b/src/core/term.mli index 8c65c5815..a169c8744 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -285,12 +285,6 @@ end first). *) type ctxt = (tvar * term * term option) list -(** Typing context with lifted terms. Used to optimise type checking and avoid - lifting terms several times. Definitions are not included because these - contexts are used to create meta variables types, which do not use [let] - definitions. *) -type bctxt = (tvar * term) list - (** Type of unification constraints. *) type constr = ctxt * term * term From d7b6f0067475c42840be8cc524ccabfc6806e197 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 18:20:29 +0100 Subject: [PATCH 15/38] dune-project: use cmdliner <= 1.0.4 --- dune-project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dune-project b/dune-project index 6964c1b96..442a429e9 100644 --- a/dune-project +++ b/dune-project @@ -59,5 +59,5 @@ the Why3 platform.") (pratter (>= 1.2)) (why3 (>= 1.4.0)) (yojson (>= 1.6.0)) - (cmdliner (>= 1.0.3)) + (cmdliner (and (>= 1.0.3) (<= 1.0.4))) (stdlib-shims (>= 0.1.0)))) From b93ccfdd9554a95ba156df10cc2251fd717dc9a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 14 Feb 2022 18:36:14 +0100 Subject: [PATCH 16/38] lambdapi.opam: use cmdliner <= 1.0.4 --- dune-project | 13 ++++++++----- lambdapi.opam | 2 +- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/dune-project b/dune-project index 442a429e9..604fbb91f 100644 --- a/dune-project +++ b/dune-project @@ -29,13 +29,16 @@ Find Lambdapi user manual on https://lambdapi.readthedocs.io/. Lambdapi provides a rich type system with dependent types. In Lambdapi, one can define both type and function symbols -by using rewriting rules (oriented equations). The declaration -of symbols and rewriting rules is separated so that one can -easily define inductive-recursive types for instance. -Rewrite rules can be exported to the TRS and XTC formats -for checking confluence and termination with external tools. +by using rewriting rules (oriented equations). A symbol can be declared associative and commutative. Lambdapi supports unicode symbols and infix operators. +The declaration of symbols and rewriting rules is separated +so that one can easily define inductive-recursive types. + +Lambdapi checks that rules are locally confluent (by checking +the joinability of critical pairs) and preserve typing. +Rewrite rules can also be exported to the TRS and XTC formats +for checking confluence and termination with external tools. Lambdapi does not come with a pre-defined logic. It is a powerful logical framework in which one can easily define diff --git a/lambdapi.opam b/lambdapi.opam index e028c1a60..deba2e60c 100644 --- a/lambdapi.opam +++ b/lambdapi.opam @@ -57,7 +57,7 @@ depends: [ "pratter" {>= "1.2"} "why3" {>= "1.4.0"} "yojson" {>= "1.6.0"} - "cmdliner" {>= "1.0.3"} + "cmdliner" {>= "1.0.3" & <= "1.0.4"} "stdlib-shims" {>= "0.1.0"} "odoc" {with-doc} ] From 8ff86cd0e22b162fdb27a74d77ec4ad9936d240c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 15 Feb 2022 06:42:29 +0100 Subject: [PATCH 17/38] remove module Bindlib --- src/core/ctxt.ml | 16 ++--- src/core/env.ml | 18 +++--- src/core/eval.ml | 50 +++++++-------- src/core/infer.ml | 22 +++---- src/core/inverse.ml | 8 +-- src/core/libMeta.ml | 6 +- src/core/libTerm.ml | 22 +++---- src/core/print.ml | 20 +++--- src/core/sign.ml | 6 +- src/core/term.ml | 34 ++++------ src/core/term.mli | 12 ++-- src/core/tree.ml | 4 +- src/core/tree_type.ml | 2 +- src/core/unif.ml | 30 ++++----- src/export/dk.ml | 10 +-- src/export/hrs.ml | 10 +-- src/export/xtc.ml | 22 +++---- src/handle/inductive.ml | 18 +++--- src/handle/rewrite.ml | 132 +++++++++++++++++++------------------- src/handle/tactic.ml | 6 +- src/handle/why3_tactic.ml | 6 +- src/parsing/scope.ml | 22 +++---- src/parsing/syntax.ml | 4 +- src/tool/lcr.ml | 32 ++++----- src/tool/sr.ml | 22 +++---- 25 files changed, 260 insertions(+), 274 deletions(-) diff --git a/src/core/ctxt.ml b/src/core/ctxt.ml index dcbf15c61..46e1748cb 100644 --- a/src/core/ctxt.ml +++ b/src/core/ctxt.ml @@ -8,24 +8,24 @@ open Timed appears in it, and @raise [Not_found] otherwise. *) let type_of : tvar -> ctxt -> term = fun x ctx -> - let (_,a,_) = List.find (fun (y,_,_) -> Bindlib.eq_vars x y) ctx in a + let (_,a,_) = List.find (fun (y,_,_) -> eq_vars x y) ctx in a (** [def_of x ctx] returns the definition of [x] in the context [ctx] if it appears, and [None] otherwise *) let rec def_of : tvar -> ctxt -> ctxt * term option = fun x c -> match c with | [] -> [], None - | (y,_,d)::c -> if Bindlib.eq_vars x y then c,d else def_of x c + | (y,_,d)::c -> if eq_vars x y then c,d else def_of x c (** [mem x ctx] tells whether variable [x] is mapped in the context [ctx]. *) let mem : tvar -> ctxt -> bool = fun x -> - List.exists (fun (y,_,_) -> Bindlib.eq_vars x y) + List.exists (fun (y,_,_) -> eq_vars x y) (** [to_prod ctx t] builds a product by abstracting over the context [ctx], in the term [t]. It returns the number of products as well. *) let to_prod : ctxt -> term -> term * int = fun ctx t -> let f (t,c) (x,a,v) = - let b = Bindlib.bind_var x t in + let b = bind_var x t in match v with | None -> mk_Prod (a, b), c + 1 | Some v -> mk_LLet (a, v, b), c @@ -35,14 +35,14 @@ let to_prod : ctxt -> term -> term * int = fun ctx t -> (** [to_abst ctx t] builds a sequence of abstractions over the context [ctx], in the term [t]. *) let to_abst : ctxt -> term -> term = fun ctx t -> - let f t (x, a, _) = mk_Abst (a, Bindlib.bind_var x t) in + let f t (x, a, _) = mk_Abst (a, bind_var x t) in List.fold_left f t ctx (** [to_let ctx t] adds the defined variables of [ctx] on top of [t]. *) let to_let : ctxt -> term -> term = fun ctx t -> let f t = function | _, _, None -> t - | x, a, Some u -> mk_LLet (a, u, Bindlib.bind_var x t) + | x, a, Some u -> mk_LLet (a, u, bind_var x t) in List.fold_left f t ctx @@ -50,7 +50,7 @@ let to_let : ctxt -> term -> term = fun ctx t -> [vs]. *) let sub : ctxt -> tvar array -> ctxt = fun ctx vs -> let f ((x,_,_) as hyp) ctx = - if Array.exists (Bindlib.eq_vars x) vs then hyp::ctx else ctx + if Array.exists (eq_vars x) vs then hyp::ctx else ctx in List.fold_right f ctx [] @@ -64,7 +64,7 @@ let rec unfold : ctxt -> term -> term = fun ctx t -> begin match !(m.meta_value) with | None -> t - | Some(b) -> unfold ctx (Bindlib.msubst b ts) + | Some(b) -> unfold ctx (msubst b ts) end | TRef(r) -> begin diff --git a/src/core/env.ml b/src/core/env.ml index 43805dd49..f5da672a3 100644 --- a/src/core/env.ml +++ b/src/core/env.ml @@ -4,7 +4,7 @@ open Lplib open Term (** Type of an environment, used in scoping to associate names to - corresponding Bindlib variables and types. Note that it cannot be + corresponding variables and types. Note that it cannot be implemented by a map as the order is important. The structure is similar to then one of {!type:Term.ctxt}, a tuple [(x,a,t)] is a variable [x], its type [a] and possibly its definition [t] *) @@ -20,7 +20,7 @@ let empty : env = [] let add : string -> tvar -> term -> term option -> env -> env = fun n v a t env -> (n, (v, a, t)) :: env -(** [find n env] returns the Bindlib variable associated to the variable name +(** [find n env] returns the variable associated to the variable name [n] in the environment [env]. If none is found, [Not_found] is raised. *) let find : string -> env -> tvar = fun n env -> let (x,_,_) = List.assoc n env in x @@ -34,7 +34,7 @@ let mem : string -> env -> bool = List.mem_assoc you obtain a term of the form [Πx1:a1,..,Πxn:an,t]. *) let to_prod : env -> term -> term = fun env t -> let add_prod t (_,(x,a,u)) = - let b = Bindlib.bind_var x t in + let b = bind_var x t in match u with | Some u -> mk_LLet (a, u, b) | None -> mk_Prod (a, b) @@ -48,14 +48,14 @@ let to_prod : env -> term -> term = fun env t -> [to_abst [(xn,an,None);..;(x1,a1,None)] t = λx1:a1,..,λxn:an,t]. *) let to_abst : env -> term -> term = fun env t -> let add_abst t (_,(x,a,u)) = - let b = Bindlib.bind_var x t in + let b = bind_var x t in match u with | Some u -> mk_LLet (a, u, b) | None -> mk_Abst (a, b) in List.fold_left add_abst t env -(** [vars env] extracts the array of the {e not defined} Bindlib variables in +(** [vars env] extracts the array of the {e not defined} variables in [env]. Note that the order is reversed: [vars [(xn,an);..;(x1,a1)] = [|x1;..;xn|]]. *) let vars : env -> tvar array = fun env -> @@ -116,8 +116,8 @@ let of_prod_nth : ctxt -> int -> term -> env * term = fun c n t -> let rec build_env i env t = if i >= n then env, t else match_prod c t (fun a b -> - let x, b = Bindlib.unbind b in - build_env (i+1) (add (Bindlib.name_of x) x a None env) b) + let x, b = unbind b in + build_env (i+1) (add (name_of x) x a None env) b) in build_env 0 [] t (** [of_prod_using c xs t] is similar to [of_prod s c n t] where [n = @@ -131,7 +131,7 @@ let of_prod_using : ctxt -> tvar array -> term -> env * term = fun c xs t -> if i >= n then env, t else match_prod c t (fun a b -> let xi = xs.(i) in - let name = Bindlib.name_of xi in + let name = name_of xi in let env = add name xi a None env in - build_env (i+1) env (Bindlib.subst b (mk_Vari xi))) + build_env (i+1) env (subst b (mk_Vari xi))) in build_env 0 [] t diff --git a/src/core/eval.ml b/src/core/eval.ml index 6d067b7ad..4f66ad172 100644 --- a/src/core/eval.ml +++ b/src/core/eval.ml @@ -44,7 +44,7 @@ let hnf : (term -> term) -> (term -> term) = fun whnf -> let rec hnf t = match whnf t with | Abst(a,t) -> - let x, t = Bindlib.unbind t in mk_Abst(a, Bindlib.bind_var x (hnf t)) + let x, t = unbind t in mk_Abst(a, bind_var x (hnf t)) | t -> t in hnf @@ -59,13 +59,13 @@ let snf : (term -> term) -> (term -> term) = fun whnf -> | Type | Kind | Symb _ -> h - | LLet(_,t,b) -> snf (Bindlib.subst b t) + | LLet(_,t,b) -> snf (subst b t) | Prod(a,b) -> - let x, b = Bindlib.unbind b in - mk_Prod(snf a, Bindlib.bind_var x (snf b)) + let x, b = unbind b in + mk_Prod(snf a, bind_var x (snf b)) | Abst(a,b) -> - let x, b = Bindlib.unbind b in - mk_Abst(snf a, Bindlib.bind_var x (snf b)) + let x, b = unbind b in + mk_Abst(snf a, bind_var x (snf b)) | Appl(t,u) -> mk_Appl(snf t, snf u) | Meta(m,ts) -> mk_Meta(m, Array.map snf ts) | Patt(i,n,ts) -> mk_Patt(i,n,Array.map snf ts) @@ -129,10 +129,10 @@ let eq_modulo : (config -> term -> term) -> config -> term -> term -> bool = if a == b then eq cfg l else match a, b with | LLet(_,t,u), _ -> - let x,u = Bindlib.unbind u in + let x,u = unbind u in eq {cfg with varmap = VarMap.add x t cfg.varmap} ((u,b)::l) | _, LLet(_,t,u) -> - let x,u = Bindlib.unbind u in + let x,u = unbind u in eq {cfg with varmap = VarMap.add x t cfg.varmap} ((a,u)::l) | Patt(None,_,_), _ | _, Patt(None,_,_) -> assert false | Patt(Some i,_,ts), Patt(Some j,_,us) -> @@ -140,15 +140,15 @@ let eq_modulo : (config -> term -> term) -> config -> term -> term -> bool = | Db i, Db j -> if i=j then eq cfg l else raise Exit | Kind, Kind | Type, Type -> eq cfg l - | Vari x, Vari y -> if Bindlib.eq_vars x y then eq cfg l else raise Exit + | Vari x, Vari y -> if eq_vars x y then eq cfg l else raise Exit | Symb f, Symb g when f == g -> eq cfg l | Prod(a1,b1), Prod(a2,b2) | Abst(a1,b1), Abst(a2,b2) -> - let _,b1,b2 = Bindlib.unbind2 b1 b2 in eq cfg ((a1,a2)::(b1,b2)::l) + let _,b1,b2 = unbind2 b1 b2 in eq cfg ((a1,a2)::(b1,b2)::l) | Abst _, (Type|Kind|Prod _) | (Type|Kind|Prod _), Abst _ -> raise Exit | (Abst(_ ,b), t | t, Abst(_ ,b)) when !eta_equality -> - let x,b = Bindlib.unbind b in eq cfg ((b, mk_Appl(t, mk_Vari x))::l) + let x,b = unbind b in eq cfg ((b, mk_Appl(t, mk_Vari x))::l) | Meta(m1,a1), Meta(m2,a2) when m1 == m2 -> eq cfg (if a1 == a2 then l else List.add_array2 a1 a2 l) (* cases of failure *) @@ -167,13 +167,13 @@ let eq_modulo : (config -> term -> term) -> config -> term -> term -> bool = | Db i, Db j -> if i=j then eq cfg l else raise Exit | Kind, Kind | Type, Type -> eq cfg l - | Vari x, Vari y when Bindlib.eq_vars x y -> eq cfg l + | Vari x, Vari y when eq_vars x y -> eq cfg l | Symb f, Symb g when f == g -> eq cfg l | Prod(a1,b1), Prod(a2,b2) | Abst(a1,b1), Abst(a2,b2) -> - let _,b1,b2 = Bindlib.unbind2 b1 b2 in eq cfg ((a1,a2)::(b1,b2)::l) + let _,b1,b2 = unbind2 b1 b2 in eq cfg ((a1,a2)::(b1,b2)::l) | (Abst(_ ,b), t | t, Abst(_ ,b)) when !eta_equality -> - let x,b = Bindlib.unbind b in eq cfg ((b, mk_Appl(t, mk_Vari x))::l) + let x,b = unbind b in eq cfg ((b, mk_Appl(t, mk_Vari x))::l) | Meta(m1,a1), Meta(m2,a2) when m1 == m2 -> eq cfg (if a1 == a2 then l else List.add_array2 a1 a2 l) | Appl(t1,u1), Appl(t2,u2) -> eq cfg ((u1,u2)::(t1,t2)::l) @@ -217,9 +217,9 @@ and whnf_stk : config -> term -> stack -> term * stack = fun cfg t stk -> match t, stk with | Appl(f,u), stk -> whnf_stk cfg f (to_tref u::stk) | Abst(_,f), u::stk when cfg.Config.beta -> - Stdlib.incr steps; whnf_stk cfg (Bindlib.subst f u) stk + Stdlib.incr steps; whnf_stk cfg (subst f u) stk | LLet(_,t,u), stk -> - Stdlib.incr steps; whnf_stk cfg (Bindlib.subst u t) stk + Stdlib.incr steps; whnf_stk cfg (subst u t) stk | (Symb s as h, stk) as r -> begin match !(s.sym_def) with | Some t -> @@ -311,14 +311,14 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = | Some(_) -> env.(slot) <- bound.(pos) | None -> let xs = Array.map (fun e -> IntMap.find e id_vars) xs in - env.(slot) <- Some(Bindlib.bind_mvar xs vars.(pos)) + env.(slot) <- Some(bind_mvar xs vars.(pos)) in List.iter f rhs_subst; (* Complete the array with fresh meta-variables if needed. *) for i = r.vars_nb to env_len - 1 do let mt = LibMeta.make cfg.problem cfg.context mk_Type in let t = LibMeta.make cfg.problem cfg.context mt in - env.(i) <- Some(Bindlib.bind_mvar [||] t) + env.(i) <- Some(bind_mvar [||] t) done; Some (subst_patt env r.rhs, stk) | Cond({ok; cond; fail}) -> @@ -340,15 +340,15 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = in (* Ensure there are no variables from [forbidden] in [b]. *) let no_forbidden b = - not (IntMap.exists (fun _ x -> Bindlib.occur_tmbinder x b) + not (IntMap.exists (fun _ x -> occur_tmbinder x b) forbidden) in (* We first attempt to match [vars.(i)] directly. *) - let b = Bindlib.bind_mvar allowed vars.(i) in + let b = bind_mvar allowed vars.(i) in if no_forbidden b then (bound.(i) <- Some b; ok) else (* As a last resort we try matching the SNF. *) - let b = Bindlib.bind_mvar allowed (snf (whnf cfg) vars.(i)) in + let b = bind_mvar allowed (snf (whnf cfg) vars.(i)) in if no_forbidden b then (bound.(i) <- Some b; ok) else fail @@ -403,7 +403,7 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = introducing variable [id] and branching on tree [tr]. The type [a] and [b] substituted are re-inserted in the stack.*) let walk_binder a b id tr = - let (bound, body) = Bindlib.unbind b in + let (bound, body) = unbind b in let vars_id = VarMap.add bound id vars_id in let id_vars = IntMap.add id bound id_vars in let stk = List.reconstruct left (a::body::args) right in @@ -523,8 +523,8 @@ let rec simplify : term -> term = fun t -> let tags = [`NoRw; `NoExpand ] in match get_args (whnf ~tags [] t) with | Prod(a,b), _ -> - let x, b = Bindlib.unbind b in - mk_Prod (simplify a, Bindlib.bind_var x (simplify b)) + let x, b = unbind b in + mk_Prod (simplify a, bind_var x (simplify b)) | h, ts -> add_args_map h (whnf ~tags []) ts let simplify = @@ -552,7 +552,7 @@ let unfold_sym : sym -> term -> term = | _ -> h in add_args h args and unfold_sym_binder b = - let x, b = Bindlib.unbind b in Bindlib.bind_var x (unfold_sym b) + let x, b = unbind b in bind_var x (unfold_sym b) in unfold_sym in fun s -> diff --git a/src/core/infer.ml b/src/core/infer.ml index f5a830c99..024087e06 100644 --- a/src/core/infer.ml +++ b/src/core/infer.ml @@ -38,7 +38,7 @@ let coerce pb c t a b = unif pb c a b; (t, false) (** NOTE: functions {!val:type_enforce}, {!val:force} and {!val:infer} return a boolean which is true iff the typechecked term has been - modified. It allows to bypass reconstruction of some Bindlib terms (which + modified. It allows to bypass reconstruction of some terms (which call [lift |> bind_var x |> unbox]). It reduces the type checking time of Holide by 21%. *) @@ -109,7 +109,7 @@ and infer_aux : problem -> ctxt -> term -> term * term * bool = let (tsi, cuf) = force pb c ts.(i) ai in ts.(i) <- tsi; Stdlib.(cu := !cu || cuf); - let b = Bindlib.subst b ts.(i) in + let b = subst b ts.(i) in ref_esubst (i + 1) b | _ -> (* Meta type must be a product of arity greater or equal @@ -124,7 +124,7 @@ and infer_aux : problem -> ctxt -> term -> term * term * bool = (* Check that [t] is of type [t_ty], and refine it *) let t, cu_t = force pb c t t_ty in (* Unbind [u] and get new context with [x: t_ty ≔ t] *) - let (x, u) = Bindlib.unbind u in + let (x, u) = unbind u in let c = (x, t_ty, Some t)::c in (* Infer type of [u'] and refine it. *) let u, u_ty, cu_u = infer pb c u in @@ -135,12 +135,12 @@ and infer_aux : problem -> ctxt -> term -> term * term * bool = term u; raise NotTypable | _ -> () ); - let u_ty = Bindlib.bind_var x u_ty in + let u_ty = bind_var x u_ty in let top_ty = mk_LLet (t_ty, t, u_ty) in let cu = cu_t_ty || cu_t || cu_u in let top = if cu then - let u = Bindlib.bind_var x u in + let u = bind_var x u in mk_LLet(t_ty, t, u) else top in @@ -148,15 +148,15 @@ and infer_aux : problem -> ctxt -> term -> term * term * bool = | Abst (dom, b) as top -> (* Domain must by of type Type (and not Kind) *) let dom, cu_dom = force pb c dom mk_Type in - let (x, b) = Bindlib.unbind b in + let (x, b) = unbind b in let c = (x,dom,None)::c in let b, range, cu_b = infer pb c b in - let range = Bindlib.bind_var x range in + let range = bind_var x range in let top_ty = mk_Prod (dom, range) in let cu = cu_b || cu_dom in let top = if cu then - let b = Bindlib.bind_var x b in + let b = bind_var x b in mk_Abst (dom, b) else top in @@ -164,13 +164,13 @@ and infer_aux : problem -> ctxt -> term -> term * term * bool = | Prod (dom, b) as top -> (* Domain must by of type Type (and not Kind) *) let dom, cu_dom = force pb c dom mk_Type in - let (x, b) = Bindlib.unbind b in + let (x, b) = unbind b in let c = (x,dom,None)::c in let b, b_s, cu_b = type_enforce pb c b in let cu = cu_b || cu_dom in let top = if cu then - let b = Bindlib.bind_var x b in + let b = bind_var x b in mk_Prod (dom, b) else top in @@ -178,7 +178,7 @@ and infer_aux : problem -> ctxt -> term -> term * term * bool = | Appl (t, u) as top -> ( let t, t_ty, cu_t = infer pb c t in let return m t u range = - let ty = Bindlib.subst range u and cu = cu_t || m in + let ty = subst range u and cu = cu_t || m in if cu then (mk_Appl (t, u), ty, cu) else (top, ty, cu) in match Eval.whnf c t_ty with diff --git a/src/core/inverse.ml b/src/core/inverse.ml index f80dd083e..0991d5bdd 100644 --- a/src/core/inverse.ml +++ b/src/core/inverse.ml @@ -81,8 +81,8 @@ let prod_graph : sym -> (sym * sym * sym * bool) list = fun s -> match get_args a with | Symb s1, [_] -> begin - match get_args (Bindlib.subst b mk_Kind) with - | Symb(s2), [_] -> add (s0,s1,s2,Bindlib.binder_occur b) l + match get_args (subst b mk_Kind) with + | Symb(s2), [_] -> add (s0,s1,s2,binder_occur b) l | _ -> l end | _ -> l @@ -127,9 +127,9 @@ let rec inverse : sym -> term -> term = fun s v -> in let t1 = inverse s1 a in let t2 = - let x, b = Bindlib.unbind b in + let x, b = unbind b in let b = inverse s2 b in - if occ then mk_Abst (a, Bindlib.bind_var x b) else b + if occ then mk_Abst (a, bind_var x b) else b in add_args (mk_Symb s0) [t1;t2] | _ -> raise Not_found diff --git a/src/core/libMeta.ml b/src/core/libMeta.ml index 395f294da..f076e394d 100644 --- a/src/core/libMeta.ml +++ b/src/core/libMeta.ml @@ -39,7 +39,7 @@ let make : problem -> ctxt -> term -> term = updates [p] with generated metavariables. *) let make_codomain : problem -> ctxt -> term -> tbinder = fun p ctx a -> let x = new_tvar "x" in - Bindlib.bind_var x (make p ((x, a, None) :: ctx) mk_Type) + bind_var x (make p ((x, a, None) :: ctx) mk_Type) (** [iter b f c t] applies the function [f] to every metavariable of [t] and, if [x] is a variable of [t] mapped to [v] in the context [c], then to every @@ -71,10 +71,10 @@ let iter : bool -> (meta -> unit) -> ctxt -> term -> unit = fun b f c -> | None -> () end | Prod(a,b) - | Abst(a,b) -> iter a; iter (Bindlib.subst b mk_Kind) + | Abst(a,b) -> iter a; iter (subst b mk_Kind) | Appl(t,u) -> iter t; iter u | Meta(m,ts) -> f m; Array.iter iter ts; if b then iter !(m.meta_type) - | LLet(a,t,u) -> iter a; iter t; iter (Bindlib.subst u mk_Kind) + | LLet(a,t,u) -> iter a; iter t; iter (subst u mk_Kind) in iter (** [occurs m c t] tests whether the metavariable [m] occurs in the term [t] diff --git a/src/core/libTerm.ml b/src/core/libTerm.ml index 537447ff9..88a723421 100644 --- a/src/core/libTerm.ml +++ b/src/core/libTerm.ml @@ -53,27 +53,27 @@ let iter : (term -> unit) -> term -> unit = fun action -> | Patt(_,_,ts) | Meta(_,ts) -> Array.iter iter ts | Prod(a,b) - | Abst(a,b) -> iter a; iter (Bindlib.subst b mk_Kind) + | Abst(a,b) -> iter a; iter (subst b mk_Kind) | Appl(t,u) -> iter t; iter u - | LLet(a,t,u) -> iter a; iter t; iter (Bindlib.subst u mk_Kind) + | LLet(a,t,u) -> iter a; iter t; iter (subst u mk_Kind) in iter -(** [unbind_name b s] is like [Bindlib.unbind b] but returns a valid variable +(** [unbind_name b s] is like [unbind b] but returns a valid variable name when [b] binds no variable. The string [s] is the prefix of the variable's name.*) let unbind_name : string -> tbinder -> tvar * term = fun s b -> - if Bindlib.binder_occur b then Bindlib.unbind b - else let x = new_tvar s in (x, Bindlib.subst b (mk_Vari x)) + if binder_occur b then unbind b + else let x = new_tvar s in (x, subst b (mk_Vari x)) -(** [unbind2_name b1 b2 s] is like [Bindlib.unbind2 b1 b2] but returns a valid +(** [unbind2_name b1 b2 s] is like [unbind2 b1 b2] but returns a valid variable name when [b1] or [b2] binds no variable. The string [s] is the prefix of the variable's name.*) let unbind2_name : string -> tbinder -> tbinder -> tvar * term * term = fun s b1 b2 -> - if Bindlib.binder_occur b1 || Bindlib.binder_occur b2 then - Bindlib.unbind2 b1 b2 + if binder_occur b1 || binder_occur b2 then + unbind2 b1 b2 else let x = new_tvar s in - (x, Bindlib.subst b1 (mk_Vari x), Bindlib.subst b2 (mk_Vari x)) + (x, subst b1 (mk_Vari x), subst b2 (mk_Vari x)) (** [distinct_vars ctx ts] checks that the terms [ts] are distinct variables. If so, the variables are returned. *) @@ -110,7 +110,7 @@ let nl_distinct_vars let vars = ref VarSet.empty (* variables already seen (linear or not) *) and nl_vars = ref VarSet.empty (* variables occurring more then once *) and patt_vars = ref StrMap.empty in - (* map from pattern variables to actual Bindlib variables *) + (* map from pattern variables to actual variables *) let rec to_var t = match Ctxt.unfold ctx t with | Vari(v) -> @@ -155,5 +155,5 @@ let sym_to_var : tvar StrMap.t -> term -> term = fun map -> | TRef _ -> assert false | _ -> t and to_var_binder b = - let (x,b) = Bindlib.unbind b in Bindlib.bind_var x (to_var b) + let (x,b) = unbind b in bind_var x (to_var b) in fun t -> if StrMap.is_empty map then t else to_var t diff --git a/src/core/print.ml b/src/core/print.ml index a25efd22c..234be1207 100644 --- a/src/core/print.ml +++ b/src/core/print.ml @@ -89,7 +89,7 @@ let sym : sym pp = fun ppf s -> else out ppf "%a.%a" path p uid n | Some alias -> out ppf "%a.%a" uid alias uid n -let var : tvar pp = fun ppf x -> uid ppf (Bindlib.name_of x) +let var : tvar pp = fun ppf x -> uid ppf (name_of x) (** Exception raised when trying to convert a term into a nat. *) exception Not_a_nat @@ -192,7 +192,7 @@ and term : term pp = fun ppf t -> begin match unfold b with | Abst(a,b) -> - let (x,p) = Bindlib.unbind b in + let (x,p) = unbind b in out ppf "`%a %a%a, %a" sym s var x typ a func p | _ -> assert false end @@ -221,32 +221,32 @@ and term : term pp = fun ppf t -> (* Product and abstraction (only them can be wrapped). *) | Abst(a,b) -> if wrap then out ppf "("; - let (x,t) = Bindlib.unbind b in + let (x,t) = unbind b in out ppf "λ %a" bvar (b,x); if !print_domains then out ppf ": %a, %a" func a func t else abstractions ppf t; if wrap then out ppf ")" | Prod(a,b) -> if wrap then out ppf "("; - let (x,t) = Bindlib.unbind b in - if Bindlib.binder_occur b then + let (x,t) = unbind b in + if binder_occur b then out ppf "Π %a: %a, %a" var x appl a func t else out ppf "%a → %a" appl a func t; if wrap then out ppf ")" | LLet(a,t,b) -> if wrap then out ppf "("; out ppf "let "; - let (x,u) = Bindlib.unbind b in + let (x,u) = unbind b in bvar ppf (b,x); if !print_domains then out ppf ": %a" atom a; out ppf " ≔ %a in %a" func t func u; if wrap then out ppf ")" and bvar ppf (b,x) = - if Bindlib.binder_occur b then out ppf "%a" var x else out ppf "_" + if binder_occur b then out ppf "%a" var x else out ppf "_" and abstractions ppf t = match unfold t with | Abst(_,b) -> - let (x,t) = Bindlib.unbind b in + let (x,t) = unbind b in out ppf " %a%a" bvar (b,x) abstractions t | t -> out ppf ", %a" func t in @@ -258,10 +258,10 @@ and term : term pp = fun ppf t -> let rec prod : (term * bool list) pp = fun ppf (t, impl) -> match unfold t, impl with | Prod(a,b), true::impl -> - let x, b = Bindlib.unbind b in + let x, b = unbind b in out ppf "Π {%a: %a}, %a" var x term a prod (b, impl) | Prod(a,b), false::impl -> - let x, b = Bindlib.unbind b in + let x, b = unbind b in out ppf "Π %a: %a, %a" var x term a prod (b, impl) | _ -> term ppf t diff --git a/src/core/sign.ml b/src/core/sign.ml index 2ab218cc5..ba8176f42 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -106,7 +106,7 @@ let link : t -> unit = fun sign -> | Wild -> assert false | TRef _ -> assert false and link_binder b = - let (x,t) = Bindlib.unbind b in Bindlib.bind_var x (link_term t) + let (x,t) = unbind b in bind_var x (link_term t) in link_term in let link_lhs = link_term mk_Appl_not_canonical @@ -178,7 +178,7 @@ let unlink : t -> unit = fun sign -> | Vari _ | Type | Kind -> () - and unlink_binder b = unlink_term (snd (Bindlib.unbind b)) in + and unlink_binder b = unlink_term (snd (unbind b)) in let unlink_rule r = List.iter unlink_term r.lhs; unlink_term r.rhs @@ -283,7 +283,7 @@ let read : string -> t = fun fname -> | Wild -> assert false | Meta _ -> assert false | Plac _ -> assert false - and reset_binder b = reset_term (snd (Bindlib.unbind b)) in + and reset_binder b = reset_term (snd (unbind b)) in let reset_rule r = List.iter reset_term r.lhs; reset_term r.rhs diff --git a/src/core/term.ml b/src/core/term.ml index e5c6b6fdb..42f8acaf3 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -1,11 +1,7 @@ (** Internal representation of terms. This module contains the definition of the internal representation of - terms, together with smart constructors and low level operation. The - representation strongly relies on the {!module:Bindlib} library, which - provides a convenient abstraction to work with binders. - - @see *) + terms, together with smart constructors and low level operation. *) open Timed open Lplib open Base @@ -157,7 +153,7 @@ and sym = the form {!constructor:Patt}[(Some i,s,e)] matched against a term [u] will results in [env.(i)] being set to [u]. If all terms of [ts] can be matched against corresponding patterns, then environment [env] is fully constructed - and it can hence be substituted in [r.rhs] with [Bindlib.msubst r.rhs env] + and it can hence be substituted in [r.rhs] with [msubst r.rhs env] to get the result of the application of the rule. *) (** {3 Metavariables and related functions} *) @@ -180,8 +176,6 @@ and tmbinder = string array * term and tvar = int * string -module Bindlib = struct - (** [unfold t] repeatedly unfolds the definition of the surface constructor of [t], until a significant {!type:term} constructor is found. The term that is returned cannot be an instantiated metavariable or term @@ -437,14 +431,10 @@ let occur : tvar -> term -> bool = fun x -> let occur_tmbinder : tvar -> tmbinder -> bool = fun x (_,t) -> occur x t -end - -let unfold = Bindlib.unfold - (** Printing functions for debug. *) module Raw = struct - let sym = Bindlib.sym - let term = Bindlib.term + let sym = sym + let term = term end (** Minimize [impl] to enforce our invariant (see {!type:Terms.sym}). *) @@ -452,7 +442,7 @@ let minimize_impl : bool list -> bool list = let rec rem_false l = match l with false::l -> rem_false l | _ -> l in fun l -> List.rev (rem_false (List.rev l)) -(** Typing context associating a [Bindlib] variable to a type and possibly a +(** Typing context associating a [ variable to a type and possibly a definition. The typing environment [x1:A1,..,xn:An] is represented by the list [xn:An;..;x1:A1] in reverse order (last added variable comes first). *) @@ -464,14 +454,14 @@ type constr = ctxt * term * term (** Sets and maps of term variables. *) module Var = struct type t = tvar - let compare = Bindlib.compare_vars + let compare = compare_vars end module VarSet = Set.Make(Var) module VarMap = Map.Make(Var) (** [new_tvar s] creates a new [tvar] of name [s]. *) -let new_tvar : string -> tvar = Bindlib.new_var +let new_tvar : string -> tvar = new_var (** [new_tvar_ind s i] creates a new [tvar] of name [s ^ string_of_int i]. *) let new_tvar_ind : string -> int -> tvar = fun s i -> @@ -561,7 +551,7 @@ let is_symb : sym -> term -> bool = fun s t -> (** Total order on terms. *) let rec cmp : term cmp = fun t t' -> match unfold t, unfold t' with - | Vari x, Vari x' -> Bindlib.compare_vars x x' + | Vari x, Vari x' -> compare_vars x x' | Type, Type | Kind, Kind | Wild, Wild -> 0 @@ -610,14 +600,14 @@ let get_args_len : term -> term * term list * int = fun t -> application is built as a left or right comb depending on the associativity of the symbol, and arguments are ordered in increasing order wrt [cmp]. -- In [LLet(_,_,b)], [Bindlib.binder_constant b = false] (useless let's are +- In [LLet(_,_,b)], [binder_constant b = false] (useless let's are erased). *) let mk_Vari x = Vari x let mk_Type = Type let mk_Kind = Kind let mk_Symb x = Symb x let mk_Prod (a,b) = Prod (a,b) -let mk_Impl (a,b) = let x = new_tvar "_" in Prod(a, Bindlib.bind_var x b) +let mk_Impl (a,b) = let x = new_tvar "_" in Prod(a, bind_var x b) let mk_Abst (a,b) = Abst (a,b) let mk_Meta (m,ts) = (*assert (m.meta_arity = Array.length ts);*) Meta (m,ts) let mk_Patt (i,s,ts) = Patt (i,s,ts) @@ -626,7 +616,7 @@ let mk_Plac b = Plac b let mk_TRef x = TRef x let mk_LLet (a,t,u) = - if Bindlib.binder_constant u then Bindlib.subst u Kind else LLet (a,t,u) + if binder_constant u then subst u Kind else LLet (a,t,u) (* We make the equality of terms modulo commutative and associative-commutative symbols syntactic by always ordering arguments in @@ -764,7 +754,7 @@ let subst_patt : tmbinder option array -> term -> term = fun env -> match unfold t with | Patt(Some i,n,ts) when 0 <= i && i < Array.length env -> begin match env.(i) with - | Some b -> Bindlib.msubst b (Array.map subst_patt ts) + | Some b -> msubst b (Array.map subst_patt ts) | None -> mk_Patt(Some i,n,Array.map subst_patt ts) end | Patt(i,n,ts) -> mk_Patt(i, n, Array.map subst_patt ts) diff --git a/src/core/term.mli b/src/core/term.mli index a169c8744..00ffa5a33 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -2,7 +2,7 @@ This module contains the definition of the internal representation of terms, together with smart constructors and low level operation. The - representation strongly relies on the {!module:Bindlib} library, which + representation strongly relies on the {!module: library, which provides a convenient abstraction to work with binders. @see *) @@ -189,7 +189,7 @@ and sym = the form {!constructor:Patt}[(Some i,s,e)] matched against a term [u] will results in [env.(i)] being set to [u]. If all terms of [ts] can be matched against corresponding patterns, then environment [env] is fully constructed - and it can hence be substituted in [r.rhs] with [Bindlib.msubst r.rhs env] + and it can hence be substituted in [r.rhs] with [msubst r.rhs env] to get the result of the application of the rule. *) (** {3 Metavariables and related functions} *) @@ -206,8 +206,6 @@ and sym = ; meta_arity : int (** Arity (environment size). *) ; meta_value : tmbinder option ref (** Definition. *) } -module Bindlib : sig - (** [subst b v] substitutes the variable bound by [b] with the value [v]. *) val subst : tbinder -> term -> term @@ -269,8 +267,6 @@ val is_closed_tmbinder : tmbinder -> bool val occur : tvar -> term -> bool val occur_tmbinder : tvar -> tmbinder -> bool -end - (** Minimize [impl] to enforce our invariant (see {!type:Term.sym}). *) val minimize_impl : bool list -> bool list @@ -279,7 +275,7 @@ module Raw : sig val term : term pp end -(** Typing context associating a [Bindlib] variable to a type and possibly a +(** Typing context associating a [ variable to a type and possibly a definition. The typing environment [x1:A1,..,xn:An] is represented by the list [xn:An;..;x1:A1] in reverse order (last added variable comes first). *) @@ -390,7 +386,7 @@ val get_args_len : term -> term * term list * int application is built as a left or right comb depending on the associativity of the symbol, and arguments are ordered in increasing order wrt [cmp]. -- In [LLet(_,_,b)], [Bindlib.binder_constant b = false] (useless let's are +- In [LLet(_,_,b)], [binder_constant b = false] (useless let's are erased). *) val mk_Vari : tvar -> term val mk_Type : term diff --git a/src/core/tree.ml b/src/core/tree.ml index a2a81a8f4..bcae8ad9a 100644 --- a/src/core/tree.ml +++ b/src/core/tree.ml @@ -521,7 +521,7 @@ module CM = struct then Some({r with c_lhs = insert (Array.of_list args)}) else None | Vari(x), Vari(y) -> - if lenh = lenp && Bindlib.eq_vars x y + if lenh = lenp && eq_vars x y then Some({r with c_lhs = insert (Array.of_list args)}) else None | _ , Patt(_) -> @@ -592,7 +592,7 @@ module CM = struct | t -> let (a, b) = get t in assert (pargs = []) ; (* Patterns in β-normal form *) - let b = Bindlib.subst b (mk_Vari v) in + let b = subst b (mk_Vari v) in Some({r with c_lhs = insert r [|a; b|]}) in diff --git a/src/core/tree_type.ml b/src/core/tree_type.ml index 415aab1d4..545925d4b 100644 --- a/src/core/tree_type.ml +++ b/src/core/tree_type.ml @@ -18,7 +18,7 @@ module TC = | Vari of int (** A bound variable identified by a ({e branch}-wise) unique integer. These variables are used with a bidirectional map (implemented as - two maps) to a higher order (Bindlib) variable. They are also used + two maps) to a higher order ( variable. They are also used in the environment builder to refer to the higher order variables a term may depend on. *) diff --git a/src/core/unif.ml b/src/core/unif.ml index 770159933..5d7658d63 100644 --- a/src/core/unif.ml +++ b/src/core/unif.ml @@ -28,19 +28,19 @@ let set_to_prod : problem -> meta -> unit = fun p m -> let env' = Env.add "y" y (mk_Meta (m1, xs)) None env in let u2 = Env.to_prod env' s in let m2 = LibMeta.fresh p u2 (n+1) in - let b = Bindlib.bind_var y (mk_Meta (m2, Array.append xs [|mk_Vari y|])) in + let b = bind_var y (mk_Meta (m2, Array.append xs [|mk_Vari y|])) in (* result *) let r = mk_Prod (a, b) in if Logger.log_enabled () then log (red "%a ≔ %a") meta m term r; - LibMeta.set p m (Bindlib.bind_mvar vs r) + LibMeta.set p m (bind_mvar vs r) (** [type_app c a ts] returns [Some u] where [u] is a type of [add_args x ts] in context [c] where [x] is any term of type [a] if [x] can be applied to at least [List.length ts] arguments, and [None] otherwise. *) let rec type_app : ctxt -> term -> term list -> term option = fun c a ts -> match Eval.whnf c a, ts with - | Prod(_,b), t::ts -> type_app c (Bindlib.subst b t) ts + | Prod(_,b), t::ts -> type_app c (subst b t) ts | _, [] -> Some a | _, _ -> None @@ -108,7 +108,7 @@ let instantiation : | Some(vs, map) -> if LibMeta.occurs m c u then None else let u = Eval.simplify (Ctxt.to_let c (sym_to_var map u)) in - Some (Logger.set_debug_in false 'm' (Bindlib.bind_mvar vs) u) + Some (Logger.set_debug_in false 'm' (bind_mvar vs) u) (** Checking type or not during meta instanciation. *) let do_type_check = Stdlib.ref true @@ -120,7 +120,7 @@ let instantiate : problem -> ctxt -> meta -> term array -> term -> bool = fun p c m ts u -> if Logger.log_enabled () then log "try instantiate"; match instantiation c m ts u with - | Some b when Bindlib.is_closed_tmbinder b -> + | Some b when is_closed_tmbinder b -> let do_instantiate() = if Logger.log_enabled () then log (red "%a ≔ %a") meta m term u; LibMeta.set p m b; @@ -217,12 +217,12 @@ let imitate_inj : | Prod(a,b) -> let m = LibMeta.fresh p (Env.to_prod env a) k in let u = mk_Meta (m,vs) in - build (i-1) (u::acc) (Bindlib.subst b u) + build (i-1) (u::acc) (subst b u) | _ -> raise Cannot_imitate in build (List.length ts) [] !(s.sym_type) in if Logger.log_enabled () then log (red "%a ≔ %a") meta m term t; - LibMeta.set p m (Bindlib.bind_mvar vars t); true + LibMeta.set p m (bind_mvar vars t); true with Cannot_imitate | Invalid_argument _ -> false (** [imitate_lam_cond h ts] tells whether [ts] is headed by a variable not @@ -232,7 +232,7 @@ let imitate_lam_cond : term -> term list -> bool = fun h ts -> | [] -> false | e :: _ -> match unfold e with - | Vari x -> not (Bindlib.occur x h) + | Vari x -> not (occur x h) | _ -> false (** For a problem of the form [Appl(m[ts],[Vari x;_]) ≡ _], where [m] is a @@ -274,15 +274,15 @@ let imitate_lam : problem -> ctxt -> meta -> unit = fun p c m -> let tm3 = Env.to_prod env' mk_Type in let m3 = LibMeta.fresh p tm3 (n+1) in let b = mk_Meta (m3, Env.to_terms env') in - let u = mk_Prod (a, Bindlib.bind_var x b) in + let u = mk_Prod (a, bind_var x b) in add_constr p (Env.to_ctxt env, u, t); x, a, env', b in let tm1 = Env.to_prod env' b in let m1 = LibMeta.fresh p tm1 (n+1) in let u1 = mk_Meta (m1, Env.to_terms env') in - let xu1 = mk_Abst (a, Bindlib.bind_var x u1) in - let v = Bindlib.bind_mvar (Env.vars env) xu1 in + let xu1 = mk_Abst (a, bind_var x u1) in + let v = bind_mvar (Env.vars env) xu1 in if Logger.log_enabled () then log (red "%a ≔ %a") meta m term xu1; LibMeta.set p m v @@ -373,11 +373,11 @@ let solve : problem -> unit = fun p -> (* [ts1] and [ts2] must be empty because of typing or normalization. *) if Logger.log_enabled () then log "decompose"; add_constr p (c,a1,a2); - let (x,b1,b2) = Bindlib.unbind2 b1 b2 in + let (x,b1,b2) = unbind2 b1 b2 in let c' = (x,a1,None)::c in add_constr p (c',b1,b2); - | Vari x1, Vari x2 when Bindlib.eq_vars x1 x2 -> + | Vari x1, Vari x2 when eq_vars x1 x2 -> if List.same_length ts1 ts2 then decompose p c ts1 ts2 else error t1 t2 @@ -430,11 +430,11 @@ let solve : problem -> unit = fun p -> (* [ts1] and [ts2] must be empty because of typing or normalization. *) if Logger.log_enabled () then log "decompose"; add_constr p (c,a1,a2); - let (x,b1,b2) = Bindlib.unbind2 b1 b2 in + let (x,b1,b2) = unbind2 b1 b2 in let c' = (x,a1,None)::c in add_constr p (c',b1,b2) - | Vari x1, Vari x2 when Bindlib.eq_vars x1 x2 -> + | Vari x1, Vari x2 when eq_vars x1 x2 -> if List.same_length ts1 ts2 then decompose p c ts1 ts2 else error t1 t2 diff --git a/src/export/dk.ml b/src/export/dk.ml index 216b2b433..e4cfe4eb9 100644 --- a/src/export/dk.ml +++ b/src/export/dk.ml @@ -108,7 +108,7 @@ let cmp : decl cmp = cmp_map (Lplib.Option.cmp Pos.cmp) pos_of_decl (** Translation of terms. *) -let tvar : tvar pp = fun ppf v -> ident ppf (Bindlib.name_of v) +let tvar : tvar pp = fun ppf v -> ident ppf (name_of v) (** [term b ppf t] prints term [t]. Print abstraction domains if [b]. *) let rec term : bool -> term pp = fun b ppf t -> @@ -118,19 +118,19 @@ let rec term : bool -> term pp = fun b ppf t -> | Kind -> assert false | Symb s -> qid ppf (s.sym_path, s.sym_name) | Prod(t,u) -> - let x,u' = Bindlib.unbind u in - if Bindlib.binder_constant u + let x,u' = unbind u in + if binder_constant u then out ppf "(%a -> %a)" (term b) t (term b) u' else out ppf "(%a : %a -> %a)" tvar x (term b) t (term b) u' | Abst(t,u) -> - let x,u = Bindlib.unbind u in + let x,u = unbind u in if b then out ppf "(%a : %a => %a)" tvar x (term b) t (term b) u else out ppf "(%a => %a)" tvar x (term b) u | Appl _ -> let h, ts = get_args t in out ppf "(%a%a)" (term b) h (List.pp (prefix " " (term b)) "") ts | LLet(a,t,u) -> - let x,u = Bindlib.unbind u in + let x,u = unbind u in out ppf "((%a : %a := %a) => %a)" tvar x (term b) a (term b) t (term b) u | Patt(None,_,_) -> assert false | Patt(Some i,_,[||]) -> int ppf i diff --git a/src/export/hrs.ml b/src/export/hrs.ml index 932b6b410..6f9610a02 100644 --- a/src/export/hrs.ml +++ b/src/export/hrs.ml @@ -37,13 +37,13 @@ let print_term : bool -> term pp = fun lhs -> (mk_Patt(Some i,n,[||])) ts) | Appl(t,u) -> out ppf "app(%a,%a)" pp t pp u | Abst(a,t) -> - let (x, t) = Bindlib.unbind t in + let (x, t) = unbind t in if lhs then out ppf "lam(m_typ,\\%a.%a)" var x pp t else out ppf "lam(%a,\\%a.%a)" pp a var x pp t | Prod(a,b) -> - let (x, b) = Bindlib.unbind b in + let (x, b) = unbind b in out ppf "pi(%a,\\%a.%a)" pp a var x pp b - | LLet(_,t,u) -> pp ppf (Bindlib.subst u t) + | LLet(_,t,u) -> pp ppf (subst u t) in pp (** [print_rule ppf lhs rhs] outputs the rule declaration [lhs]->[rhs] @@ -60,8 +60,8 @@ let print_rule : Format.formatter -> term -> term -> unit = let name = Format.sprintf "$%d" i in Stdlib.(names := StrSet.add name !names) | Abst(_,b) -> - let (x, _) = Bindlib.unbind b in - Stdlib.(names := StrSet.add (Bindlib.name_of x) !names) + let (x, _) = unbind b in + Stdlib.(names := StrSet.add (name_of x) !names) | _ -> () in LibTerm.iter fn t; diff --git a/src/export/xtc.ml b/src/export/xtc.ml index ed2bb436a..14a249725 100644 --- a/src/export/xtc.ml +++ b/src/export/xtc.ml @@ -22,7 +22,7 @@ let status : sym -> symb_status = fun s -> already gone under a product *) let rec is_arrow_kind : Term.term -> bool -> symb_status = fun t b -> match t with - | Prod(_,b) -> is_arrow_kind (snd (Bindlib.unbind b)) true + | Prod(_,b) -> is_arrow_kind (snd (unbind b)) true | Type -> if b then Type_cstr else Basic_type | _ -> Object_level in is_arrow_kind !(s.sym_type) false @@ -54,10 +54,10 @@ let rec print_term : int -> string -> term pp = fun i s ppf t -> | Appl(t,u) -> out ppf "@.%a%a@." (print_term i s) t (print_term i s) u | Abst(a,t) -> - let (x, t) = Bindlib.unbind t in + let (x, t) = unbind t in out ppf "@.v_%a@.%a@.%a@." var x (print_type i s) a (print_term i s) t - | LLet(_,t,u) -> print_term i s ppf (Bindlib.subst u t) + | LLet(_,t,u) -> print_term i s ppf (subst u t) and print_type : int -> string -> term pp = fun i s ppf t -> match unfold t with @@ -77,21 +77,21 @@ and print_type : int -> string -> term pp = fun i s ppf t -> | Appl(t,u) -> out ppf "@.%a%a@." (print_type i s) t (print_term i s) u | Abst(a,t) -> - let (x, t) = Bindlib.unbind t in + let (x, t) = unbind t in out ppf "@.v_%a@.%a@.%a@." var x (print_type i s) a (print_type i s) t | Prod(a,b) -> - if Bindlib.binder_constant b + if binder_constant b then out ppf "@.@.%a@.@.%a@.@." (print_type i s) a - (print_type i s) (snd (Bindlib.unbind b)) + (print_type i s) (snd (unbind b)) else - let (x, b) = Bindlib.unbind b in + let (x, b) = unbind b in out ppf "@.v_%a@." var x; out ppf "@.%a@.@.%a@." (print_type i s) a (print_type i s) b - | LLet(_,t,u) -> print_type i s ppf (Bindlib.subst u t) + | LLet(_,t,u) -> print_type i s ppf (subst u t) (** [print_rule ppf s r] outputs the rule declaration corresponding [r] (on the symbol [s]), to [ppf]. *) @@ -130,8 +130,8 @@ let get_vars : sym -> rule -> (string * Term.term) list = fun s r -> | Vari _ -> assert false | Symb (_) -> t | Abst (t1, b) -> - let (x,t2) = Bindlib.unbind b in - mk_Abst(subst_patt v t1, Bindlib.bind_var x (subst_patt v t2)) + let (x,t2) = unbind b in + mk_Abst(subst_patt v t1, bind_var x (subst_patt v t2)) | Appl (t1, t2) -> mk_Appl(subst_patt v t1, subst_patt v t2) | Patt (None, _, _) -> assert false | Patt (Some(i), _, a) -> @@ -163,7 +163,7 @@ let get_vars : sym -> rule -> (string * Term.term) list = fun s r -> | Some _ -> let cs = List.rev_map (fun (_,t,u) -> (t,u)) !p.to_solve in let ctx = List.map (fun (x,a,_) -> (x,a)) ctx in - List.map (fun (v,ty) -> Bindlib.name_of v, List.assoc ty cs) ctx + List.map (fun (v,ty) -> name_of v, List.assoc ty cs) ctx (** [to_XTC ppf sign] outputs a XTC representation of the rewriting system of the signature [sign] to [ppf]. *) diff --git a/src/handle/inductive.ml b/src/handle/inductive.ml index 780654d12..383336370 100644 --- a/src/handle/inductive.ml +++ b/src/handle/inductive.ml @@ -48,8 +48,8 @@ let gen_safe_prefixes : inductive -> string * string * string = let rec add_name_from_type set t = match unfold t with | Prod(_,b) -> - let x,b = Bindlib.unbind b in - add_name_from_type (StrSet.add (Bindlib.name_of x) set) b + let x,b = unbind b in + add_name_from_type (StrSet.add (name_of x) set) b | _ -> set in let add_name_from_sym set sym = @@ -89,7 +89,7 @@ let ind_typ_with_codom : | (Prod(a,b), _) -> let name = Stdlib.(incr i; x_str ^ string_of_int (!i)) in let (x,b) = LibTerm.unbind_name name b in - mk_Prod (a, Bindlib.bind_var x (aux (x::xs) b)) + mk_Prod (a, bind_var x (aux (x::xs) b)) | _ -> fatal pos "The type of %a is not supported" sym ind_sym in aux (List.map (fun (_,(v,_,_)) -> v) env) a @@ -123,7 +123,7 @@ let create_ind_pred_map : (* predicate conclusion *) let codom ts = let x = new_tvar x_str in - let t = Bindlib.bind_var x + let t = bind_var x (prf_of c ind_var (List.remove_heads arity ts) (mk_Vari x)) in mk_Prod (add_args (mk_Symb ind_sym) ts, t) in @@ -255,10 +255,10 @@ let gen_rec_types : in let acc_rec_dom _ _ _ = () in let rec_dom t x v next = - mk_Prod (t, Bindlib.bind_var x (mk_Impl (v, next))) + mk_Prod (t, bind_var x (mk_Impl (v, next))) in let acc_nonrec_dom _ _ = () in - let nonrec_dom t x next = mk_Prod (t, Bindlib.bind_var x next) in + let nonrec_dom t x next = mk_Prod (t, bind_var x next) in let codom xs _ p ts = prf_of c p (List.remove_heads n ts) (add_args (mk_Symb cons_sym) (List.rev_map mk_Vari xs)) @@ -277,7 +277,7 @@ let gen_rec_types : in let rec_typ = List.fold_right add_clauses_ind ind_list d.ind_conclu in let add_quantifier t (_,d) = - mk_Prod (d.ind_type, Bindlib.bind_var d.ind_var t) in + mk_Prod (d.ind_type, bind_var d.ind_var t) in let rec_typ = List.fold_left add_quantifier rec_typ ind_pred_map in let rec_typ = Env.to_prod env rec_typ in rec_typ @@ -322,7 +322,7 @@ let iter_rec_rules : let head = P.appl_wild head n in (* add a predicate variable for each inductive type *) let head = - let apred (_,d) t = apatt t (Bindlib.name_of d.ind_var) in + let apred (_,d) t = apatt t (name_of d.ind_var) in List.fold_right apred ind_pred_map head in (* add a case variable for each constructor *) @@ -347,7 +347,7 @@ let iter_rec_rules : let env_appl t env = List.fold_right (fun (_,(x,_,_)) t -> P.appl t (P.var x)) env t in let add_abst t (_,(x,_,_)) = - P.abst (Some (Pos.none (Bindlib.name_of x))) t in + P.abst (Some (Pos.none (name_of x))) t in List.fold_left add_abst (arec s ts (env_appl x env)) env in let acc_rec_dom acc x aux = P.appl (P.appl acc x) aux in diff --git a/src/handle/rewrite.ml b/src/handle/rewrite.ml index 5c4e453d7..ca6c12a11 100644 --- a/src/handle/rewrite.ml +++ b/src/handle/rewrite.ml @@ -33,7 +33,7 @@ let _ = let check_t_or_p _ss pos sym = let valid = match Eval.whnf [] !(sym.sym_type) with - | Prod(_, b) -> Eval.eq_modulo [] (snd (Bindlib.unbind b)) mk_Type + | Prod(_, b) -> Eval.eq_modulo [] (snd (unbind b)) mk_Type | _ -> false in if not valid then @@ -60,7 +60,7 @@ let _ = let a = new_tvar "a" in let term_T_a = mk_Appl (mk_Symb symb_T, mk_Vari a) in let impls = mk_Impl (term_T_a, mk_Impl (term_T_a, term_Prop)) in - mk_Prod (term_U, Bindlib.bind_var a impls) + mk_Prod (term_U, bind_var a impls) in register_builtin "eq" expected_eq_type; let expected_refl_type pos map = @@ -75,8 +75,8 @@ let _ = let appl_eq = mk_Appl (mk_Appl (appl_eq, mk_Vari x), mk_Vari x) in let appl = mk_Appl (mk_Symb symb_P, appl_eq) in let term_T_a = mk_Appl (mk_Symb symb_T, mk_Vari a) in - let prod = mk_Prod (term_T_a, Bindlib.bind_var x appl) in - mk_Prod (term_U, Bindlib.bind_var a prod) + let prod = mk_Prod (term_T_a, bind_var x appl) in + mk_Prod (term_U, bind_var a prod) in register_builtin "refl" expected_refl_type; let expected_eqind_type pos map = @@ -98,12 +98,12 @@ let _ = let term_P_p_y = mk_Appl (term_P, mk_Appl (mk_Vari p, mk_Vari y)) in let impl = mk_Impl (term_P_p_y, term_P_p_x) in let prod = - mk_Prod (mk_Impl (term_T_a, term_Prop), Bindlib.bind_var p impl) in + mk_Prod (mk_Impl (term_T_a, term_Prop), bind_var p impl) in let eq = add_args term_eq [mk_Vari a; mk_Vari x; mk_Vari y] in let impl = mk_Impl (mk_Appl(term_P, eq), prod) in - let prod = mk_Prod (term_T_a, Bindlib.bind_var y impl) in - let prod = mk_Prod (term_T_a, Bindlib.bind_var x prod) in - mk_Prod (term_U, Bindlib.bind_var a prod) + let prod = mk_Prod (term_T_a, bind_var y impl) in + let prod = mk_Prod (term_T_a, bind_var x prod) in + mk_Prod (term_U, bind_var a prod) in register_builtin "eqind" expected_eqind_type @@ -123,7 +123,7 @@ let get_eq_data : let rec get_eq vs t notin_whnf = if Logger.log_enabled () then log_rewr "get_eq %a" term t; match get_args t with - | Prod(_,t), _ -> let v,t = Bindlib.unbind t in get_eq (v::vs) t true + | Prod(_,t), _ -> let v,t = unbind t in get_eq (v::vs) t true | p, [u] when is_symb cfg.symb_P p -> begin let u = Eval.whnf ~tags:[`NoRw; `NoExpand] [] u in @@ -187,7 +187,7 @@ let matches : term -> term -> bool = let add_args l = List.fold_left2 (fun l pi ti -> (pi,ti)::l) l ps ts in match hp, ht with - | Vari x, Vari y when Bindlib.eq_vars x y -> eq (add_args l) + | Vari x, Vari y when eq_vars x y -> eq (add_args l) | Symb f, Symb g when f == g -> eq (add_args l) | _ -> if Logger.log_enabled() then log_rewr "distinct heads"; @@ -209,7 +209,7 @@ let matches : term -> term -> bool = let matching_subs : to_subst -> term -> term array option = fun (xs,p) t -> (* We replace [xs] by fresh [TRef]'s. *) let ts = Array.map (fun _ -> mk_TRef(ref None)) xs in - let p = Bindlib.msubst (Bindlib.bind_mvar xs p) ts in + let p = msubst (bind_mvar xs p) ts in if matches p t then Some(Array.map unfold ts) else None (** [find_subst (xs,p) t] tries to find the first instance of a subterm of [t] @@ -265,14 +265,14 @@ let bind_pattern : term -> term -> tbinder = fun p t -> match unfold t with | Appl(t,u) -> mk_Appl (replace t, replace u) | Prod(a,b) -> - let x,b = Bindlib.unbind b in - mk_Prod (replace a, Bindlib.bind_var x (replace b)) + let x,b = unbind b in + mk_Prod (replace a, bind_var x (replace b)) | Abst(a,b) -> - let x,b = Bindlib.unbind b in - mk_Abst (replace a, Bindlib.bind_var x (replace b)) + let x,b = unbind b in + mk_Abst (replace a, bind_var x (replace b)) | LLet(typ, def, body) -> - let x, body = Bindlib.unbind body in - mk_LLet (replace typ, replace def, Bindlib.bind_var x (replace body)) + let x, body = unbind body in + mk_LLet (replace typ, replace def, bind_var x (replace body)) | Meta(m,ts) -> mk_Meta (m, Array.map replace ts) | Db _ -> assert false | Wild -> assert false @@ -281,7 +281,7 @@ let bind_pattern : term -> term -> tbinder = fun p t -> | Plac _ -> assert false | _ -> t in - Bindlib.bind_var z (replace t) + bind_var z (replace t) (** [swap cfg a r l t] returns a term of type [P (eq a l r)] from a term [t] of type [P (eq a r l)]. *) @@ -291,7 +291,7 @@ let swap : eq_config -> term -> term -> term -> term -> term = let pred = let x = new_tvar "x" in let pred = add_args (mk_Symb cfg.symb_eq) [a; l; mk_Vari x] in - mk_Abst(mk_Appl(mk_Symb cfg.symb_T, a), Bindlib.bind_var x pred) + mk_Abst(mk_Appl(mk_Symb cfg.symb_T, a), bind_var x pred) in (* We build the proof term. *) let refl_a_l = add_args (mk_Symb cfg.symb_refl) [a; l] in @@ -334,7 +334,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> let (t, l, r) = if l2r then (t, l, r) else (swap cfg a l r t, r, l) in (* Bind the variables in this new witness. *) - let bound = let bind = Bindlib.bind_mvar vars in bind t, bind l, bind r in + let bound = let bind = bind_mvar vars in bind t, bind l, bind r in (* Extract the term from the goal type (get “u” from “P u”). *) let g_term = @@ -357,9 +357,9 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> term g_term term l in (* Build the required data from that substitution. *) - let (t, l, r) = Bindlib.msubst3 bound sigma in + let (t, l, r) = msubst3 bound sigma in let pred_bind = bind_pattern l g_term in - (pred_bind, Bindlib.subst pred_bind r, t, l, r) + (pred_bind, subst pred_bind r, t, l, r) (* Basic patterns. *) | Some(Rw_Term(p)) -> @@ -380,9 +380,9 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> term match_p term l in (* Build the data from the substitution. *) - let (t, l, r) = Bindlib.msubst3 bound sigma in + let (t, l, r) = msubst3 bound sigma in let pred_bind = bind_pattern l g_term in - (pred_bind, Bindlib.subst pred_bind r, t, l, r) + (pred_bind, subst pred_bind r, t, l, r) (* Nested patterns. *) | Some(Rw_InTerm(p)) -> @@ -403,14 +403,14 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> term match_p term l in (* Build the data from the substitution. *) - let (t, l, r) = Bindlib.msubst3 bound sigma in + let (t, l, r) = msubst3 bound sigma in let p_x = bind_pattern l match_p in - let p_r = Bindlib.subst p_x r in + let p_r = subst p_x r in let pred_bind = bind_pattern match_p g_term in - let new_term = Bindlib.subst pred_bind p_r in - let (x, p_x) = Bindlib.unbind p_x in - let pred = Bindlib.subst pred_bind p_x in - let pred_bind = Bindlib.bind_var x pred in + let new_term = subst pred_bind p_r in + let (x, p_x) = unbind p_x in + let pred = subst pred_bind p_x in + let pred_bind = bind_var x pred in (pred_bind, new_term, t, l, r) | Some(Rw_IdInTerm(p)) -> @@ -428,7 +428,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> the subterms where a rewrite happens. *) (* 5 - The new goal [new_term] is constructed by substituting [r_pat] in [pred_bind_l]. *) - let (id,p) = Bindlib.unbind p in + let (id,p) = unbind p in let p_refs = replace_wild_by_tref p in let id_val = match find_subst ([|id|],p_refs) g_term with @@ -437,10 +437,10 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> fatal pos "The pattern [%a] does not match [%a]." term p term l in - let pat = Bindlib.bind_var id p_refs in + let pat = bind_var id p_refs in (* The LHS of the pattern, i.e. the pattern with id replaced by *) (* id_val. *) - let pat_l = Bindlib.subst pat id_val in + let pat_l = subst pat id_val in (* This must match with the LHS of the equality proof we use. *) let sigma = @@ -454,11 +454,11 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> (* Build t, l, using the substitution we found. Note that r *) (* corresponds to the value we get by applying rewrite to *) (* id val. *) - let (t,l,r) = Bindlib.msubst3 bound sigma in + let (t,l,r) = msubst3 bound sigma in (* The RHS of the pattern, i.e. the pattern with id replaced *) (* by the result of rewriting id_val. *) - let pat_r = Bindlib.subst pat r in + let pat_r = subst pat r in (* Build the predicate, identifying all occurrences of pat_l *) (* substituting them, first with pat_r, for the new goal and *) @@ -466,12 +466,12 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> let pred_bind_l = bind_pattern pat_l g_term in (* This will be the new goal. *) - let new_term = Bindlib.subst pred_bind_l pat_r in + let new_term = subst pred_bind_l pat_r in (* [l_x] is the pattern with [id] replaced by the variable X *) (* that we use for building the predicate. *) - let (x, l_x) = Bindlib.unbind pat in - let pred_bind = Bindlib.bind_var x (Bindlib.subst pred_bind_l l_x) in + let (x, l_x) = unbind pat in + let pred_bind = bind_var x (subst pred_bind_l l_x) in (pred_bind, new_term, t, l, r) (* Combinational patterns. *) @@ -483,7 +483,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> occurrences of the first instance of [p] in [g_term] we rewrite all occurrences of the first instance of [s] in the subterm of [p] that was matched with the identifier. *) - let (id,p) = Bindlib.unbind p in + let (id,p) = unbind p in let p_refs = replace_wild_by_tref p in let id_val = match find_subst ([|id|],p_refs) g_term with @@ -497,8 +497,8 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> let id_val = id_val.(0) in (* [pat] is the full value of the pattern, with the wildcards now replaced by subterms of the goal and [id]. *) - let pat = Bindlib.bind_var id p_refs in - let pat_l = Bindlib.subst pat id_val in + let pat = bind_var id p_refs in + let pat_l = subst pat id_val in (* We then try to match the wildcards in [s] with subterms of [id_val]. *) @@ -516,7 +516,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> fatal pos "The term [%a] does not match the LHS [%a]" term s term l in - let (t,l,r) = Bindlib.msubst3 bound sigma in + let (t,l,r) = msubst3 bound sigma in (* First we work in [id_val], that is, we substitute all the occurrences of [l] in [id_val] with [r]. *) @@ -525,37 +525,37 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> (* [new_id] is the value of [id_val] with [l] replaced by [r] and [id_x] is the value of [id_val] with the free variable [x]. *) - let new_id = Bindlib.subst id_bind r in - let (x, id_x) = Bindlib.unbind id_bind in + let new_id = subst id_bind r in + let (x, id_x) = unbind id_bind in (* Then we replace in pat_l all occurrences of [id] with [new_id]. *) - let pat_r = Bindlib.subst pat new_id in + let pat_r = subst pat new_id in (* To get the new goal we replace all occurrences of [pat_l] in [g_term] with [pat_r]. *) let pred_bind_l = bind_pattern pat_l g_term in (* [new_term] is the type of the new goal meta. *) - let new_term = Bindlib.subst pred_bind_l pat_r in + let new_term = subst pred_bind_l pat_r in (* Finally we need to build the predicate. First we build the term l_x, in a few steps. We substitute all the rewrites in new_id with x and we repeat some steps. *) - let l_x = Bindlib.subst pat id_x in + let l_x = subst pat id_x in (* The last step to build the predicate is to substitute [l_x] everywhere we find [pat_l] and bind that x. *) - let pred = Bindlib.subst pred_bind_l l_x in - (Bindlib.bind_var x pred, new_term, t, l, r) + let pred = subst pred_bind_l l_x in + (bind_var x pred, new_term, t, l, r) | Some(Rw_TermAsIdInTerm(s,p)) -> (* This pattern is essentially a let clause. We first match the value of [pat] with some subterm of the goal, and then rewrite in each of the occurences of [id]. *) - let (id,pat) = Bindlib.unbind p in + let (id,pat) = unbind p in let s = replace_wild_by_tref s in - let p_s = Bindlib.subst p s in + let p_s = subst p s in (* Try to match p[s/id] with a subterm of the goal. *) let p_refs = replace_wild_by_tref p_s in if not (find_subterm_matching p_refs g_term) then @@ -583,15 +583,15 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> "The value of X, [%a], does not match the LHS, [%a]" term id_val term l in - let (t,l,r) = Bindlib.msubst3 bound sigma in + let (t,l,r) = msubst3 bound sigma in (* Now to do some term building. *) let p_x = bind_pattern l p in - let p_r = Bindlib.subst p_x r in + let p_r = subst p_x r in let pred_bind = bind_pattern p g_term in - let new_term = Bindlib.subst pred_bind p_r in - let (x, p_x) = Bindlib.unbind p_x in - let pred_bind = Bindlib.bind_var x (Bindlib.subst pred_bind p_x) in + let new_term = subst pred_bind p_r in + let (x, p_x) = unbind p_x in + let pred_bind = bind_var x (subst pred_bind p_x) in (pred_bind, new_term, t, l, r) | Some(Rw_InIdInTerm(q)) -> @@ -599,7 +599,7 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> [id_val] with [l], we try to match a subterm of [id_val] with [l], and then we rewrite this subterm. As a consequence, we just change the way we construct a [pat_r]. *) - let (id,q) = Bindlib.unbind q in + let (id,q) = unbind q in let q_refs = replace_wild_by_tref q in let id_val = match find_subst ([|id|],q_refs) g_term with @@ -609,8 +609,8 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> term q term g_term in let id_val = id_val.(0) in - let pat = Bindlib.bind_var id q_refs in - let pat_l = Bindlib.subst pat id_val in + let pat = bind_var id q_refs in + let pat_l = subst pat id_val in let sigma = match find_subst (vars,l) id_val with | Some(sigma) -> sigma @@ -619,19 +619,19 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> "The value of [%a], [%a], in [%a] does not match [%a]." var id term id_val term q term l in - let (t,l,r) = Bindlib.msubst3 bound sigma in + let (t,l,r) = msubst3 bound sigma in (* Rewrite in id. *) let id_bind = bind_pattern l id_val in - let id_val = Bindlib.subst id_bind r in - let (x, id_x) = Bindlib.unbind id_bind in + let id_val = subst id_bind r in + let (x, id_x) = unbind id_bind in (* The new RHS of the pattern is obtained by rewriting in [id_val]. *) - let r_val = Bindlib.subst pat id_val in + let r_val = subst pat id_val in let pred_bind_l = bind_pattern pat_l g_term in - let new_term = Bindlib.subst pred_bind_l r_val in - let l_x = Bindlib.subst pat id_x in - let pred_bind = Bindlib.bind_var x (Bindlib.subst pred_bind_l l_x) in + let new_term = subst pred_bind_l r_val in + let l_x = subst pat id_x in + let pred_bind = bind_var x (subst pred_bind_l l_x) in (pred_bind, new_term, t, l, r) in diff --git a/src/handle/tactic.ml b/src/handle/tactic.ml index f9e1469f1..2a21143c0 100644 --- a/src/handle/tactic.ml +++ b/src/handle/tactic.ml @@ -46,7 +46,7 @@ let add_axiom : Sig_state.t -> popt -> meta -> Sig_state.t = let meta_value = let vars = Array.init m.meta_arity (new_tvar_ind "x") in let ax = add_args (mk_Symb sym) (List.map mk_Vari (Array.to_list vars)) in - Bindlib.bind_mvar vars ax + bind_mvar vars ax in LibMeta.set (new_problem()) m meta_value; ss @@ -112,7 +112,7 @@ let tac_refine : | Some t -> if Logger.log_enabled () then log_tact (Color.red "%a ≔ %a") meta gt.goal_meta term t; - LibMeta.set p gt.goal_meta (Bindlib.bind_mvar (Env.vars gt.goal_hyps) t); + LibMeta.set p gt.goal_meta (bind_mvar (Env.vars gt.goal_hyps) t); (* Convert the metas and constraints of [p] not in [gs] into new goals. *) if Logger.log_enabled () then log_tact "%a" problem p; tac_solve pos {ps with proof_goals = Proof.add_goals_of_problem p gs} @@ -162,7 +162,7 @@ let tac_induction : popt -> proof_state -> goal_typ -> goal list let count_products : ctxt -> term -> int = fun c -> let rec count acc t = match Eval.whnf c t with - | Prod(_,b) -> count (acc + 1) (Bindlib.subst b mk_Kind) + | Prod(_,b) -> count (acc + 1) (subst b mk_Kind) | _ -> acc in count 0 diff --git a/src/handle/why3_tactic.ml b/src/handle/why3_tactic.ml index 482c9ce25..381a6eb9f 100644 --- a/src/handle/why3_tactic.ml +++ b/src/handle/why3_tactic.ml @@ -106,7 +106,7 @@ end = struct let sym = Why3.(Ty.create_tysymbol id [] Ty.NoDef) in ((te,TySym sym)::tbl, Why3.Ty.ty_app sym []) | Vari x, [] -> - let sym = Why3.Ty.tv_of_string (Bindlib.name_of x) in + let sym = Why3.Ty.tv_of_string (name_of x) in ((te,TyVar sym)::tbl, Why3.Ty.ty_var sym) | _ -> let id = Why3.Ident.id_fresh "ty" in @@ -156,10 +156,10 @@ let translate_term : config -> cnst_table -> TyTable.t -> term -> (tbl, ty_tbl, Why3.Term.t_true) | Symb(s), [a;Abst(_,t)] when s == cfg.symb_ex || s == cfg.symb_all -> let (ty_tbl, ty) = TyTable.ty_of_term ty_tbl a in - let x, t = Bindlib.unbind t in + let x, t = unbind t in let (tbl, ty_tbl ,t) = translate_prop tbl ty_tbl t in let tquant = - let id = Why3.Ident.id_fresh (Bindlib.name_of x) in + let id = Why3.Ident.id_fresh (name_of x) in let vid = Why3.(Term.create_vsymbol id) ty in let close = if s == cfg.symb_ex then Why3.Term.t_exists_close diff --git a/src/parsing/scope.ml b/src/parsing/scope.ml index a5a6adc11..b28290482 100644 --- a/src/parsing/scope.ml +++ b/src/parsing/scope.ml @@ -136,7 +136,7 @@ let fresh_patt : lhs_data -> string option -> term array -> term = mk_Patt (Some i, string_of_int i, ts) (** [is_invalid_bindlib_id s] says whether [s] can be safely used as variable - name in Bindlib. Indeed, because Bindlib converts any suffix consisting of + name in Indeed, because converts any suffix consisting of a sequence of digits into an integer, and increment it, we cannot use as bound variable names escaped identifiers or regular identifiers ending with a non-negative integer with leading zeros. *) @@ -218,7 +218,7 @@ and scope_parsed : | P_Wrap e -> get_impl e | P_Iden (_, false) -> (* We avoid unboxing if [h] is not closed (and hence not a symbol). *) - if Bindlib.is_closed h then + if is_closed h then match h with | Symb s -> s.sym_impl | _ -> [] @@ -309,7 +309,7 @@ and scope_binder : ?typ:bool -> int -> mode -> sig_state -> | None::idopts -> let v = new_tvar "_" in let t = aux env idopts in - cons (a, Bindlib.bind_var v t) + cons (a, bind_var v t) | Some {elt=id;pos}::idopts -> if is_invalid_bindlib_id id then fatal pos "\"%s\": Escaped identifiers or regular identifiers \ @@ -318,7 +318,7 @@ and scope_binder : ?typ:bool -> int -> mode -> sig_state -> let v = new_tvar id in let env = Env.add id v a None env in let t = aux env idopts in - cons (a, Bindlib.bind_var v t) + cons (a, bind_var v t) in aux env idopts in scope_params_list env params_list @@ -386,7 +386,7 @@ and scope_head : (* Check that [vs] are distinct variables. *) for i = 0 to Array.length vs - 2 do for j = i + 1 to Array.length vs - 1 do - if Bindlib.eq_vars vs.(i) vs.(j) then + if eq_vars vs.(i) vs.(j) then fatal ts.(j).pos "Variable %a appears more than once \ in the environment of a pattern variable." @@ -471,9 +471,9 @@ and scope_head : let t = scope_binder (k+1) md ss mk_Abst env xs (Some(t)) in let v = new_tvar x.elt in let u = scope ~typ (k+1) md ss (Env.add x.elt v a (Some(t)) env) u in - if not (Bindlib.occur v u) then + if not (occur v u) then wrn x.pos "Useless let-binding (%s is not bound)." x.elt; - mk_LLet (a, t, Bindlib.bind_var v u) + mk_LLet (a, t, bind_var v u) | (P_LLet(_), M_LHS(_)) -> fatal t.pos "Let-bindings are not allowed in a LHS." | (P_LLet(_), M_Patt) -> @@ -650,18 +650,18 @@ let scope_rw_patt : sig_state -> env -> p_rw_patt -> (term, tbinder) rw_patt = | Rw_InIdInTerm(x,t) -> let v = new_tvar x.elt in let t = scope_pattern ss ((x.elt,(v, mk_Kind, None))::env) t in - Rw_InIdInTerm(Bindlib.bind_var v t) + Rw_InIdInTerm(bind_var v t) | Rw_IdInTerm(x,t) -> let v = new_tvar x.elt in let t = scope_pattern ss ((x.elt,(v, mk_Kind, None))::env) t in - Rw_IdInTerm(Bindlib.bind_var v t) + Rw_IdInTerm(bind_var v t) | Rw_TermInIdInTerm(u,(x,t)) -> let u = scope_pattern ss env u in let v = new_tvar x.elt in let t = scope_pattern ss ((x.elt,(v, mk_Kind, None))::env) t in - Rw_TermInIdInTerm(u, Bindlib.bind_var v t) + Rw_TermInIdInTerm(u, bind_var v t) | Rw_TermAsIdInTerm(u,(x,t)) -> let u = scope_pattern ss env u in let v = new_tvar x.elt in let t = scope_pattern ss ((x.elt,(v, mk_Kind, None))::env) t in - Rw_TermAsIdInTerm(u, Bindlib.bind_var v t) + Rw_TermAsIdInTerm(u, bind_var v t) diff --git a/src/parsing/syntax.ml b/src/parsing/syntax.ml index ecde52602..30ce74f74 100644 --- a/src/parsing/syntax.ml +++ b/src/parsing/syntax.ml @@ -107,8 +107,8 @@ module P = struct (** [iden s] builds a [P_Iden] "@s". *) let iden : string -> p_term = qiden [] - (** [var v] builds a [P_Iden] from [Bindlib.name_of v]. *) - let var : Term.tvar -> p_term = fun v -> iden (Term.Bindlib.name_of v) + (** [var v] builds a [P_Iden] from [name_of v]. *) + let var : Term.tvar -> p_term = fun v -> iden (Term.name_of v) (** [patt s ts] builds a [P_Patt] "$s[ts]". *) let patt : string -> p_term array option -> p_term = fun s ts -> diff --git a/src/tool/lcr.ml b/src/tool/lcr.ml index 35e161ef5..6a56986ff 100644 --- a/src/tool/lcr.ml +++ b/src/tool/lcr.ml @@ -81,7 +81,7 @@ let occurs : int -> term -> bool = fun i -> | Patt(Some j,_,_) -> i=j | Vari _ | Symb _ -> false | Appl(u,v) -> occ u || occ v - | Abst(a,b) | Prod(a,b) -> occ a || let _,b = Bindlib.unbind b in occ b + | Abst(a,b) | Prod(a,b) -> occ a || let _,b = unbind b in occ b | Type -> assert false | Kind -> assert false | Meta _ -> assert false @@ -111,7 +111,7 @@ let rec shift : term -> term = fun t -> | Db _ -> assert false | LLet(a,t,b) -> mk_LLet (shift a, shift t, shift_binder b) and shift_binder b = - let x, t = Bindlib.unbind b in Bindlib.bind_var x (shift t) + let x, t = unbind b in bind_var x (shift t) (** Type for pattern variable substitutions. *) type subs = term IntMap.t @@ -133,14 +133,14 @@ let apply_subs : subs -> term -> term = fun s t -> | Vari _ | Symb _ | Type | Kind -> t | Appl(u,v) -> mk_Appl (apply_subs u, apply_subs v) | Abst(a,b) -> - let x,b = Bindlib.unbind b in - mk_Abst (apply_subs a, Bindlib.bind_var x (apply_subs b)) + let x,b = unbind b in + mk_Abst (apply_subs a, bind_var x (apply_subs b)) | Prod(a,b) -> - let x,b = Bindlib.unbind b in - mk_Prod (apply_subs a, Bindlib.bind_var x (apply_subs b)) + let x,b = unbind b in + mk_Prod (apply_subs a, bind_var x (apply_subs b)) | LLet(a,t,b) -> - let x,b = Bindlib.unbind b in - mk_LLet (apply_subs a, apply_subs t, Bindlib.bind_var x (apply_subs b)) + let x,b = unbind b in + mk_LLet (apply_subs a, apply_subs t, bind_var x (apply_subs b)) | Meta(m,ts) -> mk_Meta (m, Array.map apply_subs ts) | Db _ -> assert false | TRef _ -> assert false @@ -164,7 +164,7 @@ let iter_subterms_from_pos : subterm_pos -> iter = | Patt _ | Vari _ -> iter_args p t | Abst(a,b) - | Prod(a,b) -> iter (0::p) a; let _,b = Bindlib.unbind b in iter (1::p) b + | Prod(a,b) -> iter (0::p) a; let _,b = unbind b in iter (1::p) b | Appl _ -> assert false | Type -> assert false | Kind -> assert false @@ -200,7 +200,7 @@ let iter_subterms : iter = fun pos f t -> | Abst(a,b) | Prod(a,b) -> iter_subterms_from_pos [0] pos f a; - let _,b = Bindlib.unbind b in iter_subterms_from_pos [1] pos f b; + let _,b = unbind b in iter_subterms_from_pos [1] pos f b; | Appl(a,b) -> iter_subterms_from_pos [0] pos f a; iter_subterms_from_pos [1] pos f b; | Type -> assert false @@ -229,11 +229,11 @@ let unif : Pos.popt -> term -> term -> term IntMap.t option = | Appl(a,b), Appl(c,d) -> unif s ((a,c)::(b,d)::l) | Abst(a,b), Abst(c,d) | Prod(a,b), Prod(c,d) -> - let x,b = Bindlib.unbind b in - let d = Bindlib.subst d (mk_Vari x) in + let x,b = unbind b in + let d = subst d (mk_Vari x) in unif s ((a,c)::(b,d)::l) | Vari x, Vari y -> - if Bindlib.eq_vars x y then unif s l else raise NotUnifiable + if eq_vars x y then unif s l else raise NotUnifiable | Patt(None,_,_), _ | _, Patt(None,_,_) -> assert false | Patt(Some i,_,ts), u @@ -400,8 +400,8 @@ let typability_constraints : Pos.popt -> term -> subs option = fun pos t -> | Appl(a,b) -> mk_Appl_not_canonical(patt_to_meta a, patt_to_meta b) | Symb _ | Vari _ -> t | Abst(a,b) -> - let x,b = Bindlib.unbind b in - mk_Abst(patt_to_meta a, Bindlib.bind_var x (patt_to_meta b)) + let x,b = unbind b in + mk_Abst(patt_to_meta a, bind_var x (patt_to_meta b)) | _ -> assert false in let t = patt_to_meta t in @@ -415,7 +415,7 @@ let typability_constraints : Pos.popt -> term -> subs option = fun pos t -> let i,n = MetaMap.find m !m2p in let s = create_sym (Sign.current_path()) Public Defin Eager false (Pos.none n) mk_Kind [] in - let t = Bindlib.bind_mvar [||] (mk_Symb s) in + let t = bind_mvar [||] (mk_Symb s) in Timed.(m.meta_value := Some t); s2p := SymMap.add s i !s2p with Not_found -> () diff --git a/src/tool/sr.ml b/src/tool/sr.ml index 7e055b4e0..70f69b25d 100644 --- a/src/tool/sr.ml +++ b/src/tool/sr.ml @@ -21,7 +21,7 @@ let build_meta_type : problem -> int -> term = fun p k -> let ty_m = Array.make (k+1) mk_Type in for i = 0 to k do for j = (i-1) downto 0 do - ty_m.(i) <- mk_Prod (ty_m.(j), Bindlib.bind_var xs.(j) ty_m.(i)) + ty_m.(i) <- mk_Prod (ty_m.(j), bind_var xs.(j) ty_m.(i)) done done; (* We create the “Ai” terms and the “Mi” metavariables. *) @@ -30,7 +30,7 @@ let build_meta_type : problem -> int -> term = fun p k -> (* We finally construct our type. *) let res = ref a.(k) in for i = k - 1 downto 0 do - res := mk_Prod (a.(i), Bindlib.bind_var xs.(i) !res) + res := mk_Prod (a.(i), bind_var xs.(i) !res) done; !res @@ -59,16 +59,16 @@ let symb_to_patt : Pos.popt -> (int * int) option SymMap.t -> term -> term = | Type -> (mk_Type , ts) | Kind -> (mk_Kind , ts) | Abst(a,b) -> - let (x, t) = Bindlib.unbind b in - let b = Bindlib.bind_var x (symb_to_patt t) in + let (x, t) = unbind b in + let b = bind_var x (symb_to_patt t) in (mk_Abst (symb_to_patt a, b), ts) | Prod(a,b) -> - let (x, t) = Bindlib.unbind b in - let b = Bindlib.bind_var x (symb_to_patt t) in + let (x, t) = unbind b in + let b = bind_var x (symb_to_patt t) in (mk_Prod (symb_to_patt a, b), ts) | LLet(a,t,b) -> - let (x, u) = Bindlib.unbind b in - let b = Bindlib.bind_var x (symb_to_patt u) in + let (x, u) = unbind b in + let b = bind_var x (symb_to_patt u) in (mk_LLet (symb_to_patt a, symb_to_patt t, b), ts) | Meta(_,_) -> fatal pos "A metavariable could not be instantiated in the RHS." @@ -104,7 +104,7 @@ let check_rule : Pos.popt -> sym_rule -> sym_rule = let f m = let xs = Array.init m.meta_arity (new_tvar_ind "x") in let ts = Array.map mk_Vari xs in - Some(Bindlib.bind_mvar xs (mk_Meta (m, ts))) + Some(bind_mvar xs (mk_Meta (m, ts))) in let su = Array.map f metas in let lhs_with_metas = subst_patt su (add_args (mk_Symb s) lhs) @@ -147,7 +147,7 @@ let check_rule : Pos.popt -> sym_rule -> sym_rule = let xs = Array.init m.meta_arity (new_tvar_ind "x") in let s = mk_Symb s in let def = Array.fold_left (fun t x -> _Appl t (mk_Vari x)) s xs in - m.meta_value := Some(Bindlib.bind_mvar xs def) + m.meta_value := Some(bind_mvar xs def) in Array.iter instantiate metas; Stdlib.(!symbols) @@ -167,7 +167,7 @@ let check_rule : Pos.popt -> sym_rule -> sym_rule = let xs = Array.init m.meta_arity (new_tvar_ind "x") in let s = mk_Symb s in let def = Array.fold_left (fun t x -> mk_Appl (t, mk_Vari x)) s xs in - m.meta_value := Some(Bindlib.bind_mvar xs def) + m.meta_value := Some(bind_mvar xs def) in MetaSet.iter instantiate !p.metas; let f i m = From 83b1ec9d29340b8c05926c23041f55d03ecf6272 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 15 Feb 2022 07:24:51 +0100 Subject: [PATCH 18/38] renamings: tvar -> var, tbinder -> binder, tmbinder -> mbinder --- src/core/ctxt.ml | 8 ++-- src/core/env.ml | 12 ++--- src/core/eval.ml | 2 +- src/core/libMeta.ml | 6 +-- src/core/libTerm.ml | 26 +++++----- src/core/print.ml | 2 +- src/core/term.ml | 102 +++++++++++++++++++--------------------- src/core/term.mli | 101 ++++++++++++++++++--------------------- src/core/tree.ml | 12 ++--- src/core/unif.ml | 8 ++-- src/export/dk.ml | 12 ++--- src/export/xtc.ml | 6 +-- src/handle/inductive.ml | 28 +++++------ src/handle/rewrite.ml | 26 +++++----- src/handle/tactic.ml | 4 +- src/parsing/scope.ml | 18 +++---- src/parsing/scope.mli | 2 +- src/parsing/syntax.ml | 2 +- src/tool/sr.ml | 8 ++-- 19 files changed, 185 insertions(+), 200 deletions(-) diff --git a/src/core/ctxt.ml b/src/core/ctxt.ml index 46e1748cb..bd3de1234 100644 --- a/src/core/ctxt.ml +++ b/src/core/ctxt.ml @@ -7,18 +7,18 @@ open Timed (** [type_of x ctx] returns the type of [x] in the context [ctx] when it appears in it, and @raise [Not_found] otherwise. *) -let type_of : tvar -> ctxt -> term = fun x ctx -> +let type_of : var -> ctxt -> term = fun x ctx -> let (_,a,_) = List.find (fun (y,_,_) -> eq_vars x y) ctx in a (** [def_of x ctx] returns the definition of [x] in the context [ctx] if it appears, and [None] otherwise *) -let rec def_of : tvar -> ctxt -> ctxt * term option = fun x c -> +let rec def_of : var -> ctxt -> ctxt * term option = fun x c -> match c with | [] -> [], None | (y,_,d)::c -> if eq_vars x y then c,d else def_of x c (** [mem x ctx] tells whether variable [x] is mapped in the context [ctx]. *) -let mem : tvar -> ctxt -> bool = fun x -> +let mem : var -> ctxt -> bool = fun x -> List.exists (fun (y,_,_) -> eq_vars x y) (** [to_prod ctx t] builds a product by abstracting over the context [ctx], in @@ -48,7 +48,7 @@ let to_let : ctxt -> term -> term = fun ctx t -> (** [sub ctx vs] returns the sub-context of [ctx] made of the variables of [vs]. *) -let sub : ctxt -> tvar array -> ctxt = fun ctx vs -> +let sub : ctxt -> var array -> ctxt = fun ctx vs -> let f ((x,_,_) as hyp) ctx = if Array.exists (eq_vars x) vs then hyp::ctx else ctx in diff --git a/src/core/env.ml b/src/core/env.ml index f5da672a3..24b1d6183 100644 --- a/src/core/env.ml +++ b/src/core/env.ml @@ -8,7 +8,7 @@ open Term implemented by a map as the order is important. The structure is similar to then one of {!type:Term.ctxt}, a tuple [(x,a,t)] is a variable [x], its type [a] and possibly its definition [t] *) -type env = (string * (tvar * term * term option)) list +type env = (string * (var * term * term option)) list type t = env @@ -17,12 +17,12 @@ let empty : env = [] (** [add v a t env] extends the environment [env] by mapping the string [n] to [(v,a,t)]. *) -let add : string -> tvar -> term -> term option -> env -> env = +let add : string -> var -> term -> term option -> env -> env = fun n v a t env -> (n, (v, a, t)) :: env (** [find n env] returns the variable associated to the variable name [n] in the environment [env]. If none is found, [Not_found] is raised. *) -let find : string -> env -> tvar = fun n env -> +let find : string -> env -> var = fun n env -> let (x,_,_) = List.assoc n env in x (** [mem n env] returns [true] iff [n] is mapped to a variable in [env]. *) @@ -58,7 +58,7 @@ let to_abst : env -> term -> term = fun env t -> (** [vars env] extracts the array of the {e not defined} variables in [env]. Note that the order is reversed: [vars [(xn,an);..;(x1,a1)] = [|x1;..;xn|]]. *) -let vars : env -> tvar array = fun env -> +let vars : env -> var array = fun env -> let f (_, (x, _, u)) = if u = None then Some(x) else None in Array.of_list (List.filter_rev_map f env) @@ -80,7 +80,7 @@ let to_ctxt : env -> ctxt = List.map snd (** [match_prod c t f] returns [f a b] if [t] matches [Prod(a,b)] possibly after reduction. @raise [Invalid_argument] if [t] is not a product. *) -let match_prod : ctxt -> term -> (term -> tbinder -> 'a) -> 'a = fun c t f -> +let match_prod : ctxt -> term -> (term -> binder -> 'a) -> 'a = fun c t f -> match unfold t with | Prod(a,b) -> f a b | _ -> @@ -125,7 +125,7 @@ let of_prod_nth : ctxt -> int -> term -> env * term = fun c n t -> [xs]. @raise [Invalid_argument] if [t] does not evaluate to a series of (at least) [n] products. *) -let of_prod_using : ctxt -> tvar array -> term -> env * term = fun c xs t -> +let of_prod_using : ctxt -> var array -> term -> env * term = fun c xs t -> let n = Array.length xs in let rec build_env i env t = if i >= n then env, t diff --git a/src/core/eval.ml b/src/core/eval.ml index 4f66ad172..c33e5928c 100644 --- a/src/core/eval.ml +++ b/src/core/eval.ml @@ -340,7 +340,7 @@ and tree_walk : config -> dtree -> stack -> (term * stack) option = in (* Ensure there are no variables from [forbidden] in [b]. *) let no_forbidden b = - not (IntMap.exists (fun _ x -> occur_tmbinder x b) + not (IntMap.exists (fun _ x -> occur_mbinder x b) forbidden) in (* We first attempt to match [vars.(i)] directly. *) diff --git a/src/core/libMeta.ml b/src/core/libMeta.ml index f076e394d..b59d804d9 100644 --- a/src/core/libMeta.ml +++ b/src/core/libMeta.ml @@ -21,7 +21,7 @@ let fresh : problem -> term -> int -> meta = (** [set p m v] sets the metavariable [m] of [p] to [v]. WARNING: No specific check is performed, so this function may lead to cyclic terms. To use with care. *) -let set : problem -> meta -> tmbinder -> unit = fun p m v -> +let set : problem -> meta -> mbinder -> unit = fun p m v -> m.meta_type := mk_Kind; (* to save memory *) m.meta_value := Some v; p := {!p with metas = MetaSet.remove m !p.metas} @@ -37,8 +37,8 @@ let make : problem -> ctxt -> term -> term = (** [make_codomain p ctx a] creates a fresh metavariable term of type [Type] in the context [ctx] extended with a fresh variable of type [a], and updates [p] with generated metavariables. *) -let make_codomain : problem -> ctxt -> term -> tbinder = fun p ctx a -> - let x = new_tvar "x" in +let make_codomain : problem -> ctxt -> term -> binder = fun p ctx a -> + let x = new_var "x" in bind_var x (make p ((x, a, None) :: ctx) mk_Type) (** [iter b f c t] applies the function [f] to every metavariable of [t] and, diff --git a/src/core/libTerm.ml b/src/core/libTerm.ml index 88a723421..2d42d9cc1 100644 --- a/src/core/libTerm.ml +++ b/src/core/libTerm.ml @@ -3,12 +3,12 @@ open Term open Lplib open Extra -(** [to_tvar t] returns [x] if [t] is of the form [Vari x] and fails +(** [to_var t] returns [x] if [t] is of the form [Vari x] and fails otherwise. *) -let to_tvar : term -> tvar = fun t -> +let to_var : term -> var = fun t -> match t with Vari(x) -> x | _ -> assert false -(** {b NOTE} the [Array.map to_tvar] function is useful when working +(** {b NOTE} the [Array.map to_var] function is useful when working with multiple binders. For example, this is the case when manipulating pattern variables ([Patt] constructor) or metatavariables ([Meta] constructor). Remark that it is important for these constructors to hold @@ -16,7 +16,7 @@ let to_tvar : term -> tvar = fun t -> be substituted when if it is injected in a term (using the [Vari] constructor). *) -(** {b NOTE} the result of {!val:to_tvar} can generally NOT be precomputed. A +(** {b NOTE} the result of {!val:to_var} can generally NOT be precomputed. A first reason is that we cannot know in advance what variable identifier is going to arise when working under binders, for which fresh variables will often be generated. A second reason is that free variables should never be @@ -61,23 +61,23 @@ let iter : (term -> unit) -> term -> unit = fun action -> (** [unbind_name b s] is like [unbind b] but returns a valid variable name when [b] binds no variable. The string [s] is the prefix of the variable's name.*) -let unbind_name : string -> tbinder -> tvar * term = fun s b -> +let unbind_name : string -> binder -> var * term = fun s b -> if binder_occur b then unbind b - else let x = new_tvar s in (x, subst b (mk_Vari x)) + else let x = new_var s in (x, subst b (mk_Vari x)) (** [unbind2_name b1 b2 s] is like [unbind2 b1 b2] but returns a valid variable name when [b1] or [b2] binds no variable. The string [s] is the prefix of the variable's name.*) -let unbind2_name : string -> tbinder -> tbinder -> tvar * term * term = +let unbind2_name : string -> binder -> binder -> var * term * term = fun s b1 b2 -> if binder_occur b1 || binder_occur b2 then unbind2 b1 b2 - else let x = new_tvar s in + else let x = new_var s in (x, subst b1 (mk_Vari x), subst b2 (mk_Vari x)) (** [distinct_vars ctx ts] checks that the terms [ts] are distinct variables. If so, the variables are returned. *) -let distinct_vars : ctxt -> term array -> tvar array option = fun ctx ts -> +let distinct_vars : ctxt -> term array -> var array option = fun ctx ts -> let exception Not_unique_var in let open Stdlib in let vars = ref VarSet.empty in @@ -103,7 +103,7 @@ let distinct_vars : ctxt -> term array -> tvar array option = fun ctx ts -> metavariables into fresh symbols, and those metavariables are introduced by [sr.ml] which replaces pattern variables by metavariables. *) let nl_distinct_vars - : ctxt -> term array -> (tvar array * tvar StrMap.t) option = + : ctxt -> term array -> (var array * var StrMap.t) option = fun ctx ts -> let exception Not_a_var in let open Stdlib in @@ -122,14 +122,14 @@ let nl_distinct_vars let v = try StrMap.find f.sym_name !patt_vars with Not_found -> - let v = new_tvar f.sym_name in + let v = new_var f.sym_name in patt_vars := StrMap.add f.sym_name v !patt_vars; v in to_var (mk_Vari v) | _ -> raise Not_a_var in let replace_nl_var v = - if VarSet.mem v !nl_vars then new_tvar "_" else v + if VarSet.mem v !nl_vars then new_var "_" else v in try let vs = Array.map to_var ts in @@ -142,7 +142,7 @@ let nl_distinct_vars (** [sym_to_var m t] replaces in [t] every symbol [f] by a variable according to the map [map]. *) -let sym_to_var : tvar StrMap.t -> term -> term = fun map -> +let sym_to_var : var StrMap.t -> term -> term = fun map -> let rec to_var t = match unfold t with | Symb f -> (try mk_Vari (StrMap.find f.sym_name map) with Not_found -> t) diff --git a/src/core/print.ml b/src/core/print.ml index 234be1207..803be6acc 100644 --- a/src/core/print.ml +++ b/src/core/print.ml @@ -89,7 +89,7 @@ let sym : sym pp = fun ppf s -> else out ppf "%a.%a" path p uid n | Some alias -> out ppf "%a.%a" uid alias uid n -let var : tvar pp = fun ppf x -> uid ppf (name_of x) +let var : var pp = fun ppf x -> uid ppf (name_of x) (** Exception raised when trying to convert a term into a nat. *) exception Not_a_nat diff --git a/src/core/term.ml b/src/core/term.ml index 42f8acaf3..10ec74b4f 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -44,12 +44,12 @@ type prop = rules. Specific constructors are included for such applications, and they are considered invalid in unrelated code. *) type term = - | Vari of tvar (** Free variable. *) + | Vari of var (** Free variable. *) | Type (** "TYPE" constant. *) | Kind (** "KIND" constant. *) | Symb of sym (** User-defined symbol. *) - | Prod of term * tbinder (** Dependent product. *) - | Abst of term * tbinder (** Abstraction. *) + | Prod of term * binder (** Dependent product. *) + | Abst of term * binder (** Abstraction. *) | Appl of term * term (** Term application. *) | Meta of meta * term array (** Metavariable application. *) | Patt of int option * string * term array @@ -58,25 +58,20 @@ type term = | Wild | Plac of bool | TRef of term option ref (** Reference cell (used in surface matching). *) - | LLet of term * term * tbinder + | LLet of term * term * binder (** [LLet(a, t, u)] is [let x : a ≔ t in u] (with [x] bound in [u]). *) (** {b NOTE} that a wildcard "_" of the concrete (source code) syntax may have - a different representation depending on the application. For instance, the + a different representation depending on the context. For instance, the {!constructor:Wild} constructor is only used when matching patterns (e.g., with the "rewrite" tactic). In the LHS of a rewriting {!type:rule}, we use the {!constructor:Patt} constructor to represend wildcards of the concrete syntax. They are thus considered to be fresh, unused pattern variables. *) -(** Representation of a rewriting rule RHS. *) -and rhs = term - (** Representation of a decision tree (used for rewriting). *) and dtree = rule Tree_type.dtree -(** Representation of a user-defined symbol. Symbols carry a "mode" indicating - whether they may be given rewriting rules or a definition. Invariants must - be enforced for "mode" consistency (see {!type:sym_prop}). *) +(** Representation of a user-defined symbol. *) and sym = { sym_expo : expo (** Visibility. *) ; sym_path : Path.t (** Module in which the symbol is defined. *) @@ -122,7 +117,7 @@ and sym = the rule applies. More explanations are given below. *) and rule = { lhs : term list (** Left hand side (LHS). *) - ; rhs : rhs (** Right hand side (RHS). *) + ; rhs : term (** Right hand side (RHS). *) ; arity : int (** Required number of arguments to be applicable. *) ; arities : int array (** Arities of the pattern variables bound in the RHS. *) @@ -139,10 +134,9 @@ and sym = lambdapi files to other formats. *) (** All variables of rewriting rules that appear in the RHS must appear in the - LHS. This constraint is checked in {!module:Sr}. In the case of unification - rules, we allow variables to appear only in the RHS. In that case, these - variables are replaced by fresh meta-variables each time the rule is - used. *) + LHS. In the case of unification rules, we allow variables to appear only in + the RHS. In that case, these variables are replaced by fresh meta-variables + each time the rule is used. *) (** During evaluation, we only try to apply rewriting rules when we reduce the application of a symbol [s] to a list of argument [ts]. At this point, the @@ -150,10 +144,10 @@ and sym = {!field:sym_rules} field. To check if a rule [r] applies, we match the elements of [r.lhs] with those of [ts] while building an environment [env]. During this process, a pattern of - the form {!constructor:Patt}[(Some i,s,e)] matched against a term [u] will + the form {!constructor:Patt}[(Some i,_,_)] matched against a term [u] will results in [env.(i)] being set to [u]. If all terms of [ts] can be matched against corresponding patterns, then environment [env] is fully constructed - and it can hence be substituted in [r.rhs] with [msubst r.rhs env] + and it can hence be substituted in [r.rhs] with [subst_patt env r.rhs] to get the result of the application of the rule. *) (** {3 Metavariables and related functions} *) @@ -164,17 +158,17 @@ and sym = (i.e., set to a particular term). When a metavariable [m] is instantiated, the suspended substitution is unlocked and terms of the form {!constructor:Meta}[(m,env)] can be unfolded. *) - and meta = +and meta = { meta_key : int (** Unique key. *) ; meta_type : term ref (** Type. *) ; meta_arity : int (** Arity (environment size). *) - ; meta_value : tmbinder option ref (** Definition. *) } + ; meta_value : mbinder option ref (** Definition. *) } -and tbinder = string * term +and binder = string * term -and tmbinder = string array * term +and mbinder = string array * term -and tvar = int * string +and var = int * string (** [unfold t] repeatedly unfolds the definition of the surface constructor of [t], until a significant {!type:term} constructor is found. The term @@ -217,7 +211,7 @@ and term : term pp = fun ppf t -> | TRef r -> out ppf "&%a" (Option.pp term) !r | LLet(a,t,(n,b)) -> out ppf "let %s : %a ≔ %a in %a" n term a term t term b -and var : tvar pp = fun ppf (i,n) -> out ppf "%s%d" n i +and var : var pp = fun ppf (i,n) -> out ppf "%s%d" n i and sym : sym pp = fun ppf s -> string ppf s.sym_name and terms : term array pp = fun ppf ts -> if Array.length ts > 0 then D.array term ppf ts @@ -242,7 +236,7 @@ and lift : int -> term -> term = fun l t -> (** [msubst b vs] substitutes the variables bound by [b] with the values [vs]. Note that the length of the [vs] array should match the arity of the multiple binder [b]. *) -and msubst : tmbinder -> term array -> term = fun (ns,t) vs -> +and msubst : mbinder -> term array -> term = fun (ns,t) vs -> let n = Array.length ns in assert (Array.length vs = n); (* [msubst i t] replaces [Db(i+j)] by [lift (i-1) vs.(n-j-1)] @@ -267,11 +261,11 @@ and msubst : tmbinder -> term array -> term = fun (ns,t) vs -> r let msubst3 : - (tmbinder * tmbinder * tmbinder) -> term array -> term * term * term = + (mbinder * mbinder * mbinder) -> term array -> term * term * term = fun (b1, b2, b3) ts -> msubst b1 ts, msubst b2 ts, msubst b3 ts (** [subst b v] substitutes the variable bound by [b] with the value [v]. *) -let subst : tbinder -> term -> term = fun (_,t) v -> +let subst : binder -> term -> term = fun (_,t) v -> let rec subst i t = (*if Logger.log_enabled() then log_term "subst [%d≔%a] %a" i term v term t;*) @@ -291,34 +285,34 @@ let subst : tbinder -> term -> term = fun (_,t) v -> r (** [new_var name] creates a new unique variable of name [name]. *) -let new_var : string -> tvar = +let new_var : string -> var = let open Stdlib in let n = ref 0 in fun name -> incr n; !n, name (** [name_of x] returns the name of variable [x]. *) -let name_of : tvar -> string = fun (_i,n) -> n (*^ string_of_int i*) +let name_of : var -> string = fun (_i,n) -> n (*^ string_of_int i*) (** [unbind b] substitutes the binder [b] using a fresh variable. The variable and the result of the substitution are returned. Note that the name of the fresh variable is based on that of the binder. *) -let unbind : tbinder -> tvar * term = fun ((name,_) as b) -> +let unbind : binder -> var * term = fun ((name,_) as b) -> let x = new_var name in x, subst b (Vari x) (** [unbind2 f g] is similar to [unbind f], but it substitutes two binders [f] and [g] at once using the same fresh variable. The name of the variable is based on that of the binder [f]. *) -let unbind2 : tbinder -> tbinder -> tvar * term * term = +let unbind2 : binder -> binder -> var * term * term = fun ((name1,_) as b1) b2 -> let x = new_var name1 in x, subst b1 (Vari x), subst b2 (Vari x) (** [unmbind b] substitutes the multiple binder [b] with fresh variables. This function is analogous to [unbind] for binders. Note that the names used to create the fresh variables are based on those of the multiple binder. *) -let unmbind : tmbinder -> tvar array * term = fun ((names,_) as b) -> +let unmbind : mbinder -> var array * term = fun ((names,_) as b) -> let xs = Array.init (Array.length names) (fun i -> new_var names.(i)) in xs, msubst b (Array.map (fun x -> Vari x) xs) (** [bind_var x b] binds the variable [x] in [b], producing a boxed binder. *) -let bind_var : tvar -> term -> tbinder = fun ((_,n) as x) -> +let bind_var : var -> term -> binder = fun ((_,n) as x) -> let rec bind i t = (*if Logger.log_enabled() then log_term "bind_var %d %a" i term t;*) match unfold t with @@ -338,7 +332,7 @@ let bind_var : tvar -> term -> tbinder = fun ((_,n) as x) -> (** [bind_mvar xs b] binds the variables of [xs] in [b] to get a boxed binder. It is the equivalent of [bind_var] for multiple variables. *) -let bind_mvar : tvar array -> term -> tmbinder = fun xs t -> +let bind_mvar : var array -> term -> mbinder = fun xs t -> let n = Array.length xs in if n = 0 then [||], t else let open Stdlib in let open Extra in @@ -366,14 +360,14 @@ let bind_mvar : tvar array -> term -> tmbinder = fun xs t -> (** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to compare variables using [Pervasive.compare]. *) -let compare_vars : tvar -> tvar -> int = fun (i,_) (j,_) -> Stdlib.compare i j +let compare_vars : var -> var -> int = fun (i,_) (j,_) -> Stdlib.compare i j (** [eq_vars x y] safely computes the equality of [x] and [y]. Note that it is unsafe to compare variables with the polymorphic equality function. *) -let eq_vars : tvar -> tvar -> bool = fun x y -> compare_vars x y = 0 +let eq_vars : var -> var -> bool = fun x y -> compare_vars x y = 0 (** [binder_occur b] tests whether the bound variable occurs in [b]. *) -let binder_occur : tbinder -> bool = fun (_,t) -> +let binder_occur : binder -> bool = fun (_,t) -> let rec check i t = (*if Logger.log_enabled() then log_term "binder_occur %d %a" i term t;*) @@ -394,10 +388,10 @@ let binder_occur : tbinder -> bool = fun (_,t) -> (** [binder_constant b] tests whether the [binder] [b] is constant (i.e., its bound variable does not occur). *) -let binder_constant : tbinder -> bool = fun b -> not (binder_occur b) +let binder_constant : binder -> bool = fun b -> not (binder_occur b) (** [mbinder_arity b] gives the arity of the [mbinder]. *) -let mbinder_arity : tmbinder -> int = fun (names,_) -> Array.length names +let mbinder_arity : mbinder -> int = fun (names,_) -> Array.length names (** [is_closed t] checks whether [t] is closed. *) let is_closed : term -> bool = @@ -413,10 +407,10 @@ let is_closed : term -> bool = | _ -> () in fun t -> try check t; true with Exit -> false -let is_closed_tmbinder : tmbinder -> bool = fun (_,t) -> is_closed t +let is_closed_mbinder : mbinder -> bool = fun (_,t) -> is_closed t (** [occur x t] tells whether variable [x] occurs in [t]. *) -let occur : tvar -> term -> bool = fun x -> +let occur : var -> term -> bool = fun x -> let rec check t = match unfold t with | Vari y when y == x -> raise Exit @@ -429,7 +423,7 @@ let occur : tvar -> term -> bool = fun x -> | _ -> () in fun t -> try check t; false with Exit -> true -let occur_tmbinder : tvar -> tmbinder -> bool = fun x (_,t) -> occur x t +let occur_mbinder : var -> mbinder -> bool = fun x (_,t) -> occur x t (** Printing functions for debug. *) module Raw = struct @@ -446,26 +440,26 @@ let minimize_impl : bool list -> bool list = definition. The typing environment [x1:A1,..,xn:An] is represented by the list [xn:An;..;x1:A1] in reverse order (last added variable comes first). *) -type ctxt = (tvar * term * term option) list +type ctxt = (var * term * term option) list (** Type of unification constraints. *) type constr = ctxt * term * term (** Sets and maps of term variables. *) module Var = struct - type t = tvar + type t = var let compare = compare_vars end module VarSet = Set.Make(Var) module VarMap = Map.Make(Var) -(** [new_tvar s] creates a new [tvar] of name [s]. *) -let new_tvar : string -> tvar = new_var +(** [new_var s] creates a new [var] of name [s]. *) +let new_var : string -> var = new_var -(** [new_tvar_ind s i] creates a new [tvar] of name [s ^ string_of_int i]. *) -let new_tvar_ind : string -> int -> tvar = fun s i -> - new_tvar (Escape.add_prefix s (string_of_int i)) +(** [new_var_ind s i] creates a new [var] of name [s ^ string_of_int i]. *) +let new_var_ind : string -> int -> var = fun s i -> + new_var (Escape.add_prefix s (string_of_int i)) (** Sets and maps of symbols. *) module Sym = struct @@ -607,7 +601,7 @@ let mk_Type = Type let mk_Kind = Kind let mk_Symb x = Symb x let mk_Prod (a,b) = Prod (a,b) -let mk_Impl (a,b) = let x = new_tvar "_" in Prod(a, bind_var x b) +let mk_Impl (a,b) = let x = new_var "_" in Prod(a, bind_var x b) let mk_Abst (a,b) = Abst (a,b) let mk_Meta (m,ts) = (*assert (m.meta_arity = Array.length ts);*) Meta (m,ts) let mk_Patt (i,s,ts) = Patt (i,s,ts) @@ -676,9 +670,9 @@ let right_aliens : sym -> term -> term list = fun s -> (* unit test *) let _ = let s = create_sym [] Privat (AC true) Eager false (Pos.none "+") Kind [] in - let t1 = Vari (new_tvar "x1") in - let t2 = Vari (new_tvar "x2") in - let t3 = Vari (new_tvar "x3") in + let t1 = Vari (new_var "x1") in + let t2 = Vari (new_var "x2") in + let t3 = Vari (new_var "x3") in let left = mk_bin s (mk_bin s t1 t2) t3 in let right = mk_bin s t1 (mk_bin s t2 t3) in let eq = eq_of_cmp cmp in @@ -749,7 +743,7 @@ let lhs : sym_rule -> term = fun (s, r) -> add_args (mk_Symb s) r.lhs let rhs : sym_rule -> term = fun (_, r) -> r.rhs (** Patt substitution. *) -let subst_patt : tmbinder option array -> term -> term = fun env -> +let subst_patt : mbinder option array -> term -> term = fun env -> let rec subst_patt t = match unfold t with | Patt(Some i,n,ts) when 0 <= i && i < Array.length env -> diff --git a/src/core/term.mli b/src/core/term.mli index 00ffa5a33..426a1d8e0 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -1,11 +1,7 @@ (** Internal representation of terms. This module contains the definition of the internal representation of - terms, together with smart constructors and low level operation. The - representation strongly relies on the {!module: library, which - provides a convenient abstraction to work with binders. - - @see *) + terms, together with smart constructors and low level operation. *) open Timed open Lplib open Base @@ -40,23 +36,23 @@ type prop = | Assoc of bool (** Associative left if [true], right if [false]. *) | AC of bool (** Associative and commutative. *) -type tbinder +type binder -type tmbinder +type mbinder -type tvar +type var (** Representation of a term (or types) in a general sense. Values of the type are also used, for example, in the representation of patterns or rewriting rules. Specific constructors are included for such applications, and they are considered invalid in unrelated code. *) type term = private - | Vari of tvar (** Free variable. *) + | Vari of var (** Free variable. *) | Type (** "TYPE" constant. *) | Kind (** "KIND" constant. *) | Symb of sym (** User-defined symbol. *) - | Prod of term * tbinder (** Dependent product. *) - | Abst of term * tbinder (** Abstraction. *) + | Prod of term * binder (** Dependent product. *) + | Abst of term * binder (** Abstraction. *) | Appl of term * term (** Term application. *) | Meta of meta * term array (** Metavariable application. *) | Patt of int option * string * term array @@ -67,25 +63,20 @@ type term = private (** [Plac b] is a placeholder, or hole, for not given terms. Boolean [b] is true if the placeholder stands for a type. *) | TRef of term option ref (** Reference cell (used in surface matching). *) - | LLet of term * term * tbinder + | LLet of term * term * binder (** [LLet(a, t, u)] is [let x : a ≔ t in u] (with [x] bound in [u]). *) (** {b NOTE} that a wildcard "_" of the concrete (source code) syntax may have - a different representation depending on the application. For instance, the + a different representation depending on the context. For instance, the {!constructor:Wild} constructor is only used when matching patterns (e.g., with the "rewrite" tactic). In the LHS of a rewriting {!type:rule}, we use the {!constructor:Patt} constructor to represend wildcards of the concrete syntax. They are thus considered to be fresh, unused pattern variables. *) -(** Representation of a rewriting rule RHS. *) -and rhs = term - (** Representation of a decision tree (used for rewriting). *) and dtree = rule Tree_type.dtree -(** Representation of a user-defined symbol. Symbols carry a "mode" indicating - whether they may be given rewriting rules or a definition. Invariants must - be enforced for "mode" consistency (see {!type:prop}). *) +(** Representation of a user-defined symbol. *) and sym = { sym_expo : expo (** Visibility. *) ; sym_path : Path.t (** Module in which the symbol is defined. *) @@ -127,7 +118,7 @@ and sym = the rule applies. More explanations are given below. *) and rule = { lhs : term list (** Left hand side (LHS). *) - ; rhs : rhs (** Right hand side (RHS). *) + ; rhs : term (** Right hand side (RHS). *) ; arity : int (** Required number of arguments to be applicable. *) ; arities : int array (** Arities of the pattern variables bound in the RHS. *) @@ -139,9 +130,9 @@ and sym = (on which the rule is defined) applied to a list of pattern arguments. The list of arguments is given in {!field:lhs}, but the head symbol itself is not stored in the rule, since rules are stored in symbols. In the pattern - arguments of a LHS, [Patt(i,s,env)] is used to represent pattern variables + arguments of a LHS, [Patt(i,s,ts)] is used to represent pattern variables that are identified by a name [s] (unique in a rewriting rule). They carry - an environment [env] that should only contain distinct variables (terms of + an environment [ts] that should only contain distinct variables (terms of the form [Vari(x)]). They correspond to the set of all the variables that may appear free in a matched term. The optional integer [i] corresponds to the reserved index for the matched term in the environment of the RHS @@ -158,7 +149,7 @@ and sym = name (in the rule) that is generated automatically. Then, the term [f t u v w] matches the LHS with a substitution represented - by an array of terms (or rather “term environments”) [a] of length 3 if we + by an array of terms [a] of length 3 if we have [a.(0) = t], [a.(1) = u], [a.(1) = v] and [a.(2) = w]. {b TODO} memorising [w] in the substitution is sub-optimal. In practice, @@ -186,7 +177,7 @@ and sym = {!field:sym_rules} field. To check if a rule [r] applies, we match the elements of [r.lhs] with those of [ts] while building an environment [env]. During this process, a pattern of - the form {!constructor:Patt}[(Some i,s,e)] matched against a term [u] will + the form {!constructor:Patt}[(Some i,_,_)] matched against a term [u] will results in [env.(i)] being set to [u]. If all terms of [ts] can be matched against corresponding patterns, then environment [env] is fully constructed and it can hence be substituted in [r.rhs] with [msubst r.rhs env] @@ -204,68 +195,68 @@ and sym = { meta_key : int (** Unique key. *) ; meta_type : term ref (** Type. *) ; meta_arity : int (** Arity (environment size). *) - ; meta_value : tmbinder option ref (** Definition. *) } + ; meta_value : mbinder option ref (** Definition. *) } (** [subst b v] substitutes the variable bound by [b] with the value [v]. *) -val subst : tbinder -> term -> term +val subst : binder -> term -> term (** [msubst b vs] substitutes the variables bound by [b] with the values [vs]. Note that the length of the [vs] array should match the arity of the multiple binder [b]. *) -val msubst : tmbinder -> term array -> term +val msubst : mbinder -> term array -> term val msubst3 : - (tmbinder * tmbinder * tmbinder) -> term array -> term * term * term + (mbinder * mbinder * mbinder) -> term array -> term * term * term (** [name_of x] returns a printable name for variable [x]. *) -val name_of : tvar -> string +val name_of : var -> string (** [unbind b] substitutes the binder [b] using a fresh variable. The variable and the result of the substitution are returned. Note that the name of the fresh variable is based on that of the binder. *) -val unbind : tbinder -> tvar * term +val unbind : binder -> var * term (** [unbind2 f g] is similar to [unbind f], but it substitutes two binders [f] and [g] at once using the same fresh variable. The name of the variable is based on that of the binder [f]. *) -val unbind2 : tbinder -> tbinder -> tvar * term * term +val unbind2 : binder -> binder -> var * term * term (** [unmbind b] substitutes the multiple binder [b] with fresh variables. This function is analogous to [unbind] for binders. Note that the names used to create the fresh variables are based on those of the multiple binder. *) -val unmbind : tmbinder -> tvar array * term +val unmbind : mbinder -> var array * term (** [bind_var x b] binds the variable [x] in [b], producing a boxed binder. *) -val bind_var : tvar -> term -> tbinder +val bind_var : var -> term -> binder (** [bind_mvar xs b] binds the variables of [xs] in [b] to get a boxed binder. It is the equivalent of [bind_var] for multiple variables. *) -val bind_mvar : tvar array -> term -> tmbinder +val bind_mvar : var array -> term -> mbinder (** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to compare variables using [Pervasive.compare]. *) -val compare_vars : tvar -> tvar -> int +val compare_vars : var -> var -> int (** [eq_vars x y] safely computes the equality of [x] and [y]. Note that it is unsafe to compare variables with the polymorphic equality function. *) -val eq_vars : tvar -> tvar -> bool +val eq_vars : var -> var -> bool (** [binder_occur b] tests whether the bound variable occurs in [b]. *) -val binder_occur : tbinder -> bool +val binder_occur : binder -> bool (** [binder_constant b] tests whether the [binder] [b] is constant (i.e., its bound variable does not occur). *) -val binder_constant : tbinder -> bool +val binder_constant : binder -> bool (** [mbinder_arity b] gives the arity of the [mbinder]. *) -val mbinder_arity : tmbinder -> int +val mbinder_arity : mbinder -> int (** [is_closed b] checks whether the [box] [b] is closed. *) val is_closed : term -> bool -val is_closed_tmbinder : tmbinder -> bool +val is_closed_mbinder : mbinder -> bool (** [occur x b] tells whether variable [x] occurs in the [box] [b]. *) -val occur : tvar -> term -> bool -val occur_tmbinder : tvar -> tmbinder -> bool +val occur : var -> term -> bool +val occur_mbinder : var -> mbinder -> bool (** Minimize [impl] to enforce our invariant (see {!type:Term.sym}). *) val minimize_impl : bool list -> bool list @@ -279,22 +270,22 @@ end definition. The typing environment [x1:A1,..,xn:An] is represented by the list [xn:An;..;x1:A1] in reverse order (last added variable comes first). *) -type ctxt = (tvar * term * term option) list +type ctxt = (var * term * term option) list (** Type of unification constraints. *) type constr = ctxt * term * term (** Sets and maps of term variables. *) -module Var : Map.OrderedType with type t = tvar +module Var : Map.OrderedType with type t = var -module VarSet : Set.S with type elt = tvar -module VarMap : Map.S with type key = tvar +module VarSet : Set.S with type elt = var +module VarMap : Map.S with type key = var -(** [new_tvar s] creates a new [tvar] of name [s]. *) -val new_tvar : string -> tvar +(** [new_var s] creates a new [var] of name [s]. *) +val new_var : string -> var -(** [new_tvar_ind s i] creates a new [tvar] of name [s ^ string_of_int i]. *) -val new_tvar_ind : string -> int -> tvar +(** [new_var_ind s i] creates a new [var] of name [s ^ string_of_int i]. *) +val new_var_ind : string -> int -> var (** Sets and maps of symbols. *) module Sym : Map.OrderedType with type t = sym @@ -388,20 +379,20 @@ val get_args_len : term -> term * term list * int - In [LLet(_,_,b)], [binder_constant b = false] (useless let's are erased). *) -val mk_Vari : tvar -> term +val mk_Vari : var -> term val mk_Type : term val mk_Kind : term val mk_Symb : sym -> term -val mk_Prod : term * tbinder -> term +val mk_Prod : term * binder -> term val mk_Impl : term * term -> term -val mk_Abst : term * tbinder -> term +val mk_Abst : term * binder -> term val mk_Appl : term * term -> term val mk_Meta : meta * term array -> term val mk_Patt : int option * string * term array -> term val mk_Wild : term val mk_Plac : bool -> term val mk_TRef : term option ref -> term -val mk_LLet : term * term * tbinder -> term +val mk_LLet : term * term * binder -> term (** [mk_Appl_not_canonical t u] builds the non-canonical (wrt. C and AC symbols) application of [t] to [u]. WARNING: to use only in Sign.link. *) @@ -432,7 +423,7 @@ val lhs : sym_rule -> term val rhs : sym_rule -> term (** Patt substitution. *) -val subst_patt : tmbinder option array -> term -> term +val subst_patt : mbinder option array -> term -> term (** [cleanup t] unfold all metas and TRef's in [t]. *) val cleanup : term -> term diff --git a/src/core/tree.ml b/src/core/tree.ml index bcae8ad9a..7e68cca9e 100644 --- a/src/core/tree.ml +++ b/src/core/tree.ml @@ -438,7 +438,7 @@ module CM = struct List.exists st_r cm.clauses let index_var : int VarMap.t -> term -> int = fun vi t -> - VarMap.find (to_tvar t) vi + VarMap.find (to_var t) vi (** [mk_wildcard vs] creates a pattern variable that accepts anything and in which variables [vs] can appear free. There is no order on [vs] because @@ -569,8 +569,8 @@ module CM = struct clause [cls]. The domain [a] of the binder and [b[v/x]] are put back into the stack (in that order), with [a] with argument position 0 and [b[v/x]] as argument 1. *) - let binder : (term -> (term * tbinder)) -> VarSet.t -> int -> - tvar -> arg list -> clause list -> arg list * clause list = + let binder : (term -> (term * binder)) -> VarSet.t -> int -> + var -> arg list -> clause list -> arg list * clause list = fun get free_vars col v pos cls -> let (l, {arg_path; arg_rank}, r) = List.destruct pos col in let ab = {arg_path = 1 :: arg_path; arg_rank = arg_rank + 1} in @@ -604,13 +604,13 @@ module CM = struct is the position of terms in clauses [cls] and [free_vars] is the set of {e free} variables introduced by other binders that may appear in patterns. *) - let abstract : VarSet.t -> int -> tvar -> arg list -> clause list -> + let abstract : VarSet.t -> int -> var -> arg list -> clause list -> arg list * clause list = binder (function Abst(a,b) -> a, b | _ -> assert false) (** [product free_vars col v pos cls] is like [abstract free_vars col v pos cls] for products. *) - let product : VarSet.t -> int -> tvar -> arg list -> clause list -> + let product : VarSet.t -> int -> var -> arg list -> clause list -> arg list * clause list = binder (function Prod(a, b) -> a, b | _ -> assert false) @@ -739,7 +739,7 @@ let compile : match_strat -> CM.t -> tree = fun mstrat m -> let binder recon mat_transf = if List.for_all (fun x -> not (recon x)) column then None else let v_lvl = VarMap.cardinal vars_id in (* Level of the variable. *) - let var = new_tvar (Printf.sprintf "d%dv" v_lvl) in + let var = new_var (Printf.sprintf "d%dv" v_lvl) in let (positions, clauses) = mat_transf (keys vars_id) swap var positions updated in diff --git a/src/core/unif.ml b/src/core/unif.ml index 5d7658d63..d72adb708 100644 --- a/src/core/unif.ml +++ b/src/core/unif.ml @@ -24,7 +24,7 @@ let set_to_prod : problem -> meta -> unit = fun p m -> let m1 = LibMeta.fresh p u1 n in let a = mk_Meta (m1, xs) in (* codomain *) - let y = new_tvar "y" in + let y = new_var "y" in let env' = Env.add "y" y (mk_Meta (m1, xs)) None env in let u2 = Env.to_prod env' s in let m2 = LibMeta.fresh p u2 (n+1) in @@ -101,7 +101,7 @@ let instantiable : ctxt -> meta -> term array -> term -> bool = be instantiated and returns the corresponding instantiation, simplified. It does not check whether the instantiation is closed though. *) let instantiation : - ctxt -> meta -> term array -> term -> tmbinder option = + ctxt -> meta -> term array -> term -> mbinder option = fun c m ts u -> match nl_distinct_vars c ts with | None -> None @@ -120,7 +120,7 @@ let instantiate : problem -> ctxt -> meta -> term array -> term -> bool = fun p c m ts u -> if Logger.log_enabled () then log "try instantiate"; match instantiation c m ts u with - | Some b when is_closed_tmbinder b -> + | Some b when is_closed_mbinder b -> let do_instantiate() = if Logger.log_enabled () then log (red "%a ≔ %a") meta m term u; LibMeta.set p m b; @@ -269,7 +269,7 @@ let imitate_lam : problem -> ctxt -> meta -> unit = fun p c m -> let tm2 = Env.to_prod env mk_Type in let m2 = LibMeta.fresh p tm2 n in let a = mk_Meta (m2, Env.to_terms env) in - let x = new_tvar "x" in + let x = new_var "x" in let env' = Env.add "x" x a None env in let tm3 = Env.to_prod env' mk_Type in let m3 = LibMeta.fresh p tm3 (n+1) in diff --git a/src/export/dk.ml b/src/export/dk.ml index e4cfe4eb9..c576a9a98 100644 --- a/src/export/dk.ml +++ b/src/export/dk.ml @@ -108,12 +108,12 @@ let cmp : decl cmp = cmp_map (Lplib.Option.cmp Pos.cmp) pos_of_decl (** Translation of terms. *) -let tvar : tvar pp = fun ppf v -> ident ppf (name_of v) +let var : var pp = fun ppf v -> ident ppf (name_of v) (** [term b ppf t] prints term [t]. Print abstraction domains if [b]. *) let rec term : bool -> term pp = fun b ppf t -> match unfold t with - | Vari v -> tvar ppf v + | Vari v -> var ppf v | Type -> out ppf "Type" | Kind -> assert false | Symb s -> qid ppf (s.sym_path, s.sym_name) @@ -121,17 +121,17 @@ let rec term : bool -> term pp = fun b ppf t -> let x,u' = unbind u in if binder_constant u then out ppf "(%a -> %a)" (term b) t (term b) u' - else out ppf "(%a : %a -> %a)" tvar x (term b) t (term b) u' + else out ppf "(%a : %a -> %a)" var x (term b) t (term b) u' | Abst(t,u) -> let x,u = unbind u in - if b then out ppf "(%a : %a => %a)" tvar x (term b) t (term b) u - else out ppf "(%a => %a)" tvar x (term b) u + if b then out ppf "(%a : %a => %a)" var x (term b) t (term b) u + else out ppf "(%a => %a)" var x (term b) u | Appl _ -> let h, ts = get_args t in out ppf "(%a%a)" (term b) h (List.pp (prefix " " (term b)) "") ts | LLet(a,t,u) -> let x,u = unbind u in - out ppf "((%a : %a := %a) => %a)" tvar x (term b) a (term b) t (term b) u + out ppf "((%a : %a := %a) => %a)" var x (term b) a (term b) t (term b) u | Patt(None,_,_) -> assert false | Patt(Some i,_,[||]) -> int ppf i | Patt(Some i,_,ts) -> diff --git a/src/export/xtc.ml b/src/export/xtc.ml index 14a249725..147de2a2d 100644 --- a/src/export/xtc.ml +++ b/src/export/xtc.ml @@ -114,8 +114,8 @@ let print_tl_rule : Format.formatter -> int -> sym -> rule -> unit = in the form of a pair containing the name of the variable and its type, inferred by the solver. *) let get_vars : sym -> rule -> (string * Term.term) list = fun s r -> - let rule_ctx : tvar option array = Array.make r.vars_nb None in - let var_list : tvar list ref = ref [] in + let rule_ctx : var option array = Array.make r.vars_nb None in + let var_list : var list ref = ref [] in let rec subst_patt v t = match t with | Type @@ -137,7 +137,7 @@ let get_vars : sym -> rule -> (string * Term.term) list = fun s r -> | Patt (Some(i), _, a) -> if v.(i) = None then - (let v_i = new_tvar (string_of_int i) in + (let v_i = new_var (string_of_int i) in var_list := v_i :: !var_list; v.(i) <- Some(v_i)); let v_i = diff --git a/src/handle/inductive.ml b/src/handle/inductive.ml index 383336370..1eac47473 100644 --- a/src/handle/inductive.ml +++ b/src/handle/inductive.ml @@ -36,7 +36,7 @@ let get_config : Sig_state.t -> Pos.popt -> config = fun ss pos -> (** [prf_of p c ts t] returns the term [c.symb_prf (p t1 ... tn t)] where ts = [ts1;...;tsn]. *) -let prf_of : config -> tvar -> term list -> term -> term = fun c p ts t -> +let prf_of : config -> var -> term list -> term -> term = fun c p ts t -> mk_Appl (mk_Symb c.symb_prf, mk_Appl (add_args (mk_Vari p) ts, t)) (** compute safe prefixes for predicate and constructor argument variables. *) @@ -70,7 +70,7 @@ let gen_safe_prefixes : inductive -> string * string * string = (** Type of maps associating to every inductive type some data useful for generating the induction principles. *) -type data = { ind_var : tvar (** predicate variable *) +type data = { ind_var : var (** predicate variable *) ; ind_type : term (** predicate variable type *) ; ind_conclu : term (** induction principle conclusion *) } type ind_pred_map = (sym * data) list @@ -83,7 +83,7 @@ let ind_typ_with_codom : popt -> sym -> Env.t -> (term list -> term) -> string -> term -> term = fun pos ind_sym env codom x_str a -> let i = Stdlib.ref (-1) in - let rec aux : tvar list -> term -> term = fun xs a -> + let rec aux : var list -> term -> term = fun xs a -> match get_args a with | (Type, _) -> codom (List.rev_map mk_Vari xs) | (Prod(a,b), _) -> @@ -101,10 +101,10 @@ let ind_typ_with_codom : the names of the variable arguments of predicate variables. *) let create_ind_pred_map : popt -> config -> int -> inductive -> string -> string -> string - -> tvar array * Env.t * ind_pred_map = + -> var array * Env.t * ind_pred_map = fun pos c arity ind_list a_str p_str x_str -> (* create parameters *) - let vs = Array.init arity (new_tvar_ind a_str) in + let vs = Array.init arity (new_var_ind a_str) in let env = match ind_list with | [] -> assert false (* there must be at least one type definition *) @@ -114,7 +114,7 @@ let create_ind_pred_map : (* create the ind_pred_map *) let create_sym_pred_data i (ind_sym,_) = (* predicate variable *) - let ind_var = new_tvar_ind p_str i in + let ind_var = new_var_ind p_str i in (* predicate type *) let codom ts = mk_Impl (add_args (mk_Symb ind_sym) ts, mk_Symb c.symb_Prop) in @@ -122,7 +122,7 @@ let create_ind_pred_map : let ind_type = ind_typ_with_codom pos ind_sym env codom x_str a in (* predicate conclusion *) let codom ts = - let x = new_tvar x_str in + let x = new_var x_str in let t = bind_var x (prf_of c ind_var (List.remove_heads arity ts) (mk_Vari x)) in mk_Prod (add_args (mk_Symb ind_sym) ts, t) @@ -177,19 +177,19 @@ let fold_cons_type (ind_pred_map : ind_pred_map) (x_str : string) (ind_sym : sym) - (vs : tvar array) + (vs : var array) (cons_sym : sym) - (inj_var : int -> tvar -> 'var) + (inj_var : int -> var -> 'var) (init : 'a) - (aux : Env.t -> sym -> tvar -> term list -> 'var -> 'aux) + (aux : Env.t -> sym -> var -> term list -> 'var -> 'aux) (acc_rec_dom : 'a -> 'var -> 'aux -> 'a) (rec_dom : term -> 'var -> 'aux -> 'c -> 'c) (acc_nonrec_dom : 'a -> 'var -> 'a) (nonrec_dom : term -> 'var -> 'c -> 'c) - (codom : 'var list -> 'a -> tvar -> term list -> 'c) + (codom : 'var list -> 'a -> var -> term list -> 'c) : 'c = let i = Stdlib.ref (-1) in @@ -236,14 +236,14 @@ let fold_cons_type x₁)-> π(p (c x₀ x₁)) -> Π x:T, π(p x)]. *) let gen_rec_types : config -> popt -> inductive - -> tvar array -> Env.t -> ind_pred_map -> string -> term list = + -> var array -> Env.t -> ind_pred_map -> string -> term list = fun c pos ind_list vs env ind_pred_map x_str -> let n = Array.length vs in (* [case_of ind_sym cons_sym] creates the clause for the constructor [cons_sym] in the induction principle of [ind_sym]. *) let case_of : sym -> sym -> term = fun ind_sym cons_sym -> - (* 'var = tvar, 'a = unit, 'aux = unit, 'c = term *) + (* 'var = var, 'a = unit, 'aux = unit, 'c = term *) (* the accumulator is not used *) let inj_var _ x = x in let init = () in @@ -300,7 +300,7 @@ let rec_name ind_sym = Escape.add_prefix "ind_" ind_sym.sym_name --> pci x1 t1? ... xk tk?] with m underscores, [tj? = ind_T p pc1 .. pcn _ .. _ xj] if [Bj = T v1 ... vm], and nothing otherwise. *) let iter_rec_rules : - popt -> inductive -> tvar array -> ind_pred_map + popt -> inductive -> var array -> ind_pred_map -> (p_rule -> unit) -> unit = fun pos ind_list vs ind_pred_map f -> (* Rules are declared after recursor declarations. *) diff --git a/src/handle/rewrite.ml b/src/handle/rewrite.ml index ca6c12a11..93234fe32 100644 --- a/src/handle/rewrite.ml +++ b/src/handle/rewrite.ml @@ -57,7 +57,7 @@ let _ = let symb_P = Builtin.get pos map "P" in let term_U = get_domain_of_type symb_T in let term_Prop = get_domain_of_type symb_P in - let a = new_tvar "a" in + let a = new_var "a" in let term_T_a = mk_Appl (mk_Symb symb_T, mk_Vari a) in let impls = mk_Impl (term_T_a, mk_Impl (term_T_a, term_Prop)) in mk_Prod (term_U, bind_var a impls) @@ -69,8 +69,8 @@ let _ = let symb_P = Builtin.get pos map "P" in let symb_eq = Builtin.get pos map "eq" in let term_U = get_domain_of_type symb_T in - let a = new_tvar "a" in - let x = new_tvar "x" in + let a = new_var "a" in + let x = new_var "x" in let appl_eq = mk_Appl (mk_Symb symb_eq, mk_Vari a) in let appl_eq = mk_Appl (mk_Appl (appl_eq, mk_Vari x), mk_Vari x) in let appl = mk_Appl (mk_Symb symb_P, appl_eq) in @@ -89,10 +89,10 @@ let _ = let term_eq = mk_Symb symb_eq in let term_U = get_domain_of_type symb_T in let term_Prop = get_domain_of_type symb_P in - let a = new_tvar "a" in - let x = new_tvar "x" in - let y = new_tvar "y" in - let p = new_tvar "p" in + let a = new_var "a" in + let x = new_var "x" in + let y = new_var "y" in + let p = new_var "p" in let term_T_a = mk_Appl (term_T, mk_Vari a) in let term_P_p_x = mk_Appl (term_P, mk_Appl (mk_Vari p, mk_Vari x)) in let term_P_p_y = mk_Appl (term_P, mk_Appl (mk_Vari p, mk_Vari y)) in @@ -110,7 +110,7 @@ let _ = (** [get_eq_data pos cfg a] returns [((a,l,r),[v1;..;vn])] if [a ≡ Π v1:A1, .., Π vn:An, P (eq a l r)] and fails otherwise. *) let get_eq_data : - eq_config -> popt -> term -> (term * term * term) * tvar array = fun cfg -> + eq_config -> popt -> term -> (term * term * term) * var array = fun cfg -> let exception Not_eq of term in let get_eq_args u = if Logger.log_enabled () then log_rewr "get_eq_args %a" term u; @@ -147,7 +147,7 @@ let get_eq_data : (** Type of a term with the free variables that need to be substituted. It is usually used to store the LHS of a proof of equality, together with the variables that were quantified over. *) -type to_subst = tvar array * term +type to_subst = var array * term (** [matches p t] instantiates the [TRef]'s of [p] so that [p] gets equal to [t] and returns [true] if all [TRef]'s of [p] could be instantiated, and @@ -258,8 +258,8 @@ let find_subterm_matching : term -> term -> bool = fun p t -> (** [bind_pattern p t] replaces in the term [t] every occurence of the pattern [p] by a fresh variable, and returns the binder on this variable. *) -let bind_pattern : term -> term -> tbinder = fun p t -> - let z = new_tvar "z" in +let bind_pattern : term -> term -> binder = fun p t -> + let z = new_var "z" in let rec replace : term -> term = fun t -> if matches p t then mk_Vari z else match unfold t with @@ -289,7 +289,7 @@ let swap : eq_config -> term -> term -> term -> term -> term = fun cfg a r l t -> (* We build the predicate “λx:T a, eq a l x”. *) let pred = - let x = new_tvar "x" in + let x = new_var "x" in let pred = add_args (mk_Symb cfg.symb_eq) [a; l; mk_Vari x] in mk_Abst(mk_Appl(mk_Symb cfg.symb_T, a), bind_var x pred) in @@ -314,7 +314,7 @@ let rec replace_wild_by_tref : term -> term = fun t -> equational lemma that is appied. It handles the full set of SSReflect patterns. *) let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> - (term, tbinder) Parsing.Syntax.rw_patt option -> term -> term = + (term, binder) Parsing.Syntax.rw_patt option -> term -> term = fun ss p pos {goal_hyps=g_env; goal_type=g_type; _} l2r pat t -> (* Obtain the required symbols from the current signature. *) diff --git a/src/handle/tactic.ml b/src/handle/tactic.ml index 2a21143c0..e753e80cc 100644 --- a/src/handle/tactic.ml +++ b/src/handle/tactic.ml @@ -44,7 +44,7 @@ let add_axiom : Sig_state.t -> popt -> meta -> Sig_state.t = substituted by the terms of the explicit substitution of the metavariable. *) let meta_value = - let vars = Array.init m.meta_arity (new_tvar_ind "x") in + let vars = Array.init m.meta_arity (new_var_ind "x") in let ax = add_args (mk_Symb sym) (List.map mk_Vari (Array.to_list vars)) in bind_mvar vars ax in @@ -277,7 +277,7 @@ let handle : let n = List.length env in let m1 = LibMeta.fresh p (Env.to_prod env t) n in (* Refine the focused goal. *) - let v = new_tvar id.elt in + let v = new_var id.elt in let env' = Env.add id.elt v t None env in let m2 = LibMeta.fresh p (Env.to_prod env' gt.goal_type) (n+1) in let ts = Env.to_terms env in diff --git a/src/parsing/scope.ml b/src/parsing/scope.ml index b28290482..e5a747f68 100644 --- a/src/parsing/scope.ml +++ b/src/parsing/scope.ml @@ -288,7 +288,7 @@ and scope_domain : int -> mode -> sig_state -> env -> p_term option -> term = appear in the body. [typ] indicates if we scope a type (default is false). *) and scope_binder : ?typ:bool -> int -> mode -> sig_state -> - (term * tbinder -> term) -> Env.t -> p_params list -> + (term * binder -> term) -> Env.t -> p_params list -> p_term option -> term = fun ?(typ=false) k md ss cons env params_list t -> let rec scope_params_list env params_list = @@ -307,7 +307,7 @@ and scope_binder : ?typ:bool -> int -> mode -> sig_state -> match idopts with | [] -> scope_params_list env params_list | None::idopts -> - let v = new_tvar "_" in + let v = new_var "_" in let t = aux env idopts in cons (a, bind_var v t) | Some {elt=id;pos}::idopts -> @@ -315,7 +315,7 @@ and scope_binder : ?typ:bool -> int -> mode -> sig_state -> fatal pos "\"%s\": Escaped identifiers or regular identifiers \ having an integer suffix with leading zeros \ are not allowed for bound variable names." id; - let v = new_tvar id in + let v = new_var id in let env = Env.add id v a None env in let t = aux env idopts in cons (a, bind_var v t) @@ -469,7 +469,7 @@ and scope_head : | (P_LLet(x,xs,a,t,u), (M_Term _|M_URHS _|M_RHS _)) -> let a = scope_binder ~typ:true (k+1) md ss mk_Prod env xs a in let t = scope_binder (k+1) md ss mk_Abst env xs (Some(t)) in - let v = new_tvar x.elt in + let v = new_var x.elt in let u = scope ~typ (k+1) md ss (Env.add x.elt v a (Some(t)) env) u in if not (occur v u) then wrn x.pos "Useless let-binding (%s is not bound)." x.elt; @@ -642,26 +642,26 @@ let scope_pattern : sig_state -> env -> p_term -> term = fun ss env t -> (** [scope_rw_patt ss env t] turns a parser-level rewrite tactic specification [s] into an actual rewrite specification (possibly containing variables of [env] and using [ss] for aliasing). *) -let scope_rw_patt : sig_state -> env -> p_rw_patt -> (term, tbinder) rw_patt = +let scope_rw_patt : sig_state -> env -> p_rw_patt -> (term, binder) rw_patt = fun ss env s -> match s.elt with | Rw_Term(t) -> Rw_Term(scope_pattern ss env t) | Rw_InTerm(t) -> Rw_InTerm(scope_pattern ss env t) | Rw_InIdInTerm(x,t) -> - let v = new_tvar x.elt in + let v = new_var x.elt in let t = scope_pattern ss ((x.elt,(v, mk_Kind, None))::env) t in Rw_InIdInTerm(bind_var v t) | Rw_IdInTerm(x,t) -> - let v = new_tvar x.elt in + let v = new_var x.elt in let t = scope_pattern ss ((x.elt,(v, mk_Kind, None))::env) t in Rw_IdInTerm(bind_var v t) | Rw_TermInIdInTerm(u,(x,t)) -> let u = scope_pattern ss env u in - let v = new_tvar x.elt in + let v = new_var x.elt in let t = scope_pattern ss ((x.elt,(v, mk_Kind, None))::env) t in Rw_TermInIdInTerm(u, bind_var v t) | Rw_TermAsIdInTerm(u,(x,t)) -> let u = scope_pattern ss env u in - let v = new_tvar x.elt in + let v = new_var x.elt in let t = scope_pattern ss ((x.elt,(v, mk_Kind, None))::env) t in Rw_TermAsIdInTerm(u, bind_var v t) diff --git a/src/parsing/scope.mli b/src/parsing/scope.mli index 47edf423e..5b05a282d 100644 --- a/src/parsing/scope.mli +++ b/src/parsing/scope.mli @@ -24,4 +24,4 @@ val scope_rule : bool -> sig_state -> p_rule -> sym_rule (** [scope_rw_patt ss env t] turns a parser-level rewrite tactic specification [s] into an actual rewrite specification (possibly containing variables of [env] and using [ss] for aliasing). *) -val scope_rw_patt : sig_state -> env -> p_rw_patt -> (term, tbinder) rw_patt +val scope_rw_patt : sig_state -> env -> p_rw_patt -> (term, binder) rw_patt diff --git a/src/parsing/syntax.ml b/src/parsing/syntax.ml index 30ce74f74..e289ffb62 100644 --- a/src/parsing/syntax.ml +++ b/src/parsing/syntax.ml @@ -108,7 +108,7 @@ module P = struct let iden : string -> p_term = qiden [] (** [var v] builds a [P_Iden] from [name_of v]. *) - let var : Term.tvar -> p_term = fun v -> iden (Term.name_of v) + let var : Term.var -> p_term = fun v -> iden (Term.name_of v) (** [patt s ts] builds a [P_Patt] "$s[ts]". *) let patt : string -> p_term array option -> p_term = fun s ts -> diff --git a/src/tool/sr.ml b/src/tool/sr.ml index 70f69b25d..c7234d2ba 100644 --- a/src/tool/sr.ml +++ b/src/tool/sr.ml @@ -15,7 +15,7 @@ let log_subj = log_subj.pp metavariables in [p]. *) let build_meta_type : problem -> int -> term = fun p k -> assert (k >= 0); - let xs = Array.init k (new_tvar_ind "x") in + let xs = Array.init k (new_var_ind "x") in let ts = Array.map mk_Vari xs in (* We create the types for the “Mi” metavariables. *) let ty_m = Array.make (k+1) mk_Type in @@ -102,7 +102,7 @@ let check_rule : Pos.popt -> sym_rule -> sym_rule = in (* Replace Patt's by Meta's. *) let f m = - let xs = Array.init m.meta_arity (new_tvar_ind "x") in + let xs = Array.init m.meta_arity (new_var_ind "x") in let ts = Array.map mk_Vari xs in Some(bind_mvar xs (mk_Meta (m, ts))) in @@ -144,7 +144,7 @@ let check_rule : Pos.popt -> sym_rule -> sym_rule = false name !(m.meta_type) [] in Stdlib.(symbols := SymSet.add s !symbols); (* Build a definition for [m]. *) - let xs = Array.init m.meta_arity (new_tvar_ind "x") in + let xs = Array.init m.meta_arity (new_var_ind "x") in let s = mk_Symb s in let def = Array.fold_left (fun t x -> _Appl t (mk_Vari x)) s xs in m.meta_value := Some(bind_mvar xs def) @@ -164,7 +164,7 @@ let check_rule : Pos.popt -> sym_rule -> sym_rule = Privat Defin Eager false name !(m.meta_type) [] in Stdlib.(map := SymMap.add s None !map; m2s := MetaMap.add m s !m2s); - let xs = Array.init m.meta_arity (new_tvar_ind "x") in + let xs = Array.init m.meta_arity (new_var_ind "x") in let s = mk_Symb s in let def = Array.fold_left (fun t x -> mk_Appl (t, mk_Vari x)) s xs in m.meta_value := Some(bind_mvar xs def) From 3376e30adb67dffa56d4d86fc558ab7fcead663d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 15 Feb 2022 08:42:11 +0100 Subject: [PATCH 19/38] call mk_Appl in subst, and reorganize code in term --- src/core/term.ml | 664 +++++++++++++++++++++--------------------- src/core/term.mli | 238 ++++++++------- src/handle/rewrite.ml | 3 +- 3 files changed, 453 insertions(+), 452 deletions(-) diff --git a/src/core/term.ml b/src/core/term.ml index 10ec74b4f..da08f55d7 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -164,37 +164,118 @@ and meta = ; meta_arity : int (** Arity (environment size). *) ; meta_value : mbinder option ref (** Definition. *) } +(** Type for free variables. *) +and var = int * string + +(** Type for binders. *) and binder = string * term and mbinder = string array * term -and var = int * string +(** [mbinder_arity b] gives the arity of the [mbinder]. *) +let mbinder_arity : mbinder -> int = fun (names,_) -> Array.length names -(** [unfold t] repeatedly unfolds the definition of the surface constructor - of [t], until a significant {!type:term} constructor is found. The term - that is returned cannot be an instantiated metavariable or term - environment nor a reference cell ({!constructor:TRef} constructor). Note - that the returned value is physically equal to [t] if no unfolding was - performed. {b NOTE} that {!val:unfold} must (almost) always be called - before matching over a value of type {!type:term}. *) -let rec unfold : term -> term = fun t -> - match t with - | Meta(m, ts) -> - begin - match !(m.meta_value) with - | None -> t - | Some(b) -> unfold (msubst b ts) - end - | TRef(r) -> - begin - match !r with - | None -> t - | Some(v) -> unfold v - end - | _ -> t +(** Minimize [impl] to enforce our invariant (see {!type:Terms.sym}). *) +let minimize_impl : bool list -> bool list = + let rec rem_false l = match l with false::l -> rem_false l | _ -> l in + fun l -> List.rev (rem_false (List.rev l)) + +(** [create_sym path expo prop opaq name typ impl] creates a new symbol with + path [path], exposition [expo], property [prop], opacity [opaq], matching + strategy [mstrat], name [name.elt], type [typ], implicit arguments [impl], + position [name.pos], no definition and no rules. *) +let create_sym : Path.t -> expo -> prop -> match_strat -> bool -> + Pos.strloc -> term -> bool list -> sym = + fun sym_path sym_expo sym_prop sym_mstrat sym_opaq + { elt = sym_name; pos = sym_pos } typ sym_impl -> + {sym_path; sym_name; sym_type = ref typ; sym_impl; sym_def = ref None; + sym_opaq; sym_rules = ref []; sym_dtree = ref Tree_type.empty_dtree; + sym_mstrat; sym_prop; sym_expo; sym_pos } + +(** [is_constant s] tells whether [s] is a constant. *) +let is_constant : sym -> bool = fun s -> s.sym_prop = Const + +(** [is_injective s] tells whether [s] is injective, which is in partiular the + case if [s] is constant. *) +let is_injective : sym -> bool = fun s -> + match s.sym_prop with Const | Injec -> true | _ -> false + +(** [is_private s] tells whether the symbol [s] is private. *) +let is_private : sym -> bool = fun s -> s.sym_expo = Privat + +(** [is_modulo s] tells whether the symbol [s] is modulo some equations. *) +let is_modulo : sym -> bool = fun s -> + match s.sym_prop with Assoc _ | Commu | AC _ -> true | _ -> false + +(** Sets and maps of symbols. *) +module Sym = struct + type t = sym + let compare s1 s2 = + if s1 == s2 then 0 else + match Stdlib.compare s1.sym_name s2.sym_name with + | 0 -> Stdlib.compare s1.sym_path s2.sym_path + | n -> n +end + +module SymSet = Set.Make(Sym) +module SymMap = Map.Make(Sym) + +(** [is_unset m] returns [true] if [m] is not instantiated. *) +let is_unset : meta -> bool = fun m -> !(m.meta_value) = None + +(** Sets and maps of metavariables. *) +module Meta = struct + type t = meta + let compare m1 m2 = m2.meta_key - m1.meta_key +end + +module MetaSet = Set.Make(Meta) +module MetaMap = Map.Make(Meta) + +(** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to + compare variables using [Pervasive.compare]. *) +let compare_vars : var -> var -> int = fun (i,_) (j,_) -> Stdlib.compare i j + +(** [eq_vars x y] safely computes the equality of [x] and [y]. Note that it is + unsafe to compare variables with the polymorphic equality function. *) +let eq_vars : var -> var -> bool = fun x y -> compare_vars x y = 0 + +(** [new_var name] creates a new unique variable of name [name]. *) +let new_var : string -> var = + let open Stdlib in let n = ref 0 in fun name -> incr n; !n, name + +(** [new_var_ind s i] creates a new [var] of name [s ^ string_of_int i]. *) +let new_var_ind : string -> int -> var = fun s i -> + new_var (Escape.add_prefix s (string_of_int i)) + +(** [name_of x] returns the name of variable [x]. *) +let name_of : var -> string = fun (_i,n) -> n (*^ string_of_int i*) + +(** Sets and maps of variables. *) +module Var = struct + type t = var + let compare = compare_vars +end + +module VarSet = Set.Make(Var) +module VarMap = Map.Make(Var) + +let mk_bin s t1 t2 = Appl(Appl(Symb s, t1), t2) + +(** [mk_left_comb s t ts] builds a left comb of applications of [s] from + [t::ts] so that [mk_left_comb s t1 [t2; t3] = mk_bin s (mk_bin s t1 t2) + t3]. *) +let mk_left_comb : sym -> term -> term list -> term = fun s -> + List.fold_left (mk_bin s) + +(** [mk_right_comb s ts t] builds a right comb of applications of [s] to + [ts@[p]] so that [mk_right_comb s [t1; t2] t3 = mk_bin s t1 (mk_bin s t2 + t3)]. *) +let mk_right_comb : sym -> term list -> term -> term = fun s -> + List.fold_right (mk_bin s) (** Printing functions for debug. *) -and term : term pp = fun ppf t -> +let rec term : term pp = fun ppf t -> match unfold t with | Db k -> out ppf "`%d" k | Vari v -> var ppf v @@ -216,12 +297,36 @@ and sym : sym pp = fun ppf s -> string ppf s.sym_name and terms : term array pp = fun ppf ts -> if Array.length ts > 0 then D.array term ppf ts +(** [unfold t] repeatedly unfolds the definition of the surface constructor + of [t], until a significant {!type:term} constructor is found. The term + that is returned can be neither an instantiated metavariable + nor a reference cell ({!constructor:TRef} constructor). Note + that the returned value is physically equal to [t] if no unfolding was + performed. {b NOTE} that {!val:unfold} must (almost) always be called + before matching over a value of type {!type:term}. *) +and unfold : term -> term = fun t -> + match t with + | Meta(m, ts) -> + begin + match !(m.meta_value) with + | None -> t + | Some(b) -> unfold (msubst b ts) + end + | TRef(r) -> + begin + match !r with + | None -> t + | Some(v) -> unfold v + end + | _ -> t + (** [lift l t] updates indices when [t] is moved under [l] binders. *) and lift : int -> term -> term = fun l t -> let rec lift i t = match unfold t with | Db k -> if k < i then t else Db (k+l) - | Appl(a,b) -> (*FIXME: mk_Appl*) Appl(lift i a, lift i b) + | Appl(a,b) -> Appl(lift i a, lift i b) + (* No need to call mk_Appl here as we only change indices. *) | Abst(a,(n,u)) -> Abst(lift i a, (n, lift (i+1) u)) | Prod(a,(n,u)) -> Prod(lift i a, (n ,lift (i+1) u)) | LLet(a,t,(n,u)) -> LLet(lift i a, lift i t, (n, lift (i+1) u)) @@ -247,7 +352,7 @@ and msubst : mbinder -> term array -> term = fun (ns,t) vs -> match unfold t with | Db k -> let j = k-i in if j<0 then t else (assert(j (*FIXME: mk_Appl*) Appl(msubst i a, msubst i b) + | Appl(a,b) -> mk_Appl(msubst i a, msubst i b) | Abst(a,(n,u)) -> Abst(msubst i a, (n, msubst (i+1) u)) | Prod(a,(n,u)) -> Prod(msubst i a, (n, msubst (i+1) u)) | LLet(a,t,(n,u)) -> LLet(msubst i a, msubst i t, (n, msubst (i+1) u)) @@ -260,9 +365,144 @@ and msubst : mbinder -> term array -> term = fun (ns,t) vs -> log_term "msubst %a %a = %a" term t (D.array term) vs term r; r -let msubst3 : - (mbinder * mbinder * mbinder) -> term array -> term * term * term = - fun (b1, b2, b3) ts -> msubst b1 ts, msubst b2 ts, msubst b3 ts +(** Total order on terms. *) +and cmp : term cmp = fun t t' -> + match unfold t, unfold t' with + | Vari x, Vari x' -> compare_vars x x' + | Type, Type + | Kind, Kind + | Wild, Wild -> 0 + | Symb s, Symb s' -> Sym.compare s s' + | Prod(t,(_,u)), Prod(t',(_,u')) + | Abst(t,(_,u)), Abst(t',(_,u')) -> lex cmp cmp (t,u) (t',u') + | Appl(t,u), Appl(t',u') -> lex cmp cmp (u,t) (u',t') + | Meta(m,ts), Meta(m',ts') -> + lex Meta.compare (Array.cmp cmp) (m,ts) (m',ts') + | Patt(i,s,ts), Patt(i',s',ts') -> + lex3 Stdlib.compare Stdlib.compare (Array.cmp cmp) + (i,s,ts) (i',s',ts') + | Db i, Db j -> Stdlib.compare i j + | TRef r, TRef r' -> Stdlib.compare r r' + | LLet(a,t,(_,u)), LLet(a',t',(_,u')) -> + lex3 cmp cmp cmp (a,t,u) (a',t',u') + | t, t' -> cmp_tag t t' + +(** [get_args t] decomposes the {!type:term} [t] into a pair [(h,args)], where + [h] is the head term of [t] and [args] is the list of arguments applied to + [h] in [t]. The returned [h] cannot be an [Appl] node. *) +and get_args : term -> term * term list = fun t -> + let rec get_args t acc = + match unfold t with + | Appl(t,u) -> get_args t (u::acc) + | t -> t, acc + in get_args t [] + +(** [get_args_len t] is similar to [get_args t] but it also returns the length + of the list of arguments. *) +and get_args_len : term -> term * term list * int = fun t -> + let rec get_args_len acc len t = + match unfold t with + | Appl(t, u) -> get_args_len (u::acc) (len + 1) t + | t -> (t, acc, len) + in + get_args_len [] 0 t + +(** [is_symb s t] tests whether [t] is of the form [Symb(s)]. *) +and is_symb : sym -> term -> bool = fun s t -> + match unfold t with Symb(r) -> r == s | _ -> false + +(* We make the equality of terms modulo commutative and + associative-commutative symbols syntactic by always ordering arguments in + increasing order and by putting them in a comb form. + + The term [t1 + t2 + t3] is represented by the left comb [(t1 + t2) + t3] if + + is left associative and [t1 + (t2 + t3)] if + is right associative. *) + +(** [left_aliens s t] returns the list of the biggest subterms of [t] not + headed by [s], assuming that [s] is left associative and [t] is in + canonical form. This is the reverse of [mk_left_comb]. *) +and left_aliens : sym -> term -> term list = fun s -> + let rec aliens acc = function + | [] -> acc + | u::us -> + let h, ts = get_args u in + if is_symb s h then + match ts with + | t1 :: t2 :: _ -> aliens (t2 :: acc) (t1 :: us) + | _ -> aliens (u :: acc) us + else aliens (u :: acc) us + in fun t -> aliens [] [t] + +(** [right_aliens s t] returns the list of the biggest subterms of [t] not + headed by [s], assuming that [s] is right associative and [t] is in + canonical form. This is the reverse of [mk_right_comb]. *) +and right_aliens : sym -> term -> term list = fun s -> + let rec aliens acc = function + | [] -> acc + | u::us -> + let h, ts = get_args u in + if is_symb s h then + match ts with + | t1 :: t2 :: _ -> aliens (t1 :: acc) (t2 :: us) + | _ -> aliens (u :: acc) us + else aliens (u :: acc) us + in fun t -> let r = aliens [] [t] in + if Logger.log_enabled () then + log_term "right_aliens %a %a = %a" sym s term t (D.list term) r; + r + +(** [mk_Appl t u] puts the application of [t] to [u] in canonical form wrt C + or AC symbols. *) +and mk_Appl : term * term -> term = fun (t, u) -> + (* if Logger.log_enabled () then + log_term "mk_Appl(%a, %a)" term t term u; + let r = *) + match get_args t with + | Symb s, [t1] -> + begin + match s.sym_prop with + | Commu when cmp t1 u > 0 -> mk_bin s u t1 + | AC true -> (* left associative symbol *) + let ts = left_aliens s t1 and us = left_aliens s u in + begin + match List.sort cmp (ts @ us) with + | v::vs -> mk_left_comb s v vs + | _ -> assert false + end + | AC false -> (* right associative symbol *) + let ts = right_aliens s t1 and us = right_aliens s u in + let vs, v = List.split_last (List.sort cmp (ts @ us)) + in mk_right_comb s vs v + | _ -> Appl (t, u) + end + | _ -> Appl (t, u) + (* in + if Logger.log_enabled () then + log_term "mk_Appl(%a, %a) = %a" term t term u term r; + r *) + +(* unit test *) +let _ = + let s = create_sym [] Privat (AC true) Eager false (Pos.none "+") Kind [] in + let t1 = Vari (new_var "x1") in + let t2 = Vari (new_var "x2") in + let t3 = Vari (new_var "x3") in + let left = mk_bin s (mk_bin s t1 t2) t3 in + let right = mk_bin s t1 (mk_bin s t2 t3) in + let eq = eq_of_cmp cmp in + assert (eq (mk_left_comb s t1 [t2; t3]) left); + assert (eq (mk_right_comb s [t1; t2] t3) right); + let eq = eq_of_cmp (List.cmp cmp) in + assert (eq (left_aliens s left) [t1; t2; t3]); + assert (eq (right_aliens s right) [t3; t2; t1]) + +(** [is_abst t] returns [true] iff [t] is of the form [Abst(_)]. *) +let is_abst : term -> bool = fun t -> + match unfold t with Abst(_) -> true | _ -> false + +(** [is_prod t] returns [true] iff [t] is of the form [Prod(_)]. *) +let is_prod : term -> bool = fun t -> + match unfold t with Prod(_) -> true | _ -> false (** [subst b v] substitutes the variable bound by [b] with the value [v]. *) let subst : binder -> term -> term = fun (_,t) v -> @@ -271,7 +511,7 @@ let subst : binder -> term -> term = fun (_,t) v -> log_term "subst [%d≔%a] %a" i term v term t;*) match unfold t with | Db k -> if k = i then lift (i-1) v else t - | Appl(a,b) -> (*FIXME: mk_Appl*) Appl(subst i a, subst i b) + | Appl(a,b) -> mk_Appl(subst i a, subst i b) | Abst(a,(n,u)) -> Abst(subst i a, (n, subst (i+1) u)) | Prod(a,(n,u)) -> Prod(subst i a, (n ,subst (i+1) u)) | LLet(a,t,(n,u)) -> LLet(subst i a, subst i t, (n, subst (i+1) u)) @@ -284,13 +524,6 @@ let subst : binder -> term -> term = fun (_,t) v -> log_term "subst %a [%a] = %a" term t term v term r; r -(** [new_var name] creates a new unique variable of name [name]. *) -let new_var : string -> var = - let open Stdlib in let n = ref 0 in fun name -> incr n; !n, name - -(** [name_of x] returns the name of variable [x]. *) -let name_of : var -> string = fun (_i,n) -> n (*^ string_of_int i*) - (** [unbind b] substitutes the binder [b] using a fresh variable. The variable and the result of the substitution are returned. Note that the name of the fresh variable is based on that of the binder. *) @@ -311,13 +544,15 @@ let unmbind : mbinder -> var array * term = fun ((names,_) as b) -> let xs = Array.init (Array.length names) (fun i -> new_var names.(i)) in xs, msubst b (Array.map (fun x -> Vari x) xs) -(** [bind_var x b] binds the variable [x] in [b], producing a boxed binder. *) +(** [bind_var x t] binds the variable [x] in [t], producing a binder. *) let bind_var : var -> term -> binder = fun ((_,n) as x) -> let rec bind i t = (*if Logger.log_enabled() then log_term "bind_var %d %a" i term t;*) match unfold t with | Vari y when y == x -> Db i | Appl(a,b) -> Appl(bind i a, bind i b) + (* No need to call mk_Appl here as we only replace free variables by de + Bruijn indices. *) | Abst(a,(n,u)) -> Abst(bind i a, (n, bind (i+1) u)) | Prod(a,(n,u)) -> Prod(bind i a, (n, bind (i+1) u)) | LLet(a,t,(n,u)) -> LLet(bind i a, bind i t, (n, bind (i+1) u)) @@ -330,7 +565,7 @@ let bind_var : var -> term -> binder = fun ((_,n) as x) -> log_term "bind_var %a %a = %a" var x term t term b; n, b -(** [bind_mvar xs b] binds the variables of [xs] in [b] to get a boxed binder. +(** [bind_mvar xs t] binds the variables of [xs] in [t] to get a binder. It is the equivalent of [bind_var] for multiple variables. *) let bind_mvar : var array -> term -> mbinder = fun xs t -> let n = Array.length xs in @@ -346,6 +581,8 @@ let bind_mvar : var array -> term -> mbinder = fun xs t -> | Vari (key,_) -> (match IntMap.find_opt key !map with Some k -> Db (i+k) | None -> t) | Appl(a,b) -> Appl(bind i a, bind i b) + (* No need to call mk_Appl here as we only replace free variables by de + Bruijn indices. *) | Abst(a,(n,u)) -> Abst(bind i a, (n, bind (i+1) u)) | Prod(a,(n,u)) -> Prod(bind i a, (n, bind (i+1) u)) | LLet(a,t,(n,u)) -> LLet(bind i a, bind i t, (n, bind (i+1) u)) @@ -358,14 +595,6 @@ let bind_mvar : var array -> term -> mbinder = fun xs t -> log_term "bind_mvar %a %a = %a" (D.array var) xs term t term b; Array.map name_of xs, b -(** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to - compare variables using [Pervasive.compare]. *) -let compare_vars : var -> var -> int = fun (i,_) (j,_) -> Stdlib.compare i j - -(** [eq_vars x y] safely computes the equality of [x] and [y]. Note that it is - unsafe to compare variables with the polymorphic equality function. *) -let eq_vars : var -> var -> bool = fun x y -> compare_vars x y = 0 - (** [binder_occur b] tests whether the bound variable occurs in [b]. *) let binder_occur : binder -> bool = fun (_,t) -> let rec check i t = @@ -390,9 +619,6 @@ let binder_occur : binder -> bool = fun (_,t) -> bound variable does not occur). *) let binder_constant : binder -> bool = fun b -> not (binder_occur b) -(** [mbinder_arity b] gives the arity of the [mbinder]. *) -let mbinder_arity : mbinder -> int = fun (names,_) -> Array.length names - (** [is_closed t] checks whether [t] is closed. *) let is_closed : term -> bool = let rec check t = @@ -425,165 +651,6 @@ let occur : var -> term -> bool = fun x -> let occur_mbinder : var -> mbinder -> bool = fun x (_,t) -> occur x t -(** Printing functions for debug. *) -module Raw = struct - let sym = sym - let term = term -end - -(** Minimize [impl] to enforce our invariant (see {!type:Terms.sym}). *) -let minimize_impl : bool list -> bool list = - let rec rem_false l = match l with false::l -> rem_false l | _ -> l in - fun l -> List.rev (rem_false (List.rev l)) - -(** Typing context associating a [ variable to a type and possibly a - definition. The typing environment [x1:A1,..,xn:An] is represented by the - list [xn:An;..;x1:A1] in reverse order (last added variable comes - first). *) -type ctxt = (var * term * term option) list - -(** Type of unification constraints. *) -type constr = ctxt * term * term - -(** Sets and maps of term variables. *) -module Var = struct - type t = var - let compare = compare_vars -end - -module VarSet = Set.Make(Var) -module VarMap = Map.Make(Var) - -(** [new_var s] creates a new [var] of name [s]. *) -let new_var : string -> var = new_var - -(** [new_var_ind s i] creates a new [var] of name [s ^ string_of_int i]. *) -let new_var_ind : string -> int -> var = fun s i -> - new_var (Escape.add_prefix s (string_of_int i)) - -(** Sets and maps of symbols. *) -module Sym = struct - type t = sym - let compare s1 s2 = - if s1 == s2 then 0 else - match Stdlib.compare s1.sym_name s2.sym_name with - | 0 -> Stdlib.compare s1.sym_path s2.sym_path - | n -> n -end - -module SymSet = Set.Make(Sym) -module SymMap = Map.Make(Sym) - -(** Sets and maps of metavariables. *) -module Meta = struct - type t = meta - let compare m1 m2 = m2.meta_key - m1.meta_key -end - -module MetaSet = Set.Make(Meta) -module MetaMap = Map.Make(Meta) - -(** Representation of unification problems. *) -type problem_aux = - { to_solve : constr list - (** List of unification problems to solve. *) - ; unsolved : constr list - (** List of unification problems that could not be solved. *) - ; recompute : bool - (** Indicates whether unsolved problems should be rechecked. *) - ; metas : MetaSet.t - (** Set of unsolved metas. *) } - -type problem = problem_aux ref - -(** Create a new empty problem. *) -let new_problem : unit -> problem = fun () -> - ref {to_solve = []; unsolved = []; recompute = false; metas = MetaSet.empty} - -(** [create_sym path expo prop opaq name typ impl] creates a new symbol with - path [path], exposition [expo], property [prop], opacity [opaq], matching - strategy [mstrat], name [name.elt], type [typ], implicit arguments [impl], - position [name.pos], no definition and no rules. *) -let create_sym : Path.t -> expo -> prop -> match_strat -> bool -> - Pos.strloc -> term -> bool list -> sym = - fun sym_path sym_expo sym_prop sym_mstrat sym_opaq - { elt = sym_name; pos = sym_pos } typ sym_impl -> - {sym_path; sym_name; sym_type = ref typ; sym_impl; sym_def = ref None; - sym_opaq; sym_rules = ref []; sym_dtree = ref Tree_type.empty_dtree; - sym_mstrat; sym_prop; sym_expo; sym_pos } - -(** [is_constant s] tells whether [s] is a constant. *) -let is_constant : sym -> bool = fun s -> s.sym_prop = Const - -(** [is_injective s] tells whether [s] is injective, which is in partiular the - case if [s] is constant. *) -let is_injective : sym -> bool = fun s -> - match s.sym_prop with Const | Injec -> true | _ -> false - -(** [is_private s] tells whether the symbol [s] is private. *) -let is_private : sym -> bool = fun s -> s.sym_expo = Privat - -(** [is_modulo s] tells whether the symbol [s] is modulo some equations. *) -let is_modulo : sym -> bool = fun s -> - match s.sym_prop with Assoc _ | Commu | AC _ -> true | _ -> false - -(** [is_abst t] returns [true] iff [t] is of the form [Abst(_)]. *) -let is_abst : term -> bool = fun t -> - match unfold t with Abst(_) -> true | _ -> false - -(** [is_prod t] returns [true] iff [t] is of the form [Prod(_)]. *) -let is_prod : term -> bool = fun t -> - match unfold t with Prod(_) -> true | _ -> false - -(** [is_unset m] returns [true] if [m] is not instantiated. *) -let is_unset : meta -> bool = fun m -> !(m.meta_value) = None - -(** [is_symb s t] tests whether [t] is of the form [Symb(s)]. *) -let is_symb : sym -> term -> bool = fun s t -> - match unfold t with Symb(r) -> r == s | _ -> false - -(** Total order on terms. *) -let rec cmp : term cmp = fun t t' -> - match unfold t, unfold t' with - | Vari x, Vari x' -> compare_vars x x' - | Type, Type - | Kind, Kind - | Wild, Wild -> 0 - | Symb s, Symb s' -> Sym.compare s s' - | Prod(t,(_,u)), Prod(t',(_,u')) - | Abst(t,(_,u)), Abst(t',(_,u')) -> lex cmp cmp (t,u) (t',u') - | Appl(t,u), Appl(t',u') -> lex cmp cmp (u,t) (u',t') - | Meta(m,ts), Meta(m',ts') -> - lex Meta.compare (Array.cmp cmp) (m,ts) (m',ts') - | Patt(i,s,ts), Patt(i',s',ts') -> - lex3 Stdlib.compare Stdlib.compare (Array.cmp cmp) - (i,s,ts) (i',s',ts') - | Db i, Db j -> Stdlib.compare i j - | TRef r, TRef r' -> Stdlib.compare r r' - | LLet(a,t,(_,u)), LLet(a',t',(_,u')) -> - lex3 cmp cmp cmp (a,t,u) (a',t',u') - | t, t' -> cmp_tag t t' - -(** [get_args t] decomposes the {!type:term} [t] into a pair [(h,args)], where - [h] is the head term of [t] and [args] is the list of arguments applied to - [h] in [t]. The returned [h] cannot be an [Appl] node. *) -let get_args : term -> term * term list = fun t -> - let rec get_args t acc = - match unfold t with - | Appl(t,u) -> get_args t (u::acc) - | t -> t, acc - in get_args t [] - -(** [get_args_len t] is similar to [get_args t] but it also returns the length - of the list of arguments. *) -let get_args_len : term -> term * term list * int = fun t -> - let rec get_args_len acc len t = - match unfold t with - | Appl(t, u) -> get_args_len (u::acc) (len + 1) t - | t -> (t, acc, len) - in - get_args_len [] 0 t - (** Construction functions of the private type [term]. They ensure some invariants: @@ -594,8 +661,7 @@ let get_args_len : term -> term * term list * int = fun t -> application is built as a left or right comb depending on the associativity of the symbol, and arguments are ordered in increasing order wrt [cmp]. -- In [LLet(_,_,b)], [binder_constant b = false] (useless let's are - erased). *) +- In [LLet(_,_,b)], [binder_constant b = false] (useless let's are erased). *) let mk_Vari x = Vari x let mk_Type = Type let mk_Kind = Kind @@ -608,109 +674,7 @@ let mk_Patt (i,s,ts) = Patt (i,s,ts) let mk_Wild = Wild let mk_Plac b = Plac b let mk_TRef x = TRef x - -let mk_LLet (a,t,u) = - if binder_constant u then subst u Kind else LLet (a,t,u) - -(* We make the equality of terms modulo commutative and - associative-commutative symbols syntactic by always ordering arguments in - increasing order and by putting them in a comb form. - - The term [t1 + t2 + t3] is represented by the left comb [(t1 + t2) + t3] if - + is left associative and [t1 + (t2 + t3)] if + is right associative. *) - -let mk_bin s t1 t2 = Appl(Appl(Symb s, t1), t2) - -(** [mk_left_comb s t ts] builds a left comb of applications of [s] from - [t::ts] so that [mk_left_comb s t1 [t2; t3] = mk_bin s (mk_bin s t1 t2) - t3]. *) -let mk_left_comb : sym -> term -> term list -> term = fun s -> - List.fold_left (mk_bin s) - -(** [mk_right_comb s ts t] builds a right comb of applications of [s] to - [ts@[p]] so that [mk_right_comb s [t1; t2] t3 = mk_bin s t1 (mk_bin s t2 - t3)]. *) -let mk_right_comb : sym -> term list -> term -> term = fun s -> - List.fold_right (mk_bin s) - -(** [left_aliens s t] returns the list of the biggest subterms of [t] not - headed by [s], assuming that [s] is left associative and [t] is in - canonical form. This is the reverse of [mk_left_comb]. *) -let left_aliens : sym -> term -> term list = fun s -> - let rec aliens acc = function - | [] -> acc - | u::us -> - let h, ts = get_args u in - if is_symb s h then - match ts with - | t1 :: t2 :: _ -> aliens (t2 :: acc) (t1 :: us) - | _ -> aliens (u :: acc) us - else aliens (u :: acc) us - in fun t -> aliens [] [t] - -(** [right_aliens s t] returns the list of the biggest subterms of [t] not - headed by [s], assuming that [s] is right associative and [t] is in - canonical form. This is the reverse of [mk_right_comb]. *) -let right_aliens : sym -> term -> term list = fun s -> - let rec aliens acc = function - | [] -> acc - | u::us -> - let h, ts = get_args u in - if is_symb s h then - match ts with - | t1 :: t2 :: _ -> aliens (t1 :: acc) (t2 :: us) - | _ -> aliens (u :: acc) us - else aliens (u :: acc) us - in fun t -> let r = aliens [] [t] in - if Logger.log_enabled () then - log_term "right_aliens %a %a = %a" - Raw.sym s Raw.term t (D.list Raw.term) r; - r - -(* unit test *) -let _ = - let s = create_sym [] Privat (AC true) Eager false (Pos.none "+") Kind [] in - let t1 = Vari (new_var "x1") in - let t2 = Vari (new_var "x2") in - let t3 = Vari (new_var "x3") in - let left = mk_bin s (mk_bin s t1 t2) t3 in - let right = mk_bin s t1 (mk_bin s t2 t3) in - let eq = eq_of_cmp cmp in - assert (eq (mk_left_comb s t1 [t2; t3]) left); - assert (eq (mk_right_comb s [t1; t2] t3) right); - let eq = eq_of_cmp (List.cmp cmp) in - assert (eq (left_aliens s left) [t1; t2; t3]); - assert (eq (right_aliens s right) [t3; t2; t1]) - -(** [mk_Appl t u] puts the application of [t] to [u] in canonical form wrt C - or AC symbols. *) -let mk_Appl : term * term -> term = fun (t, u) -> - (* if Logger.log_enabled () then - log_term "mk_Appl(%a, %a)" term t term u; - let r = *) - match get_args t with - | Symb s, [t1] -> - begin - match s.sym_prop with - | Commu when cmp t1 u > 0 -> mk_bin s u t1 - | AC true -> (* left associative symbol *) - let ts = left_aliens s t1 and us = left_aliens s u in - begin - match List.sort cmp (ts @ us) with - | v::vs -> mk_left_comb s v vs - | _ -> assert false - end - | AC false -> (* right associative symbol *) - let ts = right_aliens s t1 and us = right_aliens s u in - let vs, v = List.split_last (List.sort cmp (ts @ us)) - in mk_right_comb s vs v - | _ -> Appl (t, u) - end - | _ -> Appl (t, u) - (* in - if Logger.log_enabled () then - log_term "mk_Appl(%a, %a) = %a" term t term u term r; - r *) +let mk_LLet (a,t,u) = if binder_constant u then subst u Kind else LLet (a,t,u) (** mk_Appl_not_canonical t u] builds the non-canonical (wrt. C and AC symbols) application of [t] to [u]. WARNING: to use only in Sign.link. *) @@ -720,27 +684,18 @@ let mk_Appl_not_canonical : term * term -> term = fun (t, u) -> Appl(t, u) arguments [args]. When [args] is empty, the returned value is (physically) equal to [t]. *) let add_args : term -> term list -> term = fun t ts -> - List.fold_left (fun t u -> mk_Appl(t,u)) t ts + match get_args t with + | Symb s, _ when is_modulo s -> + List.fold_left (fun t u -> mk_Appl(t,u)) t ts + | _ -> List.fold_left (fun t u -> Appl(t,u)) t ts (** [add_args_map f t ts] is equivalent to [add_args t (List.map f ts)] but more efficient. *) let add_args_map : term -> (term -> term) -> term list -> term = fun t f ts -> - List.fold_left (fun t u -> mk_Appl(t, f u)) t ts - -(** Positions in terms in reverse order. The i-th argument of a constructor - has position i-1. *) -type subterm_pos = int list - -let subterm_pos : subterm_pos pp = fun ppf l -> D.(list int) ppf (List.rev l) - -(** Type of critical pair positions (pos,l,r,p,l_p). *) -type cp_pos = Pos.popt * term * term * subterm_pos * term - -(** Type of a symbol and a rule. *) -type sym_rule = sym * rule - -let lhs : sym_rule -> term = fun (s, r) -> add_args (mk_Symb s) r.lhs -let rhs : sym_rule -> term = fun (_, r) -> r.rhs + match get_args t with + | Symb s, _ when is_modulo s -> + List.fold_left (fun t u -> mk_Appl(t, f u)) t ts + | _ -> List.fold_left (fun t u -> Appl(t, f u)) t ts (** Patt substitution. *) let subst_patt : mbinder option array -> term -> term = fun env -> @@ -785,3 +740,50 @@ let rec cleanup : term -> term = fun t -> | Type | Kind | Symb _ -> t + +(** Type of a symbol and a rule. *) +type sym_rule = sym * rule + +let lhs : sym_rule -> term = fun (s, r) -> add_args (mk_Symb s) r.lhs +let rhs : sym_rule -> term = fun (_, r) -> r.rhs + +(** Positions in terms in reverse order. The i-th argument of a constructor + has position i-1. *) +type subterm_pos = int list + +let subterm_pos : subterm_pos pp = fun ppf l -> D.(list int) ppf (List.rev l) + +(** Type of critical pair positions (pos,l,r,p,l_p). *) +type cp_pos = Pos.popt * term * term * subterm_pos * term + +(** Typing context associating a [ variable to a type and possibly a + definition. The typing environment [x1:A1,..,xn:An] is represented by the + list [xn:An;..;x1:A1] in reverse order (last added variable comes + first). *) +type ctxt = (var * term * term option) list + +(** Type of unification constraints. *) +type constr = ctxt * term * term + +(** Representation of unification problems. *) +type problem_aux = + { to_solve : constr list + (** List of unification problems to solve. *) + ; unsolved : constr list + (** List of unification problems that could not be solved. *) + ; recompute : bool + (** Indicates whether unsolved problems should be rechecked. *) + ; metas : MetaSet.t + (** Set of unsolved metas. *) } + +type problem = problem_aux ref + +(** Create a new empty problem. *) +let new_problem : unit -> problem = fun () -> + ref {to_solve = []; unsolved = []; recompute = false; metas = MetaSet.empty} + +(** Printing functions for debug. *) +module Raw = struct + let sym = sym let _ = sym + let term = term let _ = term +end diff --git a/src/core/term.mli b/src/core/term.mli index 426a1d8e0..995f06dbd 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -36,11 +36,15 @@ type prop = | Assoc of bool (** Associative left if [true], right if [false]. *) | AC of bool (** Associative and commutative. *) -type binder +(** Type for free variables. *) +type var +(** Type for binders. *) +type binder type mbinder -type var +(** [mbinder_arity b] gives the arity of the [mbinder]. *) +val mbinder_arity : mbinder -> int (** Representation of a term (or types) in a general sense. Values of the type are also used, for example, in the representation of patterns or rewriting @@ -197,40 +201,33 @@ and sym = ; meta_arity : int (** Arity (environment size). *) ; meta_value : mbinder option ref (** Definition. *) } -(** [subst b v] substitutes the variable bound by [b] with the value [v]. *) -val subst : binder -> term -> term - -(** [msubst b vs] substitutes the variables bound by [b] with the values [vs]. - Note that the length of the [vs] array should match the arity of the - multiple binder [b]. *) -val msubst : mbinder -> term array -> term -val msubst3 : - (mbinder * mbinder * mbinder) -> term array -> term * term * term +(** Minimize [impl] to enforce our invariant (see {!type:Term.sym}). *) +val minimize_impl : bool list -> bool list -(** [name_of x] returns a printable name for variable [x]. *) -val name_of : var -> string +(** [create_sym path expo prop opaq name typ impl] creates a new symbol with + position [pos], path [path], exposition [expo], property [prop], opacity + [opaq], matching strategy [mstrat], name [name.elt], type [typ], implicit + arguments [impl], position [name.pos], no definition and no rules. *) +val create_sym : Path.t -> expo -> prop -> match_strat -> bool -> + Pos.strloc -> term -> bool list -> sym -(** [unbind b] substitutes the binder [b] using a fresh variable. The variable - and the result of the substitution are returned. Note that the name of the - fresh variable is based on that of the binder. *) -val unbind : binder -> var * term +(** [is_constant s] tells whether the symbol is a constant. *) +val is_constant : sym -> bool -(** [unbind2 f g] is similar to [unbind f], but it substitutes two binders [f] - and [g] at once using the same fresh variable. The name of the variable is - based on that of the binder [f]. *) -val unbind2 : binder -> binder -> var * term * term +(** [is_injective s] tells whether [s] is injective, which is in partiular the + case if [s] is constant. *) +val is_injective : sym -> bool -(** [unmbind b] substitutes the multiple binder [b] with fresh variables. This - function is analogous to [unbind] for binders. Note that the names used to - create the fresh variables are based on those of the multiple binder. *) -val unmbind : mbinder -> var array * term +(** [is_private s] tells whether the symbol [s] is private. *) +val is_private : sym -> bool -(** [bind_var x b] binds the variable [x] in [b], producing a boxed binder. *) -val bind_var : var -> term -> binder +(** [is_modulo s] tells whether the symbol [s] is modulo some equations. *) +val is_modulo : sym -> bool -(** [bind_mvar xs b] binds the variables of [xs] in [b] to get a boxed binder. - It is the equivalent of [bind_var] for multiple variables. *) -val bind_mvar : var array -> term -> mbinder +(** Sets and maps of symbols. *) +module Sym : Map.OrderedType with type t = sym +module SymSet : Set.S with type elt = sym +module SymMap : Map.S with type key = sym (** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to compare variables using [Pervasive.compare]. *) @@ -240,99 +237,28 @@ val compare_vars : var -> var -> int unsafe to compare variables with the polymorphic equality function. *) val eq_vars : var -> var -> bool -(** [binder_occur b] tests whether the bound variable occurs in [b]. *) -val binder_occur : binder -> bool - -(** [binder_constant b] tests whether the [binder] [b] is constant (i.e., its - bound variable does not occur). *) -val binder_constant : binder -> bool - -(** [mbinder_arity b] gives the arity of the [mbinder]. *) -val mbinder_arity : mbinder -> int - -(** [is_closed b] checks whether the [box] [b] is closed. *) -val is_closed : term -> bool -val is_closed_mbinder : mbinder -> bool - -(** [occur x b] tells whether variable [x] occurs in the [box] [b]. *) -val occur : var -> term -> bool -val occur_mbinder : var -> mbinder -> bool - -(** Minimize [impl] to enforce our invariant (see {!type:Term.sym}). *) -val minimize_impl : bool list -> bool list - -(** Basic printing function (for debug). *) -module Raw : sig - val term : term pp -end - -(** Typing context associating a [ variable to a type and possibly a - definition. The typing environment [x1:A1,..,xn:An] is represented by the - list [xn:An;..;x1:A1] in reverse order (last added variable comes - first). *) -type ctxt = (var * term * term option) list - -(** Type of unification constraints. *) -type constr = ctxt * term * term - -(** Sets and maps of term variables. *) -module Var : Map.OrderedType with type t = var - -module VarSet : Set.S with type elt = var -module VarMap : Map.S with type key = var - (** [new_var s] creates a new [var] of name [s]. *) val new_var : string -> var (** [new_var_ind s i] creates a new [var] of name [s ^ string_of_int i]. *) val new_var_ind : string -> int -> var -(** Sets and maps of symbols. *) -module Sym : Map.OrderedType with type t = sym -module SymSet : Set.S with type elt = sym -module SymMap : Map.S with type key = sym - -(** [create_sym path expo prop opaq name typ impl] creates a new symbol with - position [pos], path [path], exposition [expo], property [prop], opacity - [opaq], matching strategy [mstrat], name [name.elt], type [typ], implicit - arguments [impl], position [name.pos], no definition and no rules. *) -val create_sym : Path.t -> expo -> prop -> match_strat -> bool -> - Pos.strloc -> term -> bool list -> sym - -(** [is_constant s] tells whether the symbol is a constant. *) -val is_constant : sym -> bool - -(** [is_injective s] tells whether [s] is injective, which is in partiular the - case if [s] is constant. *) -val is_injective : sym -> bool +(** [name_of x] returns the name of the variable [x]. *) +val name_of : var -> string -(** [is_private s] tells whether the symbol [s] is private. *) -val is_private : sym -> bool +(** Sets and maps of term variables. *) +module Var : Map.OrderedType with type t = var +module VarSet : Set.S with type elt = var +module VarMap : Map.S with type key = var -(** [is_modulo s] tells whether the symbol [s] is modulo some equations. *) -val is_modulo : sym -> bool +(** [is_unset m] returns [true] if [m] is not instantiated. *) +val is_unset : meta -> bool (** Sets and maps of metavariables. *) module Meta : Map.OrderedType with type t = meta module MetaSet : Set.S with type elt = Meta.t module MetaMap : Map.S with type key = Meta.t -(** Representation of unification problems. *) -type problem_aux = - { to_solve : constr list - (** List of unification problems to solve. *) - ; unsolved : constr list - (** List of unification problems that could not be solved. *) - ; recompute : bool - (** Indicates whether unsolved problems should be rechecked. *) - ; metas : MetaSet.t - (** Set of unsolved metas. *) } - -type problem = problem_aux ref - -(** Create a new empty problem. *) -val new_problem : unit -> problem - (** [unfold t] repeatedly unfolds the definition of the surface constructor of [t], until a significant {!type:term} constructor is found. The term that is returned cannot be an instantiated metavariable, term environment or @@ -343,18 +269,12 @@ val unfold : term -> term (** {b NOTE} that {!val:unfold} must (almost) always be called before matching over a value of type {!type:term}. *) -(** Total orders terms. *) -val cmp : term cmp - (** [is_abst t] returns [true] iff [t] is of the form [Abst(_)]. *) val is_abst : term -> bool (** [is_prod t] returns [true] iff [t] is of the form [Prod(_)]. *) val is_prod : term -> bool -(** [is_unset m] returns [true] if [m] is not instantiated. *) -val is_unset : meta -> bool - (** [is_symb s t] tests whether [t] is of the form [Symb(s)]. *) val is_symb : sym -> term -> bool @@ -367,6 +287,9 @@ val get_args : term -> term * term list of the list of arguments. *) val get_args_len : term -> term * term list * int +(** Total orders terms. *) +val cmp : term cmp + (** Construction functions of the private type [term]. They ensure some invariants: @@ -407,6 +330,82 @@ val add_args : term -> term list -> term more efficient. *) val add_args_map : term -> (term -> term) -> term list -> term +(** [subst b v] substitutes the variable bound by [b] with the value [v]. *) +val subst : binder -> term -> term + +(** [msubst b vs] substitutes the variables bound by [b] with the values [vs]. + Note that the length of the [vs] array should match the arity of the + multiple binder [b]. *) +val msubst : mbinder -> term array -> term + +(** [unbind b] substitutes the binder [b] using a fresh variable. The variable + and the result of the substitution are returned. Note that the name of the + fresh variable is based on that of the binder. *) +val unbind : binder -> var * term + +(** [unbind2 f g] is similar to [unbind f], but it substitutes two binders [f] + and [g] at once using the same fresh variable. The name of the variable is + based on that of the binder [f]. *) +val unbind2 : binder -> binder -> var * term * term + +(** [unmbind b] substitutes the multiple binder [b] with fresh variables. This + function is analogous to [unbind] for binders. Note that the names used to + create the fresh variables are based on those of the multiple binder. *) +val unmbind : mbinder -> var array * term + +(** [bind_var x b] binds the variable [x] in [b], producing a boxed binder. *) +val bind_var : var -> term -> binder + +(** [bind_mvar xs b] binds the variables of [xs] in [b] to get a boxed binder. + It is the equivalent of [bind_var] for multiple variables. *) +val bind_mvar : var array -> term -> mbinder + +(** [binder_occur b] tests whether the bound variable occurs in [b]. *) +val binder_occur : binder -> bool + +(** [binder_constant b] tests whether the [binder] [b] is constant (i.e., its + bound variable does not occur). *) +val binder_constant : binder -> bool + +(** [is_closed b] checks whether the [box] [b] is closed. *) +val is_closed : term -> bool +val is_closed_mbinder : mbinder -> bool + +(** [occur x b] tells whether variable [x] occurs in the [box] [b]. *) +val occur : var -> term -> bool +val occur_mbinder : var -> mbinder -> bool + +(** Patt substitution. *) +val subst_patt : mbinder option array -> term -> term + +(** [cleanup t] unfold all metas and TRef's in [t]. *) +val cleanup : term -> term + +(** Typing context associating a [ variable to a type and possibly a + definition. The typing environment [x1:A1,..,xn:An] is represented by the + list [xn:An;..;x1:A1] in reverse order (last added variable comes + first). *) +type ctxt = (var * term * term option) list + +(** Type of unification constraints. *) +type constr = ctxt * term * term + +(** Representation of unification problems. *) +type problem_aux = + { to_solve : constr list + (** List of unification problems to solve. *) + ; unsolved : constr list + (** List of unification problems that could not be solved. *) + ; recompute : bool + (** Indicates whether unsolved problems should be rechecked. *) + ; metas : MetaSet.t + (** Set of unsolved metas. *) } + +type problem = problem_aux ref + +(** Create a new empty problem. *) +val new_problem : unit -> problem + (** Positions in terms in reverse order. The i-th argument of a constructor has position i-1. *) type subterm_pos = int list @@ -422,8 +421,7 @@ type sym_rule = sym * rule val lhs : sym_rule -> term val rhs : sym_rule -> term -(** Patt substitution. *) -val subst_patt : mbinder option array -> term -> term - -(** [cleanup t] unfold all metas and TRef's in [t]. *) -val cleanup : term -> term +(** Basic printing function (for debug). *) +module Raw : sig + val term : term pp +end diff --git a/src/handle/rewrite.ml b/src/handle/rewrite.ml index 93234fe32..b4319b967 100644 --- a/src/handle/rewrite.ml +++ b/src/handle/rewrite.ml @@ -335,8 +335,9 @@ let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> (* Bind the variables in this new witness. *) let bound = let bind = bind_mvar vars in bind t, bind l, bind r in + let msubst3 (b1, b2, b3) ts = msubst b1 ts, msubst b2 ts, msubst b3 ts in - (* Extract the term from the goal type (get “u” from “P u”). *) +(* Extract the term from the goal type (get “u” from “P u”). *) let g_term = match get_args g_type with | t, [u] when is_symb cfg.symb_P t -> u From 2decd3e131f6c002c51d1840176004bd0b7119aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 15 Feb 2022 09:09:29 +0100 Subject: [PATCH 20/38] rename mk_Impl into mk_Arro --- src/core/term.ml | 2 +- src/core/term.mli | 2 +- src/handle/command.ml | 2 +- src/handle/inductive.ml | 6 +++--- src/handle/rewrite.ml | 8 ++++---- src/parsing/scope.ml | 2 +- 6 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/core/term.ml b/src/core/term.ml index da08f55d7..dbcb9ee5d 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -667,7 +667,7 @@ let mk_Type = Type let mk_Kind = Kind let mk_Symb x = Symb x let mk_Prod (a,b) = Prod (a,b) -let mk_Impl (a,b) = let x = new_var "_" in Prod(a, bind_var x b) +let mk_Arro (a,b) = let x = new_var "_" in Prod(a, bind_var x b) let mk_Abst (a,b) = Abst (a,b) let mk_Meta (m,ts) = (*assert (m.meta_arity = Array.length ts);*) Meta (m,ts) let mk_Patt (i,s,ts) = Patt (i,s,ts) diff --git a/src/core/term.mli b/src/core/term.mli index 995f06dbd..24954a086 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -307,7 +307,7 @@ val mk_Type : term val mk_Kind : term val mk_Symb : sym -> term val mk_Prod : term * binder -> term -val mk_Impl : term * term -> term +val mk_Arro : term * term -> term val mk_Abst : term * binder -> term val mk_Appl : term * term -> term val mk_Meta : meta * term array -> term diff --git a/src/handle/command.ml b/src/handle/command.ml index 3bec4dfb4..d74d199bd 100644 --- a/src/handle/command.ml +++ b/src/handle/command.ml @@ -32,7 +32,7 @@ let _ = with Not_found -> mk_Meta (LibMeta.fresh (new_problem()) mk_Type 0, [||]) in - mk_Impl (typ_0, typ_0) + mk_Arro (typ_0, typ_0) in register "+1" expected_succ_type diff --git a/src/handle/inductive.ml b/src/handle/inductive.ml index 1eac47473..00ab1312c 100644 --- a/src/handle/inductive.ml +++ b/src/handle/inductive.ml @@ -117,7 +117,7 @@ let create_ind_pred_map : let ind_var = new_var_ind p_str i in (* predicate type *) let codom ts = - mk_Impl (add_args (mk_Symb ind_sym) ts, mk_Symb c.symb_Prop) in + mk_Arro (add_args (mk_Symb ind_sym) ts, mk_Symb c.symb_Prop) in let a = snd (Env.of_prod_using [] vs !(ind_sym.sym_type)) in let ind_type = ind_typ_with_codom pos ind_sym env codom x_str a in (* predicate conclusion *) @@ -255,7 +255,7 @@ let gen_rec_types : in let acc_rec_dom _ _ _ = () in let rec_dom t x v next = - mk_Prod (t, bind_var x (mk_Impl (v, next))) + mk_Prod (t, bind_var x (mk_Arro (v, next))) in let acc_nonrec_dom _ _ = () in let nonrec_dom t x next = mk_Prod (t, bind_var x next) in @@ -270,7 +270,7 @@ let gen_rec_types : (* Generates an induction principle for each type. *) let gen_rec_type (_, d) = let add_clause_cons ind_sym cons_sym t = - mk_Impl (case_of ind_sym cons_sym, t) + mk_Arro (case_of ind_sym cons_sym, t) in let add_clauses_ind (ind_sym, cons_sym_list) t = List.fold_right (add_clause_cons ind_sym) cons_sym_list t diff --git a/src/handle/rewrite.ml b/src/handle/rewrite.ml index b4319b967..8b2bce229 100644 --- a/src/handle/rewrite.ml +++ b/src/handle/rewrite.ml @@ -59,7 +59,7 @@ let _ = let term_Prop = get_domain_of_type symb_P in let a = new_var "a" in let term_T_a = mk_Appl (mk_Symb symb_T, mk_Vari a) in - let impls = mk_Impl (term_T_a, mk_Impl (term_T_a, term_Prop)) in + let impls = mk_Arro (term_T_a, mk_Arro (term_T_a, term_Prop)) in mk_Prod (term_U, bind_var a impls) in register_builtin "eq" expected_eq_type; @@ -96,11 +96,11 @@ let _ = let term_T_a = mk_Appl (term_T, mk_Vari a) in let term_P_p_x = mk_Appl (term_P, mk_Appl (mk_Vari p, mk_Vari x)) in let term_P_p_y = mk_Appl (term_P, mk_Appl (mk_Vari p, mk_Vari y)) in - let impl = mk_Impl (term_P_p_y, term_P_p_x) in + let impl = mk_Arro (term_P_p_y, term_P_p_x) in let prod = - mk_Prod (mk_Impl (term_T_a, term_Prop), bind_var p impl) in + mk_Prod (mk_Arro (term_T_a, term_Prop), bind_var p impl) in let eq = add_args term_eq [mk_Vari a; mk_Vari x; mk_Vari y] in - let impl = mk_Impl (mk_Appl(term_P, eq), prod) in + let impl = mk_Arro (mk_Appl(term_P, eq), prod) in let prod = mk_Prod (term_T_a, bind_var y impl) in let prod = mk_Prod (term_T_a, bind_var x prod) in mk_Prod (term_U, bind_var a prod) diff --git a/src/parsing/scope.ml b/src/parsing/scope.ml index e5a747f68..3e7d91b5f 100644 --- a/src/parsing/scope.ml +++ b/src/parsing/scope.ml @@ -454,7 +454,7 @@ and scope_head : | (P_Arro(_,_), M_Patt) -> fatal t.pos "Arrows are not allowed in patterns." | (P_Arro(a,b), _) -> - mk_Impl (scope ~typ:true (k+1) md ss env a, + mk_Arro (scope ~typ:true (k+1) md ss env a, scope ~typ:true (k+1) md ss env b) | (P_Abst(_,_), M_Patt) -> From 6b5e9803a9d5d0d64cbfcd299977c72ff3fb86c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 15 Feb 2022 11:01:33 +0100 Subject: [PATCH 21/38] scope: remove useless call to is_closed --- src/parsing/scope.ml | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/parsing/scope.ml b/src/parsing/scope.ml index 3e7d91b5f..22d4c1858 100644 --- a/src/parsing/scope.ml +++ b/src/parsing/scope.ml @@ -13,7 +13,7 @@ let term = Raw.term let log_scop = Logger.make 'o' "scop" "term scoping" let log_scop = log_scop.pp -(** [find_qid prt prv ss env qid] returns a boxed term corresponding to a +(** [find_qid prt prv ss env qid] returns a term corresponding to a variable of the environment [env] (or to a symbol) which name corresponds to [qid]. In the case where the module path [fst qid.elt] is empty, we first search for the name [snd qid.elt] in the environment, and if it is @@ -217,12 +217,7 @@ and scope_parsed : match p_head.elt with | P_Wrap e -> get_impl e | P_Iden (_, false) -> - (* We avoid unboxing if [h] is not closed (and hence not a symbol). *) - if is_closed h then - match h with - | Symb s -> s.sym_impl - | _ -> [] - else [] + begin match h with Symb s -> s.sym_impl | _ -> [] end | P_Abst (params_list, t) -> Syntax.get_impl_params_list params_list @ get_impl t | _ -> [] From 6fff025bf20eb7cdd78d6758d711fdf9d843767b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 15 Feb 2022 11:01:46 +0100 Subject: [PATCH 22/38] fix comment --- src/core/infer.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/core/infer.ml b/src/core/infer.ml index 024087e06..6df7f3ced 100644 --- a/src/core/infer.ml +++ b/src/core/infer.ml @@ -38,9 +38,7 @@ let coerce pb c t a b = unif pb c a b; (t, false) (** NOTE: functions {!val:type_enforce}, {!val:force} and {!val:infer} return a boolean which is true iff the typechecked term has been - modified. It allows to bypass reconstruction of some terms (which - call [lift |> bind_var x |> unbox]). It reduces the type checking time of - Holide by 21%. *) + modified. It allows to bypass reconstruction of some terms. *) (** [type_enforce pb c a] returns a tuple [(a',s)] where [a'] is refined term [a] and [s] is a sort (Type or Kind) such that [a'] is of type From 18e5cd5e9fcfb9863ae3eed6d0381e067fe3bd23 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 15 Feb 2022 11:01:59 +0100 Subject: [PATCH 23/38] optimize link/unlink/reset by exposing binder --- src/core/sign.ml | 32 +++++++++++++++----------------- src/core/term.ml | 15 +++++++-------- src/core/term.mli | 18 +++++++++--------- 3 files changed, 31 insertions(+), 34 deletions(-) diff --git a/src/core/sign.ml b/src/core/sign.ml index ba8176f42..c92ee64b6 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -91,22 +91,20 @@ let link : t -> unit = fun sign -> let link_term mk_Appl = let rec link_term t = match unfold t with - | Vari _ + | Db _ | Type | Kind -> t | Symb s -> mk_Symb(link_symb s) - | Prod(a,b) -> mk_Prod(link_term a, link_binder b) - | Abst(a,b) -> mk_Abst(link_term a, link_binder b) - | LLet(a,t,b) -> mk_LLet(link_term a, link_term t, link_binder b) + | Prod(a,(n,b)) -> mk_Prod(link_term a, (n, link_term b)) + | Abst(a,(n,b)) -> mk_Abst(link_term a, (n, link_term b)) + | LLet(a,t,(n,b)) -> mk_LLet(link_term a, link_term t, (n, link_term b)) | Appl(a,b) -> mk_Appl(link_term a, link_term b) | Patt(i,n,ts)-> mk_Patt(i, n, Array.map link_term ts) - | Db _ -> assert false + | Vari _ -> assert false | Meta _ -> assert false | Plac _ -> assert false | Wild -> assert false | TRef _ -> assert false - and link_binder b = - let (x,t) = unbind b in bind_var x (link_term t) in link_term in let link_lhs = link_term mk_Appl_not_canonical @@ -165,20 +163,20 @@ let unlink : t -> unit = fun sign -> let rec unlink_term t = match unfold t with | Symb s -> unlink_sym s - | Prod(a,b) - | Abst(a,b) -> unlink_term a; unlink_binder b - | LLet(a,t,b) -> unlink_term a; unlink_term t; unlink_binder b + | Prod(a,(_,b)) + | Abst(a,(_,b)) -> unlink_term a; unlink_term b + | LLet(a,t,(_,b)) -> unlink_term a; unlink_term t; unlink_term b | Appl(a,b) -> unlink_term a; unlink_term b | Meta _ -> assert false | Plac _ -> assert false | Wild -> assert false | TRef _ -> assert false - | Db _ -> assert false + | Vari _ -> assert false | Patt _ - | Vari _ + | Db _ | Type | Kind -> () - and unlink_binder b = unlink_term (snd (unbind b)) in + in let unlink_rule r = List.iter unlink_term r.lhs; unlink_term r.rhs @@ -273,9 +271,9 @@ let read : string -> t = fun fname -> | Type | Kind -> () | Symb s -> shallow_reset_sym s - | Prod(a,b) - | Abst(a,b) -> reset_term a; reset_binder b - | LLet(a,t,b) -> reset_term a; reset_term t; reset_binder b + | Prod(a,(_,b)) + | Abst(a,(_,b)) -> reset_term a; reset_term b + | LLet(a,t,(_,b)) -> reset_term a; reset_term t; reset_term b | Appl(a,b) -> reset_term a; reset_term b | Patt(_,_,ts) -> Array.iter reset_term ts | TRef r -> unsafe_reset r; Option.iter reset_term !r @@ -283,7 +281,7 @@ let read : string -> t = fun fname -> | Wild -> assert false | Meta _ -> assert false | Plac _ -> assert false - and reset_binder b = reset_term (snd (unbind b)) in + in let reset_rule r = List.iter reset_term r.lhs; reset_term r.rhs diff --git a/src/core/term.ml b/src/core/term.ml index dbcb9ee5d..ac6cf6b0f 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -61,6 +61,13 @@ type term = | LLet of term * term * binder (** [LLet(a, t, u)] is [let x : a ≔ t in u] (with [x] bound in [u]). *) +(** Type for free variables. *) +and var = int * string + +(** Type for binders. *) +and binder = string * term +and mbinder = string array * term + (** {b NOTE} that a wildcard "_" of the concrete (source code) syntax may have a different representation depending on the context. For instance, the {!constructor:Wild} constructor is only used when matching patterns (e.g., @@ -164,14 +171,6 @@ and meta = ; meta_arity : int (** Arity (environment size). *) ; meta_value : mbinder option ref (** Definition. *) } -(** Type for free variables. *) -and var = int * string - -(** Type for binders. *) -and binder = string * term - -and mbinder = string array * term - (** [mbinder_arity b] gives the arity of the [mbinder]. *) let mbinder_arity : mbinder -> int = fun (names,_) -> Array.length names diff --git a/src/core/term.mli b/src/core/term.mli index 24954a086..3411d5b95 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -39,13 +39,6 @@ type prop = (** Type for free variables. *) type var -(** Type for binders. *) -type binder -type mbinder - -(** [mbinder_arity b] gives the arity of the [mbinder]. *) -val mbinder_arity : mbinder -> int - (** Representation of a term (or types) in a general sense. Values of the type are also used, for example, in the representation of patterns or rewriting rules. Specific constructors are included for such applications, and they @@ -70,6 +63,10 @@ type term = private | LLet of term * term * binder (** [LLet(a, t, u)] is [let x : a ≔ t in u] (with [x] bound in [u]). *) +(** Type for binders. *) +and binder = string * term +and mbinder = string array * term + (** {b NOTE} that a wildcard "_" of the concrete (source code) syntax may have a different representation depending on the context. For instance, the {!constructor:Wild} constructor is only used when matching patterns (e.g., @@ -120,7 +117,7 @@ and sym = LHS (left hand side), which is the pattern that should be matched for the rule to apply, and a RHS (right hand side) giving the action to perform if the rule applies. More explanations are given below. *) - and rule = +and rule = { lhs : term list (** Left hand side (LHS). *) ; rhs : term (** Right hand side (RHS). *) ; arity : int (** Required number of arguments to be applicable. *) @@ -195,12 +192,15 @@ and sym = (i.e., set to a particular term). When a metavariable [m] is instantiated, the suspended substitution is unlocked and terms of the form {!constructor:Meta}[(m,env)] can be unfolded. *) - and meta = +and meta = { meta_key : int (** Unique key. *) ; meta_type : term ref (** Type. *) ; meta_arity : int (** Arity (environment size). *) ; meta_value : mbinder option ref (** Definition. *) } +(** [mbinder_arity b] gives the arity of the [mbinder]. *) +val mbinder_arity : mbinder -> int + (** Minimize [impl] to enforce our invariant (see {!type:Term.sym}). *) val minimize_impl : bool list -> bool list From 4a51e1c8d5034ad1dc46525b31159ae8cf0a7a58 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 15 Feb 2022 13:44:38 +0100 Subject: [PATCH 24/38] remove constraints on bound variable identifiers --- doc/terms.rst | 3 --- src/core/env.ml | 10 ++++++- src/parsing/scope.ml | 63 ++++++-------------------------------------- 3 files changed, 17 insertions(+), 59 deletions(-) diff --git a/doc/terms.rst b/doc/terms.rst index fe1c7060b..c74f56c8e 100644 --- a/doc/terms.rst +++ b/doc/terms.rst @@ -16,9 +16,6 @@ An identifier can be: **Remark:** for any regular identifier ``i``, ``{|i|}`` and ``i`` are identified. -**Remark:** identifiers ending with a non-negative integer with -leading zeros cannot be used for bound variable names. - **Convention:** identifiers starting with an uppercase letter denote types (e.g. ``Nat``, ``List``), and identifiers starting with a lowercase letter denote constructors, functions and proofs diff --git a/src/core/env.ml b/src/core/env.ml index 24b1d6183..daee904b7 100644 --- a/src/core/env.ml +++ b/src/core/env.ml @@ -1,6 +1,6 @@ (** Scoping environment for variables. *) -open Lplib +open Lplib open Base open Term (** Type of an environment, used in scoping to associate names to @@ -12,6 +12,14 @@ type env = (string * (var * term * term option)) list type t = env +(** [pp ppf env] prints the environment [env] on the formatter [ppf] (for + debug). *) +let pp : env pp = + let def ppf t = out ppf " ≔ %a" Print.term t in + let elt ppf (s, (_,a,t)) = + out ppf "%s: %a%a" s Print.term a (Option.pp def) t in + Common.Debug.D.list elt + (** [empty] is the empty environment. *) let empty : env = [] diff --git a/src/parsing/scope.ml b/src/parsing/scope.ml index 22d4c1858..269977a67 100644 --- a/src/parsing/scope.ml +++ b/src/parsing/scope.ml @@ -135,57 +135,14 @@ let fresh_patt : lhs_data -> string option -> term array -> term = let i = fresh_index () in mk_Patt (Some i, string_of_int i, ts) -(** [is_invalid_bindlib_id s] says whether [s] can be safely used as variable - name in Indeed, because converts any suffix consisting of - a sequence of digits into an integer, and increment it, we cannot use as - bound variable names escaped identifiers or regular identifiers ending with - a non-negative integer with leading zeros. *) -let is_invalid_bindlib_id : string -> bool = - let rec last_digit s k = - let l = k-1 in - if l < 0 then 0 else - match s.[l] with - | '0' .. '9' -> last_digit s l - | _ -> k - in - fun s -> - let n = String.length s - 1 in - n >= 0 && - match s.[n] with - | '0' .. '9' -> let k = last_digit s n in s.[k] = '0' && k < n - | '}' -> true - | _ -> false - -(* unit tests *) -let _ = - let invalid = is_invalid_bindlib_id in - let valid s = not (invalid s) in - assert (invalid "00"); - assert (invalid "01"); - assert (invalid "a01"); - assert (invalid "{|:|}"); - assert (valid "_x_100"); - assert (valid "_z1002"); - assert (valid "case_ex2_intro"); - assert (valid "case_ex02_intro"); - assert (valid "case_ex02_intro0"); - assert (valid "case_ex02_intro1"); - assert (valid "case_ex02_intro10") - -let pp_env : env Base.pp = - let open Base in - let def ppf t = out ppf " ≔ %a" term t in - let elt ppf (s, (_,a,t)) = out ppf "%s: %a%a" s term a (Option.pp def) t in - (D.list elt) - (** [scope ~typ md ss env t] turns a parser-level term [t] into an actual term. The variables of the environment [env] may appear in [t], and the scoping mode [md] changes the behaviour related to certain constructors. The signature state [ss] is used to convert identifiers into symbols according to [find_qid]. If [typ] is true, then [t] must be a type (defaults to false). *) -let rec scope : ?typ:bool -> int -> mode -> sig_state -> env -> p_term -> - term = +let rec scope : + ?typ:bool -> int -> mode -> sig_state -> env -> p_term -> term = fun ?(typ=false) k md ss env t -> scope_parsed ~typ k md ss env (Pratt.parse ss env t) @@ -195,7 +152,7 @@ and scope_parsed : ?typ:bool -> int -> mode -> sig_state -> env -> p_term -> term = fun ?(typ=false) k md ss env t -> if Logger.log_enabled () then - log_scop "%a<= %a@ %a" D.depth k pp_env env Pretty.term t; + log_scop "%a<= %a@ %a" D.depth k Env.pp env Pretty.term t; (* Extract the spine. *) let p_head, args = Syntax.p_get_args t in (* Check that LHS pattern variables are applied to no argument. *) @@ -298,23 +255,19 @@ and scope_binder : ?typ:bool -> int -> mode -> sig_state -> let dom = scope_domain (k+1) md ss env typopt in scope_params env idopts dom params_list and scope_params env idopts a params_list = - let rec aux env idopts = + let rec scope_params_aux env idopts = match idopts with | [] -> scope_params_list env params_list | None::idopts -> let v = new_var "_" in - let t = aux env idopts in + let t = scope_params_aux env idopts in cons (a, bind_var v t) - | Some {elt=id;pos}::idopts -> - if is_invalid_bindlib_id id then - fatal pos "\"%s\": Escaped identifiers or regular identifiers \ - having an integer suffix with leading zeros \ - are not allowed for bound variable names." id; + | Some {elt=id;_}::idopts -> let v = new_var id in let env = Env.add id v a None env in - let t = aux env idopts in + let t = scope_params_aux env idopts in cons (a, bind_var v t) - in aux env idopts + in scope_params_aux env idopts in scope_params_list env params_list From dbecfe9eff3e4664b493953bcb6383ed5945bbb7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 18 Feb 2022 14:52:30 +0100 Subject: [PATCH 25/38] fix reset_term --- src/core/sign.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/sign.ml b/src/core/sign.ml index c92ee64b6..52c174d3d 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -267,6 +267,7 @@ let read : string -> t = fun fname -> in let rec reset_term t = match unfold t with + | Db _ | Vari _ | Type | Kind -> () @@ -277,7 +278,6 @@ let read : string -> t = fun fname -> | Appl(a,b) -> reset_term a; reset_term b | Patt(_,_,ts) -> Array.iter reset_term ts | TRef r -> unsafe_reset r; Option.iter reset_term !r - | Db _ -> assert false | Wild -> assert false | Meta _ -> assert false | Plac _ -> assert false From 3d6e948936f08ccc313c3a08604364aa216e1694 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 18 Feb 2022 15:15:05 +0100 Subject: [PATCH 26/38] record if a variable is bound --- src/core/env.ml | 2 +- src/core/libTerm.ml | 17 ----- src/core/term.ml | 149 +++++++++++++++++++++++----------------- src/core/term.mli | 31 +++++---- src/core/unif.ml | 2 +- src/export/dk.ml | 6 +- src/export/xtc.ml | 12 ++-- src/handle/inductive.ml | 4 +- 8 files changed, 114 insertions(+), 109 deletions(-) diff --git a/src/core/env.ml b/src/core/env.ml index daee904b7..65fa1f1d3 100644 --- a/src/core/env.ml +++ b/src/core/env.ml @@ -107,7 +107,7 @@ let of_prod : ctxt -> string -> term -> env * term = fun c s t -> let rec build_env env t = try match_prod c t (fun a b -> let name = Stdlib.(incr i; s ^ string_of_int !i) in - let x, b = LibTerm.unbind_name name b in + let x, b = unbind ~name b in build_env (add name x a None env) b) with Invalid_argument _ -> env, t in build_env [] t diff --git a/src/core/libTerm.ml b/src/core/libTerm.ml index 2d42d9cc1..a60b35ef1 100644 --- a/src/core/libTerm.ml +++ b/src/core/libTerm.ml @@ -58,23 +58,6 @@ let iter : (term -> unit) -> term -> unit = fun action -> | LLet(a,t,u) -> iter a; iter t; iter (subst u mk_Kind) in iter -(** [unbind_name b s] is like [unbind b] but returns a valid variable - name when [b] binds no variable. The string [s] is the prefix of the - variable's name.*) -let unbind_name : string -> binder -> var * term = fun s b -> - if binder_occur b then unbind b - else let x = new_var s in (x, subst b (mk_Vari x)) - -(** [unbind2_name b1 b2 s] is like [unbind2 b1 b2] but returns a valid - variable name when [b1] or [b2] binds no variable. The string [s] is the - prefix of the variable's name.*) -let unbind2_name : string -> binder -> binder -> var * term * term = - fun s b1 b2 -> - if binder_occur b1 || binder_occur b2 then - unbind2 b1 b2 - else let x = new_var s in - (x, subst b1 (mk_Vari x), subst b2 (mk_Vari x)) - (** [distinct_vars ctx ts] checks that the terms [ts] are distinct variables. If so, the variables are returned. *) let distinct_vars : ctxt -> term array -> var array option = fun ctx ts -> diff --git a/src/core/term.ml b/src/core/term.ml index ac6cf6b0f..a16d5ca93 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -39,6 +39,10 @@ type prop = | Assoc of bool (** Associative left if [true], right if [false]. *) | AC of bool (** Associative and commutative. *) +(** Data of a binder. *) +type binder_info = {binder_name : string; binder_bound : bool} +type mbinder_info = {mbinder_name : string array; mbinder_bound : bool array} + (** Representation of a term (or types) in a general sense. Values of the type are also used, for example, in the representation of patterns or rewriting rules. Specific constructors are included for such applications, and they @@ -65,8 +69,8 @@ type term = and var = int * string (** Type for binders. *) -and binder = string * term -and mbinder = string array * term +and binder = binder_info * term +and mbinder = mbinder_info * term (** {b NOTE} that a wildcard "_" of the concrete (source code) syntax may have a different representation depending on the context. For instance, the @@ -172,7 +176,7 @@ and meta = ; meta_value : mbinder option ref (** Definition. *) } (** [mbinder_arity b] gives the arity of the [mbinder]. *) -let mbinder_arity : mbinder -> int = fun (names,_) -> Array.length names +let mbinder_arity : mbinder -> int = fun (i,_) -> Array.length i.mbinder_name (** Minimize [impl] to enforce our invariant (see {!type:Terms.sym}). *) let minimize_impl : bool list -> bool list = @@ -281,8 +285,8 @@ let rec term : term pp = fun ppf t -> | Type -> out ppf "TYPE" | Kind -> out ppf "KIND" | Symb s -> sym ppf s - | Prod(a,(n,b)) -> out ppf "(Π %s: %a, %a)" n term a term b - | Abst(a,(n,b)) -> out ppf "(λ %s: %a, %a)" n term a term b + | Prod(a,(n,b)) -> out ppf "(Π %s: %a, %a)" n.binder_name term a term b + | Abst(a,(n,b)) -> out ppf "(λ %s: %a, %a)" n.binder_name term a term b | Appl(a,b) -> out ppf "(%a %a)" term a term b | Meta(m,ts) -> out ppf "?%d%a" m.meta_key terms ts | Patt(i,s,ts) -> out ppf "$%a_%s%a" (D.option D.int) i s terms ts @@ -290,7 +294,7 @@ let rec term : term pp = fun ppf t -> | Wild -> out ppf "_" | TRef r -> out ppf "&%a" (Option.pp term) !r | LLet(a,t,(n,b)) -> - out ppf "let %s : %a ≔ %a in %a" n term a term t term b + out ppf "let %s : %a ≔ %a in %a" n.binder_name term a term t term b and var : var pp = fun ppf (i,n) -> out ppf "%s%d" n i and sym : sym pp = fun ppf s -> string ppf s.sym_name and terms : term array pp = fun ppf ts -> @@ -340,8 +344,8 @@ and lift : int -> term -> term = fun l t -> (** [msubst b vs] substitutes the variables bound by [b] with the values [vs]. Note that the length of the [vs] array should match the arity of the multiple binder [b]. *) -and msubst : mbinder -> term array -> term = fun (ns,t) vs -> - let n = Array.length ns in +and msubst : mbinder -> term array -> term = fun (bi,t) vs -> + let n = Array.length bi.mbinder_name in assert (Array.length vs = n); (* [msubst i t] replaces [Db(i+j)] by [lift (i-1) vs.(n-j-1)] for all [0 <= j < n]. *) @@ -359,7 +363,9 @@ and msubst : mbinder -> term array -> term = fun (ns,t) vs -> | Patt(j,n,ts) -> Patt(j,n, Array.map (msubst i) ts) | _ -> t in - let r = if n = 0 then t else msubst 1 t in + let r = + if n = 0 || Array.for_all ((=) false) bi.mbinder_bound then t + else msubst 1 t in if Logger.log_enabled() then log_term "msubst %a %a = %a" term t (D.array term) vs term r; r @@ -504,51 +510,59 @@ let is_prod : term -> bool = fun t -> match unfold t with Prod(_) -> true | _ -> false (** [subst b v] substitutes the variable bound by [b] with the value [v]. *) -let subst : binder -> term -> term = fun (_,t) v -> - let rec subst i t = - (*if Logger.log_enabled() then - log_term "subst [%d≔%a] %a" i term v term t;*) - match unfold t with - | Db k -> if k = i then lift (i-1) v else t - | Appl(a,b) -> mk_Appl(subst i a, subst i b) - | Abst(a,(n,u)) -> Abst(subst i a, (n, subst (i+1) u)) - | Prod(a,(n,u)) -> Prod(subst i a, (n ,subst (i+1) u)) - | LLet(a,t,(n,u)) -> LLet(subst i a, subst i t, (n, subst (i+1) u)) - | Meta(m,ts) -> Meta(m, Array.map (subst i) ts) - | Patt(j,n,ts) -> Patt(j,n, Array.map (subst i) ts) - | _ -> t - in - let r = subst 1 t in - if Logger.log_enabled() then - log_term "subst %a [%a] = %a" term t term v term r; - r - -(** [unbind b] substitutes the binder [b] using a fresh variable. The variable - and the result of the substitution are returned. Note that the name of the - fresh variable is based on that of the binder. *) -let unbind : binder -> var * term = fun ((name,_) as b) -> - let x = new_var name in x, subst b (Vari x) +let subst : binder -> term -> term = fun (bi,t) v -> + if bi.binder_bound then + begin + let rec subst i t = + (*if Logger.log_enabled() then + log_term "subst [%d≔%a] %a" i term v term t;*) + match unfold t with + | Db k -> if k = i then lift (i-1) v else t + | Appl(a,b) -> mk_Appl(subst i a, subst i b) + | Abst(a,(n,u)) -> Abst(subst i a, (n, subst (i+1) u)) + | Prod(a,(n,u)) -> Prod(subst i a, (n ,subst (i+1) u)) + | LLet(a,t,(n,u)) -> LLet(subst i a, subst i t, (n, subst (i+1) u)) + | Meta(m,ts) -> Meta(m, Array.map (subst i) ts) + | Patt(j,n,ts) -> Patt(j,n, Array.map (subst i) ts) + | _ -> t + in + let r = subst 1 t in + if Logger.log_enabled() then + log_term "subst %a [%a] = %a" term t term v term r; + r + end + else t + +(** [unbind b] substitutes the binder [b] by a fresh variable of name [name] + if given, or the binder name otherwise. The variable and the result of the + substitution are returned. *) +let unbind : ?name:string -> binder -> var * term = + fun ?(name="") ((bn,_) as b) -> + let n = if name="" then bn.binder_name else name in + let x = new_var n in x, subst b (Vari x) (** [unbind2 f g] is similar to [unbind f], but it substitutes two binders [f] - and [g] at once using the same fresh variable. The name of the variable is - based on that of the binder [f]. *) -let unbind2 : binder -> binder -> var * term * term = - fun ((name1,_) as b1) b2 -> - let x = new_var name1 in x, subst b1 (Vari x), subst b2 (Vari x) + and [g] at once using the same fresh variable. *) +let unbind2 : ?name:string -> binder -> binder -> var * term * term = + fun ?(name="") ((bn1,_) as b1) b2 -> + let n = if name="" then bn1.binder_name else name in + let x = new_var n in x, subst b1 (Vari x), subst b2 (Vari x) (** [unmbind b] substitutes the multiple binder [b] with fresh variables. This function is analogous to [unbind] for binders. Note that the names used to create the fresh variables are based on those of the multiple binder. *) -let unmbind : mbinder -> var array * term = fun ((names,_) as b) -> +let unmbind : mbinder -> var array * term = + fun (({mbinder_name=names;_},_) as b) -> let xs = Array.init (Array.length names) (fun i -> new_var names.(i)) in xs, msubst b (Array.map (fun x -> Vari x) xs) (** [bind_var x t] binds the variable [x] in [t], producing a binder. *) -let bind_var : var -> term -> binder = fun ((_,n) as x) -> +let bind_var : var -> term -> binder = fun ((_,n) as x) t -> + let bound = Stdlib.ref false in let rec bind i t = (*if Logger.log_enabled() then log_term "bind_var %d %a" i term t;*) match unfold t with - | Vari y when y == x -> Db i + | Vari y when y == x -> Stdlib.(bound := true); Db i | Appl(a,b) -> Appl(bind i a, bind i b) (* No need to call mk_Appl here as we only replace free variables by de Bruijn indices. *) @@ -558,27 +572,36 @@ let bind_var : var -> term -> binder = fun ((_,n) as x) -> | Meta(m,ts) -> Meta(m, Array.map (bind i) ts) | Patt(j,n,ts) -> Patt(j,n, Array.map (bind i) ts) | _ -> t - in fun t -> - let b = bind 1 t in - if Logger.log_enabled() then - log_term "bind_var %a %a = %a" var x term t term b; - n, b + in + let b = bind 1 t in + if Logger.log_enabled() then + log_term "bind_var %a %a = %a" var x term t term b; + {binder_name=n; binder_bound=Stdlib.(!bound)}, b + +(** [binder f b] applies f inside [b]. *) +let binder : (term -> term) -> binder -> binder = fun f b -> + let x,t = unbind b in bind_var x (f t) (** [bind_mvar xs t] binds the variables of [xs] in [t] to get a binder. It is the equivalent of [bind_var] for multiple variables. *) -let bind_mvar : var array -> term -> mbinder = fun xs t -> +let bind_mvar : var array -> term -> mbinder = + let empty = {mbinder_name=[||]; mbinder_bound=[||]} in + fun xs t -> let n = Array.length xs in - if n = 0 then [||], t else + if n = 0 then empty, t else let open Stdlib in let open Extra in (*if Logger.log_enabled() then log_term "bind_mvar %a" (D.array var) xs;*) - let map = ref IntMap.empty in + let map = ref IntMap.empty and mbinder_bound = Array.make n false in Array.iteri (fun i (ki,_) -> map := IntMap.add ki (n-1-i) !map) xs; let rec bind i t = (*if Logger.log_enabled() then log_term "bind_mvar %d %a" i term t;*) match unfold t with | Vari (key,_) -> - (match IntMap.find_opt key !map with Some k -> Db (i+k) | None -> t) + begin match IntMap.find_opt key !map with + | Some k -> mbinder_bound.(k) <- true; Db (i+k) + | None -> t + end | Appl(a,b) -> Appl(bind i a, bind i b) (* No need to call mk_Appl here as we only replace free variables by de Bruijn indices. *) @@ -592,11 +615,12 @@ let bind_mvar : var array -> term -> mbinder = fun xs t -> let b = bind 1 t in if Logger.log_enabled() then log_term "bind_mvar %a %a = %a" (D.array var) xs term t term b; - Array.map name_of xs, b + let bi = { mbinder_name = Array.map name_of xs; mbinder_bound } in + bi, b (** [binder_occur b] tests whether the bound variable occurs in [b]. *) -let binder_occur : binder -> bool = fun (_,t) -> - let rec check i t = +let binder_occur : binder -> bool = fun (bi,_) -> bi.binder_bound +(* let rec check i t = (*if Logger.log_enabled() then log_term "binder_occur %d %a" i term t;*) match unfold t with @@ -613,10 +637,7 @@ let binder_occur : binder -> bool = fun (_,t) -> if Logger.log_enabled() then log_term "binder_occur 1 %a = %b" term t r; r - -(** [binder_constant b] tests whether the [binder] [b] is constant (i.e., its - bound variable does not occur). *) -let binder_constant : binder -> bool = fun b -> not (binder_occur b) +*) (** [is_closed t] checks whether [t] is closed. *) let is_closed : term -> bool = @@ -660,7 +681,7 @@ let occur_mbinder : var -> mbinder -> bool = fun x (_,t) -> occur x t application is built as a left or right comb depending on the associativity of the symbol, and arguments are ordered in increasing order wrt [cmp]. -- In [LLet(_,_,b)], [binder_constant b = false] (useless let's are erased). *) +- In [LLet(_,_,b)], [binder_occur b = true] (useless let's are erased). *) let mk_Vari x = Vari x let mk_Type = Type let mk_Kind = Kind @@ -673,7 +694,7 @@ let mk_Patt (i,s,ts) = Patt (i,s,ts) let mk_Wild = Wild let mk_Plac b = Plac b let mk_TRef x = TRef x -let mk_LLet (a,t,u) = if binder_constant u then subst u Kind else LLet (a,t,u) +let mk_LLet (a,t,b) = if binder_occur b then LLet (a,t,b) else subst b Kind (** mk_Appl_not_canonical t u] builds the non-canonical (wrt. C and AC symbols) application of [t] to [u]. WARNING: to use only in Sign.link. *) @@ -726,16 +747,16 @@ let subst_patt : mbinder option array -> term -> term = fun env -> let rec cleanup : term -> term = fun t -> match unfold t with | Patt(i,n,ts) -> mk_Patt(i, n, Array.map cleanup ts) - | Prod(a,(n,b)) -> mk_Prod(cleanup a, (n, cleanup b)) - | Abst(a,(n,b)) -> mk_Abst(cleanup a, (n, cleanup b)) + | Prod(a,b) -> mk_Prod(cleanup a, binder cleanup b) + | Abst(a,b) -> mk_Abst(cleanup a, binder cleanup b) | Appl(a,b) -> mk_Appl(cleanup a, cleanup b) | Meta(m,ts) -> mk_Meta(m, Array.map cleanup ts) - | LLet(a,t,(n,b)) -> mk_LLet(cleanup a, cleanup t, (n, cleanup b)) + | LLet(a,t,b) -> mk_LLet(cleanup a, cleanup t, binder cleanup b) | Wild -> assert false | Plac _ -> assert false | TRef _ -> assert false - | Vari _ -> assert false - | Db _ + | Db _ -> assert false + | Vari _ | Type | Kind | Symb _ -> t diff --git a/src/core/term.mli b/src/core/term.mli index 3411d5b95..b04674bb9 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -39,6 +39,10 @@ type prop = (** Type for free variables. *) type var +(** Data of a binder. *) +type binder_info +type mbinder_info + (** Representation of a term (or types) in a general sense. Values of the type are also used, for example, in the representation of patterns or rewriting rules. Specific constructors are included for such applications, and they @@ -64,8 +68,8 @@ type term = private (** [LLet(a, t, u)] is [let x : a ≔ t in u] (with [x] bound in [u]). *) (** Type for binders. *) -and binder = string * term -and mbinder = string array * term +and binder = binder_info * term +and mbinder = mbinder_info * term (** {b NOTE} that a wildcard "_" of the concrete (source code) syntax may have a different representation depending on the context. For instance, the @@ -300,8 +304,7 @@ val cmp : term cmp application is built as a left or right comb depending on the associativity of the symbol, and arguments are ordered in increasing order wrt [cmp]. -- In [LLet(_,_,b)], [binder_constant b = false] (useless let's are - erased). *) +- In [LLet(_,_,b)], [binder_occur b = true] (useless let's are erased). *) val mk_Vari : var -> term val mk_Type : term val mk_Kind : term @@ -338,15 +341,14 @@ val subst : binder -> term -> term multiple binder [b]. *) val msubst : mbinder -> term array -> term -(** [unbind b] substitutes the binder [b] using a fresh variable. The variable - and the result of the substitution are returned. Note that the name of the - fresh variable is based on that of the binder. *) -val unbind : binder -> var * term +(** [unbind b] substitutes the binder [b] by a fresh variable of name [name] + if given, or the binder name otherwise. The variable and the result of the + substitution are returned. *) +val unbind : ?name:string -> binder -> var * term (** [unbind2 f g] is similar to [unbind f], but it substitutes two binders [f] - and [g] at once using the same fresh variable. The name of the variable is - based on that of the binder [f]. *) -val unbind2 : binder -> binder -> var * term * term + and [g] at once using the same fresh variable. *) +val unbind2 : ?name:string -> binder -> binder -> var * term * term (** [unmbind b] substitutes the multiple binder [b] with fresh variables. This function is analogous to [unbind] for binders. Note that the names used to @@ -356,6 +358,9 @@ val unmbind : mbinder -> var array * term (** [bind_var x b] binds the variable [x] in [b], producing a boxed binder. *) val bind_var : var -> term -> binder +(** [binder f b] applies f inside [b]. *) +val binder : (term -> term) -> binder -> binder + (** [bind_mvar xs b] binds the variables of [xs] in [b] to get a boxed binder. It is the equivalent of [bind_var] for multiple variables. *) val bind_mvar : var array -> term -> mbinder @@ -363,10 +368,6 @@ val bind_mvar : var array -> term -> mbinder (** [binder_occur b] tests whether the bound variable occurs in [b]. *) val binder_occur : binder -> bool -(** [binder_constant b] tests whether the [binder] [b] is constant (i.e., its - bound variable does not occur). *) -val binder_constant : binder -> bool - (** [is_closed b] checks whether the [box] [b] is closed. *) val is_closed : term -> bool val is_closed_mbinder : mbinder -> bool diff --git a/src/core/unif.ml b/src/core/unif.ml index d72adb708..1f975e6f4 100644 --- a/src/core/unif.ml +++ b/src/core/unif.ml @@ -251,7 +251,7 @@ let imitate_lam : problem -> ctxt -> meta -> unit = fun p c m -> let n = m.meta_arity in let env, t = Env.of_prod_nth c n !(m.meta_type) in let of_prod a b = - let x,b = LibTerm.unbind_name "x" b in + let x,b = unbind ~name:"x" b in let env' = Env.add "x" x a None env in x, a, env', b in diff --git a/src/export/dk.ml b/src/export/dk.ml index c576a9a98..325177e41 100644 --- a/src/export/dk.ml +++ b/src/export/dk.ml @@ -119,9 +119,9 @@ let rec term : bool -> term pp = fun b ppf t -> | Symb s -> qid ppf (s.sym_path, s.sym_name) | Prod(t,u) -> let x,u' = unbind u in - if binder_constant u - then out ppf "(%a -> %a)" (term b) t (term b) u' - else out ppf "(%a : %a -> %a)" var x (term b) t (term b) u' + if binder_occur u + then out ppf "(%a : %a -> %a)" var x (term b) t (term b) u' + else out ppf "(%a -> %a)" (term b) t (term b) u' | Abst(t,u) -> let x,u = unbind u in if b then out ppf "(%a : %a => %a)" var x (term b) t (term b) u diff --git a/src/export/xtc.ml b/src/export/xtc.ml index 147de2a2d..4a6888343 100644 --- a/src/export/xtc.ml +++ b/src/export/xtc.ml @@ -81,16 +81,16 @@ and print_type : int -> string -> term pp = fun i s ppf t -> out ppf "@.v_%a@.%a@.%a@." var x (print_type i s) a (print_type i s) t | Prod(a,b) -> - if binder_constant b + if binder_occur b then - out ppf "@.@.%a@.@.%a@.@." - (print_type i s) a - (print_type i s) (snd (unbind b)) - else let (x, b) = unbind b in out ppf "@.v_%a@." var x; - out ppf "@.%a@.@.%a@." + out ppf "@.%a@.@.%a@.@." (print_type i s) a (print_type i s) b + else + out ppf "@.@.%a@.@.%a@.@." + (print_type i s) a + (print_type i s) (snd (unbind b)) | LLet(_,t,u) -> print_type i s ppf (subst u t) (** [print_rule ppf s r] outputs the rule declaration corresponding [r] (on diff --git a/src/handle/inductive.ml b/src/handle/inductive.ml index 00ab1312c..5db1e8210 100644 --- a/src/handle/inductive.ml +++ b/src/handle/inductive.ml @@ -88,7 +88,7 @@ let ind_typ_with_codom : | (Type, _) -> codom (List.rev_map mk_Vari xs) | (Prod(a,b), _) -> let name = Stdlib.(incr i; x_str ^ string_of_int (!i)) in - let (x,b) = LibTerm.unbind_name name b in + let (x,b) = unbind ~name b in mk_Prod (a, bind_var x (aux (x::xs) b)) | _ -> fatal pos "The type of %a is not supported" sym ind_sym in @@ -203,7 +203,7 @@ let fold_cons_type sym cons_sym sym ind_sym | (Prod(t,u), _) -> let name = Stdlib.(incr i; x_str ^ string_of_int (!i)) in - let x, u = LibTerm.unbind_name name u in + let x, u = unbind ~name u in let x = inj_var (List.length xs) x in begin let env, b = Env.of_prod [] "y" t in From d46bcab09c64e42f5df8394a8b7abb711db9d4ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 18 Feb 2022 16:35:55 +0100 Subject: [PATCH 27/38] details --- src/core/sign.ml | 2 +- src/core/term.ml | 2 ++ src/core/term.mli | 2 ++ src/export/hrs.ml | 5 ++--- 4 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/core/sign.ml b/src/core/sign.ml index 52c174d3d..885414765 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -277,7 +277,7 @@ let read : string -> t = fun fname -> | LLet(a,t,(_,b)) -> reset_term a; reset_term t; reset_term b | Appl(a,b) -> reset_term a; reset_term b | Patt(_,_,ts) -> Array.iter reset_term ts - | TRef r -> unsafe_reset r; Option.iter reset_term !r + | TRef _ -> assert false | Wild -> assert false | Meta _ -> assert false | Plac _ -> assert false diff --git a/src/core/term.ml b/src/core/term.ml index a16d5ca93..0acf41cc1 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -43,6 +43,8 @@ type prop = type binder_info = {binder_name : string; binder_bound : bool} type mbinder_info = {mbinder_name : string array; mbinder_bound : bool array} +let binder_name : binder_info -> string = fun bi -> bi.binder_name + (** Representation of a term (or types) in a general sense. Values of the type are also used, for example, in the representation of patterns or rewriting rules. Specific constructors are included for such applications, and they diff --git a/src/core/term.mli b/src/core/term.mli index b04674bb9..f26b553e9 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -43,6 +43,8 @@ type var type binder_info type mbinder_info +val binder_name : binder_info -> string + (** Representation of a term (or types) in a general sense. Values of the type are also used, for example, in the representation of patterns or rewriting rules. Specific constructors are included for such applications, and they diff --git a/src/export/hrs.ml b/src/export/hrs.ml index 6f9610a02..510b72f8c 100644 --- a/src/export/hrs.ml +++ b/src/export/hrs.ml @@ -59,9 +59,8 @@ let print_rule : Format.formatter -> term -> term -> unit = | Patt(Some i,_,_) -> let name = Format.sprintf "$%d" i in Stdlib.(names := StrSet.add name !names) - | Abst(_,b) -> - let (x, _) = unbind b in - Stdlib.(names := StrSet.add (name_of x) !names) + | Abst(_,(bi,_)) -> + Stdlib.(names := StrSet.add (binder_name bi) !names) | _ -> () in LibTerm.iter fn t; From 5f073ca9140c36c65af7c5f8ecc877d4ac23eff6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 18 Feb 2022 17:03:48 +0100 Subject: [PATCH 28/38] details --- src/core/sign.ml | 2 +- src/core/unif.ml | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/sign.ml b/src/core/sign.ml index 885414765..96b30b726 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -268,7 +268,6 @@ let read : string -> t = fun fname -> let rec reset_term t = match unfold t with | Db _ - | Vari _ | Type | Kind -> () | Symb s -> shallow_reset_sym s @@ -277,6 +276,7 @@ let read : string -> t = fun fname -> | LLet(a,t,(_,b)) -> reset_term a; reset_term t; reset_term b | Appl(a,b) -> reset_term a; reset_term b | Patt(_,_,ts) -> Array.iter reset_term ts + | Vari _ -> assert false | TRef _ -> assert false | Wild -> assert false | Meta _ -> assert false diff --git a/src/core/unif.ml b/src/core/unif.ml index 1f975e6f4..848dcec45 100644 --- a/src/core/unif.ml +++ b/src/core/unif.ml @@ -108,7 +108,7 @@ let instantiation : | Some(vs, map) -> if LibMeta.occurs m c u then None else let u = Eval.simplify (Ctxt.to_let c (sym_to_var map u)) in - Some (Logger.set_debug_in false 'm' (bind_mvar vs) u) + Some ((*Logger.set_debug_in false 'm'*) (bind_mvar vs) u) (** Checking type or not during meta instanciation. *) let do_type_check = Stdlib.ref true @@ -134,8 +134,8 @@ let instantiate : problem -> ctxt -> meta -> term array -> term -> bool = | Some a -> a | None -> assert false in - let r = - Logger.set_debug_in false 'i' (Infer.check_noexn p c u) typ_mts + let r = (*Logger.set_debug_in false 'i'*) + (Infer.check_noexn p c u) typ_mts in if r <> None then do_instantiate() else (if Logger.log_enabled () then log "typing failed"; false) From fe9d807bac1e0eecba5e0699dbe1adb34bed885e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 18 Feb 2022 17:06:55 +0100 Subject: [PATCH 29/38] detail --- src/core/sign.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/sign.ml b/src/core/sign.ml index 96b30b726..c4cd9dc85 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -267,9 +267,9 @@ let read : string -> t = fun fname -> in let rec reset_term t = match unfold t with - | Db _ | Type - | Kind -> () + | Kind + | Db _ -> () | Symb s -> shallow_reset_sym s | Prod(a,(_,b)) | Abst(a,(_,b)) -> reset_term a; reset_term b From 804fc06d35db278b06e54a8d08ebc34901ac2829 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Sat, 31 Dec 2022 16:32:49 +0100 Subject: [PATCH 30/38] tests/regressions: update expected output of hrs and xtc --- tests/regressions/hrs.expected | 14 ++++++-------- tests/regressions/xtc.expected | 4 ++-- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/tests/regressions/hrs.expected b/tests/regressions/hrs.expected index f30a84702..33e05faf6 100644 --- a/tests/regressions/hrs.expected +++ b/tests/regressions/hrs.expected @@ -24,12 +24,10 @@ $7_0 : t $8_0 : t $9_0 : t $10_0 : t -82 : t -83 : t -84 : t -85 : t -86 : t -87 : t +a : t +a_and_not_b : t +b : t +b_and_not_a : t ) (RULES A(L($x,$y),$z) -> $y($z), @@ -38,12 +36,12 @@ A(A(tests_OK_bool_bool_and,$1_0),tests_OK_bool_false) -> tests_OK_bool_false, A(A(tests_OK_bool_bool_and,$2_0),tests_OK_bool_true) -> $2_0, A(A(tests_OK_bool_bool_and,tests_OK_bool_false),$3_0) -> tests_OK_bool_false, A(A(tests_OK_bool_bool_and,tests_OK_bool_true),$4_0) -> $4_0, -tests_OK_bool_bool_impl -> L(tests_OK_bool_B,\82.L(tests_OK_bool_B,\83.A(A(tests_OK_bool_bool_or,83),A(tests_OK_bool_bool_neg,82)))), +tests_OK_bool_bool_impl -> L(tests_OK_bool_B,\a.L(tests_OK_bool_B,\b.A(A(tests_OK_bool_bool_or,b),A(tests_OK_bool_bool_neg,a)))), A(tests_OK_bool_bool_neg,tests_OK_bool_false) -> tests_OK_bool_true, A(tests_OK_bool_bool_neg,tests_OK_bool_true) -> tests_OK_bool_false, A(A(tests_OK_bool_bool_or,$7_0),tests_OK_bool_false) -> $7_0, A(A(tests_OK_bool_bool_or,$8_0),tests_OK_bool_true) -> tests_OK_bool_true, A(A(tests_OK_bool_bool_or,tests_OK_bool_false),$9_0) -> $9_0, A(A(tests_OK_bool_bool_or,tests_OK_bool_true),$10_0) -> tests_OK_bool_true, -tests_OK_bool_bool_xor -> L(tests_OK_bool_B,\84.L(tests_OK_bool_B,\85.B(tests_OK_bool_B,A(A(tests_OK_bool_bool_and,84),A(tests_OK_bool_bool_neg,85)),\86.B(tests_OK_bool_B,A(A(tests_OK_bool_bool_and,85),A(tests_OK_bool_bool_neg,84)),\87.A(A(tests_OK_bool_bool_or,86),87))))) +tests_OK_bool_bool_xor -> L(tests_OK_bool_B,\a.L(tests_OK_bool_B,\b.B(tests_OK_bool_B,A(A(tests_OK_bool_bool_and,a),A(tests_OK_bool_bool_neg,b)),\a_and_not_b.B(tests_OK_bool_B,A(A(tests_OK_bool_bool_and,b),A(tests_OK_bool_bool_neg,a)),\b_and_not_a.A(A(tests_OK_bool_bool_or,a_and_not_b),b_and_not_a))))) ) diff --git a/tests/regressions/xtc.expected b/tests/regressions/xtc.expected index d72a16f7d..17a0a5297 100644 --- a/tests/regressions/xtc.expected +++ b/tests/regressions/xtc.expected @@ -40,7 +40,7 @@ tests.OK.bool.bool_impl - 86tests.OK.bool.B87tests.OK.bool.Btests.OK.bool.bool_or87tests.OK.bool.bool_neg86 + atests.OK.bool.Bbtests.OK.bool.Btests.OK.bool.bool_orbtests.OK.bool.bool_nega @@ -96,7 +96,7 @@ tests.OK.bool.bool_xor - 92tests.OK.bool.B93tests.OK.bool.B94tests.OK.bool.B95tests.OK.bool.Btests.OK.bool.bool_or9495tests.OK.bool.bool_and93tests.OK.bool.bool_neg92tests.OK.bool.bool_and92tests.OK.bool.bool_neg93 + atests.OK.bool.Bbtests.OK.bool.Ba_and_not_btests.OK.bool.Bb_and_not_atests.OK.bool.Btests.OK.bool.bool_ora_and_not_bb_and_not_atests.OK.bool.bool_andbtests.OK.bool.bool_negatests.OK.bool.bool_andatests.OK.bool.bool_negb From 7862dd840e2342b9b5769bedcfb43e5e4d69ad4e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Sat, 31 Dec 2022 17:18:26 +0100 Subject: [PATCH 31/38] fix dk export --- src/core/env.ml | 4 +-- src/core/print.ml | 2 +- src/core/term.ml | 68 +++++++++++++++++++++------------------ src/core/term.mli | 8 +++-- src/export/dk.ml | 12 ++++--- src/export/hrs.ml | 4 +-- src/export/xtc.ml | 4 +-- src/handle/inductive.ml | 6 ++-- src/handle/why3_tactic.ml | 4 +-- src/parsing/syntax.ml | 4 +-- 10 files changed, 63 insertions(+), 53 deletions(-) diff --git a/src/core/env.ml b/src/core/env.ml index f551eb862..0479426d3 100644 --- a/src/core/env.ml +++ b/src/core/env.ml @@ -127,7 +127,7 @@ let of_prod_nth : ctxt -> int -> term -> env * term = fun c n t -> if i >= n then env, t else match_prod c t (fun a b -> let x, b = unbind b in - build_env (i+1) (add (name_of x) x a None env) b) + build_env (i+1) (add (base_name x) x a None env) b) in build_env 0 [] t (** [of_prod_using c xs t] is similar to [of_prod s c n t] where [n = @@ -141,7 +141,7 @@ let of_prod_using : ctxt -> var array -> term -> env * term = fun c xs t -> if i >= n then env, t else match_prod c t (fun a b -> let xi = xs.(i) in - let name = name_of xi in + let name = base_name xi in let env = add name xi a None env in build_env (i+1) env (subst b (mk_Vari xi))) in build_env 0 [] t diff --git a/src/core/print.ml b/src/core/print.ml index 2171b41bb..a1c09f259 100644 --- a/src/core/print.ml +++ b/src/core/print.ml @@ -92,7 +92,7 @@ let sym : sym pp = fun ppf s -> else out ppf "%a.%a" path p uid n | Some alias -> out ppf "%a.%a" uid alias uid n -let var : var pp = fun ppf x -> uid ppf (name_of x) +let var : var pp = fun ppf x -> uid ppf (base_name x) (** Exception raised when trying to convert a term into a nat. *) exception Not_a_nat diff --git a/src/core/term.ml b/src/core/term.ml index f37455108..3c44e56f1 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -45,6 +45,41 @@ type mbinder_info = {mbinder_name : string array; mbinder_bound : bool array} let binder_name : binder_info -> string = fun bi -> bi.binder_name +(** Type for free variables. *) +type var = int * string + +(** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to + compare variables using [Pervasive.compare]. *) +let compare_vars : var -> var -> int = fun (i,_) (j,_) -> Stdlib.compare i j + +(** [eq_vars x y] safely computes the equality of [x] and [y]. Note that it is + unsafe to compare variables with the polymorphic equality function. *) +let eq_vars : var -> var -> bool = fun x y -> compare_vars x y = 0 + +(** [new_var name] creates a new unique variable of name [name]. *) +let new_var : string -> var = + let open Stdlib in let n = ref 0 in fun name -> incr n; !n, name + +(** [new_var_ind s i] creates a new [var] of name [s ^ string_of_int i]. *) +let new_var_ind : string -> int -> var = fun s i -> + new_var (Escape.add_prefix s (string_of_int i)) + +(** [base_name x] returns the base name of variable [x]. Note that this name + is not unique: two distinct variables may have the same name. *) +let base_name : var -> string = fun (_i,n) -> n + +(** [uniq_name x] returns a string uniquely identifying the variable [x]. *) +let uniq_name : var -> string = fun (i,_) -> "v" ^ string_of_int i + +(** Sets and maps of variables. *) +module Var = struct + type t = var + let compare = compare_vars +end + +module VarSet = Set.Make(Var) +module VarMap = Map.Make(Var) + (** Representation of a term (or types) in a general sense. Values of the type are also used, for example, in the representation of patterns or rewriting rules. Specific constructors are included for such applications, and they @@ -67,9 +102,6 @@ type term = | LLet of term * term * binder (** [LLet(a, t, u)] is [let x : a ≔ t in u] (with [x] bound in [u]). *) -(** Type for free variables. *) -and var = int * string - (** Type for binders. *) and binder = binder_info * term and mbinder = mbinder_info * term @@ -237,34 +269,6 @@ end module MetaSet = Set.Make(Meta) module MetaMap = Map.Make(Meta) -(** [compare_vars x y] safely compares [x] and [y]. Note that it is unsafe to - compare variables using [Pervasive.compare]. *) -let compare_vars : var -> var -> int = fun (i,_) (j,_) -> Stdlib.compare i j - -(** [eq_vars x y] safely computes the equality of [x] and [y]. Note that it is - unsafe to compare variables with the polymorphic equality function. *) -let eq_vars : var -> var -> bool = fun x y -> compare_vars x y = 0 - -(** [new_var name] creates a new unique variable of name [name]. *) -let new_var : string -> var = - let open Stdlib in let n = ref 0 in fun name -> incr n; !n, name - -(** [new_var_ind s i] creates a new [var] of name [s ^ string_of_int i]. *) -let new_var_ind : string -> int -> var = fun s i -> - new_var (Escape.add_prefix s (string_of_int i)) - -(** [name_of x] returns the name of variable [x]. *) -let name_of : var -> string = fun (_i,n) -> n (*^ string_of_int i*) - -(** Sets and maps of variables. *) -module Var = struct - type t = var - let compare = compare_vars -end - -module VarSet = Set.Make(Var) -module VarMap = Map.Make(Var) - let mk_bin s t1 t2 = Appl(Appl(Symb s, t1), t2) (** [mk_left_comb s t ts] builds a left comb of applications of [s] from @@ -617,7 +621,7 @@ let bind_mvar : var array -> term -> mbinder = let b = bind 1 t in if Logger.log_enabled() then log_term "bind_mvar %a %a = %a" (D.array var) xs term t term b; - let bi = { mbinder_name = Array.map name_of xs; mbinder_bound } in + let bi = { mbinder_name = Array.map base_name xs; mbinder_bound } in bi, b (** [binder_occur b] tests whether the bound variable occurs in [b]. *) diff --git a/src/core/term.mli b/src/core/term.mli index 3fe59c25b..9f5cf10eb 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -249,8 +249,12 @@ val new_var : string -> var (** [new_var_ind s i] creates a new [var] of name [s ^ string_of_int i]. *) val new_var_ind : string -> int -> var -(** [name_of x] returns the name of the variable [x]. *) -val name_of : var -> string +(** [base_name x] returns the base name of the variable [x]. Note that this + base name is not unique: two distinct variables may have the same name. *) +val base_name : var -> string + +(** [uniq_name x] returns a string uniquely identifying the variable [x]. *) +val uniq_name : var -> string (** Sets and maps of term variables. *) module Var : Map.OrderedType with type t = var diff --git a/src/export/dk.ml b/src/export/dk.ml index 45128caf8..b484ea0ac 100644 --- a/src/export/dk.ml +++ b/src/export/dk.ml @@ -116,7 +116,9 @@ let cmp : decl cmp = cmp_map (Lplib.Option.cmp Pos.cmp) pos_of_decl (** Translation of terms. *) -let var : var pp = fun ppf v -> ident ppf (name_of v) +let var : var pp = fun ppf v -> string ppf (uniq_name v) + +let patt : int pp = fun ppf i -> out ppf "x%d" i (** [term b ppf t] prints term [t]. Print abstraction domains if [b]. *) let rec term : bool -> term pp = fun b ppf t -> @@ -141,9 +143,9 @@ let rec term : bool -> term pp = fun b ppf t -> let x,u = unbind u in out ppf "((%a : %a := %a) => %a)" var x (term b) a (term b) t (term b) u | Patt(None,_,_) -> assert false - | Patt(Some i,_,[||]) -> int ppf i + | Patt(Some i,_,[||]) -> patt ppf i | Patt(Some i,_,ts) -> - out ppf "(%d%a)" i (Array.pp (prefix " " (term b)) "") ts + out ppf "(%a%a)" patt i (Array.pp (prefix " " (term b)) "") ts | Db _ -> assert false | TRef _ -> assert false | Wild -> assert false @@ -197,8 +199,8 @@ let sym_decl : sym pp = fun ppf s -> let rule_decl : (Path.t * string * rule) pp = fun ppf (p, n, r) -> let rec var ppf i = if i < 0 then () - else if i = 0 then out ppf "0" - else out ppf "%a,%d" var (i-1) i + else if i = 0 then patt ppf 0 + else out ppf "%a,%a" var (i-1) patt i in out ppf "[%a] %a%a --> %a.@." var (r.vars_nb - 1) qid (p, n) (List.pp (prefix " " (term false)) "") r.lhs (term true) r.rhs diff --git a/src/export/hrs.ml b/src/export/hrs.ml index e80402571..0ef6f50a4 100644 --- a/src/export/hrs.ml +++ b/src/export/hrs.ml @@ -73,10 +73,10 @@ let sym : sym pp = fun ppf s -> string ppf (SymMap.find s !syms) (** [add_bvar v] declares an abstracted Lambdapi variable. *) let add_bvar : var -> unit = fun v -> - bvars := StrSet.add (name_of v) !bvars + bvars := StrSet.add (base_name v) !bvars (** [bvar v] translates the Lambdapi variable [v]. *) -let bvar : var pp = fun ppf v -> string ppf (name_of v) +let bvar : var pp = fun ppf v -> string ppf (base_name v) (** [pvar i] translates the pattern variable index [i]. *) let pvar : int pp = fun ppf i -> out ppf "$%d_%d" !nb_rules i diff --git a/src/export/xtc.ml b/src/export/xtc.ml index 31463c93a..1d727df6e 100644 --- a/src/export/xtc.ml +++ b/src/export/xtc.ml @@ -52,10 +52,10 @@ let sym : sym pp = fun ppf s -> (** [add_bvar v] declares an abstracted Lambdapi variable. *) let add_bvar : var -> unit = fun v -> - bvars := StrSet.add (name_of v) !bvars + bvars := StrSet.add (base_name v) !bvars (** [bvar v] translates the Lambdapi bound variable [v]. *) -let bvar : var pp = fun ppf v -> out ppf "%s" (name_of v) +let bvar : var pp = fun ppf v -> out ppf "%s" (base_name v) (** [pvar i] translates the Lambdapi pattern variable [i]. *) let pvar : int pp = fun ppf i -> out ppf "%d_%d" !nb_rules i diff --git a/src/handle/inductive.ml b/src/handle/inductive.ml index 22b73bf09..d55e4753c 100644 --- a/src/handle/inductive.ml +++ b/src/handle/inductive.ml @@ -49,7 +49,7 @@ let gen_safe_prefixes : inductive -> string * string * string = match unfold t with | Prod(_,b) -> let x,b = unbind b in - add_name_from_type (StrSet.add (name_of x) set) b + add_name_from_type (StrSet.add (base_name x) set) b | _ -> set in let add_name_from_sym set sym = @@ -318,7 +318,7 @@ let iter_rec_rules : let head = P.appl_wild head n in (* add a predicate variable for each inductive type *) let head = - let apred (_,d) t = apatt t (name_of d.ind_var) in + let apred (_,d) t = apatt t (base_name d.ind_var) in List.fold_right apred ind_pred_map head in (* add a case variable for each constructor *) @@ -343,7 +343,7 @@ let iter_rec_rules : let env_appl t env = List.fold_right (fun (_,(x,_,_)) t -> P.appl t (P.var x)) env t in let add_abst t (_,(x,_,_)) = - P.abst (Some (Pos.none (name_of x))) t in + P.abst (Some (Pos.none (base_name x))) t in List.fold_left add_abst (arec s ts (env_appl x env)) env in let acc_rec_dom acc x aux = P.appl (P.appl acc x) aux in diff --git a/src/handle/why3_tactic.ml b/src/handle/why3_tactic.ml index 2e526af2d..f22dab244 100644 --- a/src/handle/why3_tactic.ml +++ b/src/handle/why3_tactic.ml @@ -82,7 +82,7 @@ end = struct let sym = Why3.(Ty.create_tysymbol id [] Ty.NoDef) in ((te,TySym sym)::tbl, Why3.Ty.ty_app sym []) | Vari x, [] -> - let sym = Why3.Ty.tv_of_string (name_of x) in + let sym = Why3.Ty.tv_of_string (base_name x) in ((te,TyVar sym)::tbl, Why3.Ty.ty_var sym) | _ -> let id = Why3.Ident.id_fresh "ty" in @@ -130,7 +130,7 @@ let translate_term : config -> cnst_table -> TyTable.t -> term -> let x, t = unbind t in let (tbl, ty_tbl ,t) = translate_prop tbl ty_tbl t in let tquant = - let id = Why3.Ident.id_fresh (name_of x) in + let id = Why3.Ident.id_fresh (base_name x) in let vid = Why3.(Term.create_vsymbol id) ty in let close = if s == cfg.symb_ex then Why3.Term.t_exists_close diff --git a/src/parsing/syntax.ml b/src/parsing/syntax.ml index 0a3193109..ac100fcfa 100644 --- a/src/parsing/syntax.ml +++ b/src/parsing/syntax.ml @@ -107,8 +107,8 @@ module P = struct (** [iden s] builds a [P_Iden] "@s". *) let iden : string -> p_term = qiden [] - (** [var v] builds a [P_Iden] from [name_of v]. *) - let var : Term.var -> p_term = fun v -> iden (Term.name_of v) + (** [var v] builds a [P_Iden] from [base_name v]. *) + let var : Term.var -> p_term = fun v -> iden (Term.base_name v) (** [patt s ts] builds a [P_Patt] "$s[ts]". *) let patt : string -> p_term array option -> p_term = fun s ts -> From 6babc672b7562db37b0829a15bb3a37008045fe1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 9 Jun 2023 14:12:49 +0900 Subject: [PATCH 32/38] add tests/OK/991.lp --- tests/OK/991.lp | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 tests/OK/991.lp diff --git a/tests/OK/991.lp b/tests/OK/991.lp new file mode 100644 index 000000000..1ad41d8e2 --- /dev/null +++ b/tests/OK/991.lp @@ -0,0 +1,11 @@ +symbol Prop:TYPE; +symbol -:Prop → Prop; notation - prefix 10; +associative commutative symbol +: Prop → Prop → Prop; notation + infix right 5; +injective symbol π:Prop → TYPE; +symbol resolution x a b : π (x + a) → π (- x + b) → π (a + b); +opaque symbol test a b c d e : + π (e + a + b) → π (c + d + - e) → π (a + b + c + d) ≔ +begin + assume a b c d e h1 h2; + apply resolution e (b + a) (d + c) h1 h2 +end; From 68f62def51255ae3ff8c9d440635c4d72bde078f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Sat, 29 Jul 2023 16:23:11 +0200 Subject: [PATCH 33/38] update doc --- doc/terms.rst | 4 ---- 1 file changed, 4 deletions(-) diff --git a/doc/terms.rst b/doc/terms.rst index 08991bf2d..c74f56c8e 100644 --- a/doc/terms.rst +++ b/doc/terms.rst @@ -16,10 +16,6 @@ An identifier can be: **Remark:** for any regular identifier ``i``, ``{|i|}`` and ``i`` are identified. -**Remark:** Escaped identifiers or regular identifiers ending with a -non-negative integer with leading zeros cannot be used for bound -variable names. - **Convention:** identifiers starting with an uppercase letter denote types (e.g. ``Nat``, ``List``), and identifiers starting with a lowercase letter denote constructors, functions and proofs From c74325b0efcf11cee7d74301a79e8f8d6974c64e Mon Sep 17 00:00:00 2001 From: Bruno Barras Date: Fri, 26 Jan 2024 15:21:08 +0100 Subject: [PATCH 34/38] enforce locally nameless convention (never deal with terms containing free de Bruijn indices) of Term interface + avoid some unnecessary relocations --- src/core/sign.ml | 28 ++++++++++++++-------------- src/core/term.ml | 38 +++++++++++++++++++++++++------------- src/core/term.mli | 8 ++++---- 3 files changed, 43 insertions(+), 31 deletions(-) diff --git a/src/core/sign.ml b/src/core/sign.ml index ad7185644..149dd0f48 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -99,14 +99,14 @@ let link : t -> unit = fun sign -> match unfold t with | Db _ | Type - | Kind -> t + | Kind + | Vari _ -> t | Symb s -> mk_Symb(link_symb s) - | Prod(a,(n,b)) -> mk_Prod(link_term a, (n, link_term b)) - | Abst(a,(n,b)) -> mk_Abst(link_term a, (n, link_term b)) - | LLet(a,t,(n,b)) -> mk_LLet(link_term a, link_term t, (n, link_term b)) + | Prod(a,b) -> mk_Prod(link_term a, binder link_term b) + | Abst(a,b) -> mk_Abst(link_term a, binder link_term b) + | LLet(a,t,b) -> mk_LLet(link_term a, link_term t, binder link_term b) | Appl(a,b) -> mk_Appl(link_term a, link_term b) | Patt(i,n,ts)-> mk_Patt(i, n, Array.map link_term ts) - | Vari _ -> assert false | Meta _ -> assert false | Plac _ -> assert false | Wild -> assert false @@ -171,15 +171,15 @@ let unlink : t -> unit = fun sign -> let rec unlink_term t = match unfold t with | Symb s -> unlink_sym s - | Prod(a,(_,b)) - | Abst(a,(_,b)) -> unlink_term a; unlink_term b - | LLet(a,t,(_,b)) -> unlink_term a; unlink_term t; unlink_term b + | Prod(a,b) + | Abst(a,b) -> unlink_term a; unlink_term (snd(unbind b)) + | LLet(a,t,b) -> unlink_term a; unlink_term t; unlink_term (snd(unbind b)) | Appl(a,b) -> unlink_term a; unlink_term b | Meta _ -> assert false | Plac _ -> assert false | Wild -> assert false | TRef _ -> assert false - | Vari _ -> assert false + | Vari _ | Patt _ | Db _ | Type @@ -278,14 +278,14 @@ let read : string -> t = fun fname -> match unfold t with | Type | Kind - | Db _ -> () + | Db _ + | Vari _ -> () | Symb s -> shallow_reset_sym s - | Prod(a,(_,b)) - | Abst(a,(_,b)) -> reset_term a; reset_term b - | LLet(a,t,(_,b)) -> reset_term a; reset_term t; reset_term b + | Prod(a,b) + | Abst(a,b) -> reset_term a; reset_term (snd (unbind b)) + | LLet(a,t,b) -> reset_term a; reset_term t; reset_term (snd(unbind b)) | Appl(a,b) -> reset_term a; reset_term b | Patt(_,_,ts) -> Array.iter reset_term ts - | Vari _ -> assert false | TRef _ -> assert false | Wild -> assert false | Meta _ -> assert false diff --git a/src/core/term.ml b/src/core/term.ml index 07f70cb15..991b71fee 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -9,7 +9,7 @@ open Common open Debug let log = Logger.make 'm' "term" "term building" let log = log.pp - + (** {3 Term (and symbol) representation} *) (** Representation of a possibly qualified identifier. *) @@ -324,7 +324,8 @@ and unfold : term -> term = fun t -> begin match !(m.meta_value) with | None -> t - | Some(b) -> unfold (msubst b ts) + | Some(b) -> (* Note: terms of ts may have free dB: opn=true *) + unfold (msubst true b ts) end | TRef(r) -> begin @@ -348,14 +349,18 @@ and lift : int -> term -> term = fun l t -> | Patt(j,n,ts) -> Patt(j,n, Array.map (lift i) ts) | _ -> t in - let r = lift 1 t in + (* When l=0, lift is the identity: avoid unnecessary allocation *) + let r = if l=0 then t else lift 1 t in if Logger.log_enabled() then log "lift %d %a = %a" l term t term r; r -(** [msubst b vs] substitutes the variables bound by [b] with the values [vs]. +(** [msubst opn b vs] substitutes the variables bound by [b] with the values [vs]. Note that the length of the [vs] array should match the arity of the - multiple binder [b]. *) -and msubst : mbinder -> term array -> term = fun (bi,t) vs -> + multiple binder [b]. Boolean [opn] indicates whether terms of [vs] may contain + free de Bruijn indices, needing term relocation. This happens from within the + Term library but the interface ensures that from the outside all terms have + no free de Bruinj indices (locally nameless convention). *) +and msubst : bool -> mbinder -> term array -> term = fun opn (bi,t) vs -> let n = Array.length bi.mbinder_name in assert (Array.length vs = n); (* [msubst i t] replaces [Db(i+j)] by [lift (i-1) vs.(n-j-1)] @@ -365,14 +370,16 @@ and msubst : mbinder -> term array -> term = fun (bi,t) vs -> log "msubst %d %a %a" i (D.array term) vs term t; match unfold t with | Db k -> let j = k-i in - if j<0 then t else (assert(j mk_Appl(msubst i a, msubst i b) | Abst(a,(n,u)) -> Abst(msubst i a, (n, msubst (i+1) u)) | Prod(a,(n,u)) -> Prod(msubst i a, (n, msubst (i+1) u)) | LLet(a,t,(n,u)) -> LLet(msubst i a, msubst i t, (n, msubst (i+1) u)) | Meta(m,ts) -> Meta(m, Array.map (msubst i) ts) | Patt(j,n,ts) -> Patt(j,n, Array.map (msubst i) ts) - | _ -> t + | Type | Kind | Vari _ | Wild | Symb _ | Plac _ | TRef _ -> t in let r = if n = 0 || Array.for_all ((=) false) bi.mbinder_bound then t @@ -521,7 +528,8 @@ let is_abst : term -> bool = fun t -> let is_prod : term -> bool = fun t -> match unfold t with Prod(_) -> true | _ -> false -(** [subst b v] substitutes the variable bound by [b] with the value [v]. *) +(** [subst b v] substitutes the variable bound by [b] with the value [v]. + Assumes v is closed (since only called from outside the term library. *) let subst : binder -> term -> term = fun (bi,t) v -> if bi.binder_bound then begin @@ -529,7 +537,7 @@ let subst : binder -> term -> term = fun (bi,t) v -> (*if Logger.log_enabled() then log "subst [%d≔%a] %a" i term v term t;*) match unfold t with - | Db k -> if k = i then lift (i-1) v else t + | Db k -> if k = i then v else t | Appl(a,b) -> mk_Appl(subst i a, subst i b) | Abst(a,(n,u)) -> Abst(subst i a, (n, subst (i+1) u)) | Prod(a,(n,u)) -> Prod(subst i a, (n ,subst (i+1) u)) @@ -566,7 +574,7 @@ let unbind2 : ?name:string -> binder -> binder -> var * term * term = let unmbind : mbinder -> var array * term = fun (({mbinder_name=names;_},_) as b) -> let xs = Array.init (Array.length names) (fun i -> new_var names.(i)) in - xs, msubst b (Array.map (fun x -> Vari x) xs) + xs, msubst false b (Array.map (fun x -> Vari x) xs) (** [bind_var x t] binds the variable [x] in [t], producing a binder. *) let bind_var : var -> term -> binder = fun ((_,n) as x) t -> @@ -734,8 +742,8 @@ let subst_patt : mbinder option array -> term -> term = fun env -> match unfold t with | Patt(Some i,n,ts) when 0 <= i && i < Array.length env -> begin match env.(i) with - | Some b -> msubst b (Array.map subst_patt ts) - | None -> mk_Patt(Some i,n,Array.map subst_patt ts) + | Some b -> msubst true b (Array.map subst_patt ts) + | None -> mk_Patt(Some i,n,Array.map subst_patt ts) end | Patt(i,n,ts) -> mk_Patt(i, n, Array.map subst_patt ts) | Prod(a,(n,b)) -> mk_Prod(subst_patt a, (n, subst_patt b)) @@ -754,6 +762,10 @@ let subst_patt : mbinder option array -> term -> term = fun env -> | Symb _ -> t in subst_patt +(** From the outside of the library, substituted terms ae all closed + (locally nameless convention) *) +let msubst = msubst false + (** [cleanup t] unfold all metas and TRef's in [t]. *) let rec cleanup : term -> term = fun t -> match unfold t with diff --git a/src/core/term.mli b/src/core/term.mli index 0a4a938c6..58d2c6e96 100644 --- a/src/core/term.mli +++ b/src/core/term.mli @@ -45,6 +45,10 @@ type mbinder_info val binder_name : binder_info -> string +(** Type for binders. *) +type binder +type mbinder + (** Representation of a term (or types) in a general sense. Values of the type are also used, for example, in the representation of patterns or rewriting rules. Specific constructors are included for such applications, and they @@ -69,10 +73,6 @@ type term = private | LLet of term * term * binder (** [LLet(a, t, u)] is [let x : a ≔ t in u] (with [x] bound in [u]). *) -(** Type for binders. *) -and binder = binder_info * term -and mbinder = mbinder_info * term - (** {b NOTE} that a wildcard "_" of the concrete (source code) syntax may have a different representation depending on the context. For instance, the {!constructor:Wild} constructor is only used when matching patterns (e.g., From d987930f7202dc9b3af4a89a9c67ac226d096cdd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Thu, 22 Feb 2024 11:09:31 +0100 Subject: [PATCH 35/38] spaces --- src/core/term.ml | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/core/term.ml b/src/core/term.ml index 991b71fee..fd91a35a9 100644 --- a/src/core/term.ml +++ b/src/core/term.ml @@ -9,7 +9,7 @@ open Common open Debug let log = Logger.make 'm' "term" "term building" let log = log.pp - + (** {3 Term (and symbol) representation} *) (** Representation of a possibly qualified identifier. *) @@ -231,7 +231,8 @@ let create_sym : Path.t -> expo -> prop -> match_strat -> bool -> fun sym_path sym_expo sym_prop sym_mstrat sym_opaq { elt = sym_name; pos = sym_pos } sym_decl_pos typ sym_impl -> {sym_path; sym_name; sym_type = ref typ; sym_impl; sym_def = ref None; - sym_opaq = ref sym_opaq; sym_rules = ref []; sym_dtree = ref Tree_type.empty_dtree; + sym_opaq = ref sym_opaq; sym_rules = ref []; + sym_dtree = ref Tree_type.empty_dtree; sym_mstrat; sym_prop; sym_expo; sym_pos ; sym_decl_pos } (** [is_constant s] tells whether [s] is a constant. *) @@ -354,12 +355,12 @@ and lift : int -> term -> term = fun l t -> if Logger.log_enabled() then log "lift %d %a = %a" l term t term r; r -(** [msubst opn b vs] substitutes the variables bound by [b] with the values [vs]. - Note that the length of the [vs] array should match the arity of the - multiple binder [b]. Boolean [opn] indicates whether terms of [vs] may contain - free de Bruijn indices, needing term relocation. This happens from within the - Term library but the interface ensures that from the outside all terms have - no free de Bruinj indices (locally nameless convention). *) +(** [msubst opn b vs] substitutes the variables bound by [b] with the values + [vs]. Note that the length of the [vs] array should match the arity of + the multiple binder [b]. Boolean [opn] indicates whether terms of [vs] may + contain free de Bruijn indices, needing term relocation. This happens from + within the Term library but the interface ensures that from the outside + all terms have no free de Bruinj indices (locally nameless convention). *) and msubst : bool -> mbinder -> term array -> term = fun opn (bi,t) vs -> let n = Array.length bi.mbinder_name in assert (Array.length vs = n); @@ -765,7 +766,7 @@ let subst_patt : mbinder option array -> term -> term = fun env -> (** From the outside of the library, substituted terms ae all closed (locally nameless convention) *) let msubst = msubst false - + (** [cleanup t] unfold all metas and TRef's in [t]. *) let rec cleanup : term -> term = fun t -> match unfold t with From 2890ad17bd990355deb9885176b0546cc74162c4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 1 Mar 2024 12:44:05 +0100 Subject: [PATCH 36/38] exclude 991 in tests/export_raw_dk.sh --- tests/export_raw_dk.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/export_raw_dk.sh b/tests/export_raw_dk.sh index bf3541bd4..c8cacfa18 100755 --- a/tests/export_raw_dk.sh +++ b/tests/export_raw_dk.sh @@ -52,7 +52,7 @@ do # "as" 729);; # "notation" - xor|Set|quant*|Prop|prefix|parametricCoercions|opaque|nat_id*|michael|max-suc-alg|lpparse|iss861|infix|infer|indrec|implicitArgs[34]|group|cr_qu|cp*|coercions|builtin_zero_succ|plus_ac|693|693_assume|679|665|655|655b|649_fo_27|595_and_elim|584_c_slow|579_or_elim_long|579_long_no_duplicate|359|328|245|245b|244|1026);; + xor|Set|quant*|Prop|prefix|parametricCoercions|opaque|nat_id*|michael|max-suc-alg|lpparse|iss861|infix|infer|indrec|implicitArgs[34]|group|cr_qu|cp*|coercions|builtin_zero_succ|plus_ac|693|693_assume|679|665|655|655b|649_fo_27|595_and_elim|584_c_slow|579_or_elim_long|579_long_no_duplicate|359|328|245|245b|244|1026|991);; # "quantifier" 683|650|573|565|430);; # nested module name From 7dd3baa7c32adc0ed0d680ed00eb105f10dff87f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 29 Mar 2024 13:05:12 +0100 Subject: [PATCH 37/38] remove tests related to identifier restrictions due to bindlib --- tests/KO/621.lp | 4 ---- tests/KO/621b.lp | 4 ---- 2 files changed, 8 deletions(-) delete mode 100644 tests/KO/621.lp delete mode 100644 tests/KO/621b.lp diff --git a/tests/KO/621.lp b/tests/KO/621.lp deleted file mode 100644 index 50cf725c5..000000000 --- a/tests/KO/621.lp +++ /dev/null @@ -1,4 +0,0 @@ -// test that identifiers incompatible with Bindlib are rejected - -symbol A:TYPE; -symbol f (v00:A) ≔ v00; diff --git a/tests/KO/621b.lp b/tests/KO/621b.lp deleted file mode 100644 index 78150f7cd..000000000 --- a/tests/KO/621b.lp +++ /dev/null @@ -1,4 +0,0 @@ -// test that identifiers incompatible with Bindlib are rejected - -symbol A:TYPE; -symbol f ({|:00|}:A) ≔ {|:00|}); From f22cd055d2ead2b0e933b9fb30a165cfb9277bb2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Thu, 9 Jan 2025 18:53:09 +0100 Subject: [PATCH 38/38] finalize merge --- src/parsing/scope.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parsing/scope.ml b/src/parsing/scope.ml index e19bf7ba4..ef0651c0e 100644 --- a/src/parsing/scope.ml +++ b/src/parsing/scope.ml @@ -255,7 +255,7 @@ and scope_binder : match idopts with | [] -> scope_params_list n env params_list | None::idopts -> - let v = if n = 0 then new_tvar "_" else new_tvar_ind "_" n in + let v = if n = 0 then new_var "_" else new_var_ind "_" n in let t = aux (n+1) env idopts in cons (a, bind_var v t) | Some {elt=id;_}::idopts ->