diff options
306 files changed, 2268 insertions, 2190 deletions
diff --git a/checker/check.ml b/checker/check.ml index a3fc6d0f7..31f75f4f9 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -21,12 +21,12 @@ type section_path = { dirpath : string list ; basename : string } let dir_of_path p = - make_dirpath (List.map id_of_string p.dirpath) + make_dirpath (List.map Id.of_string p.dirpath) let path_of_dirpath dir = match repr_dirpath dir with [] -> failwith "path_of_dirpath" | l::dir -> - {dirpath=List.map string_of_id dir;basename=string_of_id l} + {dirpath=List.map Id.to_string dir;basename=Id.to_string l} let pr_dirlist dp = prlist_with_sep (fun _ -> str".") str (List.rev dp) let pr_path sp = @@ -203,7 +203,7 @@ let locate_absolute_library dir = let loadpath = load_paths_of_dir_path pref in if loadpath = [] then raise LibUnmappedDir; try - let name = string_of_id base^".vo" in + let name = Id.to_string base^".vo" in let _, file = System.where_in_path ~warn:false loadpath name in (dir, file) with Not_found -> @@ -226,7 +226,7 @@ let locate_qualified_library qid = let name = qid.basename^".vo" in let path, file = System.where_in_path loadpath name in let dir = - extend_dirpath (find_logical_path path) (id_of_string qid.basename) in + extend_dirpath (find_logical_path path) (Id.of_string qid.basename) in (* Look if loaded *) try (dir, library_full_filename dir) diff --git a/checker/checker.ml b/checker/checker.ml index 8e0a2a1e5..5a7efacf8 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -19,7 +19,7 @@ let () = at_exit flush_all let fatal_error info = pperrnl info; flush_all (); exit 1 -let coq_root = id_of_string "Coq" +let coq_root = Id.of_string "Coq" let parse_dir s = let len = String.length s in let rec decoupe_dirs dirs n = @@ -36,7 +36,7 @@ let parse_dir s = let dirpath_of_string s = match parse_dir s with [] -> Check.default_root_prefix - | dir -> make_dirpath (List.map id_of_string dir) + | dir -> make_dirpath (List.map Id.of_string dir) let path_of_string s = match parse_dir s with [] -> invalid_arg "path_of_string" @@ -69,7 +69,7 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = msg_warning (str ("Cannot open " ^ dir)) let convert_string d = - try id_of_string d + try Id.of_string d with _ -> if_verbose msg_warning (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)")); raise Exit diff --git a/checker/closure.ml b/checker/closure.ml index c515bdb24..9677680e6 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -48,11 +48,11 @@ let with_stats c = end else Lazy.force c -type transparent_state = Idpred.t * Cpred.t -let all_opaque = (Idpred.empty, Cpred.empty) -let all_transparent = (Idpred.full, Cpred.full) +type transparent_state = Id.Pred.t * Cpred.t +let all_opaque = (Id.Pred.empty, Cpred.empty) +let all_transparent = (Id.Pred.full, Cpred.full) -let is_transparent_variable (ids, _) id = Idpred.mem id ids +let is_transparent_variable (ids, _) id = Id.Pred.mem id ids let is_transparent_constant (_, csts) cst = Cpred.mem cst csts module type RedFlagsSig = sig @@ -63,7 +63,7 @@ module type RedFlagsSig = sig val fIOTA : red_kind val fZETA : red_kind val fCONST : constant -> red_kind - val fVAR : identifier -> red_kind + val fVAR : Id.t -> red_kind val no_red : reds val red_add : reds -> red_kind -> reds val mkflags : red_kind list -> reds @@ -85,7 +85,7 @@ module RedFlags = (struct r_iota : bool } type red_kind = BETA | DELTA | IOTA | ZETA - | CONST of constant | VAR of identifier + | CONST of constant | VAR of Id.t let fBETA = BETA let fDELTA = DELTA let fIOTA = IOTA @@ -110,7 +110,7 @@ module RedFlags = (struct | ZETA -> { red with r_zeta = true } | VAR id -> let (l1,l2) = red.r_const in - { red with r_const = Idpred.add id l1, l2 } + { red with r_const = Id.Pred.add id l1, l2 } let mkflags = List.fold_left red_add no_red @@ -122,7 +122,7 @@ module RedFlags = (struct incr_cnt c delta | VAR id -> (* En attendant d'avoir des kn pour les Var *) let (l,_) = red.r_const in - let c = Idpred.mem id l in + let c = Id.Pred.mem id l in incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta | IOTA -> incr_cnt red.r_iota iota @@ -162,7 +162,7 @@ let betaiotazeta = mkflags [fBETA;fIOTA;fZETA] type table_key = | ConstKey of constant - | VarKey of identifier + | VarKey of Id.t | RelKey of int type 'a infos = { @@ -170,7 +170,7 @@ type 'a infos = { i_repr : 'a infos -> constr -> 'a; i_env : env; i_rels : int * (int * constr) list; - i_vars : (identifier * constr) list; + i_vars : (Id.t * constr) list; i_tab : (table_key, 'a) Hashtbl.t } let ref_value_cache info ref = @@ -544,7 +544,7 @@ let rec to_constr constr_fun lfts v = let fr = mk_clos2 env t in let unfv = update v (fr.norm,fr.term) in to_constr constr_fun lfts unfv - | FLOCKED -> assert false (*mkVar(id_of_string"_LOCK_")*) + | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*) (* This function defines the correspondance between constr and fconstr. When we find a closure whose substitution is the identity, diff --git a/checker/closure.mli b/checker/closure.mli index 428197fa8..443eeb6aa 100644 --- a/checker/closure.mli +++ b/checker/closure.mli @@ -25,7 +25,7 @@ val with_stats: 'a Lazy.t -> 'a Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) -type transparent_state = Idpred.t * Cpred.t +type transparent_state = Id.Pred.t * Cpred.t val all_opaque : transparent_state val all_transparent : transparent_state @@ -44,7 +44,7 @@ module type RedFlagsSig = sig val fIOTA : red_kind val fZETA : red_kind val fCONST : constant -> red_kind - val fVAR : identifier -> red_kind + val fVAR : Id.t -> red_kind (* No reduction at all *) val no_red : reds @@ -69,7 +69,7 @@ val betadeltaiotanolet : reds (***********************************************************************) type table_key = | ConstKey of constant - | VarKey of identifier + | VarKey of Id.t | RelKey of int type 'a infos diff --git a/checker/declarations.ml b/checker/declarations.ml index df0134e02..7e368dcad 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -607,7 +607,7 @@ type one_inductive_body = { (* Primitive datas *) (* Name of the type: [Ii] *) - mind_typename : identifier; + mind_typename : Id.t; (* Arity context of [Ii] with parameters: [forall params, Ui] *) mind_arity_ctxt : rel_context; @@ -616,7 +616,7 @@ type one_inductive_body = { mind_arity : inductive_arity; (* Names of the constructors: [cij] *) - mind_consnames : identifier array; + mind_consnames : Id.t array; (* Types of the constructors with parameters: [forall params, Tij], where the Ik are replaced by de Bruijn index in the context @@ -764,8 +764,8 @@ and struct_expr_body = | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path - | With_definition_body of identifier list * constant_body + With_module_body of Id.t list * module_path + | With_definition_body of Id.t list * constant_body and module_body = { mod_mp : module_path; diff --git a/checker/declarations.mli b/checker/declarations.mli index 7dfe609c3..c14d8b73a 100644 --- a/checker/declarations.mli +++ b/checker/declarations.mli @@ -91,7 +91,7 @@ type one_inductive_body = { (* Primitive datas *) (* Name of the type: [Ii] *) - mind_typename : identifier; + mind_typename : Id.t; (* Arity context of [Ii] with parameters: [forall params, Ui] *) mind_arity_ctxt : rel_context; @@ -100,7 +100,7 @@ type one_inductive_body = { mind_arity : inductive_arity; (* Names of the constructors: [cij] *) - mind_consnames : identifier array; + mind_consnames : Id.t array; (* Types of the constructors with parameters: [forall params, Tij], where the Ik are replaced by de Bruijn index in the context @@ -191,8 +191,8 @@ and struct_expr_body = | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path - | With_definition_body of identifier list * constant_body + With_module_body of Id.t list * module_path + | With_definition_body of Id.t list * constant_body and module_body = { mod_mp : module_path; diff --git a/checker/environ.mli b/checker/environ.mli index 628febbb0..36b76960f 100644 --- a/checker/environ.mli +++ b/checker/environ.mli @@ -40,8 +40,8 @@ val push_rec_types : name array * constr array * 'a -> env -> env (* Named variables *) val named_context : env -> named_context val push_named : named_declaration -> env -> env -val lookup_named : identifier -> env -> named_declaration -val named_type : identifier -> env -> constr +val lookup_named : Id.t -> env -> named_declaration +val named_type : Id.t -> env -> constr (* Universes *) val universes : env -> Univ.universes diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 3539289e7..edd970f6b 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -76,10 +76,10 @@ type inductive_error = | NotEnoughArgs of env * constr * constr | NotConstructor of env * constr * constr | NonPar of env * constr * int * constr * constr - | SameNamesTypes of identifier - | SameNamesConstructors of identifier - | SameNamesOverlap of identifier list - | NotAnArity of identifier + | SameNamesTypes of Id.t + | SameNamesConstructors of Id.t + | SameNamesOverlap of Id.t list + | NotAnArity of Id.t | BadEntry exception InductiveError of inductive_error diff --git a/checker/indtypes.mli b/checker/indtypes.mli index 691c9466f..5c032a0ca 100644 --- a/checker/indtypes.mli +++ b/checker/indtypes.mli @@ -27,10 +27,10 @@ type inductive_error = | NotEnoughArgs of env * constr * constr | NotConstructor of env * constr * constr | NonPar of env * constr * int * constr * constr - | SameNamesTypes of identifier - | SameNamesConstructors of identifier - | SameNamesOverlap of identifier list - | NotAnArity of identifier + | SameNamesTypes of Id.t + | SameNamesConstructors of Id.t + | SameNamesOverlap of Id.t list + | NotAnArity of Id.t | BadEntry exception InductiveError of inductive_error diff --git a/checker/term.ml b/checker/term.ml index 0c3fc741d..6bafeda7f 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -88,7 +88,7 @@ let val_cast = val_enum "cast_kind" 2 type constr = | Rel of int - | Var of identifier + | Var of Id.t | Meta of metavariable | Evar of constr pexistential | Sort of sorts @@ -318,7 +318,7 @@ let val_rdecl = let val_nctxt = val_list val_ndecl let val_rctxt = val_list val_rdecl -type named_declaration = identifier * constr option * constr +type named_declaration = Id.t * constr option * constr type rel_declaration = name * constr option * constr type named_context = named_declaration list diff --git a/checker/term.mli b/checker/term.mli index 0340c79b4..c417cd14e 100644 --- a/checker/term.mli +++ b/checker/term.mli @@ -26,7 +26,7 @@ type 'a pcofixpoint = int * 'a prec_declaration type cast_kind = VMcast | DEFAULTcast type constr = Rel of int - | Var of identifier + | Var of Id.t | Meta of metavariable | Evar of constr pexistential | Sort of sorts @@ -71,7 +71,7 @@ val substnl : constr list -> int -> constr -> constr val substl : constr list -> constr -> constr val subst1 : constr -> constr -> constr -type named_declaration = identifier * constr option * constr +type named_declaration = Id.t * constr option * constr type rel_declaration = name * constr option * constr type named_context = named_declaration list val empty_named_context : named_context diff --git a/checker/typeops.ml b/checker/typeops.ml index ad05f96b7..129c242b9 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -395,7 +395,7 @@ let check_named_ctxt env ctxt = let _ = try let _ = lookup_named id env in - failwith ("variable "^string_of_id id^" defined twice") + failwith ("variable "^Id.to_string id^" defined twice") with Not_found -> () in match d with (_,None,ty) -> diff --git a/dev/db_printers.ml b/dev/db_printers.ml index f54df8a80..95e94c6d8 100644 --- a/dev/db_printers.ml +++ b/dev/db_printers.ml @@ -10,7 +10,7 @@ open Names let pp s = pp (hov 0 s) -let prid id = Format.print_string (string_of_id id) +let prid id = Format.print_string (Id.to_string id) let prsp sp = Format.print_string (string_of_path sp) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 89c2179d2..186ab170e 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -61,12 +61,12 @@ let ppbigint n = pp (str (Bigint.to_string n));; let prset pr l = str "[" ++ hov 0 (prlist_with_sep spc pr l) ++ str "]" let ppintset l = pp (prset int (Int.Set.elements l)) -let ppidset l = pp (prset pr_id (Idset.elements l)) +let ppidset l = pp (prset pr_id (Id.Set.elements l)) let prset' pr l = str "[" ++ hov 0 (prlist_with_sep pr_comma pr l) ++ str "]" let ppidmap pr l = let pr (id,b) = pr_id id ++ str "=>" ++ pr id b in - pp (prset' pr (Idmap.fold (fun a b l -> (a,b)::l) l [])) + pp (prset' pr (Id.Map.fold (fun a b l -> (a,b)::l) l [])) let ppevarsubst = ppidmap (fun id0 -> prset (fun (c,copt,id) -> hov 0 @@ -161,7 +161,7 @@ let constr_display csr = let rec term_display c = match kind_of_term c with | Rel n -> "Rel("^(string_of_int n)^")" | Meta n -> "Meta("^(string_of_int n)^")" - | Var id -> "Var("^(string_of_id id)^")" + | Var id -> "Var("^(Id.to_string id)^")" | Sort s -> "Sort("^(sort_display s)^")" | Cast (c,k, t) -> "Cast("^(term_display c)^","^(cast_kind_display k)^","^(term_display t)^")" @@ -211,7 +211,7 @@ let constr_display csr = "Type("^(string_of_int !cnt)^")" and name_display = function - | Name id -> "Name("^(string_of_id id)^")" + | Name id -> "Name("^(Id.to_string id)^")" | Anonymous -> "Anonymous" in @@ -223,14 +223,14 @@ let print_pure_constr csr = let rec term_display c = match kind_of_term c with | Rel n -> print_string "#"; print_int n | Meta n -> print_string "Meta("; print_int n; print_string ")" - | Var id -> print_string (string_of_id id) + | Var id -> print_string (Id.to_string id) | Sort s -> sort_display s | Cast (c,_, t) -> open_hovbox 1; print_string "("; (term_display c); print_cut(); print_string "::"; (term_display t); print_string ")"; close_box() | Prod (Name(id),t,c) -> open_hovbox 1; - print_string"("; print_string (string_of_id id); + print_string"("; print_string (Id.to_string id); print_string ":"; box_display t; print_string ")"; print_cut(); box_display c; close_box() @@ -315,13 +315,13 @@ let print_pure_constr csr = print_string "Type("; pp (pr_uni u); print_string ")"; close_box() and name_display = function - | Name id -> print_string (string_of_id id) + | Name id -> print_string (Id.to_string id) | Anonymous -> print_string "_" (* Remove the top names for library and Scratch to avoid long names *) and sp_display sp = (* let dir,l = decode_kn sp in let ls = - match List.rev (List.map string_of_id (repr_dirpath dir)) with + match List.rev (List.map Id.to_string (repr_dirpath dir)) with ("Top"::l)-> l | ("Coq"::_::l) -> l | l -> l @@ -330,7 +330,7 @@ let print_pure_constr csr = and sp_con_display sp = (* let dir,l = decode_kn sp in let ls = - match List.rev (List.map string_of_id (repr_dirpath dir)) with + match List.rev (List.map Id.to_string (repr_dirpath dir)) with ("Top"::l)-> l | ("Coq"::_::l) -> l | l -> l @@ -421,7 +421,7 @@ let _ = [[GramTerminal "PrintConstr"; GramNonTerminal (Loc.ghost,ConstrArgType,Aentry ("constr","constr"), - Some (Names.id_of_string "c"))]] + Some (Names.Id.of_string "c"))]] let _ = try @@ -438,7 +438,7 @@ let _ = [[GramTerminal "PrintPureConstr"; GramNonTerminal (Loc.ghost,ConstrArgType,Aentry ("constr","constr"), - Some (Names.id_of_string "c"))]] + Some (Names.Id.of_string "c"))]] (* Setting printer of unbound global reference *) open Names @@ -451,7 +451,7 @@ let encode_path loc prefix mpdir suffix id = (repr_dirpath (dirpath_of_string (string_of_mp mp))@ repr_dirpath dir) in Qualid (loc, make_qualid - (make_dirpath (List.rev (id_of_string prefix::dir@suffix))) id) + (make_dirpath (List.rev (Id.of_string prefix::dir@suffix))) id) let raw_string_of_ref loc = function | ConstRef cst -> @@ -460,12 +460,12 @@ let raw_string_of_ref loc = function | IndRef (kn,i) -> let (mp,dir,id) = repr_mind kn in encode_path loc "IND" (Some (mp,dir)) [id_of_label id] - (id_of_string ("_"^string_of_int i)) + (Id.of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> let (mp,dir,id) = repr_mind kn in encode_path loc "CSTR" (Some (mp,dir)) - [id_of_label id;id_of_string ("_"^string_of_int i)] - (id_of_string ("_"^string_of_int j)) + [id_of_label id;Id.of_string ("_"^string_of_int i)] + (Id.of_string ("_"^string_of_int j)) | VarRef id -> encode_path loc "SECVAR" None [] id @@ -475,11 +475,11 @@ let short_string_of_ref loc = function | IndRef (kn,0) -> Ident (loc,id_of_label (pi3 (repr_mind kn))) | IndRef (kn,i) -> encode_path loc "IND" None [id_of_label (pi3 (repr_mind kn))] - (id_of_string ("_"^string_of_int i)) + (Id.of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> encode_path loc "CSTR" None - [id_of_label (pi3 (repr_mind kn));id_of_string ("_"^string_of_int i)] - (id_of_string ("_"^string_of_int j)) + [id_of_label (pi3 (repr_mind kn));Id.of_string ("_"^string_of_int i)] + (Id.of_string ("_"^string_of_int j)) (* Anticipate that printers can be used from ocamldebug and that pretty-printer should not make calls to the global env since ocamldebug diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 59545d8aa..50207157b 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -34,7 +34,7 @@ let print_idkey idk = print_string "Cons("; print_string (string_of_con sp); print_string ")" - | VarKey id -> print_string (string_of_id id) + | VarKey id -> print_string (Id.to_string id) | RelKey i -> print_string "~";print_int i let rec ppzipper z = diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 9c31e2c82..c11ffddbf 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -121,7 +121,7 @@ let possibly_empty_subentries loc (prods,act) = let bind_name p v e = match p with | None -> e | Some id -> - let s = Names.string_of_id id in <:expr< let $lid:s$ = $v$ in $e$ >> in + let s = Names.Id.to_string id in <:expr< let $lid:s$ = $v$ in $e$ >> in let rec aux = function | [] -> <:expr< let loc = $default_loc$ in let _ = loc = loc in $act$ >> | GramNonTerminal(_,OptArgType _,_,p) :: tl -> @@ -130,7 +130,7 @@ let possibly_empty_subentries loc (prods,act) = bind_name p <:expr< [] >> (aux tl) | GramNonTerminal(_,(ExtraArgType _ as t),_,p) :: tl -> (* We check at runtime if extraarg s parses "epsilon" *) - let s = match p with None -> "_" | Some id -> Names.string_of_id id in + let s = match p with None -> "_" | Some id -> Names.Id.to_string id in <:expr< let $lid:s$ = match Genarg.default_empty_value $make_rawwit loc t$ with [ None -> raise Exit | Some v -> v ] in $aux tl$ >> @@ -163,7 +163,7 @@ let make_act loc act pil = let rec make = function | [] -> <:expr< Pcoq.Gram.action (fun loc -> ($act$ : 'a)) >> | GramNonTerminal (_,t,_,Some p) :: tl -> - let p = Names.string_of_id p in + let p = Names.Id.to_string p in <:expr< Pcoq.Gram.action (fun $lid:p$ -> @@ -316,10 +316,10 @@ EXTEND genarg: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let t, g = interp_entry_name false None e "" in - GramNonTerminal (!@loc, t, g, Some (Names.id_of_string s)) + GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let t, g = interp_entry_name false None e sep in - GramNonTerminal (!@loc, t, g, Some (Names.id_of_string s)) + GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | s = STRING -> if String.length s > 0 && Util.is_letter s.[0] then Lexer.add_keyword s; diff --git a/grammar/q_constr.ml4 b/grammar/q_constr.ml4 index 5d46897c6..130f14717 100644 --- a/grammar/q_constr.ml4 +++ b/grammar/q_constr.ml4 @@ -33,7 +33,7 @@ EXTEND | "Type" -> Misctypes.GType None ] ] ; ident: - [ [ s = string -> <:expr< Names.id_of_string $str:s$ >> ] ] + [ [ s = string -> <:expr< Names.Id.of_string $str:s$ >> ] ] ; name: [ [ "_" -> <:expr< Anonymous >> | id = ident -> <:expr< Name $id$ >> ] ] diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 index 4fe6d6aa1..e879f2fff 100644 --- a/grammar/q_coqast.ml4 +++ b/grammar/q_coqast.ml4 @@ -25,12 +25,12 @@ let loc = CompatLoc.ghost let dloc = <:expr< Loc.ghost >> let mlexpr_of_ident id = - <:expr< Names.id_of_string $str:Names.string_of_id id$ >> + <:expr< Names.Id.of_string $str:Names.Id.to_string id$ >> let mlexpr_of_name = function | Names.Anonymous -> <:expr< Names.Anonymous >> | Names.Name id -> - <:expr< Names.Name (Names.id_of_string $str:Names.string_of_id id$) >> + <:expr< Names.Name (Names.Id.of_string $str:Names.Id.to_string id$) >> let mlexpr_of_dirpath dir = let l = Names.repr_dirpath dir in @@ -139,9 +139,9 @@ let mlexpr_of_binder_kind = function $mlexpr_of_binding_kind b'$ $mlexpr_of_bool b''$ >> let rec mlexpr_of_constr = function - | Constrexpr.CRef (Libnames.Ident (loc,id)) when is_meta (string_of_id id) -> + | Constrexpr.CRef (Libnames.Ident (loc,id)) when is_meta (Id.to_string id) -> let loc = of_coqloc loc in - anti loc (string_of_id id) + anti loc (Id.to_string id) | Constrexpr.CRef r -> <:expr< Constrexpr.CRef $mlexpr_of_reference r$ >> | Constrexpr.CFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" | Constrexpr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index f74031687..41cd830b5 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -22,7 +22,7 @@ open Compat let rec make_patt = function | [] -> <:patt< [] >> | GramNonTerminal(loc',_,_,Some p)::l -> - let p = Names.string_of_id p in + let p = Names.Id.to_string p in <:patt< [ $lid:p$ :: $make_patt l$ ] >> | _::l -> make_patt l @@ -30,7 +30,7 @@ let rec make_when loc = function | [] -> <:expr< True >> | GramNonTerminal(loc',t,_,Some p)::l -> let loc' = of_coqloc loc' in - let p = Names.string_of_id p in + let p = Names.Id.to_string p in let l = make_when loc l in let loc = CompatLoc.merge loc' loc in let t = mlexpr_of_argtype loc' t in @@ -41,7 +41,7 @@ let rec make_let e = function | [] -> e | GramNonTerminal(loc,t,_,Some p)::l -> let loc = of_coqloc loc in - let p = Names.string_of_id p in + let p = Names.Id.to_string p in let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in let e = make_let e l in let v = <:expr< Genarg.out_gen $make_wit loc t$ $lid:p$ >> in @@ -73,7 +73,7 @@ let rec make_args = function | [] -> <:expr< [] >> | GramNonTerminal(loc,t,_,Some p)::l -> let loc = of_coqloc loc in - let p = Names.string_of_id p in + let p = Names.Id.to_string p in <:expr< [ Genarg.in_gen $make_wit loc t$ $lid:p$ :: $make_args l$ ] >> | _::l -> make_args l @@ -200,10 +200,10 @@ EXTEND tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let t, g = interp_entry_name false None e "" in - GramNonTerminal (!@loc, t, g, Some (Names.id_of_string s)) + GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let t, g = interp_entry_name false None e sep in - GramNonTerminal (!@loc, t, g, Some (Names.id_of_string s)) + GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | s = STRING -> if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str "Empty terminal."); GramTerminal s diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 29a59da79..9ae529ea0 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -21,7 +21,7 @@ let rec make_let e = function | [] -> e | GramNonTerminal(loc,t,_,Some p)::l -> let loc = of_coqloc loc in - let p = Names.string_of_id p in + let p = Names.Id.to_string p in let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in let e = make_let e l in <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> @@ -93,10 +93,10 @@ EXTEND args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let t, g = interp_entry_name false None e "" in - GramNonTerminal (!@loc, t, g, Some (Names.id_of_string s)) + GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let t, g = interp_entry_name false None e sep in - GramNonTerminal (!@loc, t, g, Some (Names.id_of_string s)) + GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | s = STRING -> GramTerminal s ] ] diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index d49219114..602c2314a 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -53,9 +53,9 @@ let prim_token_eq t1 t2 = match t1, t2 with let explicitation_eq ex1 ex2 = match ex1, ex2 with | ExplByPos (i1, id1), ExplByPos (i2, id2) -> - Int.equal i1 i2 && Option.equal id_eq id1 id2 + Int.equal i1 i2 && Option.equal Id.equal id1 id2 | ExplByName id1, ExplByName id2 -> - id_eq id1 id2 + Id.equal id1 id2 | _ -> false let eq_located f (_, x) (_, y) = f x y @@ -64,7 +64,7 @@ let rec cases_pattern_expr_eq p1 p2 = if p1 == p2 then true else match p1, p2 with | CPatAlias(_,a1,i1), CPatAlias(_,a2,i2) -> - id_eq i1 i2 && cases_pattern_expr_eq a1 a2 + Id.equal i1 i2 && cases_pattern_expr_eq a1 a2 | CPatCstr(_,c1,a1,b1), CPatCstr(_,c2,a2,b2) -> eq_reference c1 c2 && List.equal cases_pattern_expr_eq a1 a2 && @@ -97,10 +97,10 @@ let rec constr_expr_eq e1 e2 = else match e1, e2 with | CRef r1, CRef r2 -> eq_reference r1 r2 | CFix(_,id1,fl1), CFix(_,id2,fl2) -> - eq_located id_eq id1 id2 && + eq_located Id.equal id1 id2 && List.equal fix_expr_eq fl1 fl2 | CCoFix(_,id1,fl1), CCoFix(_,id2,fl2) -> - eq_located id_eq id1 id2 && + eq_located Id.equal id1 id2 && List.equal cofix_expr_eq fl1 fl2 | CProdN(_,bl1,a1), CProdN(_,bl2,a2) -> List.equal binder_expr_eq bl1 bl2 && @@ -145,7 +145,7 @@ let rec constr_expr_eq e1 e2 = constr_expr_eq f1 f2 | CHole _, CHole _ -> true | CPatVar(_,(b1, i1)), CPatVar(_,(b2, i2)) -> - (b1 : bool) == b2 && id_eq i1 i2 + (b1 : bool) == b2 && Id.equal i1 i2 | CEvar (_, ev1, c1), CEvar (_, ev2, c2) -> Int.equal ev1 ev2 && Option.equal (List.equal constr_expr_eq) c1 c2 @@ -188,15 +188,15 @@ and binder_expr_eq ((n1, _, e1) : binder_expr) (n2, _, e2) = List.equal (eq_located name_eq) n1 n2 && constr_expr_eq e1 e2 and fix_expr_eq (id1,(j1, r1),bl1,a1,b1) (id2,(j2, r2),bl2,a2,b2) = - (eq_located id_eq id1 id2) && - Option.equal (eq_located id_eq) j1 j2 && + (eq_located Id.equal id1 id2) && + Option.equal (eq_located Id.equal) j1 j2 && recursion_order_expr_eq r1 r2 && List.equal local_binder_eq bl1 bl2 && constr_expr_eq a1 a2 && constr_expr_eq b1 b2 and cofix_expr_eq (id1,bl1,a1,b1) (id2,bl2,a2,b2) = - (eq_located id_eq id1 id2) && + (eq_located Id.equal id1 id2) && List.equal local_binder_eq bl1 bl2 && constr_expr_eq a1 a2 && constr_expr_eq b1 b2 diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 8eb88f70d..49dea9f31 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -44,7 +44,7 @@ val local_binders_loc : local_binder list -> Loc.t (** {6 Constructors}*) -val mkIdentC : identifier -> constr_expr +val mkIdentC : Id.t -> constr_expr val mkRefC : reference -> constr_expr val mkAppC : constr_expr * constr_expr list -> constr_expr val mkCastC : constr_expr * constr_expr cast_type -> constr_expr @@ -63,10 +63,10 @@ val mkCProdN : Loc.t -> local_binder list -> constr_expr -> constr_expr (** {6 Destructors}*) -val coerce_reference_to_id : reference -> identifier +val coerce_reference_to_id : reference -> Id.t (** FIXME: nothing to do here *) -val coerce_to_id : constr_expr -> identifier located +val coerce_to_id : constr_expr -> Id.t located (** Destruct terms of the form [CRef (Ident _)]. *) val coerce_to_name : constr_expr -> name located diff --git a/interp/constrextern.ml b/interp/constrextern.ml index d0be33031..c91db464d 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -271,7 +271,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = match pat with | PatCstr(loc,cstrsp,args,na) when !in_debugger||Inductiveops.mis_constructor_has_local_defs cstrsp -> - let c = extern_reference loc Idset.empty (ConstructRef cstrsp) in + let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in let args = List.map (extern_cases_pattern_in_scope scopes vars) args in CPatCstr (loc, c, add_patt_for_params (fst cstrsp) args, []) | _ -> @@ -308,12 +308,12 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = | CPatAtom(_, None) :: tail -> ip q tail acc (* we don't want to have 'x = _' in our patterns *) | head :: tail -> ip q tail - ((extern_reference loc Idset.empty (ConstRef c), head) :: acc) + ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc) in CPatRecord(loc, List.rev (ip projs args [])) with Not_found | No_match | Exit -> - let c = extern_reference loc Idset.empty (ConstructRef cstrsp) in + let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in if !Topconstr.oldfashion_patterns then if pattern_printable_in_both_syntax cstrsp then CPatCstr (loc, c, [], args) @@ -638,7 +638,7 @@ let rec extern inctx scopes vars r = | [] -> raise No_match (* we give up since the constructor is not complete *) | head :: tail -> ip q locs' tail - ((extern_reference loc Idset.empty (ConstRef c), head) :: acc) + ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc) in CRecord (loc, None, List.rev (ip projs locals args [])) with @@ -667,7 +667,7 @@ let rec extern inctx scopes vars r = | GCases (loc,sty,rtntypopt,tml,eqns) -> let vars' = - List.fold_right (name_fold Idset.add) + List.fold_right (name_fold Id.Set.add) (cases_predicate_names tml) vars in let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in let tml = List.map (fun (tm,(na,x)) -> @@ -681,7 +681,7 @@ let rec extern inctx scopes vars r = else None end | Anonymous, _ -> None - | Name id, GVar (_,id') when id_eq id id' -> None + | Name id, GVar (_,id') when Id.equal id id' -> None | Name _, _ -> Some (Loc.ghost,na) in (sub_extern false scopes vars tm, (na',Option.map (fun (loc,ind,nal) -> @@ -708,15 +708,15 @@ let rec extern inctx scopes vars r = sub_extern inctx scopes vars b1, sub_extern inctx scopes vars b2) | GRec (loc,fk,idv,blv,tyv,bv) -> - let vars' = Array.fold_right Idset.add idv vars in + let vars' = Array.fold_right Id.Set.add idv vars in (match fk with | GFix (nv,n) -> let listdecl = Array.mapi (fun i fi -> let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in let (assums,ids,bl) = extern_local_binder scopes vars bl in - let vars0 = List.fold_right (name_fold Idset.add) ids vars in - let vars1 = List.fold_right (name_fold Idset.add) ids vars' in + let vars0 = List.fold_right (name_fold Id.Set.add) ids vars in + let vars1 = List.fold_right (name_fold Id.Set.add) ids vars' in let n = match fst nv.(i) with | None -> None @@ -731,8 +731,8 @@ let rec extern inctx scopes vars r = let listdecl = Array.mapi (fun i fi -> let (_,ids,bl) = extern_local_binder scopes vars blv.(i) in - let vars0 = List.fold_right (name_fold Idset.add) ids vars in - let vars1 = List.fold_right (name_fold Idset.add) ids vars' in + let vars0 = List.fold_right (name_fold Id.Set.add) ids vars in + let vars1 = List.fold_right (name_fold Id.Set.add) ids vars' in ((Loc.ghost, fi),bl,extern_typ scopes vars0 tyv.(i), sub_extern false scopes vars1 bv.(i))) idv in @@ -775,13 +775,13 @@ and extern_local_binder scopes vars = function [] -> ([],[],[]) | (na,bk,Some bd,ty)::l -> let (assums,ids,l) = - extern_local_binder scopes (name_fold Idset.add na vars) l in + extern_local_binder scopes (name_fold Id.Set.add na vars) l in (assums,na::ids, LocalRawDef((Loc.ghost,na), extern false scopes vars bd) :: l) | (na,bk,None,ty)::l -> let ty = extern_typ scopes vars (anonymize_if_reserved na ty) in - (match extern_local_binder scopes (name_fold Idset.add na vars) l with + (match extern_local_binder scopes (name_fold Id.Set.add na vars) l with (assums,ids,LocalRawAssum(nal,k,ty')::l) when constr_expr_eq ty ty' & match na with Name id -> not (occur_var_constr_expr id ty') @@ -933,7 +933,7 @@ let rec glob_of_pat env = function | Name id -> id | Anonymous -> anomaly "glob_constr_of_pattern: index to an anonymous variable" - with Not_found -> id_of_string ("_UNBOUND_REL_"^(string_of_int n)) in + with Not_found -> Id.of_string ("_UNBOUND_REL_"^(string_of_int n)) in GVar (loc,id) | PMeta None -> GHole (loc,Evar_kinds.InternalHole) | PMeta (Some n) -> GPatVar (loc,(false,n)) @@ -976,7 +976,7 @@ let rec glob_of_pat env = function | PSort s -> GSort (loc,s) let extern_constr_pattern env pat = - extern true (None,[]) Idset.empty (glob_of_pat env pat) + extern true (None,[]) Id.Set.empty (glob_of_pat env pat) let extern_rel_context where env sign = let a = detype_rel_context where [] (names_of_rel_context env) sign in diff --git a/interp/constrextern.mli b/interp/constrextern.mli index 0ca25656f..0e40e83e6 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -25,9 +25,9 @@ open Misctypes (** Translation of pattern, cases pattern, glob_constr and term into syntax trees for printing *) -val extern_cases_pattern : Idset.t -> cases_pattern -> cases_pattern_expr -val extern_glob_constr : Idset.t -> glob_constr -> constr_expr -val extern_glob_type : Idset.t -> glob_constr -> constr_expr +val extern_cases_pattern : Id.Set.t -> cases_pattern -> cases_pattern_expr +val extern_glob_constr : Id.Set.t -> glob_constr -> constr_expr +val extern_glob_type : Id.Set.t -> glob_constr -> constr_expr val extern_constr_pattern : names_context -> constr_pattern -> constr_expr (** If [b=true] in [extern_constr b env c] then the variables in the first @@ -35,7 +35,7 @@ val extern_constr_pattern : names_context -> constr_pattern -> constr_expr val extern_constr : bool -> env -> constr -> constr_expr val extern_constr_in_scope : bool -> scope_name -> env -> constr -> constr_expr -val extern_reference : Loc.t -> Idset.t -> global_reference -> reference +val extern_reference : Loc.t -> Id.Set.t -> global_reference -> reference val extern_type : bool -> env -> types -> constr_expr val extern_sort : sorts -> glob_sort val extern_rel_context : constr option -> env -> diff --git a/interp/constrintern.ml b/interp/constrintern.ml index e4df61c47..f4fff70db 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -46,7 +46,7 @@ open Decl_kinds types and recursive definitions and of projection names in records *) type var_internalization_type = - | Inductive of identifier list (* list of params *) + | Inductive of Id.t list (* list of params *) | Recursive | Method | Variable @@ -57,14 +57,14 @@ type var_internalization_data = var_internalization_type * (* impargs to automatically add to the variable, e.g. for "JMeq A a B b" in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *) - identifier list * + Id.t list * (* signature of impargs of the variable *) Impargs.implicit_status list * (* subscopes of the args of the variable *) scope_name option list type internalization_env = - (var_internalization_data) Idmap.t + (var_internalization_data) Id.Map.t type glob_binder = (name * binding_kind * glob_constr option * glob_constr) @@ -109,11 +109,11 @@ let global_reference_in_absolute_module dir id = (* Internalization errors *) type internalization_error = - | VariableCapture of identifier * identifier + | VariableCapture of Id.t * Id.t | IllegalMetavariable | NotAConstructor of reference - | UnboundFixName of bool * identifier - | NonLinearPattern of identifier + | UnboundFixName of bool * Id.t + | NonLinearPattern of Id.t | BadPatternsNumber of int * int exception InternalizationError of Loc.t * internalization_error @@ -165,7 +165,7 @@ let error_parameter_not_implicit loc = let parsing_explicit = ref false -let empty_internalization_env = Idmap.empty +let empty_internalization_env = Id.Map.empty let compute_explicitable_implicit imps = function | Inductive params -> @@ -184,7 +184,7 @@ let compute_internalization_data env ty typ impl = let compute_internalization_env env ty = List.fold_left3 - (fun map id typ impl -> Idmap.add id (compute_internalization_data env ty typ impl) map) + (fun map id typ impl -> Id.Map.add id (compute_internalization_data env ty typ impl) map) empty_internalization_env (**********************************************************************) @@ -234,7 +234,7 @@ let contract_pat_notation ntn (l,ll) = !ntn',(l,ll) type intern_env = { - ids: Names.Idset.t; + ids: Names.Id.Set.t; unb: bool; tmp_scope: Notation_term.tmp_scope_name option; scopes: Notation_term.scope_name list; @@ -354,14 +354,14 @@ let locate_if_isevar loc na = function | x -> x let reset_hidden_inductive_implicit_test env = - { env with impls = Idmap.fold (fun id x -> + { env with impls = Id.Map.fold (fun id x -> let x = match x with | (Inductive _,b,c,d) -> (Inductive [],b,c,d) | x -> x - in Idmap.add id x) env.impls Idmap.empty } + in Id.Map.add id x) env.impls Id.Map.empty } let check_hidden_implicit_parameters id impls = - if Idmap.exists (fun _ -> function + if Id.Map.exists (fun _ -> function | (Inductive indparams,_,_,_) -> List.mem id indparams | _ -> false) impls then @@ -379,11 +379,11 @@ let push_name_env ?(global_level=false) lvar implargs env = set_var_scope loc id false env (let (_,ntnvars) = lvar in ntnvars); if global_level then Dumpglob.dump_definition (loc,id) true "var" else Dumpglob.dump_binding loc id; - {env with ids = Idset.add id env.ids; impls = Idmap.add id implargs env.impls} + {env with ids = Id.Set.add id env.ids; impls = Id.Map.add id implargs env.impls} let intern_generalized_binder ?(global_level=false) intern_type lvar env (loc, na) b b' t ty = - let ids = (match na with Anonymous -> fun x -> x | Name na -> Idset.add na) env.ids in + let ids = (match na with Anonymous -> fun x -> x | Name na -> Id.Set.add na) env.ids in let ty, ids' = if t then ty, ids else Implicit_quantifiers.implicit_application ids @@ -407,7 +407,7 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar let id = match ty with | CApp (_, (_, CRef (Ident (loc,id))), _) -> id - | _ -> id_of_string "H" + | _ -> Id.of_string "H" in Implicit_quantifiers.make_fresh ids' (Global.env ()) id in Name name | _ -> na @@ -469,7 +469,7 @@ let intern_generalization intern env lvar loc bk ak c = (* Syntax extensions *) let option_mem_assoc id = function - | Some (id',c) -> id_eq id id' + | Some (id',c) -> Id.equal id id' | None -> false let find_fresh_name renaming (terms,termlists,binders) id = @@ -477,7 +477,7 @@ let find_fresh_name renaming (terms,termlists,binders) id = let fvs2 = List.flatten (List.map (fun (_,(l,_)) -> List.map free_vars_of_constr_expr l) termlists) in let fvs3 = List.map snd renaming in (* TODO binders *) - let fvs = List.flatten (List.map Idset.elements (fvs1@fvs2)) @ fvs3 in + let fvs = List.flatten (List.map Id.Set.elements (fvs1@fvs2)) @ fvs3 in next_ident_away id fvs let traverse_binder (terms,_,_ as subst) @@ -488,12 +488,12 @@ let traverse_binder (terms,_,_ as subst) try (* Binders bound in the notation are considered first-order objects *) let _,na = coerce_to_name (fst (List.assoc id terms)) in - (renaming,{env with ids = name_fold Idset.add na env.ids}), na + (renaming,{env with ids = name_fold Id.Set.add na env.ids}), na with Not_found -> (* Binders not bound in the notation do not capture variables *) (* outside the notation (i.e. in the substitution) *) let id' = find_fresh_name renaming subst id in - let renaming' = if id_eq id id' then renaming else (id,id')::renaming in + let renaming' = if Id.equal id id' then renaming else (id,id')::renaming in (renaming',env), Name id' let make_letins = List.fold_right (fun (loc,(na,b,t)) c -> GLetIn (loc,na,b,c)) @@ -510,7 +510,7 @@ let rec subordinate_letins letins = function letins,[] let rec subst_iterator y t = function - | GVar (_,id) as x -> if id_eq id y then t else x + | GVar (_,id) as x -> if Id.equal id y then t else x | x -> map_glob_constr (subst_iterator y t) x let subst_aconstr_in_glob_constr loc intern lvar subst infos c = @@ -607,15 +607,15 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = let (ltacvars,unbndltacvars) = ltacvars in (* Is [id] an inductive type potentially with implicit *) try - let ty,expl_impls,impls,argsc = Idmap.find id genv.impls in + let ty,expl_impls,impls,argsc = Id.Map.find id genv.impls in let expl_impls = List.map (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) expl_impls in let tys = string_of_ty ty in - Dumpglob.dump_reference loc "<>" (string_of_id id) tys; + Dumpglob.dump_reference loc "<>" (Id.to_string id) tys; GVar (loc,id), make_implicits_list impls, argsc, expl_impls with Not_found -> (* Is [id] bound in current term or is an ltac var bound to constr *) - if Idset.mem id genv.ids or List.mem id ltacvars + if Id.Set.mem id genv.ids or List.mem id ltacvars then GVar (loc,id), [], [], [] (* Is [id] a notation variable *) @@ -624,7 +624,7 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = then (set_var_scope loc id true genv ntnvars; GVar (loc,id), [], [], []) (* Is [id] the special variable for recursive notations *) - else if ntnvars != [] && id_eq id ldots_var + else if ntnvars != [] && Id.equal id ldots_var then GVar (loc,id), [], [], [] else @@ -722,7 +722,7 @@ let intern_applied_reference intern env namedctx lvar args = function let interp_reference vars r = let (r,_,_,_),_ = intern_applied_reference (fun _ -> error_not_enough_arguments Loc.ghost) - {ids = Idset.empty; unb = false ; + {ids = Id.Set.empty; unb = false ; tmp_scope = None; scopes = []; impls = empty_internalization_env} [] (vars,[]) [] r in r @@ -912,7 +912,7 @@ let sort_fields mode loc l completer = let ind = record.Recordops.s_CONST in try (* insertion of Constextern.reference_global *) (record.Recordops.s_EXPECTEDPARAM, - Qualid (loc, shortest_qualid_of_global Idset.empty (ConstructRef ind)), + Qualid (loc, shortest_qualid_of_global Id.Set.empty (ConstructRef ind)), build_patt record.Recordops.s_PROJ record.Recordops.s_PROJKIND 1 (0,[])) with Not_found -> anomaly "Environment corruption for records." in @@ -987,7 +987,7 @@ let message_redundant_alias (id1,id2) = let rec subst_pat_iterator y t p = match p with | RCPatAtom (_,id) -> - begin match id with Some x when id_eq x y -> t | _ -> p end + begin match id with Some x when Id.equal x y -> t | _ -> p end | RCPatCstr (loc,id,l1,l2) -> RCPatCstr (loc,id,List.map (subst_pat_iterator y t) l1, List.map (subst_pat_iterator y t) l2) @@ -1093,8 +1093,8 @@ let drop_notations_pattern looked_for = in_pat {env with scopes=subscopes@env.scopes; tmp_scope = scopt} a with Not_found -> - if id_eq id ldots_var then RCPatAtom (loc,Some id) else - anomaly ("Unbound pattern notation variable: "^(string_of_id id)) + if Id.equal id ldots_var then RCPatAtom (loc,Some id) else + anomaly ("Unbound pattern notation variable: "^(Id.to_string id)) end | NRef g -> looked_for g; @@ -1209,7 +1209,7 @@ let check_projection isproj nargs r = user_err_loc (loc,"",str "Projection has not the right number of explicit parameters."); with Not_found -> user_err_loc - (loc,"",pr_global_env Idset.empty ref ++ str " is not a registered projection.")) + (loc,"",pr_global_env Id.Set.empty ref ++ str " is not a registered projection.")) | _, Some _ -> user_err_loc (loc_of_glob_constr r, "", str "Not a projection.") | _, None -> () @@ -1222,7 +1222,7 @@ let set_hole_implicit i b = function | _ -> anomaly "Only refs have implicits" let exists_implicit_name id = - List.exists (fun imp -> is_status_implicit imp && id_eq id (name_of_implicit imp)) + List.exists (fun imp -> is_status_implicit imp && Id.equal id (name_of_implicit imp)) let extract_explicit_arg imps args = let rec aux = function @@ -1403,19 +1403,19 @@ let internalize sigma globalenv env allow_patvar lvar c = end | CCases (loc, sty, rtnpo, tms, eqns) -> let as_in_vars = List.fold_left (fun acc (_,(na,inb)) -> - Option.fold_left (fun x tt -> List.fold_right Idset.add (ids_of_cases_indtype tt) x) - (Option.fold_left (fun x (_,y) -> match y with | Name y' -> Idset.add y' x |_ -> x) acc na) - inb) Idset.empty tms in + Option.fold_left (fun x tt -> List.fold_right Id.Set.add (ids_of_cases_indtype tt) x) + (Option.fold_left (fun x (_,y) -> match y with | Name y' -> Id.Set.add y' x |_ -> x) acc na) + inb) Id.Set.empty tms in (* as, in & return vars *) let forbidden_vars = Option.cata free_vars_of_constr_expr as_in_vars rtnpo in let tms,ex_ids,match_from_in = List.fold_right (fun citm (inds,ex_ids,matchs) -> let ((tm,ind),extra_id,match_td) = intern_case_item env forbidden_vars citm in - (tm,ind)::inds, Option.fold_right Idset.add extra_id ex_ids, List.rev_append match_td matchs) - tms ([],Idset.empty,[]) in - let env' = Idset.fold + (tm,ind)::inds, Option.fold_right Id.Set.add extra_id ex_ids, List.rev_append match_td matchs) + tms ([],Id.Set.empty,[]) in + let env' = Id.Set.fold (fun var bli -> push_name_env lvar (Variable,[],[],[]) bli (Loc.ghost,Name var)) - (Idset.union ex_ids as_in_vars) (reset_hidden_inductive_implicit_test env) in + (Id.Set.union ex_ids as_in_vars) (reset_hidden_inductive_implicit_test env) in (* PatVars before a real pattern do not need to be matched *) let stripped_match_from_in = let rec aux = function |[] -> [] @@ -1438,7 +1438,7 @@ let internalize sigma globalenv env allow_patvar lvar c = | CLetTuple (loc, nal, (na,po), b, c) -> let env' = reset_tmp_scope env in (* "in" is None so no match to add *) - let ((b',(na',_)),_,_) = intern_case_item env' Idset.empty (b,(na,None)) in + let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,(na,None)) in let p' = Option.map (fun u -> let env'' = push_name_env lvar (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') (Loc.ghost,na') in @@ -1447,7 +1447,7 @@ let internalize sigma globalenv env allow_patvar lvar c = intern (List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) | CIf (loc, c, (na,po), b1, b2) -> let env' = reset_tmp_scope env in - let ((c',(na',_)),_,_) = intern_case_item env' Idset.empty (c,(na,None)) in (* no "in" no match to ad too *) + let ((c',(na',_)),_,_) = intern_case_item env' Id.Set.empty (c,(na,None)) in (* no "in" no match to ad too *) let p' = Option.map (fun p -> let env'' = push_name_env lvar (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env) (Loc.ghost,na') in @@ -1492,7 +1492,7 @@ let internalize sigma globalenv env allow_patvar lvar c = let eqn_ids,pll = intern_disjunctive_multiple_pattern env loc n lhs in (* Linearity implies the order in ids is irrelevant *) check_linearity lhs eqn_ids; - let env_ids = List.fold_right Idset.add eqn_ids env.ids in + let env_ids = List.fold_right Id.Set.add eqn_ids env.ids in List.map (fun (asubst,pl) -> let rhs = replace_vars_constr_expr asubst rhs in List.iter message_redundant_alias asubst; @@ -1504,7 +1504,7 @@ let internalize sigma globalenv env allow_patvar lvar c = let tm' = intern env tm in (* the "as" part *) let extra_id,na = match tm', na with - | GVar (loc,id), None when Idset.mem id env.ids -> Some id,(loc,Name id) + | GVar (loc,id), None when Id.Set.mem id env.ids -> Some id,(loc,Name id) | GRef (loc, VarRef id), None -> Some id,(loc,Name id) | _, None -> None,(Loc.ghost,Anonymous) | _, Some (loc,na) -> None,(loc,na) in @@ -1512,7 +1512,7 @@ let internalize sigma globalenv env allow_patvar lvar c = let match_td,typ = match t with | Some t -> let tids = ids_of_cases_indtype t in - let tids = List.fold_right Idset.add tids Idset.empty in + let tids = List.fold_right Id.Set.add tids Id.Set.empty in let with_letin,(ind,l) = intern_ind_pattern globalenv {env with ids = tids; tmp_scope = None} t in let (mib,mip) = Inductive.lookup_mind_specif globalenv ind in let nparams = (List.length (mib.Declarations.mind_params_ctxt)) in @@ -1544,7 +1544,7 @@ let internalize sigma globalenv env allow_patvar lvar c = |_ -> assert false in let _,args_rel = List.chop nparams (List.rev mip.Declarations.mind_arity_ctxt) in - canonize_args args_rel l (Idset.elements forbidden_names_for_gen) [] [] in + canonize_args args_rel l (Id.Set.elements forbidden_names_for_gen) [] [] in match_to_do, Some (cases_pattern_expr_loc t,ind,List.rev_map snd nal) | None -> [], None in @@ -1618,9 +1618,9 @@ let internalize sigma globalenv env allow_patvar lvar c = (**************************************************************************) let extract_ids env = - List.fold_right Idset.add + List.fold_right Id.Set.add (Termops.ids_of_rel_context (Environ.rel_context env)) - Idset.empty + Id.Set.empty let scope_of_type_kind = function | IsType -> Some Notation.type_scope @@ -1674,7 +1674,7 @@ let interp_open_constr sigma env c = let interp_open_constr_patvar sigma env c = let raw = intern_gen (OfType None) sigma env c ~allow_patvar:true in let sigma = ref sigma in - let evars = ref (Gmap.empty : (identifier,glob_constr) Gmap.t) in + let evars = ref (Gmap.empty : (Id.t,glob_constr) Gmap.t) in let rec patvar_to_evar r = match r with | GPatVar (loc,(_,id)) -> ( try Gmap.find id !evars @@ -1724,7 +1724,7 @@ let interp_casted_constr_evars evdref env ?(impls=empty_internalization_env) c t let interp_type_evars evdref env ?(impls=empty_internalization_env) c = interp_constr_evars_gen evdref env IsType ~impls c -type ltac_sign = identifier list * unbound_ltac_var_map +type ltac_sign = Id.t list * unbound_ltac_var_map let intern_constr_pattern sigma env ?(as_type=false) ?(ltacvars=([],[])) c = let c = intern_gen (if as_type then IsType else OfType None) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 28e7e2985..6cb97fd60 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -41,7 +41,7 @@ open Decl_kinds of [env] *) type var_internalization_type = - | Inductive of identifier list (* list of params *) + | Inductive of Id.t list (* list of params *) | Recursive | Method | Variable @@ -50,14 +50,14 @@ type var_internalization_data = var_internalization_type * (** type of the "free" variable, for coqdoc, e.g. while typing the constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) - identifier list * + Id.t list * (** impargs to automatically add to the variable, e.g. for "JMeq A a B b" in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *) Impargs.implicit_status list * (** signature of impargs of the variable *) Notation_term.scope_name option list (** subscopes of the args of the variable *) (** A map of free variables to their implicit arguments and scopes *) -type internalization_env = var_internalization_data Idmap.t +type internalization_env = var_internalization_data Id.Map.t val empty_internalization_env : internalization_env @@ -65,10 +65,10 @@ val compute_internalization_data : env -> var_internalization_type -> types -> Impargs.manual_explicitation list -> var_internalization_data val compute_internalization_env : env -> var_internalization_type -> - identifier list -> types list -> Impargs.manual_explicitation list list -> + Id.t list -> types list -> Impargs.manual_explicitation list list -> internalization_env -type ltac_sign = identifier list * unbound_ltac_var_map +type ltac_sign = Id.t list * unbound_ltac_var_map type glob_binder = (name * binding_kind * glob_constr option * glob_constr) @@ -83,8 +83,8 @@ val intern_gen : typing_constraint -> evar_map -> env -> constr_expr -> glob_constr val intern_pattern : env -> cases_pattern_expr -> - Names.identifier list * - ((Names.identifier * Names.identifier) list * cases_pattern) list + Names.Id.t list * + ((Names.Id.t * Names.Id.t) list * cases_pattern) list val intern_context : bool -> evar_map -> env -> internalization_env -> local_binder list -> internalization_env * glob_binder list @@ -168,19 +168,19 @@ val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env - (** Locating references of constructions, possibly via a syntactic definition (these functions do not modify the glob file) *) -val is_global : identifier -> bool -val construct_reference : named_context -> identifier -> constr -val global_reference : identifier -> constr -val global_reference_in_absolute_module : dir_path -> identifier -> constr +val is_global : Id.t -> bool +val construct_reference : named_context -> Id.t -> constr +val global_reference : Id.t -> constr +val global_reference_in_absolute_module : dir_path -> Id.t -> constr (** Interprets a term as the left-hand side of a notation; the boolean list is a set and this set is [true] for a variable occurring in term position, [false] for a variable occurring in binding position; [true;false] if in both kinds of position *) val interp_notation_constr : ?impls:internalization_env -> - (identifier * notation_var_internalization_type) list -> - (identifier * identifier) list -> constr_expr -> - (identifier * (subscopes * notation_var_internalization_type)) list * + (Id.t * notation_var_internalization_type) list -> + (Id.t * Id.t) list -> constr_expr -> + (Id.t * (subscopes * notation_var_internalization_type)) list * notation_constr (** Globalization options *) diff --git a/interp/coqlib.ml b/interp/coqlib.ml index 607355873..4b2ca2004 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -21,10 +21,10 @@ open Smartlocate type message = string -let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) +let make_dir l = make_dirpath (List.map Id.of_string (List.rev l)) let find_reference locstr dir s = - let sp = Libnames.make_path (make_dir dir) (id_of_string s) in + let sp = Libnames.make_path (make_dir dir) (Id.of_string s) in try global_of_extended_global (Nametab.extended_global_of_path sp) with Not_found -> anomaly (locstr^": cannot find "^(string_of_path sp)) @@ -63,7 +63,7 @@ let gen_constant_in_modules locstr dirs s = (* For tactics/commands requiring vernacular libraries *) let check_required_library d = - let d' = List.map id_of_string d in + let d' = List.map Id.of_string d in let dir = make_dirpath (List.rev d') in let mp = (fst(Lib.current_prefix())) in let current_dir = match mp with @@ -130,14 +130,14 @@ let make_con dir id = Globnames.encode_con dir id (** Identity *) -let id = make_con datatypes_module (id_of_string "id") -let type_of_id = make_con datatypes_module (id_of_string "ID") +let id = make_con datatypes_module (Id.of_string "id") +let type_of_id = make_con datatypes_module (Id.of_string "ID") let _ = Termops.set_impossible_default_clause (mkConst id,mkConst type_of_id) (** Natural numbers *) -let nat_kn = make_kn datatypes_module (id_of_string "nat") -let nat_path = Libnames.make_path datatypes_module (id_of_string "nat") +let nat_kn = make_kn datatypes_module (Id.of_string "nat") +let nat_path = Libnames.make_path datatypes_module (Id.of_string "nat") let glob_nat = IndRef (nat_kn,0) @@ -147,7 +147,7 @@ let glob_O = ConstructRef path_of_O let glob_S = ConstructRef path_of_S (** Booleans *) -let bool_kn = make_kn datatypes_module (id_of_string "bool") +let bool_kn = make_kn datatypes_module (Id.of_string "bool") let glob_bool = IndRef (bool_kn,0) @@ -157,13 +157,13 @@ let glob_true = ConstructRef path_of_true let glob_false = ConstructRef path_of_false (** Equality *) -let eq_kn = make_kn logic_module (id_of_string "eq") +let eq_kn = make_kn logic_module (Id.of_string "eq") let glob_eq = IndRef (eq_kn,0) -let identity_kn = make_kn datatypes_module (id_of_string "identity") +let identity_kn = make_kn datatypes_module (Id.of_string "identity") let glob_identity = IndRef (identity_kn,0) -let jmeq_kn = make_kn jmeq_module (id_of_string "JMeq") +let jmeq_kn = make_kn jmeq_module (Id.of_string "JMeq") let glob_jmeq = IndRef (jmeq_kn,0) type coq_sigma_data = { @@ -278,8 +278,8 @@ let build_coq_jmeq_data () = congr = Lazy.force coq_jmeq_congr } let join_jmeq_types eq = - mkLambda(Name (id_of_string "A"),Termops.new_Type(), - mkLambda(Name (id_of_string "x"),mkRel 1, + mkLambda(Name (Id.of_string "A"),Termops.new_Type(), + mkLambda(Name (Id.of_string "x"),mkRel 1, mkApp (eq,[|mkRel 2;mkRel 1;mkRel 2|]))) let build_coq_inversion_jmeq_data () = diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index f87130e57..6ea0d09a4 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -135,7 +135,7 @@ let add_glob_gen loc sp lib_dp ty = let mod_dp_trunc = Libnames.drop_dirpath_prefix lib_dp mod_dp in let filepath = Names.string_of_dirpath lib_dp in let modpath = Names.string_of_dirpath mod_dp_trunc in - let ident = Names.string_of_id id in + let ident = Names.Id.to_string id in dump_ref loc filepath modpath ident ty let add_glob loc ref = @@ -160,7 +160,7 @@ let dump_binding loc id = () let dump_definition (loc, id) sec s = let bl,el = interval loc in dump_string (Printf.sprintf "%s %d:%d %s %s\n" s bl el - (Names.string_of_dirpath (Lib.current_dirpath sec)) (Names.string_of_id id)) + (Names.string_of_dirpath (Lib.current_dirpath sec)) (Names.Id.to_string id)) let dump_reference loc modpath ident ty = let bl,el = interval loc in diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index a3e67234c..4a0752a3a 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -25,14 +25,14 @@ val continue : unit -> unit val add_glob : Loc.t -> Globnames.global_reference -> unit val add_glob_kn : Loc.t -> Names.kernel_name -> unit -val dump_definition : Loc.t * Names.identifier -> bool -> string -> unit +val dump_definition : Loc.t * Names.Id.t -> bool -> string -> unit val dump_moddef : Loc.t -> Names.module_path -> string -> unit val dump_modref : Loc.t -> Names.module_path -> string -> unit val dump_reference : Loc.t -> string -> string -> string -> unit val dump_libref : Loc.t -> Names.dir_path -> string -> unit val dump_notation_location : (int * int) list -> Constrexpr.notation -> (Notation.notation_location * Notation_term.scope_name option) -> unit -val dump_binding : Loc.t -> Names.Idset.elt -> unit +val dump_binding : Loc.t -> Names.Id.Set.elt -> unit val dump_notation : Loc.t * (Constrexpr.notation * Notation.notation_location) -> Notation_term.scope_name option -> bool -> unit diff --git a/interp/genarg.mli b/interp/genarg.mli index b8ed6f374..7bcb5aa11 100644 --- a/interp/genarg.mli +++ b/interp/genarg.mli @@ -130,21 +130,21 @@ val rawwit_intro_pattern : (intro_pattern_expr located,rlevel) abstract_argument val globwit_intro_pattern : (intro_pattern_expr located,glevel) abstract_argument_type val wit_intro_pattern : (intro_pattern_expr located,tlevel) abstract_argument_type -val rawwit_ident : (identifier,rlevel) abstract_argument_type -val globwit_ident : (identifier,glevel) abstract_argument_type -val wit_ident : (identifier,tlevel) abstract_argument_type +val rawwit_ident : (Id.t,rlevel) abstract_argument_type +val globwit_ident : (Id.t,glevel) abstract_argument_type +val wit_ident : (Id.t,tlevel) abstract_argument_type -val rawwit_pattern_ident : (identifier,rlevel) abstract_argument_type -val globwit_pattern_ident : (identifier,glevel) abstract_argument_type -val wit_pattern_ident : (identifier,tlevel) abstract_argument_type +val rawwit_pattern_ident : (Id.t,rlevel) abstract_argument_type +val globwit_pattern_ident : (Id.t,glevel) abstract_argument_type +val wit_pattern_ident : (Id.t,tlevel) abstract_argument_type -val rawwit_ident_gen : bool -> (identifier,rlevel) abstract_argument_type -val globwit_ident_gen : bool -> (identifier,glevel) abstract_argument_type -val wit_ident_gen : bool -> (identifier,tlevel) abstract_argument_type +val rawwit_ident_gen : bool -> (Id.t,rlevel) abstract_argument_type +val globwit_ident_gen : bool -> (Id.t,glevel) abstract_argument_type +val wit_ident_gen : bool -> (Id.t,tlevel) abstract_argument_type -val rawwit_var : (identifier located,rlevel) abstract_argument_type -val globwit_var : (identifier located,glevel) abstract_argument_type -val wit_var : (identifier,tlevel) abstract_argument_type +val rawwit_var : (Id.t located,rlevel) abstract_argument_type +val globwit_var : (Id.t located,glevel) abstract_argument_type +val wit_var : (Id.t,tlevel) abstract_argument_type val rawwit_ref : (reference,rlevel) abstract_argument_type val globwit_ref : (global_reference located or_var,glevel) abstract_argument_type diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 13c39f60d..480b6a18e 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -23,28 +23,28 @@ open Nameops open Misctypes (*i*) -let generalizable_table = ref Idpred.empty +let generalizable_table = ref Id.Pred.empty let _ = Summary.declare_summary "generalizable-ident" { Summary.freeze_function = (fun () -> !generalizable_table); Summary.unfreeze_function = (fun r -> generalizable_table := r); - Summary.init_function = (fun () -> generalizable_table := Idpred.empty) } + Summary.init_function = (fun () -> generalizable_table := Id.Pred.empty) } let declare_generalizable_ident table (loc,id) = - if not (id_eq id (root_of_id id)) then + if not (Id.equal id (root_of_id id)) then user_err_loc(loc,"declare_generalizable_ident", (pr_id id ++ str " is not declarable as generalizable identifier: it must have no trailing digits, quote, or _")); - if Idpred.mem id table then + if Id.Pred.mem id table then user_err_loc(loc,"declare_generalizable_ident", (pr_id id++str" is already declared as a generalizable identifier")) - else Idpred.add id table + else Id.Pred.add id table let add_generalizable gen table = match gen with - | None -> Idpred.empty - | Some [] -> Idpred.full + | None -> Id.Pred.empty + | Some [] -> Id.Pred.full | Some l -> List.fold_left (fun table lid -> declare_generalizable_ident table lid) table l @@ -54,7 +54,7 @@ let cache_generalizable_type (_,(local,cmd)) = let load_generalizable_type _ (_,(local,cmd)) = generalizable_table := add_generalizable cmd !generalizable_table -let in_generalizable : bool * identifier Loc.located list option -> obj = +let in_generalizable : bool * Id.t Loc.located list option -> obj = declare_object {(default_object "GENERALIZED-IDENT") with load_function = load_generalizable_type; cache_function = cache_generalizable_type; @@ -64,10 +64,10 @@ let in_generalizable : bool * identifier Loc.located list option -> obj = let declare_generalizable local gen = Lib.add_anonymous_leaf (in_generalizable (local, gen)) -let find_generalizable_ident id = Idpred.mem (root_of_id id) !generalizable_table +let find_generalizable_ident id = Id.Pred.mem (root_of_id id) !generalizable_table let ids_of_list l = - List.fold_right Idset.add l Idset.empty + List.fold_right Id.Set.add l Id.Set.empty let locate_reference qid = match Nametab.locate_extended qid with @@ -82,7 +82,7 @@ let is_global id = let is_freevar ids env x = try - if Idset.mem x ids then false + if Id.Set.mem x ids then false else try ignore(Environ.lookup_named x env) ; false with _ -> not (is_global x) @@ -94,7 +94,7 @@ let ungeneralizable loc id = user_err_loc (loc, "Generalization", str "Unbound and ungeneralizable variable " ++ pr_id id) -let free_vars_of_constr_expr c ?(bound=Idset.empty) l = +let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = let found loc id bdvars l = if List.mem id l then l else if is_freevar bdvars (Global.env ()) id @@ -105,25 +105,25 @@ let free_vars_of_constr_expr c ?(bound=Idset.empty) l = in let rec aux bdvars l c = match c with | CRef (Ident (loc,id)) -> found loc id bdvars l - | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [], [])) when not (Idset.mem id bdvars) -> - Topconstr.fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c - | c -> Topconstr.fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c + | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [], [])) when not (Id.Set.mem id bdvars) -> + Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c + | c -> Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c in aux bound l c let ids_of_names l = List.fold_left (fun acc x -> match snd x with Name na -> na :: acc | Anonymous -> acc) [] l -let free_vars_of_binders ?(bound=Idset.empty) l (binders : local_binder list) = +let free_vars_of_binders ?(bound=Id.Set.empty) l (binders : local_binder list) = let rec aux bdvars l c = match c with ((LocalRawAssum (n, _, c)) :: tl) -> let bound = ids_of_names n in let l' = free_vars_of_constr_expr c ~bound:bdvars l in - aux (Idset.union (ids_of_list bound) bdvars) l' tl + aux (Id.Set.union (ids_of_list bound) bdvars) l' tl | ((LocalRawDef (n, c)) :: tl) -> let bound = match snd n with Anonymous -> [] | Name n -> [n] in let l' = free_vars_of_constr_expr c ~bound:bdvars l in - aux (Idset.union (ids_of_list bound) bdvars) l' tl + aux (Id.Set.union (ids_of_list bound) bdvars) l' tl | [] -> bdvars, l in aux bound l binders @@ -131,9 +131,9 @@ let free_vars_of_binders ?(bound=Idset.empty) l (binders : local_binder list) = let add_name_to_ids set na = match na with | Anonymous -> set - | Name id -> Idset.add id set + | Name id -> Id.Set.add id set -let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty) = +let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.empty) = let rec vars bound vs = function | GVar (loc,id) -> if is_freevar bound (Global.env ()) id then @@ -160,7 +160,7 @@ let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty let vs3 = vars bound vs2 b1 in vars bound vs3 b2 | GRec (loc,fk,idl,bl,tyl,bv) -> - let bound' = Array.fold_right Idset.add idl bound in + let bound' = Array.fold_right Id.Set.add idl bound in let vars_fix i vs fid = let vs1,bound1 = List.fold_left @@ -182,7 +182,7 @@ let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> vs and vars_pattern bound vs (loc,idl,p,c) = - let bound' = List.fold_right Idset.add idl bound in + let bound' = List.fold_right Id.Set.add idl bound in vars bound' vs c and vars_option bound vs = function None -> vs | Some p -> vars bound vs p @@ -193,7 +193,7 @@ let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty in fun rt -> let vars = List.rev (vars bound [] rt) in List.iter (fun (id, loc) -> - if not (Idset.mem id allowed || find_generalizable_ident id) then + if not (Id.Set.mem id allowed || find_generalizable_ident id) then ungeneralizable loc id) vars; vars @@ -202,7 +202,7 @@ let rec make_fresh ids env x = let next_name_away_from na avoid = match na with - | Anonymous -> make_fresh avoid (Global.env ()) (id_of_string "anon") + | Anonymous -> make_fresh avoid (Global.env ()) (Id.of_string "anon") | Name id -> make_fresh avoid (Global.env ()) id let combine_params avoid fn applied needed = @@ -211,7 +211,7 @@ let combine_params avoid fn applied needed = (function (t, Some (loc, ExplByName id)) -> let is_id (_, (na, _, _)) = match na with - | Name id' -> id_eq id id' + | Name id' -> Id.equal id id' | Anonymous -> false in if not (List.exists is_id needed) then @@ -255,7 +255,7 @@ let combine_params avoid fn applied needed = let combine_params_freevar = fun avoid (_, (na, _, _)) -> let id' = next_name_away_from na avoid in - (CRef (Ident (Loc.ghost, id')), Idset.add id' avoid) + (CRef (Ident (Loc.ghost, id')), Id.Set.add id' avoid) let destClassApp cl = match cl with @@ -282,7 +282,7 @@ let implicit_application env ?(allow_partial=true) f ty = match is_class with | None -> ty, env | Some ((loc, id, par), gr) -> - let avoid = Idset.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in + let avoid = Id.Set.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in let c, avoid = let c = class_info gr in let (ci, rd) = c.cl_context in diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli index 256f65ba2..2c5ad7408 100644 --- a/interp/implicit_quantifiers.mli +++ b/interp/implicit_quantifiers.mli @@ -22,35 +22,35 @@ open Libnames open Globnames open Typeclasses -val declare_generalizable : Vernacexpr.locality_flag -> (identifier located) list option -> unit +val declare_generalizable : Vernacexpr.locality_flag -> (Id.t located) list option -> unit -val ids_of_list : identifier list -> Idset.t +val ids_of_list : Id.t list -> Id.Set.t val destClassApp : constr_expr -> Loc.t * reference * constr_expr list val destClassAppExpl : constr_expr -> Loc.t * reference * (constr_expr * explicitation located option) list (** Fragile, should be used only for construction a set of identifiers to avoid *) -val free_vars_of_constr_expr : constr_expr -> ?bound:Idset.t -> - identifier list -> identifier list +val free_vars_of_constr_expr : constr_expr -> ?bound:Id.Set.t -> + Id.t list -> Id.t list val free_vars_of_binders : - ?bound:Idset.t -> Names.identifier list -> local_binder list -> Idset.t * Names.identifier list + ?bound:Id.Set.t -> Names.Id.t list -> local_binder list -> Id.Set.t * Names.Id.t list (** Returns the generalizable free ids in left-to-right order with the location of their first occurence *) -val generalizable_vars_of_glob_constr : ?bound:Idset.t -> ?allowed:Idset.t -> - glob_constr -> (Names.identifier * Loc.t) list +val generalizable_vars_of_glob_constr : ?bound:Id.Set.t -> ?allowed:Id.Set.t -> + glob_constr -> (Names.Id.t * Loc.t) list -val make_fresh : Names.Idset.t -> Environ.env -> identifier -> identifier +val make_fresh : Names.Id.Set.t -> Environ.env -> Id.t -> Id.t val implicits_of_glob_constr : ?with_products:bool -> Glob_term.glob_constr -> Impargs.manual_implicits val combine_params_freevar : - Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) -> - Constrexpr.constr_expr * Names.Idset.t + Names.Id.Set.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) -> + Constrexpr.constr_expr * Names.Id.Set.t -val implicit_application : Idset.t -> ?allow_partial:bool -> - (Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) -> - Constrexpr.constr_expr * Names.Idset.t) -> - constr_expr -> constr_expr * Idset.t +val implicit_application : Id.Set.t -> ?allow_partial:bool -> + (Names.Id.Set.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) -> + Constrexpr.constr_expr * Names.Id.Set.t) -> + constr_expr -> constr_expr * Id.Set.t diff --git a/interp/notation.ml b/interp/notation.ml index 8a01c5985..d5aa59788 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -643,15 +643,15 @@ let declare_ref_arguments_scope ref = type symbol = | Terminal of string - | NonTerminal of identifier - | SProdList of identifier * symbol list + | NonTerminal of Id.t + | SProdList of Id.t * symbol list | Break of int let rec symbol_eq s1 s2 = match s1, s2 with | Terminal s1, Terminal s2 -> String.equal s1 s2 -| NonTerminal id1, NonTerminal id2 -> id_eq id1 id2 +| NonTerminal id1, NonTerminal id2 -> Id.equal id1 id2 | SProdList (id1, l1), SProdList (id2, l2) -> - id_eq id1 id2 && List.equal symbol_eq l1 l2 + Id.equal id1 id2 && List.equal symbol_eq l1 l2 | Break i1, Break i2 -> Int.equal i1 i2 | _ -> false @@ -677,7 +677,7 @@ let decompose_notation_key s = in let tok = match String.sub s n (pos-n) with - | "_" -> NonTerminal (id_of_string "_") + | "_" -> NonTerminal (Id.of_string "_") | s -> Terminal (String.drop_simple_quotes s) in decomp_ntn (tok::dirs) (pos+1) in @@ -695,7 +695,7 @@ let classes_of_scope sc = let pr_scope_class = function | ScopeSort -> str "Sort" - | ScopeRef t -> pr_global_env Idset.empty t + | ScopeRef t -> pr_global_env Id.Set.empty t let pr_scope_classes sc = let l = classes_of_scope sc in diff --git a/interp/notation.mli b/interp/notation.mli index 5c8dbb40b..c3106f5d3 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -169,8 +169,8 @@ val compute_scope_of_global : global_reference -> scope_name option type symbol = | Terminal of string - | NonTerminal of identifier - | SProdList of identifier * symbol list + | NonTerminal of Id.t + | SProdList of Id.t * symbol list | Break of int val symbol_eq : symbol -> symbol -> bool diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index c0289fbad..a7e591383 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -50,7 +50,7 @@ let rec subst_glob_vars l = function GLambda (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c) | r -> map_glob_constr (subst_glob_vars l) r (* assume: id is not binding *) -let ldots_var = id_of_string ".." +let ldots_var = Id.of_string ".." let glob_constr_of_notation_constr_with_binders loc g f e = function | NVar id -> GVar (loc,id) @@ -122,7 +122,7 @@ let add_name r = function Anonymous -> () | Name id -> add_id r id let split_at_recursive_part c = let sub = ref None in let rec aux = function - | GApp (loc0,GVar(loc,v),c::l) when id_eq v ldots_var -> + | GApp (loc0,GVar(loc,v),c::l) when Id.equal v ldots_var -> begin match !sub with | None -> let () = sub := Some c in @@ -140,14 +140,14 @@ let split_at_recursive_part c = | None -> (* No recursive pattern found *) raise Not_found | Some c -> match outer_iterator with - | GVar (_,v) when id_eq v ldots_var -> (* Not enough context *) raise Not_found + | GVar (_,v) when Id.equal v ldots_var -> (* Not enough context *) raise Not_found | _ -> outer_iterator, c let on_true_do b f c = if b then (f c; b) else b let compare_glob_constr f add t1 t2 = match t1,t2 with | GRef (_,r1), GRef (_,r2) -> eq_gr r1 r2 - | GVar (_,v1), GVar (_,v2) -> on_true_do (id_eq v1 v2) add (Name v1) + | GVar (_,v1), GVar (_,v2) -> on_true_do (Id.equal v1 v2) add (Name v1) | GApp (_,f1,l1), GApp (_,f2,l2) -> f f1 f2 && List.for_all2eq f l1 l2 | GLambda (_,na1,bk1,ty1,c1), GLambda (_,na2,bk2,ty2,c2) when name_eq na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> @@ -181,18 +181,18 @@ let compare_recursive_parts found f (iterator,subc) = let diff = ref None in let terminator = ref None in let rec aux c1 c2 = match c1,c2 with - | GVar(_,v), term when id_eq v ldots_var -> + | GVar(_,v), term when Id.equal v ldots_var -> (* We found the pattern *) assert (match !terminator with None -> true | Some _ -> false); terminator := Some term; true - | GApp (_,GVar(_,v),l1), GApp (_,term,l2) when id_eq v ldots_var -> + | GApp (_,GVar(_,v),l1), GApp (_,term,l2) when Id.equal v ldots_var -> (* We found the pattern, but there are extra arguments *) (* (this allows e.g. alternative (recursive) notation of application) *) assert (match !terminator with None -> true | Some _ -> false); terminator := Some term; List.for_all2eq aux l1 l2 - | GVar (_,x), GVar (_,y) when not (id_eq x y) -> + | GVar (_,x), GVar (_,y) when not (Id.equal x y) -> (* We found the position where it differs *) let lassoc = match !terminator with None -> false | Some _ -> true in let x,y = if lassoc then y,x else x,y in @@ -249,7 +249,7 @@ let notation_constr_and_vars_of_glob_constr a = with Not_found -> found := keepfound; match c with - | GApp (_,GVar (loc,f),[c]) when id_eq f ldots_var -> + | GApp (_,GVar (loc,f),[c]) when Id.equal f ldots_var -> (* Fall on the second part of the recursive pattern w/o having found the first part *) user_err_loc (loc,"", @@ -300,7 +300,7 @@ let notation_constr_and_vars_of_glob_constr a = let rec list_rev_mem_assoc x = function | [] -> false - | (_,x')::l -> id_eq x x' || list_rev_mem_assoc x l + | (_,x')::l -> Id.equal x x' || list_rev_mem_assoc x l let check_variables vars recvars (found,foundrec,foundrecbinding) = let useless_vars = List.map snd recvars in @@ -316,9 +316,9 @@ let check_variables vars recvars (found,foundrec,foundrecbinding) = if List.mem_assoc x foundrec or List.mem_assoc x foundrecbinding or list_rev_mem_assoc x foundrec or list_rev_mem_assoc x foundrecbinding then - error ((string_of_id x)^" should not be bound in a recursive pattern of the right-hand side.") + error ((Id.to_string x)^" should not be bound in a recursive pattern of the right-hand side.") else - error ((string_of_id x)^" is unbound in the right-hand side.") in + error ((Id.to_string x)^" is unbound in the right-hand side.") in let check_pair s x y where = if not (List.mem (x,y) where) then errorlabstrm "" (strbrk "in the right-hand side, " ++ pr_id x ++ @@ -493,10 +493,10 @@ let abstract_return_type_context_notation_constr = exception No_match let rec alpha_var id1 id2 = function - | (i1,i2)::_ when id_eq i1 id1 -> id_eq i2 id2 - | (i1,i2)::_ when id_eq i2 id2 -> id_eq i1 id1 + | (i1,i2)::_ when Id.equal i1 id1 -> Id.equal i2 id2 + | (i1,i2)::_ when Id.equal i2 id2 -> Id.equal i1 id1 | _::idl -> alpha_var id1 id2 idl - | [] -> id_eq id1 id2 + | [] -> Id.equal id1 id2 let bind_env alp (sigma,sigmalist,sigmabinders as fullsigma) var v = try @@ -636,7 +636,7 @@ let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 = (* Matching compositionally *) | GVar (_,id1), NVar id2 when alpha_var id1 id2 alp -> sigma | GRef (_,r1), NRef r2 when (eq_gr r1 r2) -> sigma - | GPatVar (_,(_,n1)), NPatVar n2 when id_eq n1 n2 -> sigma + | GPatVar (_,(_,n1)), NPatVar n2 when Id.equal n1 n2 -> sigma | GApp (loc,f1,l1), NApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in let f1,l1,f2,l2 = diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index b2df95901..35c9a8e1c 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -17,11 +17,11 @@ open Glob_term bound by the notation; also interpret recursive patterns *) val notation_constr_of_glob_constr : - (identifier * notation_var_internalization_type) list -> - (identifier * identifier) list -> glob_constr -> notation_constr + (Id.t * notation_var_internalization_type) list -> + (Id.t * Id.t) list -> glob_constr -> notation_constr (** Name of the special identifier used to encode recursive notations *) -val ldots_var : identifier +val ldots_var : Id.t (** Equality of [glob_constr] (warning: only partially implemented) *) (** FIXME: nothing to do here *) diff --git a/interp/reserve.ml b/interp/reserve.ml index 3a865cb7d..30953007e 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -22,7 +22,7 @@ type key = | RefKey of global_reference | Oth -let reserve_table = ref Idmap.empty +let reserve_table = ref Id.Map.empty let reserve_revtable = ref Gmapl.empty let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) @@ -34,17 +34,17 @@ let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) let cache_reserved_type (_,(id,t)) = let key = fst (notation_constr_key t) in - reserve_table := Idmap.add id t !reserve_table; + reserve_table := Id.Map.add id t !reserve_table; reserve_revtable := Gmapl.add key (t,id) !reserve_revtable -let in_reserved : identifier * notation_constr -> obj = +let in_reserved : Id.t * notation_constr -> obj = declare_object {(default_object "RESERVED-TYPE") with cache_function = cache_reserved_type } let freeze_reserved () = (!reserve_table,!reserve_revtable) let unfreeze_reserved (r,rr) = reserve_table := r; reserve_revtable := rr let init_reserved () = - reserve_table := Idmap.empty; reserve_revtable := Gmapl.empty + reserve_table := Id.Map.empty; reserve_revtable := Gmapl.empty let _ = Summary.declare_summary "reserved-type" @@ -53,12 +53,12 @@ let _ = Summary.init_function = init_reserved } let declare_reserved_type_binding (loc,id) t = - if not (id_eq id (root_of_id id)) then + if not (Id.equal id (root_of_id id)) then user_err_loc(loc,"declare_reserved_type", (pr_id id ++ str " is not reservable: it must have no trailing digits, quote, or _")); begin try - let _ = Idmap.find id !reserve_table in + let _ = Id.Map.find id !reserve_table in user_err_loc(loc,"declare_reserved_type", (pr_id id++str" is already bound to a type")) with Not_found -> () end; @@ -67,7 +67,7 @@ let declare_reserved_type_binding (loc,id) t = let declare_reserved_type idl t = List.iter (fun id -> declare_reserved_type_binding id t) (List.rev idl) -let find_reserved_type id = Idmap.find (root_of_id id) !reserve_table +let find_reserved_type id = Id.Map.find (root_of_id id) !reserve_table let constr_key c = try RefKey (canonical_gr (global_of_constr (fst (Term.decompose_app c)))) diff --git a/interp/reserve.mli b/interp/reserve.mli index e6c1946a5..305480840 100644 --- a/interp/reserve.mli +++ b/interp/reserve.mli @@ -12,6 +12,6 @@ open Names open Glob_term open Notation_term -val declare_reserved_type : identifier located list -> notation_constr -> unit -val find_reserved_type : identifier -> notation_constr +val declare_reserved_type : Id.t located list -> notation_constr -> unit +val find_reserved_type : Id.t -> notation_constr val anonymize_if_reserved : name -> glob_constr -> glob_constr diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index cabd207e2..254805f6a 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -41,8 +41,8 @@ let load_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = let is_alias_of_already_visible_name sp = function | _,NRef ref -> - let (dir,id) = repr_qualid (shortest_qualid_of_global Idset.empty ref) in - dir_path_eq dir empty_dirpath && id_eq id (basename sp) + let (dir,id) = repr_qualid (shortest_qualid_of_global Id.Set.empty ref) in + dir_path_eq dir empty_dirpath && Id.equal id (basename sp) | _ -> false @@ -76,7 +76,7 @@ let in_syntax_constant subst_function = subst_syntax_constant; classify_function = classify_syntax_constant } -type syndef_interpretation = (identifier * subscopes) list * notation_constr +type syndef_interpretation = (Id.t * subscopes) list * notation_constr (* Coercions to the general format of notation that also supports variables bound to list of expressions *) @@ -86,8 +86,8 @@ let out_pat (ids,ac) = (List.map (fun (id,(sc,typ)) -> (id,sc)) ids,ac) let declare_syntactic_definition local id onlyparse pat = let _ = add_leaf id (in_syntax_constant (local,in_pat pat,onlyparse)) in () -let pr_global r = pr_global_env Idset.empty r -let pr_syndef kn = pr_qualid (shortest_qualid_of_syndef Idset.empty kn) +let pr_global r = pr_global_env Id.Set.empty r +let pr_syndef kn = pr_qualid (shortest_qualid_of_syndef Id.Set.empty kn) let allow_compat_notations = ref true let verbose_compat_notations = ref false @@ -101,7 +101,7 @@ let verbose_compat kn def = function if !verbose_compat_notations then msg_warning else errorlabstrm "" in let pp_def = match def with - | [], NRef r -> str " is " ++ pr_global_env Idset.empty r + | [], NRef r -> str " is " ++ pr_global_env Id.Set.empty r | _ -> str " is a compatibility notation" in let since = str (" since Coq > " ^ Flags.pr_version v ^ ".") in diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index 26e98f67c..f3c4a61e6 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -14,9 +14,9 @@ open Libnames (** Syntactic definitions. *) -type syndef_interpretation = (identifier * subscopes) list * notation_constr +type syndef_interpretation = (Id.t * subscopes) list * notation_constr -val declare_syntactic_definition : bool -> identifier -> +val declare_syntactic_definition : bool -> Id.t -> Flags.compat_version option -> syndef_interpretation -> unit val search_syntactic_definition : kernel_name -> syndef_interpretation diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 046904cf5..7f6f5672b 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -79,8 +79,8 @@ let rec cases_pattern_fold_names f a = function let ids_of_pattern_list = List.fold_left (Loc.located_fold_left - (List.fold_left (cases_pattern_fold_names Idset.add))) - Idset.empty + (List.fold_left (cases_pattern_fold_names Id.Set.add))) + Id.Set.empty let rec fold_constr_expr_binders g f n acc b = function | (nal,bk,t)::l -> @@ -123,7 +123,7 @@ let fold_constr_expr_with_binders g f n acc = function let acc = List.fold_left (f n) acc (List.map fst al) in List.fold_right (fun (loc,patl,rhs) acc -> let ids = ids_of_pattern_list patl in - f (Idset.fold g ids n) acc rhs) bl acc + f (Id.Set.fold g ids n) acc rhs) bl acc | CLetTuple (loc,nal,(ona,po),b,c) -> let n' = List.fold_right (Loc.down_located (name_fold g)) nal n in f (Option.fold_right (Loc.down_located (name_fold g)) ona n') (f n acc b) c @@ -141,11 +141,11 @@ let fold_constr_expr_with_binders g f n acc = function let free_vars_of_constr_expr c = let rec aux bdvars l = function - | CRef (Ident (_,id)) -> if List.mem id bdvars then l else Idset.add id l + | CRef (Ident (_,id)) -> if List.mem id bdvars then l else Id.Set.add id l | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c - in aux [] Idset.empty c + in aux [] Id.Set.empty c -let occur_var_constr_expr id c = Idset.mem id (free_vars_of_constr_expr c) +let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c) (* Interpret the index of a recursion order annotation *) @@ -161,7 +161,7 @@ let split_at_annot bl na = let rec aux acc = function | LocalRawAssum (bls, k, t) as x :: rest -> let test (_, na) = match na with - | Name id' -> id_eq id id' + | Name id' -> Id.equal id id' | Anonymous -> false in let l, r = List.split_when test bls in diff --git a/interp/topconstr.mli b/interp/topconstr.mli index a4228c762..6cc3615f0 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -25,26 +25,26 @@ val oldfashion_patterns : bool ref (** Utilities on constr_expr *) val replace_vars_constr_expr : - (identifier * identifier) list -> constr_expr -> constr_expr + (Id.t * Id.t) list -> constr_expr -> constr_expr -val free_vars_of_constr_expr : constr_expr -> Idset.t -val occur_var_constr_expr : identifier -> constr_expr -> bool +val free_vars_of_constr_expr : constr_expr -> Id.Set.t +val occur_var_constr_expr : Id.t -> constr_expr -> bool (** Specific function for interning "in indtype" syntax of "match" *) -val ids_of_cases_indtype : cases_pattern_expr -> identifier list +val ids_of_cases_indtype : cases_pattern_expr -> Id.t list -val split_at_annot : local_binder list -> identifier located option -> local_binder list * local_binder list +val split_at_annot : local_binder list -> Id.t located option -> local_binder list * local_binder list (** Used in typeclasses *) -val fold_constr_expr_with_binders : (identifier -> 'a -> 'a) -> +val fold_constr_expr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> 'b -> constr_expr -> 'b) -> 'a -> 'b -> constr_expr -> 'b (** Used in correctness and interface; absence of var capture not guaranteed in pattern-matching clauses and in binders of the form [x,y:T(x)] *) val map_constr_expr_with_binders : - (identifier -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) -> + (Id.t -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) -> 'a -> constr_expr -> constr_expr val ntn_loc : diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index 01380b8d5..a67e59185 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -19,8 +19,8 @@ open Decl_kinds type notation = string type explicitation = - | ExplByPos of int * identifier option - | ExplByName of identifier + | ExplByPos of int * Id.t option + | ExplByName of Id.t type binder_kind = | Default of binding_kind @@ -35,15 +35,15 @@ type proj_flag = int option (** [Some n] = proj of the n-th visible argument *) type prim_token = Numeral of Bigint.bigint | String of string type raw_cases_pattern_expr = - | RCPatAlias of Loc.t * raw_cases_pattern_expr * identifier + | RCPatAlias of Loc.t * raw_cases_pattern_expr * Id.t | RCPatCstr of Loc.t * Globnames.global_reference * raw_cases_pattern_expr list * raw_cases_pattern_expr list (** [CPatCstr (_, Inl c, l1, l2)] represents (@c l1) l2 *) - | RCPatAtom of Loc.t * identifier option + | RCPatAtom of Loc.t * Id.t option | RCPatOr of Loc.t * raw_cases_pattern_expr list type cases_pattern_expr = - | CPatAlias of Loc.t * cases_pattern_expr * identifier + | CPatAlias of Loc.t * cases_pattern_expr * Id.t | CPatCstr of Loc.t * reference * cases_pattern_expr list * cases_pattern_expr list (** [CPatCstr (_, Inl c, l1, l2)] represents (@c l1) l2 *) @@ -63,8 +63,8 @@ and cases_pattern_notation_substitution = type constr_expr = | CRef of reference - | CFix of Loc.t * identifier located * fix_expr list - | CCoFix of Loc.t * identifier located * cofix_expr list + | CFix of Loc.t * Id.t located * fix_expr list + | CCoFix of Loc.t * Id.t located * cofix_expr list | CProdN of Loc.t * binder_expr list * constr_expr | CLambdaN of Loc.t * binder_expr list * constr_expr | CLetIn of Loc.t * name located * constr_expr * constr_expr @@ -98,11 +98,11 @@ and binder_expr = name located list * binder_kind * constr_expr and fix_expr = - identifier located * (identifier located option * recursion_order_expr) * + Id.t located * (Id.t located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr and cofix_expr = - identifier located * local_binder list * constr_expr * constr_expr + Id.t located * local_binder list * constr_expr * constr_expr and recursion_order_expr = | CStructRec @@ -128,8 +128,8 @@ type constr_pattern_expr = constr_expr (** Concrete syntax for modules and module types *) type with_declaration_ast = - | CWith_Module of identifier list located * qualid located - | CWith_Definition of identifier list located * constr_expr + | CWith_Module of Id.t list located * qualid located + | CWith_Definition of Id.t list located * constr_expr type module_ast = | CMident of qualid located diff --git a/intf/evar_kinds.mli b/intf/evar_kinds.mli index 90ada0e3d..596f6b889 100644 --- a/intf/evar_kinds.mli +++ b/intf/evar_kinds.mli @@ -17,7 +17,7 @@ open Globnames type obligation_definition_status = Define of bool | Expand type t = - | ImplicitArg of global_reference * (int * identifier option) + | ImplicitArg of global_reference * (int * Id.t option) * bool (** Force inference *) | BinderType of name | QuestionMark of obligation_definition_status @@ -26,4 +26,4 @@ type t = | TomatchTypeParameter of inductive * int | GoalEvar | ImpossibleCase - | MatchingVar of bool * identifier + | MatchingVar of bool * Id.t diff --git a/intf/genredexpr.mli b/intf/genredexpr.mli index 63d945b7c..833d32545 100644 --- a/intf/genredexpr.mli +++ b/intf/genredexpr.mli @@ -44,5 +44,5 @@ type ('a,'b,'c) red_expr_gen = type ('a,'b,'c) may_eval = | ConstrTerm of 'a | ConstrEval of ('a,'b,'c) red_expr_gen * 'a - | ConstrContext of (Loc.t * Names.identifier) * 'a + | ConstrContext of (Loc.t * Names.Id.t) * 'a | ConstrTypeOf of 'a diff --git a/intf/glob_term.mli b/intf/glob_term.mli index 8e7b012b0..b8d6564a6 100644 --- a/intf/glob_term.mli +++ b/intf/glob_term.mli @@ -29,7 +29,7 @@ type cases_pattern = type glob_constr = | GRef of (Loc.t * global_reference) - | GVar of (Loc.t * identifier) + | GVar of (Loc.t * Id.t) | GEvar of Loc.t * existential_key * glob_constr list option | GPatVar of Loc.t * (bool * patvar) (** Used for patterns only *) | GApp of Loc.t * glob_constr * glob_constr list @@ -43,7 +43,7 @@ type glob_constr = | GLetTuple of Loc.t * name list * (name * glob_constr option) * glob_constr * glob_constr | GIf of Loc.t * glob_constr * (name * glob_constr option) * glob_constr * glob_constr - | GRec of Loc.t * fix_kind * identifier array * glob_decl list array * + | GRec of Loc.t * fix_kind * Id.t array * glob_decl list array * glob_constr array * glob_constr array | GSort of Loc.t * glob_sort | GHole of (Loc.t * Evar_kinds.t) @@ -68,7 +68,7 @@ and tomatch_tuple = (glob_constr * predicate_pattern) and tomatch_tuples = tomatch_tuple list -and cases_clause = (Loc.t * identifier list * cases_pattern list * glob_constr) +and cases_clause = (Loc.t * Id.t list * cases_pattern list * glob_constr) (** [(p,il,cl,t)] = "|'cl' => 't'". Precondition: the free variables of [t] are members of [il]. *) and cases_clauses = cases_clause list diff --git a/intf/locus.mli b/intf/locus.mli index 9073b6ae8..e0ce43331 100644 --- a/intf/locus.mli +++ b/intf/locus.mli @@ -49,7 +49,7 @@ type 'id clause_expr = { onhyps : 'id hyp_location_expr list option; concl_occs : occurrences_expr } -type clause = identifier clause_expr +type clause = Id.t clause_expr (** {6 Concrete view of occurrence clauses} *) @@ -59,7 +59,7 @@ type clause = identifier clause_expr or in both) or to some occurrences of the conclusion *) type clause_atom = - | OnHyp of identifier * occurrences_expr * hyp_location_flag + | OnHyp of Id.t * occurrences_expr * hyp_location_flag | OnConcl of occurrences_expr (** A [concrete_clause] is an effective collection of occurrences @@ -72,7 +72,7 @@ type concrete_clause = clause_atom list (** A [hyp_location] is an hypothesis together with a location *) -type hyp_location = identifier * hyp_location_flag +type hyp_location = Id.t * hyp_location_flag (** A [goal_location] is either an hypothesis (together with a location) or the conclusion (represented by None) *) @@ -85,4 +85,4 @@ type goal_location = hyp_location option (** A [simple_clause] is a set of hypotheses, possibly extended with the conclusion (conclusion is represented by None) *) -type simple_clause = identifier option list +type simple_clause = Id.t option list diff --git a/intf/misctypes.mli b/intf/misctypes.mli index f46ada445..3a044018c 100644 --- a/intf/misctypes.mli +++ b/intf/misctypes.mli @@ -12,7 +12,7 @@ open Names (** Cases pattern variables *) -type patvar = identifier +type patvar = Id.t (** Introduction patterns *) @@ -20,8 +20,8 @@ type intro_pattern_expr = | IntroOrAndPattern of or_and_intro_pattern_expr | IntroWildcard | IntroRewrite of bool - | IntroIdentifier of identifier - | IntroFresh of identifier + | IntroIdentifier of Id.t + | IntroFresh of Id.t | IntroForthcoming of bool | IntroAnonymous and or_and_intro_pattern_expr = (Loc.t * intro_pattern_expr) list list @@ -61,7 +61,7 @@ type 'a cast_type = (** Bindings *) -type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier +type quantified_hypothesis = AnonHyp of int | NamedHyp of Id.t type 'a explicit_bindings = (Loc.t * quantified_hypothesis * 'a) list @@ -77,9 +77,9 @@ type 'a with_bindings = 'a * 'a bindings type 'a or_var = | ArgArg of 'a - | ArgVar of Names.identifier Loc.located + | ArgVar of Names.Id.t Loc.located -type 'a and_short_name = 'a * identifier Loc.located option +type 'a and_short_name = 'a * Id.t Loc.located option type 'a or_by_notation = | AN of 'a diff --git a/intf/notation_term.mli b/intf/notation_term.mli index d7bd73588..2b1286940 100644 --- a/intf/notation_term.mli +++ b/intf/notation_term.mli @@ -22,14 +22,14 @@ open Glob_term type notation_constr = (** Part common to [glob_constr] and [cases_pattern] *) | NRef of global_reference - | NVar of identifier + | NVar of Id.t | NApp of notation_constr * notation_constr list | NHole of Evar_kinds.t - | NList of identifier * identifier * notation_constr * notation_constr * bool + | NList of Id.t * Id.t * notation_constr * notation_constr * bool (** Part only in [glob_constr] *) | NLambda of name * notation_constr * notation_constr | NProd of name * notation_constr * notation_constr - | NBinderList of identifier * identifier * notation_constr * notation_constr + | NBinderList of Id.t * Id.t * notation_constr * notation_constr | NLetIn of name * notation_constr * notation_constr | NCases of case_style * notation_constr option * (notation_constr * (name * (inductive * name list) option)) list * @@ -38,7 +38,7 @@ type notation_constr = notation_constr * notation_constr | NIf of notation_constr * (name * notation_constr option) * notation_constr * notation_constr - | NRec of fix_kind * identifier array * + | NRec of fix_kind * Id.t array * (name * notation_constr option * notation_constr) list array * notation_constr array * notation_constr array | NSort of glob_sort @@ -71,5 +71,5 @@ type notation_var_internalization_type = (** This characterizes to what a notation is interpreted to *) type interpretation = - (identifier * (subscopes * notation_var_instance_type)) list * + (Id.t * (subscopes * notation_var_instance_type)) list * notation_constr diff --git a/intf/pattern.mli b/intf/pattern.mli index a8c787673..5c0dfbd5d 100644 --- a/intf/pattern.mli +++ b/intf/pattern.mli @@ -43,7 +43,7 @@ open Misctypes could be inferred. We also loose the ability of typing ltac variables before calling the right-hand-side of ltac matching clauses. *) -type constr_under_binders = identifier list * constr +type constr_under_binders = Id.t list * constr (** Types of substitutions with or w/o bound variables *) @@ -60,7 +60,7 @@ type case_info_pattern = type constr_pattern = | PRef of global_reference - | PVar of identifier + | PVar of Id.t | PEvar of existential_key * constr_pattern array | PRel of int | PApp of constr_pattern * constr_pattern array diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 1f1388e3d..26ab4b666 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -34,7 +34,7 @@ type debug = Debug | Info | Off (* for trivial / auto / eauto ... *) type 'a induction_arg = | ElimOnConstr of 'a - | ElimOnIdent of identifier located + | ElimOnIdent of Id.t located | ElimOnAnonHyp of int type inversion_kind = @@ -75,7 +75,7 @@ type multi = (* Type of patterns *) type 'a match_pattern = | Term of 'a - | Subterm of bool * identifier option * 'a + | Subterm of bool * Id.t option * 'a (* Type of hypotheses for a Match Context rule *) type 'a match_context_hyps = @@ -93,7 +93,7 @@ type ('trm,'pat,'cst,'ind,'ref,'nam,'lev) gen_atomic_tactic_expr = (* Basic tactics *) | TacIntroPattern of intro_pattern_expr located list | TacIntrosUntil of quantified_hypothesis - | TacIntroMove of identifier option * 'nam move_location + | TacIntroMove of Id.t option * 'nam move_location | TacAssumption | TacExact of 'trm | TacExactNoCheck of 'trm @@ -104,10 +104,10 @@ type ('trm,'pat,'cst,'ind,'ref,'nam,'lev) gen_atomic_tactic_expr = | TacElimType of 'trm | TacCase of evars_flag * 'trm with_bindings | TacCaseType of 'trm - | TacFix of identifier option * int - | TacMutualFix of identifier * int * (identifier * int * 'trm) list - | TacCofix of identifier option - | TacMutualCofix of identifier * (identifier * 'trm) list + | TacFix of Id.t option * int + | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list + | TacCofix of Id.t option + | TacMutualCofix of Id.t * (Id.t * 'trm) list | TacCut of 'trm | TacAssert of ('trm,'pat,'cst,'ind,'ref,'nam,'lev) gen_tactic_expr option * @@ -167,7 +167,7 @@ type ('trm,'pat,'cst,'ind,'ref,'nam,'lev) gen_atomic_tactic_expr = (* For syntax extensions *) | TacAlias of Loc.t * string * - (identifier * 'lev generic_argument) list * (dir_path * glob_tactic_expr) + (Id.t * 'lev generic_argument) list * (dir_path * glob_tactic_expr) (** Possible arguments of a tactic definition *) @@ -213,12 +213,12 @@ and ('t,'p,'c,'i,'r,'n,'l) gen_tactic_expr = | TacProgress of ('t,'p,'c,'i,'r,'n,'l) gen_tactic_expr | TacShowHyps of ('t,'p,'c,'i,'r,'n,'l) gen_tactic_expr | TacAbstract of - ('t,'p,'c,'i,'r,'n,'l) gen_tactic_expr * identifier option + ('t,'p,'c,'i,'r,'n,'l) gen_tactic_expr * Id.t option | TacId of 'n message_token list | TacFail of int or_var * 'n message_token list | TacInfo of ('t,'p,'c,'i,'r,'n,'l) gen_tactic_expr | TacLetIn of rec_flag * - (identifier located * ('t,'p,'c,'i,'r,'n,'l) gen_tactic_arg) list * + (Id.t located * ('t,'p,'c,'i,'r,'n,'l) gen_tactic_arg) list * ('t,'p,'c,'i,'r,'n,'l) gen_tactic_expr | TacMatch of lazy_flag * ('t,'p,'c,'i,'r,'n,'l) gen_tactic_expr * @@ -229,7 +229,7 @@ and ('t,'p,'c,'i,'r,'n,'l) gen_tactic_expr = | TacArg of ('t,'p,'c,'i,'r,'n,'l) gen_tactic_arg located and ('t,'p,'c,'i,'r,'n,'l) gen_tactic_fun_ast = - identifier option list * ('t,'p,'c,'i,'r,'n,'l) gen_tactic_expr + Id.t option list * ('t,'p,'c,'i,'r,'n,'l) gen_tactic_expr (** Globalized tactics *) @@ -238,7 +238,7 @@ and g_pat = glob_constr_and_expr * constr_pattern and g_cst = evaluable_global_reference and_short_name or_var and g_ind = inductive or_var and g_ref = ltac_constant located or_var -and g_nam = identifier located +and g_nam = Id.t located and glob_tactic_expr = (g_trm, g_pat, g_cst, g_ind, g_ref, g_nam, glevel) gen_tactic_expr @@ -256,7 +256,7 @@ type r_pat = constr_pattern_expr type r_cst = reference or_by_notation type r_ind = reference or_by_notation type r_ref = reference -type r_nam = identifier located or_metaid +type r_nam = Id.t located or_metaid type r_lev = rlevel type raw_atomic_tactic_expr = diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index f1eebc18e..16175be0d 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -18,7 +18,7 @@ open Libnames (** Vernac expressions, produced by the parser *) -type lident = identifier located +type lident = Id.t located type lname = name located type lstring = string located type lreference = reference @@ -151,10 +151,10 @@ type definition_expr = * constr_expr option type fixpoint_expr = - identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr option + Id.t located * (Id.t located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr option type cofixpoint_expr = - identifier located * local_binder list * constr_expr * constr_expr option + Id.t located * local_binder list * constr_expr * constr_expr option type local_decl_expr = | AssumExpr of lname * constr_expr @@ -184,7 +184,7 @@ type module_binder = bool option * lident list * module_ast_inl type grammar_tactic_prod_item_expr = | TacTerm of string - | TacNonTerm of Loc.t * string * (Names.identifier * string) option + | TacNonTerm of Loc.t * string * (Names.Id.t * string) option type syntax_modifier = | SetItemLevel of string list * Extend.production_level @@ -312,7 +312,7 @@ type vernac_expr = | VernacCreateHintDb of locality_flag * string * bool | VernacRemoveHints of locality_flag * string list * reference list | VernacHints of locality_flag * string list * hints_expr - | VernacSyntacticDefinition of identifier located * (identifier list * constr_expr) * + | VernacSyntacticDefinition of Id.t located * (Id.t list * constr_expr) * locality_flag * onlyparsing_flag | VernacDeclareImplicits of locality_flag * reference or_by_notation * (explicitation * bool * bool) list list diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 994242a8a..382fcf7f2 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -121,7 +121,7 @@ type instruction = and bytecodes = instruction list -type fv_elem = FVnamed of identifier | FVrel of int +type fv_elem = FVnamed of Id.t | FVrel of int type fv = fv_elem array diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 0a631987e..0698f3836 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -114,7 +114,7 @@ type instruction = and bytecodes = instruction list -type fv_elem = FVnamed of identifier | FVrel of int +type fv_elem = FVnamed of Id.t | FVrel of int type fv = fv_elem array diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 1d2587efe..021e50847 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -188,7 +188,7 @@ let find_at f l = let pos_named id r = let env = !(r.in_env) in let cid = FVnamed id in - let f = function FVnamed id' -> id_eq id id' | _ -> false in + let f = function FVnamed id' -> Id.equal id id' | _ -> false in try Kenvacc(r.offset + env.size - (find_at f env.fv_rev)) with Not_found -> let pos = env.size in @@ -710,7 +710,7 @@ let compile env c = Format.print_string "fv = "; List.iter (fun v -> match v with - | FVnamed id -> Format.print_string ((string_of_id id)^"; ") + | FVnamed id -> Format.print_string ((Id.to_string id)^"; ") | FVrel i -> Format.print_string ((string_of_int i)^"; ")) fv; Format .print_string "\n"; Format.print_flush(); *) diff --git a/kernel/closure.ml b/kernel/closure.ml index 370053275..934701f43 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -65,10 +65,10 @@ let with_stats c = end else Lazy.force c -let all_opaque = (Idpred.empty, Cpred.empty) -let all_transparent = (Idpred.full, Cpred.full) +let all_opaque = (Id.Pred.empty, Cpred.empty) +let all_transparent = (Id.Pred.full, Cpred.full) -let is_transparent_variable (ids, _) id = Idpred.mem id ids +let is_transparent_variable (ids, _) id = Id.Pred.mem id ids let is_transparent_constant (_, csts) cst = Cpred.mem cst csts module type RedFlagsSig = sig @@ -80,7 +80,7 @@ module type RedFlagsSig = sig val fIOTA : red_kind val fZETA : red_kind val fCONST : constant -> red_kind - val fVAR : identifier -> red_kind + val fVAR : Id.t -> red_kind val no_red : reds val red_add : reds -> red_kind -> reds val red_sub : reds -> red_kind -> reds @@ -104,7 +104,7 @@ module RedFlags = (struct r_iota : bool } type red_kind = BETA | DELTA | ETA | IOTA | ZETA - | CONST of constant | VAR of identifier + | CONST of constant | VAR of Id.t let fBETA = BETA let fDELTA = DELTA let fETA = ETA @@ -131,7 +131,7 @@ module RedFlags = (struct | ZETA -> { red with r_zeta = true } | VAR id -> let (l1,l2) = red.r_const in - { red with r_const = Idpred.add id l1, l2 } + { red with r_const = Id.Pred.add id l1, l2 } let red_sub red = function | BETA -> { red with r_beta = false } @@ -144,7 +144,7 @@ module RedFlags = (struct | ZETA -> { red with r_zeta = false } | VAR id -> let (l1,l2) = red.r_const in - { red with r_const = Idpred.remove id l1, l2 } + { red with r_const = Id.Pred.remove id l1, l2 } let red_add_transparent red tr = { red with r_const = tr } @@ -160,7 +160,7 @@ module RedFlags = (struct incr_cnt c delta | VAR id -> (* En attendant d'avoir des kn pour les Var *) let (l,_) = red.r_const in - let c = Idpred.mem id l in + let c = Id.Pred.mem id l in incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta | IOTA -> incr_cnt red.r_iota iota @@ -225,7 +225,7 @@ type 'a infos = { i_env : env; i_sigma : existential -> constr option; i_rels : constr option array; - i_vars : (identifier * constr) list; + i_vars : (Id.t * constr) list; i_tab : 'a KeyTable.t } let info_flags info = info.i_flags @@ -659,7 +659,7 @@ let rec to_constr constr_fun lfts v = let fr = mk_clos2 env t in let unfv = update v (fr.norm,fr.term) in to_constr constr_fun lfts unfv - | FLOCKED -> assert false (*mkVar(id_of_string"_LOCK_")*) + | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*) (* This function defines the correspondance between constr and fconstr. When we find a closure whose substitution is the identity, diff --git a/kernel/closure.mli b/kernel/closure.mli index 62ebfe3ea..d7a775fde 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -46,7 +46,7 @@ module type RedFlagsSig = sig val fIOTA : red_kind val fZETA : red_kind val fCONST : constant -> red_kind - val fVAR : identifier -> red_kind + val fVAR : Id.t -> red_kind (** No reduction at all *) val no_red : reds diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index 7da2a7faa..6f013e46f 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -23,14 +23,14 @@ let is_transparent = function | Level 0 -> true | _ -> false -type oracle = level Idmap.t * level Cmap.t +type oracle = level Id.Map.t * level Cmap.t -let var_opacity = ref Idmap.empty +let var_opacity = ref Id.Map.empty let cst_opacity = ref Cmap.empty let get_strategy = function | VarKey id -> - (try Idmap.find id !var_opacity + (try Id.Map.find id !var_opacity with Not_found -> default) | ConstKey c -> (try Cmap.find c !cst_opacity @@ -41,8 +41,8 @@ let set_strategy k l = match k with | VarKey id -> var_opacity := - if l=default then Idmap.remove id !var_opacity - else Idmap.add id l !var_opacity + if l=default then Id.Map.remove id !var_opacity + else Id.Map.add id l !var_opacity | ConstKey c -> cst_opacity := if l=default then Cmap.remove c !cst_opacity @@ -50,9 +50,9 @@ let set_strategy k l = | RelKey _ -> Errors.error "set_strategy: RelKey" let get_transp_state () = - (Idmap.fold - (fun id l ts -> if l=Opaque then Idpred.remove id ts else ts) - !var_opacity Idpred.full, + (Id.Map.fold + (fun id l ts -> if l=Opaque then Id.Pred.remove id ts else ts) + !var_opacity Id.Pred.full, Cmap.fold (fun c l ts -> if l=Opaque then Cpred.remove c ts else ts) !cst_opacity Cpred.full) @@ -67,6 +67,6 @@ let oracle_order l2r k1 k2 = | _ -> l2r (* use recommended default *) (* summary operations *) -let init() = (cst_opacity := Cmap.empty; var_opacity := Idmap.empty) +let init() = (cst_opacity := Cmap.empty; var_opacity := Id.Map.empty) let freeze () = (!var_opacity, !cst_opacity) let unfreeze (vo,co) = (cst_opacity := co; var_opacity := vo) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 99b582fe3..864d2f45a 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -23,7 +23,7 @@ open Environ (*s Cooking the constants. *) -type work_list = identifier array Cmap.t * identifier array Mindmap.t +type work_list = Id.t array Cmap.t * Id.t array Mindmap.t let pop_dirpath p = match repr_dirpath p with | [] -> anomaly "dirpath_prefix: empty dirpath" @@ -139,7 +139,7 @@ let cook_constant env r = in let const_hyps = Sign.fold_named_context (fun (h,_,_) hyps -> - List.filter (fun (id,_,_) -> not (id_eq id h)) hyps) + List.filter (fun (id,_,_) -> not (Id.equal id h)) hyps) hyps ~init:cb.const_hyps in let typ = match cb.const_type with | NonPolymorphicType t -> diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 1586adae7..7adb00da6 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -14,7 +14,7 @@ open Univ (** {6 Cooking the constants. } *) -type work_list = identifier array Cmap.t * identifier array Mindmap.t +type work_list = Id.t array Cmap.t * Id.t array Mindmap.t type recipe = { d_from : constant_body; diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index f44e85320..789df8b3d 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -117,7 +117,7 @@ and slot_for_fv env fv = let (_, b, _) = Sign.lookup_named id env.env_named_context in let v,d = match b with - | None -> (val_of_named id, Idset.empty) + | None -> (val_of_named id, Id.Set.empty) | Some c -> (val_of_constr env c, Environ.global_vars_set (Environ.env_of_pre_env env) c) in nv := VKvalue (v,d); v @@ -131,7 +131,7 @@ and slot_for_fv env fv = let (_, b, _) = lookup_rel i env.env_rel_context in let (v, d) = match b with - | None -> (val_of_rel (nb_rel env - i), Idset.empty) + | None -> (val_of_rel (nb_rel env - i), Id.Set.empty) | Some c -> let renv = env_of_rel i env in (val_of_constr renv c, Environ.global_vars_set (Environ.env_of_pre_env renv) c) in diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 3e5b10f3b..baeab9142 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -241,7 +241,7 @@ type one_inductive_body = { (* Primitive datas *) (* Name of the type: [Ii] *) - mind_typename : identifier; + mind_typename : Id.t; (* Arity context of [Ii] with parameters: [forall params, Ui] *) mind_arity_ctxt : rel_context; @@ -250,7 +250,7 @@ type one_inductive_body = { mind_arity : inductive_arity; (* Names of the constructors: [cij] *) - mind_consnames : identifier array; + mind_consnames : Id.t array; (* Types of the constructors with parameters: [forall params, Tij], where the Ik are replaced by de Bruijn index in the context @@ -363,10 +363,10 @@ let hcons_indarity = function let hcons_mind_packet oib = { oib with - mind_typename = hcons_ident oib.mind_typename; + mind_typename = Id.hcons oib.mind_typename; mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt; mind_arity = hcons_indarity oib.mind_arity; - mind_consnames = Array.smartmap hcons_ident oib.mind_consnames; + mind_consnames = Array.smartmap Id.hcons oib.mind_consnames; mind_user_lc = Array.smartmap hcons_types oib.mind_user_lc; mind_nf_lc = Array.smartmap hcons_types oib.mind_nf_lc } @@ -395,8 +395,8 @@ and struct_expr_body = | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path - | With_definition_body of identifier list * constant_body + With_module_body of Id.t list * module_path + | With_definition_body of Id.t list * constant_body and module_body = { mod_mp : module_path; diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 0a09ad76f..fc142d253 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -123,13 +123,13 @@ type inductive_arity = type one_inductive_body = { (** {8 Primitive datas } *) - mind_typename : identifier; (** Name of the type: [Ii] *) + mind_typename : Id.t; (** Name of the type: [Ii] *) mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *) mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *) - mind_consnames : identifier array; (** Names of the constructors: [cij] *) + mind_consnames : Id.t array; (** Names of the constructors: [cij] *) mind_user_lc : types array; (** Types of the constructors with parameters: [forall params, Tij], @@ -208,8 +208,8 @@ and struct_expr_body = | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path - | With_definition_body of identifier list * constant_body + With_module_body of Id.t list * module_path + | With_definition_body of Id.t list * constant_body and module_body = { (** absolute path of the module *) diff --git a/kernel/entries.mli b/kernel/entries.mli index 2460ec644..db91ff597 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -37,15 +37,15 @@ then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1]; *) type one_inductive_entry = { - mind_entry_typename : identifier; + mind_entry_typename : Id.t; mind_entry_arity : constr; - mind_entry_consnames : identifier list; + mind_entry_consnames : Id.t list; mind_entry_lc : constr list } type mutual_inductive_entry = { mind_entry_record : bool; mind_entry_finite : bool; - mind_entry_params : (identifier * local_entry) list; + mind_entry_params : (Id.t * local_entry) list; mind_entry_inds : one_inductive_entry list } (** {6 Constants (Definition/Axiom) } *) @@ -73,8 +73,8 @@ type module_struct_entry = | MSEapply of module_struct_entry * module_struct_entry and with_declaration = - With_Module of identifier list * module_path - | With_Definition of identifier list * constr + With_Module of Id.t list * module_path + | With_Definition of Id.t list * constr and module_entry = { mod_entry_type : module_struct_entry option; diff --git a/kernel/environ.ml b/kernel/environ.ml index 20436cbe7..27b7c76b4 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -238,12 +238,12 @@ let global_vars_set env constr = let acc = match kind_of_term c with | Var _ | Const _ | Ind _ | Construct _ -> - List.fold_right Idset.add (vars_of_global env c) acc + List.fold_right Id.Set.add (vars_of_global env c) acc | _ -> acc in fold_constr filtrec acc c in - filtrec Idset.empty constr + filtrec Id.Set.empty constr (* [keep_hyps env ids] keeps the part of the section context of [env] which @@ -254,20 +254,20 @@ let keep_hyps env needed = let really_needed = Sign.fold_named_context_reverse (fun need (id,copt,t) -> - if Idset.mem id need then + if Id.Set.mem id need then let globc = match copt with - | None -> Idset.empty + | None -> Id.Set.empty | Some c -> global_vars_set env c in - Idset.union + Id.Set.union (global_vars_set env t) - (Idset.union globc need) + (Id.Set.union globc need) else need) ~init:needed (named_context env) in Sign.fold_named_context (fun (id,_,_ as d) nsign -> - if Idset.mem id really_needed then add_named_decl d nsign + if Id.Set.mem id really_needed then add_named_decl d nsign else nsign) (named_context env) ~init:empty_named_context @@ -322,7 +322,7 @@ let apply_to_hyp (ctxt,vals) id f = let rec aux rtail ctxt vals = match ctxt, vals with | (idc,c,ct as d)::ctxt, v::vals -> - if id_eq idc id then + if Id.equal idc id then (f ctxt d rtail)::ctxt, v::vals else let ctxt',vals' = aux (d::rtail) ctxt vals in @@ -335,7 +335,7 @@ let apply_to_hyp_and_dependent_on (ctxt,vals) id f g = let rec aux ctxt vals = match ctxt,vals with | (idc,c,ct as d)::ctxt, v::vals -> - if id_eq idc id then + if Id.equal idc id then let sign = ctxt,vals in push_named_context_val (f d sign) sign else @@ -349,7 +349,7 @@ let insert_after_hyp (ctxt,vals) id d check = let rec aux ctxt vals = match ctxt, vals with | (idc,c,ct)::ctxt', v::vals' -> - if id_eq idc id then begin + if Id.equal idc id then begin check ctxt; push_named_context_val d (ctxt,vals) end else diff --git a/kernel/environ.mli b/kernel/environ.mli index 51e1cfa5a..d2ca7b3da 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -88,7 +88,7 @@ val push_named_context_val : (** Looks up in the context of local vars referred by names ([named_context]) - raises [Not_found] if the identifier is not found *) + raises [Not_found] if the Id.t is not found *) val lookup_named : variable -> env -> named_declaration val lookup_named_val : variable -> named_context_val -> named_declaration @@ -162,12 +162,12 @@ val set_engagement : engagement -> env -> env directly as [Var id] in [c] or indirectly as a section variable dependent in a global reference occurring in [c] *) -val global_vars_set : env -> constr -> Idset.t +val global_vars_set : env -> constr -> Id.Set.t (** the constr must be a global reference *) -val vars_of_global : env -> constr -> identifier list +val vars_of_global : env -> constr -> Id.t list -val keep_hyps : env -> Idset.t -> section_context +val keep_hyps : env -> Id.Set.t -> section_context (** {5 Unsafe judgments. } We introduce here the pre-type of judgments, which is @@ -212,7 +212,7 @@ val insert_after_hyp : named_context_val -> variable -> named_declaration -> (named_context -> unit) -> named_context_val -val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val +val remove_hyps : Id.t list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 1aa6e8cda..2d6317967 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -37,12 +37,12 @@ let is_constructor_head t = type inductive_error = | NonPos of env * constr * constr | NotEnoughArgs of env * constr * constr - | NotConstructor of env * identifier * constr * constr * int * int + | NotConstructor of env * Id.t * constr * constr * int * int | NonPar of env * constr * int * constr * constr - | SameNamesTypes of identifier - | SameNamesConstructors of identifier - | SameNamesOverlap of identifier list - | NotAnArity of identifier + | SameNamesTypes of Id.t + | SameNamesConstructors of Id.t + | SameNamesOverlap of Id.t list + | NotAnArity of Id.t | BadEntry | LargeNonPropInductiveNotInType @@ -57,10 +57,10 @@ let check_constructors_names = let rec check idset = function | [] -> idset | c::cl -> - if Idset.mem c idset then + if Id.Set.mem c idset then raise (InductiveError (SameNamesConstructors c)) else - check (Idset.add c idset) cl + check (Id.Set.add c idset) cl in check @@ -74,13 +74,13 @@ let mind_check_names mie = | ind::inds -> let id = ind.mind_entry_typename in let cl = ind.mind_entry_consnames in - if Idset.mem id indset then + if Id.Set.mem id indset then raise (InductiveError (SameNamesTypes id)) else let cstset' = check_constructors_names cstset cl in - check (Idset.add id indset) cstset' inds + check (Id.Set.add id indset) cstset' inds in - check Idset.empty Idset.empty mie.mind_entry_inds + check Id.Set.empty Id.Set.empty mie.mind_entry_inds (* The above verification is not necessary from the kernel point of vue since inductive and constructors are not referred to by their name, but only by the name of the inductive packet and an index. *) @@ -373,7 +373,7 @@ if Int.equal nmr 0 then 0 else in find 0 (n-1) (lpar,List.rev hyps) let lambda_implicit_lift n a = - let level = UniverseLevel.make (make_dirpath [id_of_string "implicit"]) 0 in + let level = UniverseLevel.make (make_dirpath [Id.of_string "implicit"]) 0 in let implicit_sort = mkType (Universe.make level) in let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in iterate lambda_implicit n (lift n a) @@ -597,8 +597,8 @@ let fold_inductive_blocks f = let used_section_variables env inds = let ids = fold_inductive_blocks - (fun l c -> Idset.union (Environ.global_vars_set env c) l) - Idset.empty inds in + (fun l c -> Id.Set.union (Environ.global_vars_set env c) l) + Id.Set.empty inds in keep_hyps env ids let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 4d71a81d0..0d3d1bdff 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -23,12 +23,12 @@ open Typeops type inductive_error = | NonPos of env * constr * constr | NotEnoughArgs of env * constr * constr - | NotConstructor of env * identifier * constr * constr * int * int + | NotConstructor of env * Id.t * constr * constr * int * int | NonPar of env * constr * int * constr * constr - | SameNamesTypes of identifier - | SameNamesConstructors of identifier - | SameNamesOverlap of identifier list - | NotAnArity of identifier + | SameNamesTypes of Id.t + | SameNamesConstructors of Id.t + | SameNamesOverlap of Id.t list + | NotAnArity of Id.t | BadEntry | LargeNonPropInductiveNotInType diff --git a/kernel/inductive.ml b/kernel/inductive.ml index d1cffe867..dddac2ba0 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -178,7 +178,7 @@ let instantiate_universes env ctx ar argsorts = (* This is a Type with constraints *) else Type level -exception SingletonInductiveBecomesProp of identifier +exception SingletonInductiveBecomesProp of Id.t let type_of_inductive_knowing_parameters ?(polyprop=true) env mip paramtyps = match mip.mind_arity with diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 89ba78697..abf5e6c2c 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -89,7 +89,7 @@ val check_cofix : env -> cofixpoint -> unit parameter instantiation. This is used by the Ocaml extraction, which cannot handle (yet?) Prop-polymorphism. *) -exception SingletonInductiveBecomesProp of identifier +exception SingletonInductiveBecomesProp of Id.t val type_of_inductive_knowing_parameters : ?polyprop:bool -> env -> one_inductive_body -> types array -> types diff --git a/kernel/modops.ml b/kernel/modops.ml index 084628a4e..51b4ca39c 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -29,8 +29,8 @@ type signature_mismatch_error = | DefinitionFieldExpected | ModuleFieldExpected | ModuleTypeFieldExpected - | NotConvertibleInductiveField of identifier - | NotConvertibleConstructorField of identifier + | NotConvertibleInductiveField of Id.t + | NotConvertibleConstructorField of Id.t | NotConvertibleBodyField | NotConvertibleTypeField | NotSameConstructorNamesField diff --git a/kernel/modops.mli b/kernel/modops.mli index 99cb8144a..0d87ce88b 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -56,8 +56,8 @@ type signature_mismatch_error = | DefinitionFieldExpected | ModuleFieldExpected | ModuleTypeFieldExpected - | NotConvertibleInductiveField of identifier - | NotConvertibleConstructorField of identifier + | NotConvertibleInductiveField of Id.t + | NotConvertibleConstructorField of Id.t | NotConvertibleBodyField | NotConvertibleTypeField | NotSameConstructorNamesField diff --git a/kernel/names.ml b/kernel/names.ml index 1917f8f40..dad51b51f 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -24,48 +24,75 @@ open Util (** {6 Identifiers } *) -type identifier = string +module Id = +struct + type t = string + + let equal = String.equal -let check_ident_soft x = - Option.iter (fun (fatal,x) -> - if fatal then error x else Pp.msg_warning (str x)) - (Unicode.ident_refutation x) -let check_ident x = - Option.iter (fun (_,x) -> Errors.error x) (Unicode.ident_refutation x) + let compare = String.compare -let id_of_string s = - let () = check_ident_soft s in - let s = String.copy s in - String.hcons s + let check_soft x = + let iter (fatal, x) = + if fatal then error x else Pp.msg_warning (str x) + in + Option.iter iter (Unicode.ident_refutation x) -let string_of_id id = String.copy id + let check x = + let iter (_, x) = Errors.error x in + Option.iter iter (Unicode.ident_refutation x) -let id_ord = String.compare + let of_string s = + let () = check_soft s in + let s = String.copy s in + String.hcons s -let id_eq = String.equal + let to_string id = String.copy id -module IdOrdered = + module Self = struct - type t = identifier - let compare = id_ord + type t = string + let compare = compare end -module Idset = Set.Make(IdOrdered) -module Idmap = -struct - include Map.Make(IdOrdered) - exception Finded - let exists f m = - try iter (fun a b -> if f a b then raise Finded) m ; false - with |Finded -> true - let singleton k v = add k v empty + module Set = Set.Make(Self) + module Map = + struct + include Map.Make(Self) + exception Finded + let exists f m = + try iter (fun a b -> if f a b then raise Finded) m ; false + with Finded -> true + let singleton k v = add k v empty + end + + module Pred = Predicate.Make(Self) + + let hcons = String.hcons + end -module Idpred = Predicate.Make(IdOrdered) + +(** Backward compatibility for [Id.t] *) + +type identifier = Id.t + +let id_eq = Id.equal +let id_ord = Id.compare +let check_ident_soft = Id.check_soft +let check_ident = Id.check +let string_of_id = Id.to_string +let id_of_string = Id.of_string + +module Idset = Id.Set +module Idmap = Id.Map +module Idpred = Id.Pred + +(** / End of backward compatibility *) (** {6 Various types based on identifiers } *) -type name = Name of identifier | Anonymous -type variable = identifier +type name = Name of Id.t | Anonymous +type variable = Id.t let name_eq n1 n2 = match n1, n2 with | Anonymous, Anonymous -> true @@ -78,7 +105,7 @@ let name_eq n1 n2 = match n1, n2 with The actual representation is reversed to optimise sharing: Coq.A.B is ["B";"A";"Coq"] *) -type module_ident = identifier +type module_ident = Id.t type dir_path = module_ident list module ModIdmap = Idmap @@ -90,7 +117,7 @@ let rec dir_path_ord (p1 : dir_path) (p2 : dir_path) = | [], _ -> -1 | _, [] -> 1 | id1 :: p1, id2 :: p2 -> - let c = id_ord id1 id2 in + let c = Id.compare id1 id2 in if Int.equal c 0 then dir_path_ord p1 p2 else c end @@ -111,7 +138,7 @@ let string_of_dirpath = function (** {6 Unique names for bound modules } *) let u_number = ref 0 -type uniq_ident = int * identifier * dir_path +type uniq_ident = int * Id.t * dir_path let make_uid dir s = incr u_number;(!u_number,s,dir) let debug_string_of_uid (i,s,p) = "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">" @@ -125,7 +152,7 @@ let uniq_ident_ord (x : uniq_ident) (y : uniq_ident) = let ans = Int.compare nl nr in if not (Int.equal ans 0) then ans else - let ans = id_ord idl idr in + let ans = Id.compare idl idr in if not (Int.equal ans 0) then ans else dir_path_ord dpl dpr @@ -149,7 +176,7 @@ let id_of_mbid (_,s,_) = s (** {6 Names of structure elements } *) -type label = identifier +type label = Id.t let mk_label = id_of_string let string_of_label = string_of_id @@ -389,12 +416,12 @@ module Constrmap_env = Map.Make(ConstructorOrdered_env) (* Better to have it here that in closure, since used in grammar.cma *) type evaluable_global_reference = - | EvalVarRef of identifier + | EvalVarRef of Id.t | EvalConstRef of constant let eq_egr e1 e2 = match e1, e2 with EvalConstRef con1, EvalConstRef con2 -> eq_constant con1 con2 - | EvalVarRef id1, EvalVarRef id2 -> Int.equal (id_ord id1 id2) 0 + | EvalVarRef id1, EvalVarRef id2 -> Int.equal (Id.compare id1 id2) 0 | _, _ -> false (** {6 Hash-consing of name objects } *) @@ -402,7 +429,7 @@ let eq_egr e1 e2 = match e1, e2 with module Hname = Hashcons.Make( struct type t = name - type u = identifier -> identifier + type u = Id.t -> Id.t let hashcons hident = function | Name id -> Name (hident id) | n -> n @@ -418,7 +445,7 @@ module Hname = Hashcons.Make( module Hdir = Hashcons.Make( struct type t = dir_path - type u = identifier -> identifier + type u = Id.t -> Id.t let hashcons hident d = List.smartmap hident d let rec equal d1 d2 = (d1==d2) || @@ -432,7 +459,7 @@ module Hdir = Hashcons.Make( module Huniqid = Hashcons.Make( struct type t = uniq_ident - type u = (identifier -> identifier) * (dir_path -> dir_path) + type u = (Id.t -> Id.t) * (dir_path -> dir_path) let hashcons (hid,hdir) (n,s,dir) = (n,hid s,hdir dir) let equal ((n1,s1,dir1) as x) ((n2,s2,dir2) as y) = (x == y) || @@ -502,10 +529,9 @@ module Hconstruct = Hashcons.Make( let hash = Hashtbl.hash end) -let hcons_ident = String.hcons -let hcons_name = Hashcons.simple_hcons Hname.generate hcons_ident -let hcons_dirpath = Hashcons.simple_hcons Hdir.generate hcons_ident -let hcons_uid = Hashcons.simple_hcons Huniqid.generate (hcons_ident,hcons_dirpath) +let hcons_name = Hashcons.simple_hcons Hname.generate Id.hcons +let hcons_dirpath = Hashcons.simple_hcons Hdir.generate Id.hcons +let hcons_uid = Hashcons.simple_hcons Huniqid.generate (Id.hcons,hcons_dirpath) let hcons_mp = Hashcons.simple_hcons Hmod.generate (hcons_dirpath,hcons_uid,String.hcons) let hcons_kn = Hashcons.simple_hcons Hkn.generate (hcons_mp,hcons_dirpath,String.hcons) @@ -526,7 +552,7 @@ let cst_full_transparent_state = (Idpred.empty, Cpred.full) type 'a tableKey = | ConstKey of constant - | VarKey of identifier + | VarKey of Id.t | RelKey of 'a @@ -544,7 +570,7 @@ let eq_id_key ik1 ik2 = if ans then Int.equal (kn_ord kn1 kn2) 0 else ans | VarKey id1, VarKey id2 -> - Int.equal (id_ord id1 id2) 0 + Int.equal (Id.compare id1 id2) 0 | RelKey k1, RelKey k2 -> Int.equal k1 k2 | _ -> false diff --git a/kernel/names.mli b/kernel/names.mli index 0f37c8055..c0b38666b 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -8,37 +8,60 @@ (** {6 Identifiers } *) -type identifier +module Id : +sig + type t + (** Type of identifiers *) -val check_ident : string -> unit -val check_ident_soft : string -> unit + val equal : t -> t -> bool + (** Equality over identifiers *) -(** Parsing and printing of identifiers *) -val string_of_id : identifier -> string -val id_of_string : string -> identifier + val compare : t -> t -> int + (** Comparison over identifiers *) -val id_ord : identifier -> identifier -> int -val id_eq : identifier -> identifier -> bool + val check : string -> unit + (** Check that a string may be converted to an identifier. Raise an exception + related to the problem when this is not the case. *) + + val check_soft : string -> unit + (** As [check], but may raise a warning instead of failing when the string is + not an identifier, but is a well-formed string. *) + + val of_string : string -> t + (** Converts a string into an identifier. *) + + val to_string : t -> string + (** Converts a identifier into an string. *) + + module Set : Set.S with type elt = t + (** Finite sets of identifiers. *) + + module Map : sig + include Map.S with type key = t + (** FIXME: this is included in OCaml 3.12 *) + val exists : (key -> 'a -> bool) -> 'a t -> bool + val singleton : key -> 'a -> 'a t + end + (** Finite maps of identifiers. *) + + module Pred : Predicate.S with type elt = t + (** Predicates over identifiers. *) + + val hcons : t -> t + (** Hashconsing of identifiers. *) -(** Identifiers sets and maps *) -module Idset : Set.S with type elt = identifier -module Idpred : Predicate.S with type elt = identifier -module Idmap : sig - include Map.S with type key = identifier - val exists : (identifier -> 'a -> bool) -> 'a t -> bool - val singleton : key -> 'a -> 'a t end (** {6 Various types based on identifiers } *) -type name = Name of identifier | Anonymous -type variable = identifier +type name = Name of Id.t | Anonymous +type variable = Id.t val name_eq : name -> name -> bool (** {6 Directory paths = section names paths } *) -type module_ident = identifier +type module_ident = Id.t module ModIdmap : Map.S with type key = module_ident type dir_path @@ -67,8 +90,8 @@ val mk_label : string -> label val string_of_label : label -> string val pr_label : label -> Pp.std_ppcmds -val label_of_id : identifier -> label -val id_of_label : label -> identifier +val label_of_id : Id.t -> label +val id_of_label : label -> Id.t val eq_label : label -> label -> bool @@ -85,9 +108,9 @@ val mod_bound_id_eq : mod_bound_id -> mod_bound_id -> bool (** The first argument is a file name - to prevent conflict between different files *) -val make_mbid : dir_path -> identifier -> mod_bound_id -val repr_mbid : mod_bound_id -> int * identifier * dir_path -val id_of_mbid : mod_bound_id -> identifier +val make_mbid : dir_path -> Id.t -> mod_bound_id +val repr_mbid : mod_bound_id -> int * Id.t * dir_path +val id_of_mbid : mod_bound_id -> Id.t val debug_string_of_mbid : mod_bound_id -> string val string_of_mbid : mod_bound_id -> string @@ -212,7 +235,7 @@ val eq_constructor : constructor -> constructor -> bool (** Better to have it here that in Closure, since required in grammar.cma *) type evaluable_global_reference = - | EvalVarRef of identifier + | EvalVarRef of Id.t | EvalConstRef of constant val eq_egr : evaluable_global_reference -> evaluable_global_reference @@ -220,7 +243,6 @@ val eq_egr : evaluable_global_reference -> evaluable_global_reference (** {6 Hash-consing } *) -val hcons_ident : identifier -> identifier val hcons_name : name -> name val hcons_dirpath : dir_path -> dir_path val hcons_con : constant -> constant @@ -232,10 +254,10 @@ val hcons_construct : constructor -> constructor type 'a tableKey = | ConstKey of constant - | VarKey of identifier + | VarKey of Id.t | RelKey of 'a -type transparent_state = Idpred.t * Cpred.t +type transparent_state = Id.Pred.t * Cpred.t val empty_transparent_state : transparent_state val full_transparent_state : transparent_state @@ -256,3 +278,40 @@ val eq_id_key : id_key -> id_key -> bool val eq_con_chk : constant -> constant -> bool val eq_ind_chk : inductive -> inductive -> bool +(** {6 Deprecated functions. For backward compatibility. *) + +(** {5 Identifiers} *) + +type identifier = Id.t +(** @deprecated Alias for [Id.t] *) + +val check_ident : string -> unit +(** @deprecated Same as [Id.check]. *) + +val check_ident_soft : string -> unit +(** @deprecated Same as [Id.check_soft]. *) + +val string_of_id : identifier -> string +(** @deprecated Same as [Id.to_string]. *) + +val id_of_string : string -> identifier +(** @deprecated Same as [Id.of_string]. *) + +val id_ord : identifier -> identifier -> int +(** @deprecated Same as [Id.compare]. *) + +val id_eq : identifier -> identifier -> bool +(** @deprecated Same as [Id.equal]. *) + +module Idset : Set.S with type elt = identifier and type t = Id.Set.t +(** @deprecated Same as [Id.Set]. *) + +module Idpred : Predicate.S with type elt = identifier and type t = Id.Pred.t +(** @deprecated Same as [Id.Pred]. *) + +module Idmap : sig + include Map.S with type key = identifier + val exists : (identifier -> 'a -> bool) -> 'a t -> bool + val singleton : key -> 'a -> 'a t +end +(** @deprecated Same as [Id.Map]. *) diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 207a37f97..2a467ad0a 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -39,12 +39,12 @@ type stratification = { } type val_kind = - | VKvalue of values * Idset.t + | VKvalue of values * Id.Set.t | VKnone type lazy_val = val_kind ref -type named_vals = (identifier * lazy_val) list +type named_vals = (Id.t * lazy_val) list type env = { env_globals : globals; @@ -116,7 +116,7 @@ let push_named d env = env_named_vals = (id,rval):: env.env_named_vals } let lookup_named_val id env = - snd(List.find (fun (id',_) -> id_eq id id') env.env_named_vals) + snd(List.find (fun (id',_) -> Id.equal id id') env.env_named_vals) (* Warning all the names should be different *) let env_of_named id env = env diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index a8868a4f8..569e8830a 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -31,12 +31,12 @@ type stratification = { } type val_kind = - | VKvalue of values * Idset.t + | VKvalue of values * Id.Set.t | VKnone type lazy_val = val_kind ref -type named_vals = (identifier * lazy_val) list +type named_vals = (Id.t * lazy_val) list type env = { env_globals : globals; @@ -66,8 +66,8 @@ val env_of_rel : int -> env -> env val push_named_context_val : named_declaration -> named_context_val -> named_context_val val push_named : named_declaration -> env -> env -val lookup_named_val : identifier -> env -> lazy_val -val env_of_named : identifier -> env -> env +val lookup_named_val : Id.t -> env -> lazy_val +val env_of_named : Id.t -> env -> env (** Global constants *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index fb6ffd2d1..9aa70c9eb 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -26,7 +26,7 @@ open Esubst let unfold_reference ((ids, csts), infos) k = match k with - | VarKey id when not (Idpred.mem id ids) -> None + | VarKey id when not (Id.Pred.mem id ids) -> None | ConstKey cst when not (Cpred.mem cst csts) -> None | _ -> unfold_reference infos k @@ -446,7 +446,7 @@ let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->No let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars -let fconv = trans_fconv (Idpred.full, Cpred.full) +let fconv = trans_fconv (Id.Pred.full, Cpred.full) let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None) let conv ?(l2r=false) ?(evars=fun _->None) = fconv CONV l2r evars diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 28052c41b..8a95c9fd2 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -242,7 +242,7 @@ let safe_push_named (id,_,_ as d) env = let _ = try let _ = lookup_named id env in - error ("Identifier "^string_of_id id^" already defined.") + error ("Identifier "^Id.to_string id^" already defined.") with Not_found -> () in Environ.push_named d env diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 34dc68d2e..71ebe15ce 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -31,10 +31,10 @@ val is_empty : safe_environment -> bool (** Adding and removing local declarations (Local or Variables) *) val push_named_assum : - identifier * types -> safe_environment -> + Id.t * types -> safe_environment -> Univ.constraints * safe_environment val push_named_def : - identifier * constr * types option -> safe_environment -> + Id.t * constr * types option -> safe_environment -> Univ.constraints * safe_environment (** Adding global axioms or definitions *) diff --git a/kernel/sign.ml b/kernel/sign.ml index b2a509678..3fced7119 100644 --- a/kernel/sign.ml +++ b/kernel/sign.ml @@ -29,7 +29,7 @@ let empty_named_context = [] let add_named_decl d sign = d::sign let rec lookup_named id = function - | (id',_,_ as decl) :: _ when id_eq id id' -> decl + | (id',_,_ as decl) :: _ when Id.equal id id' -> decl | _ :: sign -> lookup_named id sign | [] -> raise Not_found diff --git a/kernel/sign.mli b/kernel/sign.mli index 4325fe90c..6239ab5dc 100644 --- a/kernel/sign.mli +++ b/kernel/sign.mli @@ -16,9 +16,9 @@ type section_context = named_context val empty_named_context : named_context val add_named_decl : named_declaration -> named_context -> named_context -val vars_of_named_context : named_context -> identifier list +val vars_of_named_context : named_context -> Id.t list -val lookup_named : identifier -> named_context -> named_declaration +val lookup_named : Id.t -> named_context -> named_declaration (** number of declarations *) val named_context_length : named_context -> int diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 6aaf5b47d..d278c2d0c 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -136,8 +136,8 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let check_packet cst p1 p2 = let check f test why = if not (test (f p1) (f p2)) then error why in - check (fun p -> p.mind_consnames) (Array.equal id_eq) NotSameConstructorNamesField; - check (fun p -> p.mind_typename) id_eq NotSameInductiveNameInBlockField; + check (fun p -> p.mind_consnames) (Array.equal Id.equal) NotSameConstructorNamesField; + check (fun p -> p.mind_typename) Id.equal NotSameInductiveNameInBlockField; (* nf_lc later *) (* nf_arity later *) (* user_lc ignored *) diff --git a/kernel/term.ml b/kernel/term.ml index 2ad39d189..ced5c6fc5 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -105,7 +105,7 @@ type ('constr, 'types) pcofixpoint = de Bruijn indices. *) type ('constr, 'types) kind_of_term = | Rel of int - | Var of identifier + | Var of Id.t | Meta of metavariable | Evar of 'constr pexistential | Sort of sorts @@ -345,7 +345,7 @@ let isRelN n c = match kind_of_term c with Rel n' -> Int.equal n n' | _ -> false (* Tests if a variable *) let isVar c = match kind_of_term c with Var _ -> true | _ -> false -let isVarId id c = match kind_of_term c with Var id' -> Int.equal (id_ord id id') 0 | _ -> false +let isVarId id c = match kind_of_term c with Var id' -> Int.equal (Id.compare id id') 0 | _ -> false (* Tests if an inductive *) let isInd c = match kind_of_term c with Ind _ -> true | _ -> false @@ -578,7 +578,7 @@ let compare_constr f t1 t2 = match kind_of_term t1, kind_of_term t2 with | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 - | Var id1, Var id2 -> Int.equal (id_ord id1 id2) 0 + | Var id1, Var id2 -> Int.equal (Id.compare id1 id2) 0 | Sort s1, Sort s2 -> Int.equal (sorts_ord s1 s2) 0 | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 @@ -624,7 +624,7 @@ let constr_ord_int f t1 t2 = match kind_of_term t1, kind_of_term t2 with | Rel n1, Rel n2 -> Int.compare n1 n2 | Meta m1, Meta m2 -> Int.compare m1 m2 - | Var id1, Var id2 -> id_ord id1 id2 + | Var id1, Var id2 -> Id.compare id1 id2 | Sort s1, Sort s2 -> sorts_ord s1 s2 | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 @@ -669,7 +669,7 @@ type types = constr type strategy = types option -type named_declaration = identifier * constr option * types +type named_declaration = Id.t * constr option * types type rel_declaration = name * constr option * types let map_named_declaration f (id, (v : strategy), ty) = (id, Option.map f v, f ty) @@ -685,7 +685,7 @@ let for_all_named_declaration f (_, v, ty) = Option.cata f true v && f ty let for_all_rel_declaration f (_, v, ty) = Option.cata f true v && f ty let eq_named_declaration (i1, c1, t1) (i2, c2, t2) = - id_eq i1 i2 && Option.equal eq_constr c1 c2 && eq_constr t1 t2 + Id.equal i1 i2 && Option.equal eq_constr c1 c2 && eq_constr t1 t2 let eq_rel_declaration (n1, c1, t1) (n2, c2, t2) = name_eq n1 n2 && Option.equal eq_constr c1 c2 && eq_constr t1 t2 @@ -856,7 +856,7 @@ let subst1_named_decl = subst1_decl let rec thin_val = function | [] -> [] | (((id,{ sit = v }) as s)::tl) when isVar v -> - if Int.equal (id_ord id (destVar v)) 0 then thin_val tl else s::(thin_val tl) + if Int.equal (Id.compare id (destVar v)) 0 then thin_val tl else s::(thin_val tl) | h::tl -> h::(thin_val tl) (* (replace_vars sigma M) applies substitution sigma to term M *) @@ -1433,7 +1433,7 @@ let hcons_constr = hcons_ind, hcons_con, hcons_name, - hcons_ident) + Id.hcons) let hcons_types = hcons_constr diff --git a/kernel/term.mli b/kernel/term.mli index cb48fbbe3..17c55f069 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -79,7 +79,7 @@ type types = constr val mkRel : int -> constr (** Constructs a Variable *) -val mkVar : identifier -> constr +val mkVar : Id.t -> constr (** Constructs an patvar named "?n" *) val mkMeta : metavariable -> constr @@ -104,7 +104,7 @@ val mkCast : constr * cast_kind * constr -> constr (** Constructs the product [(x:t1)t2] *) val mkProd : name * types * types -> types -val mkNamedProd : identifier -> types -> types -> types +val mkNamedProd : Id.t -> types -> types -> types (** non-dependent product [t1 -> t2], an alias for [forall (_:t1), t2]. Beware [t_2] is NOT lifted. @@ -114,11 +114,11 @@ val mkArrow : types -> types -> constr (** Constructs the abstraction \[x:t{_ 1}\]t{_ 2} *) val mkLambda : name * types * constr -> constr -val mkNamedLambda : identifier -> types -> constr -> constr +val mkNamedLambda : Id.t -> types -> constr -> constr (** Constructs the product [let x = t1 : t2 in t3] *) val mkLetIn : name * constr * types * constr -> constr -val mkNamedLetIn : identifier -> constr -> types -> constr -> constr +val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr (** [mkApp (f,[| t_1; ...; t_n |]] constructs the application {% $(f~t_1~\dots~t_n)$ %}. *) @@ -197,7 +197,7 @@ type ('constr, 'types) pcofixpoint = type ('constr, 'types) kind_of_term = | Rel of int - | Var of identifier + | Var of Id.t | Meta of metavariable | Evar of 'constr pexistential | Sort of sorts @@ -234,7 +234,7 @@ val kind_of_type : types -> (constr, types) kind_of_type val isRel : constr -> bool val isRelN : int -> constr -> bool val isVar : constr -> bool -val isVarId : identifier -> constr -> bool +val isVarId : Id.t -> constr -> bool val isInd : constr -> bool val isEvar : constr -> bool val isMeta : constr -> bool @@ -271,7 +271,7 @@ val destRel : constr -> int val destMeta : constr -> metavariable (** Destructs a variable *) -val destVar : constr -> identifier +val destVar : constr -> Id.t (** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) @@ -337,7 +337,7 @@ val destCoFix : constr -> cofixpoint (in the latter case, [na] is of type [name] but just for printing purpose) *) -type named_declaration = identifier * constr option * types +type named_declaration = Id.t * constr option * types type rel_declaration = name * constr option * types val map_named_declaration : @@ -570,16 +570,16 @@ val subst1_decl : constr -> rel_declaration -> rel_declaration val subst1_named_decl : constr -> named_declaration -> named_declaration val substl_named_decl : constr list -> named_declaration -> named_declaration -val replace_vars : (identifier * constr) list -> constr -> constr -val subst_var : identifier -> constr -> constr +val replace_vars : (Id.t * constr) list -> constr -> constr +val subst_var : Id.t -> constr -> constr (** [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t] if two names are identical, the one of least indice is kept *) -val subst_vars : identifier list -> constr -> constr +val subst_vars : Id.t list -> constr -> constr (** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t] if two names are identical, the one of least indice is kept *) -val substn_vars : int -> identifier list -> constr -> constr +val substn_vars : int -> Id.t list -> constr -> constr (** {6 Functionals working on the immediate subterm of a construction } *) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index aed7615b8..ccb6a4a7d 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -62,7 +62,7 @@ let safe_push_named (id,_,_ as d) env = let _ = try let _ = lookup_named id env in - error ("Identifier "^string_of_id id^" already defined.") + error ("Identifier "^Id.to_string id^" already defined.") with Not_found -> () in push_named d env @@ -110,28 +110,28 @@ let global_vars_set_constant_type env = function | PolymorphicArity (ctx,_) -> Sign.fold_rel_context (fold_rel_declaration - (fun t c -> Idset.union (global_vars_set env t) c)) - ctx ~init:Idset.empty + (fun t c -> Id.Set.union (global_vars_set env t) c)) + ctx ~init:Id.Set.empty let build_constant_declaration env kn (def,typ,cst,ctx) = let hyps = let inferred = let ids_typ = global_vars_set_constant_type env typ in let ids_def = match def with - | Undef _ -> Idset.empty + | Undef _ -> Id.Set.empty | Def cs -> global_vars_set env (Declarations.force cs) | OpaqueDef lc -> global_vars_set env (Declarations.force_opaque lc) in - keep_hyps env (Idset.union ids_typ ids_def) in + keep_hyps env (Id.Set.union ids_typ ids_def) in let declared = match ctx with | None -> inferred | Some declared -> declared in - let mk_set l = List.fold_right Idset.add (List.map pi1 l) Idset.empty in + let mk_set l = List.fold_right Id.Set.add (List.map pi1 l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in - if not (Idset.subset inferred_set declared_set) then + if not (Id.Set.subset inferred_set declared_set) then error ("The following section variable are used but not declared:\n"^ - (String.concat ", " (List.map string_of_id - (Idset.elements (Idset.diff inferred_set declared_set))))); + (String.concat ", " (List.map Id.to_string + (Id.Set.elements (Id.Set.diff inferred_set declared_set))))); declared in let tps = Cemitcodes.from_val (compile_constant_body env def) in { const_hyps = hyps; diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 3a4179fd4..7b3aff20d 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -20,7 +20,7 @@ val infer_v : env -> constr array -> unsafe_judgment array * constraints val infer_type : env -> types -> unsafe_type_judgment * constraints val infer_local_decls : - env -> (identifier * local_entry) list + env -> (Id.t * local_entry) list -> env * rel_context * constraints (** {6 Basic operations of the typing machine. } *) diff --git a/kernel/univ.ml b/kernel/univ.ml index 5f2e32a5d..1d71fd672 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -776,7 +776,7 @@ let bellman_ford bottom g = graph already contains [Type.n] nodes (calling a module Type is probably a bad idea anyway). *) let sort_universes orig = - let mp = Names.make_dirpath [Names.id_of_string "Type"] in + let mp = Names.make_dirpath [Names.Id.of_string "Type"] in let rec make_level accu g i = let type0 = UniverseLevel.Level (i, mp) in let distances = bellman_ford type0 g in diff --git a/kernel/vm.mli b/kernel/vm.mli index 4bdc1fbff..cbc68c488 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -54,7 +54,7 @@ type whd = val val_of_str_const : structured_constant -> values val val_of_rel : int -> values -val val_of_named : identifier -> values +val val_of_named : Id.t -> values val val_of_constant : constant -> values external val_of_annot_switch : annot_switch -> values = "%identity" diff --git a/library/assumptions.ml b/library/assumptions.ml index 7d85b362a..1f6c8eeeb 100644 --- a/library/assumptions.ml +++ b/library/assumptions.ml @@ -24,7 +24,7 @@ open Mod_subst let cst_ord k1 k2 = kn_ord (canonical_con k1) (canonical_con k2) type context_object = - | Variable of identifier (* A section variable or a Let definition *) + | Variable of Id.t (* A section variable or a Let definition *) | Axiom of constant (* An axiom or a constant. *) | Opaque of constant (* An opaque constant. *) | Transparent of constant @@ -35,7 +35,7 @@ struct type t = context_object let compare x y = match x , y with - | Variable i1 , Variable i2 -> id_ord i1 i2 + | Variable i1 , Variable i2 -> Id.compare i1 i2 | Axiom k1 , Axiom k2 -> cst_ord k1 k2 | Opaque k1 , Opaque k2 -> cst_ord k1 k2 | Transparent k1 , Transparent k2 -> cst_ord k1 k2 diff --git a/library/assumptions.mli b/library/assumptions.mli index e5d2a977c..f91412013 100644 --- a/library/assumptions.mli +++ b/library/assumptions.mli @@ -13,7 +13,7 @@ open Environ (** A few declarations for the "Print Assumption" command @author spiwack *) type context_object = - | Variable of identifier (** A section variable or a Let definition *) + | Variable of Id.t (** A section variable or a Let definition *) | Axiom of constant (** An axiom or a constant. *) | Opaque of constant (** An opaque constant. *) | Transparent of constant (** A transparent constant *) diff --git a/library/declare.ml b/library/declare.ml index 9d986d185..b5670a1a2 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -80,7 +80,7 @@ let discharge_variable (_,o) = match o with | Inl _ -> Some o type variable_obj = - (Univ.constraints, identifier * variable_declaration) union + (Univ.constraints, Id.t * variable_declaration) union let inVariable : variable_obj -> obj = declare_object { (default_object "VARIABLE") with diff --git a/library/declare.mli b/library/declare.mli index 9cc6e371c..09bd6ac8b 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -55,11 +55,11 @@ type internal_flag = | UserVerbose val declare_constant : - ?internal:internal_flag -> identifier -> constant_declaration -> constant + ?internal:internal_flag -> Id.t -> constant_declaration -> constant val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> - identifier -> ?types:constr -> constr -> constant + Id.t -> ?types:constr -> constr -> constant (** [declare_mind me] declares a block of inductive types with their constructors in the current section; it returns the path of @@ -76,11 +76,11 @@ val add_cache_hook : (full_path -> unit) -> unit (** Declaration messages *) -val definition_message : identifier -> unit -val assumption_message : identifier -> unit -val fixpoint_message : int array option -> identifier list -> unit -val cofixpoint_message : identifier list -> unit +val definition_message : Id.t -> unit +val assumption_message : Id.t -> unit +val fixpoint_message : int array option -> Id.t list -> unit +val cofixpoint_message : Id.t list -> unit val recursive_message : bool (** true = fixpoint *) -> - int array option -> identifier list -> unit + int array option -> Id.t list -> unit -val exists_name : identifier -> bool +val exists_name : Id.t -> bool diff --git a/library/declaremods.ml b/library/declaremods.ml index b8dd671cf..b58b355f7 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -436,7 +436,7 @@ let rec replace_module_object idl (mbids,mp,lib_stack) (mbids2,mp2,objs) mp1 = | [] -> () | _ -> anomaly "Unexpected functor objects" in let rec replace_idl = function | _,[] -> [] - | id::idl,(id',obj)::tail when id_eq id id' -> + | id::idl,(id',obj)::tail when Id.equal id id' -> if not (String.equal (object_tag obj) "MODULE") then anomaly "MODULE expected!"; let substobjs = match idl with | [] -> diff --git a/library/declaremods.mli b/library/declaremods.mli index dedb9b67a..e52e2620a 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -64,14 +64,14 @@ val declare_module : (env -> 'modast -> module_struct_entry) -> (env -> 'modast -> module_struct_entry) -> (env -> 'modast -> module_struct_entry * bool) -> - identifier -> - (identifier located list * ('modast annotated)) list -> + Id.t -> + (Id.t located list * ('modast annotated)) list -> ('modast annotated) module_signature -> ('modast annotated) list -> module_path val start_module : (env -> 'modast -> module_struct_entry) -> - bool option -> identifier -> - (identifier located list * ('modast annotated)) list -> + bool option -> Id.t -> + (Id.t located list * ('modast annotated)) list -> ('modast annotated) module_signature -> module_path val end_module : unit -> module_path @@ -82,14 +82,14 @@ val end_module : unit -> module_path val declare_modtype : (env -> 'modast -> module_struct_entry) -> (env -> 'modast -> module_struct_entry * bool) -> - identifier -> - (identifier located list * ('modast annotated)) list -> + Id.t -> + (Id.t located list * ('modast annotated)) list -> ('modast annotated) list -> ('modast annotated) list -> module_path val start_modtype : (env -> 'modast -> module_struct_entry) -> - identifier -> (identifier located list * ('modast annotated)) list -> + Id.t -> (Id.t located list * ('modast annotated)) list -> ('modast annotated) list -> module_path val end_modtype : unit -> module_path diff --git a/library/decls.ml b/library/decls.ml index af6ee3448..205e51f9b 100644 --- a/library/decls.ml +++ b/library/decls.ml @@ -20,25 +20,25 @@ open Libnames type variable_data = dir_path * bool (* opacity *) * Univ.constraints * logical_kind -let vartab = ref (Idmap.empty : variable_data Idmap.t) +let vartab = ref (Id.Map.empty : variable_data Id.Map.t) let _ = Summary.declare_summary "VARIABLE" { Summary.freeze_function = (fun () -> !vartab); Summary.unfreeze_function = (fun ft -> vartab := ft); - Summary.init_function = (fun () -> vartab := Idmap.empty) } + Summary.init_function = (fun () -> vartab := Id.Map.empty) } -let add_variable_data id o = vartab := Idmap.add id o !vartab +let add_variable_data id o = vartab := Id.Map.add id o !vartab -let variable_path id = let (p,_,_,_) = Idmap.find id !vartab in p -let variable_opacity id = let (_,opaq,_,_) = Idmap.find id !vartab in opaq -let variable_kind id = let (_,_,_,k) = Idmap.find id !vartab in k -let variable_constraints id = let (_,_,cst,_) = Idmap.find id !vartab in cst +let variable_path id = let (p,_,_,_) = Id.Map.find id !vartab in p +let variable_opacity id = let (_,opaq,_,_) = Id.Map.find id !vartab in opaq +let variable_kind id = let (_,_,_,k) = Id.Map.find id !vartab in k +let variable_constraints id = let (_,_,cst,_) = Id.Map.find id !vartab in cst let variable_secpath id = let dir = drop_dirpath_prefix (Lib.library_dp()) (variable_path id) in make_qualid dir id -let variable_exists id = Idmap.mem id !vartab +let variable_exists id = Id.Map.mem id !vartab (** Datas associated to global parameters and constants *) diff --git a/library/decls.mli b/library/decls.mli index d06db6e34..c424eacd3 100644 --- a/library/decls.mli +++ b/library/decls.mli @@ -40,4 +40,4 @@ val initialize_named_context_for_proof : unit -> Environ.named_context_val (** Miscellaneous functions *) -val last_section_hyps : dir_path -> identifier list +val last_section_hyps : dir_path -> Id.t list diff --git a/library/global.mli b/library/global.mli index 82b7cc8eb..fdada3f87 100644 --- a/library/global.mli +++ b/library/global.mli @@ -35,22 +35,22 @@ val named_context : unit -> Sign.named_context val env_is_empty : unit -> bool (** {6 Extending env with variables and local definitions } *) -val push_named_assum : (identifier * types) -> Univ.constraints -val push_named_def : (identifier * constr * types option) -> Univ.constraints +val push_named_assum : (Id.t * types) -> Univ.constraints +val push_named_def : (Id.t * constr * types option) -> Univ.constraints (** {6 ... } *) (** Adding constants, inductives, modules and module types. All these functions verify that given names match those generated by kernel *) val add_constant : - dir_path -> identifier -> global_declaration -> constant + dir_path -> Id.t -> global_declaration -> constant val add_mind : - dir_path -> identifier -> mutual_inductive_entry -> mutual_inductive + dir_path -> Id.t -> mutual_inductive_entry -> mutual_inductive val add_module : - identifier -> module_entry -> inline -> module_path * delta_resolver + Id.t -> module_entry -> inline -> module_path * delta_resolver val add_modtype : - identifier -> module_struct_entry -> inline -> module_path + Id.t -> module_struct_entry -> inline -> module_path val add_include : module_struct_entry -> bool -> inline -> delta_resolver @@ -65,16 +65,16 @@ val set_engagement : engagement -> unit (** [start_*] functions return the [module_path] valid for components of the started module / module type *) -val start_module : identifier -> module_path +val start_module : Id.t -> module_path -val end_module : Summary.frozen ->identifier -> +val end_module : Summary.frozen ->Id.t -> (module_struct_entry * inline) option -> module_path * delta_resolver val add_module_parameter : mod_bound_id -> module_struct_entry -> inline -> delta_resolver -val start_modtype : identifier -> module_path -val end_modtype : Summary.frozen -> identifier -> module_path +val start_modtype : Id.t -> module_path +val end_modtype : Summary.frozen -> Id.t -> module_path val pack_module : unit -> module_body diff --git a/library/globnames.ml b/library/globnames.ml index b5312e574..9ce5451a1 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -29,7 +29,7 @@ let eq_gr gr1 gr2 = | ConstRef con1, ConstRef con2 -> eq_constant con1 con2 | IndRef kn1, IndRef kn2 -> eq_ind kn1 kn2 | ConstructRef kn1, ConstructRef kn2 -> eq_constructor kn1 kn2 - | VarRef v1, VarRef v2 -> id_eq v1 v2 + | VarRef v1, VarRef v2 -> Id.equal v1 v2 | _ -> false let destVarRef = function VarRef ind -> ind | _ -> failwith "destVarRef" @@ -87,7 +87,7 @@ let global_ord_gen fc fmi x y = | ConstructRef (indx,jx), ConstructRef (indy,jy) -> let c = Int.compare jx jy in if Int.equal c 0 then ind_ord indx indy else c - | VarRef v1, VarRef v2 -> id_ord v1 v2 + | VarRef v1, VarRef v2 -> Id.compare v1 v2 | _, _ -> Pervasives.compare x y let global_ord_can = global_ord_gen canonical_con canonical_mind diff --git a/library/globnames.mli b/library/globnames.mli index af1f10ee4..b82c68ea7 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -80,10 +80,10 @@ val constr_of_global_or_constr : global_reference_or_constr -> constr (** {6 Temporary function to brutally form kernel names from section paths } *) -val encode_mind : dir_path -> identifier -> mutual_inductive -val decode_mind : mutual_inductive -> dir_path * identifier -val encode_con : dir_path -> identifier -> constant -val decode_con : constant -> dir_path * identifier +val encode_mind : dir_path -> Id.t -> mutual_inductive +val decode_mind : mutual_inductive -> dir_path * Id.t +val encode_con : dir_path -> Id.t -> constant +val decode_con : constant -> dir_path * Id.t (** {6 Popping one level of section in global names } *) diff --git a/library/goptions.ml b/library/goptions.ml index 460b153de..858ebbfc8 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -342,7 +342,7 @@ let msg_option_value (name,v) = | IntValue (Some n) -> int n | IntValue None -> str "undefined" | StringValue s -> str s -(* | IdentValue r -> pr_global_env Idset.empty r *) +(* | IdentValue r -> pr_global_env Id.Set.empty r *) let print_option_value key = let (name, depr, (_,read,_,_,_)) = get_option key in diff --git a/library/impargs.ml b/library/impargs.ml index 8df8420c8..e2abb0925 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -264,7 +264,7 @@ type force_inference = bool (* true = always infer, never turn into evar/subgoal type implicit_status = (* None = Not implicit *) - (identifier * implicit_explanation * (maximal_insertion * force_inference)) option + (Id.t * implicit_explanation * (maximal_insertion * force_inference)) option type implicit_side_condition = DefaultImpArgs | LessArgsThan of int @@ -326,7 +326,7 @@ let check_correct_manual_implicits autoimps l = List.iter (function | ExplByName id,(b,fi,forced) -> if not forced then - error ("Wrong or non-dependent implicit argument name: "^(string_of_id id)^".") + error ("Wrong or non-dependent implicit argument name: "^(Id.to_string id)^".") | ExplByPos (i,_id),_t -> if i<1 or i>List.length autoimps then error ("Bad implicit argument number: "^(string_of_int i)^".") @@ -340,7 +340,7 @@ let set_manual_implicits env flags enriching autoimps l = try let (id, (b, fi, fo)), l' = assoc_by_pos k l in if fo then - let id = match id with Some id -> id | None -> id_of_string ("arg_" ^ string_of_int k) in + let id = match id with Some id -> id | None -> Id.of_string ("arg_" ^ string_of_int k) in l', Some (id,Manual,(b,fi)) else l, None with Not_found -> l, None diff --git a/library/impargs.mli b/library/impargs.mli index 79d506568..66d72abbb 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -68,7 +68,7 @@ type implicit_explanation = type maximal_insertion = bool (** true = maximal contextual insertion *) type force_inference = bool (** true = always infer, never turn into evar/subgoal *) -type implicit_status = (identifier * implicit_explanation * +type implicit_status = (Id.t * implicit_explanation * (maximal_insertion * force_inference)) option (** [None] = Not implicit *) @@ -78,7 +78,7 @@ type implicits_list = implicit_side_condition * implicit_status list val is_status_implicit : implicit_status -> bool val is_inferable_implicit : bool -> int -> implicit_status -> bool -val name_of_implicit : implicit_status -> identifier +val name_of_implicit : implicit_status -> Id.t val maximal_insertion_of : implicit_status -> bool val force_inference_of : implicit_status -> bool diff --git a/library/lib.ml b/library/lib.ml index 2653b8418..6e82bfcb6 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -31,7 +31,7 @@ and library_entry = object_name * node and library_segment = library_entry list -type lib_objects = (Names.identifier * obj) list +type lib_objects = (Names.Id.t * obj) list let module_kind is_type = if is_type then "module type" else "module" @@ -214,7 +214,7 @@ let add_entry sp node = let anonymous_id = let n = ref 0 in - fun () -> incr n; Names.id_of_string ("_" ^ (string_of_int !n)) + fun () -> incr n; Names.Id.of_string ("_" ^ (string_of_int !n)) let add_anonymous_entry node = let id = anonymous_id () in @@ -387,8 +387,8 @@ let find_opening_node id = try let oname,entry = find_entry_p is_opening_node in let id' = basename (fst oname) in - if not (Names.id_eq id id') then - error ("Last block to end has name "^(Names.string_of_id id')^"."); + if not (Names.Id.equal id id') then + error ("Last block to end has name "^(Names.Id.to_string id')^"."); entry with Not_found -> error "There is nothing to end." @@ -401,12 +401,12 @@ let find_opening_node id = - the list of substitution to do at section closing *) -type variable_info = Names.identifier * Decl_kinds.binding_kind * Term.constr option * Term.types +type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types type variable_context = variable_info list type abstr_list = variable_context Names.Cmap.t * variable_context Names.Mindmap.t let sectab = - ref ([] : ((Names.identifier * Decl_kinds.binding_kind) list * + ref ([] : ((Names.Id.t * Decl_kinds.binding_kind) list * Cooking.work_list * abstr_list) list) let add_section () = @@ -420,7 +420,7 @@ let add_section_variable id impl = let extract_hyps (secs,ohyps) = let rec aux = function - | ((id,impl)::idl,(id',b,t)::hyps) when Names.id_eq id id' -> + | ((id,impl)::idl,(id',b,t)::hyps) when Names.Id.equal id id' -> (id',impl,b,t) :: aux (idl,hyps) | (id::idl,hyps) -> aux (idl,hyps) | [], _ -> [] @@ -461,7 +461,7 @@ let section_segment_of_mutual_inductive kn = let rec list_mem_assoc x = function | [] -> raise Not_found - | (a, _) :: l -> Int.equal (Names.id_ord a x) 0 || list_mem_assoc x l + | (a, _) :: l -> Int.equal (Names.Id.compare a x) 0 || list_mem_assoc x l let section_instance = function | VarRef id -> @@ -612,7 +612,7 @@ let label_before_name (loc,id) = | (_, Leaf o) when !found && String.equal (object_tag o) "DOT" -> true | ((fp, _),_) -> let (_, name) = repr_path fp in - let () = if Names.id_eq id name then found := true in + let () = if Names.Id.equal id name then found := true in false in match find_entry_p search with @@ -657,7 +657,7 @@ let rec split_mp mp = | Names.MPfile dp -> dp, Names.empty_dirpath | Names.MPdot (prfx, lbl) -> let mprec, dprec = split_mp prfx in - mprec, Names.make_dirpath (Names.id_of_string (Names.string_of_label lbl) :: (Names.repr_dirpath dprec)) + mprec, Names.make_dirpath (Names.Id.of_string (Names.string_of_label lbl) :: (Names.repr_dirpath dprec)) | Names.MPbound mbid -> let (_, id, dp) = Names.repr_mbid mbid in library_dp(), Names.make_dirpath [id] let split_modpath mp = diff --git a/library/lib.mli b/library/lib.mli index 25c0e1b24..75e18b194 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -27,7 +27,7 @@ type node = and library_segment = (Libnames.object_name * node) list -type lib_objects = (Names.identifier * Libobject.obj) list +type lib_objects = (Names.Id.t * Libobject.obj) list (** {6 Object iteration functions. } *) @@ -53,12 +53,12 @@ val segment_of_objects : (** Adding operations (which call the [cache] method, and getting the current list of operations (most recent ones coming first). *) -val add_leaf : Names.identifier -> Libobject.obj -> Libnames.object_name +val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name val add_anonymous_leaf : Libobject.obj -> unit (** this operation adds all objects with the same name and calls [load_object] for each of them *) -val add_leaves : Names.identifier -> Libobject.obj list -> Libnames.object_name +val add_leaves : Names.Id.t -> Libobject.obj list -> Libnames.object_name val add_frozen_state : unit -> unit @@ -75,14 +75,14 @@ val contents_after : Libnames.object_name option -> library_segment val cwd : unit -> Names.dir_path val cwd_except_section : unit -> Names.dir_path val current_dirpath : bool -> Names.dir_path (* false = except sections *) -val make_path : Names.identifier -> Libnames.full_path -val make_path_except_section : Names.identifier -> Libnames.full_path +val make_path : Names.Id.t -> Libnames.full_path +val make_path_except_section : Names.Id.t -> Libnames.full_path val path_of_include : unit -> Libnames.full_path (** Kernel-side names *) val current_prefix : unit -> Names.module_path * Names.dir_path -val make_kn : Names.identifier -> Names.kernel_name -val make_con : Names.identifier -> Names.constant +val make_kn : Names.Id.t -> Names.kernel_name +val make_con : Names.Id.t -> Names.constant (** Are we inside an opened section *) val sections_are_opened : unit -> bool @@ -98,7 +98,7 @@ val is_module : unit -> bool val current_mod_id : unit -> Names.module_ident (** Returns the opening node of a given name *) -val find_opening_node : Names.identifier -> node +val find_opening_node : Names.Id.t -> node (** {6 Modules and module types } *) @@ -134,13 +134,13 @@ val library_dp : unit -> Names.dir_path (** Extract the library part of a name even if in a section *) val dp_of_mp : Names.module_path -> Names.dir_path val split_mp : Names.module_path -> Names.dir_path * Names.dir_path -val split_modpath : Names.module_path -> Names.dir_path * Names.identifier list +val split_modpath : Names.module_path -> Names.dir_path * Names.Id.t list val library_part : Globnames.global_reference -> Names.dir_path val remove_section_part : Globnames.global_reference -> Names.dir_path (** {6 Sections } *) -val open_section : Names.identifier -> unit +val open_section : Names.Id.t -> unit val close_section : unit -> unit (** {6 Backtracking } *) @@ -164,7 +164,7 @@ val first_command_label : int val reset_label : int -> unit (** search the label registered immediately before adding some definition *) -val label_before_name : Names.identifier Loc.located -> int +val label_before_name : Names.Id.t Loc.located -> int (** {6 We can get and set the state of the operations (used in [States]). } *) @@ -176,29 +176,29 @@ val unfreeze : frozen -> unit val init : unit -> unit (** XML output hooks *) -val set_xml_open_section : (Names.identifier -> unit) -> unit -val set_xml_close_section : (Names.identifier -> unit) -> unit +val set_xml_open_section : (Names.Id.t -> unit) -> unit +val set_xml_close_section : (Names.Id.t -> unit) -> unit (** {6 Section management for discharge } *) -type variable_info = Names.identifier * Decl_kinds.binding_kind * +type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types type variable_context = variable_info list -val instance_from_variable_context : variable_context -> Names.identifier array +val instance_from_variable_context : variable_context -> Names.Id.t array val named_of_variable_context : variable_context -> Sign.named_context val section_segment_of_constant : Names.constant -> variable_context val section_segment_of_mutual_inductive: Names.mutual_inductive -> variable_context -val section_instance : Globnames.global_reference -> Names.identifier array +val section_instance : Globnames.global_reference -> Names.Id.t array val is_in_section : Globnames.global_reference -> bool -val add_section_variable : Names.identifier -> Decl_kinds.binding_kind -> unit +val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> unit val add_section_constant : Names.constant -> Sign.named_context -> unit val add_section_kn : Names.mutual_inductive -> Sign.named_context -> unit val replacement_context : unit -> - (Names.identifier array Names.Cmap.t * Names.identifier array Names.Mindmap.t) + (Names.Id.t array Names.Cmap.t * Names.Id.t array Names.Mindmap.t) (** {6 Discharge: decrease the section level if in the current section } *) diff --git a/library/libnames.ml b/library/libnames.ml index a0eff296c..ee24b2575 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -59,7 +59,7 @@ let parse_dir s = in if Int.equal pos n then error (s ^ " is an invalid path."); let dir = String.sub s n (pos-n) in - decoupe_dirs ((id_of_string dir)::dirs) (pos+1) + decoupe_dirs ((Id.of_string dir)::dirs) (pos+1) in decoupe_dirs [] 0 @@ -80,10 +80,10 @@ module Dirmap = Map.Make(struct type t = dir_path let compare = dir_path_ord end type full_path = { dirpath : dir_path ; - basename : identifier } + basename : Id.t } let eq_full_path p1 p2 = - id_eq p1.basename p2.basename && + Id.equal p1.basename p2.basename && Int.equal (dir_path_ord p1.dirpath p2.dirpath) 0 let make_path pa id = { dirpath = pa; basename = id } @@ -94,14 +94,14 @@ let repr_path { dirpath = pa; basename = id } = (pa,id) let string_of_path sp = let (sl,id) = repr_path sp in match repr_dirpath sl with - | [] -> string_of_id id - | _ -> (string_of_dirpath sl) ^ "." ^ (string_of_id id) + | [] -> Id.to_string id + | _ -> (string_of_dirpath sl) ^ "." ^ (Id.to_string id) let sp_ord sp1 sp2 = let (p1,id1) = repr_path sp1 and (p2,id2) = repr_path sp2 in let p_bit = compare p1 p2 in - if Int.equal p_bit 0 then id_ord id1 id2 else p_bit + if Int.equal p_bit 0 then Id.compare id1 id2 else p_bit module SpOrdered = struct @@ -178,7 +178,7 @@ let eq_global_dir_reference r1 r2 = match r1, r2 with type reference = | Qualid of qualid Loc.located - | Ident of identifier Loc.located + | Ident of Id.t Loc.located let qualid_of_reference = function | Qualid (loc,qid) -> loc, qid @@ -186,11 +186,11 @@ let qualid_of_reference = function let string_of_reference = function | Qualid (loc,qid) -> string_of_qualid qid - | Ident (loc,id) -> string_of_id id + | Ident (loc,id) -> Id.to_string id let pr_reference = function | Qualid (_,qid) -> pr_qualid qid - | Ident (_,id) -> str (string_of_id id) + | Ident (_,id) -> str (Id.to_string id) let loc_of_reference = function | Qualid (loc,qid) -> loc @@ -198,7 +198,7 @@ let loc_of_reference = function let eq_reference r1 r2 = match r1, r2 with | Qualid (_, q1), Qualid (_, q2) -> qualid_eq q1 q2 -| Ident (_, id1), Ident (_, id2) -> id_eq id1 id2 +| Ident (_, id1), Ident (_, id2) -> Id.equal id1 id2 | _ -> false (* Deprecated synonyms *) diff --git a/library/libnames.mli b/library/libnames.mli index 434041f77..08330349e 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -23,7 +23,7 @@ val pop_dirpath : dir_path -> dir_path val pop_dirpath_n : int -> dir_path -> dir_path (** Give the immediate prefix and basename of a [dir_path] *) -val split_dirpath : dir_path -> dir_path * identifier +val split_dirpath : dir_path -> dir_path * Id.t val add_dirpath_suffix : dir_path -> module_ident -> dir_path val add_dirpath_prefix : module_ident -> dir_path -> dir_path @@ -43,12 +43,12 @@ type full_path val eq_full_path : full_path -> full_path -> bool (** Constructors of [full_path] *) -val make_path : dir_path -> identifier -> full_path +val make_path : dir_path -> Id.t -> full_path (** Destructors of [full_path] *) -val repr_path : full_path -> dir_path * identifier +val repr_path : full_path -> dir_path * Id.t val dirpath : full_path -> dir_path -val basename : full_path -> identifier +val basename : full_path -> Id.t (** Parsing and printing of section path as ["coq_root.module.id"] *) val path_of_string : string -> full_path @@ -67,8 +67,8 @@ val restrict_path : int -> full_path -> full_path type qualid -val make_qualid : dir_path -> identifier -> qualid -val repr_qualid : qualid -> dir_path * identifier +val make_qualid : dir_path -> Id.t -> qualid +val repr_qualid : qualid -> dir_path * Id.t val qualid_eq : qualid -> qualid -> bool @@ -76,12 +76,12 @@ val pr_qualid : qualid -> std_ppcmds val string_of_qualid : qualid -> string val qualid_of_string : string -> qualid -(** Turns an absolute name, a dirpath, or an identifier into a +(** Turns an absolute name, a dirpath, or an Id.t into a qualified name denoting the same name *) val qualid_of_path : full_path -> qualid val qualid_of_dirpath : dir_path -> qualid -val qualid_of_ident : identifier -> qualid +val qualid_of_ident : Id.t -> qualid (** Both names are passed to objects: a "semantic" [kernel_name], which can be substituted and a "syntactic" [full_path] which can be printed @@ -93,7 +93,7 @@ type object_prefix = dir_path * (module_path * dir_path) val eq_op : object_prefix -> object_prefix -> bool -val make_oname : object_prefix -> identifier -> object_name +val make_oname : object_prefix -> Id.t -> object_name (** to this type are mapped [dir_path]'s in the nametab *) type global_dir_reference = @@ -114,7 +114,7 @@ val eq_global_dir_reference : type reference = | Qualid of qualid located - | Ident of identifier located + | Ident of Id.t located val eq_reference : reference -> reference -> bool val qualid_of_reference : reference -> qualid located @@ -124,5 +124,5 @@ val loc_of_reference : reference -> Loc.t (** Deprecated synonyms *) -val make_short_qualid : identifier -> qualid (** = qualid_of_ident *) +val make_short_qualid : Id.t -> qualid (** = qualid_of_ident *) val qualid_of_sp : full_path -> qualid (** = qualid_of_path *) diff --git a/library/library.ml b/library/library.ml index ec84a75e8..b25b1d313 100644 --- a/library/library.ml +++ b/library/library.ml @@ -71,7 +71,7 @@ let add_load_path isroot (phys_path,coq_path) = let extend_path_with_dirpath p dir = List.fold_left Filename.concat p - (List.map string_of_id (List.rev (repr_dirpath dir))) + (List.map Id.to_string (List.rev (repr_dirpath dir))) let root_paths_matching_dir_path dir = let rec aux = function @@ -330,7 +330,7 @@ let locate_absolute_library dir = let loadpath = root_paths_matching_dir_path pref in let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in try - let name = (string_of_id base)^".vo" in + let name = (Id.to_string base)^".vo" in let _, file = System.where_in_path ~warn:false loadpath name in (dir, file) with Not_found -> @@ -346,7 +346,7 @@ let locate_qualified_library warn qid = let dir, base = repr_qualid qid in let loadpath = loadpaths_matching_dir_path dir in let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in - let name = string_of_id base ^ ".vo" in + let name = Id.to_string base ^ ".vo" in let lpath, file = System.where_in_path ~warn (List.map fst loadpath) name in let dir = add_dirpath_suffix (List.assoc lpath loadpath) base in (* Look if loaded *) @@ -450,7 +450,7 @@ let rec_intern_library needed mref = let _,needed = intern_library needed mref in needed let check_library_short_name f dir = function - | Some id when not (id_eq id (snd (split_dirpath dir))) -> + | Some id when not (Id.equal id (snd (split_dirpath dir))) -> errorlabstrm "check_library_short_name" (str ("The file " ^ f ^ " contains library") ++ spc () ++ pr_dirpath dir ++ spc () ++ str "and not library" ++ spc () ++ @@ -598,9 +598,9 @@ let import_module export (loc,qid) = let check_coq_overwriting p id = let l = repr_dirpath p in let is_empty = match l with [] -> true | _ -> false in - if not !Flags.boot && not is_empty && String.equal (string_of_id (List.last l)) "Coq" then + if not !Flags.boot && not is_empty && String.equal (Id.to_string (List.last l)) "Coq" then errorlabstrm "" - (strbrk ("Cannot build module "^string_of_dirpath p^"."^string_of_id id^ + (strbrk ("Cannot build module "^string_of_dirpath p^"."^Id.to_string id^ ": it starts with prefix \"Coq\" which is reserved for the Coq library.")) let start_library f = @@ -608,7 +608,7 @@ let start_library f = let _,longf = System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in let ldir0 = find_logical_path (Filename.dirname longf) in - let id = id_of_string (Filename.basename f) in + let id = Id.of_string (Filename.basename f) in check_coq_overwriting ldir0 id; let ldir = add_dirpath_suffix ldir0 id in Declaremods.start_library ldir; diff --git a/library/library.mli b/library/library.mli index f17ea8b6e..4e88a85b5 100644 --- a/library/library.mli +++ b/library/library.mli @@ -26,7 +26,7 @@ open Libobject val require_library : qualid located list -> bool option -> unit val require_library_from_dirpath : (dir_path * string) list -> bool option -> unit val require_library_from_file : - identifier option -> CUnix.physical_path -> bool option -> unit + Id.t option -> CUnix.physical_path -> bool option -> unit (** {6 ... } *) (** Open a module (or a library); if the boolean is true then it's also diff --git a/library/nameops.ml b/library/nameops.ml index 461e7a405..f8f95135f 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -12,7 +12,7 @@ open Names (* Identifiers *) -let pr_id id = str (string_of_id id) +let pr_id id = str (Id.to_string id) let pr_name = function | Anonymous -> str "_" @@ -24,7 +24,7 @@ let code_of_0 = Char.code '0' let code_of_9 = Char.code '9' let cut_ident skip_quote s = - let s = string_of_id s in + let s = Id.to_string s in let slen = String.length s in (* [n'] is the position of the first non nullary digit *) let rec numpart n n' = @@ -46,7 +46,7 @@ let cut_ident skip_quote s = let repr_ident s = let numstart = cut_ident false s in - let s = string_of_id s in + let s = Id.to_string s in let slen = String.length s in if Int.equal numstart slen then (s, None) @@ -60,17 +60,17 @@ let make_ident sa = function let s = if c < code_of_0 or c > code_of_9 then sa ^ (string_of_int n) else sa ^ "_" ^ (string_of_int n) in - id_of_string s - | None -> id_of_string (String.copy sa) + Id.of_string s + | None -> Id.of_string (String.copy sa) let root_of_id id = let suffixstart = cut_ident true id in - id_of_string (String.sub (string_of_id id) 0 suffixstart) + Id.of_string (String.sub (Id.to_string id) 0 suffixstart) (* Rem: semantics is a bit different, if an ident starts with toto00 then after successive renamings it comes to toto09, then it goes on with toto10 *) let lift_subscript id = - let id = string_of_id id in + let id = Id.to_string id in let len = String.length id in let rec add carrypos = let c = id.[carrypos] in @@ -93,20 +93,20 @@ let lift_subscript id = end; newid end - in id_of_string (add (len-1)) + in Id.of_string (add (len-1)) let has_subscript id = - let id = string_of_id id in + let id = Id.to_string id in is_digit (id.[String.length id - 1]) let forget_subscript id = let numstart = cut_ident false id in let newid = String.make (numstart+1) '0' in - String.blit (string_of_id id) 0 newid 0 numstart; - (id_of_string newid) + String.blit (Id.to_string id) 0 newid 0 numstart; + (Id.of_string newid) -let add_suffix id s = id_of_string (string_of_id id ^ s) -let add_prefix s id = id_of_string (s ^ string_of_id id) +let add_suffix id s = Id.of_string (Id.to_string id ^ s) +let add_prefix s id = Id.of_string (s ^ Id.to_string id) let atompart_of_id id = fst (repr_ident id) @@ -141,7 +141,7 @@ let pr_lab l = str (string_of_label l) let default_library = Names.initial_dir (* = ["Top"] *) (*s Roots of the space of absolute names *) -let coq_root = id_of_string "Coq" +let coq_root = Id.of_string "Coq" let default_root_prefix = make_dirpath [] (* Metavariables *) diff --git a/library/nameops.mli b/library/nameops.mli index fb26c1910..3bdd64f75 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -9,31 +9,31 @@ open Names (** Identifiers and names *) -val pr_id : identifier -> Pp.std_ppcmds +val pr_id : Id.t -> Pp.std_ppcmds val pr_name : name -> Pp.std_ppcmds -val make_ident : string -> int option -> identifier -val repr_ident : identifier -> string * int option +val make_ident : string -> int option -> Id.t +val repr_ident : Id.t -> string * int option -val atompart_of_id : identifier -> string (** remove trailing digits *) -val root_of_id : identifier -> identifier (** remove trailing digits, ' and _ *) +val atompart_of_id : Id.t -> string (** remove trailing digits *) +val root_of_id : Id.t -> Id.t (** remove trailing digits, ' and _ *) -val add_suffix : identifier -> string -> identifier -val add_prefix : string -> identifier -> identifier +val add_suffix : Id.t -> string -> Id.t +val add_prefix : string -> Id.t -> Id.t -val has_subscript : identifier -> bool -val lift_subscript : identifier -> identifier -val forget_subscript : identifier -> identifier +val has_subscript : Id.t -> bool +val lift_subscript : Id.t -> Id.t +val forget_subscript : Id.t -> Id.t -val out_name : name -> identifier +val out_name : name -> Id.t (** [out_name] associates [id] to [Name id]. Raises [Failure "Nameops.out_name"] otherwise. *) -val name_fold : (identifier -> 'a -> 'a) -> name -> 'a -> 'a -val name_iter : (identifier -> unit) -> name -> unit -val name_cons : name -> identifier list -> identifier list -val name_app : (identifier -> identifier) -> name -> name -val name_fold_map : ('a -> identifier -> 'a * identifier) -> 'a -> name -> 'a * name +val name_fold : (Id.t -> 'a -> 'a) -> name -> 'a -> 'a +val name_iter : (Id.t -> unit) -> name -> unit +val name_cons : name -> Id.t list -> Id.t list +val name_app : (Id.t -> Id.t) -> name -> name +val name_fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> name -> 'a * name val pr_lab : label -> Pp.std_ppcmds diff --git a/library/nametab.ml b/library/nametab.ml index 7c1100165..bbcee8b66 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -48,7 +48,7 @@ module type UserName = sig type t val equal : t -> t -> bool val to_string : t -> string - val repr : t -> identifier * module_ident list + val repr : t -> Id.t * module_ident list end module type EqualityType = @@ -77,7 +77,7 @@ module type NAMETREE = sig val find : user_name -> t -> elt val exists : user_name -> t -> bool val user_name : qualid -> t -> user_name - val shortest_qualid : Idset.t -> user_name -> t -> qualid + val shortest_qualid : Id.Set.t -> user_name -> t -> qualid val find_prefixes : qualid -> t -> elt list end @@ -101,9 +101,9 @@ struct let mktree p m = { path=p; map=m } let empty_tree = mktree Nothing ModIdmap.empty - type t = nametree Idmap.t + type t = nametree Id.Map.t - let empty = Idmap.empty + let empty = Id.Map.empty (* [push_until] is used to register [Until vis] visibility and [push_exactly] to [Exactly vis] and [push_tree] chooses the right one*) @@ -178,14 +178,14 @@ let rec push_exactly uname o level tree = function let push visibility uname o tab = let id,dir = U.repr uname in let ptab = - try Idmap.find id tab + try Id.Map.find id tab with Not_found -> empty_tree in let ptab' = match visibility with | Until i -> push_until uname o (i-1) ptab dir | Exactly i -> push_exactly uname o (i-1) ptab dir in - Idmap.add id ptab' tab + Id.Map.add id ptab' tab let rec search tree = function @@ -194,7 +194,7 @@ let rec search tree = function let find_node qid tab = let (dir,id) = repr_qualid qid in - search (Idmap.find id tab) (repr_dirpath dir) + search (Id.Map.find id tab) (repr_dirpath dir) let locate qid tab = let o = match find_node qid tab with @@ -212,7 +212,7 @@ let user_name qid tab = let find uname tab = let id,l = U.repr uname in - match search (Idmap.find id tab) l with + match search (Id.Map.find id tab) l with Absolute (_,o) -> o | _ -> raise Not_found @@ -225,7 +225,7 @@ let exists uname tab = let shortest_qualid ctx uname tab = let id,dir = U.repr uname in - let hidden = Idset.mem id ctx in + let hidden = Id.Set.mem id ctx in let rec find_uname pos dir tree = let is_empty = match pos with [] -> true | _ -> false in match tree.path with @@ -236,7 +236,7 @@ let shortest_qualid ctx uname tab = [] -> raise Not_found | id::dir -> find_uname (id::pos) dir (ModIdmap.find id tree.map) in - let ptab = Idmap.find id tab in + let ptab = Id.Map.find id tab in let found_dir = find_uname [] dir ptab in make_qualid (make_dirpath found_dir) id @@ -256,7 +256,7 @@ let rec search_prefixes tree = function let find_prefixes qid tab = try let (dir,id) = repr_qualid qid in - search_prefixes (Idmap.find id tab) (repr_dirpath dir) + search_prefixes (Id.Map.find id tab) (repr_dirpath dir) with Not_found -> [] end @@ -520,15 +520,15 @@ let shortest_qualid_of_syndef ctx kn = let shortest_qualid_of_module mp = let dir = MPmap.find mp !the_modrevtab in - DirTab.shortest_qualid Idset.empty dir !the_dirtab + DirTab.shortest_qualid Id.Set.empty dir !the_dirtab let shortest_qualid_of_modtype kn = let sp = MPmap.find kn !the_modtyperevtab in - MPTab.shortest_qualid Idset.empty sp !the_modtypetab + MPTab.shortest_qualid Id.Set.empty sp !the_modtypetab let shortest_qualid_of_tactic kn = let sp = KNmap.find kn !the_tacticrevtab in - KnTab.shortest_qualid Idset.empty sp !the_tactictab + KnTab.shortest_qualid Id.Set.empty sp !the_tactictab let pr_global_env env ref = (* Il est important de laisser le let-in, car les streams s'évaluent diff --git a/library/nametab.mli b/library/nametab.mli index 8c22749b5..8a18166a9 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -51,7 +51,7 @@ open Globnames {- [shortest_qualid_of : object_reference -> user_name] The [user_name] can be for example the shortest non ambiguous [qualid] or - the [full_user_name] or [identifier]. Such a function can also have a + the [full_user_name] or [Id.t]. Such a function can also have a local context argument.}} *) @@ -149,18 +149,18 @@ val path_of_tactic : ltac_constant -> full_path associated to global reference *) val dirpath_of_global : global_reference -> dir_path -val basename_of_global : global_reference -> identifier +val basename_of_global : global_reference -> Id.t (** Printing of global references using names as short as possible *) -val pr_global_env : Idset.t -> global_reference -> std_ppcmds +val pr_global_env : Id.Set.t -> global_reference -> std_ppcmds (** The [shortest_qualid] functions given an object with [user_name] Coq.A.B.x, try to find the shortest among x, B.x, A.B.x and Coq.A.B.x that denotes the same object. *) -val shortest_qualid_of_global : Idset.t -> global_reference -> qualid -val shortest_qualid_of_syndef : Idset.t -> syndef_name -> qualid +val shortest_qualid_of_global : Id.Set.t -> global_reference -> qualid +val shortest_qualid_of_syndef : Id.Set.t -> syndef_name -> qualid val shortest_qualid_of_modtype : module_path -> qualid val shortest_qualid_of_module : module_path -> qualid val shortest_qualid_of_tactic : ltac_constant -> qualid diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 1c00e6581..bbc4a0c5a 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -56,7 +56,7 @@ let cases_pattern_expr_of_name (loc,na) = match na with type grammar_constr_prod_item = | GramConstrTerminal of Tok.t - | GramConstrNonTerminal of constr_prod_entry_key * identifier option + | GramConstrNonTerminal of constr_prod_entry_key * Id.t option | GramConstrListMark of int * bool (* tells action rule to make a list of the n previous parsed items; concat with last parsed list if true *) diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli index 3079ffc28..827e7c197 100644 --- a/parsing/egramcoq.mli +++ b/parsing/egramcoq.mli @@ -27,7 +27,7 @@ open Egramml type grammar_constr_prod_item = | GramConstrTerminal of Tok.t - | GramConstrNonTerminal of constr_prod_entry_key * identifier option + | GramConstrNonTerminal of constr_prod_entry_key * Id.t option | GramConstrListMark of int * bool (* tells action rule to make a list of the n previous parsed items; concat with last parsed list if true *) diff --git a/parsing/egramml.ml b/parsing/egramml.ml index ae7351a9a..a24804786 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -31,7 +31,7 @@ let make_generic_action type grammar_prod_item = | GramTerminal of string | GramNonTerminal of - Loc.t * argument_type * prod_entry_key * identifier option + Loc.t * argument_type * prod_entry_key * Id.t option let make_prod_item = function | GramTerminal s -> (gram_token_of_string s, None) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index d38652c97..442b0138f 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -14,7 +14,7 @@ type grammar_prod_item = | GramTerminal of string | GramNonTerminal of Loc.t * Genarg.argument_type * - Pcoq.prod_entry_key * Names.identifier option + Pcoq.prod_entry_key * Names.Id.t option val extend_tactic_grammar : string -> grammar_prod_item list list -> unit @@ -29,5 +29,5 @@ val get_extend_vernac_grammars : (** Utility function reused in Egramcoq : *) val make_rule : - (Loc.t -> (Names.identifier * Tacexpr.raw_generic_argument) list -> 'b) -> + (Loc.t -> (Names.Id.t * Tacexpr.raw_generic_argument) list -> 'b) -> grammar_prod_item list -> Pcoq.Gram.symbol list * Pcoq.Gram.action diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 1f7a85c8e..3f246b48c 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -21,7 +21,7 @@ open Pcoq.Prim open Pcoq.Constr (* TODO: avoid this redefinition without an extra dep to Notation_ops *) -let ldots_var = id_of_string ".." +let ldots_var = Id.of_string ".." let constr_kw = [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; @@ -88,7 +88,7 @@ let lpar_id_coloneq = (match get_tok (stream_nth 2 strm) with | KEYWORD ":=" -> stream_njunk 3 strm; - Names.id_of_string s + Names.Id.of_string s | _ -> err ()) | _ -> err ()) | _ -> err ()) @@ -102,7 +102,7 @@ let impl_ident_head = | IDENT ("wf"|"struct"|"measure") -> err () | IDENT s -> stream_njunk 2 strm; - Names.id_of_string s + Names.Id.of_string s | _ -> err ()) | _ -> err ()) @@ -114,7 +114,7 @@ let name_colon = (match get_tok (stream_nth 1 strm) with | KEYWORD ":" -> stream_njunk 2 strm; - Name (Names.id_of_string s) + Name (Names.Id.of_string s) | _ -> err ()) | KEYWORD "_" -> (match get_tok (stream_nth 1 strm) with @@ -135,7 +135,7 @@ GEXTEND Gram [ [ id = Prim.ident -> id (* This is used in quotations and Syntax *) - | id = METAIDENT -> id_of_string id ] ] + | id = METAIDENT -> Id.of_string id ] ] ; Prim.name: [ [ "_" -> (!@loc, Anonymous) ] ] diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index e868bc77c..8e52a3bab 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -39,7 +39,7 @@ GEXTEND Gram [ [ s = IDENT -> s ] ] ; ident: - [ [ s = IDENT -> id_of_string s ] ] + [ [ s = IDENT -> Id.of_string s ] ] ; pattern_ident: [ [ LEFTQMARK; id = ident -> id ] ] @@ -54,7 +54,7 @@ GEXTEND Gram [ [ id = ident -> (!@loc, id) ] ] ; field: - [ [ s = FIELD -> id_of_string s ] ] + [ [ s = FIELD -> Id.of_string s ] ] ; fields: [ [ id = field; (l,id') = fields -> (l@[id],id') diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 index e1a43c400..53ade7c2c 100644 --- a/parsing/g_xml.ml4 +++ b/parsing/g_xml.ml4 @@ -79,7 +79,7 @@ let get_xml_attr s al = (* Interpreting specific attributes *) -let ident_of_cdata (loc,a) = id_of_string a +let ident_of_cdata (loc,a) = Id.of_string a let uri_of_data s = let n = String.index s ':' in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index e9b504e05..d1fd1edc7 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -159,25 +159,25 @@ module Prim : open Names open Libnames val preident : string Gram.entry - val ident : identifier Gram.entry + val ident : Id.t Gram.entry val name : name located Gram.entry - val identref : identifier located Gram.entry - val pattern_ident : identifier Gram.entry - val pattern_identref : identifier located Gram.entry - val base_ident : identifier Gram.entry + val identref : Id.t located Gram.entry + val pattern_ident : Id.t Gram.entry + val pattern_identref : Id.t located Gram.entry + val base_ident : Id.t Gram.entry val natural : int Gram.entry val bigint : Bigint.bigint Gram.entry val integer : int Gram.entry val string : string Gram.entry val qualid : qualid located Gram.entry - val fullyqualid : identifier list located Gram.entry + val fullyqualid : Id.t list located Gram.entry val reference : reference Gram.entry val by_notation : (Loc.t * string * string option) Gram.entry val smart_global : reference or_by_notation Gram.entry val dirpath : dir_path Gram.entry val ne_string : string Gram.entry val ne_lstring : string located Gram.entry - val var : identifier located Gram.entry + val var : Id.t located Gram.entry end module Constr : @@ -187,7 +187,7 @@ module Constr : val lconstr : constr_expr Gram.entry val binder_constr : constr_expr Gram.entry val operconstr : constr_expr Gram.entry - val ident : identifier Gram.entry + val ident : Id.t Gram.entry val global : reference Gram.entry val sort : glob_sort Gram.entry val pattern : cases_pattern_expr Gram.entry @@ -197,7 +197,7 @@ module Constr : val binder : local_binder list Gram.entry (* closed_binder or variable *) val binders : local_binder list Gram.entry (* list of binder *) val open_binders : local_binder list Gram.entry - val binders_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.entry + val binders_fixannot : (local_binder list * (Id.t located option * recursion_order_expr)) Gram.entry val typeclass_constraint : (name located * bool * constr_expr) Gram.entry val record_declaration : constr_expr Gram.entry val appl_arg : (constr_expr * explicitation located option) Gram.entry diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 2155171c9..f029c053a 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -98,7 +98,7 @@ type cinfo= type term= Symb of constr | Product of sorts_family * sorts_family - | Eps of identifier + | Eps of Id.t | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) @@ -106,7 +106,7 @@ let rec term_equal t1 t2 = match t1, t2 with | Symb c1, Symb c2 -> eq_constr c1 c2 | Product (s1, t1), Product (s2, t2) -> s1 = s2 && t1 = t2 - | Eps i1, Eps i2 -> id_ord i1 i2 = 0 + | Eps i1, Eps i2 -> Id.compare i1 i2 = 0 | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2 | Constructor {ci_constr=c1; ci_arity=i1; ci_nhyps=j1}, Constructor {ci_constr=c2; ci_arity=i2; ci_nhyps=j2} -> @@ -149,7 +149,7 @@ type patt_kind = | Creates_variables type quant_eq = - {qe_hyp_id: identifier; + {qe_hyp_id: Id.t; qe_pol: bool; qe_nvars:int; qe_lhs: ccpattern; @@ -203,7 +203,7 @@ module Termhash = Hashtbl.Make end) module Identhash = Hashtbl.Make - (struct type t = identifier + (struct type t = Id.t let equal = Pervasives.(=) let hash = Hashtbl.hash end) @@ -356,8 +356,8 @@ let new_representative typ = (* rebuild a constr from an applicative term *) -let _A_ = Name (id_of_string "A") -let _B_ = Name (id_of_string "A") +let _A_ = Name (Id.of_string "A") +let _B_ = Name (Id.of_string "A") let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) let cc_product s1 s2 = @@ -722,7 +722,7 @@ let one_step state = true with Not_found -> false -let __eps__ = id_of_string "_eps_" +let __eps__ = Id.of_string "_eps_" let new_state_var typ state = let id = pf_get_new_id __eps__ state.gls in diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 6232b126e..5d286c732 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -18,7 +18,7 @@ type cinfo = type term = Symb of constr | Product of sorts_family * sorts_family - | Eps of identifier + | Eps of Id.t | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) @@ -87,7 +87,7 @@ val add_equality : state -> constr -> term -> term -> unit val add_disequality : state -> from -> term -> term -> unit -val add_quant : state -> identifier -> bool -> +val add_quant : state -> Id.t -> bool -> int * patt_kind * ccpattern * patt_kind * ccpattern -> unit val tail_pac : pa_constructor -> pa_constructor @@ -106,7 +106,7 @@ val join_path : forest -> int -> int -> ((int * int) * equality) list * ((int * int) * equality) list type quant_eq= - {qe_hyp_id: identifier; + {qe_hyp_id: Id.t; qe_pol: bool; qe_nvars:int; qe_lhs: ccpattern; @@ -161,7 +161,7 @@ type term = type rule = Congruence - | Axiom of Names.identifier + | Axiom of Names.Id.t | Injection of int*int*int*int type equality = @@ -207,19 +207,19 @@ val process_rec : UF.t -> equality list -> int list val cc : UF.t -> unit val make_uf : - (Names.identifier * (term * term)) list -> UF.t + (Names.Id.t * (term * term)) list -> UF.t val add_one_diseq : UF.t -> (term * term) -> int * int val add_disaxioms : - UF.t -> (Names.identifier * (term * term)) list -> - (Names.identifier * (int * int)) list + UF.t -> (Names.Id.t * (term * term)) list -> + (Names.Id.t * (int * int)) list val check_equal : UF.t -> int * int -> bool val find_contradiction : UF.t -> - (Names.identifier * (int * int)) list -> - (Names.identifier * (int * int)) + (Names.Id.t * (int * int)) list -> + (Names.Id.t * (int * int)) *) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 7d4d1728a..9a2f23d64 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -238,7 +238,7 @@ let build_projection intype outtype (cstr:constructor) special default gls= let pred=mkLambda(Anonymous,intype,outtype) in let case_info=make_case_info (pf_env gls) ind RegularStyle in let body= mkCase(case_info, pred, casee, branches) in - let id=pf_get_new_id (id_of_string "t") gls in + let id=pf_get_new_id (Id.of_string "t") gls in mkLambda(Name id,intype,body) (* generate an adhoc tactic following the proof tree *) @@ -275,7 +275,7 @@ let rec proof_tac p gls = let typf = Termops.refresh_universes (pf_type_of gls tf1) in let typx = Termops.refresh_universes (pf_type_of gls tx1) in let typfx = Termops.refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in - let id = pf_get_new_id (id_of_string "f") gls in + let id = pf_get_new_id (Id.of_string "f") gls in let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in let lemma1 = mkApp(Lazy.force _f_equal, @@ -316,7 +316,7 @@ let refute_tac c t1 t2 p gls = let neweq= mkApp(Lazy.force _eq, [|intype;tt1;tt2|]) in - let hid=pf_get_new_id (id_of_string "Heq") gls in + let hid=pf_get_new_id (Id.of_string "Heq") gls in let false_t=mkApp (c,[|mkVar hid|]) in tclTHENS (assert_tac (Name hid) neweq) [proof_tac p; simplest_elim false_t] gls @@ -325,8 +325,8 @@ let convert_to_goal_tac c t1 t2 p gls = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let sort = Termops.refresh_universes (pf_type_of gls tt2) in let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in - let e=pf_get_new_id (id_of_string "e") gls in - let x=pf_get_new_id (id_of_string "X") gls in + let e=pf_get_new_id (Id.of_string "e") gls in + let x=pf_get_new_id (Id.of_string "X") gls in let identity=mkLambda (Name x,sort,mkRel 1) in let endt=mkApp (Lazy.force _eq_rect, [|sort;tt1;identity;c;tt2;mkVar e|]) in @@ -335,7 +335,7 @@ let convert_to_goal_tac c t1 t2 p gls = let convert_to_hyp_tac c1 t1 c2 t2 p gls = let tt2=constr_of_term t2 in - let h=pf_get_new_id (id_of_string "H") gls in + let h=pf_get_new_id (Id.of_string "H") gls in let false_t=mkApp (c2,[|mkVar h|]) in tclTHENS (assert_tac (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; @@ -346,13 +346,13 @@ let discriminate_tac cstr p gls = let intype = Termops.refresh_universes (pf_type_of gls t1) in let concl=pf_concl gls in let outsort = mkType (Termops.new_univ ()) in - let xid=pf_get_new_id (id_of_string "X") gls in - let tid=pf_get_new_id (id_of_string "t") gls in + let xid=pf_get_new_id (Id.of_string "X") gls in + let tid=pf_get_new_id (Id.of_string "t") gls in let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in let trivial=pf_type_of gls identity in let outtype = mkType (Termops.new_univ ()) in let pred=mkLambda(Name xid,outtype,mkRel 1) in - let hid=pf_get_new_id (id_of_string "Heq") gls in + let hid=pf_get_new_id (Id.of_string "Heq") gls in let proj=build_projection intype outtype cstr trivial concl gls in let injt=mkApp (Lazy.force _f_equal, [|intype;outtype;proj;t1;t2;mkVar hid|]) in diff --git a/plugins/decl_mode/decl_expr.mli b/plugins/decl_mode/decl_expr.mli index 966429682..966ebff40 100644 --- a/plugins/decl_mode/decl_expr.mli +++ b/plugins/decl_mode/decl_expr.mli @@ -16,7 +16,7 @@ type 'it statement = type thesis_kind = Plain - | For of identifier + | For of Id.t type 'this or_thesis = This of 'this @@ -60,8 +60,8 @@ type ('hyp,'constr,'pat,'tac) bare_proof_instr = | Pconsider of 'constr*('hyp,'constr) hyp list | Pclaim of 'constr statement | Pfocus of 'constr statement - | Pdefine of identifier * 'hyp list * 'constr - | Pcast of identifier or_thesis * 'constr + | Pdefine of Id.t * 'hyp list * 'constr + | Pcast of Id.t or_thesis * 'constr | Psuppose of ('hyp,'constr) hyp list | Pcase of 'hyp list*'pat*(('hyp,'constr or_thesis) hyp list) | Ptake of 'constr list @@ -77,13 +77,13 @@ type ('hyp,'constr,'pat,'tac) gen_proof_instr= type raw_proof_instr = - ((identifier*(Constrexpr.constr_expr option)) Loc.located, + ((Id.t*(Constrexpr.constr_expr option)) Loc.located, Constrexpr.constr_expr, Constrexpr.cases_pattern_expr, raw_tactic_expr) gen_proof_instr type glob_proof_instr = - ((identifier*(Genarg.glob_constr_and_expr option)) Loc.located, + ((Id.t*(Genarg.glob_constr_and_expr option)) Loc.located, Genarg.glob_constr_and_expr, Constrexpr.cases_pattern_expr, Tacexpr.glob_tactic_expr) gen_proof_instr diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index 5e185f7e3..eb7d9e8e4 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -219,7 +219,7 @@ let interp_hyps_gen inject blend sigma env hyps head = let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps glob_prop) -let dummy_prefix= id_of_string "__" +let dummy_prefix= Id.of_string "__" let rec deanonymize ids = function diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml index 1f55257e5..4bab801b1 100644 --- a/plugins/decl_mode/decl_mode.ml +++ b/plugins/decl_mode/decl_mode.ml @@ -24,11 +24,11 @@ let get_daimon_flag () = !daimon_flag open Store.Field type split_tree= - Skip_patt of Idset.t * split_tree - | Split_patt of Idset.t * inductive * - (bool array * (Idset.t * split_tree) option) array + Skip_patt of Id.Set.t * split_tree + | Split_patt of Id.Set.t * inductive * + (bool array * (Id.Set.t * split_tree) option) array | Close_patt of split_tree - | End_patt of (identifier * (int * int)) + | End_patt of (Id.t * (int * int)) type elim_kind = EK_dep of split_tree @@ -48,7 +48,7 @@ type per_info = per_wf:recpath} type stack_info = - Per of Decl_expr.elim_type * per_info * elim_kind * identifier list + Per of Decl_expr.elim_type * per_info * elim_kind * Id.t list | Suppose_case | Claim | Focus_claim diff --git a/plugins/decl_mode/decl_mode.mli b/plugins/decl_mode/decl_mode.mli index f23a97b4e..853135f10 100644 --- a/plugins/decl_mode/decl_mode.mli +++ b/plugins/decl_mode/decl_mode.mli @@ -27,11 +27,11 @@ val get_current_mode : unit -> command_mode val check_not_proof_mode : string -> unit type split_tree= - Skip_patt of Idset.t * split_tree - | Split_patt of Idset.t * inductive * - (bool array * (Idset.t * split_tree) option) array + Skip_patt of Id.Set.t * split_tree + | Split_patt of Id.Set.t * inductive * + (bool array * (Id.Set.t * split_tree) option) array | Close_patt of split_tree - | End_patt of (identifier * (int * int)) + | End_patt of (Id.t * (int * int)) type elim_kind = EK_dep of split_tree @@ -51,7 +51,7 @@ type per_info = per_wf:recpath} type stack_info = - Per of Decl_expr.elim_type * per_info * elim_kind * Names.identifier list + Per of Decl_expr.elim_type * per_info * elim_kind * Names.Id.t list | Suppose_case | Claim | Focus_claim @@ -69,7 +69,7 @@ val get_stack : Proof.proof -> stack_info list val get_top_stack : Proof.proof -> stack_info list -val get_last: Environ.env -> identifier +val get_last: Environ.env -> Id.t val focus : Proof.proof -> unit diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 8075f05e9..a42e0cb3e 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -91,7 +91,7 @@ let mk_evd metalist gls = meta_declare meta typ evd in List.fold_right add_one metalist evd0 -let is_tmp id = (string_of_id id).[0] = '_' +let is_tmp id = (Id.to_string id).[0] = '_' let tmp_ids gls = let ctx = pf_hyps gls in @@ -210,27 +210,27 @@ let filter_hyps f gls = tclTRY (clear [id]) in tclMAP filter_aux (pf_hyps gls) gls -let local_hyp_prefix = id_of_string "___" +let local_hyp_prefix = Id.of_string "___" let add_justification_hyps keep items gls = let add_aux c gls= match kind_of_term c with Var id -> - keep:=Idset.add id !keep; + keep:=Id.Set.add id !keep; tclIDTAC gls | _ -> let id=pf_get_new_id local_hyp_prefix gls in - keep:=Idset.add id !keep; + keep:=Id.Set.add id !keep; tclTHEN (letin_tac None (Names.Name id) c None Locusops.nowhere) (thin_body [id]) gls in tclMAP add_aux items gls let prepare_goal items gls = - let tokeep = ref Idset.empty in + let tokeep = ref Id.Set.empty in let auxres = add_justification_hyps tokeep items gls in tclTHENLIST [ (fun _ -> auxres); - filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls + filter_hyps (let keep = !tokeep in fun id -> Id.Set.mem id keep)] gls let my_automation_tac = ref (fun gls -> anomaly "No automation registered") @@ -474,7 +474,7 @@ let instr_cut mkstat _thus _then cut gls0 = let stat = cut.cut_stat in let (c_id,_) = match stat.st_label with Anonymous -> - pf_get_new_id (id_of_string "_fact") gls0,false + pf_get_new_id (Id.of_string "_fact") gls0,false | Name id -> id,true in let c_stat = mkstat info gls0 stat.st_it in let thus_tac gls= @@ -520,7 +520,7 @@ let instr_rew _thus rew_side cut gls0 = justification (tclTHEN items_tac method_tac) gls in let (c_id,_) = match cut.cut_stat.st_label with Anonymous -> - pf_get_new_id (id_of_string "_eq") gls0,false + pf_get_new_id (Id.of_string "_eq") gls0,false | Name id -> id,true in let thus_tac new_eq gls= if _thus then @@ -549,7 +549,7 @@ let instr_rew _thus rew_side cut gls0 = let instr_claim _thus st gls0 = let info = get_its_info gls0 in let (id,_) = match st.st_label with - Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false + Anonymous -> pf_get_new_id (Id.of_string "_claim") gls0,false | Name id -> id,true in let thus_tac gls= if _thus then @@ -566,7 +566,7 @@ let instr_claim _thus st gls0 = let push_intro_tac coerce nam gls = let (hid,_) = match nam with - Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false + Anonymous -> pf_get_new_id (Id.of_string "_hyp") gls,false | Name id -> id,true in tclTHENLIST [intro_mustbe_force hid; @@ -640,7 +640,7 @@ let rec build_applist prod = function let instr_suffices _then cut gls0 = let info = get_its_info gls0 in - let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in + let c_id = pf_get_new_id (Id.of_string "_cofact") gls0 in let ctx,hd = cut.cut_stat in let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in let metas = metas_from 1 ctx in @@ -677,7 +677,7 @@ let rec intron_then n ids ltac gls = if n<=0 then ltac ids gls else - let id = pf_get_new_id (id_of_string "_tmp") gls in + let id = pf_get_new_id (Id.of_string "_tmp") gls in tclTHEN (intro_mustbe_force id) (intron_then (pred n) (id::ids) ltac) gls @@ -692,7 +692,7 @@ let rec consider_match may_intro introduced available expected gls = | [],hyps -> if may_intro then begin - let id = pf_get_new_id (id_of_string "_tmp") gls in + let id = pf_get_new_id (Id.of_string "_tmp") gls in tclIFTHENELSE (intro_mustbe_force id) (consider_match true [] [id] hyps) @@ -732,7 +732,7 @@ let consider_tac c hyps gls = Var id -> consider_match false [] [id] hyps gls | _ -> - let id = pf_get_new_id (id_of_string "_tmp") gls in + let id = pf_get_new_id (Id.of_string "_tmp") gls in tclTHEN (forward None (Some (Loc.ghost, IntroIdentifier id)) c) (consider_match false [] [id] hyps) gls @@ -823,7 +823,7 @@ let map_tree id_fun mapi = function let start_tree env ind rp = - init_tree Idset.empty ind rp (fun _ _ -> None) + init_tree Id.Set.empty ind rp (fun _ _ -> None) let build_per_info etype casee gls = let concl=pf_concl gls in @@ -872,7 +872,7 @@ let per_tac etype casee gls= Per(etype,per_info,ek,[])::info.pm_stack} gls | Virtual cut -> assert (cut.cut_stat.st_label=Anonymous); - let id = pf_get_new_id (id_of_string "anonymous_matched") gls in + let id = pf_get_new_id (Id.of_string "anonymous_matched") gls in let c = mkVar id in let modified_cut = {cut with cut_stat={cut.cut_stat with st_label=Name id}} in @@ -901,7 +901,7 @@ let register_nodep_subcase id= function let suppose_tac hyps gls0 = let info = get_its_info gls0 in let thesis = pf_concl gls0 in - let id = pf_get_new_id (id_of_string "subcase_") gls0 in + let id = pf_get_new_id (Id.of_string "subcase_") gls0 in let clause = build_product hyps thesis in let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in let old_clauses,stack = register_nodep_subcase id info.pm_stack in @@ -931,17 +931,17 @@ let rec tree_of_pats ((id,_) as cpl) pats = | (patt,rp) :: rest_args -> match patt with PatVar (_,v) -> - Skip_patt (Idset.singleton id, + Skip_patt (Id.Set.singleton id, tree_of_pats cpl (rest_args::stack)) | PatCstr (_,(ind,cnum),args,nam) -> let nexti i ati = if i = pred cnum then let nargs = List.map_i (fun j a -> (a,ati.(j))) 0 args in - Some (Idset.singleton id, + Some (Id.Set.singleton id, tree_of_pats cpl (nargs::rest_args::stack)) else None - in init_tree Idset.empty ind rp nexti + in init_tree Id.Set.empty ind rp nexti let rec add_branch ((id,_) as cpl) pats tree= match pats with @@ -967,10 +967,10 @@ let rec add_branch ((id,_) as cpl) pats tree= begin match tree with Skip_patt (ids,t) -> - Skip_patt (Idset.add id ids, + Skip_patt (Id.Set.add id ids, add_branch cpl (rest_args::stack) t) | Split_patt (_,_,_) -> - map_tree (Idset.add id) + map_tree (Id.Set.add id) (fun i bri -> append_branch cpl 1 (rest_args::stack) bri) tree @@ -983,7 +983,7 @@ let rec add_branch ((id,_) as cpl) pats tree= if i = pred cnum then let nargs = List.map_i (fun j a -> (a,ati.(j))) 0 args in - Some (Idset.add id ids, + Some (Id.Set.add id ids, add_branch cpl (nargs::rest_args::stack) (skip_args t ids (Array.length ati))) else @@ -1005,19 +1005,19 @@ let rec add_branch ((id,_) as cpl) pats tree= | _ -> anomaly "No pop/stop expected here" and append_branch ((id,_) as cpl) depth pats = function Some (ids,tree) -> - Some (Idset.add id ids,append_tree cpl depth pats tree) + Some (Id.Set.add id ids,append_tree cpl depth pats tree) | None -> - Some (Idset.singleton id,tree_of_pats cpl pats) + Some (Id.Set.singleton id,tree_of_pats cpl pats) and append_tree ((id,_) as cpl) depth pats tree = if depth<=0 then add_branch cpl pats tree else match tree with Close_patt t -> Close_patt (append_tree cpl (pred depth) pats t) | Skip_patt (ids,t) -> - Skip_patt (Idset.add id ids,append_tree cpl depth pats t) + Skip_patt (Id.Set.add id ids,append_tree cpl depth pats t) | End_patt _ -> anomaly "Premature end of branch" | Split_patt (_,_,_) -> - map_tree (Idset.add id) + map_tree (Id.Set.add id) (fun i bri -> append_branch cpl (succ depth) pats bri) tree (* suppose it is *) @@ -1101,7 +1101,7 @@ let rec register_dep_subcase id env per_info pat = function let case_tac params pat_info hyps gls0 = let info = get_its_info gls0 in - let id = pf_get_new_id (id_of_string "subcase_") gls0 in + let id = pf_get_new_id (Id.of_string "subcase_") gls0 in let et,per_info,ek,old_clauses,rest = match info.pm_stack with Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) @@ -1139,7 +1139,7 @@ let push_arg arg stacks = let push_one_head c ids (id,stack) = - let head = if Idset.mem id ids then Some c else None in + let head = if Id.Set.mem id ids then Some c else None in id,(head,[]) :: stack let push_head c ids stacks = @@ -1251,7 +1251,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = | Some (sub_ids,tree) -> let br_args = List.filter - (fun (id,_) -> Idset.mem id sub_ids) args in + (fun (id,_) -> Id.Set.mem id sub_ids) args in let construct = applist (mkConstruct(ind,succ i),params) in let p_args = @@ -1333,9 +1333,9 @@ let end_tac et2 gls = begin fun gls0 -> let fix_id = - pf_get_new_id (id_of_string "_fix") gls0 in + pf_get_new_id (Id.of_string "_fix") gls0 in let c_id = - pf_get_new_id (id_of_string "_main_arg") gls0 in + pf_get_new_id (Id.of_string "_main_arg") gls0 in tclTHENLIST [fix (Some fix_id) (succ nargs); tclDO nargs introf; diff --git a/plugins/decl_mode/decl_proof_instr.mli b/plugins/decl_mode/decl_proof_instr.mli index 775d2f535..fb7e5c29a 100644 --- a/plugins/decl_mode/decl_proof_instr.mli +++ b/plugins/decl_mode/decl_proof_instr.mli @@ -31,24 +31,24 @@ val execute_cases : Names.name -> Decl_mode.per_info -> (Term.constr -> Proof_type.tactic) -> - (Names.Idset.elt * (Term.constr option * Term.constr list) list) list -> + (Names.Id.Set.elt * (Term.constr option * Term.constr list) list) list -> Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic val tree_of_pats : - identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> + Id.t * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> split_tree val add_branch : - identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> + Id.t * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> split_tree -> split_tree val append_branch : - identifier *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> - (Names.Idset.t * Decl_mode.split_tree) option -> - (Names.Idset.t * Decl_mode.split_tree) option + Id.t *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> + (Names.Id.Set.t * Decl_mode.split_tree) option -> + (Names.Id.Set.t * Decl_mode.split_tree) option val append_tree : - identifier * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> + Id.t * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> split_tree -> split_tree val build_dep_clause : Term.types Decl_expr.statement list -> @@ -58,7 +58,7 @@ val build_dep_clause : Term.types Decl_expr.statement list -> Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types val register_dep_subcase : - Names.identifier * (int * int) -> + Names.Id.t * (int * int) -> Environ.env -> Decl_mode.per_info -> Glob_term.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind @@ -69,41 +69,41 @@ val thesis_for : Term.constr -> val close_previous_case : Proof.proof -> unit val pop_stacks : - (Names.identifier * + (Names.Id.t * (Term.constr option * Term.constr list) list) list -> - (Names.identifier * + (Names.Id.t * (Term.constr option * Term.constr list) list) list val push_head : Term.constr -> - Names.Idset.t -> - (Names.identifier * + Names.Id.Set.t -> + (Names.Id.t * (Term.constr option * Term.constr list) list) list -> - (Names.identifier * + (Names.Id.t * (Term.constr option * Term.constr list) list) list val push_arg : Term.constr -> - (Names.identifier * + (Names.Id.t * (Term.constr option * Term.constr list) list) list -> - (Names.identifier * + (Names.Id.t * (Term.constr option * Term.constr list) list) list val hrec_for: - Names.identifier -> + Names.Id.t -> Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> - Names.identifier -> Term.constr + Names.Id.t -> Term.constr val consider_match : bool -> - (Names.Idset.elt*bool) list -> - Names.Idset.elt list -> + (Names.Id.Set.elt*bool) list -> + Names.Id.Set.elt list -> (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list -> Proof_type.tactic val init_tree: - Names.Idset.t -> + Names.Id.Set.t -> Names.inductive -> int option * Declarations.wf_paths -> (int -> (int option * Declarations.recarg Rtree.t) array -> - (Names.Idset.t * Decl_mode.split_tree) option) -> + (Names.Id.Set.t * Decl_mode.split_tree) option) -> Decl_mode.split_tree diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 04cc167a8..3269befdb 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -18,7 +18,7 @@ open Miniml open Mlutil let string_of_id id = - let s = Names.string_of_id id in + let s = Names.Id.to_string id in for i = 0 to String.length s - 2 do if s.[i] = '_' && s.[i+1] = '_' then warning_id s done; @@ -109,12 +109,12 @@ let pseudo_qualify = qualify "__" let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false -let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id)) +let lowercase_id id = Id.of_string (String.uncapitalize (string_of_id id)) let uppercase_id id = let s = string_of_id id in assert (s<>""); - if s.[0] = '_' then id_of_string ("Coq_"^s) - else id_of_string (String.capitalize s) + if s.[0] = '_' then Id.of_string ("Coq_"^s) + else Id.of_string (String.capitalize s) type kind = Term | Type | Cons | Mod @@ -128,12 +128,12 @@ let kindcase_id k id = (*s de Bruijn environments for programs *) -type env = identifier list * Idset.t +type env = Id.t list * Id.Set.t (*s Generic renaming issues for local variable names. *) let rec rename_id id avoid = - if Idset.mem id avoid then rename_id (lift_subscript id) avoid else id + if Id.Set.mem id avoid then rename_id (lift_subscript id) avoid else id let rec rename_vars avoid = function | [] -> @@ -145,14 +145,14 @@ let rec rename_vars avoid = function | id :: idl -> let (idl, avoid) = rename_vars avoid idl in let id = rename_id (lowercase_id id) avoid in - (id :: idl, Idset.add id avoid) + (id :: idl, Id.Set.add id avoid) let rename_tvars avoid l = let rec rename avoid = function | [] -> [],avoid | id :: idl -> let id = rename_id (lowercase_id id) avoid in - let idl, avoid = rename (Idset.add id avoid) idl in + let idl, avoid = rename (Id.Set.add id avoid) idl in (id :: idl, avoid) in fst (rename avoid l) @@ -162,7 +162,7 @@ let push_vars ids (db,avoid) = let get_db_name n (db,_) = let id = List.nth db (pred n) in - if id = dummy_name then id_of_string "__" else id + if id = dummy_name then Id.of_string "__" else id (*S Renamings of global objects. *) @@ -179,13 +179,13 @@ let set_phase, get_phase = let ph = ref Impl in ((:=) ph), (fun () -> !ph) let set_keywords, get_keywords = - let k = ref Idset.empty in + let k = ref Id.Set.empty in ((:=) k), (fun () -> !k) let add_global_ids, get_global_ids = - let ids = ref Idset.empty in + let ids = ref Id.Set.empty in register_cleanup (fun () -> ids := get_keywords ()); - let add s = ids := Idset.add s !ids + let add s = ids := Id.Set.add s !ids and get () = !ids in (add,get) @@ -309,7 +309,7 @@ let modular_rename k id = if upperkind k then "Coq_",is_upper else "coq_",is_lower in if not (is_ok s) || - (Idset.mem id (get_keywords ())) || + (Id.Set.mem id (get_keywords ())) || (String.length s >= 4 && String.sub s 0 4 = prefix) then prefix ^ s else s @@ -320,7 +320,7 @@ let modular_rename k id = let modfstlev_rename = let add_prefixes,get_prefixes,_ = mktable true in fun l -> - let coqid = id_of_string "Coq" in + let coqid = Id.of_string "Coq" in let id = id_of_label l in try let coqset = get_prefixes id in @@ -372,12 +372,12 @@ let ref_renaming_fun (k,r) = let idg = safe_basename_of_global r in if l = [""] (* this happens only at toplevel of the monolithic case *) then - let globs = Idset.elements (get_global_ids ()) in + let globs = Id.Set.elements (get_global_ids ()) in let id = next_ident_away (kindcase_id k idg) globs in string_of_id id else modular_rename k idg in - add_global_ids (id_of_string s); + add_global_ids (Id.of_string s); s::l (* Cached version of the last function *) diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index 7233b8c2b..9ddd0f2af 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -33,17 +33,17 @@ val pp_tuple_light : (bool -> 'a -> std_ppcmds) -> 'a list -> std_ppcmds val pp_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds val pp_boxed_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds -val pr_binding : identifier list -> std_ppcmds +val pr_binding : Id.t list -> std_ppcmds -val rename_id : identifier -> Idset.t -> identifier +val rename_id : Id.t -> Id.Set.t -> Id.t -type env = identifier list * Idset.t +type env = Id.t list * Id.Set.t val empty_env : unit -> env -val rename_vars: Idset.t -> identifier list -> env -val rename_tvars: Idset.t -> identifier list -> identifier list -val push_vars : identifier list -> env -> identifier list * env -val get_db_name : int -> env -> identifier +val rename_vars: Id.Set.t -> Id.t list -> env +val rename_tvars: Id.Set.t -> Id.t list -> Id.t list +val push_vars : Id.t list -> env -> Id.t list * env +val get_db_name : int -> env -> Id.t type phase = Pre | Impl | Intf @@ -69,7 +69,7 @@ type reset_kind = AllButExternal | Everything val reset_renaming_tables : reset_kind -> unit -val set_keywords : Idset.t -> unit +val set_keywords : Id.Set.t -> unit (** For instance: [mk_ind "Coq.Init.Datatypes" "nat"] *) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 0b4047f17..3cd3f7f8a 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -388,7 +388,7 @@ let descr () = match lang () with (* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli" Works similarly for the other languages. *) -let default_id = id_of_string "Main" +let default_id = Id.of_string "Main" let mono_filename f = let d = descr () in @@ -402,7 +402,7 @@ let mono_filename f = in let id = if lang () <> Haskell then default_id - else try id_of_string (Filename.basename f) + else try Id.of_string (Filename.basename f) with _ -> error "Extraction: provided filename is not a valid identifier" in Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id @@ -412,7 +412,7 @@ let mono_filename f = let module_filename mp = let f = file_of_modfile mp in let d = descr () in - Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id_of_string f + Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, Id.of_string f (*s Extraction of one decl to stdout. *) diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 5e14214b9..6c648b981 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -15,7 +15,7 @@ open Globnames val simple_extraction : reference -> unit val full_extraction : string option -> reference list -> unit val separate_extraction : reference list -> unit -val extraction_library : bool -> identifier -> unit +val extraction_library : bool -> Id.t -> unit (* For debug / external output via coqtop.byte + Drop : *) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 6645f1d5d..5b31db3f9 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -192,7 +192,7 @@ let parse_ind_args si args relmax = in parse 1 1 si let oib_equal o1 o2 = - id_ord o1.mind_typename o2.mind_typename = 0 && + Id.compare o1.mind_typename o2.mind_typename = 0 && List.equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt && begin match o1.mind_arity, o2.mind_arity with | Monomorphic {mind_user_arity=c1; mind_sort=s1}, diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli index 1eb9ca8e5..3a5fc9794 100644 --- a/plugins/extraction/extraction.mli +++ b/plugins/extraction/extraction.mli @@ -19,7 +19,7 @@ val extract_constant : env -> constant -> constant_body -> ml_decl val extract_constant_spec : env -> constant -> constant_body -> ml_spec -val extract_with_type : env -> constant_body -> ( identifier list * ml_type ) option +val extract_with_type : env -> constant_body -> ( Id.t list * ml_type ) option val extract_fixpoint : env -> constant array -> (constr, types) prec_declaration -> ml_decl diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index bdb102b18..5295e2cf9 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -33,7 +33,7 @@ let pr_int_or_id _ _ _ = function ARGUMENT EXTEND int_or_id TYPED AS int_or_id PRINTED BY pr_int_or_id -| [ preident(id) ] -> [ ArgId (id_of_string id) ] +| [ preident(id) ] -> [ ArgId (Id.of_string id) ] | [ integer(i) ] -> [ ArgInt i ] END diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 5de13e53c..3925a2a2f 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -21,16 +21,16 @@ open Common (*s Haskell renaming issues. *) -let pr_lower_id id = str (String.uncapitalize (string_of_id id)) -let pr_upper_id id = str (String.capitalize (string_of_id id)) +let pr_lower_id id = str (String.uncapitalize (Id.to_string id)) +let pr_upper_id id = str (String.capitalize (Id.to_string id)) let keywords = - List.fold_right (fun s -> Idset.add (id_of_string s)) + List.fold_right (fun s -> Id.Set.add (Id.of_string s)) [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else"; "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance"; "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__"; "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ] - Idset.empty + Id.Set.empty let pp_comment s = str "-- " ++ s ++ fnl () let pp_bracket_comment s = str"{- " ++ hov 0 s ++ str" -}" diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index d170acbb0..14a30ae79 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -65,11 +65,11 @@ type inductive_kind = *) type ml_ind_packet = { - ip_typename : identifier; - ip_consnames : identifier array; + ip_typename : Id.t; + ip_consnames : Id.t array; ip_logical : bool; ip_sign : signature; - ip_vars : identifier list; + ip_vars : Id.t list; ip_types : (ml_type list) array } @@ -91,8 +91,8 @@ type ml_ind = { type ml_ident = | Dummy - | Id of identifier - | Tmp of identifier + | Id of Id.t + | Tmp of Id.t (** We now store some typing information on constructors and cases to avoid type-unsafe optimisations. This will be @@ -116,7 +116,7 @@ and ml_ast = | MLcons of ml_type * global_reference * ml_ast list | MLtuple of ml_ast list | MLcase of ml_type * ml_ast * ml_branch array - | MLfix of int * identifier array * ml_ast array + | MLfix of int * Id.t array * ml_ast array | MLexn of string | MLdummy | MLaxiom @@ -133,13 +133,13 @@ and ml_pattern = type ml_decl = | Dind of mutual_inductive * ml_ind - | Dtype of global_reference * identifier list * ml_type + | Dtype of global_reference * Id.t list * ml_type | Dterm of global_reference * ml_ast * ml_type | Dfix of global_reference array * ml_ast array * ml_type array type ml_spec = | Sind of mutual_inductive * ml_ind - | Stype of global_reference * identifier list * ml_type option + | Stype of global_reference * Id.t list * ml_type option | Sval of global_reference * ml_type type ml_specif = @@ -154,8 +154,8 @@ and ml_module_type = | MTwith of ml_module_type * ml_with_declaration and ml_with_declaration = - | ML_With_type of identifier list * identifier list * ml_type - | ML_With_module of identifier list * module_path + | ML_With_type of Id.t list * Id.t list * ml_type + | ML_With_module of Id.t list * module_path and ml_module_sig = (label * ml_specif) list @@ -191,13 +191,13 @@ type unsafe_needs = { } type language_descr = { - keywords : Idset.t; + keywords : Id.Set.t; (* Concerning the source file *) file_suffix : string; (* the second argument is a comment to add to the preamble *) preamble : - identifier -> std_ppcmds option -> module_path list -> unsafe_needs -> + Id.t -> std_ppcmds option -> module_path list -> unsafe_needs -> std_ppcmds; pp_struct : ml_structure -> std_ppcmds; @@ -205,7 +205,7 @@ type language_descr = { sig_suffix : string option; (* the second argument is a comment to add to the preamble *) sig_preamble : - identifier -> std_ppcmds option -> module_path list -> unsafe_needs -> + Id.t -> std_ppcmds option -> module_path list -> unsafe_needs -> std_ppcmds; pp_sig : ml_signature -> std_ppcmds; diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 18c3f840e..d8d1d1eae 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -22,8 +22,8 @@ exception Impossible (*S Names operations. *) -let anonymous_name = id_of_string "x" -let dummy_name = id_of_string "_" +let anonymous_name = Id.of_string "x" +let dummy_name = Id.of_string "_" let anonymous = Id anonymous_name @@ -857,7 +857,7 @@ let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false let is_program_branch = function | Id id -> - let s = string_of_id id in + let s = Id.to_string id in let br = "program_branch_" in let n = String.length br in (try diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index be32ba6ed..1c70908b6 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -77,10 +77,10 @@ val term_expunge : signature -> ml_ident list * ml_ast -> ml_ast (*s Special identifiers. [dummy_name] is to be used for dead code and will be printed as [_] in concrete (Caml) code. *) -val anonymous_name : identifier -val dummy_name : identifier -val id_of_name : name -> identifier -val id_of_mlid : ml_ident -> identifier +val anonymous_name : Id.t +val dummy_name : Id.t +val id_of_name : name -> Id.t +val id_of_mlid : ml_ident -> Id.t val tmp_id : ml_ident -> ml_ident (*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 7640416fd..b8d75d445 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -24,7 +24,7 @@ open Common (*s Some utility functions. *) let pp_tvar id = - let s = string_of_id id in + let s = Id.to_string id in if String.length s < 2 || s.[1]<>'\'' then str ("'"^s) else str ("' "^s) @@ -48,7 +48,7 @@ let pp_letin pat def body = (*s Ocaml renaming issues. *) let keywords = - List.fold_right (fun s -> Idset.add (id_of_string s)) + List.fold_right (fun s -> Id.Set.add (Id.of_string s)) [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; @@ -57,7 +57,7 @@ let keywords = "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true"; "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] - Idset.empty + Id.Set.empty let pp_open mp = str ("open "^ string_of_modfile mp ^"\n") diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index bfbcc7b0a..8125b4757 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -20,11 +20,11 @@ open Common (*s Scheme renaming issues. *) let keywords = - List.fold_right (fun s -> Idset.add (id_of_string s)) + List.fold_right (fun s -> Id.Set.add (Id.of_string s)) [ "define"; "let"; "lambda"; "lambdas"; "match"; "apply"; "car"; "cdr"; "error"; "delay"; "force"; "_"; "__"] - Idset.empty + Id.Set.empty let pp_comment s = str";; "++h 0 s++fnl () @@ -40,7 +40,7 @@ let preamble _ comment _ usf = (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ()) let pr_id id = - let s = string_of_id id in + let s = Id.to_string id in for i = 0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done; diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index dd3b65b90..c7d8d42de 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -56,7 +56,7 @@ let is_modfile = function | _ -> false let raw_string_of_modfile = function - | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f))) + | MPfile f -> String.capitalize (Id.to_string (List.hd (repr_dirpath f))) | _ -> assert false let current_toplevel () = fst (Lib.current_prefix ()) @@ -256,8 +256,8 @@ let safe_basename_of_global r = | VarRef _ -> assert false let string_of_global r = - try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r) - with _ -> string_of_id (safe_basename_of_global r) + try string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty r) + with _ -> Id.to_string (safe_basename_of_global r) let safe_pr_global r = str (string_of_global r) @@ -273,7 +273,7 @@ let safe_pr_long_global r = let pr_long_mp mp = let lid = repr_dirpath (Nametab.dirpath_of_module mp) in - str (String.concat "." (List.map string_of_id (List.rev lid))) + str (String.concat "." (List.map Id.to_string (List.rev lid))) let pr_long_global ref = pr_path (Nametab.path_of_global ref) @@ -411,7 +411,7 @@ let error_MPfile_as_mod mp b = let msg_non_implicit r n id = let name = match id with | Anonymous -> "" - | Name id -> "(" ^ string_of_id id ^ ") " + | Name id -> "(" ^ Id.to_string id ^ ") " in "The " ^ (String.ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r) @@ -652,7 +652,7 @@ let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) (*s Extraction Implicit *) -type int_or_id = ArgInt of int | ArgId of identifier +type int_or_id = ArgInt of int | ArgId of Id.t let implicits_table = ref Refmap'.empty @@ -704,21 +704,21 @@ let extraction_implicit r l = (*s Extraction Blacklist of filenames not to use while extracting *) -let blacklist_table = ref Idset.empty +let blacklist_table = ref Id.Set.empty let modfile_ids = ref [] let modfile_mps = ref MPmap.empty let reset_modfile () = - modfile_ids := Idset.elements !blacklist_table; + modfile_ids := Id.Set.elements !blacklist_table; modfile_mps := MPmap.empty let string_of_modfile mp = try MPmap.find mp !modfile_mps with Not_found -> - let id = id_of_string (raw_string_of_modfile mp) in + let id = Id.of_string (raw_string_of_modfile mp) in let id' = next_ident_away id !modfile_ids in - let s' = string_of_id id' in + let s' = Id.to_string id' in modfile_ids := id' :: !modfile_ids; modfile_mps := MPmap.add mp s' !modfile_mps; s' @@ -727,7 +727,7 @@ let string_of_modfile mp = let file_of_modfile mp = let s0 = match mp with - | MPfile f -> string_of_id (List.hd (repr_dirpath f)) + | MPfile f -> Id.to_string (List.hd (repr_dirpath f)) | _ -> assert false in let s = String.copy (string_of_modfile mp) in @@ -736,7 +736,7 @@ let file_of_modfile mp = let add_blacklist_entries l = blacklist_table := - List.fold_right (fun s -> Idset.add (id_of_string (String.capitalize s))) + List.fold_right (fun s -> Id.Set.add (Id.of_string (String.capitalize s))) l !blacklist_table (* Registration of operations for rollback. *) @@ -752,26 +752,26 @@ let blacklist_extraction : string list -> obj = let _ = declare_summary "Extraction Blacklist" { freeze_function = (fun () -> !blacklist_table); unfreeze_function = ((:=) blacklist_table); - init_function = (fun () -> blacklist_table := Idset.empty) } + init_function = (fun () -> blacklist_table := Id.Set.empty) } (* Grammar entries. *) let extraction_blacklist l = - let l = List.rev_map string_of_id l in + let l = List.rev_map Id.to_string l in Lib.add_anonymous_leaf (blacklist_extraction l) (* Printing part *) let print_extraction_blacklist () = - prlist_with_sep fnl pr_id (Idset.elements !blacklist_table) + prlist_with_sep fnl pr_id (Id.Set.elements !blacklist_table) (* Reset part *) let reset_blacklist : unit -> obj = declare_object {(default_object "Reset Extraction Blacklist") with - cache_function = (fun (_,_)-> blacklist_table := Idset.empty); - load_function = (fun _ (_,_)-> blacklist_table := Idset.empty)} + cache_function = (fun (_,_)-> blacklist_table := Id.Set.empty); + load_function = (fun _ (_,_)-> blacklist_table := Id.Set.empty)} let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ()) diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 16c2275f1..fbf48889f 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -15,7 +15,7 @@ open Declarations module Refset' : Set.S with type elt = global_reference module Refmap' : Map.S with type key = global_reference -val safe_basename_of_global : global_reference -> identifier +val safe_basename_of_global : global_reference -> Id.t (*s Warning and Error messages. *) @@ -30,7 +30,7 @@ val error_inductive : global_reference -> 'a val error_nb_cons : unit -> 'a val error_module_clash : module_path -> module_path -> 'a val error_no_module_expr : module_path -> 'a -val error_singleton_become_prop : identifier -> 'a +val error_singleton_become_prop : Id.t -> 'a val error_unknown_module : qualid -> 'a val error_scheme : unit -> 'a val error_not_visible : global_reference -> 'a @@ -193,12 +193,12 @@ val extract_inductive : reference -> string -> string list -> string option -> unit -type int_or_id = ArgInt of int | ArgId of identifier +type int_or_id = ArgInt of int | ArgId of Id.t val extraction_implicit : reference -> int_or_id list -> unit (*s Table of blacklisted filenames *) -val extraction_blacklist : identifier list -> unit +val extraction_blacklist : Id.t list -> unit val reset_extraction_blacklist : unit -> unit val print_extraction_blacklist : unit -> Pp.std_ppcmds diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index d224f87df..093087511 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -116,7 +116,7 @@ type side = Hyp | Concl | Hint let no_atoms = (false,{positive=[];negative=[]}) -let dummy_id=VarRef (id_of_string "_") (* "_" cannot be parsed *) +let dummy_id=VarRef (Id.of_string "_") (* "_" cannot be parsed *) let build_atoms gl metagen side cciterm = let trivial =ref false diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 753fdda72..48e60d798 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -25,7 +25,7 @@ let update_flags ()= red_flags:= Closure.RedFlags.red_add_transparent Closure.betaiotazeta - (Names.Idpred.full,Names.Cpred.complement !predref) + (Names.Id.Pred.full,Names.Cpred.complement !predref) let ground_tac solver startseq gl= update_flags (); diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 414afad46..c7a582a0e 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -98,7 +98,7 @@ let rec collect_quantified seq= let dummy_constr=mkMeta (-1) -let dummy_bvid=id_of_string "x" +let dummy_bvid=Id.of_string "x" let mk_open_instance id gl m t= let env=pf_env gl in diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index 78a70ff51..bfebbaaf8 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -19,7 +19,7 @@ type 'a with_backtracking = tactic -> 'a val wrap : int -> bool -> seqtac -val basename_of_global: global_reference -> identifier +val basename_of_global: global_reference -> Id.t val clear_global: global_reference -> tactic diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 429a0a4a8..f8b1927a3 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -463,7 +463,7 @@ let mkAppL a = let rec fourier gl= Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; let goal = strip_outer_cast (pf_concl gl) in - let fhyp=id_of_string "new_hyp_for_fourier" in + let fhyp=Id.of_string "new_hyp_for_fourier" in (* si le but est une inéquation, on introduit son contraire, et le but à prouver devient False *) try (let tac = diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index c129306d2..ca73799c1 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -105,17 +105,17 @@ let make_refl_eq constructor type_of_t t = type pte_info = { - proving_tac : (identifier list -> Tacmach.tactic); + proving_tac : (Id.t list -> Tacmach.tactic); is_valid : constr -> bool } -type ptes_info = pte_info Idmap.t +type ptes_info = pte_info Id.Map.t type 'a dynamic_info = { nb_rec_hyps : int; - rec_hyps : identifier list ; - eq_hyps : identifier list; + rec_hyps : Id.t list ; + eq_hyps : Id.t list; info : 'a } @@ -361,7 +361,7 @@ let is_property (ptes_info:ptes_info) t_x full_type_of_hyp = if isVar pte && Array.for_all closed0 args then try - let info = Idmap.find (destVar pte) ptes_info in + let info = Id.Map.find (destVar pte) ptes_info in info.is_valid full_type_of_hyp with Not_found -> false else false @@ -406,7 +406,7 @@ let rewrite_until_var arg_num eq_ids : tactic = do_rewrite eq_ids -let rec_pte_id = id_of_string "Hrec" +let rec_pte_id = Id.of_string "Hrec" let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let coq_False = Coqlib.build_coq_False () in let coq_True = Coqlib.build_coq_True () in @@ -430,7 +430,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = if is_property ptes_infos t_x actual_real_type_of_hyp then begin let pte,pte_args = (destApp t_x) in - let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in + let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar pte) ptes_infos).proving_tac in let popped_t' = Termops.pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let prove_new_type_of_hyp = @@ -579,7 +579,7 @@ let clean_goal_with_heq ptes_infos continue_tac (dyn_infos:body_info) = ] g -let heq_id = id_of_string "Heq" +let heq_id = Id.of_string "Heq" let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = fun g -> @@ -632,7 +632,7 @@ let my_orelse tac1 tac2 g = (* observe (str "using snd tac since : " ++ Errors.print e); *) tac2 g -let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = +let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = let args = Array.of_list (List.map mkVar args_id) in let instanciate_one_hyp hid = my_orelse @@ -672,10 +672,10 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id tclMAP instanciate_one_hyp hyps; (fun g -> let all_g_hyps_id = - List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty + List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in let remaining_hyps = - List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps + List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps in do_prove remaining_hyps g ) @@ -885,7 +885,7 @@ let build_proof type static_fix_info = { idx : int; - name : identifier; + name : Id.t; types : types; offset : int; nb_realargs : int; @@ -1042,7 +1042,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : (fun na -> let new_id = match na with - Name id -> fresh_id !avoid (string_of_id id) + Name id -> fresh_id !avoid (Id.to_string id) | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; @@ -1183,14 +1183,14 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : in (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) (* str " to " ++ Ppconstr.pr_id info.name); *) - (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info) + (Id.Map.add (Nameops.out_name pte) info acc_map,info::acc_info) ) 0 - (Idmap.empty,[]) + (Id.Map.empty,[]) (List.rev princ_info.predicates) in pte_to_fix,List.rev rev_info - | _ -> Idmap.empty,[] + | _ -> Id.Map.empty,[] in let mk_fixes : tactic = let pre_info,infos = list_chop fun_num infos in @@ -1224,7 +1224,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : let pte,pte_args = (decompose_app pte_app) in try let pte = try destVar pte with _ -> anomaly "Property is not a variable" in - let fix_info = Idmap.find pte ptes_to_fix in + let fix_info = Id.Map.find pte ptes_to_fix in let nb_args = fix_info.nb_realargs in tclTHENSEQ [ @@ -1262,7 +1262,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : build_proof interactive_proof (Array.to_list fnames) - (Idmap.map prove_rec_hyp ptes_to_fix) + (Id.Map.map prove_rec_hyp ptes_to_fix) in let prove_tac branches = let dyn_infos = @@ -1272,7 +1272,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : } in observe_tac "cleaning" (clean_goal_with_heq - (Idmap.map prove_rec_hyp ptes_to_fix) + (Id.Map.map prove_rec_hyp ptes_to_fix) do_prove dyn_infos) in @@ -1316,7 +1316,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : build_proof interactive_proof (Array.to_list fnames) - (Idmap.map prove_rec_hyp ptes_to_fix) + (Id.Map.map prove_rec_hyp ptes_to_fix) in let prove_tac branches = let dyn_infos = @@ -1326,7 +1326,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : } in clean_goal_with_heq - (Idmap.map prove_rec_hyp ptes_to_fix) + (Id.Map.map prove_rec_hyp ptes_to_fix) do_prove dyn_infos in @@ -1413,7 +1413,7 @@ let rec rewrite_eqs_in_eqs eqs = (tclMAP (fun id gl -> observe_tac - (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id)) + (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) (tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true (* dep proofs also: *) true id (mkVar eq) false)) gl @@ -1427,7 +1427,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = (tclTHENSEQ [ backtrack_eqs_until_hrec hrec eqs; - (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *) + (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) (tclTHENS (* We must have exactly ONE subgoal !*) (apply (mkVar hrec)) [ tclTHENSEQ @@ -1463,13 +1463,13 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = let is_valid_hypothesis predicates_name = - let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in + let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in let is_pte typ = if isApp typ then let pte,_ = destApp typ in if isVar pte - then Idset.mem (destVar pte) predicates_name + then Id.Set.mem (destVar pte) predicates_name else false else false in @@ -1491,7 +1491,7 @@ let prove_principle_for_gen fun na -> let new_id = match na with - | Name id -> fresh_id !avoid (string_of_id id) + | Name id -> fresh_id !avoid (Id.to_string id) | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; @@ -1534,9 +1534,9 @@ let prove_principle_for_gen let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in - let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in + let wf_thm_id = Nameops.out_name (fresh_id (Name (Id.of_string "wf_R"))) in let acc_rec_arg_id = - Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id))))) + Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) in let revert l = tclTHEN (h_generalize (List.map mkVar l)) (clear l) @@ -1580,7 +1580,7 @@ let prove_principle_for_gen let hyps = pf_ids_of_hyps gls in let hid = next_ident_away_in_goal - (id_of_string "prov") + (Id.of_string "prov") hyps in tclTHENSEQ @@ -1669,14 +1669,14 @@ let prove_principle_for_gen is_valid = is_valid_hypothesis predicates_names } in - let ptes_info : pte_info Idmap.t = + let ptes_info : pte_info Id.Map.t = List.fold_left (fun map pte_id -> - Idmap.add pte_id + Id.Map.add pte_id pte_info map ) - Idmap.empty + Id.Map.empty predicates_names in let make_proof rec_hyps = diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 533fbfaaa..1d30ce9a6 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -41,7 +41,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let env = Global.env () in let env_with_params = Environ.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:identifier list) (predicates:rel_context) : rel_context = + let rec change_predicates_names (avoid:Id.t list) (predicates:rel_context) : rel_context = match predicates with | [] -> [] |(Name x,v,t)::predicates -> @@ -83,10 +83,10 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in let is_pte = - let set = List.fold_right Idset.add ptes_vars Idset.empty in + let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in fun t -> match kind_of_term t with - | Var id -> Idset.mem id set + | Var id -> Id.Set.mem id set | _ -> false in let pre_princ = @@ -114,7 +114,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | Construct((_,num),_) -> num | _ -> assert false in - let dummy_var = mkVar (id_of_string "________") in + let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = let res = mkApp(rel_to_fun.(i), Array.map Termops.pop (array_get_start args)) in (* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *) @@ -284,7 +284,7 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); let new_princ_name = - next_ident_away_in_goal (id_of_string "___________princ_________") [] + next_ident_away_in_goal (Id.of_string "___________princ_________") [] in begin Lemmas.start_proof @@ -366,7 +366,7 @@ let generate_functional_principle begin try let id = Pfedit.get_current_proof_name () in - let s = string_of_id id in + let s = Id.to_string id in let n = String.length "___________princ_________" in if String.length s >= n then if String.sub s 0 n = "___________princ_________" @@ -519,7 +519,7 @@ let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry lis begin try let id = Pfedit.get_current_proof_name () in - let s = string_of_id id in + let s = Id.to_string id in let n = String.length "___________princ_________" in if String.length s >= n then if String.sub s 0 n = "___________princ_________" diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 00d130d28..a16b834f8 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -10,7 +10,7 @@ val generate_functional_principle : (* *) sorts array option -> (* Name of the new principle *) - (identifier) option -> + (Id.t) option -> (* the compute functions to use *) constant array -> (* We prove the nth- principle *) @@ -29,6 +29,6 @@ exception No_graph_found val make_scheme : (constant*glob_sort) list -> Entries.definition_entry list -val build_scheme : (identifier*Libnames.reference*glob_sort) list -> unit -val build_case_scheme : (identifier*Libnames.reference*glob_sort) -> unit +val build_scheme : (Id.t*Libnames.reference*glob_sort) list -> unit +val build_case_scheme : (Id.t*Libnames.reference*glob_sort) -> unit diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 2fdf62d26..ef2276134 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -368,7 +368,7 @@ let find_fapp (test:constr -> bool) g : fapp_info list = an occurence of function [id] in the conclusion of goal [g]. If [id]=[None] then calls to any function are selected. In any case [heuristic] is used to select the most pertinent occurrence. *) -let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list) +let finduction (oid:Id.t option) (heuristic: fapp_info list -> fapp_info list) (nexttac:Proof_type.tactic) g = let test = match oid with | Some id -> @@ -468,10 +468,10 @@ VERNAC COMMAND EXTEND MergeFunind let ar2 = List.length (fst (decompose_prod f2type)) in let _ = if ar1 <> List.length cl1 then - Errors.error ("not the right number of arguments for " ^ string_of_id id1) in + Errors.error ("not the right number of arguments for " ^ Id.to_string id1) in let _ = if ar2 <> List.length cl2 then - Errors.error ("not the right number of arguments for " ^ string_of_id id2) in + Errors.error ("not the right number of arguments for " ^ Id.to_string id2) in Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2) id ] END diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 593e274fb..cf7d8e8fe 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -57,7 +57,7 @@ type 'a build_entry_pre_return = type 'a build_entry_return = { result : 'a build_entry_pre_return list; - to_avoid : identifier list + to_avoid : Id.t list } (* @@ -114,9 +114,9 @@ let ids_of_binder = function let rec change_vars_in_binder mapping = function [] -> [] | (bt,t)::l -> - let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in + let new_mapping = List.fold_right Id.Map.remove (ids_of_binder bt) mapping in (bt,change_vars mapping t):: - (if idmap_is_empty new_mapping + (if Id.Map.is_empty new_mapping then l else change_vars_in_binder new_mapping l ) @@ -138,23 +138,23 @@ let apply_args ctxt body args = let need_convert avoid bt = List.exists (need_convert_id avoid) (ids_of_binder bt) in - let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = + let next_name_away (na:name) (mapping: Id.t Id.Map.t) (avoid: Id.t list) = match na with | Name id when List.mem id avoid -> let new_id = Namegen.next_ident_away id avoid in - Name new_id,Idmap.add id new_id mapping,new_id::avoid + Name new_id,Id.Map.add id new_id mapping,new_id::avoid | _ -> na,mapping,avoid in - let next_bt_away bt (avoid:identifier list) = + let next_bt_away bt (avoid:Id.t list) = match bt with | LetIn na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in LetIn new_na,mapping,new_avoid | Prod na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in Prod new_na,mapping,new_avoid | Lambda na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in Lambda new_na,mapping,new_avoid in let rec do_apply avoid ctxt body args = @@ -173,7 +173,7 @@ let apply_args ctxt body args = let new_avoid = id::avoid in let new_id = Namegen.next_ident_away id new_avoid in let new_avoid' = new_id :: new_avoid in - let mapping = Idmap.add id new_id Idmap.empty in + let mapping = Id.Map.add id new_id Id.Map.empty in let new_ctxt' = change_vars_in_binder mapping ctxt' in let new_body = change_vars mapping body in new_avoid',new_ctxt',new_body,new_id @@ -477,7 +477,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = GApp(Loc.ghost,t,l) in build_entry_lc env funnames avoid (aux f args) - | GVar(_,id) when Idset.mem id funnames -> + | GVar(_,id) when Id.Set.mem id funnames -> (* if we have [f t1 ... tn] with [f]$\in$[fnames] then we create a fresh variable [res], add [res] and its "value" (i.e. [res v1 ... vn]) to each @@ -725,7 +725,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve (will be used in the following recursive calls) *) let new_env = List.fold_right2 add_pat_variables patl types env in - let not_those_patterns : (identifier list -> glob_constr -> glob_constr) list = + let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = List.map2 (fun pat typ -> fun avoid pat'_as_term -> @@ -787,7 +787,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve let pat_as_term = pattern_to_term pat in List.fold_right (fun id acc -> - if Idset.mem id this_pat_ids + if Id.Set.mem id this_pat_ids then (Prod (Name id), let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in let raw_typ_of_id = @@ -835,7 +835,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve let is_res id = try - String.sub (string_of_id id) 0 4 = "_res" + String.sub (Id.to_string id) 0 4 = "_res" with Invalid_argument _ -> false @@ -901,7 +901,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (depth + 1) b in mkGProd(n,new_t,new_b), - Idset.filter not_free_in_t id_to_exclude + Id.Set.filter not_free_in_t id_to_exclude | _ -> (* the first args is the name of the function! *) assert false end @@ -1019,7 +1019,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (* J.F:. keep this comment it explain how to remove some meaningless equalities if keep_eq then mkGProd(n,t,new_b),id_to_exclude - else new_b, Idset.add id id_to_exclude + else new_b, Id.Set.add id id_to_exclude *) | GApp(loc1,GRef(loc2,eq_as_ref),[ty;rt1;rt2]) when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous @@ -1051,10 +1051,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (depth + 1) b in match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id - (Idset.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + new_b,Id.Set.remove id + (Id.Set.filter not_free_in_t id_to_exclude) + | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude end | _ -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); @@ -1067,10 +1067,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (depth + 1) b in match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id - (Idset.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + new_b,Id.Set.remove id + (Id.Set.filter not_free_in_t id_to_exclude) + | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude end | GLambda(_,n,k,t,b) -> begin @@ -1087,11 +1087,11 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (args@[mkGVar id])new_crossed_types (depth + 1 ) b in - if Idset.mem id id_to_exclude && depth >= nb_args + if Id.Set.mem id id_to_exclude && depth >= nb_args then - new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude) + new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) else - GProd(Loc.ghost,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude + GProd(Loc.ghost,n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude | _ -> anomaly "Should not have an anonymous function here" (* We have renamed all the anonymous functions during alpha_renaming phase *) @@ -1108,10 +1108,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = args (t::crossed_types) (depth + 1 ) b in match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) | _ -> GLetIn(Loc.ghost,n,t,new_b), - Idset.filter not_free_in_t id_to_exclude + Id.Set.filter not_free_in_t id_to_exclude end | GLetTuple(_,nal,(na,rto),t,b) -> assert (rto=None); @@ -1133,15 +1133,15 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (depth + 1) b in (* match n with *) -(* | Name id when Idset.mem id id_to_exclude -> *) -(* new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *) +(* | Name id when Id.Set.mem id id_to_exclude -> *) +(* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) (* | _ -> *) GLetTuple(Loc.ghost,nal,(na,None),t,new_b), - Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude') + Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') end - | _ -> mkGApp(mkGVar relname,args@[rt]),Idset.empty + | _ -> mkGApp(mkGVar relname,args@[rt]),Id.Set.empty (* debuging wrapper *) @@ -1164,7 +1164,7 @@ let rebuild_cons env nb_args relname args crossed_types rt = *) let rec compute_cst_params relnames params = function | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params - | GApp(_,GVar(_,relname'),rtl) when Idset.mem relname' relnames -> + | GApp(_,GVar(_,relname'),rtl) when Id.Set.mem relname' relnames -> compute_cst_params_from_app [] (params,rtl) | GApp(_,f,args) -> List.fold_left (compute_cst_params relnames) params (f::args) @@ -1182,7 +1182,7 @@ and compute_cst_params_from_app acc (params,rtl) = match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) | ((Name id,_,is_defined) as param)::params',(GVar(_,id'))::rtl' - when id_ord id id' == 0 && not is_defined -> + when Id.compare id id' == 0 && not is_defined -> compute_cst_params_from_app (param::acc) (params',rtl') | _ -> List.rev acc @@ -1233,7 +1233,7 @@ let do_build_inductive (rtl:glob_constr list) = let _time1 = System.get_time () in (* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) - let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in + let funnames_as_set = List.fold_right Id.Set.add funnames Id.Set.empty in let funnames = Array.of_list funnames in let funsargs = Array.of_list funsargs in let returned_types = Array.of_list returned_types in @@ -1244,7 +1244,7 @@ let do_build_inductive Ensures by: obvious i*) let relnames = Array.map mk_rel_id funnames in - let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in + let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in (* Construction of the pseudo constructors *) let env = Array.fold_right @@ -1264,12 +1264,12 @@ let do_build_inductive (fun (n,t,is_defined) acc -> if is_defined then - Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),Constrextern.extern_glob_constr Idset.empty t, + Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),Constrextern.extern_glob_constr Id.Set.empty t, acc) else Constrexpr.CProdN (Loc.ghost, - [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t], + [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,Constrextern.extern_glob_constr Id.Set.empty t], acc ) ) @@ -1307,9 +1307,9 @@ let do_build_inductive (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) - id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) + Id.of_string ((Id.to_string (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) in - let rel_constructors i rt : (identifier*glob_constr) list = + let rel_constructors i rt : (Id.t*glob_constr) list = next_constructor_id := (-1); List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) in @@ -1330,12 +1330,12 @@ let do_build_inductive (fun (n,t,is_defined) acc -> if is_defined then - Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),Constrextern.extern_glob_constr Idset.empty t, + Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),Constrextern.extern_glob_constr Id.Set.empty t, acc) else Constrexpr.CProdN (Loc.ghost, - [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t], + [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,Constrextern.extern_glob_constr Id.Set.empty t], acc ) ) @@ -1352,10 +1352,10 @@ let do_build_inductive (fun (n,t,is_defined) -> if is_defined then - Constrexpr.LocalRawDef((Loc.ghost,n), Constrextern.extern_glob_constr Idset.empty t) + Constrexpr.LocalRawDef((Loc.ghost,n), Constrextern.extern_glob_constr Id.Set.empty t) else Constrexpr.LocalRawAssum - ([(Loc.ghost,n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Idset.empty t) + ([(Loc.ghost,n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t) ) rels_params in @@ -1365,7 +1365,7 @@ let do_build_inductive false,((Loc.ghost,id), Flags.with_option Flags.raw_print - (Constrextern.extern_glob_type Idset.empty) ((* zeta_normalize *) t) + (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) t) ) )) (rel_constructors) diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index b8e7b3ab4..87fcb1022 100644 --- a/plugins/funind/glob_term_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -8,7 +8,7 @@ *) val build_inductive : - Names.identifier list -> (* The list of function name *) + Names.Id.t list -> (* The list of function name *) (Names.name*Glob_term.glob_constr*bool) list list -> (* The list of function args *) Constrexpr.constr_expr list -> (* The list of function returned type *) Glob_term.glob_constr list -> (* the list of body *) diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index f678b898b..7785cbe59 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -6,9 +6,6 @@ open Names open Decl_kinds open Misctypes -(* Ocaml 3.06 Map.S does not handle is_empty *) -let idmap_is_empty m = m = Idmap.empty - (* Some basic functions to rebuild glob_constr In each of them the location is Loc.ghost @@ -119,7 +116,7 @@ let rec glob_make_or_list = function let remove_name_from_mapping mapping na = match na with | Anonymous -> mapping - | Name id -> Idmap.remove id mapping + | Name id -> Id.Map.remove id mapping let change_vars = let rec change_vars mapping rt = @@ -128,7 +125,7 @@ let change_vars = | GVar(loc,id) -> let new_id = try - Idmap.find id mapping + Id.Map.find id mapping with Not_found -> id in GVar(loc,new_id) @@ -187,8 +184,8 @@ let change_vars = GCast(loc,change_vars mapping b, Miscops.map_cast_type (change_vars mapping) c) and change_vars_br mapping ((loc,idl,patl,res) as br) = - let new_mapping = List.fold_right Idmap.remove idl mapping in - if idmap_is_empty new_mapping + let new_mapping = List.fold_right Id.Map.remove idl mapping in + if Id.Map.is_empty new_mapping then br else (loc,idl,patl,change_vars new_mapping res) in @@ -200,27 +197,27 @@ let rec alpha_pat excluded pat = match pat with | PatVar(loc,Anonymous) -> let new_id = Indfun_common.fresh_id excluded "_x" in - PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty + PatVar(loc,Name new_id),(new_id::excluded),Id.Map.empty | PatVar(loc,Name id) -> if List.mem id excluded then let new_id = Namegen.next_ident_away id excluded in PatVar(loc,Name new_id),(new_id::excluded), - (Idmap.add id new_id Idmap.empty) - else pat,excluded,Idmap.empty + (Id.Map.add id new_id Id.Map.empty) + else pat,excluded,Id.Map.empty | PatCstr(loc,constr,patl,na) -> let new_na,new_excluded,map = match na with | Name id when List.mem id excluded -> let new_id = Namegen.next_ident_away id excluded in - Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty - | _ -> na,excluded,Idmap.empty + Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty + | _ -> na,excluded,Id.Map.empty in let new_patl,new_excluded,new_map = List.fold_left (fun (patl,excluded,map) pat -> let new_pat,new_excluded,new_map = alpha_pat excluded pat in - (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map) + (new_pat::patl,new_excluded,Id.Map.fold Id.Map.add new_map map) ) ([],new_excluded,map) patl @@ -232,9 +229,9 @@ let alpha_patl excluded patl = List.fold_left (fun (patl,excluded,map) pat -> let new_pat,new_excluded,new_map = alpha_pat excluded pat in - new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map) + new_pat::patl,new_excluded,(Id.Map.fold Id.Map.add new_map map) ) - ([],excluded,Idmap.empty) + ([],excluded,Id.Map.empty) patl in (List.rev patl,new_excluded,map) @@ -266,7 +263,7 @@ let rec alpha_rt excluded rt = match rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ -> rt | GLambda(loc,Anonymous,k,t,b) -> - let new_id = Namegen.next_ident_away (id_of_string "_x") excluded in + let new_id = Namegen.next_ident_away (Id.of_string "_x") excluded in let new_excluded = new_id :: excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in @@ -285,7 +282,7 @@ let rec alpha_rt excluded rt = if new_id = id then t,b else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) in let new_excluded = new_id::excluded in @@ -299,7 +296,7 @@ let rec alpha_rt excluded rt = if new_id = id then t,b else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) in let new_t = alpha_rt new_excluded t in @@ -311,7 +308,7 @@ let rec alpha_rt excluded rt = if new_id = id then t,b else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) in let new_excluded = new_id::excluded in @@ -332,14 +329,14 @@ let rec alpha_rt excluded rt = then na::nal,id::excluded,mapping else - (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping) + (Name new_id)::nal,id::excluded,(Id.Map.add id new_id mapping) ) - ([],excluded,Idmap.empty) + ([],excluded,Id.Map.empty) nal in let new_nal = List.rev rev_new_nal in let new_rto,new_t,new_b = - if idmap_is_empty mapping + if Id.Map.is_empty mapping then rto,t,b else let replace = change_vars mapping in (Option.map replace rto, t,replace b) @@ -387,14 +384,14 @@ and alpha_br excluded (loc,ids,patl,res) = let is_free_in id = let rec is_free_in = function | GRef _ -> false - | GVar(_,id') -> id_ord id' id == 0 + | GVar(_,id') -> Id.compare id' id == 0 | GEvar _ -> false | GPatVar _ -> false | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) | GLetIn(_,n,t,b) -> let check_in_b = match n with - | Name id' -> id_ord id' id <> 0 + | Name id' -> Id.compare id' id <> 0 | _ -> true in is_free_in t || (check_in_b && is_free_in b) @@ -451,7 +448,7 @@ let replace_var_by_term x_id term = let rec replace_var_by_pattern rt = match rt with | GRef _ -> rt - | GVar(_,id) when id_ord id x_id == 0 -> term + | GVar(_,id) when Id.compare id x_id == 0 -> term | GVar _ -> rt | GEvar _ -> rt | GPatVar _ -> rt @@ -460,7 +457,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern rt', List.map replace_var_by_pattern rtl ) - | GLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt + | GLambda(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt | GLambda(loc,name,k,t,b) -> GLambda(loc, name, @@ -468,7 +465,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern t, replace_var_by_pattern b ) - | GProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt + | GProd(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt | GProd(loc,name,k,t,b) -> GProd(loc, name, @@ -476,7 +473,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern t, replace_var_by_pattern b ) - | GLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt + | GLetIn(_,Name id,_,_) when Id.compare id x_id == 0 -> rt | GLetIn(loc,name,def,b) -> GLetIn(loc, name, @@ -512,7 +509,7 @@ let replace_var_by_term x_id term = GCast(loc,replace_var_by_pattern b, Miscops.map_cast_type replace_var_by_pattern c) and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = - if List.exists (fun id -> id_ord id x_id == 0) idl + if List.exists (fun id -> Id.compare id x_id == 0) idl then br else (loc,idl,patl,replace_var_by_pattern res) in @@ -573,13 +570,13 @@ let eq_cases_pattern pat1 pat2 = let ids_of_pat = let rec ids_of_pat ids = function | PatVar(_,Anonymous) -> ids - | PatVar(_,Name id) -> Idset.add id ids + | PatVar(_,Name id) -> Id.Set.add id ids | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl in - ids_of_pat Idset.empty + ids_of_pat Id.Set.empty let id_of_name = function - | Names.Anonymous -> id_of_string "x" + | Names.Anonymous -> Id.of_string "x" | Names.Name x -> x (* TODO: finish Rec caes *) @@ -604,7 +601,7 @@ let ids_of_glob_constr c = | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> [] in (* build the set *) - List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_glob_constr [] c) + List.fold_left (fun acc x -> Id.Set.add x acc) Id.Set.empty (ids_of_glob_constr [] c) @@ -678,7 +675,7 @@ let expand_as = match pat with | PatVar _ -> map | PatCstr(_,_,patl,Name id) -> - Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl) + Id.Map.add id (pattern_to_term pat) (List.fold_left add_as map patl) | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl in let rec expand_as map rt = @@ -687,7 +684,7 @@ let expand_as = | GVar(_,id) -> begin try - Idmap.find id map + Id.Map.find id map with Not_found -> rt end | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args) @@ -710,4 +707,4 @@ let expand_as = and expand_as_br map (loc,idl,cpl,rt) = (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) in - expand_as Idmap.empty + expand_as Id.Map.empty diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 9cf83df15..55d793e03 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -1,12 +1,8 @@ open Glob_term open Misctypes -(* Ocaml 3.06 Map.S does not handle is_empty *) -val idmap_is_empty : 'a Names.Idmap.t -> bool - - (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) -val get_pattern_id : cases_pattern -> Names.identifier list +val get_pattern_id : cases_pattern -> Names.Id.t list (* [pattern_to_term pat] returns a glob_constr corresponding to [pat]. [pat] must not contain occurences of anonymous pattern @@ -18,7 +14,7 @@ val pattern_to_term : cases_pattern -> glob_constr In each of them the location is Util.Loc.ghost *) val mkGRef : Globnames.global_reference -> glob_constr -val mkGVar : Names.identifier -> glob_constr +val mkGVar : Names.Id.t -> glob_constr val mkGApp : glob_constr*(glob_constr list) -> glob_constr val mkGLambda : Names.name * glob_constr * glob_constr -> glob_constr val mkGProd : Names.name * glob_constr * glob_constr -> glob_constr @@ -61,7 +57,7 @@ val glob_make_or_list : glob_constr list -> glob_constr (* Replace the var mapped in the glob_constr/context *) -val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr +val change_vars : Names.Id.t Names.Id.Map.t -> glob_constr -> glob_constr @@ -73,27 +69,27 @@ val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr [avoid] with the variables appearing in the result. *) val alpha_pat : - Names.Idmap.key list -> + Names.Id.Map.key list -> Glob_term.cases_pattern -> - Glob_term.cases_pattern * Names.Idmap.key list * - Names.identifier Names.Idmap.t + Glob_term.cases_pattern * Names.Id.Map.key list * + Names.Id.t Names.Id.Map.t (* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt conventions and does not share bound variables with avoid *) -val alpha_rt : Names.identifier list -> glob_constr -> glob_constr +val alpha_rt : Names.Id.t list -> glob_constr -> glob_constr (* same as alpha_rt but for case branches *) -val alpha_br : Names.identifier list -> - Loc.t * Names.identifier list * Glob_term.cases_pattern list * +val alpha_br : Names.Id.t list -> + Loc.t * Names.Id.t list * Glob_term.cases_pattern list * Glob_term.glob_constr -> - Loc.t * Names.identifier list * Glob_term.cases_pattern list * + Loc.t * Names.Id.t list * Glob_term.cases_pattern list * Glob_term.glob_constr (* Reduction function *) val replace_var_by_term : - Names.identifier -> + Names.Id.t -> Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr @@ -101,7 +97,7 @@ val replace_var_by_term : (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) -val is_free_in : Names.identifier -> glob_constr -> bool +val is_free_in : Names.Id.t -> glob_constr -> bool val are_unifiable : cases_pattern -> cases_pattern -> bool @@ -110,13 +106,13 @@ val eq_cases_pattern : cases_pattern -> cases_pattern -> bool (* - ids_of_pat : cases_pattern -> Idset.t + ids_of_pat : cases_pattern -> Id.Set.t returns the set of variables appearing in a pattern *) -val ids_of_pat : cases_pattern -> Names.Idset.t +val ids_of_pat : cases_pattern -> Names.Id.Set.t (* TODO: finish this function (Fix not treated) *) -val ids_of_glob_constr: glob_constr -> Names.Idset.t +val ids_of_glob_constr: glob_constr -> Names.Id.Set.t (* removing let_in construction in a glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 22da1a966..f922b2f60 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -85,19 +85,19 @@ let functional_induction with_clean c princl pat = let princ_vars = List.fold_right (fun a acc -> - try Idset.add (destVar a) acc + try Id.Set.add (destVar a) acc with _ -> acc ) args - Idset.empty + Id.Set.empty in - let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in - let old_idl = Idset.diff old_idl princ_vars in + let old_idl = List.fold_right Id.Set.add (Tacmach.pf_ids_of_hyps g) Id.Set.empty in + let old_idl = Id.Set.diff old_idl princ_vars in let subst_and_reduce g = if with_clean then let idl = - List.filter (fun id -> not (Idset.mem id old_idl)) + List.filter (fun id -> not (Id.Set.mem id old_idl)) (Tacmach.pf_ids_of_hyps g) in let flag = @@ -152,7 +152,7 @@ let build_newrecursive let arityc = Constrexpr_ops.prod_constr_expr arityc bl in let arity = Constrintern.interp_type sigma env0 arityc in let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in - (Environ.push_named (recname,None,arity) env, Idmap.add recname impl impls)) + (Environ.push_named (recname,None,arity) env, Id.Map.add recname impl impls)) (env0,Constrintern.empty_internalization_env) lnameargsardef in let recdef = (* Declare local notations *) @@ -185,8 +185,8 @@ let build_newrecursive l = (* Checks whether or not the mutual bloc is recursive *) let is_rec names = - let names = List.fold_right Idset.add names Idset.empty in - let check_id id names = Idset.mem id names in + let names = List.fold_right Id.Set.add names Id.Set.empty in + let check_id id names = Id.Set.mem id names in let rec lookup names = function | GVar(_,id) -> check_id id names | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false @@ -195,11 +195,11 @@ let is_rec names = | GIf(_,b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) | GLetIn(_,na,t,b) | GLambda(_,na,_,t,b) | GProd(_,na,_,t,b) -> - lookup names t || lookup (Nameops.name_fold Idset.remove na names) b + lookup names t || lookup (Nameops.name_fold Id.Set.remove na names) b | GLetTuple(_,nal,_,t,b) -> lookup names t || lookup (List.fold_left - (fun acc na -> Nameops.name_fold Idset.remove na acc) + (fun acc na -> Nameops.name_fold Id.Set.remove na acc) names nal ) @@ -209,7 +209,7 @@ let is_rec names = List.exists (fun (e,_) -> lookup names e) el || List.exists (lookup_br names) brl and lookup_br names (_,idl,_,rt) = - let new_names = List.fold_right Idset.remove idl names in + let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt in lookup names @@ -460,9 +460,9 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas match wf_rel_expr_opt with | None -> let ltof = - let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in + let make_dir l = make_dirpath (List.map Id.of_string (List.rev l)) in Libnames.Qualid (Loc.ghost,Libnames.qualid_of_path - (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof"))) + (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof"))) in let fun_from_mes = let applied_mes = @@ -475,8 +475,8 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas wf_rel_from_mes,true | Some wf_rel_expr -> let wf_rel_with_mes = - let a = Names.id_of_string "___a" in - let b = Names.id_of_string "___b" in + let a = Names.Id.of_string "___a" in + let b = Names.Id.of_string "___b" in Constrexpr_ops.mkLambdaC( [Loc.ghost,Name a;Loc.ghost,Name b], Constrexpr.Default Explicit, diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index fb9116cc2..2d50adf00 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -4,7 +4,7 @@ open Libnames open Globnames open Refiner open Hiddentac -let mk_prefix pre id = id_of_string (pre^(string_of_id id)) +let mk_prefix pre id = Id.of_string (pre^(Id.to_string id)) let mk_rel_id = mk_prefix "R_" let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" @@ -16,7 +16,7 @@ let msgnl m = let invalid_argument s = raise (Invalid_argument s) -let fresh_id avoid s = Namegen.next_ident_away_in_goal (id_of_string s) avoid +let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) avoid let fresh_name avoid s = Name (fresh_id avoid s) @@ -116,7 +116,7 @@ let const_of_id id = qualid_of_reference (Libnames.Ident (Loc.ghost,id)) in try Nametab.locate_constant princ_ref - with Not_found -> Errors.error ("cannot find "^ string_of_id id) + with Not_found -> Errors.error ("cannot find "^ Id.to_string id) let def_of_const t = match (Term.kind_of_term t) with @@ -133,8 +133,8 @@ let coq_constant s = let find_reference sl s = (Nametab.locate (make_qualid(Names.make_dirpath - (List.map id_of_string (List.rev sl))) - (id_of_string s)));; + (List.map Id.of_string (List.rev sl))) + (Id.of_string s)));; let eq = lazy(coq_constant "eq") let refl_equal = lazy(coq_constant "eq_refl") @@ -510,8 +510,8 @@ let jmeq_refl () = let h_intros l = tclMAP h_intro l -let h_id = id_of_string "h" -let hrec_id = id_of_string "hrec" +let h_id = Id.of_string "h" +let hrec_id = Id.of_string "hrec" let well_founded = function () -> (coq_constant "well_founded") let acc_rel = function () -> (coq_constant "Acc") let acc_inv_id = function () -> (coq_constant "Acc_inv") diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 8f80c072c..7d0f5a00e 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -5,23 +5,23 @@ open Pp The mk_?_id function build different name w.r.t. a function Each of their use is justified in the code *) -val mk_rel_id : identifier -> identifier -val mk_correct_id : identifier -> identifier -val mk_complete_id : identifier -> identifier -val mk_equation_id : identifier -> identifier +val mk_rel_id : Id.t -> Id.t +val mk_correct_id : Id.t -> Id.t +val mk_complete_id : Id.t -> Id.t +val mk_equation_id : Id.t -> Id.t val msgnl : std_ppcmds -> unit val invalid_argument : string -> 'a -val fresh_id : identifier list -> string -> identifier -val fresh_name : identifier list -> string -> name -val get_name : identifier list -> ?default:string -> name -> name +val fresh_id : Id.t list -> string -> Id.t +val fresh_name : Id.t list -> string -> name +val get_name : Id.t list -> ?default:string -> name -> name val array_get_start : 'a array -> 'a array -val id_of_name : name -> identifier +val id_of_name : name -> Id.t val locate_ind : Libnames.reference -> inductive val locate_constant : Libnames.reference -> constant @@ -44,7 +44,7 @@ val chop_rprod_n : int -> Glob_term.glob_constr -> val def_of_const : Term.constr -> Term.constr val eq : Term.constr Lazy.t val refl_equal : Term.constr Lazy.t -val const_of_id: identifier -> constant +val const_of_id: Id.t -> constant val jmeq : unit -> Term.constr val jmeq_refl : unit -> Term.constr @@ -54,14 +54,14 @@ val jmeq_refl : unit -> Term.constr val new_save_named : bool -> unit -val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> +val save : bool -> Id.t -> Entries.definition_entry -> Decl_kinds.goal_kind -> unit Tacexpr.declaration_hook -> unit (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and abort the proof *) val get_proof_clean : bool -> - Names.identifier * + Names.Id.t * (Entries.definition_entry * Decl_kinds.goal_kind * unit Tacexpr.declaration_hook) @@ -113,9 +113,9 @@ exception ToShow of exn val is_strict_tcc : unit -> bool -val h_intros: Names.identifier list -> Proof_type.tactic -val h_id : Names.identifier -val hrec_id : Names.identifier +val h_intros: Names.Id.t list -> Proof_type.tactic +val h_id : Names.Id.t +val hrec_id : Names.Id.t val acc_inv_id : Term.constr Util.delayed val ltof_ref : Globnames.global_reference Util.delayed val well_founded_ltof : Term.constr Util.delayed diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 517a1ce9c..4a466175f 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -126,8 +126,8 @@ let generate_type g_to_f f graph i = (*i We need to name the vars [res] and [fv] i*) let filter = function (Name id,_,_) -> Some id | (Anonymous,_,_) -> None in let named_ctxt = List.map_filter filter fun_ctxt in - let res_id = Namegen.next_ident_away_in_goal (id_of_string "_res") named_ctxt in - let fv_id = Namegen.next_ident_away_in_goal (id_of_string "fv") (res_id :: named_ctxt) in + let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in + let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (res_id :: named_ctxt) in (*i we can then type the argument to be applied to the function [f] i*) let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in (*i @@ -242,13 +242,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let princ_infos = Tactics.compute_elim_sig princ_type in (* The number of args of the function is then easilly computable *) let nb_fun_args = nb_prod (pf_concl g) - 2 in - let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in + let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* Since we cannot ensure that the funcitonnal principle is defined in the environement and due to the bug #1174, we will need to pose the principle using a name *) - let principle_id = Namegen.next_ident_away_in_goal (id_of_string "princ") ids in + let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") ids in let ids = principle_id :: ids in (* We get the branches of the principle *) let branches = List.rev princ_infos.branches in @@ -258,7 +258,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (fun (_,_,br_type) -> List.map (fun id -> Loc.ghost, IntroIdentifier id) - (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) ) branches in @@ -276,16 +276,16 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.fold_right (fun (_,pat) acc -> match pat with - | Genarg.IntroIdentifier id -> Idset.add id acc + | Genarg.IntroIdentifier id -> Id.Set.add id acc | _ -> anomaly "Not an identifier" ) (List.nth intro_pats (pred i)) - Idset.empty + Id.Set.empty in let pre_args g = List.fold_right (fun (id,b,t) pre_args -> - if Idset.mem id this_branche_ids + if Id.Set.mem id this_branche_ids then match b with | None -> id::pre_args @@ -299,7 +299,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let pre_tac g = List.fold_right (fun (id,b,t) pre_tac -> - if Idset.mem id this_branche_ids + if Id.Set.mem id this_branche_ids then match b with | None -> pre_tac @@ -383,7 +383,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let app_constructor g = applist((mkConstruct(constructor)),constructor_args g) in (* an apply the tactic *) let res,hres = - match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with + match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with | [res;hres] -> res,hres | _ -> assert false in @@ -466,7 +466,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem princ_type (h_exact f_principle)); observe_tac "intro args_names" (tclMAP h_intro args_names); - (* observe_tac "titi" (pose_proof (Name (id_of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) + (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) observe_tac "idtac" tclIDTAC; tclTHEN_i (observe_tac "functional_induction" ( @@ -506,13 +506,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let princ_infos = Tactics.compute_elim_sig princ_type in (* The number of args of the function is then easilly computable *) let nb_fun_args = nb_prod (pf_concl g) - 2 in - let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in + let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* Since we cannot ensure that the funcitonnal principle is defined in the environement and due to the bug #1174, we will need to pose the principle using a name *) - let principle_id = Namegen.next_ident_away_in_goal (id_of_string "princ") ids in + let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") ids in let ids = principle_id :: ids in (* We get the branches of the principle *) let branches = List.rev princ_infos.branches in @@ -522,7 +522,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (fun (_,_,br_type) -> List.map (fun id -> Loc.ghost, Genarg.IntroIdentifier id) - (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) ) branches in @@ -540,17 +540,17 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.fold_right (fun (_,pat) acc -> match pat with - | Genarg.IntroIdentifier id -> Idset.add id acc + | Genarg.IntroIdentifier id -> Id.Set.add id acc | _ -> anomaly "Not an identifier" ) (List.nth intro_pats (pred i)) - Idset.empty + Id.Set.empty in (* and get the real args of the branch by unfolding the defined constant *) let pre_args,pre_tac = List.fold_right (fun (id,b,t) (pre_args,pre_tac) -> - if Idset.mem id this_branche_ids + if Id.Set.mem id this_branche_ids then match b with | None -> (id::pre_args,pre_tac) @@ -624,7 +624,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let app_constructor = applist((mkConstruct(constructor)),constructor_args) in (* an apply the tactic *) let res,hres = - match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with + match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with | [res;hres] -> res,hres | _ -> assert false in @@ -735,7 +735,7 @@ and intros_with_rewrite_aux : tactic = | App(eq,args) when (eq_constr eq eq_ind) -> if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then - let id = pf_get_new_id (id_of_string "y") g in + let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ h_intro id; thin [id]; intros_with_rewrite ] g else if isVar args.(1) && (Environ.evaluable_named (destVar args.(1)) (pf_env g)) then tclTHENSEQ[ @@ -753,7 +753,7 @@ and intros_with_rewrite_aux : tactic = ] g else if isVar args.(1) then - let id = pf_get_new_id (id_of_string "y") g in + let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ h_intro id; generalize_dependent_of (destVar args.(1)) id; tclTRY (Equality.rewriteLR (mkVar id)); @@ -762,7 +762,7 @@ and intros_with_rewrite_aux : tactic = g else if isVar args.(2) then - let id = pf_get_new_id (id_of_string "y") g in + let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ h_intro id; generalize_dependent_of (destVar args.(2)) id; tclTRY (Equality.rewriteRL (mkVar id)); @@ -771,7 +771,7 @@ and intros_with_rewrite_aux : tactic = g else begin - let id = pf_get_new_id (id_of_string "y") g in + let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ[ h_intro id; tclTRY (Equality.rewriteLR (mkVar id)); @@ -797,7 +797,7 @@ and intros_with_rewrite_aux : tactic = intros_with_rewrite ] g | _ -> - let id = pf_get_new_id (id_of_string "y") g in + let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ h_intro id;intros_with_rewrite] g end | LetIn _ -> @@ -904,11 +904,11 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = and compute a fresh name for each of them *) let nb_fun_args = nb_prod (pf_concl g) - 2 in - let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in + let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* and fresh names for res H and the principle (cf bug bug #1174) *) let res,hres,graph_principle_id = - match generate_fresh_id (id_of_string "z") ids 3 with + match generate_fresh_id (Id.of_string "z") ids 3 with | [res;hres;graph_principle_id] -> res,hres,graph_principle_id | _ -> assert false in @@ -920,7 +920,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (fun (_,_,br_type) -> List.map (fun id -> id) - (generate_fresh_id (id_of_string "y") ids (nb_prod br_type)) + (generate_fresh_id (Id.of_string "y") ids (nb_prod br_type)) ) branches in @@ -1059,7 +1059,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g (fst lemmas_types_infos.(i)) (fun _ _ -> ()); Pfedit.by - (observe_tac ("prove correctness ("^(string_of_id f_id)^")") + (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") (proving_tac i)); do_save (); let finfo = find_Function_infos f_as_constant in @@ -1110,7 +1110,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g (fst lemmas_types_infos.(i)) (fun _ _ -> ()); Pfedit.by - (observe_tac ("prove completeness ("^(string_of_id f_id)^")") + (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") (proving_tac i)); do_save (); let finfo = find_Function_infos f_as_constant in @@ -1187,7 +1187,7 @@ let revert_graph kn post_tac hid g = let functional_inversion kn hid fconst f_correct : tactic = fun g -> - let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in + let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in let type_of_h = pf_type_of g (mkVar hid) in match kind_of_term type_of_h with | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> @@ -1206,7 +1206,7 @@ let functional_inversion kn hid fconst f_correct : tactic = h_intro hid; Inv.inv FullInversion None (NamedHyp hid); (fun g -> - let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in + let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in tclMAP (revert_graph kn pre_tac) (hid::new_ids) g ); ] g diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 485b5b280..089493079 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -53,10 +53,10 @@ let understand = Pretyping.understand Evd.empty (Global.env()) (** Operations on names and identifiers *) let id_of_name = function - Anonymous -> id_of_string "H" + Anonymous -> Id.of_string "H" | Name id -> id;; -let name_of_string str = Name (id_of_string str) -let string_of_name nme = string_of_id (id_of_name nme) +let name_of_string str = Name (Id.of_string str) +let string_of_name nme = Id.to_string (id_of_name nme) (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) let isVarf f x = @@ -75,7 +75,7 @@ let ident_global_exist id = (** [next_ident_fresh id] returns a fresh identifier (ie not linked in global env) with base [id]. *) -let next_ident_fresh (id:identifier) = +let next_ident_fresh (id:Id.t) = let res = ref id in while ident_global_exist !res do res := Nameops.lift_subscript !res done; !res @@ -129,7 +129,7 @@ let prNamedRLDecl s lc = prstr "\n"; end -let showind (id:identifier) = +let showind (id:Id.t) = let cstrid = Constrintern.global_reference id in let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in @@ -247,7 +247,7 @@ type 'a merged_arg = type merge_infos = { - ident:identifier; (** new inductive name *) + ident:Id.t; (** new inductive name *) mib1: mutual_inductive_body; oib1: one_inductive_body; mib2: mutual_inductive_body; @@ -350,8 +350,8 @@ let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = (** {1 Utilities for merging} *) -let ind1name = id_of_string "__ind1" -let ind2name = id_of_string "__ind2" +let ind1name = Id.of_string "__ind1" +let ind2name = Id.of_string "__ind2" (** Performs verifications on two graphs before merging: they must not be co-inductive, and for the moment they must not be mutual @@ -374,11 +374,11 @@ let build_raw_params prms_decl avoid = let _ = prNamedRConstr "RAWDUMMY" dummy_glob_constr in let res,_ = glob_decompose_prod dummy_glob_constr in let comblist = List.combine prms_decl res in - comblist, res , (avoid @ (Idset.elements (ids_of_glob_constr dummy_glob_constr))) + comblist, res , (avoid @ (Id.Set.elements (ids_of_glob_constr dummy_glob_constr))) *) let ids_of_rawlist avoid rawl = - List.fold_left Idset.union avoid (List.map ids_of_glob_constr rawl) + List.fold_left Id.Set.union avoid (List.map ids_of_glob_constr rawl) @@ -456,7 +456,7 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array ([],[],[],[]) arity_ctxt in (* let arity_ctxt2 = build_raw_params oib2.mind_arity_ctxt - (Idset.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*) + (Id.Set.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*) let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in let _ = prstr "\n\n\n" in let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in @@ -564,7 +564,7 @@ let build_suppl_reccall (accrec:(name * glob_constr) list) concl2 shift = List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec -let find_app (nme:identifier) ltyp = +let find_app (nme:Id.t) ltyp = try ignore (List.map @@ -650,16 +650,16 @@ let rec merge_types shift accrec1 linked args [allargs2] to target args of [allargs1] as specified in [shift]. [allargs1] and [allargs2] are in reverse order. Also returns the list of unlinked vars of [allargs2]. *) -let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array) +let build_link_map_aux (allargs1:Id.t array) (allargs2:Id.t array) (lnk:int merged_arg array) = Array.fold_left_i (fun i acc e -> if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *) else match e with - | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc + | Prm_linked j | Arg_linked j -> Id.Map.add allargs2.(i) allargs1.(j) acc | _ -> acc) - Idmap.empty lnk + Id.Map.empty lnk let build_link_map allargs1 allargs2 lnk = let allargs1 = @@ -742,18 +742,18 @@ let fresh_cstror_suffix , cstror_suffix_init = (** [merge_constructor_id id1 id2 shift] returns the identifier of the new constructor from the id of the two merged constructor and the merging info. *) -let merge_constructor_id id1 id2 shift:identifier = - let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in - next_ident_fresh (id_of_string id) +let merge_constructor_id id1 id2 shift:Id.t = + let id = Id.to_string shift.ident ^ "_" ^ fresh_cstror_suffix () in + next_ident_fresh (Id.of_string id) (** [merge_constructors lnk shift avoid] merges the two list of constructor [(name*type)]. These are translated to glob_constr first, each of them having distinct var names. *) -let merge_constructors (shift:merge_infos) (avoid:Idset.t) - (typcstr1:(identifier * glob_constr) list) - (typcstr2:(identifier * glob_constr) list) : (identifier * glob_constr) list = +let merge_constructors (shift:merge_infos) (avoid:Id.Set.t) + (typcstr1:(Id.t * glob_constr) list) + (typcstr2:(Id.t * glob_constr) list) : (Id.t * glob_constr) list = List.flatten (List.map (fun (id1,rawtyp1) -> @@ -775,14 +775,14 @@ let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) let mkrawcor nme avoid typ = (* first replace rel 1 by a varname *) let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in - Detyping.detype false (Idset.elements avoid) [] substindtyp in + Detyping.detype false (Id.Set.elements avoid) [] substindtyp in let lcstr1: glob_constr list = Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in (* add to avoid all indentifiers of lcstr1 *) - let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in + let avoid2 = Id.Set.union avoid (ids_of_rawlist avoid lcstr1) in let lcstr2 = Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in - let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in + let avoid3 = Id.Set.union avoid (ids_of_rawlist avoid lcstr2) in let params1 = try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) @@ -806,11 +806,11 @@ let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) let merge_mutual_inductive_body (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) = (* Mutual not treated, we take first ind body of each. *) - merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0) + merge_inductive_body shift Id.Set.empty mib1.mind_packets.(0) mib2.mind_packets.(0) let glob_constr_to_constr_expr x = (* build a constr_expr from a glob_constr *) - Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Idset.empty) x + Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Id.Set.empty) x let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let params = prms2 @ prms1 in @@ -842,7 +842,7 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = [rawlist], named ident. FIXME: params et cstr_expr (arity) *) let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift - (rawlist:(identifier * glob_constr) list) = + (rawlist:(Id.t * glob_constr) list) = let lident = Loc.ghost, shift.ident in let bindlist , cstr_expr = (* params , arities *) merge_rec_params_and_arity prms1 prms2 shift mkSet in @@ -875,7 +875,7 @@ let merge_inductive (ind1: inductive) (ind2: inductive) let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in let _ = prstr "\nrawlist : " in let _ = - List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in + List.iter (fun (nm,tp) -> prNamedRConstr (Id.to_string nm) tp;prstr "\n") rawlist in let _ = prstr "\nend rawlist\n" in (* FIX: retransformer en constr ici let shift_prm = @@ -892,7 +892,7 @@ let merge_inductive (ind1: inductive) (ind2: inductive) (* Find infos on identifier id. *) -let find_Function_infos_safe (id:identifier): Indfun_common.function_info = +let find_Function_infos_safe (id:Id.t): Indfun_common.function_info = let kn_of_id x = let f_ref = Libnames.Ident (Loc.ghost,x) in locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref) @@ -909,8 +909,8 @@ let find_Function_infos_safe (id:identifier): Indfun_common.function_info = Warning: For the moment, repetitions of an id in [args1] or [args2] are not supported. *) -let merge (id1:identifier) (id2:identifier) (args1:identifier array) - (args2:identifier array) id : unit = +let merge (id1:Id.t) (id2:Id.t) (args1:Id.t array) + (args2:Id.t array) id : unit = let finfo1 = find_Function_infos_safe id1 in let finfo2 = find_Function_infos_safe id2 in (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index a2f16dc6d..28752fe4f 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -51,11 +51,11 @@ let coq_base_constant s = let find_reference sl s = (locate (make_qualid(Names.make_dirpath - (List.map id_of_string (List.rev sl))) - (id_of_string s)));; + (List.map Id.of_string (List.rev sl))) + (Id.of_string s)));; -let (declare_fun : identifier -> logical_kind -> constr -> global_reference) = +let (declare_fun : Id.t -> logical_kind -> constr -> global_reference) = fun f_id kind value -> let ce = {const_entry_body = value; const_entry_secctx = None; @@ -73,7 +73,7 @@ let def_of_const t = | _ -> assert false) with _ -> anomaly ("Cannot find definition of constant "^ - (string_of_id (id_of_label (con_label sp)))) + (Id.to_string (id_of_label (con_label sp)))) ) |_ -> assert false @@ -86,8 +86,8 @@ let type_of_const t = let constant sl s = constr_of_global (locate (make_qualid(Names.make_dirpath - (List.map id_of_string (List.rev sl))) - (id_of_string s)));; + (List.map Id.of_string (List.rev sl))) + (Id.of_string s)));; let const_of_ref = function ConstRef kn -> kn | _ -> anomaly "ConstRef expected" @@ -120,15 +120,15 @@ let pf_get_new_ids idl g = let compute_renamed_type gls c = rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] (pf_type_of gls c) -let h'_id = id_of_string "h'" -let teq_id = id_of_string "teq" -let ano_id = id_of_string "anonymous" -let x_id = id_of_string "x" -let k_id = id_of_string "k" -let v_id = id_of_string "v" -let def_id = id_of_string "def" -let p_id = id_of_string "p" -let rec_res_id = id_of_string "rec_res";; +let h'_id = Id.of_string "h'" +let teq_id = Id.of_string "teq" +let ano_id = Id.of_string "anonymous" +let x_id = Id.of_string "x" +let k_id = Id.of_string "k" +let v_id = Id.of_string "v" +let def_id = Id.of_string "def" +let p_id = Id.of_string "p" +let rec_res_id = Id.of_string "rec_res";; let lt = function () -> (coq_base_constant "lt") let le = function () -> (coq_base_constant "le") let ex = function () -> (coq_base_constant "ex") @@ -202,7 +202,7 @@ let (value_f:constr list -> global_reference -> constr) = let body = understand Evd.empty env glob_body in it_mkLambda_or_LetIn body context -let (declare_f : identifier -> logical_kind -> constr list -> global_reference -> global_reference) = +let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) = fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; @@ -300,7 +300,7 @@ let check_not_nested forbidden e = let rec check_not_nested e = match kind_of_term e with | Rel _ -> () - | Var x -> if List.mem x (forbidden) then error ("check_not_nested : failure "^string_of_id x) + | Var x -> if List.mem x (forbidden) then error ("check_not_nested : failure "^Id.to_string x) | Meta _ | Evar _ | Sort _ -> () | Cast(e,_,t) -> check_not_nested e;check_not_nested t | Prod(_,t,b) -> check_not_nested t;check_not_nested b @@ -324,21 +324,21 @@ let check_not_nested forbidden e = type 'a infos = { nb_arg : int; (* function number of arguments *) concl_tac : tactic; (* final tactic to finish proofs *) - rec_arg_id : identifier; (*name of the declared recursive argument *) + rec_arg_id : Id.t; (*name of the declared recursive argument *) is_mes : bool; (* type of recursion *) - ih : identifier; (* induction hypothesis name *) - f_id : identifier; (* function name *) + ih : Id.t; (* induction hypothesis name *) + f_id : Id.t; (* function name *) f_constr : constr; (* function term *) f_terminate : constr; (* termination proof term *) func : global_reference; (* functionnal reference *) info : 'a; is_main_branch : bool; (* on the main branch or on a matched expression *) is_final : bool; (* final first order term or not *) - values_and_bounds : (identifier*identifier) list; - eqs : identifier list; - forbidden_ids : identifier list; + values_and_bounds : (Id.t*Id.t) list; + eqs : Id.t list; + forbidden_ids : Id.t list; acc_inv : constr lazy_t; - acc_id : identifier; + acc_id : Id.t; args_assoc : ((constr list)*constr) list; } @@ -651,7 +651,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info = introduced back later; the result is the pair of the tactic and the list of hypotheses that have been generalized and cleared. *) let mkDestructEq : - identifier list -> constr -> goal sigma -> tactic * identifier list = + Id.t list -> constr -> goal sigma -> tactic * Id.t list = fun not_on_hyp expr g -> let hyps = pf_hyps g in let to_revert = @@ -1031,10 +1031,10 @@ let termination_proof_header is_mes input_type ids args_id relation in let relation = substl pre_rec_args relation in let input_type = substl pre_rec_args input_type in - let wf_thm = next_ident_away_in_goal (id_of_string ("wf_R")) ids in + let wf_thm = next_ident_away_in_goal (Id.of_string ("wf_R")) ids in let wf_rec_arg = next_ident_away_in_goal - (id_of_string ("Acc_"^(string_of_id rec_arg_id))) + (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))) (wf_thm::ids) in let hrec = next_ident_away_in_goal hrec_id @@ -1206,8 +1206,8 @@ let build_and_l l = let is_rec_res id = - let rec_res_name = string_of_id rec_res_id in - let id_name = string_of_id id in + let rec_res_name = Id.to_string rec_res_id in + let id_name = Id.to_string id in try String.sub id_name 0 (String.length rec_res_name) = rec_res_name with _ -> false @@ -1384,7 +1384,7 @@ let com_terminate let start_equation (f:global_reference) (term_f:global_reference) - (cont_tactic:identifier list -> tactic) g = + (cont_tactic:Id.t list -> tactic) g = let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_global term_f in let nargs = nb_prod (type_of_const terminate_constr) in @@ -1397,7 +1397,7 @@ let start_equation (f:global_reference) (term_f:global_reference) Array.of_list (List.map mkVar x)))); observe_tac (str "prove_eq") (cont_tactic x)] g;; -let (com_eqn : int -> identifier -> +let (com_eqn : int -> Id.t -> global_reference -> global_reference -> global_reference -> constr -> unit) = fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> @@ -1430,12 +1430,12 @@ let (com_eqn : int -> identifier -> eqs = []; forbidden_ids = []; acc_inv = lazy (assert false); - acc_id = id_of_string "____"; + acc_id = Id.of_string "____"; args_assoc = []; - f_id = id_of_string "______"; - rec_arg_id = id_of_string "______"; + f_id = Id.of_string "______"; + rec_arg_id = Id.of_string "______"; is_mes = false; - ih = id_of_string "______"; + ih = Id.of_string "______"; } ) ); diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 1117e2597..2ef685203 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -4,11 +4,11 @@ val tclUSER_if_not_mes : Proof_type.tactic -> bool -> - Names.identifier list option -> + Names.Id.t list option -> Proof_type.tactic val recursive_definition : bool -> - Names.identifier -> + Names.Id.t -> Constrintern.internalization_env -> Constrexpr.constr_expr -> Constrexpr.constr_expr -> diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index aab237a23..d2d6a7b63 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -66,7 +66,7 @@ type 'cst formula = | C of 'cst formula * 'cst formula | D of 'cst formula * 'cst formula | N of 'cst formula - | I of 'cst formula * Names.identifier option * 'cst formula + | I of 'cst formula * Names.Id.t option * 'cst formula (** * Formula pretty-printer. @@ -83,7 +83,7 @@ let rec pp_formula o f = | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" pp_formula f1 (match n with - | Some id -> Names.string_of_id id + | Some id -> Names.Id.to_string id | None -> "") pp_formula f2 | N(f) -> Printf.fprintf o "N(%a)" pp_formula f @@ -1158,7 +1158,7 @@ struct | (e::l) -> let (name,expr,typ) = e in xset (Term.mkNamedLetIn - (Names.id_of_string name) + (Names.Id.of_string name) expr typ acc) l in xset concl l @@ -1185,7 +1185,7 @@ let same_proof sg cl1 cl2 = let tags_of_clause tgs wit clause = let rec xtags tgs = function - | Mc.PsatzIn n -> Names.Idset.union tgs + | Mc.PsatzIn n -> Names.Id.Set.union tgs (snd (List.nth clause (CoqToCaml.nat n) )) | Mc.PsatzMulC(e,w) -> xtags tgs w | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(w1,w2) -> xtags (xtags tgs w1) w2 @@ -1194,7 +1194,7 @@ let tags_of_clause tgs wit clause = (*let tags_of_cnf wits cnf = List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) - Names.Idset.empty wits cnf *) + Names.Id.Set.empty wits cnf *) let find_witness prover polys1 = try_any prover polys1 diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 9bfebe348..851516945 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -85,7 +85,7 @@ let generalize_time = timing "Generalize" let new_identifier = let cpt = ref 0 in - (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s) + (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; Id.of_string s) let new_identifier_state = let cpt = ref 0 in @@ -93,7 +93,7 @@ let new_identifier_state = let new_identifier_var = let cpt = ref 0 in - (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s) + (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; Id.of_string s) let new_id = let cpt = ref 0 in fun () -> incr cpt; !cpt @@ -109,7 +109,7 @@ let display_var i = Printf.sprintf "X%d" i let intern_id,unintern_id = let cpt = ref 0 in let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in - (fun (name : identifier) -> + (fun (name : Id.t) -> try Hashtbl.find table name with Not_found -> let idx = !cpt in Hashtbl.add table name idx; @@ -136,13 +136,13 @@ let rev_assoc k = loop let tag_hypothesis,tag_of_hyp, hyp_of_tag = - let l = ref ([]:(identifier * int) list) in + let l = ref ([]:(Id.t * int) list) in (fun h id -> l := (h,id):: !l), (fun h -> try List.assoc h !l with Not_found -> failwith "tag_hypothesis"), (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis") let hide_constr,find_constr,clear_tables,dump_tables = - let l = ref ([]:(constr * (identifier * identifier * bool)) list) in + let l = ref ([]:(constr * (Id.t * Id.t * bool)) list) in (fun h id eg b -> l := (h,(id,eg,b)):: !l), (fun h -> try List.assoc_f eq_constr h !l with Not_found -> failwith "find_contr"), (fun () -> l := []), @@ -329,7 +329,7 @@ let sp_Zge = lazy (evaluable_ref_of_constr "Z.ge" coq_Zge) let sp_Zlt = lazy (evaluable_ref_of_constr "Z.lt" coq_Zlt) let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ()))) -let mk_var v = mkVar (id_of_string v) +let mk_var v = mkVar (Id.of_string v) let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) @@ -370,7 +370,7 @@ type omega_proposition = | Kn type result = - | Kvar of identifier + | Kvar of Id.t | Kapp of omega_constant * constr list | Kimp of constr * constr | Kufo @@ -527,7 +527,7 @@ let occurence path (t : constr) = let abstract_path typ path t = let term_occur = ref (mkRel 0) in let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in - mkLambda (Name (id_of_string "x"), typ, abstract), !term_occur + mkLambda (Name (Id.of_string "x"), typ, abstract), !term_occur let focused_simpl path gl = let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in @@ -539,7 +539,7 @@ type oformula = | Oplus of oformula * oformula | Oinv of oformula | Otimes of oformula * oformula - | Oatom of identifier + | Oatom of Id.t | Oz of bigint | Oufo of constr @@ -551,7 +551,7 @@ let rec oprint = function | Otimes (t1,t2) -> print_string "("; oprint t1; print_string "*"; oprint t2; print_string ")" - | Oatom s -> print_string (string_of_id s) + | Oatom s -> print_string (Id.to_string s) | Oz i -> print_string (string_of_bigint i) | Oufo f -> print_string "?" @@ -597,10 +597,10 @@ let clever_rewrite_base_poly typ p result theorem gl = let t = applist (mkLambda - (Name (id_of_string "P"), + (Name (Id.of_string "P"), mkArrow typ mkProp, mkLambda - (Name (id_of_string "H"), + (Name (Id.of_string "H"), applist (mkRel 1,[result]), mkApp (Lazy.force coq_eq_ind_r, [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), @@ -1007,9 +1007,9 @@ let rec clear_zero p = function | t -> [],t let replay_history tactic_normalisation = - let aux = id_of_string "auxiliary" in - let aux1 = id_of_string "auxiliary_1" in - let aux2 = id_of_string "auxiliary_2" in + let aux = Id.of_string "auxiliary" in + let aux1 = Id.of_string "auxiliary_1" in + let aux2 = Id.of_string "auxiliary_2" in let izero = mk_integer zero in let rec loop t = match t with diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index ee341cbc2..d94a7136a 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -39,7 +39,7 @@ END TACTIC EXTEND omega' | [ "omega" "with" ne_ident_list(l) ] -> - [ omega_tactic (List.map Names.string_of_id l) ] + [ omega_tactic (List.map Names.Id.to_string l) ] | [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ] END diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 61a464c1c..4238037e7 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -189,10 +189,10 @@ let decomp_term c = kind_of_term (strip_outer_cast c) type [typ] *) let coerce_meta_out id = - let s = string_of_id id in + let s = Id.to_string id in int_of_string (String.sub s 1 (String.length s - 1)) let coerce_meta_in n = - id_of_string ("M" ^ string_of_int n) + Id.of_string ("M" ^ string_of_int n) let compute_lhs typ i nargsi = match kind_of_term typ with diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 5b57a0d17..92135d497 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -22,10 +22,10 @@ let string_of_global r = let prefix = match Names.repr_dirpath dp with | [] -> "" | m::_ -> - let s = Names.string_of_id m in + let s = Names.Id.to_string m in if List.mem s meaningful_submodule then s^"." else "" in - prefix^(Names.string_of_id (Nametab.basename_of_global r)) + prefix^(Names.Id.to_string (Nametab.basename_of_global r)) let destructurate t = let c, args = Term.decompose_app t in @@ -36,7 +36,7 @@ let destructurate t = Kapp (string_of_global (Globnames.ConstructRef csp), args) | Term.Ind isp, args -> Kapp (string_of_global (Globnames.IndRef isp), args) - | Term.Var id,[] -> Kvar(Names.string_of_id id) + | Term.Var id,[] -> Kvar(Names.Id.to_string id) | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) | Term.Prod (Names.Name _,_,_),[] -> Errors.error "Omega: Not a quantifier-free goal" @@ -296,13 +296,13 @@ let coq_Zneg = lazy (bin_constant "Zneg") let recognize t = let rec loop t = let f,l = dest_const_apply t in - match Names.string_of_id f,l with + match Names.Id.to_string f,l with "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) | "xO",[t] -> Bigint.mult Bigint.two (loop t) | "xH",[] -> Bigint.one | _ -> failwith "not a number" in let f,l = dest_const_apply t in - match Names.string_of_id f,l with + match Names.Id.to_string f,l with "Zpos",[t] -> loop t | "Zneg",[t] -> Bigint.neg (loop t) | "Z0",[] -> Bigint.zero diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index 5a843e2b7..a68196e8c 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -37,6 +37,6 @@ END TACTIC EXTEND romega' | [ "romega" "with" ne_ident_list(l) ] -> - [ romega_tactic (List.map Names.string_of_id l) ] + [ romega_tactic (List.map Names.Id.to_string l) ] | [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ] END diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index e573f2006..e3674fae0 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -40,7 +40,7 @@ type occ_path = occ_step list (* chemin identifiant une proposition sous forme du nom de l'hypothèse et d'une liste de pas à partir de la racine de l'hypothèse *) -type occurence = {o_hyp : Names.identifier; o_path : occ_path} +type occurence = {o_hyp : Names.Id.t; o_path : occ_path} (* \subsection{refiable formulas} *) type oformula = @@ -137,7 +137,7 @@ type context_content = (* \section{Specific utility functions to handle base types} *) (* Nom arbitraire de l'hypothèse codant la négation du but final *) -let id_concl = Names.id_of_string "__goal__" +let id_concl = Names.Id.of_string "__goal__" (* Initialisation de l'environnement de réification de la tactique *) let new_environment () = { @@ -746,7 +746,7 @@ let reify_gl env gl = (i,t) :: lhyps -> let t' = oproposition_of_constr env (false,[],i,[]) gl t in if !debug then begin - Printf.printf " %s: " (Names.string_of_id i); + Printf.printf " %s: " (Names.Id.to_string i); pprint stdout t'; Printf.printf "\n" end; @@ -840,7 +840,7 @@ let display_systems syst_list = (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M") oformula_eq.e_origin.o_path)); Printf.printf "\n Origin: %s (negated : %s)\n\n" - (Names.string_of_id oformula_eq.e_origin.o_hyp) + (Names.Id.to_string oformula_eq.e_origin.o_hyp) (if oformula_eq.e_negated then "yes" else "no") in let display_system syst = diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli index e5fb646a4..f7e6ec020 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -18,7 +18,7 @@ val make_hyps : atom_env -> Proof_type.goal Tacmach.sigma -> Term.types list -> - (Names.identifier * Term.types option * Term.types) list -> - (Names.identifier * Proof_search.form) list + (Names.Id.t * Term.types option * Term.types) list -> + (Names.Id.t * Proof_search.form) list val rtauto_tac : Proof_type.tactic diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index 717b19e2c..17ea6f2bf 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml4 @@ -119,19 +119,19 @@ END;;*) (* let closed_term_ast l = - TacFun([Some(id_of_string"t")], + TacFun([Some(Id.of_string"t")], TacAtom(Loc.ghost,TacExtend(Loc.ghost,"closed_term", - [Genarg.in_gen Genarg.wit_constr (mkVar(id_of_string"t")); + [Genarg.in_gen Genarg.wit_constr (mkVar(Id.of_string"t")); Genarg.in_gen (Genarg.wit_list1 Genarg.wit_ref) l]))) *) let closed_term_ast l = let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in - TacFun([Some(id_of_string"t")], + TacFun([Some(Id.of_string"t")], TacAtom(Loc.ghost,TacExtend(Loc.ghost,"closed_term", - [Genarg.in_gen Genarg.globwit_constr (GVar(Loc.ghost,id_of_string"t"),None); + [Genarg.in_gen Genarg.globwit_constr (GVar(Loc.ghost,Id.of_string"t"),None); Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l]))) (* -let _ = add_tacdef false ((Loc.ghost,id_of_string"ring_closed_term" +let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" *) (****************************************************************************) @@ -143,7 +143,7 @@ let ic c = let ty c = Typing.type_of (Global.env()) Evd.empty c let decl_constant na c = - mkConst(declare_constant (id_of_string na) (DefinitionEntry + mkConst(declare_constant (Id.of_string na) (DefinitionEntry { const_entry_body = c; const_entry_secctx = None; const_entry_type = None; @@ -156,17 +156,17 @@ let ltac_call tac (args:glob_tactic_arg list) = (* Calling a locally bound tactic *) let ltac_lcall tac args = - TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, id_of_string tac),args)) + TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args)) let ltac_letin (x, e1) e2 = - TacLetIn(false,[(Loc.ghost,id_of_string x),e1],e2) + TacLetIn(false,[(Loc.ghost,Id.of_string x),e1],e2) let ltac_apply (f:glob_tactic_expr) (args:glob_tactic_arg list) = Tacinterp.eval_tactic (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args)) let ltac_record flds = - TacFun([Some(id_of_string"proj")], ltac_lcall "proj" flds) + TacFun([Some(Id.of_string"proj")], ltac_lcall "proj" flds) let carg c = TacDynamic(Loc.ghost,Pretyping.constr_in c) @@ -178,7 +178,7 @@ let dummy_goal env = Evd.sigma = sigma} let exec_tactic env n f args = - let lid = List.tabulate(fun i -> id_of_string("x"^string_of_int i)) n in + let lid = List.tabulate(fun i -> Id.of_string("x"^string_of_int i)) n in let res = ref [||] in let get_res ist = let l = List.map (fun id -> List.assoc id ist.lfun) lid in @@ -244,11 +244,11 @@ let my_constant c = lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c) let new_ring_path = - make_dirpath (List.map id_of_string ["Ring_tac";plugin_dir;"Coq"]) + make_dirpath (List.map Id.of_string ["Ring_tac";plugin_dir;"Coq"]) let ltac s = lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s)) let znew_ring_path = - make_dirpath (List.map id_of_string ["InitialRing";plugin_dir;"Coq"]) + make_dirpath (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"]) let zltac s = lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s)) @@ -689,8 +689,8 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = let lemma1 = constr_of params.(3) in let lemma2 = constr_of params.(4) in - let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in - let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in + let lemma1 = decl_constant (Id.to_string name^"_ring_lemma1") lemma1 in + let lemma2 = decl_constant (Id.to_string name^"_ring_lemma2") lemma2 in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = @@ -826,7 +826,7 @@ END (***********************************************************************) let new_field_path = - make_dirpath (List.map id_of_string ["Field_tac";plugin_dir;"Coq"]) + make_dirpath (List.map Id.of_string ["Field_tac";plugin_dir;"Coq"]) let field_ltac s = lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s)) @@ -1049,11 +1049,11 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odi match inj with | Some thm -> mkApp(constr_of params.(8),[|thm|]) | None -> constr_of params.(7) in - let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in - let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in - let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in - let lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in - let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in + let lemma1 = decl_constant (Id.to_string name^"_field_lemma1") lemma1 in + let lemma2 = decl_constant (Id.to_string name^"_field_lemma2") lemma2 in + let lemma3 = decl_constant (Id.to_string name^"_field_lemma3") lemma3 in + let lemma4 = decl_constant (Id.to_string name^"_field_lemma4") lemma4 in + let cond_lemma = decl_constant (Id.to_string name^"_lemma5") cond_lemma in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 03fbc7e98..958fdc649 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -16,9 +16,9 @@ open Coqlib exception Non_closed_ascii -let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) -let make_kn dir id = Globnames.encode_mind (make_dir dir) (id_of_string id) -let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id) +let make_dir l = make_dirpath (List.map Id.of_string (List.rev l)) +let make_kn dir id = Globnames.encode_mind (make_dir dir) (Id.of_string id) +let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let ascii_module = ["Coq";"Strings";"Ascii"] diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index 94d4e0713..f86b56bc7 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -14,8 +14,8 @@ open Glob_term (*** Constants for locating int31 / bigN / bigZ / bigQ constructors ***) -let make_dir l = Names.make_dirpath (List.map Names.id_of_string (List.rev l)) -let make_path dir id = Libnames.make_path (make_dir dir) (Names.id_of_string id) +let make_dir l = Names.make_dirpath (List.map Names.Id.of_string (List.rev l)) +let make_path dir id = Libnames.make_path (make_dir dir) (Names.Id.of_string id) let make_mind mp id = Names.make_mind mp Names.empty_dirpath (Names.mk_label id) let make_mind_mpfile dir id = make_mind (Names.MPfile (make_dir dir)) id diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index a40c966fe..f7d0091f3 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -19,14 +19,14 @@ exception Non_closed_number open Glob_term open Bigint -let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) +let make_dir l = make_dirpath (List.map Id.of_string (List.rev l)) let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"] -let make_path dir id = Libnames.make_path dir (id_of_string id) +let make_path dir id = Libnames.make_path dir (Id.of_string id) let r_path = make_path rdefinitions "R" (* TODO: temporary hack *) -let make_path dir id = Globnames.encode_con dir (id_of_string id) +let make_path dir id = Globnames.encode_con dir (Id.of_string id) let r_kn = make_path rdefinitions "R" let glob_R = ConstRef r_kn diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index 8e5a07e0d..9faa6edd1 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -23,15 +23,15 @@ open Glob_term let binnums = ["Coq";"Numbers";"BinNums"] -let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) -let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id) +let make_dir l = make_dirpath (List.map Id.of_string (List.rev l)) +let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let positive_path = make_path binnums "positive" (* TODO: temporary hack *) let make_kn dir id = Globnames.encode_mind dir id -let positive_kn = make_kn (make_dir binnums) (id_of_string "positive") +let positive_kn = make_kn (make_dir binnums) (Id.of_string "positive") let glob_positive = IndRef (positive_kn,0) let path_of_xI = ((positive_kn,0),1) let path_of_xO = ((positive_kn,0),2) @@ -93,7 +93,7 @@ let _ = Notation.declare_numeral_interpreter "positive_scope" (* Parsing N via scopes *) (**********************************************************************) -let n_kn = make_kn (make_dir binnums) (id_of_string "N") +let n_kn = make_kn (make_dir binnums) (Id.of_string "N") let glob_n = IndRef (n_kn,0) let path_of_N0 = ((n_kn,0),1) let path_of_Npos = ((n_kn,0),2) @@ -144,7 +144,7 @@ let _ = Notation.declare_numeral_interpreter "N_scope" (**********************************************************************) let z_path = make_path binnums "Z" -let z_kn = make_kn (make_dir binnums) (id_of_string "Z") +let z_kn = make_kn (make_dir binnums) (Id.of_string "Z") let glob_z = IndRef (z_kn,0) let path_of_ZERO = ((z_kn,0),1) let path_of_POS = ((z_kn,0),2) diff --git a/plugins/xml/acic.ml b/plugins/xml/acic.ml index 653c2b7bd..3e2c8ade7 100644 --- a/plugins/xml/acic.ml +++ b/plugins/xml/acic.ml @@ -34,7 +34,7 @@ type 'constr context_entry = (* is not present in the DTD, but is needed *) (* to use Coq functions during exportation. *) -type 'constr hypothesis = identifier * 'constr context_entry +type 'constr hypothesis = Id.t * 'constr context_entry type context = constr hypothesis list type conjecture = existential_key * context * constr @@ -57,13 +57,13 @@ type obj = inductiveType list * (* inductive types , *) params * int (* parameters,n ind. pars*) and inductiveType = - identifier * bool * constr * (* typename, inductive, arity *) + Id.t * bool * constr * (* typename, inductive, arity *) constructor list (* constructors *) and constructor = - identifier * constr (* id, type *) + Id.t * constr (* id, type *) type aconstr = - | ARel of id * int * id * identifier + | ARel of id * int * id * Id.t | AVar of id * uri | AEvar of id * existential_key * aconstr list | ASort of id * sorts @@ -79,9 +79,9 @@ type aconstr = | AFix of id * int * ainductivefun list | ACoFix of id * int * acoinductivefun list and ainductivefun = - id * identifier * int * aconstr * aconstr + id * Id.t * int * aconstr * aconstr and acoinductivefun = - id * identifier * aconstr * aconstr + id * Id.t * aconstr * aconstr and explicit_named_substitution = id option * (uri * aconstr) list type acontext = (id * aconstr hypothesis) list @@ -102,7 +102,7 @@ type aobj = anninductiveType list * (* inductive types , *) params * int (* parameters,n ind. pars*) and anninductiveType = - id * identifier * bool * aconstr * (* typename, inductive, arity *) + id * Id.t * bool * aconstr * (* typename, inductive, arity *) annconstructor list (* constructors *) and annconstructor = - identifier * aconstr (* id, type *) + Id.t * aconstr (* id, type *) diff --git a/plugins/xml/acic2Xml.ml4 b/plugins/xml/acic2Xml.ml4 index c03b13b5a..34bb1d51f 100644 --- a/plugins/xml/acic2Xml.ml4 +++ b/plugins/xml/acic2Xml.ml4 @@ -37,7 +37,7 @@ let print_term ids_to_inner_sorts = A.ARel (id,n,idref,b) -> let sort = Hashtbl.find ids_to_inner_sorts id in X.xml_empty "REL" - ["value",(string_of_int n) ; "binder",(N.string_of_id b) ; + ["value",(string_of_int n) ; "binder",(N.Id.to_string b) ; "id",id ; "idref",idref; "sort",sort] | A.AVar (id,uri) -> let sort = Hashtbl.find ids_to_inner_sorts id in @@ -71,7 +71,7 @@ let print_term ids_to_inner_sorts = ("id",id)::("type",sort):: match binder with Names.Anonymous -> [] - | Names.Name b -> ["binder",Names.string_of_id b] + | Names.Name b -> ["binder",Names.Id.to_string b] in [< X.xml_nempty "decl" attrs (aux s) ; i >] ) [< >] prods ; @@ -96,7 +96,7 @@ let print_term ids_to_inner_sorts = ("id",id)::("type",sort):: match binder with Names.Anonymous -> [] - | Names.Name b -> ["binder",Names.string_of_id b] + | Names.Name b -> ["binder",Names.Id.to_string b] in [< X.xml_nempty "decl" attrs (aux s) ; i >] ) [< >] lambdas ; @@ -115,7 +115,7 @@ let print_term ids_to_inner_sorts = ("id",id)::("sort",sort):: match binder with Names.Anonymous -> assert false - | Names.Name b -> ["binder",Names.string_of_id b] + | Names.Name b -> ["binder",Names.Id.to_string b] in [< X.xml_nempty "def" attrs (aux s) ; i >] ) [< >] letins ; @@ -161,7 +161,7 @@ let print_term ids_to_inner_sorts = (fun i (id,fi,ai,ti,bi) -> [< i ; X.xml_nempty "FixFunction" - ["id",id ; "name", (Names.string_of_id fi) ; + ["id",id ; "name", (Names.Id.to_string fi) ; "recIndex", (string_of_int ai)] [< X.xml_nempty "type" [] [< aux ti >] ; X.xml_nempty "body" [] [< aux bi >] @@ -177,7 +177,7 @@ let print_term ids_to_inner_sorts = (fun i (id,fi,ti,bi) -> [< i ; X.xml_nempty "CofixFunction" - ["id",id ; "name", Names.string_of_id fi] + ["id",id ; "name", Names.Id.to_string fi] [< X.xml_nempty "type" [] [< aux ti >] ; X.xml_nempty "body" [] [< aux bi >] >] @@ -229,11 +229,11 @@ let print_object uri ids_to_inner_sorts = [< (match t with n,A.Decl t -> X.xml_nempty "Decl" - ["id",hid;"name",Names.string_of_id n] + ["id",hid;"name",Names.Id.to_string n] (print_term ids_to_inner_sorts t) | n,A.Def (t,_) -> X.xml_nempty "Def" - ["id",hid;"name",Names.string_of_id n] + ["id",hid;"name",Names.Id.to_string n] (print_term ids_to_inner_sorts t) ) ; i @@ -315,7 +315,7 @@ let print_object uri ids_to_inner_sorts = (fun i (id,typename,finite,arity,cons) -> [< i ; X.xml_nempty "InductiveType" - ["id",id ; "name",Names.string_of_id typename ; + ["id",id ; "name",Names.Id.to_string typename ; "inductive",(string_of_bool finite) ] [< X.xml_nempty "arity" [] @@ -324,7 +324,7 @@ let print_object uri ids_to_inner_sorts = (fun i (name,lc) -> [< i ; X.xml_nempty "Constructor" - ["name",Names.string_of_id name] + ["name",Names.Id.to_string name] (print_term ids_to_inner_sorts lc) >]) [<>] cons ) diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml index 62f7cc7cf..d817396f1 100644 --- a/plugins/xml/cic2acic.ml +++ b/plugins/xml/cic2acic.ml @@ -62,7 +62,7 @@ let get_uri_of_var v pvars = [] -> Errors.error ("Variable "^v^" not found") | he::tl as modules -> let dirpath = N.make_dirpath modules in - if List.mem (N.id_of_string v) (D.last_section_hyps dirpath) then + if List.mem (N.Id.of_string v) (D.last_section_hyps dirpath) then modules else search_in_open_sections tl @@ -75,7 +75,7 @@ let get_uri_of_var v pvars = in "cic:" ^ List.fold_left - (fun i x -> "/" ^ N.string_of_id x ^ i) "" path + (fun i x -> "/" ^ N.Id.to_string x ^ i) "" path ;; type tag = @@ -120,8 +120,8 @@ let subtract l1 l2 = let token_list_of_path dir id tag = let module N = Names in let token_list_of_dirpath dirpath = - List.rev_map N.string_of_id (N.repr_dirpath dirpath) in - token_list_of_dirpath dir @ [N.string_of_id id ^ "." ^ (ext_of_tag tag)] + List.rev_map N.Id.to_string (N.repr_dirpath dirpath) in + token_list_of_dirpath dir @ [N.Id.to_string id ^ "." ^ (ext_of_tag tag)] let token_list_of_kernel_name tag = let module N = Names in @@ -202,7 +202,7 @@ let typeur sigma metamap = let (_,_,ty) = Environ.lookup_named id env in ty with Not_found -> - Errors.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound")) + Errors.anomaly ("type_of: variable "^(Names.Id.to_string id)^" unbound")) | T.Const c -> let cb = Environ.lookup_constant c env in Typeops.type_of_constant_type env (cb.Declarations.const_type) @@ -455,8 +455,8 @@ print_endline "PASSATO" ; flush stdout ; let he1' = remove_module_dirpath_from_dirpath ~basedir he1_sp in let he1'' = String.concat "/" - (List.map Names.string_of_id (List.rev he1')) ^ "/" - ^ (Names.string_of_id he1_id) ^ ".var" + (List.map Names.Id.to_string (List.rev he1')) ^ "/" + ^ (Names.Id.to_string he1_id) ^ ".var" in (he1'',he2)::subst, extra_args, uninst in @@ -501,13 +501,13 @@ print_endline "PASSATO" ; flush stdout ; A.ARel (fresh_id'', n, List.nth idrefs (n-1), id) | T.Var id -> let pvars = Termops.ids_of_named_context (E.named_context env) in - let pvars = List.map N.string_of_id pvars in - let path = get_uri_of_var (N.string_of_id id) pvars in + let pvars = List.map N.Id.to_string pvars in + let path = get_uri_of_var (N.Id.to_string id) pvars in Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then add_inner_type fresh_id'' ; A.AVar - (fresh_id'', path ^ "/" ^ (N.string_of_id id) ^ ".var") + (fresh_id'', path ^ "/" ^ (N.Id.to_string id) ^ ".var") | T.Evar (n,l) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then @@ -610,7 +610,7 @@ print_endline "PASSATO" ; flush stdout ; | T.LetIn (n,s,t,d) -> let id = match n with - N.Anonymous -> N.id_of_string "_X" + N.Anonymous -> N.Id.of_string "_X" | N.Name id -> id in let n' = @@ -886,7 +886,7 @@ let acic_object_of_cic_object sigma obj = in let dummy_never_used = let s = "dummy_never_used" in - A.ARel (s,99,s,Names.id_of_string s) + A.ARel (s,99,s,Names.Id.of_string s) in final_env,final_idrefs, (hid,(n,A.Def (at,dummy_never_used)))::atl diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml index 8259266af..35760a51d 100644 --- a/plugins/xml/xmlcommand.ml +++ b/plugins/xml/xmlcommand.ml @@ -35,7 +35,7 @@ let filter_params pvars hyps = let ids' = id::ids in let ids'' = "cic:/" ^ - String.concat "/" (List.rev (List.map Names.string_of_id ids')) in + String.concat "/" (List.rev (List.map Names.Id.to_string ids')) in let he' = ids'', List.rev (List.filter (function x -> List.mem x hyps) he) in let tl' = aux ids' tl in @@ -44,7 +44,7 @@ let filter_params pvars hyps = | _,_ -> he'::tl' in let cwd = Lib.cwd () in - let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in + let cwdsp = Libnames.make_path cwd (Names.Id.of_string "dummy") in let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in aux (Names.repr_dirpath modulepath) (List.rev pvars) ;; @@ -55,7 +55,7 @@ let filter_params pvars hyps = let search_variables () = let module N = Names in let cwd = Lib.cwd () in - let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in + let cwdsp = Libnames.make_path cwd (Names.Id.of_string "dummy") in let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in let rec aux = function @@ -63,7 +63,7 @@ let search_variables () = | he::tl as modules -> let one_section_variables = let dirpath = N.make_dirpath (modules @ N.repr_dirpath modulepath) in - let t = List.map N.string_of_id (Decls.last_section_hyps dirpath) in + let t = List.map N.Id.to_string (Decls.last_section_hyps dirpath) in [he,t] in one_section_variables @ aux tl @@ -113,7 +113,7 @@ let theory_filename xml_library_root = match xml_library_root with None -> None (* stdout *) | Some xml_library_root' -> - let toks = List.map N.string_of_id (N.repr_dirpath (Lib.library_dp ())) in + let toks = List.map N.Id.to_string (N.repr_dirpath (Lib.library_dp ())) in (* theory from A/B/C/F.v goes into A/B/C/F.theory *) let alltoks = List.rev toks in Some (join_dirs xml_library_root' alltoks ^ ".theory") @@ -153,7 +153,7 @@ let print_object uri obj sigma filename = let string_list_of_named_context_list = List.map - (function (n,_,_) -> Names.string_of_id n) + (function (n,_,_) -> Names.Id.to_string n) ;; (* Function to collect the variables that occur in a term. *) @@ -212,11 +212,11 @@ let mk_variable_obj id body typ = | Some bo -> find_hyps bo, Some (Unshare.unshare bo) in let hyps' = find_hyps typ @ hyps in - let hyps'' = List.map Names.string_of_id hyps' in + let hyps'' = List.map Names.Id.to_string hyps' in let variables = search_variables () in let params = filter_params variables hyps'' in Acic.Variable - (Names.string_of_id id, unsharedbody, Unshare.unshare typ, params) + (Names.Id.to_string id, unsharedbody, Unshare.unshare typ, params) ;; @@ -226,10 +226,10 @@ let mk_constant_obj id bo ty variables hyps = let params = filter_params variables hyps in match bo with None -> - Acic.Constant (Names.string_of_id id,None,ty,params) + Acic.Constant (Names.Id.to_string id,None,ty,params) | Some c -> Acic.Constant - (Names.string_of_id id, Some (Unshare.unshare (Declarations.force c)), + (Names.Id.to_string id, Some (Unshare.unshare (Declarations.force c)), ty,params) ;; @@ -531,7 +531,7 @@ let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ; let uri_of_dirpath dir = "/" ^ String.concat "/" - (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir))) + (List.map Names.Id.to_string (List.rev (Names.repr_dirpath dir))) ;; let _ = diff --git a/pretyping/cases.ml b/pretyping/cases.ml index c02dbba23..a92e37480 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -73,7 +73,7 @@ let rec list_try_compile f = function list_try_compile f t let force_name = - let nx = Name (id_of_string "x") in function Anonymous -> nx | na -> na + let nx = Name (Id.of_string "x") in function Anonymous -> nx | na -> na (************************************************************************) (* Pattern-matching compilation (Cases) *) @@ -107,8 +107,8 @@ let rec relocate_index n1 n2 k t = match kind_of_term t with type 'a rhs = { rhs_env : env; - rhs_vars : identifier list; - avoid_ids : identifier list; + rhs_vars : Id.t list; + avoid_ids : Id.t list; it : 'a option} type 'a equation = @@ -1807,7 +1807,7 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred = let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in let sigma = !evdref in (* let sigma = Option.cata (fun tycon -> *) - (* let na = Name (id_of_string "x") in *) + (* let na = Name (Id.of_string "x") in *) (* let tms = List.map (fun tm -> Pushed(tm,[],na)) tomatchs in *) (* let predinst = extract_predicate predcclj.uj_val tms in *) (* Coercion.inh_conv_coerce_to loc env !evdref predinst tycon) *) @@ -1830,11 +1830,11 @@ let ($) f x = f x let string_of_name name = match name with | Anonymous -> "anonymous" - | Name n -> string_of_id n + | Name n -> Id.to_string n let make_prime_id name = let str = string_of_name name in - id_of_string str, id_of_string (str ^ "'") + Id.of_string str, Id.of_string (str ^ "'") let prime avoid name = let previd, id = make_prime_id name in @@ -1846,7 +1846,7 @@ let make_prime avoid prevname = previd, id let eq_id avoid id = - let hid = id_of_string ("Heq_" ^ string_of_id id) in + let hid = Id.of_string ("Heq_" ^ Id.to_string id) in let hid' = next_ident_away hid avoid in hid' @@ -1865,7 +1865,7 @@ let constr_of_pat env isevars arsign pat avoid = let name, avoid = match name with Name n -> name, avoid | Anonymous -> - let previd, id = prime avoid (Name (id_of_string "wildcard")) in + let previd, id = prime avoid (Name (Id.of_string "wildcard")) in Name id, id :: avoid in (PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, @@ -1931,7 +1931,7 @@ let constr_of_pat env isevars arsign pat avoid = (* shadows functional version *) let eq_id avoid id = - let hid = id_of_string ("Heq_" ^ string_of_id id) in + let hid = Id.of_string ("Heq_" ^ Id.to_string id) in let hid' = next_ident_away hid !avoid in avoid := hid' :: !avoid; hid' @@ -1960,7 +1960,7 @@ let vars_of_ctx ctx = match na with Anonymous -> raise (Invalid_argument "vars_of_ctx") | Name n -> n, GVar (Loc.ghost, n) :: vars) - ctx (id_of_string "vars_of_ctx_error", []) + ctx (Id.of_string "vars_of_ctx_error", []) in List.rev y let rec is_included x y = @@ -2075,7 +2075,7 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in - let branch_name = id_of_string ("program_branch_" ^ (string_of_int !i)) in + let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in let branch = let bref = GVar (Loc.ghost, branch_name) in @@ -2123,7 +2123,7 @@ let abstract_tomatch env tomatchs tycon = | _ -> let tycon = Option.map (fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in - let name = next_ident_away (id_of_string "filtered_var") names in + let name = next_ident_away (Id.of_string "filtered_var") names in (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, name :: names, tycon) diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 9d0a6c9c3..d1ca69dcd 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -59,16 +59,16 @@ val constr_of_pat : Evd.evar_map ref -> Term.rel_declaration list -> Glob_term.cases_pattern -> - Names.identifier list -> + Names.Id.t list -> Glob_term.cases_pattern * (Term.rel_declaration list * Term.constr * (Term.types * Term.constr list) * Glob_term.cases_pattern) * - Names.identifier list + Names.Id.t list type 'a rhs = { rhs_env : env; - rhs_vars : identifier list; - avoid_ids : identifier list; + rhs_vars : Id.t list; + avoid_ids : Id.t list; it : 'a option} type 'a equation = diff --git a/pretyping/classops.ml b/pretyping/classops.ml index d8cfde590..ebdfcdbe6 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -56,7 +56,7 @@ let coe_info_typ_equal c1 c2 = let cl_typ_eq t1 t2 = match t1, t2 with | CL_SORT, CL_SORT -> true | CL_FUN, CL_FUN -> true -| CL_SECVAR v1, CL_SECVAR v2 -> id_eq v1 v2 +| CL_SECVAR v1, CL_SECVAR v2 -> Id.equal v1 v2 | CL_CONST c1, CL_CONST c2 -> eq_constant c1 c2 | CL_IND i1, CL_IND i2 -> eq_ind i1 i2 | _ -> false @@ -201,11 +201,11 @@ let string_of_class = function | CL_FUN -> "Funclass" | CL_SORT -> "Sortclass" | CL_CONST sp -> - string_of_qualid (shortest_qualid_of_global Idset.empty (ConstRef sp)) + string_of_qualid (shortest_qualid_of_global Id.Set.empty (ConstRef sp)) | CL_IND sp -> - string_of_qualid (shortest_qualid_of_global Idset.empty (IndRef sp)) + string_of_qualid (shortest_qualid_of_global Id.Set.empty (IndRef sp)) | CL_SECVAR sp -> - string_of_qualid (shortest_qualid_of_global Idset.empty (VarRef sp)) + string_of_qualid (shortest_qualid_of_global Id.Set.empty (VarRef sp)) let pr_class x = str (string_of_class x) @@ -444,7 +444,7 @@ let coercion_of_reference r = let ref = Nametab.global r in if not (coercion_exists ref) then errorlabstrm "try_add_coercion" - (Nametab.pr_global_env Idset.empty ref ++ str" is not a coercion."); + (Nametab.pr_global_env Id.Set.empty ref ++ str" is not a coercion."); ref module CoercionPrinting = @@ -452,7 +452,7 @@ module CoercionPrinting = type t = coe_typ let encode = coercion_of_reference let subst = subst_coe_typ - let printer x = pr_global_env Idset.empty x + let printer x = pr_global_env Id.Set.empty x let key = ["Printing";"Coercion"] let title = "Explicitly printed coercions: " let member_message x b = diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 888e4e388..b398a5693 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -70,7 +70,7 @@ let app_opt env evars f t = whd_betaiota !evars (app_opt f t) let pair_of_array a = (a.(0), a.(1)) -let make_name s = Name (id_of_string s) +let make_name s = Name (Id.of_string s) let disc_subset x = match kind_of_term x with @@ -174,7 +174,7 @@ and coerce loc env isevars (x : Term.constr) (y : Term.constr) | Type x, Type y when Univ.Universe.equal x y -> None (* false *) | _ -> subco ()) | Prod (name, a, b), Prod (name', a', b') -> - let name' = Name (Namegen.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in + let name' = Name (Namegen.next_ident_away (Id.of_string "x") (Termops.ids_of_context env)) in let env' = push_rel (name', None, a') env in let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) @@ -435,7 +435,7 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = (* Note: we retype the term because sort-polymorphism may have *) (* weaken its type *) let name = match name with - | Anonymous -> Name (id_of_string "x") + | Anonymous -> Name (Id.of_string "x") | _ -> name in let env1 = push_rel (name,None,u1) env in let (evd', v1) = diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index a96deca06..af8cc43c1 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -74,7 +74,7 @@ module PrintingInductiveMake = let kn' = subst_ind subst kn in if kn' == kn then obj else kn', ints - let printer ind = pr_global_env Idset.empty (IndRef ind) + let printer ind = pr_global_env Id.Set.empty (IndRef ind) let key = ["Printing";Test.field] let title = Test.title let member_message x = Test.member_message (printer x) @@ -175,11 +175,11 @@ let lookup_name_as_displayed env t s = let rec lookup avoid n c = match kind_of_term c with | Prod (name,_,c') -> (match compute_displayed_name_in RenamingForGoal avoid name c' with - | (Name id,avoid') -> if id_eq id s then Some n else lookup avoid' (n+1) c' + | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | LetIn (name,_,_,c') -> (match compute_displayed_name_in RenamingForGoal avoid name c' with - | (Name id,avoid') -> if id_eq id s then Some n else lookup avoid' (n+1) c' + | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | Cast (c,_,_) -> lookup avoid n c | _ -> None @@ -231,7 +231,7 @@ let rec decomp_branch n nal b (avoid,env as e) c = | Lambda (na,_,c) -> na,c,compute_displayed_let_name_in | LetIn (na,_,_,c) -> na,c,compute_displayed_name_in | _ -> - Name (id_of_string "x"),(applist (lift 1 c, [mkRel 1])), + Name (Id.of_string "x"),(applist (lift 1 c, [mkRel 1])), compute_displayed_name_in in let na',avoid' = f flag avoid na c in decomp_branch (n-1) (na'::nal) b (avoid',add_name na' env) c @@ -293,7 +293,7 @@ let it_destRLambda_or_LetIn_names n c = | _ -> (* eta-expansion *) let next l = - let x = next_ident_away (id_of_string "x") l in + let x = next_ident_away (Id.of_string "x") l in (* Not efficient but unusual and no function to get free glob_vars *) (* if occur_glob_constr x c then next (x::l) else x in *) x @@ -386,7 +386,7 @@ let rec detype (isgoal:bool) avoid env t = | Anonymous -> !detype_anonymous dl n with Not_found -> let s = "_UNBOUND_REL_"^(string_of_int n) - in GVar (dl, id_of_string s)) + in GVar (dl, Id.of_string s)) | Meta n -> (* Meta in constr are not user-parsable and are mapped to Evar *) GEvar (dl, n, None) diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 6c1e1265f..1e31e04d4 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -29,23 +29,23 @@ val subst_glob_constr : substitution -> glob_constr -> glob_constr [isgoal] tells if naming must avoid global-level synonyms as intro does [ctx] gives the names of the free variables *) -val detype : bool -> identifier list -> names_context -> constr -> glob_constr +val detype : bool -> Id.t list -> names_context -> constr -> glob_constr val detype_case : bool -> ('a -> glob_constr) -> (constructor array -> int array -> 'a array -> - (Loc.t * identifier list * cases_pattern list * glob_constr) list) -> + (Loc.t * Id.t list * cases_pattern list * glob_constr) list) -> ('a -> int -> bool) -> - identifier list -> inductive * case_style * int array * int -> + Id.t list -> inductive * case_style * int array * int -> 'a option -> 'a -> 'a array -> glob_constr val detype_sort : sorts -> glob_sort -val detype_rel_context : constr option -> identifier list -> names_context -> +val detype_rel_context : constr option -> Id.t list -> names_context -> rel_context -> glob_decl list (** look for the index of a named var or a nondep var as it is renamed *) -val lookup_name_as_displayed : env -> constr -> identifier -> int option +val lookup_name_as_displayed : env -> constr -> Id.t -> int option val lookup_index_as_renamed : env -> constr -> int -> int option val set_detype_anonymous : (Loc.t -> int -> glob_constr) -> unit diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 3cf0c50ba..d9f857c4e 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -595,8 +595,8 @@ let filter_possible_projections c ty ctxt args = (* interested in finding a term u convertible to c such that a occurs *) (* in u *) isRel a && Int.Set.mem (destRel a) fv1 || - isVar a && Idset.mem (destVar a) fv2 || - Idset.mem id tyvars) + isVar a && Id.Set.mem (destVar a) fv2 || + Id.Set.mem id tyvars) ctxt args let solve_evars = ref (fun _ -> failwith "solve_evars not installed") diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index b82f18da7..b6e8f9d13 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -440,12 +440,12 @@ let compute_var_aliases sign = (match kind_of_term t with | Var id' -> let aliases_of_id = - try Idmap.find id' aliases with Not_found -> [] in - Idmap.add id (aliases_of_id@[t]) aliases + try Id.Map.find id' aliases with Not_found -> [] in + Id.Map.add id (aliases_of_id@[t]) aliases | _ -> - Idmap.add id [t] aliases) + Id.Map.add id [t] aliases) | None -> aliases) - sign Idmap.empty + sign Id.Map.empty let compute_rel_aliases var_aliases rels = snd (List.fold_right (fun (_,b,t) (n,aliases) -> @@ -455,7 +455,7 @@ let compute_rel_aliases var_aliases rels = (match kind_of_term t with | Var id' -> let aliases_of_n = - try Idmap.find id' var_aliases with Not_found -> [] in + try Id.Map.find id' var_aliases with Not_found -> [] in Int.Map.add n (aliases_of_n@[t]) aliases | Rel p -> let aliases_of_n = @@ -480,7 +480,7 @@ let lift_aliases n (var_aliases,rel_aliases as aliases) = let get_alias_chain_of aliases x = match kind_of_term x with | Rel n -> (try Int.Map.find n (snd aliases) with Not_found -> []) - | Var id -> (try Idmap.find id (fst aliases) with Not_found -> []) + | Var id -> (try Id.Map.find id (fst aliases) with Not_found -> []) | _ -> [] let normalize_alias_opt aliases x = @@ -508,7 +508,7 @@ let extend_alias (_,b,_) (var_aliases,rel_aliases) = (match kind_of_term t with | Var id' -> let aliases_of_binder = - try Idmap.find id' var_aliases with Not_found -> [] in + try Id.Map.find id' var_aliases with Not_found -> [] in Int.Map.add 1 (aliases_of_binder@[t]) rel_aliases | Rel p -> let aliases_of_binder = @@ -545,15 +545,15 @@ let rec expand_vars_in_term_using aliases t = match kind_of_term t with let expand_vars_in_term env = expand_vars_in_term_using (make_alias_map env) let free_vars_and_rels_up_alias_expansion aliases c = - let acc1 = ref Int.Set.empty and acc2 = ref Idset.empty in - let cache_rel = ref Int.Set.empty and cache_var = ref Idset.empty in + let acc1 = ref Int.Set.empty and acc2 = ref Id.Set.empty in + let cache_rel = ref Int.Set.empty and cache_var = ref Id.Set.empty in let is_in_cache depth = function | Rel n -> Int.Set.mem (n-depth) !cache_rel - | Var s -> Idset.mem s !cache_var + | Var s -> Id.Set.mem s !cache_var | _ -> false in let put_in_cache depth = function | Rel n -> cache_rel := Int.Set.add (n-depth) !cache_rel - | Var s -> cache_var := Idset.add s !cache_var + | Var s -> cache_var := Id.Set.add s !cache_var | _ -> () in let rec frec (aliases,depth) c = match kind_of_term c with @@ -562,11 +562,11 @@ let free_vars_and_rels_up_alias_expansion aliases c = put_in_cache depth ck; let c = expansion_of_var aliases c in match kind_of_term c with - | Var id -> acc2 := Idset.add id !acc2 + | Var id -> acc2 := Id.Set.add id !acc2 | Rel n -> if n >= depth+1 then acc1 := Int.Set.add (n-depth) !acc1 | _ -> frec (aliases,depth) c end | Const _ | Ind _ | Construct _ -> - acc2 := List.fold_right Idset.add (vars_of_global (Global.env()) c) !acc2 + acc2 := List.fold_right Id.Set.add (vars_of_global (Global.env()) c) !acc2 | _ -> iter_constr_with_full_binders (fun d (aliases,depth) -> (extend_alias d aliases,depth+1)) @@ -580,10 +580,10 @@ let free_vars_and_rels_up_alias_expansion aliases c = (************************************) type clear_dependency_error = -| OccurHypInSimpleClause of identifier option +| OccurHypInSimpleClause of Id.t option | EvarTypingBreak of existential -exception ClearDependencyError of identifier * clear_dependency_error +exception ClearDependencyError of Id.t * clear_dependency_error open Store.Field @@ -624,7 +624,7 @@ let rec check_and_clear_in_constr evdref err ids c = (* Check if some id to clear occurs in the instance a of rid in ev and remember the dependency *) match - List.filter (fun id -> List.mem id ids) (Idset.elements (collect_vars a)) + List.filter (fun id -> List.mem id ids) (Id.Set.elements (collect_vars a)) with | id :: _ -> (hy,ar,(rid,id)::ri) | _ -> @@ -680,7 +680,7 @@ let clear_hyps_in_evi evdref hyps concl ids = match !vk with | VKnone -> vk | VKvalue (v,d) -> - if (List.for_all (fun e -> not (Idset.mem e d)) ids) then + if (List.for_all (fun e -> not (Id.Set.mem e d)) ids) then (* v does depend on any of ids, it's ok *) vk else @@ -728,7 +728,7 @@ let get_actual_deps aliases l t = let (fv_rels,fv_ids) = free_vars_and_rels_up_alias_expansion aliases t in List.filter (fun c -> match kind_of_term c with - | Var id -> Idset.mem id fv_ids + | Var id -> Id.Set.mem id fv_ids | Rel n -> Int.Set.mem n fv_rels | _ -> assert false) l @@ -838,23 +838,23 @@ let make_projectable_subst aliases sigma evi args = let l = try Constrmap.find cstr cstrs with Not_found -> [] in Constrmap.add cstr ((args,id)::l) cstrs | _ -> cstrs in - (rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs) + (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs) | Some c, a::rest -> let a = whd_evar sigma a in (match kind_of_term c with | Var id' -> let idc = normalize_alias_var evar_aliases id' in - let sub = try Idmap.find idc all with Not_found -> [] in + let sub = try Id.Map.find idc all with Not_found -> [] in if List.exists (fun (c,_,_) -> eq_constr a c) sub then (rest,all,cstrs) else (rest, - Idmap.add idc ((a,normalize_alias_opt aliases a,id)::sub) all, + Id.Map.add idc ((a,normalize_alias_opt aliases a,id)::sub) all, cstrs) | _ -> - (rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs)) + (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs)) | _ -> anomaly "Instance does not match its signature") - sign (Array.rev_to_list args,Idmap.empty,Constrmap.empty) in + sign (Array.rev_to_list args,Id.Map.empty,Constrmap.empty) in (full_subst,cstr_subst) let make_pure_subst evi args = @@ -993,10 +993,10 @@ let find_projectable_constructor env evd cstr k args cstr_subst = type evar_projection = | ProjectVar -| ProjectEvar of existential * evar_info * identifier * evar_projection +| ProjectEvar of existential * evar_info * Id.t * evar_projection exception NotUnique -exception NotUniqueInType of (identifier * evar_projection) list +exception NotUniqueInType of (Id.t * evar_projection) list let rec assoc_up_to_alias sigma aliases y yc = function | [] -> raise Not_found @@ -1039,7 +1039,7 @@ let rec find_projectable_vars with_evars aliases sigma y subst = | _ -> anomaly "More than one non var in aliases class of evar instance" else subst' in - Idmap.fold is_projectable subst [] + Id.Map.fold is_projectable subst [] (* [filter_solution] checks if one and only one possible projection exists * among a set of solutions to a projection problem *) @@ -1199,13 +1199,13 @@ let filter_candidates evd evk filter candidates = | Some l, Some filter -> let ids = List.map pi1 (List.filter_with filter (evar_context evi)) in Some (List.filter (fun a -> - List.subset (Idset.elements (collect_vars a)) ids) l) + List.subset (Id.Set.elements (collect_vars a)) ids) l) let closure_of_filter evd evk filter = let evi = Evd.find_undefined evd evk in let vars = collect_vars (evar_concl evi) in let ids = List.map pi1 (evar_context evi) in - let test id b = b || Idset.mem id vars in + let test id b = b || Id.Set.mem id vars in let newfilter = List.map2 test ids filter in if eq_filter newfilter (evar_filter evi) then None else Some newfilter @@ -1372,7 +1372,7 @@ let rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t = | Ind _ -> Array.for_all (is_constrainable_in k g) args | Prod (_,t1,t2) -> is_constrainable_in k g t1 && is_constrainable_in k g t2 | Evar (ev',_) -> not (Int.equal ev' ev) (*If ev' needed, one may also try to restrict it*) - | Var id -> Idset.mem id fv_ids + | Var id -> Id.Set.mem id fv_ids | Rel n -> n <= k || Int.Set.mem n fv_rels | Sort _ -> true | _ -> (* We don't try to be more clever *) true @@ -1380,7 +1380,7 @@ let rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t = let has_constrainable_free_vars evd aliases k ev (fv_rels,fv_ids as fvs) t = let t = expansion_of_var aliases t in match kind_of_term t with - | Var id -> Idset.mem id fv_ids + | Var id -> Id.Set.mem id fv_ids | Rel n -> n <= k || Int.Set.mem n fv_rels | _ -> is_constrainable_in k (ev,fvs) t @@ -1536,7 +1536,7 @@ let solve_candidates conv_algo env evd (evk,argsv as ev) rhs = *) exception NotInvertibleUsingOurAlgorithm of constr -exception NotEnoughInformationToProgress of (identifier * evar_projection) list +exception NotEnoughInformationToProgress of (Id.t * evar_projection) list exception OccurCheckIn of evar_map * constr let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs = @@ -1954,7 +1954,7 @@ let empty_valcon = None (* Builds a value constraint *) let mk_valcon c = Some c -let idx = id_of_string "x" +let idx = Id.of_string "x" (* Refining an evar to a product *) diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index fb53654de..b056cd260 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -51,7 +51,7 @@ val new_type_evar : val new_evar_instance : named_context_val -> evar_map -> types -> ?src:Loc.t * Evar_kinds.t -> ?filter:bool list -> ?candidates:constr list -> constr list -> evar_map * constr -val make_pure_subst : evar_info -> constr array -> (identifier * constr) list +val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list (** {6 Instantiate evars} *) @@ -201,17 +201,17 @@ val pr_tycon : env -> type_constraint -> Pp.std_ppcmds raise OccurHypInSimpleClause if the removal breaks dependencies *) type clear_dependency_error = -| OccurHypInSimpleClause of identifier option +| OccurHypInSimpleClause of Id.t option | EvarTypingBreak of existential -exception ClearDependencyError of identifier * clear_dependency_error +exception ClearDependencyError of Id.t * clear_dependency_error (* spiwack: marks an evar that has been "defined" by clear. used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*) val cleared : bool Store.Field.t val clear_hyps_in_evi : evar_map ref -> named_context_val -> types -> - identifier list -> named_context_val * types + Id.t list -> named_context_val * types val push_rel_context_to_named_context : Environ.env -> types -> named_context_val * types * constr list * constr list diff --git a/pretyping/evd.mli b/pretyping/evd.mli index a4e314873..a73dbdcdc 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -217,7 +217,7 @@ val meta_opt_fvalue : evar_map -> metavariable -> (constr freelisted * instance_ val meta_type : evar_map -> metavariable -> types val meta_ftype : evar_map -> metavariable -> types freelisted val meta_name : evar_map -> metavariable -> name -val meta_with_name : evar_map -> identifier -> metavariable +val meta_with_name : evar_map -> Id.t -> metavariable val meta_declare : metavariable -> types -> ?name:name -> evar_map -> evar_map val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 8bd8dc217..65c21f1be 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -117,11 +117,11 @@ let iter_glob_constr f = fold_glob_constr (fun () -> f) () let same_id na id = match na with | Anonymous -> false -| Name id' -> id_eq id id' +| Name id' -> Id.equal id id' let occur_glob_constr id = let rec occur = function - | GVar (loc,id') -> id_eq id id' + | GVar (loc,id') -> Id.equal id id' | GApp (loc,f,args) -> (occur f) or (List.exists occur args) | GLambda (loc,na,bk,ty,c) -> (occur ty) || (not (same_id na id) && (occur c)) @@ -141,13 +141,13 @@ let occur_glob_constr id = | GRec (loc,fk,idl,bl,tyl,bv) -> not (Array.for_all4 (fun fid bl ty bd -> let rec occur_fix = function - [] -> not (occur ty) && (id_eq fid id || not(occur bd)) + [] -> not (occur ty) && (Id.equal fid id || not(occur bd)) | (na,k,bbd,bty)::bl -> not (occur bty) && (match bbd with Some bd -> not (occur bd) | _ -> true) && - (match na with Name id' -> id_eq id id' | _ -> not (occur_fix bl)) in + (match na with Name id' -> Id.equal id id' | _ -> not (occur_fix bl)) in occur_fix bl) idl bl tyl bv) | GCast (loc,c,k) -> (occur c) or (match k with CastConv t | CastVM t -> occur t | CastCoerce -> false) @@ -165,11 +165,11 @@ let occur_glob_constr id = let add_name_to_ids set na = match na with | Anonymous -> set - | Name id -> Idset.add id set + | Name id -> Id.Set.add id set let free_glob_vars = let rec vars bounded vs = function - | GVar (loc,id') -> if Idset.mem id' bounded then vs else Idset.add id' vs + | GVar (loc,id') -> if Id.Set.mem id' bounded then vs else Id.Set.add id' vs | GApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args) | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (loc,na,ty,c) -> let vs' = vars bounded vs ty in @@ -190,7 +190,7 @@ let free_glob_vars = let vs3 = vars bounded vs2 b1 in vars bounded vs3 b2 | GRec (loc,fk,idl,bl,tyl,bv) -> - let bounded' = Array.fold_right Idset.add idl bounded in + let bounded' = Array.fold_right Id.Set.add idl bounded in let vars_fix i vs fid = let vs1,bounded1 = List.fold_left @@ -212,7 +212,7 @@ let free_glob_vars = | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> vs and vars_pattern bounded vs (loc,idl,p,c) = - let bounded' = List.fold_right Idset.add idl bounded in + let bounded' = List.fold_right Id.Set.add idl bounded in vars bounded' vs c and vars_option bounded vs = function None -> vs | Some p -> vars bounded vs p @@ -222,8 +222,8 @@ let free_glob_vars = vars_option bounded' vs tyopt in fun rt -> - let vs = vars Idset.empty Idset.empty rt in - Idset.elements vs + let vs = vars Id.Set.empty Id.Set.empty rt in + Id.Set.elements vs let loc_of_glob_constr = function diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index ed2d0ae2d..2e8908cfb 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -38,8 +38,8 @@ val map_glob_constr_left_to_right : val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit -val occur_glob_constr : identifier -> glob_constr -> bool -val free_glob_vars : glob_constr -> identifier list +val occur_glob_constr : Id.t -> glob_constr -> bool +val free_glob_vars : glob_constr -> Id.t list val loc_of_glob_constr : glob_constr -> Loc.t (** Conversion from glob_constr to cases pattern, if possible diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 257ad448a..e42013b33 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -36,7 +36,7 @@ type recursion_scheme_error = exception RecursionSchemeError of recursion_scheme_error let make_prod_dep dep env = if dep then mkProd_name env else mkProd -let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c) +let mkLambda_string s t c = mkLambda (Name (Id.of_string s), t, c) (*******************************************) (* Building curryfied elimination *) @@ -380,7 +380,7 @@ let mis_make_indrec env sigma listdepkind mib = let fixn = Array.of_list (List.rev ln) in let fixtyi = Array.of_list (List.rev ltyp) in let fixdef = Array.of_list (List.rev ldef) in - let names = Array.create nrec (Name(id_of_string "F")) in + let names = Array.create nrec (Name(Id.of_string "F")) in mkFix ((fixn,p),(names,fixtyi,fixdef)) in mrec 0 [] [] [] @@ -570,6 +570,6 @@ let lookup_eliminator ind_sp s = errorlabstrm "default_elim" (strbrk "Cannot find the elimination combinator " ++ pr_id id ++ strbrk ", the elimination of the inductive definition " ++ - pr_global_env Idset.empty (IndRef ind_sp) ++ + pr_global_env Id.Set.empty (IndRef ind_sp) ++ strbrk " on sort " ++ Termops.pr_sort_family s ++ strbrk " is probably not allowed.") diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index 1bf5fd90c..610a7bf39 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -63,6 +63,6 @@ val weaken_sort_scheme : sorts -> int -> constr -> types -> constr * types val lookup_eliminator : inductive -> sorts_family -> constr val elimination_suffix : sorts_family -> string -val make_elimination_ident : identifier -> sorts_family -> identifier +val make_elimination_ident : Id.t -> sorts_family -> Id.t val case_suffix : string diff --git a/pretyping/locusops.mli b/pretyping/locusops.mli index bd4df6edd..ddf615033 100644 --- a/pretyping/locusops.mli +++ b/pretyping/locusops.mli @@ -34,5 +34,5 @@ val is_nowhere : 'a clause_expr -> bool (** Clause conversion functions, parametrized by a hyp enumeration function *) -val simple_clause_of : (unit -> identifier list) -> clause -> simple_clause -val concrete_clause_of : (unit -> identifier list) -> clause -> concrete_clause +val simple_clause_of : (unit -> Id.t list) -> clause -> simple_clause +val concrete_clause_of : (unit -> Id.t list) -> clause -> concrete_clause diff --git a/pretyping/matching.ml b/pretyping/matching.ml index 9f4badd22..dfc52295d 100644 --- a/pretyping/matching.ml +++ b/pretyping/matching.ml @@ -43,14 +43,14 @@ open Misctypes *) -type bound_ident_map = (identifier * identifier) list +type bound_ident_map = (Id.t * Id.t) list exception PatternMatchingFailure let constrain n (ids, m as x) (names, terms as subst) = try let (ids',m') = List.assoc n terms in - if List.equal id_eq ids ids' && eq_constr m m' then subst + if List.equal Id.equal ids ids' && eq_constr m m' then subst else raise PatternMatchingFailure with Not_found -> @@ -89,7 +89,7 @@ let build_lambda toabstract stk (m : constr) = let rec list_insert a = function | [] -> [a] | b :: l -> - let ord = id_ord a b in + let ord = Id.compare a b in if ord < 0 then a :: b :: l else if ord > 0 then b :: list_insert a l else raise PatternMatchingFailure @@ -162,9 +162,9 @@ let matches_core convert allow_partial_app allow_bound_rels pat c = | PMeta None, m -> subst - | PRef (VarRef v1), Var v2 when id_eq v1 v2 -> subst + | PRef (VarRef v1), Var v2 when Id.equal v1 v2 -> subst - | PVar v1, Var v2 when id_eq v1 v2 -> subst + | PVar v1, Var v2 when Id.equal v1 v2 -> subst | PRef ref, _ when conv (constr_of_global ref) cT -> subst @@ -249,7 +249,7 @@ let matches_core convert allow_partial_app allow_bound_rels pat c = in let names,terms = sorec [] ([],[]) pat c in - (names, List.sort (fun (a, _) (b, _) -> id_ord a b) terms) + (names, List.sort (fun (a, _) (b, _) -> Id.compare a b) terms) let matches_core_closed convert allow_partial_app pat c = let names,subst = matches_core convert allow_partial_app false pat c in diff --git a/pretyping/matching.mli b/pretyping/matching.mli index 273c4d061..05e01e2e2 100644 --- a/pretyping/matching.mli +++ b/pretyping/matching.mli @@ -25,7 +25,7 @@ val special_meta : metavariable (** [bound_ident_map] represents the result of matching binding identifiers of the pattern with the binding identifiers of the term matched *) -type bound_ident_map = (identifier * identifier) list +type bound_ident_map = (Id.t * Id.t) list (** [matches pat c] matches [c] against [pat] and returns the resulting assignment of metavariables; it raises [PatternMatchingFailure] if diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml index c7f51d17b..5e725979b 100644 --- a/pretyping/namegen.ml +++ b/pretyping/namegen.ml @@ -63,7 +63,7 @@ let is_constructor id = (* Generating "intuitive" names from its type *) let lowercase_first_char id = (* First character of a constr *) - Unicode.lowercase_first_char (string_of_id id) + Unicode.lowercase_first_char (Id.to_string id) let sort_hdchar = function | Prop(_) -> "P" @@ -100,11 +100,11 @@ let hdchar env c = hdrec 0 c let id_of_name_using_hdchar env a = function - | Anonymous -> id_of_string (hdchar env a) + | Anonymous -> Id.of_string (hdchar env a) | Name id -> id let named_hd env a = function - | Anonymous -> Name (id_of_string (hdchar env a)) + | Anonymous -> Name (Id.of_string (hdchar env a)) | x -> x let mkProd_name env (n,a,b) = mkProd (named_hd env a n, a, b) @@ -139,7 +139,7 @@ let it_mkLambda_or_LetIn_name env b hyps = (**********************************************************************) (* Fresh names *) -let default_x = id_of_string "x" +let default_x = Id.of_string "x" (* Looks for next "good" name by lifting subscript *) @@ -179,7 +179,7 @@ let next_ident_away_in_goal id avoid = next_ident_away_from id bad let next_name_away_in_goal na avoid = - let id = match na with Name id -> id | Anonymous -> id_of_string "H" in + let id = match na with Name id -> id | Anonymous -> Id.of_string "H" in next_ident_away_in_goal id avoid (* 3- Looks for next fresh name outside a list that is moreover valid @@ -203,7 +203,7 @@ let next_ident_away id avoid = else id let next_name_away_with_default default na avoid = - let id = match na with Name id -> id | Anonymous -> id_of_string default in + let id = match na with Name id -> id | Anonymous -> Id.of_string default in next_ident_away id avoid let reserved_type_name = ref (fun t -> Anonymous) @@ -214,7 +214,7 @@ let next_name_away_with_default_using_types default na avoid t = | Name id -> id | Anonymous -> match !reserved_type_name t with | Name id -> id - | Anonymous -> id_of_string default in + | Anonymous -> Id.of_string default in next_ident_away id avoid let next_name_away = next_name_away_with_default "H" @@ -237,7 +237,7 @@ let occur_rel p env id = try let name = lookup_name_of_rel p env in begin match name with - | Name id' -> id_eq id' id + | Name id' -> Id.equal id' id | Anonymous -> false end with Not_found -> false (* Unbound indice : may happen in debug *) @@ -246,7 +246,7 @@ let visibly_occur_id id (nenv,c) = let rec occur n c = match kind_of_term c with | Const _ | Ind _ | Construct _ | Var _ when - let short = shortest_qualid_of_global Idset.empty (global_of_constr c) in + let short = shortest_qualid_of_global Id.Set.empty (global_of_constr c) in qualid_eq short (qualid_of_ident id) -> raise Occur | Rel p when p>n & occur_rel (p-n) nenv id -> raise Occur @@ -267,7 +267,7 @@ let next_name_away_for_default_printing env_t na avoid = (* In principle, an anonymous name is not dependent and will not be *) (* taken into account by the function compute_displayed_name_in; *) (* just in case, invent a valid name *) - id_of_string "H" in + Id.of_string "H" in next_ident_away_for_default_printing env_t id avoid (**********************************************************************) diff --git a/pretyping/namegen.mli b/pretyping/namegen.mli index e23c6dad8..6702c9f70 100644 --- a/pretyping/namegen.mli +++ b/pretyping/namegen.mli @@ -13,10 +13,10 @@ open Environ (********************************************************************* Generating "intuitive" names from their type *) -val lowercase_first_char : identifier -> string +val lowercase_first_char : Id.t -> string val sort_hdchar : sorts -> string val hdchar : env -> types -> string -val id_of_name_using_hdchar : env -> types -> name -> identifier +val id_of_name_using_hdchar : env -> types -> name -> Id.t val named_hd : env -> types -> name -> name val mkProd_name : env -> name * types * types -> types @@ -40,27 +40,27 @@ val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr Fresh names *) (** Avoid clashing with a name satisfying some predicate *) -val next_ident_away_from : identifier -> (identifier -> bool) -> identifier +val next_ident_away_from : Id.t -> (Id.t -> bool) -> Id.t (** Avoid clashing with a name of the given list *) -val next_ident_away : identifier -> identifier list -> identifier +val next_ident_away : Id.t -> Id.t list -> Id.t (** Avoid clashing with a name already used in current module *) -val next_ident_away_in_goal : identifier -> identifier list -> identifier +val next_ident_away_in_goal : Id.t -> Id.t list -> Id.t (** Avoid clashing with a name already used in current module but tolerate overwriting section variables, as in goals *) -val next_global_ident_away : identifier -> identifier list -> identifier +val next_global_ident_away : Id.t -> Id.t list -> Id.t (** Avoid clashing with a constructor name already used in current module *) -val next_name_away_in_cases_pattern : name -> identifier list -> identifier +val next_name_away_in_cases_pattern : name -> Id.t list -> Id.t -val next_name_away : name -> identifier list -> identifier (** default is "H" *) -val next_name_away_with_default : string -> name -> identifier list -> - identifier +val next_name_away : name -> Id.t list -> Id.t (** default is "H" *) +val next_name_away_with_default : string -> name -> Id.t list -> + Id.t val next_name_away_with_default_using_types : string -> name -> - identifier list -> types -> identifier + Id.t list -> types -> Id.t val set_reserved_typed_name : (types -> name) -> unit @@ -75,10 +75,10 @@ type renaming_flags = val make_all_name_different : env -> env val compute_displayed_name_in : - renaming_flags -> identifier list -> name -> constr -> name * identifier list + renaming_flags -> Id.t list -> name -> constr -> name * Id.t list val compute_and_force_displayed_name_in : - renaming_flags -> identifier list -> name -> constr -> name * identifier list + renaming_flags -> Id.t list -> name -> constr -> name * Id.t list val compute_displayed_let_name_in : - renaming_flags -> identifier list -> name -> constr -> name * identifier list + renaming_flags -> Id.t list -> name -> constr -> name * Id.t list val rename_bound_vars_as_displayed : - identifier list -> name list -> types -> types + Id.t list -> name list -> types -> types diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index c7819e134..d784fc0ed 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -29,7 +29,7 @@ let case_info_pattern_eq i1 i2 = let rec constr_pattern_eq p1 p2 = match p1, p2 with | PRef r1, PRef r2 -> eq_gr r1 r2 -| PVar v1, PVar v2 -> id_eq v1 v2 +| PVar v1, PVar v2 -> Id.equal v1 v2 | PEvar (ev1, ctx1), PEvar (ev2, ctx2) -> Int.equal ev1 ev2 && Array.equal constr_pattern_eq ctx1 ctx2 | PRel i1, PRel i2 -> @@ -37,7 +37,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with | PApp (t1, arg1), PApp (t2, arg2) -> constr_pattern_eq t1 t2 && Array.equal constr_pattern_eq arg1 arg2 | PSoApp (id1, arg1), PSoApp (id2, arg2) -> - id_eq id1 id2 && List.equal constr_pattern_eq arg1 arg2 + Id.equal id1 id2 && List.equal constr_pattern_eq arg1 arg2 | PLambda (v1, t1, b1), PLambda (v2, t2, b2) -> name_eq v1 v2 && constr_pattern_eq t1 t2 && constr_pattern_eq b1 b2 | PProd (v1, t1, b1), PProd (v2, t2, b2) -> @@ -45,7 +45,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with | PLetIn (v1, t1, b1), PLetIn (v2, t2, b2) -> name_eq v1 v2 && constr_pattern_eq t1 t2 && constr_pattern_eq b1 b2 | PSort s1, PSort s2 -> glob_sort_eq s1 s2 -| PMeta m1, PMeta m2 -> Option.equal id_eq m1 m2 +| PMeta m1, PMeta m2 -> Option.equal Id.equal m1 m2 | PIf (t1, l1, r1), PIf (t2, l2, r2) -> constr_pattern_eq t1 t2 && constr_pattern_eq l1 l2 && constr_pattern_eq r1 r2 | PCase (info1, p1, r1, l1), PCase (info2, p2, r2, l2) -> @@ -122,7 +122,7 @@ let pattern_of_constr sigma t = let rec pattern_of_constr t = match kind_of_term t with | Rel n -> PRel n - | Meta n -> PMeta (Some (id_of_string ("META" ^ string_of_int n))) + | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n))) | Var id -> PVar id | Sort (Prop Null) -> PSort GProp | Sort (Prop Pos) -> PSort GSet diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index b20510b86..8148fe25d 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -53,7 +53,7 @@ val pattern_of_glob_constr : glob_constr -> patvar list * constr_pattern val instantiate_pattern : - Evd.evar_map -> (identifier * (identifier list * constr)) list -> + Evd.evar_map -> (Id.t * (Id.t list * constr)) list -> constr_pattern -> constr_pattern val lift_pattern : int -> constr_pattern -> constr_pattern diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 0cd5743cd..cced783f5 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -26,13 +26,13 @@ type pretype_error = | CannotUnifyLocal of constr * constr * constr | CannotUnifyBindingType of constr * constr | CannotGeneralize of constr - | NoOccurrenceFound of constr * identifier option + | NoOccurrenceFound of constr * Id.t option | CannotFindWellTypedAbstraction of constr * constr list | WrongAbstractionType of name * constr * types * types | AbstractionOverMeta of name * name | NonLinearUnification of name * constr (* Pretyping *) - | VarNotFound of identifier + | VarNotFound of Id.t | UnexpectedType of constr * constr | NotProduct of constr | TypingError of type_error diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index e2e66e80f..aa0b65e4f 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -28,13 +28,13 @@ type pretype_error = | CannotUnifyLocal of constr * constr * constr | CannotUnifyBindingType of constr * constr | CannotGeneralize of constr - | NoOccurrenceFound of constr * identifier option + | NoOccurrenceFound of constr * Id.t option | CannotFindWellTypedAbstraction of constr * constr list | WrongAbstractionType of name * constr * types * types | AbstractionOverMeta of name * name | NonLinearUnification of name * constr (** Pretyping *) - | VarNotFound of identifier + | VarNotFound of Id.t | UnexpectedType of constr * constr | NotProduct of constr | TypingError of Type_errors.type_error @@ -131,4 +131,4 @@ val error_not_product_loc : (** {6 Error in conversion from AST to glob_constr } *) -val error_var_not_found_loc : Loc.t -> identifier -> 'b +val error_var_not_found_loc : Loc.t -> Id.t -> 'b diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 674c7e19e..358d53e48 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -44,8 +44,8 @@ open Pattern open Misctypes type typing_constraint = OfType of types option | IsType -type var_map = (identifier * constr_under_binders) list -type unbound_ltac_var_map = (identifier * identifier option) list +type var_map = (Id.t * constr_under_binders) list +type unbound_ltac_var_map = (Id.t * Id.t option) list type ltac_var_map = var_map * unbound_ltac_var_map type glob_constr_ltac_closure = ltac_var_map * glob_constr type pure_open_constr = evar_map * constr @@ -609,7 +609,7 @@ let rec pretype (tycon : type_constraint) env evdref lvar = function (fun (n, b, t) -> match n with Name _ -> (n, b, t) - | Anonymous -> (Name (id_of_string "H"), b, t)) + | Anonymous -> (Name (Id.of_string "H"), b, t)) cs.cs_args in let env_c = push_rel_context csgn env in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index ec1cc0c6d..e637d2b8e 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -28,8 +28,8 @@ val search_guard : type typing_constraint = OfType of types option | IsType -type var_map = (identifier * Pattern.constr_under_binders) list -type unbound_ltac_var_map = (identifier * identifier option) list +type var_map = (Id.t * Pattern.constr_under_binders) list +type unbound_ltac_var_map = (Id.t * Id.t option) list type ltac_var_map = var_map * unbound_ltac_var_map type glob_constr_ltac_closure = ltac_var_map * glob_constr type pure_open_constr = evar_map * constr diff --git a/pretyping/program.ml b/pretyping/program.ml index a8e91856b..a0befa130 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -11,10 +11,10 @@ open Util open Names open Term -let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) +let make_dir l = make_dirpath (List.map Id.of_string (List.rev l)) let find_reference locstr dir s = - let sp = Libnames.make_path (make_dir dir) (id_of_string s) in + let sp = Libnames.make_path (make_dir dir) (Id.of_string s) in try Nametab.global_of_path sp with Not_found -> anomaly (locstr^": cannot find "^(Libnames.string_of_path sp)) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 23de3eb19..72d43fabd 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -243,8 +243,8 @@ let compute_canonical_projections (con,ind) = ((ConstRef proji_sp, patt, n, args) :: l) with Not_found -> if Flags.is_verbose () then - (let con_pp = Nametab.pr_global_env Idset.empty (ConstRef con) - and proji_sp_pp = Nametab.pr_global_env Idset.empty (ConstRef proji_sp) in + (let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con) + and proji_sp_pp = Nametab.pr_global_env Id.Set.empty (ConstRef proji_sp) in msg_warning (strbrk "No global reference exists for projection value" ++ Termops.print_constr t ++ strbrk " in instance " ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.")); @@ -259,7 +259,7 @@ let compute_canonical_projections (con,ind) = comp let pr_cs_pattern = function - Const_cs c -> Nametab.pr_global_env Idset.empty c + Const_cs c -> Nametab.pr_global_env Id.Set.empty c | Prod_cs -> str "_ -> _" | Default_cs -> str "_" | Sort_cs s -> Termops.pr_sort_family s @@ -277,7 +277,7 @@ let open_canonical_structure i (_,o) = if Flags.is_verbose () then let old_can_s = (Termops.print_constr cs.o_DEF) and new_can_s = (Termops.print_constr s.o_DEF) in - let prj = (Nametab.pr_global_env Idset.empty proj) + let prj = (Nametab.pr_global_env Id.Set.empty proj) and hd_val = (pr_cs_pattern cs_pat) in msg_warning (strbrk "Ignoring canonical projection to " ++ hd_val ++ strbrk " by " ++ prj ++ strbrk " in " diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index de23de75f..f2366ea02 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -644,7 +644,7 @@ let plain_instance s c = (try let g = List.assoc p s in match kind_of_term g with | App _ -> - let h = id_of_string "H" in + let h = Id.of_string "H" in mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l')) | _ -> mkApp (g,l') with Not_found -> mkApp (f,l')) diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 800945f02..beb0be32f 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -40,7 +40,7 @@ let sort_of_atomic_type env sigma ft args = let type_of_var env id = try let (_,_,ty) = lookup_named id env in ty with Not_found -> - anomaly ("type_of: variable "^(string_of_id id)^" unbound") + anomaly ("type_of: variable "^(Id.to_string id)^" unbound") let is_impredicative_set env = match Environ.engagement env with | Some ImpredicativeSet -> true diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 6c2f8f189..1a4bd3877 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -38,7 +38,7 @@ exception Redelimination let error_not_evaluable r = errorlabstrm "error_not_evaluable" - (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Idset.empty r ++ + (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r ++ spc () ++ str "to an evaluable reference.") let is_evaluable_const env cst = @@ -70,13 +70,13 @@ let global_of_evaluable_reference = function type evaluable_reference = | EvalConst of constant - | EvalVar of identifier + | EvalVar of Id.t | EvalRel of int | EvalEvar of existential let evaluable_reference_eq r1 r2 = match r1, r2 with | EvalConst c1, EvalConst c2 -> eq_constant c1 c2 -| EvalVar id1, EvalVar id2 -> id_eq id1 id2 +| EvalVar id1, EvalVar id2 -> Id.equal id1 id2 | EvalRel i1, EvalRel i2 -> Int.equal i1 i2 | EvalEvar (e1, ctx1), EvalEvar (e2, ctx2) -> Int.equal e1 e2 && Array.equal eq_constr ctx1 ctx2 @@ -220,7 +220,7 @@ let invert_name labs l na0 env sigma ref = function | Name id -> let minfxargs = List.length l in begin match na0 with - | Name id' when id_eq id' id -> + | Name id' when Id.equal id' id -> Some (minfxargs,ref) | _ -> let refi = match ref with @@ -334,7 +334,7 @@ let reference_eval sigma env = function The type Tij' is Tij[yi(j-1)..y1 <- ai(j-1)..a1] *) -let x = Name (id_of_string "x") +let x = Name (Id.of_string "x") let make_elim_fun (names,(nbfix,lv,n)) largs = let lu = List.firstn n largs in @@ -363,8 +363,8 @@ let make_elim_fun (names,(nbfix,lv,n)) largs = do so that the reduction uses this extra information *) let dummy = mkProp -let vfx = id_of_string"_expanded_fix_" -let vfun = id_of_string"_eliminator_function_" +let vfx = Id.of_string"_expanded_fix_" +let vfun = Id.of_string"_eliminator_function_" (* Mark every occurrence of substituted vars (associated to a function) as a problem variable: an evar that can be instantiated either by @@ -957,7 +957,7 @@ let substlin env evalref n (nowhere_except_in,locs) c = (!pos, t') let string_of_evaluable_ref env = function - | EvalVarRef id -> string_of_id id + | EvalVarRef id -> Id.to_string id | EvalConstRef kn -> string_of_qualid (Nametab.shortest_qualid_of_global (vars_of_env env) (ConstRef kn)) @@ -1125,7 +1125,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = | IndRef mind' when eq_ind mind mind' -> t | _ -> errorlabstrm "" (str "Cannot recognize a statement based on " ++ - Nametab.pr_global_env Idset.empty ref ++ str".") + Nametab.pr_global_env Id.Set.empty ref ++ str".") end else (* lazily reduces to match the head of [t] with the expected [ref] *) @@ -1138,7 +1138,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = else errorlabstrm "" (str "Cannot recognize an atomic statement based on " ++ - Nametab.pr_global_env Idset.empty ref ++ str".") + Nametab.pr_global_env Id.Set.empty ref ++ str".") | _ -> try if eq_gr (global_of_constr c) ref @@ -1151,7 +1151,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = with NotStepReducible -> errorlabstrm "" (str "Cannot recognize a statement based on " ++ - Nametab.pr_global_env Idset.empty ref ++ str".") + Nametab.pr_global_env Id.Set.empty ref ++ str".") in elimrec env t [] diff --git a/pretyping/termops.ml b/pretyping/termops.ml index 4a267dd7e..2cc538004 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -221,7 +221,7 @@ let lookup_rel_id id sign = | [] -> raise Not_found | (Anonymous, _, _) :: l -> lookrec (n + 1) l | (Name id', b, t) :: l -> - if Int.equal (Names.id_ord id' id) 0 then (n, b, t) else lookrec (n + 1) l + if Int.equal (Names.Id.compare id' id) 0 then (n, b, t) else lookrec (n + 1) l in lookrec 1 sign @@ -564,9 +564,9 @@ let collect_metas c = all section variables; for the latter, use global_vars_set *) let collect_vars c = let rec aux vars c = match kind_of_term c with - | Var id -> Idset.add id vars + | Var id -> Id.Set.add id vars | _ -> fold_constr aux vars c in - aux Idset.empty c + aux Id.Set.empty c (* Tests whether [m] is a subterm of [t]: [m] is appropriately lifted through abstractions of [t] *) @@ -726,7 +726,7 @@ type 'a testing_function = { match_fun : constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; - mutable last_found : ((identifier * hyp_location_flag) option * int * constr) option + mutable last_found : ((Id.t * hyp_location_flag) option * int * constr) option } let subst_closed_term_occ_gen_modulo occs test cl occ t = @@ -825,14 +825,14 @@ let subst_closed_term_occ_decl_modulo (plocs,hyploc) test d = let vars_of_env env = let s = - Sign.fold_named_context (fun (id,_,_) s -> Idset.add id s) - (named_context env) ~init:Idset.empty in + Sign.fold_named_context (fun (id,_,_) s -> Id.Set.add id s) + (named_context env) ~init:Id.Set.empty in Sign.fold_rel_context - (fun (na,_,_) s -> match na with Name id -> Idset.add id s | _ -> s) + (fun (na,_,_) s -> match na with Name id -> Id.Set.add id s | _ -> s) (rel_context env) ~init:s let add_vname vars = function - Name id -> Idset.add id vars + Name id -> Id.Set.add id vars | _ -> vars (*************************) @@ -846,7 +846,7 @@ let lookup_name_of_rel p names = let lookup_rel_of_name id names = let rec lookrec n = function | Anonymous :: l -> lookrec (n+1) l - | (Name id') :: l -> if id_eq id' id then n else lookrec (n+1) l + | (Name id') :: l -> if Id.equal id' id then n else lookrec (n+1) l | [] -> raise Not_found in lookrec 1 names @@ -1049,31 +1049,31 @@ let adjust_subst_to_rel_context sign l = let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init let rec mem_named_context id = function - | (id',_,_) :: _ when id_eq id id' -> true + | (id',_,_) :: _ when Id.equal id id' -> true | _ :: sign -> mem_named_context id sign | [] -> false let clear_named_body id env = let aux _ = function - | (id',Some c,t) when id_eq id id' -> push_named (id,None,t) + | (id',Some c,t) when Id.equal id id' -> push_named (id,None,t) | d -> push_named d in fold_named_context aux env ~init:(reset_context env) -let global_vars env ids = Idset.elements (global_vars_set env ids) +let global_vars env ids = Id.Set.elements (global_vars_set env ids) let global_vars_set_of_decl env = function | (_,None,t) -> global_vars_set env t | (_,Some c,t) -> - Idset.union (global_vars_set env t) + Id.Set.union (global_vars_set env t) (global_vars_set env c) let dependency_closure env sign hyps = - if Idset.is_empty hyps then [] else + if Id.Set.is_empty hyps then [] else let (_,lh) = Sign.fold_named_context_reverse (fun (hs,hl) (x,_,_ as d) -> - if Idset.mem x hs then - (Idset.union (global_vars_set_of_decl env d) (Idset.remove x hs), + if Id.Set.mem x hs then + (Id.Set.union (global_vars_set_of_decl env d) (Id.Set.remove x hs), x::hl) else (hs,hl)) ~init:(hyps,[]) @@ -1111,8 +1111,8 @@ let impossible_default_case = ref None let set_impossible_default_clause c = impossible_default_case := Some c let coq_unit_judge = - let na1 = Name (id_of_string "A") in - let na2 = Name (id_of_string "H") in + let na1 = Name (Id.of_string "A") in + let na2 = Name (Id.of_string "H") in fun () -> match !impossible_default_case with | Some (id,type_of_id) -> diff --git a/pretyping/termops.mli b/pretyping/termops.mli index 096cdbcbb..051a77883 100644 --- a/pretyping/termops.mli +++ b/pretyping/termops.mli @@ -41,7 +41,7 @@ val push_rel_assum : name * types -> env -> env val push_rels_assum : (name * types) list -> env -> env val push_named_rec_types : name array * types array * 'a -> env -> env -val lookup_rel_id : identifier -> rel_context -> int * constr option * types +val lookup_rel_id : Id.t -> rel_context -> int * constr option * types (** Associates the contents of an identifier in a [rel_context]. Raise [Not_found] if there is no such identifier. *) @@ -104,16 +104,16 @@ val occur_meta : types -> bool val occur_existential : types -> bool val occur_meta_or_existential : types -> bool val occur_evar : existential_key -> types -> bool -val occur_var : env -> identifier -> types -> bool +val occur_var : env -> Id.t -> types -> bool val occur_var_in_decl : env -> - identifier -> 'a * types option * types -> bool + Id.t -> 'a * types option * types -> bool val free_rels : constr -> Int.Set.t val dependent : constr -> constr -> bool val dependent_no_evar : constr -> constr -> bool val count_occurrences : constr -> constr -> int val collect_metas : constr -> int list -val collect_vars : constr -> Idset.t (** for visible vars only *) +val collect_vars : constr -> Id.Set.t (** for visible vars only *) val occur_term : constr -> constr -> bool (** Synonymous of dependent Substitution of metavariables *) @@ -162,7 +162,7 @@ type 'a testing_function = { match_fun : constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; - mutable last_found : ((identifier * hyp_location_flag) option * int * constr) option + mutable last_found : ((Id.t * hyp_location_flag) option * int * constr) option } val make_eq_test : constr -> unit testing_function @@ -170,7 +170,7 @@ val make_eq_test : constr -> unit testing_function exception NotUnifiable val subst_closed_term_occ_modulo : - occurrences -> 'a testing_function -> (identifier * hyp_location_flag) option + occurrences -> 'a testing_function -> (Id.t * hyp_location_flag) option -> constr -> types (** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at @@ -228,19 +228,19 @@ val adjust_app_array_size : constr -> constr array -> constr -> constr array -> type names_context = name list val add_name : name -> names_context -> names_context val lookup_name_of_rel : int -> names_context -> name -val lookup_rel_of_name : identifier -> names_context -> int +val lookup_rel_of_name : Id.t -> names_context -> int val empty_names_context : names_context -val ids_of_rel_context : rel_context -> identifier list -val ids_of_named_context : named_context -> identifier list -val ids_of_context : env -> identifier list +val ids_of_rel_context : rel_context -> Id.t list +val ids_of_named_context : named_context -> Id.t list +val ids_of_context : env -> Id.t list val names_of_rel_context : env -> names_context val context_chop : int -> rel_context -> rel_context * rel_context val env_rel_context_chop : int -> env -> env * rel_context (** Set of local names *) -val vars_of_env: env -> Idset.t -val add_vname : Idset.t -> name -> Idset.t +val vars_of_env: env -> Id.Set.t +val add_vname : Id.Set.t -> name -> Id.Set.t (** other signature iterators *) val process_rel_context : (rel_declaration -> env -> env) -> env -> env @@ -256,19 +256,19 @@ val map_rel_context_with_binders : val fold_named_context_both_sides : ('a -> named_declaration -> named_declaration list -> 'a) -> named_context -> init:'a -> 'a -val mem_named_context : identifier -> named_context -> bool +val mem_named_context : Id.t -> named_context -> bool -val clear_named_body : identifier -> env -> env +val clear_named_body : Id.t -> env -> env -val global_vars : env -> constr -> identifier list -val global_vars_set_of_decl : env -> named_declaration -> Idset.t +val global_vars : env -> constr -> Id.t list +val global_vars_set_of_decl : env -> named_declaration -> Id.Set.t (** Gives an ordered list of hypotheses, closed by dependencies, containing a given set *) -val dependency_closure : env -> named_context -> Idset.t -> identifier list +val dependency_closure : env -> named_context -> Id.Set.t -> Id.t list (** Test if an identifier is the basename of a global reference *) -val is_section_variable : identifier -> bool +val is_section_variable : Id.t -> bool val isGlobalRef : constr -> bool diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml index 4a0b66a7b..cfcf9cf43 100644 --- a/pretyping/typeclasses_errors.ml +++ b/pretyping/typeclasses_errors.ml @@ -19,8 +19,8 @@ type contexts = Parameters | Properties type typeclass_error = | NotAClass of constr - | UnboundMethod of global_reference * identifier Loc.located (* Class name, method *) - | NoInstance of identifier Loc.located * constr list + | UnboundMethod of global_reference * Id.t Loc.located (* Class name, method *) + | NoInstance of Id.t Loc.located * constr list | UnsatisfiableConstraints of evar_map * (existential_key * Evar_kinds.t) option | MismatchedContextInstance of contexts * constr_expr list * rel_context (* found, expected *) diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli index ea72eab72..5155b7163 100644 --- a/pretyping/typeclasses_errors.mli +++ b/pretyping/typeclasses_errors.mli @@ -23,8 +23,8 @@ type contexts = Parameters | Properties type typeclass_error = | NotAClass of constr - | UnboundMethod of global_reference * identifier located (** Class name, method *) - | NoInstance of identifier located * constr list + | UnboundMethod of global_reference * Id.t located (** Class name, method *) + | NoInstance of Id.t located * constr list | UnsatisfiableConstraints of evar_map * (existential_key * Evar_kinds.t) option | MismatchedContextInstance of contexts * constr_expr list * rel_context (** found, expected *) @@ -32,9 +32,9 @@ exception TypeClassError of env * typeclass_error val not_a_class : env -> constr -> 'a -val unbound_method : env -> global_reference -> identifier located -> 'a +val unbound_method : env -> global_reference -> Id.t located -> 'a -val no_instance : env -> identifier located -> constr list -> 'a +val no_instance : env -> Id.t located -> constr list -> 'a val unsatisfiable_constraints : env -> evar_map -> evar option -> 'a diff --git a/pretyping/unification.ml b/pretyping/unification.ml index facc243e2..dee597733 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -337,7 +337,7 @@ let key_of b flags f = Cpred.mem cst (snd flags.modulo_delta) -> Some (ConstKey cst) | Var id when is_transparent (VarKey id) && - Idpred.mem id (fst flags.modulo_delta) -> + Id.Pred.mem id (fst flags.modulo_delta) -> Some (VarKey id) | _ -> None @@ -657,9 +657,9 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag | _ -> constr_cmp cv_pb m n) then true else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with | Some (cv_id, cv_k), (dl_id, dl_k) -> - Idpred.subset dl_id cv_id && Cpred.subset dl_k cv_k + Id.Pred.subset dl_id cv_id && Cpred.subset dl_k cv_k | None,(dl_id, dl_k) -> - Idpred.is_empty dl_id && Cpred.is_empty dl_k) + Id.Pred.is_empty dl_id && Cpred.is_empty dl_k) then error_cannot_unify env sigma (m, n) else false) then subst else unirec_rec (env,0) cv_pb conv_at_top false subst m n diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 321364140..82eccab96 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -22,7 +22,7 @@ let crazy_type = mkSet let decompose_prod env t = let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in - if name = Anonymous then (Name (id_of_string "x"),dom,codom) + if name = Anonymous then (Name (Id.of_string "x"),dom,codom) else res exception Find_at of int @@ -141,7 +141,7 @@ and nf_whd env whd typ = | Vsort s -> mkSort s | Vprod p -> let dom = nf_vtype env (dom p) in - let name = Name (id_of_string "x") in + let name = Name (Id.of_string "x") in let vc = body_of_vfun (nb_rel env) (codom p) in let codom = nf_vtype (push_rel (name,None,dom) env) vc in mkProd(name,dom,codom) @@ -213,7 +213,7 @@ and nf_predicate env ind mip params v pT = | Vfun f, _ -> let k = nb_rel env in let vb = body_of_vfun k f in - let name = Name (id_of_string "c") in + let name = Name (Id.of_string "c") in let n = mip.mind_nrealargs in let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if n=0 then params else Array.map (lift n) params in @@ -262,7 +262,7 @@ and nf_fix env f = let vb, vt = reduce_fix k f in let ndef = Array.length vt in let ft = Array.map (fun v -> nf_val env v crazy_type) vt in - let name = Array.init ndef (fun _ -> (Name (id_of_string "Ffix"))) in + let name = Array.init ndef (fun _ -> (Name (Id.of_string "Ffix"))) in let env = push_rec_types (name,ft,ft) env in let fb = Util.Array.map2 (fun v t -> nf_fun env v t) vb ft in mkFix ((rec_args,init),(name,ft,fb)) @@ -280,7 +280,7 @@ and nf_cofix env cf = let vb,vt = reduce_cofix k cf in let ndef = Array.length vt in let cft = Array.map (fun v -> nf_val env v crazy_type) vt in - let name = Array.init ndef (fun _ -> (Name (id_of_string "Fcofix"))) in + let name = Array.init ndef (fun _ -> (Name (Id.of_string "Fcofix"))) in let env = push_rec_types (name,cft,cft) env in let cfb = Util.Array.map2 (fun v t -> nf_val env v t) vb cft in mkCoFix (init,(name,cft,cfb)) diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index ebda3cb76..6d34b10bc 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -138,7 +138,7 @@ let pr_opt_type_spc pr = function let pr_lident (loc,id) = if loc <> Loc.ghost then let (b,_) = Loc.unloc loc in - pr_located pr_id (Loc.make_loc (b,b+String.length(string_of_id id)),id) + pr_located pr_id (Loc.make_loc (b,b+String.length(Id.to_string id)),id) else pr_id id let pr_lname = function diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 1d7f5f7f5..7343140d2 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -30,9 +30,9 @@ val prec_less : int -> int * Ppextend.parenRelation -> bool val pr_tight_coma : unit -> std_ppcmds val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds -val pr_metaid : identifier -> std_ppcmds +val pr_metaid : Id.t -> std_ppcmds -val pr_lident : identifier located -> std_ppcmds +val pr_lident : Id.t located -> std_ppcmds val pr_lname : name located -> std_ppcmds val pr_with_comments : Loc.t -> std_ppcmds -> std_ppcmds @@ -42,7 +42,7 @@ val pr_sep_com : (constr_expr -> std_ppcmds) -> constr_expr -> std_ppcmds -val pr_id : identifier -> std_ppcmds +val pr_id : Id.t -> std_ppcmds val pr_name : name -> std_ppcmds val pr_qualid : qualid -> std_ppcmds val pr_patvar : patvar -> std_ppcmds @@ -59,7 +59,7 @@ val pr_may_eval : val pr_glob_sort : glob_sort -> std_ppcmds val pr_guard_annot : (constr_expr -> std_ppcmds) -> local_binder list -> - ('a * Names.identifier) option * recursion_order_expr -> + ('a * Names.Id.t) option * recursion_order_expr -> std_ppcmds val pr_binders : local_binder list -> std_ppcmds diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 5c65f55b5..5b33f89cb 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -24,7 +24,7 @@ open Genredexpr open Ppconstr open Printer -let pr_global x = Nametab.pr_global_env Idset.empty x +let pr_global x = Nametab.pr_global_env Id.Set.empty x type grammar_terminals = string option list @@ -606,7 +606,7 @@ let pr_fix_tac (id,n,c) = match List.chop (n-1) nal with _, (_,Name id) :: _ -> id, (nal,ty)::bll | bef, (loc,Anonymous) :: aft -> - let id = next_ident_away (id_of_string"y") avoid in + let id = next_ident_away (Id.of_string"y") avoid in id, ((bef@(loc,Name id)::aft, ty)::bll) | _ -> assert false else diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 41882acb4..24b0dc6cd 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -28,11 +28,11 @@ let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr let pr_lident (loc,id) = if loc <> Loc.ghost then let (b,_) = Loc.unloc loc in - pr_located pr_id (Loc.make_loc (b,b+String.length(string_of_id id)),id) + pr_located pr_id (Loc.make_loc (b,b+String.length(Id.to_string id)),id) else pr_id id let string_of_fqid fqid = - String.concat "." (List.map string_of_id fqid) + String.concat "." (List.map Id.to_string fqid) let pr_fqid fqid = str (string_of_fqid fqid) @@ -104,8 +104,8 @@ let pr_set_entry_type = function | ETBinderList _ | ETConstrList _ -> failwith "Internal entry type" let strip_meta id = - let s = string_of_id id in - if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1)) + let s = Id.to_string id in + if s.[0]='$' then Id.of_string (String.sub s 1 (String.length s - 1)) else id let pr_production_item = function diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 1e17a8ab0..dee144b95 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -36,7 +36,7 @@ type object_pr = { print_syntactic_def : kernel_name -> std_ppcmds; print_module : bool -> Names.module_path -> std_ppcmds; print_modtype : module_path -> std_ppcmds; - print_named_decl : identifier * constr option * types -> std_ppcmds; + print_named_decl : Id.t * constr option * types -> std_ppcmds; print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option; print_context : bool -> int option -> Lib.library_segment -> std_ppcmds; print_typed_value_in_env : Environ.env -> Term.constr * Term.types -> Pp.std_ppcmds; @@ -325,9 +325,9 @@ let print_located_qualid ref = let module N = Nametab in let expand = function | TrueGlobal ref -> - Term ref, N.shortest_qualid_of_global Idset.empty ref + Term ref, N.shortest_qualid_of_global Id.Set.empty ref | SynDef kn -> - Syntactic kn, N.shortest_qualid_of_syndef Idset.empty kn in + Syntactic kn, N.shortest_qualid_of_syndef Id.Set.empty kn in match List.map expand (N.locate_extended_all qid) with | [] -> let (dir,id) = repr_qualid qid in @@ -370,7 +370,7 @@ let print_named_assum name typ = str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]" let gallina_print_named_decl (id,c,typ) = - let s = string_of_id id in + let s = Id.to_string id in match c with | Some body -> print_named_def s body typ | None -> print_named_assum s typ @@ -430,7 +430,7 @@ let gallina_print_constant_with_infos sp = with_line_skip (print_name_infos (ConstRef sp)) let gallina_print_syntactic_def kn = - let qid = Nametab.shortest_qualid_of_syndef Idset.empty kn + let qid = Nametab.shortest_qualid_of_syndef Id.Set.empty kn and (vars,a) = Syntax_def.search_syntactic_definition kn in let c = Notation_ops.glob_constr_of_notation_constr Loc.ghost a in hov 2 diff --git a/printing/prettyp.mli b/printing/prettyp.mli index f9e77bec9..7a3395f1b 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -64,7 +64,7 @@ type object_pr = { print_syntactic_def : kernel_name -> std_ppcmds; print_module : bool -> Names.module_path -> std_ppcmds; print_modtype : module_path -> std_ppcmds; - print_named_decl : identifier * constr option * types -> std_ppcmds; + print_named_decl : Id.t * constr option * types -> std_ppcmds; print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option; print_context : bool -> int option -> Lib.library_segment -> std_ppcmds; print_typed_value_in_env : Environ.env -> Term.constr * Term.types -> Pp.std_ppcmds; diff --git a/printing/printer.ml b/printing/printer.ml index 4f09460d8..a3e2fd9c2 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -92,12 +92,12 @@ let pr_glob_constr_env env c = pr_constr_expr (extern_glob_constr (Termops.vars_of_env env) c) let pr_lglob_constr c = - pr_lconstr_expr (extern_glob_constr Idset.empty c) + pr_lconstr_expr (extern_glob_constr Id.Set.empty c) let pr_glob_constr c = - pr_constr_expr (extern_glob_constr Idset.empty c) + pr_constr_expr (extern_glob_constr Id.Set.empty c) let pr_cases_pattern t = - pr_cases_pattern_expr (extern_cases_pattern Idset.empty t) + pr_cases_pattern_expr (extern_cases_pattern Id.Set.empty t) let pr_lconstr_pattern_env env c = pr_lconstr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) c) @@ -124,7 +124,7 @@ let pr_univ_cstr (c:Univ.constraints) = (* Global references *) let pr_global_env = pr_global_env -let pr_global = pr_global_env Idset.empty +let pr_global = pr_global_env Id.Set.empty let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst) let pr_existential env ev = pr_lconstr_env env (mkEvar ev) @@ -135,7 +135,7 @@ let pr_evaluable_reference ref = pr_global (Tacred.global_of_evaluable_reference ref) (*let pr_glob_constr t = - pr_lconstr (Constrextern.extern_glob_constr Idset.empty t)*) + pr_lconstr (Constrextern.extern_glob_constr Id.Set.empty t)*) (*open Pattern @@ -257,7 +257,7 @@ let pr_predicate pr_elt (b, elts) = if elts = [] then str"none" else pr_elts let pr_cpred p = pr_predicate (pr_constant (Global.env())) (Cpred.elements p) -let pr_idpred p = pr_predicate Nameops.pr_id (Idpred.elements p) +let pr_idpred p = pr_predicate Nameops.pr_id (Id.Pred.elements p) let pr_transparent_state (ids, csts) = hv 0 (str"VARIABLES: " ++ pr_idpred ids ++ fnl () ++ @@ -596,7 +596,7 @@ let pr_assumptionset env s = let (v, a, o, tr) = accu in match t with | Variable id -> - let var = str (string_of_id id) ++ str " : " ++ pr_ltype typ in + let var = str (Id.to_string id) ++ str " : " ++ pr_ltype typ in (var :: v, a, o, tr) | Axiom kn -> let ax = safe_pr_constant env kn ++ safe_pr_ltype typ in @@ -688,10 +688,10 @@ let get_fields = let rec prodec_rec l subst c = match kind_of_term c with | Prod (na,t,c) -> - let id = match na with Name id -> id | Anonymous -> id_of_string "_" in + let id = match na with Name id -> id | Anonymous -> Id.of_string "_" in prodec_rec ((id,true,substl subst t)::l) (mkVar id::subst) c | LetIn (na,b,_,c) -> - let id = match na with Name id -> id | Anonymous -> id_of_string "_" in + let id = match na with Name id -> id | Anonymous -> Id.of_string "_" in prodec_rec ((id,false,substl subst b)::l) (mkVar id::subst) c | _ -> List.rev l in diff --git a/printing/printer.mli b/printing/printer.mli index 47dfa32b9..2340b310f 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -76,7 +76,7 @@ val pr_univ_cstr : Univ.constraints -> std_ppcmds (** Printing global references using names as short as possible *) -val pr_global_env : Idset.t -> global_reference -> std_ppcmds +val pr_global_env : Id.Set.t -> global_reference -> std_ppcmds val pr_global : global_reference -> std_ppcmds val pr_constant : env -> constant -> std_ppcmds @@ -102,7 +102,7 @@ val pr_context_of : env -> std_ppcmds val pr_predicate : ('a -> std_ppcmds) -> (bool * 'a list) -> std_ppcmds val pr_cpred : Cpred.t -> std_ppcmds -val pr_idpred : Idpred.t -> std_ppcmds +val pr_idpred : Id.Pred.t -> std_ppcmds val pr_transparent_state : transparent_state -> std_ppcmds (** Proofs *) diff --git a/printing/printmod.ml b/printing/printmod.ml index b5a633cd2..44c246661 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -70,7 +70,7 @@ let print_kn locals kn = Not_found -> print_modpath locals kn let nametab_register_dir mp = - let id = id_of_string "FAKETOP" in + let id = Id.of_string "FAKETOP" in let fp = Libnames.make_path empty_dirpath id in let dir = make_dirpath [id] in Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,empty_dirpath))); @@ -175,11 +175,11 @@ let rec print_modtype env mp locals mty = prlist_with_sep spc (print_modpath locals) mapp ++ str")") | SEBwith(seb,With_definition_body(idl,cb))-> let env' = None in (* TODO: build a proper environment if env <> None *) - let s = (String.concat "." (List.map string_of_id idl)) in + let s = (String.concat "." (List.map Id.to_string idl)) in hov 2 (print_modtype env' mp locals seb ++ spc() ++ str "with" ++ spc() ++ str "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) | SEBwith(seb,With_module_body(idl,mp))-> - let s =(String.concat "." (List.map string_of_id idl)) in + let s =(String.concat "." (List.map Id.to_string idl)) in hov 2 (print_modtype env mp locals seb ++ spc() ++ str "with" ++ spc() ++ str "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) diff --git a/proofs/goal.ml b/proofs/goal.ml index 6b672d2cb..38e536ba2 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -279,16 +279,16 @@ let recheck_typability (what,id) env sigma t = with _ -> let s = match what with | None -> "the conclusion" - | Some id -> "hypothesis "^(Names.string_of_id id) in + | Some id -> "hypothesis "^(Names.Id.to_string id) in Errors.error - ("The correctness of "^s^" relies on the body of "^(Names.string_of_id id)) + ("The correctness of "^s^" relies on the body of "^(Names.Id.to_string id)) let remove_hyp_body env sigma id = let sign = wrap_apply_to_hyp_and_dependent_on (Environ.named_context_val env) id (fun (_,c,t) _ -> match c with - | None -> Errors.error ((Names.string_of_id id)^" is not a local definition") + | None -> Errors.error ((Names.Id.to_string id)^" is not a local definition") | Some c ->(id,None,t)) (fun (id',c,t as d) sign -> ( @@ -384,9 +384,9 @@ let convert_hyp check (id,b,bt as d) env rdefs gl info = let replace_function = (fun _ (_,c,ct) _ -> if check && not (Reductionops.is_conv env sigma bt ct) then - Errors.error ("Incorrect change of the type of "^(Names.string_of_id id)); + Errors.error ("Incorrect change of the type of "^(Names.Id.to_string id)); if check && not (Option.equal (Reductionops.is_conv env sigma) b c) then - Errors.error ("Incorrect change of the body of "^(Names.string_of_id id)); + Errors.error ("Incorrect change of the body of "^(Names.Id.to_string id)); d) in (* Modified named context. *) @@ -427,9 +427,9 @@ let rename_hyp_sign id1 id2 sign = (fun d _ -> map_named_declaration (replace_vars [id1,mkVar id2]) d) let rename_hyp id1 id2 env rdefs gl info = let hyps = hyps env rdefs gl info in - if not (Names.id_eq id1 id2) && + if not (Names.Id.equal id1 id2) && List.mem id2 (Termops.ids_of_named_context (Environ.named_context_of_val hyps)) then - Errors.error ((Names.string_of_id id2)^" is already used."); + Errors.error ((Names.Id.to_string id2)^" is already used."); let new_hyps = rename_hyp_sign id1 id2 hyps in let new_env = Environ.reset_with_named_context new_hyps env in let new_concl = Term.replace_vars [id1,mkVar id2] (concl env rdefs gl info) in diff --git a/proofs/goal.mli b/proofs/goal.mli index 762bcf643..1146d95f6 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -102,10 +102,10 @@ val refine : refinable -> subgoals sensitive (*** Cleaning goals ***) (* Implements the [clear] tactic *) -val clear : Names.identifier list -> subgoals sensitive +val clear : Names.Id.t list -> subgoals sensitive (* Implements the [clearbody] tactic *) -val clear_body : Names.identifier list -> subgoals sensitive +val clear_body : Names.Id.t list -> subgoals sensitive (*** Conversion in goals ***) @@ -121,7 +121,7 @@ val convert_concl : bool -> Term.constr -> subgoals sensitive (*** Bureaucracy in hypotheses ***) (* Renames a hypothesis. *) -val rename_hyp : Names.identifier -> Names.identifier -> subgoals sensitive +val rename_hyp : Names.Id.t -> Names.Id.t -> subgoals sensitive (*** Sensitive primitives ***) diff --git a/proofs/logic.ml b/proofs/logic.ml index b8341f1aa..ba85be766 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -34,7 +34,7 @@ type refiner_error = (* Errors raised by the tactics *) | IntroNeedsProduct - | DoesNotOccurIn of constr * identifier + | DoesNotOccurIn of constr * Id.t exception RefinerError of refiner_error @@ -58,7 +58,7 @@ let rec catchable_exception = function | _ -> false let error_no_such_hypothesis id = - error ("No such hypothesis: " ^ string_of_id id ^ ".") + error ("No such hypothesis: " ^ Id.to_string id ^ ".") (* Tells if the refiner should check that the submitted rules do not produce invalid subgoals *) @@ -103,16 +103,16 @@ let recheck_typability (what,id) env sigma t = with _ -> let s = match what with | None -> "the conclusion" - | Some id -> "hypothesis "^(string_of_id id) in + | Some id -> "hypothesis "^(Id.to_string id) in error - ("The correctness of "^s^" relies on the body of "^(string_of_id id)) + ("The correctness of "^s^" relies on the body of "^(Id.to_string id)) let remove_hyp_body env sigma id = let sign = apply_to_hyp_and_dependent_on (named_context_val env) id (fun (_,c,t) _ -> match c with - | None -> error ((string_of_id id)^" is not a local definition.") + | None -> error ((Id.to_string id)^" is not a local definition.") | Some c ->(id,None,t)) (fun (id',c,t as d) sign -> (if !check then @@ -134,36 +134,36 @@ let remove_hyp_body env sigma id = (* pas echangees. Choix: les hyps mentionnees ne peuvent qu'etre *) (* reculees par rapport aux autres (faire le contraire!) *) -let mt_q = (Idmap.empty,[]) +let mt_q = (Id.Map.empty,[]) let push_val y = function (_,[] as q) -> q - | (m, (x,l)::q) -> (m, (x,Idset.add y l)::q) + | (m, (x,l)::q) -> (m, (x,Id.Set.add y l)::q) let push_item x v (m,l) = - (Idmap.add x v m, (x,Idset.empty)::l) -let mem_q x (m,_) = Idmap.mem x m + (Id.Map.add x v m, (x,Id.Set.empty)::l) +let mem_q x (m,_) = Id.Map.mem x m let find_q x (m,q) = - let v = Idmap.find x m in - let m' = Idmap.remove x m in + let v = Id.Map.find x m in + let m' = Id.Map.remove x m in let rec find accs acc = function [] -> raise Not_found | [(x',l)] -> - if id_eq x x' then ((v,Idset.union accs l),(m',List.rev acc)) + if Id.equal x x' then ((v,Id.Set.union accs l),(m',List.rev acc)) else raise Not_found | (x',l as i)::((x'',l'')::q as itl) -> - if id_eq x x' then - ((v,Idset.union accs l), - (m',List.rev acc@(x'',Idset.add x (Idset.union l l''))::q)) - else find (Idset.union l accs) (i::acc) itl in - find Idset.empty [] q + if Id.equal x x' then + ((v,Id.Set.union accs l), + (m',List.rev acc@(x'',Id.Set.add x (Id.Set.union l l''))::q)) + else find (Id.Set.union l accs) (i::acc) itl in + find Id.Set.empty [] q let occur_vars_in_decl env hyps d = - if Idset.is_empty hyps then false else + if Id.Set.is_empty hyps then false else let ohyps = global_vars_set_of_decl env d in - Idset.exists (fun h -> Idset.mem h ohyps) hyps + Id.Set.exists (fun h -> Id.Set.mem h ohyps) hyps let reorder_context env sign ord = - let ords = List.fold_right Idset.add ord Idset.empty in - if not (Int.equal (List.length ord) (Idset.cardinal ords)) then + let ords = List.fold_right Id.Set.add ord Id.Set.empty in + if not (Int.equal (List.length ord) (Id.Set.cardinal ords)) then error "Order list has duplicates"; let rec step ord expected ctxt_head moved_hyps ctxt_tail = match ord with @@ -175,15 +175,15 @@ let reorder_context env sign ord = (str "Cannot move declaration " ++ pr_id top ++ spc() ++ str "before " ++ pr_sequence pr_id - (Idset.elements (Idset.inter h + (Id.Set.elements (Id.Set.inter h (global_vars_set_of_decl env d)))); step ord' expected ctxt_head mh (d::ctxt_tail) | _ -> (match ctxt_head with | [] -> error_no_such_hypothesis (List.hd ord) | (x,_,_ as d) :: ctxt -> - if Idset.mem x expected then - step ord (Idset.remove x expected) + if Id.Set.mem x expected then + step ord (Id.Set.remove x expected) ctxt (push_item x d moved_hyps) ctxt_tail else step ord expected @@ -200,7 +200,7 @@ let check_decl_position env sign (x,_,_ as d) = let needed = global_vars_set_of_decl env d in let deps = dependency_closure env (named_context_of_val sign) needed in if List.mem x deps then - error ("Cannot create self-referring hypothesis "^string_of_id x); + error ("Cannot create self-referring hypothesis "^Id.to_string x); x::deps (* Auxiliary functions for primitive MOVE tactic @@ -212,8 +212,8 @@ let check_decl_position env sign (x,_,_ as d) = * If [with_dep] then dependent hypotheses are moved accordingly. *) let move_location_eq m1 m2 = match m1, m2 with -| MoveAfter id1, MoveAfter id2 -> id_eq id1 id2 -| MoveBefore id1, MoveBefore id2 -> id_eq id1 id2 +| MoveAfter id1, MoveAfter id2 -> Id.equal id1 id2 +| MoveBefore id1, MoveBefore id2 -> Id.equal id1 id2 | MoveLast, MoveLast -> true | MoveFirst, MoveFirst -> true | _ -> false @@ -221,7 +221,7 @@ let move_location_eq m1 m2 = match m1, m2 with let rec get_hyp_after h = function | [] -> error_no_such_hypothesis h | (hyp,_,_) :: right -> - if id_eq hyp h then + if Id.equal hyp h then match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveFirst else get_hyp_after h right @@ -230,11 +230,11 @@ let split_sign hfrom hto l = let rec splitrec left toleft = function | [] -> error_no_such_hypothesis hfrom | (hyp,c,typ) as d :: right -> - if id_eq hyp hfrom then + if Id.equal hyp hfrom then (left,right,d, toleft || move_location_eq hto MoveLast) else let is_toleft = match hto with - | MoveAfter h' | MoveBefore h' -> id_eq hyp h' + | MoveAfter h' | MoveBefore h' -> Id.equal hyp h' | _ -> false in splitrec (d::left) (toleft || is_toleft) @@ -471,9 +471,9 @@ let convert_hyp sign sigma (id,b,bt as d) = (fun _ (_,c,ct) _ -> let env = Global.env_of_context sign in if !check && not (is_conv env sigma bt ct) then - error ("Incorrect change of the type of "^(string_of_id id)^"."); + error ("Incorrect change of the type of "^(Id.to_string id)^"."); if !check && not (Option.equal (is_conv env sigma) b c) then - error ("Incorrect change of the body of "^(string_of_id id)^"."); + error ("Incorrect change of the body of "^(Id.to_string id)^"."); if !check then reorder := check_decl_position env sign d; d) in reorder_val_context env sign' !reorder @@ -495,7 +495,7 @@ let prim_refiner r sigma goal = (* Logical rules *) | Intro id -> if !check && mem_named_context id (named_context_of_val sign) then - error ("Variable " ^ string_of_id id ^ " is already declared."); + error ("Variable " ^ Id.to_string id ^ " is already declared."); (match kind_of_term (strip_outer_cast cl) with | Prod (_,c1,b) -> let (sg,ev,sigma) = mk_goal (push_named_context_val (id,None,c1) sign) @@ -524,7 +524,7 @@ let prim_refiner r sigma goal = cl,sigma else (if !check && mem_named_context id (named_context_of_val sign) then - error ("Variable " ^ string_of_id id ^ " is already declared."); + error ("Variable " ^ Id.to_string id ^ " is already declared."); push_named_context_val (id,None,t) sign,cl,sigma) in let (sg2,ev2,sigma) = Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in @@ -556,7 +556,7 @@ let prim_refiner r sigma goal = "mutual inductive declaration."); if !check && mem_named_context f (named_context_of_val sign) then error - ("Name "^string_of_id f^" already used in the environment"); + ("Name "^Id.to_string f^" already used in the environment"); mk_sign (push_named_context_val (f,None,ar) sign) oth | [] -> Goal.list_map (fun sigma (_,_,c) -> @@ -679,9 +679,9 @@ let prim_refiner r sigma goal = ([gl], sigma) | Rename (id1,id2) -> - if !check && not (id_eq id1 id2) && + if !check && not (Id.equal id1 id2) && List.mem id2 (ids_of_named_context (named_context_of_val sign)) then - error ((string_of_id id2)^" is already used."); + error ((Id.to_string id2)^" is already used."); let sign' = rename_hyp id1 id2 sign in let cl' = replace_vars [id1,mkVar id2] cl in let (gl,ev,sigma) = mk_goal sign' cl' in diff --git a/proofs/logic.mli b/proofs/logic.mli index 75d9bd957..e87adb165 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -47,7 +47,7 @@ type refiner_error = (*i Errors raised by the tactics i*) | IntroNeedsProduct - | DoesNotOccurIn of constr * identifier + | DoesNotOccurIn of constr * Id.t exception RefinerError of refiner_error diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 44c5d7f30..ad334e91c 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -156,7 +156,7 @@ let build_constant_by_tactic id sign typ tac = raise e let build_by_tactic env typ tac = - let id = id_of_string ("temporary_proof"^string_of_int (next())) in + let id = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in (build_constant_by_tactic id sign typ tac).const_entry_body diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 382dd598d..1b2ae9ec7 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -38,7 +38,7 @@ val check_no_pending_proofs : unit -> unit (** [delete_proof name] deletes proof of name [name] or fails if no proof has this name *) -val delete_proof : identifier located -> unit +val delete_proof : Id.t located -> unit (** [delete_current_proof ()] deletes current focused proof or fails if no proof is focused *) @@ -75,7 +75,7 @@ val current_proof_depth: unit -> int type lemma_possible_guards = Proof_global.lemma_possible_guards val start_proof : - identifier -> goal_kind -> named_context_val -> constr -> + Id.t -> goal_kind -> named_context_val -> constr -> ?init_tac:tactic -> ?compute_guard:lemma_possible_guards -> unit declaration_hook -> unit @@ -91,7 +91,7 @@ val restart_proof : unit -> unit it also tells if the guardness condition has to be inferred. *) val cook_proof : (Proof.proof -> unit) -> - identifier * + Id.t * (Entries.definition_entry * lemma_possible_guards * goal_kind * unit declaration_hook) @@ -117,19 +117,19 @@ val get_current_goal_context : unit -> Evd.evar_map * env (** [current_proof_statement] *) val current_proof_statement : - unit -> identifier * goal_kind * types * unit declaration_hook + unit -> Id.t * goal_kind * types * unit declaration_hook (** {6 ... } *) (** [get_current_proof_name ()] return the name of the current focused proof or failed if no proof is focused *) -val get_current_proof_name : unit -> identifier +val get_current_proof_name : unit -> Id.t (** [get_all_proof_names ()] returns the list of all pending proof names. The first name is the current proof, the other names may come in any order. *) -val get_all_proof_names : unit -> identifier list +val get_all_proof_names : unit -> Id.t list (** {6 ... } *) (** [set_end_tac tac] applies tactic [tac] to all subgoal generate @@ -140,7 +140,7 @@ val set_end_tac : tactic -> unit (** {6 ... } *) (** [set_used_variables l] declares that section variables [l] will be used in the proof *) -val set_used_variables : identifier list -> unit +val set_used_variables : Id.t list -> unit val get_used_variables : unit -> Sign.section_context option (** {6 ... } *) @@ -165,7 +165,7 @@ val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit (** [build_by_tactic typ tac] returns a term of type [typ] by calling [tac] *) -val build_constant_by_tactic : identifier -> named_context_val -> types -> tactic -> +val build_constant_by_tactic : Id.t -> named_context_val -> types -> tactic -> Entries.definition_entry val build_by_tactic : env -> types -> tactic -> constr diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 9cc726beb..c5a190228 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -60,7 +60,7 @@ let _ = (*** Proof Global Environment ***) (* local shorthand *) -type nproof = identifier*Proof.proof +type nproof = Id.t*Proof.proof (* Extra info on proofs. *) type lemma_possible_guards = int list list @@ -75,7 +75,7 @@ type proof_info = { (* The head of [!current_proof] is the actual current proof, the other ones are to be resumed when the current proof is closed or aborted. *) let current_proof = ref ([]:nproof list) -let proof_info = ref (Idmap.empty : proof_info Idmap.t) +let proof_info = ref (Id.Map.empty : proof_info Id.Map.t) (* Current proof_mode, for bookkeeping *) let current_proof_mode = ref !default_proof_mode @@ -84,7 +84,7 @@ let current_proof_mode = ref !default_proof_mode let update_proof_mode () = match !current_proof with | (id,_)::_ -> - let { mode = m } = Idmap.find id !proof_info in + let { mode = m } = Id.Map.find id !proof_info in !current_proof_mode.reset (); current_proof_mode := m; !current_proof_mode.set () @@ -103,7 +103,7 @@ let _ = Errors.register_handler begin function end let extract id l = let rec aux = function - | ((id',_) as np)::l when id_eq id id' -> (np,l) + | ((id',_) as np)::l when Id.equal id id' -> (np,l) | np::l -> let (np', l) = aux l in (np' , np::l) | [] -> raise NoSuchProof in @@ -128,9 +128,9 @@ let find_top l = (* combinators for the proof_info map *) let add id info m = - m := Idmap.add id info !m + m := Id.Map.add id info !m let remove id m = - m := Idmap.remove id !m + m := Id.Map.remove id !m (*** Proof Global manipulation ***) @@ -183,7 +183,7 @@ let discard_current () = let discard_all () = current_proof := []; - proof_info := Idmap.empty + proof_info := Id.Map.empty (* [set_proof_mode] sets the proof mode to be used after it's called. It is typically called by the Proof Mode command. *) @@ -191,9 +191,9 @@ let discard_all () = No undo handling. Applies to proof [id], and proof mode [m]. *) let set_proof_mode m id = - let info = Idmap.find id !proof_info in + let info = Id.Map.find id !proof_info in let info = { info with mode = m } in - proof_info := Idmap.add id info !proof_info; + proof_info := Id.Map.add id info !proof_info; update_proof_mode () (* Complete function. Handles undo. @@ -223,7 +223,7 @@ end let start_proof id str goals ?(compute_guard=[]) hook = begin List.iter begin fun (id_ex,_) -> - if Names.id_eq id id_ex then raise AlreadyExists + if Names.Id.equal id id_ex then raise AlreadyExists end !current_proof end; let p = Proof.start goals in @@ -247,7 +247,7 @@ let set_endline_tactic tac = let set_used_variables l = let p = give_me_the_proof () in let env = Global.env () in - let ids = List.fold_right Idset.add l Idset.empty in + let ids = List.fold_right Id.Set.add l Id.Set.empty in let ctx = Environ.keep_hyps env ids in Proof.set_used_variables ctx p @@ -274,7 +274,7 @@ let close_proof () = proofs_and_types in let { compute_guard=cg ; strength=str ; hook=hook } = - Idmap.find id !proof_info + Id.Map.find id !proof_info in (id, (entries,cg,str,hook)) with @@ -405,7 +405,7 @@ module V82 = struct let p = give_me_the_proof () in let id = get_current_proof_name () in let { strength=str ; hook=hook } = - Idmap.find id !proof_info + Id.Map.find id !proof_info in (id,(Proof.V82.get_initial_conclusions p, str, hook)) end diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 3b43f61f9..33a0bf98a 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -32,10 +32,10 @@ val there_is_a_proof : unit -> bool val there_are_pending_proofs : unit -> bool val check_no_pending_proof : unit -> unit -val get_current_proof_name : unit -> Names.identifier -val get_all_proof_names : unit -> Names.identifier list +val get_current_proof_name : unit -> Names.Id.t +val get_all_proof_names : unit -> Names.Id.t list -val discard : Names.identifier Loc.located -> unit +val discard : Names.Id.t Loc.located -> unit val discard_current : unit -> unit val discard_all : unit -> unit @@ -53,7 +53,7 @@ val give_me_the_proof : unit -> Proof.proof proof end (e.g. to declare the built constructions as a coercion or a setoid morphism). *) type lemma_possible_guards = int list list -val start_proof : Names.identifier -> +val start_proof : Names.Id.t -> Decl_kinds.goal_kind -> (Environ.env * Term.types) list -> ?compute_guard:lemma_possible_guards -> @@ -61,7 +61,7 @@ val start_proof : Names.identifier -> unit val close_proof : unit -> - Names.identifier * + Names.Id.t * (Entries.definition_entry list * lemma_possible_guards * Decl_kinds.goal_kind * @@ -77,7 +77,7 @@ val run_tactic : unit Proofview.tactic -> unit val set_endline_tactic : unit Proofview.tactic -> unit (** Sets the section variables assumed by the proof *) -val set_used_variables : Names.identifier list -> unit +val set_used_variables : Names.Id.t list -> unit val get_used_variables : unit -> Sign.section_context option (** Appends the endline tactic of the current proof to a tactic. *) @@ -127,5 +127,5 @@ module Bullet : sig end module V82 : sig - val get_current_initial_conclusions : unit -> Names.identifier *(Term.types list * Decl_kinds.goal_kind * unit Tacexpr.declaration_hook) + val get_current_initial_conclusions : unit -> Names.Id.t *(Term.types list * Decl_kinds.goal_kind * unit Tacexpr.declaration_hook) end diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml index b7237f1fc..eadf870fb 100644 --- a/proofs/proof_type.ml +++ b/proofs/proof_type.ml @@ -27,18 +27,18 @@ type goal = Goal.goal type tactic = goal sigma -> goal list sigma type prim_rule = - | Intro of identifier - | Cut of bool * bool * identifier * types - | FixRule of identifier * int * (identifier * int * constr) list * int - | Cofix of identifier * (identifier * constr) list * int + | Intro of Id.t + | Cut of bool * bool * Id.t * types + | FixRule of Id.t * int * (Id.t * int * constr) list * int + | Cofix of Id.t * (Id.t * constr) list * int | Refine of constr | Convert_concl of types * cast_kind | Convert_hyp of named_declaration - | Thin of identifier list - | ThinBody of identifier list - | Move of bool * identifier * identifier move_location - | Order of identifier list - | Rename of identifier * identifier + | Thin of Id.t list + | ThinBody of Id.t list + | Move of bool * Id.t * Id.t move_location + | Order of Id.t list + | Rename of Id.t * Id.t | Change_evars (** Nowadays, the only rules we'll consider are the primitive rules *) @@ -51,9 +51,9 @@ type ltac_call_kind = | LtacNotationCall of string | LtacNameCall of ltac_constant | LtacAtomCall of glob_atomic_tactic_expr - | LtacVarCall of identifier * glob_tactic_expr + | LtacVarCall of Id.t * glob_tactic_expr | LtacConstrInterp of glob_constr * - (extended_patvar_map * (identifier * identifier option) list) + (extended_patvar_map * (Id.t * Id.t option) list) type ltac_trace = (int * Loc.t * ltac_call_kind) list diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index 95ca33e90..37d5c4544 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -23,18 +23,18 @@ open Misctypes is used by [Proof_tree] and [Refiner] *) type prim_rule = - | Intro of identifier - | Cut of bool * bool * identifier * types - | FixRule of identifier * int * (identifier * int * constr) list * int - | Cofix of identifier * (identifier * constr) list * int + | Intro of Id.t + | Cut of bool * bool * Id.t * types + | FixRule of Id.t * int * (Id.t * int * constr) list * int + | Cofix of Id.t * (Id.t * constr) list * int | Refine of constr | Convert_concl of types * cast_kind | Convert_hyp of named_declaration - | Thin of identifier list - | ThinBody of identifier list - | Move of bool * identifier * identifier move_location - | Order of identifier list - | Rename of identifier * identifier + | Thin of Id.t list + | ThinBody of Id.t list + | Move of bool * Id.t * Id.t move_location + | Order of Id.t list + | Rename of Id.t * Id.t | Change_evars (** Nowadays, the only rules we'll consider are the primitive rules *) @@ -76,9 +76,9 @@ type ltac_call_kind = | LtacNotationCall of string | LtacNameCall of ltac_constant | LtacAtomCall of glob_atomic_tactic_expr - | LtacVarCall of identifier * glob_tactic_expr + | LtacVarCall of Id.t * glob_tactic_expr | LtacConstrInterp of glob_constr * - (extended_patvar_map * (identifier * identifier option) list) + (extended_patvar_map * (Id.t * Id.t option) list) type ltac_trace = (int * Loc.t * ltac_call_kind) list diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index e4b8697d1..be0cba3a1 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -44,7 +44,7 @@ let set_strategy_one ref l = | OpaqueDef _ -> errorlabstrm "set_transparent_const" (str "Cannot make" ++ spc () ++ - Nametab.pr_global_env Idset.empty (ConstRef sp) ++ + Nametab.pr_global_env Id.Set.empty (ConstRef sp) ++ spc () ++ str "transparent because it was declared opaque."); | _ -> Csymtable.set_transparent_const sp) | _ -> () diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 704dd9887..c83d5ca7a 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -204,7 +204,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) List.fold_left (fun acc lh -> acc ^ (if !frst then (frst:=false;"") else " | ") ^ (List.fold_left - (fun acc (nm,_,_) -> (Names.string_of_id nm) ^ " " ^ acc) + (fun acc (nm,_,_) -> (Names.Id.to_string nm) ^ " " ^ acc) "" lh)) "" newhyps in pp (str (emacs_str "<infoH>") diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 66a9a9962..2b5114174 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -53,7 +53,7 @@ let pf_get_hyp gls id = try Sign.lookup_named id (pf_hyps gls) with Not_found -> - error ("No such hypothesis: " ^ (string_of_id id)) + error ("No such hypothesis: " ^ (Id.to_string id)) let pf_get_hyp_typ gls id = let (_,_,ty)= (pf_get_hyp gls id) in @@ -72,7 +72,7 @@ let pf_get_new_ids ids gls = let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id -let pf_parse_const gls = compose (pf_global gls) id_of_string +let pf_parse_const gls = compose (pf_global gls) Id.of_string let pf_reduction_of_red_expr gls re c = (fst (reduction_of_red_expr re)) (pf_env gls) (project gls) c diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index da9aecde9..328a3d65b 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -39,22 +39,22 @@ val apply_sig_tac : val pf_concl : goal sigma -> types val pf_env : goal sigma -> env val pf_hyps : goal sigma -> named_context -(*i val pf_untyped_hyps : goal sigma -> (identifier * constr) list i*) -val pf_hyps_types : goal sigma -> (identifier * types) list -val pf_nth_hyp_id : goal sigma -> int -> identifier +(*i val pf_untyped_hyps : goal sigma -> (Id.t * constr) list i*) +val pf_hyps_types : goal sigma -> (Id.t * types) list +val pf_nth_hyp_id : goal sigma -> int -> Id.t val pf_last_hyp : goal sigma -> named_declaration -val pf_ids_of_hyps : goal sigma -> identifier list -val pf_global : goal sigma -> identifier -> constr +val pf_ids_of_hyps : goal sigma -> Id.t list +val pf_global : goal sigma -> Id.t -> constr val pf_parse_const : goal sigma -> string -> constr val pf_type_of : goal sigma -> constr -> types val pf_check_type : goal sigma -> constr -> types -> unit val pf_hnf_type_of : goal sigma -> constr -> types -val pf_get_hyp : goal sigma -> identifier -> named_declaration -val pf_get_hyp_typ : goal sigma -> identifier -> types +val pf_get_hyp : goal sigma -> Id.t -> named_declaration +val pf_get_hyp_typ : goal sigma -> Id.t -> types -val pf_get_new_id : identifier -> goal sigma -> identifier -val pf_get_new_ids : identifier list -> goal sigma -> identifier list +val pf_get_new_id : Id.t -> goal sigma -> Id.t +val pf_get_new_ids : Id.t list -> goal sigma -> Id.t list val pf_reduction_of_red_expr : goal sigma -> red_expr -> constr -> constr @@ -87,34 +87,34 @@ val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool (** {6 The most primitive tactics. } *) val refiner : rule -> tactic -val introduction_no_check : identifier -> tactic -val internal_cut_no_check : bool -> identifier -> types -> tactic -val internal_cut_rev_no_check : bool -> identifier -> types -> tactic +val introduction_no_check : Id.t -> tactic +val internal_cut_no_check : bool -> Id.t -> types -> tactic +val internal_cut_rev_no_check : bool -> Id.t -> types -> tactic val refine_no_check : constr -> tactic val convert_concl_no_check : types -> cast_kind -> tactic val convert_hyp_no_check : named_declaration -> tactic -val thin_no_check : identifier list -> tactic -val thin_body_no_check : identifier list -> tactic +val thin_no_check : Id.t list -> tactic +val thin_body_no_check : Id.t list -> tactic val move_hyp_no_check : - bool -> identifier -> identifier move_location -> tactic -val rename_hyp_no_check : (identifier*identifier) list -> tactic -val order_hyps : identifier list -> tactic + bool -> Id.t -> Id.t move_location -> tactic +val rename_hyp_no_check : (Id.t*Id.t) list -> tactic +val order_hyps : Id.t list -> tactic val mutual_fix : - identifier -> int -> (identifier * int * constr) list -> int -> tactic -val mutual_cofix : identifier -> (identifier * constr) list -> int -> tactic + Id.t -> int -> (Id.t * int * constr) list -> int -> tactic +val mutual_cofix : Id.t -> (Id.t * constr) list -> int -> tactic (** {6 The most primitive tactics with consistency and type checking } *) -val introduction : identifier -> tactic -val internal_cut : bool -> identifier -> types -> tactic -val internal_cut_rev : bool -> identifier -> types -> tactic +val introduction : Id.t -> tactic +val internal_cut : bool -> Id.t -> types -> tactic +val internal_cut_rev : bool -> Id.t -> types -> tactic val refine : constr -> tactic val convert_concl : types -> cast_kind -> tactic val convert_hyp : named_declaration -> tactic -val thin : identifier list -> tactic -val thin_body : identifier list -> tactic -val move_hyp : bool -> identifier -> identifier move_location -> tactic -val rename_hyp : (identifier*identifier) list -> tactic +val thin : Id.t list -> tactic +val thin_body : Id.t list -> tactic +val move_hyp : bool -> Id.t -> Id.t move_location -> tactic +val rename_hyp : (Id.t*Id.t) list -> tactic (** {6 Tactics handling a list of goals. } *) diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index 6f93ab725..afbc8bbe4 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -169,13 +169,13 @@ let db_pattern_rule debug num r = (* Prints the hypothesis pattern identifier if it exists *) let hyp_bound = function | Anonymous -> " (unbound)" - | Name id -> " (bound to "^(Names.string_of_id id)^")" + | Name id -> " (bound to "^(Names.Id.to_string id)^")" (* Prints a matched hypothesis *) let db_matched_hyp debug env (id,_,c) ido = if is_debug debug then msg_tac_debug (str "Hypothesis " ++ - str ((Names.string_of_id id)^(hyp_bound ido)^ + str ((Names.Id.to_string id)^(hyp_bound ido)^ " has been matched: ") ++ print_constr_env env c) (* Prints the matched conclusion *) diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli index e456ad90b..2ba1b315b 100644 --- a/proofs/tactic_debug.mli +++ b/proofs/tactic_debug.mli @@ -46,7 +46,7 @@ val db_pattern_rule : (** Prints a matched hypothesis *) val db_matched_hyp : - debug_info -> env -> identifier * constr option * constr -> name -> unit + debug_info -> env -> Id.t * constr option * constr -> name -> unit (** Prints the matched conclusion *) val db_matched_concl : debug_info -> env -> constr -> unit @@ -78,4 +78,4 @@ val db_logic_failure : debug_info -> exn -> unit (** Prints a logic failure message for a rule *) val db_breakpoint : debug_info -> - identifier Loc.located message_token list -> unit + Id.t Loc.located message_token list -> unit diff --git a/tactics/auto.ml b/tactics/auto.ml index ecc0930c1..7ac79356f 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -152,7 +152,7 @@ let lookup_tacs (hdc,c) st (l,l',dn) = module Constr_map = Map.Make(RefOrdered) let is_transparent_gr (ids, csts) = function - | VarRef id -> Idpred.mem id ids + | VarRef id -> Id.Pred.mem id ids | ConstRef cst -> Cpred.mem cst csts | IndRef _ | ConstructRef _ -> false @@ -308,7 +308,7 @@ module Hint_db = struct type t = { hintdb_state : Names.transparent_state; hintdb_cut : hints_path; - hintdb_unfolds : Idset.t * Cset.t; + hintdb_unfolds : Id.Set.t * Cset.t; mutable hintdb_max_id : int; use_dn : bool; hintdb_map : search_entry Constr_map.t; @@ -322,7 +322,7 @@ module Hint_db = struct let empty st use_dn = { hintdb_state = st; hintdb_cut = PathEmpty; - hintdb_unfolds = (Idset.empty, Cset.empty); + hintdb_unfolds = (Id.Set.empty, Cset.empty); hintdb_max_id = 0; use_dn = use_dn; hintdb_map = Constr_map.empty; @@ -384,7 +384,7 @@ module Hint_db = struct | Unfold_nth egr -> let addunf (ids,csts) (ids',csts') = match egr with - | EvalVarRef id -> (Idpred.add id ids, csts), (Idset.add id ids', csts') + | EvalVarRef id -> (Id.Pred.add id ids, csts), (Id.Set.add id ids', csts') | EvalConstRef cst -> (ids, Cpred.add cst csts), (ids', Cset.add cst csts') in let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in @@ -611,7 +611,7 @@ let add_transparency dbname grs b = List.fold_left (fun (ids, csts) gr -> match gr with | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts) - | EvalVarRef v -> (if b then Idpred.add else Idpred.remove) v ids, csts) + | EvalVarRef v -> (if b then Id.Pred.add else Id.Pred.remove) v ids, csts) st grs in searchtable_add (dbname, Hint_db.set_transparent_state db st') @@ -806,7 +806,7 @@ type hints_entry = | HintsExternEntry of int * (patvar list * constr_pattern) option * glob_tactic_expr -let h = id_of_string "H" +let h = Id.of_string "H" exception Found of constr * types @@ -833,8 +833,8 @@ let prepare_hint env (sigma,c) = let rec iter c = try find_next_evar c; c with Found (evar,t) -> - let id = next_ident_away_from h (fun id -> Idset.mem id !vars) in - vars := Idset.add id !vars; + let id = next_ident_away_from h (fun id -> Id.Set.mem id !vars) in + vars := Id.Set.add id !vars; subst := (evar,mkVar id)::!subst; mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in iter c @@ -1312,7 +1312,7 @@ and my_find_search_delta db_list local_db hdc concl = let l = match hdc with None -> Hint_db.map_none db | Some hdc -> - if (Idpred.is_empty ids && Cpred.is_empty csts) + if (Id.Pred.is_empty ids && Cpred.is_empty csts) then Hint_db.map_auto (hdc,concl) db else Hint_db.map_all hdc db in {flags with modulo_delta = st}, l diff --git a/tactics/auto.mli b/tactics/auto.mli index b7f5a312a..2ec0c877d 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -88,7 +88,7 @@ module Hint_db : val add_cut : hints_path -> t -> t val cut : t -> hints_path - val unfolds : t -> Idset.t * Cset.t + val unfolds : t -> Id.Set.t * Cset.t end type hint_db_name = string diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 672b5bc45..cae417ad3 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -129,7 +129,7 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic = match Tacmach.pf_hyps gl with (last_hyp_id,_,_)::_ -> last_hyp_id | _ -> (* even the hypothesis id is missing *) - error ("No such hypothesis: " ^ (string_of_id !id) ^".") + error ("No such hypothesis: " ^ (Id.to_string !id) ^".") in let gl' = general_rewrite_in dir AllOccurrences true ~tac:(tac, conds) false !id cstr false gl in let gls = gl'.Evd.it in @@ -137,7 +137,7 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic = g::_ -> (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with (lastid,_,_)::_ -> - if not (id_eq last_hyp_id lastid) then + if not (Id.equal last_hyp_id lastid) then begin let gl'' = if !to_be_cleared then diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index ab335f789..773e3694e 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -22,7 +22,7 @@ val add_rew_rules : string -> raw_rew_rule list -> unit Default is Naive: first match in the clause, don't look at the side-conditions to tell if the rewrite succeeded. *) val autorewrite : ?conds:conditions -> tactic -> string list -> tactic -val autorewrite_in : ?conds:conditions -> Names.identifier -> tactic -> string list -> tactic +val autorewrite_in : ?conds:conditions -> Names.Id.t -> tactic -> string list -> tactic (** Rewriting rules *) type rew_rule = { rew_lemma: constr; diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 875370501..0a1845322 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -74,7 +74,7 @@ struct | Const c -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l) | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) - | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Var id when not (Id.Pred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l) | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c]) | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l) | Sort _ -> Dn.Label(Term_dn.SortLabel, []) diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 4d037843e..f1297647c 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -449,7 +449,7 @@ let autounfolds db occs = in let (ids, csts) = Hint_db.unfolds db in Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts - (Idset.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) + (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) in unfold_option unfolds let autounfold db cls gl = @@ -471,7 +471,7 @@ END let unfold_head env (ids, csts) c = let rec aux c = match kind_of_term c with - | Var id when Idset.mem id ids -> + | Var id when Id.Set.mem id ids -> (match Environ.named_body id env with | Some b -> true, b | None -> false, c) @@ -507,7 +507,7 @@ let autounfold_one db cl gl = with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in - (Idset.union ids i, Cset.union csts c)) (Idset.empty, Cset.empty) db + (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db in let did, c' = unfold_head (pf_env gl) st (match cl with Some (id, _) -> pf_get_hyp_typ gl id | None -> pf_concl gl) in if did then @@ -517,7 +517,7 @@ let autounfold_one db cl gl = else tclFAIL 0 (str "Nothing to unfold") gl (* Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts *) -(* (Idset.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *) +(* (Id.Set.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *) (* in unfold_option unfolds cl *) (* let db = try searchtable_map dbname *) @@ -525,7 +525,7 @@ let autounfold_one db cl gl = (* in *) (* let (ids, csts) = Hint_db.unfolds db in *) (* Cset.fold (fun cst -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cst)) csts *) -(* (Idset.fold (fun id -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cl) ids acc))) *) +(* (Id.Set.fold (fun id -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cl) ids acc))) *) (* (tclFAIL 0 (mt())) db *) TACTIC EXTEND autounfold_one diff --git a/tactics/elim.ml b/tactics/elim.ml index 88348206b..faa32ab86 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -81,7 +81,7 @@ and general_decompose_aux recognizer id = pas si aucune élimination n'est possible *) (* Meilleures stratégies mais perte de compatibilité *) -let tmphyp_name = id_of_string "_TmpHyp" +let tmphyp_name = Id.of_string "_TmpHyp" let up_to_delta = ref false (* true *) let general_decompose recognizer c gl = diff --git a/tactics/elim.mli b/tactics/elim.mli index a1af31c6b..d135997cd 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -23,7 +23,7 @@ val introCaseAssumsThen : (intro_pattern_expr Loc.located list -> branch_assumptions -> tactic) -> branch_args -> tactic -val general_decompose : (identifier * constr -> bool) -> constr -> tactic +val general_decompose : (Id.t * constr -> bool) -> constr -> tactic val decompose_nonrec : constr -> tactic val decompose_and : constr -> tactic val decompose_or : constr -> tactic diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4 index 6500b0e53..a5f8831a0 100644 --- a/tactics/eqdecide.ml4 +++ b/tactics/eqdecide.ml4 @@ -85,8 +85,8 @@ let mkDecideEqGoal eqonleft op rectype c1 c2 g = let mkGenDecideEqGoal rectype g = let hypnames = pf_ids_of_hyps g in - let xname = next_ident_away (id_of_string "x") hypnames - and yname = next_ident_away (id_of_string "y") hypnames in + let xname = next_ident_away (Id.of_string "x") hypnames + and yname = next_ident_away (Id.of_string "y") hypnames in (mkNamedProd xname rectype (mkNamedProd yname rectype (mkDecideEqGoal true (build_coq_sumbool ()) @@ -99,8 +99,8 @@ let eqCase tac = tac))) let diseqCase eqonleft = - let diseq = id_of_string "diseq" in - let absurd = id_of_string "absurd" in + let diseq = Id.of_string "diseq" in + let absurd = Id.of_string "absurd" in (tclTHEN (intro_using diseq) (tclTHEN (choose_noteq eqonleft) (tclTHEN red_in_concl diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 5f6c776ba..27d086095 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -57,8 +57,8 @@ open Inductiveops open Ind_tables open Indrec -let hid = id_of_string "H" -let xid = id_of_string "X" +let hid = Id.of_string "H" +let xid = Id.of_string "X" let default_id_of_sort = function InProp | InSet -> hid | InType -> xid let fresh env id = next_global_ident_away id [] @@ -311,8 +311,8 @@ let build_l2r_rew_scheme dep env ind kind = Array.concat [extended_rel_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let varHC = fresh env (id_of_string "HC") in - let varP = fresh env (id_of_string "P") in + let varHC = fresh env (Id.of_string "HC") in + let varP = fresh env (Id.of_string "P") in let applied_ind = build_dependent_inductive ind specif in let applied_ind_P = mkApp (mkInd ind, Array.concat @@ -418,8 +418,8 @@ let build_l2r_forward_rew_scheme dep env ind kind = Array.concat [extended_rel_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let varHC = fresh env (id_of_string "HC") in - let varP = fresh env (id_of_string "P") in + let varHC = fresh env (Id.of_string "HC") in + let varP = fresh env (Id.of_string "P") in let applied_ind = build_dependent_inductive ind specif in let applied_ind_P = mkApp (mkInd ind, Array.concat @@ -504,8 +504,8 @@ let build_r2l_forward_rew_scheme dep env ind kind = mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in let constrargs_cstr = constrargs@[cstr 0] in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let varHC = fresh env (id_of_string "HC") in - let varP = fresh env (id_of_string "P") in + let varHC = fresh env (Id.of_string "HC") in + let varP = fresh env (Id.of_string "P") in let applied_ind = build_dependent_inductive ind specif in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in @@ -691,9 +691,9 @@ let build_congr env (eq,refl) ind = if Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt) then error "Constructor must have no arguments"; let b = List.nth constrargs (i + mib.mind_nparams - 1) in - let varB = fresh env (id_of_string "B") in - let varH = fresh env (id_of_string "H") in - let varf = fresh env (id_of_string "f") in + let varB = fresh env (Id.of_string "B") in + let varH = fresh env (Id.of_string "H") in + let varf = fresh env (Id.of_string "f") in let ci = make_case_info (Global.env()) ind RegularStyle in my_it_mkLambda_or_LetIn mib.mind_params_ctxt (mkNamedLambda varB (new_Type ()) diff --git a/tactics/equality.ml b/tactics/equality.ml index 8d457d9f4..1af172bfb 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -399,7 +399,7 @@ let general_multi_rewrite l2r with_evars ?tac c cl = (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) let ids = let ids_in_c = Environ.global_vars_set (Global.env()) (fst c) in - Idset.fold (fun id l -> List.remove id l) ids_in_c (pf_ids_of_hyps gl) + Id.Set.fold (fun id l -> List.remove id l) ids_in_c (pf_ids_of_hyps gl) in do_hyps_atleastonce ids gl in if cl.concl_occs == NoOccurrences then do_hyps else @@ -755,7 +755,7 @@ let discrimination_pf e (t,t1,t2) discriminator lbeq = let eq_elim = ind_scheme_of_eq lbeq in (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term) -let eq_baseid = id_of_string "e" +let eq_baseid = Id.of_string "e" let apply_on_clause (f,t) clause = let sigma = clause.evd in @@ -1140,7 +1140,7 @@ let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause = then ( (* Require Import Eqdec_dec copied from vernac_require in vernacentries.ml*) let qidl = qualid_of_reference - (Ident (Loc.ghost,id_of_string "Eqdep_dec")) in + (Ident (Loc.ghost,Id.of_string "Eqdep_dec")) in Library.require_library [qidl] (Some false); (* cut with the good equality and prove the requested goal *) tclTHENS (cut (mkApp (ceq,new_eq_args)) ) @@ -1394,7 +1394,7 @@ let restrict_to_eq_and_identity eq = (* compatibility *) not (eq_constr eq (constr_of_global glob_identity)) then raise PatternMatchingFailure -exception FoundHyp of (identifier * constr * bool) +exception FoundHyp of (Id.t * constr * bool) (* tests whether hyp [c] is [x = t] or [t = x], [x] not occuring in [t] *) let is_eq_x gl x (id,_,c) = @@ -1412,7 +1412,7 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) gl = (* The set of hypotheses using x *) let depdecls = let test (id,_,c as dcl) = - if not (id_eq id hyp) && occur_var_in_decl (pf_env gl) x dcl then Some dcl + if not (Id.equal id hyp) && occur_var_in_decl (pf_env gl) x dcl then Some dcl else None in List.rev (List.map_filter test (pf_hyps gl)) in let dephyps = List.map (fun (id,_,_) -> id) depdecls in diff --git a/tactics/equality.mli b/tactics/equality.mli index 7b93727ce..ddef64502 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -52,21 +52,21 @@ val rewriteRL : ?tac:(tactic * conditions) -> constr -> tactic (* Warning: old [general_rewrite_in] is now [general_rewrite_bindings_in] *) val register_general_rewrite_clause : - (identifier option -> orientation -> + (Id.t option -> orientation -> occurrences -> constr with_bindings -> new_goals:constr list -> tactic) -> unit val register_is_applied_rewrite_relation : (env -> evar_map -> rel_context -> constr -> constr option) -> unit -val general_rewrite_ebindings_clause : identifier option -> +val general_rewrite_ebindings_clause : Id.t option -> orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic val general_rewrite_bindings_in : orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(tactic * conditions) -> - identifier -> constr with_bindings -> evars_flag -> tactic + Id.t -> constr with_bindings -> evars_flag -> tactic val general_rewrite_in : orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> - ?tac:(tactic * conditions) -> identifier -> constr -> evars_flag -> tactic + ?tac:(tactic * conditions) -> Id.t -> constr -> evars_flag -> tactic val general_multi_rewrite : orientation -> evars_flag -> ?tac:(tactic * conditions) -> constr with_bindings -> clause -> tactic @@ -80,14 +80,14 @@ val general_multi_multi_rewrite : val replace_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic val replace : constr -> constr -> tactic -val replace_in : identifier -> constr -> constr -> tactic +val replace_in : Id.t -> constr -> constr -> tactic val replace_by : constr -> constr -> tactic -> tactic -val replace_in_by : identifier -> constr -> constr -> tactic -> tactic +val replace_in_by : Id.t -> constr -> constr -> tactic -> tactic val discr : evars_flag -> constr with_bindings -> tactic val discrConcl : tactic val discrClause : evars_flag -> clause -> tactic -val discrHyp : identifier -> tactic +val discrHyp : Id.t -> tactic val discrEverywhere : evars_flag -> tactic val discr_tac : evars_flag -> constr with_bindings induction_arg option -> tactic @@ -95,7 +95,7 @@ val inj : intro_pattern_expr Loc.located list -> evars_flag -> constr with_bindings -> tactic val injClause : intro_pattern_expr Loc.located list -> evars_flag -> constr with_bindings induction_arg option -> tactic -val injHyp : identifier -> tactic +val injHyp : Id.t -> tactic val injConcl : tactic val dEq : evars_flag -> constr with_bindings induction_arg option -> tactic @@ -105,29 +105,29 @@ val make_iterated_tuple : env -> evar_map -> constr -> (constr * types) -> constr * constr * constr (* The family cutRewriteIn expect an equality statement *) -val cutRewriteInHyp : bool -> types -> identifier -> tactic +val cutRewriteInHyp : bool -> types -> Id.t -> tactic val cutRewriteInConcl : bool -> constr -> tactic (* The family rewriteIn expect the proof of an equality *) -val rewriteInHyp : bool -> constr -> identifier -> tactic +val rewriteInHyp : bool -> constr -> Id.t -> tactic val rewriteInConcl : bool -> constr -> tactic (* Expect the proof of an equality; fails with raw internal errors *) -val substClause : bool -> constr -> identifier option -> tactic +val substClause : bool -> constr -> Id.t option -> tactic val discriminable : env -> evar_map -> constr -> constr -> bool val injectable : env -> evar_map -> constr -> constr -> bool (* Subst *) -val unfold_body : identifier -> tactic +val unfold_body : Id.t -> tactic type subst_tactic_flags = { only_leibniz : bool; rewrite_dependent_proof : bool } -val subst_gen : bool -> identifier list -> tactic -val subst : identifier list -> tactic +val subst_gen : bool -> Id.t list -> tactic +val subst : Id.t list -> tactic val subst_all : ?flags:subst_tactic_flags -> tactic (* Replace term *) diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli index 9220a60bd..7813f5326 100644 --- a/tactics/evar_tactics.mli +++ b/tactics/evar_tactics.mli @@ -12,6 +12,6 @@ open Tacexpr open Locus val instantiate : int -> Tacinterp.interp_sign * Glob_term.glob_constr -> - (identifier * hyp_location_flag, unit) location -> tactic + (Id.t * hyp_location_flag, unit) location -> tactic val let_evar : name -> Term.types -> tactic diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index 5c2746986..a15f907c6 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -121,8 +121,8 @@ END type 'id gen_place= ('id * hyp_location_flag,unit) location -type loc_place = identifier Loc.located gen_place -type place = identifier gen_place +type loc_place = Id.t Loc.located gen_place +type place = Id.t gen_place let pr_gen_place pr_id = function ConclLocation () -> Pp.mt () diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index 31f51866f..7fc3ac8a5 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -33,21 +33,21 @@ val glob : constr_expr Pcoq.Gram.entry type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location -type loc_place = identifier Loc.located gen_place -type place = identifier gen_place +type loc_place = Id.t Loc.located gen_place +type place = Id.t gen_place val rawwit_hloc : loc_place raw_abstract_argument_type val wit_hloc : place typed_abstract_argument_type val hloc : loc_place Pcoq.Gram.entry val pr_hloc : loc_place -> Pp.std_ppcmds -val in_arg_hyp: (Names.identifier Loc.located list option * bool) Pcoq.Gram.entry -val globwit_in_arg_hyp : (Names.identifier Loc.located list option * bool) glob_abstract_argument_type -val rawwit_in_arg_hyp : (Names.identifier Loc.located list option * bool) raw_abstract_argument_type -val wit_in_arg_hyp : (Names.identifier list option * bool) typed_abstract_argument_type -val raw_in_arg_hyp_to_clause : (Names.identifier Loc.located list option * bool) -> Locus.clause -val glob_in_arg_hyp_to_clause : (Names.identifier list option * bool) -> Locus.clause -val pr_in_arg_hyp : (Names.identifier list option * bool) -> Pp.std_ppcmds +val in_arg_hyp: (Names.Id.t Loc.located list option * bool) Pcoq.Gram.entry +val globwit_in_arg_hyp : (Names.Id.t Loc.located list option * bool) glob_abstract_argument_type +val rawwit_in_arg_hyp : (Names.Id.t Loc.located list option * bool) raw_abstract_argument_type +val wit_in_arg_hyp : (Names.Id.t list option * bool) typed_abstract_argument_type +val raw_in_arg_hyp_to_clause : (Names.Id.t Loc.located list option * bool) -> Locus.clause +val glob_in_arg_hyp_to_clause : (Names.Id.t list option * bool) -> Locus.clause +val pr_in_arg_hyp : (Names.Id.t list option * bool) -> Pp.std_ppcmds val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry val rawwit_by_arg_tac : raw_tactic_expr option raw_abstract_argument_type diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index ade53e768..2cfec1e21 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -551,7 +551,7 @@ let subst_var_with_hole occ tid t = let locref = ref 0 in let rec substrec = function | GVar (_,id) as x -> - if id_eq id tid + if Id.equal id tid then (decr occref; if Int.equal !occref 0 then x @@ -650,7 +650,7 @@ END exception Found of tactic let rewrite_except h g = - tclMAP (fun id -> if id_eq id h then tclIDTAC else + tclMAP (fun id -> if Id.equal id h then tclIDTAC else tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false)) (Tacmach.pf_ids_of_hyps g) g @@ -684,7 +684,7 @@ let case_eq_intros_rewrite x g = mkCaseEq x; (fun g -> let n' = nb_prod (Tacmach.pf_concl g) in - let h = fresh_id (Tacmach.pf_ids_of_hyps g) (id_of_string "heq") g in + let h = fresh_id (Tacmach.pf_ids_of_hyps g) (Id.of_string "heq") g in tclTHENLIST [ (tclDO (n'-n-1) intro); Tacmach.introduction h; rewrite_except h] g diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli index ad72a4aac..306067ff0 100644 --- a/tactics/extratactics.mli +++ b/tactics/extratactics.mli @@ -8,8 +8,8 @@ open Proof_type -val discrHyp : Names.identifier -> tactic -val injHyp : Names.identifier -> tactic +val discrHyp : Names.Id.t -> tactic +val injHyp : Names.Id.t -> tactic val refine_tac : Evd.open_constr -> tactic diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli index 1199fe7a8..47fd9aac2 100644 --- a/tactics/hiddentac.mli +++ b/tactics/hiddentac.mli @@ -25,8 +25,8 @@ open Misctypes (** Basic tactics *) -val h_intro_move : identifier option -> identifier move_location -> tactic -val h_intro : identifier -> tactic +val h_intro_move : Id.t option -> Id.t move_location -> tactic +val h_intro : Id.t -> tactic val h_intros_until : quantified_hypothesis -> tactic val h_assumption : tactic @@ -38,7 +38,7 @@ val h_apply : advanced_flag -> evars_flag -> constr with_bindings located list -> tactic val h_apply_in : advanced_flag -> evars_flag -> constr with_bindings located list -> - identifier * intro_pattern_expr located option -> tactic + Id.t * intro_pattern_expr located option -> tactic val h_elim : evars_flag -> constr with_bindings -> constr with_bindings option -> tactic @@ -46,11 +46,11 @@ val h_elim_type : constr -> tactic val h_case : evars_flag -> constr with_bindings -> tactic val h_case_type : constr -> tactic -val h_mutual_fix : identifier -> int -> - (identifier * int * constr) list -> tactic -val h_fix : identifier option -> int -> tactic -val h_mutual_cofix : identifier -> (identifier * constr) list -> tactic -val h_cofix : identifier option -> tactic +val h_mutual_fix : Id.t -> int -> + (Id.t * int * constr) list -> tactic +val h_fix : Id.t option -> int -> tactic +val h_mutual_cofix : Id.t -> (Id.t * constr) list -> tactic +val h_cofix : Id.t option -> tactic val h_cut : constr -> tactic val h_generalize : constr list -> tactic @@ -90,11 +90,11 @@ val h_lapply : constr -> tactic (** Context management *) -val h_clear : bool -> identifier list -> tactic -val h_clear_body : identifier list -> tactic -val h_move : bool -> identifier -> identifier move_location -> tactic -val h_rename : (identifier*identifier) list -> tactic -val h_revert : identifier list -> tactic +val h_clear : bool -> Id.t list -> tactic +val h_clear_body : Id.t list -> tactic +val h_move : bool -> Id.t -> Id.t move_location -> tactic +val h_rename : (Id.t*Id.t) list -> tactic +val h_revert : Id.t list -> tactic (** Constructors *) val h_constructor : evars_flag -> int -> constr bindings -> tactic diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 65f0e0302..b873c2050 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -288,7 +288,7 @@ let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ] let match_arrow_pattern t = match matches coq_arrow_pattern t with | [(m1,arg);(m2,mind)] -> - assert (id_eq m1 meta1 && id_eq m2 meta2); (arg, mind) + assert (Id.equal m1 meta1 && Id.equal m2 meta2); (arg, mind) | _ -> anomaly "Incorrect pattern matching" let match_with_nottype t = @@ -368,10 +368,10 @@ let match_eq eqn eq_pat = let pat = try Lazy.force eq_pat with _ -> raise PatternMatchingFailure in match matches pat eqn with | [(m1,t);(m2,x);(m3,y)] -> - assert (id_eq m1 meta1 && id_eq m2 meta2 && id_eq m3 meta3); + assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); PolymorphicLeibnizEq (t,x,y) | [(m1,t);(m2,x);(m3,t');(m4,x')] -> - assert (id_eq m1 meta1 && id_eq m2 meta2 && id_eq m3 meta3 && id_eq m4 meta4); + assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4); HeterogenousEq (t,x,t',x') | _ -> anomaly "match_eq: an eq pattern should match 3 or 4 terms" @@ -412,7 +412,7 @@ open Tacmach let match_eq_nf gls eqn eq_pat = match pf_matches gls (Lazy.force eq_pat) eqn with | [(m1,t);(m2,x);(m3,y)] -> - assert (id_eq m1 meta1 && id_eq m2 meta2 && id_eq m3 meta3); + assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); (t,pf_whd_betadeltaiota gls x,pf_whd_betadeltaiota gls y) | _ -> anomaly "match_eq: an eq pattern should match 3 terms" @@ -432,7 +432,7 @@ let coq_exist_pattern = coq_ex_pattern_gen coq_exist_ref let match_sigma ex ex_pat = match matches (Lazy.force ex_pat) ex with | [(m1,a);(m2,p);(m3,car);(m4,cdr)] -> - assert (id_eq m1 meta1 && id_eq m2 meta2 && id_eq m3 meta3 && id_eq m4 meta4); + assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4); (a,p,car,cdr) | _ -> anomaly "match_sigma: a successful sigma pattern should match 4 terms" diff --git a/tactics/inv.ml b/tactics/inv.ml index 1e2d6fa6a..a4f7b5e3f 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -448,7 +448,7 @@ let raw_inversion inv_kind id status names gl = try pf_reduce_to_atomic_ind gl (pf_type_of gl c) with UserError _ -> errorlabstrm "raw_inversion" - (str ("The type of "^(string_of_id id)^" is not inductive.")) in + (str ("The type of "^(Id.to_string id)^" is not inductive.")) in let indclause = mk_clenv_from gl (c,t) in let ccl = clenv_type indclause in check_no_metas indclause ccl; diff --git a/tactics/inv.mli b/tactics/inv.mli index 1266ac9f8..52db199ee 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -21,11 +21,11 @@ val inv_gen : bool -> inversion_kind -> inversion_status -> intro_pattern_expr located option -> quantified_hypothesis -> tactic val invIn_gen : - inversion_kind -> intro_pattern_expr located option -> identifier list -> + inversion_kind -> intro_pattern_expr located option -> Id.t list -> quantified_hypothesis -> tactic val inv_clause : - inversion_kind -> intro_pattern_expr located option -> identifier list -> + inversion_kind -> intro_pattern_expr located option -> Id.t list -> quantified_hypothesis -> tactic val inv : inversion_kind -> intro_pattern_expr located option -> @@ -34,9 +34,9 @@ val inv : inversion_kind -> intro_pattern_expr located option -> val dinv : inversion_kind -> constr option -> intro_pattern_expr located option -> quantified_hypothesis -> tactic -val half_inv_tac : identifier -> tactic -val inv_tac : identifier -> tactic -val inv_clear_tac : identifier -> tactic -val half_dinv_tac : identifier -> tactic -val dinv_tac : identifier -> tactic -val dinv_clear_tac : identifier -> tactic +val half_inv_tac : Id.t -> tactic +val inv_tac : Id.t -> tactic +val inv_clear_tac : Id.t -> tactic +val half_dinv_tac : Id.t -> tactic +val dinv_tac : Id.t -> tactic +val dinv_clear_tac : Id.t -> tactic diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 3031734fb..fa2931c80 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -140,7 +140,7 @@ let rec add_prods_sign env sigma t = let compute_first_inversion_scheme env sigma ind sort dep_option = let indf,realargs = dest_ind_type ind in let allvars = ids_of_context env in - let p = next_ident_away (id_of_string "P") allvars in + let p = next_ident_away (Id.of_string "P") allvars in let pty,goal = if dep_option then let pty = make_arity env true indf sort in @@ -210,7 +210,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = let rec fill_holes c = match kind_of_term c with | Evar (e,args) -> - let h = next_ident_away (id_of_string "H") !avoid in + let h = next_ident_away (Id.of_string "H") !avoid in let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in avoid := h::!avoid; ownSign := add_named_decl (h,None,ty) !ownSign; diff --git a/tactics/leminv.mli b/tactics/leminv.mli index 45538690c..5019ceda5 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -16,14 +16,14 @@ open Constrexpr open Misctypes val lemInv_gen : quantified_hypothesis -> constr -> tactic -val lemInvIn_gen : quantified_hypothesis -> constr -> identifier list -> tactic +val lemInvIn_gen : quantified_hypothesis -> constr -> Id.t list -> tactic val lemInv_clause : - quantified_hypothesis -> constr -> identifier list -> tactic + quantified_hypothesis -> constr -> Id.t list -> tactic val inversion_lemma_from_goal : - int -> identifier -> identifier located -> sorts -> bool -> - (identifier -> tactic) -> unit + int -> Id.t -> Id.t located -> sorts -> bool -> + (Id.t -> tactic) -> unit val add_inversion_lemma_exn : - identifier -> constr_expr -> glob_sort -> bool -> (identifier -> tactic) -> + Id.t -> constr_expr -> glob_sort -> bool -> (Id.t -> tactic) -> unit diff --git a/tactics/refine.ml b/tactics/refine.ml index 3d1e4f010..160bcfc70 100644 --- a/tactics/refine.ml +++ b/tactics/refine.ml @@ -127,7 +127,7 @@ let replace_in_array keep_length env sigma a = v',mm,sgp let fresh env n = - let id = match n with Name x -> x | _ -> id_of_string "_H" in + let id = match n with Name x -> x | _ -> Id.of_string "_H" in next_ident_away_in_goal id (ids_of_named_context (named_context env)) let rec compute_metamap env sigma c = match kind_of_term c with diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4 index d1eda3f7e..e5fddfde2 100644 --- a/tactics/rewrite.ml4 +++ b/tactics/rewrite.ml4 @@ -38,7 +38,7 @@ open Decl_kinds (** Typeclass-based generalized rewriting. *) let classes_dirpath = - make_dirpath (List.map id_of_string ["Classes";"Coq"]) + make_dirpath (List.map Id.of_string ["Classes";"Coq"]) let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () @@ -52,10 +52,10 @@ let proper_proxy_class = let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) -let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) +let make_dir l = make_dirpath (List.map Id.of_string (List.rev l)) let try_find_global_reference dir s = - let sp = Libnames.make_path (make_dir ("Coq"::dir)) (id_of_string s) in + let sp = Libnames.make_path (make_dir ("Coq"::dir)) (Id.of_string s) in Nametab.global_of_path sp let try_find_reference dir s = @@ -229,8 +229,8 @@ let rec decompose_app_rel env evd t = else let (f', args) = decompose_app_rel env evd args.(0) in let ty = Typing.type_of env evd args.(0) in - let f'' = mkLambda (Name (id_of_string "x"), ty, - mkLambda (Name (id_of_string "y"), lift 1 ty, + let f'' = mkLambda (Name (Id.of_string "x"), ty, + mkLambda (Name (Id.of_string "y"), lift 1 ty, mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) in (f'', args) | _ -> error "The term provided is not an applied relation." @@ -270,7 +270,7 @@ let decompose_applied_relation_expr env sigma flags (is, (c,l)) left2right = let rewrite_db = "rewrite" -let conv_transparent_state = (Idpred.empty, Cpred.full) +let conv_transparent_state = (Id.Pred.empty, Cpred.full) let _ = Auto.add_auto_init @@ -543,7 +543,7 @@ type rewrite_result_info = { type rewrite_result = rewrite_result_info option -type strategy = Environ.env -> identifier list -> constr -> types -> +type strategy = Environ.env -> Id.t list -> constr -> types -> constr option -> evars -> rewrite_result option let get_rew_rel r = match r.rew_prf with @@ -588,7 +588,7 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars let cl_args = [| appmtype' ; signature ; appm |] in let app = mkApp (Lazy.force proper_type, cl_args) in let env' = Environ.push_named - (id_of_string "do_subrelation", Some (Lazy.force do_subrelation), Lazy.force apply_subrelation) + (Id.of_string "do_subrelation", Some (Lazy.force do_subrelation), Lazy.force apply_subrelation) env in let evars, morph = new_cstr_evar evars env' app in @@ -1150,7 +1150,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul match abs with | None -> p | Some (t, ty) -> - mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) + mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) in Some (evars, Some (mkApp (term, [| mkVar id |])), newt) | RewCast c -> @@ -1162,7 +1162,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul (match abs with | None -> Some (evars, Some p, newt) | Some (t, ty) -> - let proof = mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) in + let proof = mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) in Some (evars, Some proof, newt)) | RewCast c -> Some (evars, None, newt)) in Some res @@ -1232,7 +1232,7 @@ let assert_replacing id newt tac = let nc' = Environ.fold_named_context (fun _ (n, b, t as decl) nc' -> - if id_eq n id then (n, b, newt) :: nc' + if Id.equal n id then (n, b, newt) :: nc' else decl :: nc') env ~init:[] in @@ -1246,7 +1246,7 @@ let assert_replacing id newt tac = let inst = fold_named_context (fun _ (n, b, t) inst -> - if id_eq n id then ev' :: inst + if Id.equal n id then ev' :: inst else if Option.is_empty b then mkVar n :: inst else inst) env ~init:[] in @@ -1524,7 +1524,7 @@ TACTIC EXTEND rewrite_strat END let clsubstitute o c = - let is_tac id = match fst (fst (snd c)) with GVar (_, id') when id_eq id' id -> true | _ -> false in + let is_tac id = match fst (fst (snd c)) with GVar (_, id') when Id.equal id' id -> true | _ -> false in Tacticals.onAllHypsAndConcl (fun cl -> match cl with @@ -1570,7 +1570,7 @@ TACTIC EXTEND GenRew [ cl_rewrite_clause_newtac_tac c o AllOccurrences None ] END -let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,id_of_string s))),l) +let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s))),l) let declare_an_instance n s args = ((Loc.ghost,Name n), Explicit, @@ -1586,17 +1586,17 @@ let anew_instance global binders instance fields = let declare_instance_refl global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" in anew_instance global binders instance - [(Ident (Loc.ghost,id_of_string "reflexivity"),lemma)] + [(Ident (Loc.ghost,Id.of_string "reflexivity"),lemma)] let declare_instance_sym global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" in anew_instance global binders instance - [(Ident (Loc.ghost,id_of_string "symmetry"),lemma)] + [(Ident (Loc.ghost,Id.of_string "symmetry"),lemma)] let declare_instance_trans global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" in anew_instance global binders instance - [(Ident (Loc.ghost,id_of_string "transitivity"),lemma)] + [(Ident (Loc.ghost,Id.of_string "transitivity"),lemma)] let declare_relation ?(binders=[]) a aeq n refl symm trans = init_setoid (); @@ -1620,16 +1620,16 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in ignore( anew_instance global binders instance - [(Ident (Loc.ghost,id_of_string "PreOrder_Reflexive"), lemma1); - (Ident (Loc.ghost,id_of_string "PreOrder_Transitive"),lemma3)]) + [(Ident (Loc.ghost,Id.of_string "PreOrder_Reflexive"), lemma1); + (Ident (Loc.ghost,Id.of_string "PreOrder_Transitive"),lemma3)]) | (None, Some lemma2, Some lemma3) -> let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in ignore( anew_instance global binders instance - [(Ident (Loc.ghost,id_of_string "PER_Symmetric"), lemma2); - (Ident (Loc.ghost,id_of_string "PER_Transitive"),lemma3)]) + [(Ident (Loc.ghost,Id.of_string "PER_Symmetric"), lemma2); + (Ident (Loc.ghost,Id.of_string "PER_Transitive"),lemma3)]) | (Some lemma1, Some lemma2, Some lemma3) -> let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in @@ -1637,9 +1637,9 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance global binders instance - [(Ident (Loc.ghost,id_of_string "Equivalence_Reflexive"), lemma1); - (Ident (Loc.ghost,id_of_string "Equivalence_Symmetric"), lemma2); - (Ident (Loc.ghost,id_of_string "Equivalence_Transitive"), lemma3)]) + [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), lemma1); + (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), lemma2); + (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), lemma3)]) type 'a binders_argtype = (local_binder list, 'a) Genarg.abstract_argument_type @@ -1815,9 +1815,9 @@ let add_setoid global binders a aeq t n = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance global binders instance - [(Ident (Loc.ghost,id_of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); - (Ident (Loc.ghost,id_of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - (Ident (Loc.ghost,id_of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); + (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); + (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) let add_morphism_infer glob m n = init_setoid (); diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 9a8774b11..0f2ac6cfe 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -53,9 +53,9 @@ let skip_metaid = function (** Generic arguments *) type glob_sign = { - ltacvars : identifier list * identifier list; + ltacvars : Id.t list * Id.t list; (* ltac variables and the subset of vars introduced by Intro/Let/... *) - ltacrecvars : (identifier * ltac_constant) list; + ltacrecvars : (Id.t * ltac_constant) list; (* ltac recursive names *) gsigma : Evd.evar_map; genv : Environ.env } @@ -87,10 +87,10 @@ let lookup_intern_genarg id = (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) -let atomic_mactab = ref Idmap.empty +let atomic_mactab = ref Id.Map.empty let add_primitive_tactic s tac = - let id = id_of_string s in - atomic_mactab := Idmap.add id tac !atomic_mactab + let id = Id.of_string s in + atomic_mactab := Id.Map.add id tac !atomic_mactab let _ = let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in @@ -124,10 +124,10 @@ let _ = "fresh", TacArg(dloc,TacFreshId []) ] -let lookup_atomic id = Idmap.find id !atomic_mactab +let lookup_atomic id = Id.Map.find id !atomic_mactab let is_atomic_kn kn = let (_,_,l) = repr_kn kn in - Idmap.mem (id_of_label l) !atomic_mactab + Id.Map.mem (id_of_label l) !atomic_mactab (* Tactics table (TacExtend). *) @@ -753,7 +753,7 @@ and intern_tacarg strict onlytac ist = function | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) | MetaIdArg (loc,istac,s) -> (* $id can occur in Grammar tactic... *) - let id = id_of_string s in + let id = Id.of_string s in if find_ltacvar id ist then if istac then Reference (ArgVar (adjust_loc loc,id)) else ConstrMayEval (ConstrTerm (GVar (adjust_loc loc,id), None)) @@ -865,7 +865,7 @@ let add (kn,td) = mactab := Gmap.add kn td !mactab let replace (kn,td) = mactab := Gmap.add kn td (Gmap.remove kn !mactab) type tacdef_kind = - | NewTac of identifier + | NewTac of Id.t | UpdateTac of ltac_constant let load_md i ((sp,kn),(local,defs)) = diff --git a/tactics/tacintern.mli b/tactics/tacintern.mli index 69a708d23..5f302f1b9 100644 --- a/tactics/tacintern.mli +++ b/tactics/tacintern.mli @@ -24,8 +24,8 @@ open Nametab Conversion from [raw_tactic_expr] to [glob_tactic_expr] *) type glob_sign = { - ltacvars : identifier list * identifier list; - ltacrecvars : (identifier * ltac_constant) list; + ltacvars : Id.t list * Id.t list; + ltacrecvars : (Id.t * ltac_constant) list; gsigma : Evd.evar_map; genv : Environ.env } @@ -40,7 +40,7 @@ val make_empty_glob_sign : unit -> glob_sign val glob_tactic : raw_tactic_expr -> glob_tactic_expr val glob_tactic_env : - identifier list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr + Id.t list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr (** Low-level variants *) @@ -55,7 +55,7 @@ val intern_constr_with_bindings : glob_sign -> constr_expr * constr_expr bindings -> glob_constr_and_expr * glob_constr_and_expr bindings -val intern_hyp : glob_sign -> identifier Loc.located -> identifier Loc.located +val intern_hyp : glob_sign -> Id.t Loc.located -> Id.t Loc.located (** Adds a globalization function for extra generic arguments *) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 3f7cbb625..3db2328e2 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -53,8 +53,8 @@ let safe_msgnl s = type value = | VRTactic of (goal list sigma) (* For Match results *) (* Not a true value *) - | VFun of ltac_trace * (identifier*value) list * - identifier option list * glob_tactic_expr + | VFun of ltac_trace * (Id.t*value) list * + Id.t option list * glob_tactic_expr | VVoid | VInteger of int | VIntroPattern of intro_pattern_expr (* includes idents which are not *) @@ -64,7 +64,7 @@ type value = (* includes idents known to be bound and references *) | VConstr_context of constr | VList of value list - | VRec of (identifier*value) list ref * glob_tactic_expr + | VRec of (Id.t*value) list ref * glob_tactic_expr let dloc = Loc.ghost @@ -83,8 +83,8 @@ let catch_error call_trace tac g = (* Signature for interpretation: val_interp and interpretation functions *) type interp_sign = - { lfun : (identifier * value) list; - avoid_ids : identifier list; (* ids inherited from the call context + { lfun : (Id.t * value) list; + avoid_ids : Id.t list; (* ids inherited from the call context (needed to get fresh ids) *) debug : debug_info; trace : ltac_trace } @@ -234,7 +234,7 @@ let try_interp_ltac_var coerce ist env (loc,id) = let interp_ltac_var coerce ist env locid = try try_interp_ltac_var coerce ist env locid - with Not_found -> anomaly ("Detected '" ^ (string_of_id (snd locid)) ^ "' as ltac var at interning time") + with Not_found -> anomaly ("Detected '" ^ (Id.to_string (snd locid)) ^ "' as ltac var at interning time") (* Interprets an identifier which must be fresh *) let coerce_to_ident fresh env = function @@ -271,11 +271,11 @@ let interp_intro_pattern_var loc ist env id = with Not_found -> IntroIdentifier id let coerce_to_hint_base = function - | VIntroPattern (IntroIdentifier id) -> string_of_id id + | VIntroPattern (IntroIdentifier id) -> Id.to_string id | _ -> raise (CannotCoerceTo "a hint base name") let interp_hint_base ist s = - try try_interp_ltac_var coerce_to_hint_base ist None (dloc,id_of_string s) + try try_interp_ltac_var coerce_to_hint_base ist None (dloc,Id.of_string s) with Not_found -> s let coerce_to_int = function @@ -438,7 +438,7 @@ let rec extract_ids ids = function | _::tl -> extract_ids ids tl | [] -> [] -let default_fresh_id = id_of_string "H" +let default_fresh_id = Id.of_string "H" let interp_fresh_id ist env l = let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in @@ -449,9 +449,9 @@ let interp_fresh_id ist env l = let s = String.concat "" (List.map (function | ArgArg s -> s - | ArgVar (_,id) -> string_of_id (interp_ident ist env id)) l) in + | ArgVar (_,id) -> Id.to_string (interp_ident ist env id)) l) in let s = if Lexer.is_keyword s then s^"0" else s in - id_of_string s in + Id.of_string s in Tactics.fresh_id_in_env avoid id env let pf_interp_fresh_id ist gl = interp_fresh_id ist (pf_env gl) @@ -831,7 +831,7 @@ let read_pattern lfun ist env sigma = function let cons_and_check_name id l = if List.mem id l then user_err_loc (dloc,"read_match_goal_hyps", - strbrk ("Hypothesis pattern-matching variable "^(string_of_id id)^ + strbrk ("Hypothesis pattern-matching variable "^(Id.to_string id)^ " used twice in the same pattern.")) else id::l @@ -866,7 +866,7 @@ let equal_instances gl (ctx',c') (ctx,c) = (* How to compare instances? Do we want the terms to be convertible? unifiable? Do we want the universe levels to be relevant? (historically, conv_x is used) *) - List.equal id_eq ctx ctx' && pf_conv_x gl c' c + List.equal Id.equal ctx ctx' && pf_conv_x gl c' c (* Verifies if the matched list is coherent with respect to lcm *) (* While non-linear matching is modulo eq_constr in matches, merge of *) @@ -874,7 +874,7 @@ let equal_instances gl (ctx',c') (ctx,c) = let verify_metas_coherence gl (ln1,lcm) (ln,lm) = let rec aux = function | (id,c as x)::tl -> - if List.for_all (fun (id',c') -> not (id_eq id' id) || equal_instances gl c' c) lcm + if List.for_all (fun (id',c') -> not (Id.equal id' id) || equal_instances gl c' c) lcm then x :: aux tl else @@ -1496,13 +1496,13 @@ and interp_ltac_constr ist gl e = str "instantiated arguments " ++ fnl() ++ List.fold_right (fun p s -> - let (i,v) = p in str (string_of_id i) ++ str ", " ++ s) + let (i,v) = p in str (Id.to_string i) ++ str ", " ++ s) il (str "") ++ str "uninstantiated arguments " ++ fnl() ++ List.fold_right (fun opt_id s -> (match opt_id with - Some id -> str (string_of_id id) + Some id -> str (Id.to_string id) | None -> str "_") ++ str ", " ++ s) ul (mt())) | VVoid -> str "VVoid" diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 1401bab4e..eba62f5d7 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -22,20 +22,20 @@ open Misctypes (** Values for interpretation *) type value = | VRTactic of (goal list sigma) - | VFun of ltac_trace * (identifier*value) list * - identifier option list * glob_tactic_expr + | VFun of ltac_trace * (Id.t*value) list * + Id.t option list * glob_tactic_expr | VVoid | VInteger of int | VIntroPattern of intro_pattern_expr | VConstr of Pattern.constr_under_binders | VConstr_context of constr | VList of value list - | VRec of (identifier*value) list ref * glob_tactic_expr + | VRec of (Id.t*value) list ref * glob_tactic_expr (** Signature for interpretation: val\_interp and interpretation functions *) and interp_sign = - { lfun : (identifier * value) list; - avoid_ids : identifier list; + { lfun : (Id.t * value) list; + avoid_ids : Id.t list; debug : debug_info; trace : ltac_trace } @@ -79,7 +79,7 @@ val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map (** Interprets tactic expressions *) -val interp_hyp : interp_sign -> goal sigma -> identifier Loc.located -> identifier +val interp_hyp : interp_sign -> goal sigma -> Id.t Loc.located -> Id.t val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> glob_constr_and_expr bindings -> Evd.evar_map * constr bindings @@ -93,7 +93,7 @@ val eval_tactic : glob_tactic_expr -> tactic (** Globalization + interpretation *) -val interp_tac_gen : (identifier * value) list -> identifier list -> +val interp_tac_gen : (Id.t * value) list -> Id.t list -> debug_info -> raw_tactic_expr -> tactic val interp : raw_tactic_expr -> tactic @@ -112,8 +112,8 @@ val declare_xml_printer : exception CannotCoerceTo of string -val interp_ltac_var : (value -> 'a) -> interp_sign -> Environ.env option -> identifier Loc.located -> 'a +val interp_ltac_var : (value -> 'a) -> interp_sign -> Environ.env option -> Id.t Loc.located -> 'a -val interp_int : interp_sign -> identifier Loc.located -> int +val interp_int : interp_sign -> Id.t Loc.located -> int -val error_ltac_variable : Loc.t -> identifier -> Environ.env option -> value -> string -> 'a +val error_ltac_variable : Loc.t -> Id.t -> Environ.env option -> value -> string -> 'a diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 68d4890fd..9b32f108c 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -109,7 +109,7 @@ let onNLastHypsId n tac = onHyps (nLastHypsId n) tac let onNLastHyps n tac = onHyps (nLastHyps n) tac let afterHyp id gl = - fst (List.split_when (fun (hyp,_,_) -> id_eq hyp id) (pf_hyps gl)) + fst (List.split_when (fun (hyp,_,_) -> Id.equal hyp id) (pf_hyps gl)) (***************************************) (* Clause Tacticals *) @@ -249,7 +249,7 @@ let general_elim_then_using mk_elim let name_elim = match kind_of_term elim with | Const kn -> string_of_con kn - | Var id -> string_of_id id + | Var id -> Id.to_string id | _ -> "\b" in error ("The elimination combinator " ^ name_elim ^ " is unknown.") diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 61b80b584..1d97e2b94 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -69,28 +69,28 @@ val tclFIRST_PROGRESS_ON : ('a -> tactic) -> 'a list -> tactic (** {6 Tacticals applying to hypotheses } *) -val onNthHypId : int -> (identifier -> tactic) -> tactic +val onNthHypId : int -> (Id.t -> tactic) -> tactic val onNthHyp : int -> (constr -> tactic) -> tactic val onNthDecl : int -> (named_declaration -> tactic) -> tactic -val onLastHypId : (identifier -> tactic) -> tactic +val onLastHypId : (Id.t -> tactic) -> tactic val onLastHyp : (constr -> tactic) -> tactic val onLastDecl : (named_declaration -> tactic) -> tactic -val onNLastHypsId : int -> (identifier list -> tactic) -> tactic +val onNLastHypsId : int -> (Id.t list -> tactic) -> tactic val onNLastHyps : int -> (constr list -> tactic) -> tactic val onNLastDecls : int -> (named_context -> tactic) -> tactic -val lastHypId : goal sigma -> identifier +val lastHypId : goal sigma -> Id.t val lastHyp : goal sigma -> constr val lastDecl : goal sigma -> named_declaration -val nLastHypsId : int -> goal sigma -> identifier list +val nLastHypsId : int -> goal sigma -> Id.t list val nLastHyps : int -> goal sigma -> constr list val nLastDecls : int -> goal sigma -> named_context -val afterHyp : identifier -> goal sigma -> named_context +val afterHyp : Id.t -> goal sigma -> named_context -val ifOnHyp : (identifier * types -> bool) -> - (identifier -> tactic) -> (identifier -> tactic) -> - identifier -> tactic +val ifOnHyp : (Id.t * types -> bool) -> + (Id.t -> tactic) -> (Id.t -> tactic) -> + Id.t -> tactic val onHyps : (goal sigma -> named_context) -> (named_context -> tactic) -> tactic @@ -101,14 +101,14 @@ val onHyps : (goal sigma -> named_context) -> goal; in particular, it can abstractly refer to the set of hypotheses independently of the effective contents of the current goal *) -val tryAllHyps : (identifier -> tactic) -> tactic -val tryAllHypsAndConcl : (identifier option -> tactic) -> tactic +val tryAllHyps : (Id.t -> tactic) -> tactic +val tryAllHypsAndConcl : (Id.t option -> tactic) -> tactic -val onAllHyps : (identifier -> tactic) -> tactic -val onAllHypsAndConcl : (identifier option -> tactic) -> tactic +val onAllHyps : (Id.t -> tactic) -> tactic +val onAllHypsAndConcl : (Id.t option -> tactic) -> tactic -val onClause : (identifier option -> tactic) -> clause -> tactic -val onClauseLR : (identifier option -> tactic) -> clause -> tactic +val onClause : (Id.t option -> tactic) -> clause -> tactic +val onClauseLR : (Id.t option -> tactic) -> clause -> tactic (** {6 Elimination tacticals. } *) @@ -141,8 +141,8 @@ val compute_induction_names : intro_pattern_expr located list array val elimination_sort_of_goal : goal sigma -> sorts_family -val elimination_sort_of_hyp : identifier -> goal sigma -> sorts_family -val elimination_sort_of_clause : identifier option -> goal sigma -> sorts_family +val elimination_sort_of_hyp : Id.t -> goal sigma -> sorts_family +val elimination_sort_of_clause : Id.t option -> goal sigma -> sorts_family val general_elim_then_using : (inductive -> goal sigma -> constr) -> rec_flag -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 966309395..f6f939ed3 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -94,7 +94,7 @@ let string_of_inductive c = try match kind_of_term c with | Ind ind_sp -> let (mib,mip) = Global.lookup_inductive ind_sp in - string_of_id mip.mind_typename + Id.to_string mip.mind_typename | _ -> raise Bound with Bound -> error "Bound head variable." @@ -373,8 +373,8 @@ let id_of_name_with_default id = function | Anonymous -> id | Name id -> id -let hid = id_of_string "H" -let xid = id_of_string "X" +let hid = Id.of_string "H" +let xid = Id.of_string "X" let default_id_of_sort = function Prop _ -> hid | Type _ -> xid @@ -389,9 +389,9 @@ let default_id env sigma = function possibly a move to do after the introduction *) type intro_name_flag = - | IntroAvoid of identifier list - | IntroBasedOn of identifier * identifier list - | IntroMustBe of identifier + | IntroAvoid of Id.t list + | IntroBasedOn of Id.t * Id.t list + | IntroMustBe of Id.t let find_name loc decl gl = function | IntroAvoid idl -> @@ -401,7 +401,7 @@ let find_name loc decl gl = function | IntroMustBe id -> (* When name is given, we allow to hide a global name *) let id' = next_ident_away id (pf_ids_of_hyps gl) in - if not (id_eq id' id) then user_err_loc (loc,"",pr_id id ++ str" is already used."); + if not (Id.equal id' id) then user_err_loc (loc,"",pr_id id ++ str" is already used."); id' (* Returns the names that would be created by intros, without doing @@ -468,9 +468,9 @@ let intro_forthcoming_then_gen loc name_flag move_flag dep_flag tac = aux [] let rec get_next_hyp_position id = function - | [] -> error ("No such hypothesis: " ^ string_of_id id) + | [] -> error ("No such hypothesis: " ^ Id.to_string id) | (hyp,_,_) :: right -> - if id_eq hyp id then + if Id.equal hyp id then match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveLast else get_next_hyp_position id right @@ -919,7 +919,7 @@ let descend_in_conjunctions tac exit c gl = | Some (_,_,isrec) -> let n = (mis_constr_nargs ind).(0) in let sort = elimination_sort_of_goal gl in - let id = fresh_id [] (id_of_string "H") gl in + let id = fresh_id [] (Id.of_string "H") gl in let IndType (indf,_) = pf_apply find_rectype gl ccl in let params = snd (dest_ind_family indf) in let cstr = (get_constructors (pf_env gl) indf).(0) in @@ -1137,7 +1137,7 @@ let clear_wildcards ids = with ClearDependencyError (id,err) -> (* Intercept standard [thin] error message *) Loc.raise loc - (error_clear_dependency (pf_env gl) (id_of_string "_") err)) + (error_clear_dependency (pf_env gl) (Id.of_string "_") err)) ids (* Takes a list of booleans, and introduces all the variables @@ -1347,17 +1347,17 @@ let rec explicit_intro_names = function | [] -> [] -let wild_id = id_of_string "_tmp" +let wild_id = Id.of_string "_tmp" let rec list_mem_assoc_right id = function | [] -> false - | (x,id')::l -> id_eq id id' || list_mem_assoc_right id l + | (x,id')::l -> Id.equal id id' || list_mem_assoc_right id l let check_thin_clash_then id thin avoid tac = if list_mem_assoc_right id thin then let newid = next_ident_away (add_suffix id "'") avoid in let thin = - List.map (on_snd (fun id' -> if id_eq id id' then newid else id')) thin in + List.map (on_snd (fun id' -> if Id.equal id id' then newid else id')) thin in tclTHEN (rename_hyp [id,newid]) (tac thin) else tac thin @@ -1441,7 +1441,7 @@ let ipat_of_name = function let allow_replace c gl = function (* A rather arbitrary condition... *) | Some (_, IntroIdentifier id) -> let c = fst (decompose_app ((strip_lam_assum c))) in - isVar c && id_eq (destVar c) id + isVar c && Id.equal (destVar c) id | _ -> false @@ -1631,7 +1631,7 @@ let out_arg = function let occurrences_of_hyp id cls = let rec hyp_occ = function [] -> None - | ((occs,id'),hl)::_ when id_eq id id' -> + | ((occs,id'),hl)::_ when Id.equal id id' -> Some (occurrences_map (List.map out_arg) occs, hl) | _::l -> hyp_occ l in match cls.onhyps with @@ -1684,7 +1684,7 @@ let letin_tac with_eq name c occs gl = let id = if name = Anonymous then fresh_id [] x gl else if not (mem_named_context x (pf_hyps gl)) then x else - error ("The variable "^(string_of_id x)^" is already declared") in + error ("The variable "^(Id.to_string x)^" is already declared") in let (depdecls,marks,ccl)= letin_abstract id c occs gl in let t = pf_type_of gl c in let tmpcl = List.fold_right mkNamedProd_or_LetIn depdecls ccl in @@ -1767,7 +1767,7 @@ let letin_tac_gen with_eq name (sigmac,c) test ty occs gl = let x = id_of_name_using_hdchar (Global.env()) t name in if name == Anonymous then fresh_id [] x gl else if not (mem_named_context x (pf_hyps gl)) then x else - error ("The variable "^(string_of_id x)^" is already declared.") in + error ("The variable "^(Id.to_string x)^" is already declared.") in let (depdecls,lastlhyp,ccl,c) = letin_abstract id c test occs gl in let t = match ty with Some t -> t | None -> pf_apply typ_of gl c in let newcl,eq_tac = match with_eq with @@ -1925,7 +1925,7 @@ let safe_dest_intros_patterns avoid thin dest pat tac gl = type elim_arg_kind = RecArg | IndArg | OtherArg type recarg_position = - | AfterFixedPosition of identifier option (* None = top of context *) + | AfterFixedPosition of Id.t option (* None = top of context *) let update_dest (recargdests,tophyp as dests) = function | [] -> dests @@ -2035,15 +2035,15 @@ let find_atomic_param_of_ind nparams indtyp = let argl = snd (decompose_app indtyp) in let argv = Array.of_list argl in let params = List.firstn nparams argl in - let indvars = ref Idset.empty in + let indvars = ref Id.Set.empty in for i = nparams to (Array.length argv)-1 do match kind_of_term argv.(i) with | Var id when not (List.exists (occur_var (Global.env()) id) params) -> - indvars := Idset.add id !indvars + indvars := Id.Set.add id !indvars | _ -> () done; - Idset.elements !indvars; + Id.Set.elements !indvars; (* [cook_sign] builds the lists [indhyps] of hyps that must be @@ -2109,7 +2109,7 @@ let find_atomic_param_of_ind nparams indtyp = *) -exception Shunt of identifier move_location +exception Shunt of Id.t move_location let cook_sign hyp0_opt indvars env = let hyp0,inhyps = @@ -2126,7 +2126,7 @@ let cook_sign hyp0_opt indvars env = let lstatus = ref [] in let before = ref true in let seek_deps env (hyp,_,_ as decl) rhyp = - if id_eq hyp hyp0 then begin + if Id.equal hyp hyp0 then begin before:=false; (* If there was no main induction hypotheses, then hyp is one of indvars too, so add it to indhyps. *) @@ -2154,7 +2154,7 @@ let cook_sign hyp0_opt indvars env = let _ = fold_named_context seek_deps env ~init:MoveFirst in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) let compute_lstatus lhyp (hyp,_,_) = - if id_eq hyp hyp0 then raise (Shunt lhyp); + if Id.equal hyp hyp0 then raise (Shunt lhyp); if List.mem hyp !ldeps then begin lstatus := (hyp,lhyp)::!lstatus; lhyp @@ -2246,19 +2246,19 @@ let make_base n id = else (* This extends the name to accept new digits if it already ends with *) (* digits *) - id_of_string (atompart_of_id (make_ident (string_of_id id) (Some 0))) + Id.of_string (atompart_of_id (make_ident (Id.to_string id) (Some 0))) (* Builds two different names from an optional inductive type and a number, also deals with a list of names to avoid. If the inductive type is None, then hyprecname is IHi where i is a number. *) let make_up_names n ind_opt cname = let is_hyp = String.equal (atompart_of_id cname) "H" in - let base = string_of_id (make_base n cname) in + let base = Id.to_string (make_base n cname) in let ind_prefix = "IH" in let base_ind = if is_hyp then match ind_opt with - | None -> id_of_string ind_prefix + | None -> Id.of_string ind_prefix | Some ind_id -> add_prefix ind_prefix (Nametab.basename_of_global ind_id) else add_prefix ind_prefix cname in let hyprecname = make_base n base_ind in @@ -2268,12 +2268,12 @@ let make_up_names n ind_opt cname = (* Forbid to use cname, cname0, hyprecname and hyprecname0 *) (* in order to get names such as f1, f2, ... *) let avoid = - (make_ident (string_of_id hyprecname) None) :: - (make_ident (string_of_id hyprecname) (Some 0)) :: [] in + (make_ident (Id.to_string hyprecname) None) :: + (make_ident (Id.to_string hyprecname) (Some 0)) :: [] in if not (String.equal (atompart_of_id cname) "H") then (make_ident base (Some 0)) :: (make_ident base None) :: avoid else avoid in - id_of_string base, hyprecname, avoid + Id.of_string base, hyprecname, avoid let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in @@ -2312,7 +2312,7 @@ let lift_list l = List.map (lift 1) l let ids_of_constr ?(all=false) vars c = let rec aux vars c = match kind_of_term c with - | Var id -> Idset.add id vars + | Var id -> Id.Set.add id vars | App (f, args) -> (match kind_of_term f with | Construct (ind,_) @@ -2371,17 +2371,17 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls = mkApp (appeqs, abshypt) let hyps_of_vars env sign nogen hyps = - if Idset.is_empty hyps then [] + if Id.Set.is_empty hyps then [] else let (_,lh) = Sign.fold_named_context_reverse (fun (hs,hl) (x,_,_ as d) -> - if Idset.mem x nogen then (hs,hl) - else if Idset.mem x hs then (hs,x::hl) + if Id.Set.mem x nogen then (hs,hl) + else if Id.Set.mem x hs then (hs,x::hl) else let xvars = global_vars_set_of_decl env d in - if not (Idset.equal (Idset.diff xvars hs) Idset.empty) then - (Idset.add x hs, x :: hl) + if not (Id.Set.equal (Id.Set.diff xvars hs) Id.Set.empty) then + (Id.Set.add x hs, x :: hl) else (hs, hl)) ~init:(hyps,[]) sign @@ -2393,11 +2393,11 @@ let linear vars args = let seen = ref vars in try Array.iter (fun i -> - let rels = ids_of_constr ~all:true Idset.empty i in + let rels = ids_of_constr ~all:true Id.Set.empty i in let seen' = - Idset.fold (fun id acc -> - if Idset.mem id acc then raise Seen - else Idset.add id acc) + Id.Set.fold (fun id acc -> + if Id.Set.mem id acc then raise Seen + else Id.Set.add id acc) rels !seen in seen := seen') args; @@ -2415,7 +2415,7 @@ let abstract_args gl generalize_vars dep id defined f args = let dep = dep || dependent (mkVar id) concl in let avoid = ref [] in let get_id name = - let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> id_of_string "gen_x") gl in + let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") gl in avoid := id :: !avoid; id in (* Build application generalized w.r.t. the argument plus the necessary eqs. @@ -2436,9 +2436,9 @@ let abstract_args gl generalize_vars dep id defined f args = let liftargty = lift lenctx argty in let leq = constr_cmp Reduction.CUMUL liftargty ty in match kind_of_term arg with - | Var id when not (is_defined_variable env id) && leq && not (Idset.mem id nongenvars) -> + | Var id when not (is_defined_variable env id) && leq && not (Id.Set.mem id nongenvars) -> (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, - Idset.add id nongenvars, Idset.remove id vars, env) + Id.Set.add id nongenvars, Id.Set.remove id vars, env) | _ -> let name = get_id name in let decl = (Name name, None, ty) in @@ -2456,11 +2456,11 @@ let abstract_args gl generalize_vars dep id defined f args = let refls = refl :: refls in let argvars = ids_of_constr vars arg in (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, - nongenvars, Idset.union argvars vars, env) + nongenvars, Id.Set.union argvars vars, env) in let f', args' = decompose_indapp f args in let dogen, f', args' = - let parvars = ids_of_constr ~all:true Idset.empty f' in + let parvars = ids_of_constr ~all:true Id.Set.empty f' in if not (linear parvars args') then true, f, args else match Array.findi (fun i x -> not (isVar x) || is_defined_variable env (destVar x)) args' with @@ -2471,12 +2471,12 @@ let abstract_args gl generalize_vars dep id defined f args = in if dogen then let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = - Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],Idset.empty,Idset.empty,env) args' + Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' in let args, refls = List.rev args, List.rev refls in let vars = if generalize_vars then - let nogen = Idset.add id nogen in + let nogen = Id.Set.add id nogen in hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars else [] in @@ -2674,7 +2674,7 @@ let compute_elim_sig ?elimc elimt = let params_preds,branches,args_indargs,conclusion = decompose_paramspred_branch_args elimt in - let ccl = exchange_hd_app (mkVar (id_of_string "__QI_DUMMY__")) conclusion in + let ccl = exchange_hd_app (mkVar (Id.of_string "__QI_DUMMY__")) conclusion in let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in let nparams = Int.Set.cardinal (free_rels concl_with_args) in let preds,params = cut_list (List.length params_preds - nparams) params_preds in @@ -2833,11 +2833,11 @@ let find_elim isrec elim hyp0 gl = | Some e -> given_elim hyp0 e gl type scheme_signature = - (identifier list * (elim_arg_kind * bool * identifier) list) array + (Id.t list * (elim_arg_kind * bool * Id.t) list) array type eliminator_source = | ElimUsing of (eliminator * types) * scheme_signature - | ElimOver of bool * identifier + | ElimOver of bool * Id.t let find_induction_type isrec elim hyp0 gl = let scheme,elim = @@ -3299,7 +3299,7 @@ let andE id gl = (tclTHEN (simplest_elim (mkVar id)) (tclDO 2 intro)) gl else errorlabstrm "andE" - (str("Tactic andE expects "^(string_of_id id)^" is a conjunction.")) + (str("Tactic andE expects "^(Id.to_string id)^" is a conjunction.")) let dAnd cls = onClause @@ -3314,7 +3314,7 @@ let orE id gl = (tclTHEN (simplest_elim (mkVar id)) intro) gl else errorlabstrm "orE" - (str("Tactic orE expects "^(string_of_id id)^" is a disjunction.")) + (str("Tactic orE expects "^(Id.to_string id)^" is a disjunction.")) let dorE b cls = onClause @@ -3332,7 +3332,7 @@ let impE id gl = (apply_term (mkVar id) [mkMeta (new_meta())]) gl else errorlabstrm "impE" - (str("Tactic impE expects "^(string_of_id id)^ + (str("Tactic impE expects "^(Id.to_string id)^ " is a an implication.")) let dImp cls = diff --git a/tactics/tactics.mli b/tactics/tactics.mli index f33ef1bc5..041edd250 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -38,44 +38,44 @@ open Locus val string_of_inductive : constr -> string val head_constr : constr -> constr * constr list val head_constr_bound : constr -> constr * constr list -val is_quantified_hypothesis : identifier -> goal sigma -> bool +val is_quantified_hypothesis : Id.t -> goal sigma -> bool exception Bound (** {6 Primitive tactics. } *) -val introduction : identifier -> tactic +val introduction : Id.t -> tactic val refine : constr -> tactic val convert_concl : constr -> cast_kind -> tactic val convert_hyp : named_declaration -> tactic -val thin : identifier list -> tactic +val thin : Id.t list -> tactic val mutual_fix : - identifier -> int -> (identifier * int * constr) list -> int -> tactic -val fix : identifier option -> int -> tactic -val mutual_cofix : identifier -> (identifier * constr) list -> int -> tactic -val cofix : identifier option -> tactic + Id.t -> int -> (Id.t * int * constr) list -> int -> tactic +val fix : Id.t option -> int -> tactic +val mutual_cofix : Id.t -> (Id.t * constr) list -> int -> tactic +val cofix : Id.t option -> tactic (** {6 Introduction tactics. } *) -val fresh_id_in_env : identifier list -> identifier -> env -> identifier -val fresh_id : identifier list -> identifier -> goal sigma -> identifier -val find_intro_names : rel_context -> goal sigma -> identifier list +val fresh_id_in_env : Id.t list -> Id.t -> env -> Id.t +val fresh_id : Id.t list -> Id.t -> goal sigma -> Id.t +val find_intro_names : rel_context -> goal sigma -> Id.t list val intro : tactic val introf : tactic -val intro_move : identifier option -> identifier move_location -> tactic +val intro_move : Id.t option -> Id.t move_location -> tactic - (** [intro_avoiding idl] acts as intro but prevents the new identifier + (** [intro_avoiding idl] acts as intro but prevents the new Id.t to belong to [idl] *) -val intro_avoiding : identifier list -> tactic +val intro_avoiding : Id.t list -> tactic -val intro_replacing : identifier -> tactic -val intro_using : identifier -> tactic -val intro_mustbe_force : identifier -> tactic -val intro_then : (identifier -> tactic) -> tactic -val intros_using : identifier list -> tactic -val intro_erasing : identifier -> tactic -val intros_replacing : identifier list -> tactic +val intro_replacing : Id.t -> tactic +val intro_using : Id.t -> tactic +val intro_mustbe_force : Id.t -> tactic +val intro_then : (Id.t -> tactic) -> tactic +val intros_using : Id.t list -> tactic +val intro_erasing : Id.t -> tactic +val intros_replacing : Id.t list -> tactic val intros : tactic @@ -96,7 +96,7 @@ val intros_clearing : bool list -> tactic hypothesis is already in context and directly apply [tac] *) val try_intros_until : - (identifier -> tactic) -> quantified_hypothesis -> tactic + (Id.t -> tactic) -> quantified_hypothesis -> tactic (** Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) @@ -107,10 +107,10 @@ val onInductionArg : (** {6 Introduction tactics with eliminations. } *) -val intro_pattern : identifier move_location -> intro_pattern_expr -> tactic +val intro_pattern : Id.t move_location -> intro_pattern_expr -> tactic val intro_patterns : intro_pattern_expr located list -> tactic val intros_pattern : - identifier move_location -> intro_pattern_expr located list -> tactic + Id.t move_location -> intro_pattern_expr located list -> tactic (** {6 Exact tactics. } *) @@ -159,16 +159,16 @@ val unfold_constr : global_reference -> tactic (** {6 Modification of the local context. } *) -val clear : identifier list -> tactic -val clear_body : identifier list -> tactic -val keep : identifier list -> tactic +val clear : Id.t list -> tactic +val clear_body : Id.t list -> tactic +val keep : Id.t list -> tactic val specialize : int option -> constr with_bindings -> tactic -val move_hyp : bool -> identifier -> identifier move_location -> tactic -val rename_hyp : (identifier * identifier) list -> tactic +val move_hyp : bool -> Id.t -> Id.t move_location -> tactic +val rename_hyp : (Id.t * Id.t) list -> tactic -val revert : identifier list -> tactic +val revert : Id.t list -> tactic (** {6 Resolution tactics. } *) @@ -188,11 +188,11 @@ val eapply_with_bindings : constr with_bindings -> tactic val cut_and_apply : constr -> tactic val apply_in : - advanced_flag -> evars_flag -> identifier -> + advanced_flag -> evars_flag -> Id.t -> constr with_bindings located list -> intro_pattern_expr located option -> tactic -val simple_apply_in : identifier -> constr -> tactic +val simple_apply_in : Id.t -> constr -> tactic (** {6 Elimination tactics. } *) @@ -257,14 +257,14 @@ val elimination_clause_scheme : evars_flag -> ?flags:unify_flags -> int -> clausenv -> clausenv -> tactic val elimination_in_clause_scheme : evars_flag -> ?flags:unify_flags -> - identifier -> int -> clausenv -> clausenv -> tactic + Id.t -> int -> clausenv -> clausenv -> tactic val general_elim_clause_gen : (int -> Clenv.clausenv -> 'a -> tactic) -> 'a -> eliminator -> tactic val general_elim : evars_flag -> constr with_bindings -> eliminator -> tactic -val general_elim_in : evars_flag -> identifier -> +val general_elim_in : evars_flag -> Id.t -> constr with_bindings -> eliminator -> tactic val default_elim : evars_flag -> constr with_bindings -> tactic @@ -308,9 +308,9 @@ val elim_type : constr -> tactic (** {6 Some eliminations which are frequently used. } *) -val impE : identifier -> tactic -val andE : identifier -> tactic -val orE : identifier -> tactic +val impE : Id.t -> tactic +val andE : Id.t -> tactic +val orE : Id.t -> tactic val dImp : clause -> tactic val dAnd : clause -> tactic val dorE : bool -> clause ->tactic @@ -345,8 +345,8 @@ val intros_reflexivity : tactic val register_setoid_symmetry : tactic -> unit val symmetry_red : bool -> tactic val symmetry : tactic -val register_setoid_symmetry_in : (identifier -> tactic) -> unit -val symmetry_in : identifier -> tactic +val register_setoid_symmetry_in : (Id.t -> tactic) -> unit +val symmetry_in : Id.t -> tactic val intros_symmetry : clause -> tactic val register_setoid_transitivity : (constr option -> tactic) -> unit @@ -357,8 +357,8 @@ val intros_transitivity : constr option -> tactic val cut : constr -> tactic val cut_intro : constr -> tactic -val assert_replacing : identifier -> types -> tactic -> tactic -val cut_replacing : identifier -> types -> tactic -> tactic +val assert_replacing : Id.t -> types -> tactic -> tactic +val cut_replacing : Id.t -> types -> tactic -> tactic val cut_in_parallel : constr list -> tactic val assert_as : bool -> intro_pattern_expr located option -> constr -> tactic @@ -378,15 +378,15 @@ val generalize_dep : ?with_let:bool (** Don't lose let bindings *) -> constr - val unify : ?state:Names.transparent_state -> constr -> constr -> tactic val resolve_classes : tactic -val tclABSTRACT : identifier option -> tactic -> tactic +val tclABSTRACT : Id.t option -> tactic -> tactic val admit_as_an_axiom : tactic -val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> identifier -> tactic -val specialize_eqs : identifier -> tactic +val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> Id.t -> tactic +val specialize_eqs : Id.t -> tactic val register_general_multi_rewrite : (bool -> evars_flag -> constr with_bindings -> clause -> tactic) -> unit val register_subst_one : - (bool -> identifier -> identifier * constr * bool -> tactic) -> unit + (bool -> Id.t -> Id.t * constr * bool -> tactic) -> unit diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 5b41e0b3b..fbae96651 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -20,7 +20,7 @@ open Errors open Util let assoc_var s ist = - match List.assoc (Names.id_of_string s) ist.lfun with + match List.assoc (Names.Id.of_string s) ist.lfun with | VConstr ([],c) -> c | _ -> failwith "tauto: anomaly" @@ -297,8 +297,8 @@ let tauto_intuitionistic flags g = errorlabstrm "tauto" (str "tauto failed.") let coq_nnpp_path = - let dir = List.map id_of_string ["Classical_Prop";"Logic";"Coq"] in - Libnames.make_path (make_dirpath dir) (id_of_string "NNPP") + let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in + Libnames.make_path (make_dirpath dir) (Id.of_string "NNPP") let tauto_classical flags nnpp g = try tclTHEN (apply nnpp) (tauto_intuitionistic flags) g diff --git a/tactics/termdn.ml b/tactics/termdn.ml index 268c6a2e8..becd19a66 100644 --- a/tactics/termdn.ml +++ b/tactics/termdn.ml @@ -85,9 +85,9 @@ let constr_pat_discr_st (idpred,cpred) t = match decomp_pat t with | PRef ((IndRef _) as ref), args | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) - | PRef ((VarRef v) as ref), args when not (Idpred.mem v idpred) -> + | PRef ((VarRef v) as ref), args when not (Id.Pred.mem v idpred) -> Some(GRLabel ref,args) - | PVar v, args when not (Idpred.mem v idpred) -> + | PVar v, args when not (Id.Pred.mem v idpred) -> Some(GRLabel (VarRef v),args) | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) -> Some (GRLabel ref, args) @@ -113,7 +113,7 @@ let constr_val_discr_st (idpred,cpred) t = | Const c -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l) | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l) - | Var id when not (Idpred.mem id idpred) -> Label(GRLabel (VarRef id),l) + | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l) | Sort _ -> Label (SortLabel, []) diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 3fc4aa84f..eaca147e1 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -126,15 +126,15 @@ let build_beq_scheme kn = context_chop (nparams-nparrec) mib.mind_params_ctxt in (* predef coq's boolean type *) (* rec name *) - let rec_name i =(string_of_id (Array.get mib.mind_packets i).mind_typename)^ + let rec_name i =(Id.to_string (Array.get mib.mind_packets i).mind_typename)^ "_eqrec" in (* construct the "fun A B ... N, eqA eqB eqC ... N => fixpoint" part *) let create_input c = let myArrow u v = mkArrow u (lift 1 v) and eqName = function - | Name s -> id_of_string ("eq_"^(string_of_id s)) - | Anonymous -> id_of_string "eq_A" + | Name s -> Id.of_string ("eq_"^(Id.to_string s)) + | Anonymous -> Id.of_string "eq_A" in let ext_rel_list = extended_rel_list 0 lnamesparrec in let lift_cnt = ref 0 in @@ -154,7 +154,7 @@ let build_beq_scheme kn = List.fold_left (fun a (n,_,t) ->(* mkLambda(n,t,a)) eq_input rel_list *) (* Same here , hoping the auto renaming will do something good ;) *) mkNamedLambda - (match n with Name s -> s | Anonymous -> id_of_string "A") + (match n with Name s -> s | Anonymous -> Id.of_string "A") t a) eq_input lnamesparrec in let make_one_eq cur = @@ -178,7 +178,7 @@ let build_beq_scheme kn = let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in match kind_of_term c with | Rel x -> mkRel (x-nlist+ndx) - | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))) + | Var x -> mkVar (Id.of_string ("eq_"^(Id.to_string x))) | Cast (x,_,_) -> aux (applist (x,a)) | App _ -> assert false | Ind (kn',i as ind') -> if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1) @@ -265,18 +265,18 @@ let build_beq_scheme kn = ar.(i) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) (mkCase (ci,do_predicate rel_list nb_cstr_args, - mkVar (id_of_string "Y") ,ar2)) + mkVar (Id.of_string "Y") ,ar2)) (constrsi.(i).cs_args)) done; - mkNamedLambda (id_of_string "X") (mkFullInd ind (nb_ind-1+1)) ( - mkNamedLambda (id_of_string "Y") (mkFullInd ind (nb_ind-1+2)) ( - mkCase (ci, do_predicate rel_list 0,mkVar (id_of_string "X"),ar))) + mkNamedLambda (Id.of_string "X") (mkFullInd ind (nb_ind-1+1)) ( + mkNamedLambda (Id.of_string "Y") (mkFullInd ind (nb_ind-1+2)) ( + mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))) in (* build_beq_scheme *) let names = Array.make nb_ind Anonymous and types = Array.make nb_ind mkSet and cores = Array.make nb_ind mkSet in for i=0 to (nb_ind-1) do - names.(i) <- Name (id_of_string (rec_name i)); + names.(i) <- Name (Id.of_string (rec_name i)); types.(i) <- mkArrow (mkFullInd (kn,i) 0) (mkArrow (mkFullInd (kn,i) 1) bb); cores.(i) <- make_one_eq i @@ -319,9 +319,9 @@ let do_replace_lb lb_scheme_key aavoid narg gls p q = let s = destVar v in let n = Array.length avoid in let rec find i = - if id_eq avoid.(n-i) s then avoid.(n-i-x) + if Id.equal avoid.(n-i) s then avoid.(n-i-x) else (if i<n then find (i+1) - else error ("Var "^(string_of_id s)^" seems unknown.") + else error ("Var "^(Id.to_string s)^" seems unknown.") ) in mkVar (find 1) with _ -> (* if this happen then the args have to be already declared as a @@ -366,9 +366,9 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt = let s = destVar v in let n = Array.length avoid in let rec find i = - if id_eq avoid.(n-i) s then avoid.(n-i-x) + if Id.equal avoid.(n-i) s then avoid.(n-i-x) else (if i<n then find (i+1) - else error ("Var "^(string_of_id s)^" seems unknown.") + else error ("Var "^(Id.to_string s)^" seems unknown.") ) in mkVar (find 1) with _ -> (* if this happen then the args have to be already declared as a @@ -444,11 +444,11 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt = *) let list_id l = List.fold_left ( fun a (n,_,t) -> let s' = match n with - Name s -> string_of_id s + Name s -> Id.to_string s | Anonymous -> "A" in - (id_of_string s',id_of_string ("eq_"^s'), - id_of_string (s'^"_bl"), - id_of_string (s'^"_lb")) + (Id.of_string s',Id.of_string ("eq_"^s'), + Id.of_string (s'^"_bl"), + Id.of_string (s'^"_lb")) ::a ) [] l (* @@ -470,8 +470,8 @@ let compute_bl_goal ind lnamesparrec nparrec = let eqI = eqI ind lnamesparrec in let list_id = list_id lnamesparrec in let create_input c = - let x = id_of_string "x" and - y = id_of_string "y" in + let x = Id.of_string "x" and + y = Id.of_string "y" in let bl_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( @@ -490,11 +490,11 @@ let compute_bl_goal ind lnamesparrec nparrec = mkNamedProd seq b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a (n,_,t) -> mkNamedProd - (match n with Name s -> s | Anonymous -> id_of_string "A") + (match n with Name s -> s | Anonymous -> Id.of_string "A") t a) eq_input lnamesparrec in - let n = id_of_string "x" and - m = id_of_string "y" in + let n = Id.of_string "x" and + m = Id.of_string "y" in create_input ( mkNamedProd n (mkFullInd ind nparrec) ( mkNamedProd m (mkFullInd ind (nparrec+1)) ( @@ -514,11 +514,11 @@ let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec gsig = let fresh_first_intros = List.map ( fun s -> let fresh = fresh_id (!avoid) s gsig in avoid := fresh::(!avoid); fresh ) first_intros in - let freshn = fresh_id (!avoid) (id_of_string "x") gsig in + let freshn = fresh_id (!avoid) (Id.of_string "x") gsig in let freshm = avoid := freshn::(!avoid); - fresh_id (!avoid) (id_of_string "y") gsig in + fresh_id (!avoid) (Id.of_string "y") gsig in let freshz = avoid := freshm::(!avoid); - fresh_id (!avoid) (id_of_string "Z") gsig in + fresh_id (!avoid) (Id.of_string "Z") gsig in (* try with *) avoid := freshz::(!avoid); tclTHENSEQ [ intros_using fresh_first_intros; @@ -539,7 +539,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). tclTHENSEQ [ simple_apply_in freshz (andb_prop()); fun gl -> - let fresht = fresh_id (!avoid) (id_of_string "Z") gsig + let fresht = fresh_id (!avoid) (Id.of_string "Z") gsig in avoid := fresht::(!avoid); (new_destruct false [Tacexpr.ElimOnConstr @@ -600,8 +600,8 @@ let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let eqI = eqI ind lnamesparrec in let create_input c = - let x = id_of_string "x" and - y = id_of_string "y" in + let x = Id.of_string "x" and + y = Id.of_string "y" in let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( @@ -620,11 +620,11 @@ let compute_lb_goal ind lnamesparrec nparrec = mkNamedProd seq b a ) lb_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a (n,_,t) -> mkNamedProd - (match n with Name s -> s | Anonymous -> id_of_string "A") + (match n with Name s -> s | Anonymous -> Id.of_string "A") t a) eq_input lnamesparrec in - let n = id_of_string "x" and - m = id_of_string "y" in + let n = Id.of_string "x" and + m = Id.of_string "y" in create_input ( mkNamedProd n (mkFullInd ind nparrec) ( mkNamedProd m (mkFullInd ind (nparrec+1)) ( @@ -644,11 +644,11 @@ let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec gsig = let fresh_first_intros = List.map ( fun s -> let fresh = fresh_id (!avoid) s gsig in avoid := fresh::(!avoid); fresh ) first_intros in - let freshn = fresh_id (!avoid) (id_of_string "x") gsig in + let freshn = fresh_id (!avoid) (Id.of_string "x") gsig in let freshm = avoid := freshn::(!avoid); - fresh_id (!avoid) (id_of_string "y") gsig in + fresh_id (!avoid) (Id.of_string "y") gsig in let freshz = avoid := freshm::(!avoid); - fresh_id (!avoid) (id_of_string "Z") gsig in + fresh_id (!avoid) (Id.of_string "Z") gsig in (* try with *) avoid := freshz::(!avoid); tclTHENSEQ [ intros_using fresh_first_intros; @@ -716,8 +716,8 @@ let compute_dec_goal ind lnamesparrec nparrec = check_not_is_defined (); let list_id = list_id lnamesparrec in let create_input c = - let x = id_of_string "x" and - y = id_of_string "y" in + let x = Id.of_string "x" and + y = Id.of_string "y" in let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( @@ -749,11 +749,11 @@ let compute_dec_goal ind lnamesparrec nparrec = mkNamedProd seq b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a (n,_,t) -> mkNamedProd - (match n with Name s -> s | Anonymous -> id_of_string "A") + (match n with Name s -> s | Anonymous -> Id.of_string "A") t a) eq_input lnamesparrec in - let n = id_of_string "x" and - m = id_of_string "y" in + let n = Id.of_string "x" and + m = Id.of_string "y" in let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in create_input ( mkNamedProd n (mkFullInd ind (2*nparrec)) ( @@ -778,11 +778,11 @@ let compute_dec_tact ind lnamesparrec nparrec gsig = let fresh_first_intros = List.map ( fun s -> let fresh = fresh_id (!avoid) s gsig in avoid := fresh::(!avoid); fresh ) first_intros in - let freshn = fresh_id (!avoid) (id_of_string "x") gsig in + let freshn = fresh_id (!avoid) (Id.of_string "x") gsig in let freshm = avoid := freshn::(!avoid); - fresh_id (!avoid) (id_of_string "y") gsig in + fresh_id (!avoid) (Id.of_string "y") gsig in let freshH = avoid := freshm::(!avoid); - fresh_id (!avoid) (id_of_string "H") gsig in + fresh_id (!avoid) (Id.of_string "H") gsig in let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in avoid := freshH::(!avoid); let arfresh = Array.of_list fresh_first_intros in @@ -806,7 +806,7 @@ let compute_dec_tact ind lnamesparrec nparrec gsig = ) (tclTHEN (destruct_on eqbnm) Auto.default_auto); (fun gsig -> - let freshH2 = fresh_id (!avoid) (id_of_string "H") gsig in + let freshH2 = fresh_id (!avoid) (Id.of_string "H") gsig in avoid := freshH2::(!avoid); tclTHENS (destruct_on_using (mkVar freshH) freshH2) [ (* left *) @@ -817,7 +817,7 @@ let compute_dec_tact ind lnamesparrec nparrec gsig = ]; (*right *) (fun gsig -> - let freshH3 = fresh_id (!avoid) (id_of_string "H") gsig in + let freshH3 = fresh_id (!avoid) (Id.of_string "H") gsig in avoid := freshH3::(!avoid); tclTHENSEQ [ simplest_right ; diff --git a/toplevel/backtrack.ml b/toplevel/backtrack.ml index 37496387e..2d1e1c6a3 100644 --- a/toplevel/backtrack.ml +++ b/toplevel/backtrack.ml @@ -32,7 +32,7 @@ open Vernacexpr type info = { label : int; nproofs : int; - prfname : identifier option; + prfname : Id.t option; prfdepth : int; ngoals : int; cmd : vernac_expr; @@ -228,7 +228,7 @@ let get_script prf = let script = ref [] in let select i = match i.prfname with | None -> raise Not_found - | Some p when id_eq p prf && i.reachable -> script := i :: !script + | Some p when Id.equal p prf && i.reachable -> script := i :: !script | _ -> () in (try Stack.iter select history with Not_found -> ()); diff --git a/toplevel/backtrack.mli b/toplevel/backtrack.mli index d350901e6..5f9e9f98c 100644 --- a/toplevel/backtrack.mli +++ b/toplevel/backtrack.mli @@ -66,7 +66,7 @@ val reset_initial : unit -> unit (** Reset to the last known state just before defining [id] *) -val reset_name : Names.identifier Loc.located -> unit +val reset_name : Names.Id.t Loc.located -> unit (** When a proof is ended (via either Qed/Admitted/Restart/Abort), old proof steps should be marked differently to avoid jumping back @@ -77,11 +77,11 @@ val reset_name : Names.identifier Loc.located -> unit We also mark as unreachable the proof steps cancelled via a Undo. *) -val mark_unreachable : ?after:int -> Names.identifier list -> unit +val mark_unreachable : ?after:int -> Names.Id.t list -> unit (** Parse the history stack for printing the script of a proof *) -val get_script : Names.identifier -> (Vernacexpr.vernac_expr * int) list +val get_script : Names.Id.t -> (Vernacexpr.vernac_expr * int) list (** For debug purpose, a dump of the history *) @@ -89,7 +89,7 @@ val get_script : Names.identifier -> (Vernacexpr.vernac_expr * int) list type info = { label : int; nproofs : int; - prfname : Names.identifier option; + prfname : Names.Id.t option; prfdepth : int; ngoals : int; cmd : Vernacexpr.vernac_expr; diff --git a/toplevel/class.ml b/toplevel/class.ml index aa77a00c5..01205e597 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -166,7 +166,7 @@ let ident_key_of_class = function | CL_SORT -> "Sortclass" | CL_CONST sp -> string_of_label (con_label sp) | CL_IND (sp,_) -> string_of_label (mind_label sp) - | CL_SECVAR id -> string_of_id id + | CL_SECVAR id -> Id.to_string id (* coercion identité *) @@ -185,7 +185,7 @@ let build_id_coercion idf_opt source = let lams,t = decompose_lam_assum c in let val_f = it_mkLambda_or_LetIn - (mkLambda (Name (id_of_string "x"), + (mkLambda (Name (Id.of_string "x"), applistc vs (extended_rel_list 0 lams), mkRel 1)) lams @@ -209,7 +209,7 @@ let build_id_coercion idf_opt source = | Some idf -> idf | None -> let cl,_ = find_class_type Evd.empty t in - id_of_string ("Id_"^(ident_key_of_class source)^"_"^ + Id.of_string ("Id_"^(ident_key_of_class source)^"_"^ (ident_key_of_class cl)) in let constr_entry = (* Cast is necessary to express [val_f] is identity *) @@ -290,7 +290,7 @@ let try_add_new_coercion_with_source ref stre ~source = let add_coercion_hook stre ref = try_add_new_coercion ref stre; Flags.if_verbose msg_info - (pr_global_env Idset.empty ref ++ str " is now a coercion") + (pr_global_env Id.Set.empty ref ++ str " is now a coercion") let add_subclass_hook stre ref = let cl = class_of_global ref in diff --git a/toplevel/class.mli b/toplevel/class.mli index e4ff43972..a72ec1a81 100644 --- a/toplevel/class.mli +++ b/toplevel/class.mli @@ -39,7 +39,7 @@ val try_add_new_coercion_with_source : global_reference -> locality -> (** [try_add_new_identity_coercion id s src tg] enriches the environment with a new definition of name [id] declared as an identity coercion from [src] to [tg] *) -val try_add_new_identity_coercion : identifier -> locality -> +val try_add_new_identity_coercion : Id.t -> locality -> source:cl_typ -> target:cl_typ -> unit val add_coercion_hook : unit Tacexpr.declaration_hook diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 618ec2bc0..fbabaa432 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -63,7 +63,7 @@ let existing_instance glob g = let mismatched_params env n m = mismatched_ctx_inst env Parameters n m let mismatched_props env n m = mismatched_ctx_inst env Properties n m -type binder_list = (identifier Loc.located * bool * constr_expr) list +type binder_list = (Id.t Loc.located * bool * constr_expr) list (* Declare everything in the parameters as implicit, and the class instance as well *) @@ -121,7 +121,7 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props let tclass, ids = match bk with | Implicit -> - Implicit_quantifiers.implicit_application Idset.empty ~allow_partial:false + Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false (fun avoid (clname, (id, _, t)) -> match clname with | Some (cl, b) -> @@ -129,7 +129,7 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props t, avoid | None -> failwith ("new instance: under-applied typeclass")) cl - | Explicit -> cl, Idset.empty + | Explicit -> cl, Id.Set.empty in let tclass = if generalize then CGeneralization (Loc.ghost, Implicit, Some AbsPi, tclass) else tclass in let k, cty, ctx', ctx, len, imps, subst = @@ -210,7 +210,7 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props if Option.is_empty b then try let is_id (id', _) = match id, get_id id' with - | Name id, (_, id') -> id_eq id id' + | Name id, (_, id') -> Id.equal id id' | Anonymous, _ -> false in let (loc_mid, c) = @@ -338,7 +338,7 @@ let context l = else ( let impl = List.exists (fun (x,_) -> - match x with ExplByPos (_, Some id') -> id_eq id id' | _ -> false) impls + match x with ExplByPos (_, Some id') -> Id.equal id id' | _ -> false) impls in Command.declare_assumption false (Local (* global *), Definitional) t [] impl (* implicit *) None (* inline *) (Loc.ghost, id) && status) diff --git a/toplevel/classes.mli b/toplevel/classes.mli index cfb8362f0..736ba62a9 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -40,10 +40,10 @@ val declare_instance_constant : bool -> (** globality *) Impargs.manual_explicitation list -> (** implicits *) ?hook:(Globnames.global_reference -> unit) -> - identifier -> (** name *) + Id.t -> (** name *) Term.constr -> (** body *) Term.types -> (** type *) - Names.identifier + Names.Id.t val new_instance : ?abstract:bool -> (** Not abstract by default. *) @@ -55,7 +55,7 @@ val new_instance : ?tac:Proof_type.tactic -> ?hook:(Globnames.global_reference -> unit) -> int option -> - identifier + Id.t (** Setting opacity *) @@ -63,7 +63,7 @@ val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> u (** For generation on names based on classes only *) -val id_of_class : typeclass -> identifier +val id_of_class : typeclass -> Id.t (** Context command *) diff --git a/toplevel/command.ml b/toplevel/command.ml index c6c934a81..fc039d968 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -210,9 +210,9 @@ let push_types env idl tl = env idl tl type structured_one_inductive_expr = { - ind_name : identifier; + ind_name : Id.t; ind_arity : constr_expr; - ind_lc : (identifier * constr_expr) list + ind_lc : (Id.t * constr_expr) list } type structured_inductive_expr = @@ -430,7 +430,7 @@ let rec partial_order = function let res = List.remove_assoc y res in let res = List.map (function | (z, Inl t) -> - if id_eq t y then (z, Inl x) else (z, Inl t) + if Id.equal t y then (z, Inl x) else (z, Inl t) | (z, Inr zge) -> if List.mem y zge then (z, Inr (List.add_set x (List.remove y zge))) @@ -446,11 +446,11 @@ let rec partial_order = function let non_full_mutual_message x xge y yge isfix rest = let reason = if List.mem x yge then - string_of_id y^" depends on "^string_of_id x^" but not conversely" + Id.to_string y^" depends on "^Id.to_string x^" but not conversely" else if List.mem y xge then - string_of_id x^" depends on "^string_of_id y^" but not conversely" + Id.to_string x^" depends on "^Id.to_string y^" but not conversely" else - string_of_id y^" and "^string_of_id x^" are not mutually dependent" in + Id.to_string y^" and "^Id.to_string x^" are not mutually dependent" in let e = if List.is_empty rest then reason else "e.g.: "^reason in let k = if isfix then "fixpoint" else "cofixpoint" in let w = @@ -464,7 +464,7 @@ let check_mutuality env isfix fixl = let names = List.map fst fixl in let preorder = List.map (fun (id,def) -> - (id, List.filter (fun id' -> not (id_eq id id') && occur_var env id' def) names)) + (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env id' def) names)) fixl in let po = partial_order preorder in match List.filter (function (_,Inr _) -> true | _ -> false) po with @@ -473,8 +473,8 @@ let check_mutuality env isfix fixl = | _ -> () type structured_fixpoint_expr = { - fix_name : identifier; - fix_annot : identifier Loc.located option; + fix_name : Id.t; + fix_annot : Id.t Loc.located option; fix_binders : local_binder list; fix_body : constr_expr option; fix_type : constr_expr @@ -532,7 +532,7 @@ let compute_possible_guardness_evidences (ids,_,na) = List.interval 0 (List.length ids - 1) type recursive_preentry = - identifier list * constr option list * types list + Id.t list * constr option list * types list (* Wellfounded definition *) @@ -597,7 +597,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let top_arity = interp_type_evars isevars top_env arityc in let full_arity = it_mkProd_or_LetIn top_arity binders_rel in let argtyp, letbinders, make = telescope binders_rel in - let argname = id_of_string "recarg" in + let argname = Id.of_string "recarg" in let arg = (Name argname, None, argtyp) in let binders = letbinders @ [arg] in let binders_env = push_rel_context binders_rel env in @@ -631,7 +631,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = in wf_rel, wf_rel_fun, measure in let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in - let argid' = id_of_string (string_of_id argname ^ "'") in + let argid' = Id.of_string (Id.to_string argname ^ "'") in let wfarg len = (Name argid', None, mkSubset (Name argid') argtyp (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) @@ -654,7 +654,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let arg = mkApp ((delayed_force build_sigma).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in let rcurry = mkApp (rel, [| measure; lift len measure |]) in - let lam = (Name (id_of_string "recproof"), None, rcurry) in + let lam = (Name (Id.of_string "recproof"), None, rcurry) in let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in (Name recname, Some body, ty) @@ -667,8 +667,8 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = Constrintern.compute_internalization_data env Constrintern.Recursive full_arity impls in - let newimpls = Idmap.singleton recname - (r, l, impls @ [(Some (id_of_string "recproof", Impargs.Manual, (true, false)))], + let newimpls = Id.Map.singleton recname + (r, l, impls @ [(Some (Id.of_string "recproof", Impargs.Manual, (true, false)))], scopes @ [None]) in interp_casted_constr_evars isevars ~impls:newimpls (push_rel_context ctx env) body (lift 1 top_arity) @@ -759,7 +759,7 @@ let interp_recursive isfix fixl notations = Metasyntax.with_syntax_protection (fun () -> List.iter (Metasyntax.set_notation_for_interpretation impls) notations; List.map4 - (fun fixctximpenv -> interp_fix_body evdref env_rec (Idmap.fold Idmap.add fixctximpenv impls)) + (fun fixctximpenv -> interp_fix_body evdref env_rec (Id.Map.fold Id.Map.add fixctximpenv impls)) fixctximpenvs fixctxs fixl fixccls) () in diff --git a/toplevel/command.mli b/toplevel/command.mli index 47e6f5a25..a9898329a 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -35,10 +35,10 @@ val interp_definition : local_binder list -> red_expr option -> constr_expr -> constr_expr option -> definition_entry * Evd.evar_map * Impargs.manual_implicits -val declare_definition : identifier -> definition_kind -> +val declare_definition : Id.t -> definition_kind -> definition_entry -> Impargs.manual_implicits -> 'a declaration_hook -> 'a -val do_definition : identifier -> definition_kind -> +val do_definition : Id.t -> definition_kind -> local_binder list -> red_expr option -> constr_expr -> constr_expr option -> unit declaration_hook -> unit @@ -63,9 +63,9 @@ val declare_assumptions : variable Loc.located list -> inductive declarations *) type structured_one_inductive_expr = { - ind_name : identifier; + ind_name : Id.t; ind_arity : constr_expr; - ind_lc : (identifier * constr_expr) list + ind_lc : (Id.t * constr_expr) list } type structured_inductive_expr = @@ -100,8 +100,8 @@ val do_mutual_inductive : (** {6 Fixpoints and cofixpoints} *) type structured_fixpoint_expr = { - fix_name : identifier; - fix_annot : identifier Loc.located option; + fix_name : Id.t; + fix_annot : Id.t Loc.located option; fix_binders : local_binder list; fix_body : constr_expr option; fix_type : constr_expr @@ -121,7 +121,7 @@ val extract_cofixpoint_components : (** Typing global fixpoints and cofixpoint_expr *) type recursive_preentry = - identifier list * constr option list * types list + Id.t list * constr option list * types list val interp_fixpoint : structured_fixpoint_expr list -> decl_notation list -> @@ -151,7 +151,7 @@ val do_cofixpoint : (** Utils *) -val check_mutuality : Environ.env -> bool -> (identifier * types) list -> unit +val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit -val declare_fix : definition_object_kind -> identifier -> +val declare_fix : definition_object_kind -> Id.t -> constr -> types -> Impargs.manual_implicits -> global_reference diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 1f4082b84..e40e46e69 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -56,7 +56,7 @@ let load_rcfile() = (* Puts dir in the path of ML and in the LoadPath *) let coq_add_path unix_path s = - Mltop.add_path ~unix_path ~coq_root:(Names.make_dirpath [Nameops.coq_root;Names.id_of_string s]) + Mltop.add_path ~unix_path ~coq_root:(Names.make_dirpath [Nameops.coq_root;Names.Id.of_string s]) let coq_add_rec_path unix_path = Mltop.add_rec_path ~unix_path ~coq_root:(Names.make_dirpath [Nameops.coq_root]) (* By the option -include -I or -R of the command line *) @@ -104,7 +104,7 @@ let init_load_path () = if Coq_config.local then coq_add_path (coqlib/"dev") "dev"; (* then standard library *) List.iter - (fun (s,alias) -> Mltop.add_rec_path ~unix_path:(coqlib/s) ~coq_root:(Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root])) + (fun (s,alias) -> Mltop.add_rec_path ~unix_path:(coqlib/s) ~coq_root:(Names.make_dirpath [Names.Id.of_string alias; Nameops.coq_root])) theories_dirs_map; (* then plugins *) List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs; diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 00875a681..90652d348 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -52,7 +52,7 @@ let engage () = let set_batch_mode () = batch_mode := true -let toplevel_default_name = make_dirpath [id_of_string "Top"] +let toplevel_default_name = make_dirpath [Id.of_string "Top"] let toplevel_name = ref (Some toplevel_default_name) let set_toplevel_name dir = if dir_path_eq dir empty_dirpath then error "Need a non empty toplevel module name"; diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 2f2040199..ef510aee5 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -349,7 +349,7 @@ let explain_evar_kind env evi = function let id = Option.get ido in str "the implicit parameter " ++ pr_id id ++ spc () ++ str "of" ++ - spc () ++ Nametab.pr_global_env Idset.empty c + spc () ++ Nametab.pr_global_env Id.Set.empty c | Evar_kinds.InternalHole -> str "an internal placeholder" ++ Option.cata (fun evi -> @@ -543,7 +543,7 @@ let explain_not_match_error = function | ModuleTypeFieldExpected -> strbrk "a module type is expected" | NotConvertibleInductiveField id | NotConvertibleConstructorField id -> - str "types given to " ++ str (string_of_id id) ++ str " differ" + str "types given to " ++ str (Id.to_string id) ++ str " differ" | NotConvertibleBodyField -> str "the body of definitions differs" | NotConvertibleTypeField -> @@ -565,7 +565,7 @@ let explain_not_match_error = function | RecordProjectionsExpected nal -> (if List.length nal >= 2 then str "expected projection names are " else str "expected projection name is ") ++ - pr_enum (function Name id -> str (string_of_id id) | _ -> str "_") nal + pr_enum (function Name id -> str (Id.to_string id) | _ -> str "_") nal | NotEqualInductiveAliases -> str "Aliases to inductive types do not match" | NoTypeConstraintExpected -> diff --git a/toplevel/ide_slave.ml b/toplevel/ide_slave.ml index 5c32bd0ed..4f5bb148d 100644 --- a/toplevel/ide_slave.ml +++ b/toplevel/ide_slave.ml @@ -121,7 +121,7 @@ let interp (raw,verbosely,s) = (** Goal display *) let hyp_next_tac sigma env (id,_,ast) = - let id_s = Names.string_of_id id in + let id_s = Names.Id.to_string id in let type_s = string_of_ppcmds (pr_ltype_env env ast) in [ ("clear "^id_s),("clear "^id_s^"."); @@ -230,15 +230,15 @@ let status () = and display the other parts (opened sections and modules) *) let path = let l = Names.repr_dirpath (Lib.cwd ()) in - List.rev_map Names.string_of_id l + List.rev_map Names.Id.to_string l in let proof = - try Some (Names.string_of_id (Proof_global.get_current_proof_name ())) + try Some (Names.Id.to_string (Proof_global.get_current_proof_name ())) with _ -> None in let allproofs = let l = Proof_global.get_all_proof_names () in - List.map Names.string_of_id l + List.map Names.Id.to_string l in { Interface.status_path = path; diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 722a1a748..f039a6c40 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -87,7 +87,7 @@ let scheme_object_table = (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t) let declare_scheme_object s aux f = - (try check_ident ("ind"^s) with _ -> + (try Id.check ("ind"^s) with _ -> error ("Illegal induction scheme suffix: "^s)); let key = if String.is_empty aux then s else aux in try diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli index 7032eb46e..35ceef86a 100644 --- a/toplevel/ind_tables.mli +++ b/toplevel/ind_tables.mli @@ -41,10 +41,10 @@ val declare_scheme : 'a scheme_kind -> (inductive * constant) array -> unit val define_individual_scheme : individual scheme_kind -> Declare.internal_flag (** internal *) -> - identifier option -> inductive -> constant + Id.t option -> inductive -> constant val define_mutual_scheme : mutual scheme_kind -> Declare.internal_flag (** internal *) -> - (int * identifier) list -> mutual_inductive -> constant array + (int * Id.t) list -> mutual_inductive -> constant array (** Main function to retrieve a scheme in the cache or to generate it *) val find_scheme : 'a scheme_kind -> inductive -> constant diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli index ecadc3a18..be49f41e5 100644 --- a/toplevel/indschemes.mli +++ b/toplevel/indschemes.mli @@ -37,17 +37,17 @@ val declare_rewriting_schemes : inductive -> unit (** Mutual Minimality/Induction scheme *) val do_mutual_induction_scheme : - (identifier located * bool * inductive * glob_sort) list -> unit + (Id.t located * bool * inductive * glob_sort) list -> unit (** Main calls to interpret the Scheme command *) -val do_scheme : (identifier located option * scheme) list -> unit +val do_scheme : (Id.t located option * scheme) list -> unit (** Combine a list of schemes into a conjunction of them *) val build_combined_scheme : env -> constant list -> constr * types -val do_combined_scheme : identifier located -> identifier located list -> unit +val do_combined_scheme : Id.t located -> Id.t located list -> unit (** Hook called at each inductive type definition *) diff --git a/toplevel/lemmas.ml b/toplevel/lemmas.ml index ecd1cc59b..eea41c152 100644 --- a/toplevel/lemmas.ml +++ b/toplevel/lemmas.ml @@ -177,7 +177,7 @@ let save id const do_guard (locality,kind) hook = definition_message id; hook l r -let default_thm_id = id_of_string "Unnamed_thm" +let default_thm_id = Id.of_string "Unnamed_thm" let compute_proof_name locality = function | Some (loc,id) -> @@ -236,7 +236,7 @@ let save_named opacity = save id const do_guard persistence hook let check_anonymity id save_ident = - if not (String.equal (atompart_of_id id) (string_of_id (default_thm_id))) then + if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then error "This command can only be used for unnamed theorem." let save_anonymous opacity save_ident = diff --git a/toplevel/lemmas.mli b/toplevel/lemmas.mli index a956916f8..3c7000cb0 100644 --- a/toplevel/lemmas.mli +++ b/toplevel/lemmas.mli @@ -18,7 +18,7 @@ open Pfedit (** A hook start_proof calls on the type of the definition being started *) val set_start_hook : (types -> unit) -> unit -val start_proof : identifier -> goal_kind -> types -> +val start_proof : Id.t -> goal_kind -> types -> ?init_tac:tactic -> ?compute_guard:lemma_possible_guards -> unit declaration_hook -> unit @@ -28,7 +28,7 @@ val start_proof_com : goal_kind -> val start_proof_with_initialization : goal_kind -> (bool * lemma_possible_guards * tactic list option) option -> - (identifier * (types * (name list * Impargs.manual_explicitation list))) list + (Id.t * (types * (name list * Impargs.manual_explicitation list))) list -> int list option -> unit declaration_hook -> unit (** A hook the next three functions pass to cook_proof *) @@ -44,13 +44,13 @@ val save_named : bool -> unit (** [save_anonymous b name] behaves as [save_named] but declares the theorem under the name [name] and respects the strength of the declaration *) -val save_anonymous : bool -> identifier -> unit +val save_anonymous : bool -> Id.t -> unit (** [save_anonymous_with_strength s b name] behaves as [save_anonymous] but declares the theorem under the name [name] and gives it the strength [strength] *) -val save_anonymous_with_strength : theorem_kind -> bool -> identifier -> unit +val save_anonymous_with_strength : theorem_kind -> bool -> Id.t -> unit (** [admit ()] aborts the current goal and save it as an assmumption *) diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 71305cb13..f9721e2d8 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -324,7 +324,7 @@ let rec find_pattern nt xl = function let rec interp_list_parser hd = function | [] -> [], List.rev hd - | NonTerminal id :: tl when id_eq id ldots_var -> + | NonTerminal id :: tl when Id.equal id ldots_var -> let hd = List.rev hd in let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in let xyl,tl'' = interp_list_parser [] tl' in @@ -357,7 +357,7 @@ let rec raw_analyze_notation_tokens = function | String ".." :: sl -> NonTerminal ldots_var :: raw_analyze_notation_tokens sl | String "_" :: _ -> error "_ must be quoted." | String x :: sl when Lexer.is_ident x -> - NonTerminal (Names.id_of_string x) :: raw_analyze_notation_tokens sl + NonTerminal (Names.Id.of_string x) :: raw_analyze_notation_tokens sl | String s :: sl -> Terminal (String.drop_simple_quotes s) :: raw_analyze_notation_tokens sl | WhiteSpace n :: sl -> @@ -374,9 +374,9 @@ let rec get_notation_vars = function | [] -> [] | NonTerminal id :: sl -> let vars = get_notation_vars sl in - if id_eq id ldots_var then vars else + if Id.equal id ldots_var then vars else if List.mem id vars then - error ("Variable "^string_of_id id^" occurs more than once.") + error ("Variable "^Id.to_string id^" occurs more than once.") else id::vars | (Terminal _ | Break _) :: sl -> get_notation_vars sl @@ -389,7 +389,7 @@ let analyze_notation_tokens l = recvars, List.subtract vars (List.map snd recvars), l let error_not_same_scope x y = - error ("Variables "^string_of_id x^" and "^string_of_id y^ + error ("Variables "^Id.to_string x^" and "^Id.to_string y^ " must be in the same scope.") (**********************************************************************) @@ -557,7 +557,7 @@ let make_hunks etyps symbols from = let error_format () = error "The format does not match the notation." let rec split_format_at_ldots hd = function - | UnpTerminal s :: fmt when String.equal s (string_of_id ldots_var) -> List.rev hd, fmt + | UnpTerminal s :: fmt when String.equal s (Id.to_string ldots_var) -> List.rev hd, fmt | u :: fmt -> check_no_ldots_in_box u; split_format_at_ldots (u::hd) fmt @@ -597,7 +597,7 @@ let hunks_of_format (from,(vars,typs)) symfmt = | Terminal s :: symbs, (UnpTerminal s') :: fmt when String.equal s (String.drop_simple_quotes s') -> let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l - | NonTerminal s :: symbs, UnpTerminal s' :: fmt when id_eq s (id_of_string s') -> + | NonTerminal s :: symbs, UnpTerminal s' :: fmt when Id.equal s (Id.of_string s') -> let i = List.index s vars in let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l @@ -800,14 +800,14 @@ let interp_modifiers modl = | [] -> (assoc,level,etyps,!onlyparsing,format) | SetEntryType (s,typ) :: l -> - let id = id_of_string s in + let id = Id.of_string s in if List.mem_assoc id etyps then error (s^" is already assigned to an entry or constr level."); interp assoc level ((id,typ)::etyps) format l | SetItemLevel ([],n) :: l -> interp assoc level etyps format l | SetItemLevel (s::idl,n) :: l -> - let id = id_of_string s in + let id = Id.of_string s in if List.mem_assoc id etyps then error (s^" is already assigned to an entry or constr level."); let typ = ETConstr (n,()) in @@ -1239,7 +1239,7 @@ let add_notation local c ((loc,df),modifiers) sc = (* Infix notations *) -let inject_var x = CRef (Ident (Loc.ghost, id_of_string x)) +let inject_var x = CRef (Ident (Loc.ghost, Id.of_string x)) let add_infix local ((loc,inf),modifiers) pr sc = check_infix_modifiers modifiers; diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index c7e1be39d..93752b3bc 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -52,7 +52,7 @@ val add_syntax_extension : (** Add a syntactic definition (as in "Notation f := ...") *) -val add_syntactic_definition : identifier -> identifier list * constr_expr -> +val add_syntactic_definition : Id.t -> Id.t list * constr_expr -> bool -> Flags.compat_version option -> unit (** Print the Camlp4 state of a grammar *) diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml index 947b02924..75a0a8964 100644 --- a/toplevel/mltop.ml +++ b/toplevel/mltop.ml @@ -155,7 +155,7 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = msg_warning (str ("Cannot open " ^ dir)) let convert_string d = - try Names.id_of_string d + try Names.Id.of_string d with _ -> if_warn msg_warning (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)")); raise Exit diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 4abcfacf9..e9f31bbca 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -46,7 +46,7 @@ let check_evars env evm = (Evd.undefined_list evm) type oblinfo = - { ev_name: int * identifier; + { ev_name: int * Id.t; ev_hyps: named_context; ev_status: Evar_kinds.obligation_definition_status; ev_chop: int option; @@ -64,7 +64,7 @@ let evar_tactic = Store.field () let subst_evar_constr evs n idf t = let seen = ref Int.Set.empty in - let transparent = ref Idset.empty in + let transparent = ref Id.Set.empty in let evar_info id = List.assoc id evs in let rec substrec (depth, fixrels) c = match kind_of_term c with | Evar (k, args) -> @@ -95,7 +95,7 @@ let subst_evar_constr evs n idf t = in aux hyps args [] in if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then - transparent := Idset.add idstr !transparent; + transparent := Id.Set.add idstr !transparent; mkApp (idf idstr, Array.of_list args) | Fix _ -> map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c @@ -126,14 +126,14 @@ let etype_of_evar evs hyps concl = let t'' = subst_vars acc 0 t' in let rest, s', trans' = aux (id :: acc) (succ n) tl in let s' = Int.Set.union s s' in - let trans' = Idset.union trans trans' in + let trans' = Id.Set.union trans trans' in (match copt with Some c -> let c', s'', trans'' = subst_evar_constr evs n mkVar c in let c' = subst_vars acc 0 c' in mkNamedProd_or_LetIn (id, Some c', t'') rest, Int.Set.union s'' s', - Idset.union trans'' trans' + Id.Set.union trans'' trans' | None -> mkNamedProd_or_LetIn (id, None, t'') rest, s', trans') | [] -> @@ -214,8 +214,8 @@ let eterm_obligations env name evm fs ?status t ty = let evn = let i = ref (-1) in List.rev_map (fun (id, ev) -> incr i; - (id, (!i, id_of_string - (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))), + (id, (!i, Id.of_string + (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i))), ev)) evl in let evts = @@ -263,7 +263,7 @@ let eterm_obligations env name evm fs ?status t ty = ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info in let status = match status with - | Evar_kinds.Define true when Idset.mem name transparent -> + | Evar_kinds.Define true when Id.Set.mem name transparent -> Evar_kinds.Define false | _ -> status in name, typ, src, status, deps, tac) evts @@ -284,18 +284,18 @@ let error s = pperror (str s) let reduce c = Reductionops.clos_norm_flags Closure.betaiota (Global.env ()) Evd.empty c -exception NoObligations of identifier option +exception NoObligations of Id.t option let explain_no_obligations = function - Some ident -> str "No obligations for program " ++ str (string_of_id ident) + Some ident -> str "No obligations for program " ++ str (Id.to_string ident) | None -> str "No obligations remaining" type obligation_info = - (Names.identifier * Term.types * Evar_kinds.t Loc.located * + (Names.Id.t * Term.types * Evar_kinds.t Loc.located * Evar_kinds.obligation_definition_status * Int.Set.t * tactic option) array type obligation = - { obl_name : identifier; + { obl_name : Id.t; obl_type : types; obl_location : Evar_kinds.t Loc.located; obl_body : constr option; @@ -307,17 +307,17 @@ type obligation = type obligations = (obligation array * int) type fixpoint_kind = - | IsFixpoint of (identifier Loc.located option * Constrexpr.recursion_order_expr) list + | IsFixpoint of (Id.t Loc.located option * Constrexpr.recursion_order_expr) list | IsCoFixpoint type notations = (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list type program_info = { - prg_name: identifier; + prg_name: Id.t; prg_body: constr; prg_type: constr; prg_obligations: obligations; - prg_deps : identifier list; + prg_deps : Id.t list; prg_fixkind : fixpoint_kind option ; prg_implicits : (Constrexpr.explicitation * (bool * bool * bool)) list; prg_notations : notations ; @@ -428,7 +428,7 @@ let subst_deps_obl obls obl = let t' = subst_deps true obls obl.obl_deps obl.obl_type in { obl with obl_type = t' } -module ProgMap = Map.Make(struct type t = identifier let compare = id_ord end) +module ProgMap = Map.Make(struct type t = Id.t let compare = Id.compare end) let map_replace k v m = ProgMap.add k v (ProgMap.remove k m) @@ -518,7 +518,7 @@ open Pp let rec lam_index n t acc = match kind_of_term t with - | Lambda (Name n', _, _) when id_eq n n' -> + | Lambda (Name n', _, _) when Id.equal n n' -> acc | Lambda (_, _, b) -> lam_index n b (succ acc) @@ -592,7 +592,7 @@ let declare_obligation prg obl body = (DefinitionEntry ce,IsProof Property) in if not opaque then - Auto.add_hints false [string_of_id prg.prg_name] + Auto.add_hints false [Id.to_string prg.prg_name] (Auto.HintsUnfoldEntry [EvalConstRef constant]); definition_message obl.obl_name; { obl with obl_body = Some (mkConst constant) } @@ -723,7 +723,7 @@ let rec string_of_list sep f = function (* Solve an obligation using tactics, return the corresponding proof term *) let solve_by_tac evi t = - let id = id_of_string "H" in + let id = Id.of_string "H" in try Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl (fun _ _ -> ()); @@ -762,7 +762,7 @@ let rec solve_obligation prg num tac = else Globnames.constr_of_global gr in if transparent then - Auto.add_hints true [string_of_id prg.prg_name] + Auto.add_hints true [Id.to_string prg.prg_name] (Auto.HintsUnfoldEntry [EvalConstRef cst]); { obl with obl_body = Some body } in @@ -873,7 +873,7 @@ let show_obligations_of_prg ?(msg=true) prg = if !showed > 0 then ( decr showed; msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ - str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ + str "of" ++ spc() ++ str (Id.to_string n) ++ str ":" ++ spc () ++ hov 1 (Printer.pr_constr_env (Global.env ()) x.obl_type ++ str "." ++ fnl ()))) | Some _ -> ()) @@ -890,13 +890,13 @@ let show_obligations ?(msg=true) n = let show_term n = let prg = get_prog_err n in let n = prg.prg_name in - (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++ + (str (Id.to_string n) ++ spc () ++ str":" ++ spc () ++ Printer.pr_constr_env (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ Printer.pr_constr_env (Global.env ()) prg.prg_body) let add_definition n ?term t ?(implicits=[]) ?(kind=Global,Definition) ?tactic ?(reduce=reduce) ?(hook=fun _ _ -> ()) obls = - let info = str (string_of_id n) ++ str " has type-checked" in + let info = str (Id.to_string n) ++ str " has type-checked" in let prg = init_prog_info n term t [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli index 3017db4a6..428d7e321 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -21,11 +21,11 @@ open Decl_kinds open Tacexpr (** Forward declaration. *) -val declare_fix_ref : (definition_object_kind -> identifier -> +val declare_fix_ref : (definition_object_kind -> Id.t -> constr -> types -> Impargs.manual_implicits -> global_reference) ref val declare_definition_ref : - (identifier -> locality * definition_object_kind -> + (Id.t -> locality * definition_object_kind -> Entries.definition_entry -> Impargs.manual_implicits -> global_reference declaration_hook -> global_reference) ref @@ -38,21 +38,21 @@ val sort_dependencies : (int * evar_info * Int.Set.t) list -> (int * evar_info * (* env, id, evars, number of function prototypes to try to clear from evars contexts, object and type *) -val eterm_obligations : env -> identifier -> evar_map -> int -> +val eterm_obligations : env -> Id.t -> evar_map -> int -> ?status:Evar_kinds.obligation_definition_status -> constr -> types -> - (identifier * types * Evar_kinds.t Loc.located * Evar_kinds.obligation_definition_status * Int.Set.t * + (Id.t * types * Evar_kinds.t Loc.located * Evar_kinds.obligation_definition_status * Int.Set.t * tactic option) array (* Existential key, obl. name, type as product, location of the original evar, associated tactic, status and dependencies as indexes into the array *) - * ((existential_key * identifier) list * ((identifier -> constr) -> constr -> constr)) * + * ((existential_key * Id.t) list * ((Id.t -> constr) -> constr -> constr)) * constr * types (* Translations from existential identifiers to obligation identifiers and for terms with existentials to closed terms, given a translation from obligation identifiers to constrs, new term, new type *) type obligation_info = - (identifier * Term.types * Evar_kinds.t Loc.located * + (Id.t * Term.types * Evar_kinds.t Loc.located * Evar_kinds.obligation_definition_status * Int.Set.t * tactic option) array (* ident, type, location, (opaque or transparent, expand or define), dependencies, tactic to solve it *) @@ -69,7 +69,7 @@ val print_default_tactic : unit -> Pp.std_ppcmds val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *) val get_proofs_transparency : unit -> bool -val add_definition : Names.identifier -> ?term:Term.constr -> Term.types -> +val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:Proof_type.tactic -> @@ -80,11 +80,11 @@ type notations = (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list type fixpoint_kind = - | IsFixpoint of (identifier Loc.located option * Constrexpr.recursion_order_expr) list + | IsFixpoint of (Id.t Loc.located option * Constrexpr.recursion_order_expr) list | IsCoFixpoint val add_mutual_definitions : - (Names.identifier * Term.constr * Term.types * + (Names.Id.t * Term.constr * Term.types * (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list -> ?tactic:Proof_type.tactic -> ?kind:Decl_kinds.definition_kind -> @@ -93,28 +93,28 @@ val add_mutual_definitions : notations -> fixpoint_kind -> unit -val obligation : int * Names.identifier option * Constrexpr.constr_expr option -> +val obligation : int * Names.Id.t option * Constrexpr.constr_expr option -> Tacexpr.raw_tactic_expr option -> unit -val next_obligation : Names.identifier option -> Tacexpr.raw_tactic_expr option -> unit +val next_obligation : Names.Id.t option -> Tacexpr.raw_tactic_expr option -> unit -val solve_obligations : Names.identifier option -> Proof_type.tactic option -> progress +val solve_obligations : Names.Id.t option -> Proof_type.tactic option -> progress (* Number of remaining obligations to be solved for this program *) val solve_all_obligations : Proof_type.tactic option -> unit -val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit +val try_solve_obligation : int -> Names.Id.t option -> Proof_type.tactic option -> unit -val try_solve_obligations : Names.identifier option -> Proof_type.tactic option -> unit +val try_solve_obligations : Names.Id.t option -> Proof_type.tactic option -> unit -val show_obligations : ?msg:bool -> Names.identifier option -> unit +val show_obligations : ?msg:bool -> Names.Id.t option -> unit -val show_term : Names.identifier option -> std_ppcmds +val show_term : Names.Id.t option -> std_ppcmds -val admit_obligations : Names.identifier option -> unit +val admit_obligations : Names.Id.t option -> unit -exception NoObligations of Names.identifier option +exception NoObligations of Names.Id.t option -val explain_no_obligations : Names.identifier option -> Pp.std_ppcmds +val explain_no_obligations : Names.Id.t option -> Pp.std_ppcmds val set_program_mode : bool -> unit diff --git a/toplevel/record.ml b/toplevel/record.ml index 27f63d2f8..12b87b67a 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -38,7 +38,7 @@ let interp_fields_evars evars env impls_env nots l = let impls = match i with | Anonymous -> impls - | Name id -> Idmap.add id (compute_internalization_data env Constrintern.Method t' impl) impls + | Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method t' impl) impls in let d = (i,b',t') in List.iter (Metasyntax.set_notation_for_interpretation impls) no; @@ -90,14 +90,14 @@ let degenerate_decl (na,b,t) = | Some b -> (id, Entries.LocalDef b) type record_error = - | MissingProj of identifier * identifier list - | BadTypedProj of identifier * env * Type_errors.type_error + | MissingProj of Id.t * Id.t list + | BadTypedProj of Id.t * env * Type_errors.type_error let warning_or_error coe indsp err = let st = match err with | MissingProj (fi,projs) -> let s,have = if List.length projs > 1 then "s","were" else "","was" in - (str(string_of_id fi) ++ + (str(Id.to_string fi) ++ strbrk" cannot be defined because the projection" ++ str s ++ spc () ++ prlist_with_sep pr_comma pr_id projs ++ spc () ++ str have ++ strbrk " not defined.") diff --git a/toplevel/record.mli b/toplevel/record.mli index 04691f920..e7e3330b8 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -19,15 +19,15 @@ open Globnames as coercions accordingly to [coers]; it returns the absolute names of projections *) val declare_projections : - inductive -> ?kind:Decl_kinds.definition_object_kind -> ?name:identifier -> + inductive -> ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t -> coercion_flag list -> manual_explicitation list list -> rel_context -> (name * bool) list * constant option list val declare_structure : Decl_kinds.recursivity_kind -> - bool (**infer?*) -> identifier -> identifier -> + bool (**infer?*) -> Id.t -> Id.t -> manual_explicitation list -> rel_context -> (** params *) constr -> (** arity *) Impargs.manual_explicitation list list -> rel_context -> (** fields *) - ?kind:Decl_kinds.definition_object_kind -> ?name:identifier -> + ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t -> bool -> (** coercion? *) bool list -> (** field coercions *) Evd.evar_map -> @@ -36,4 +36,4 @@ val declare_structure : Decl_kinds.recursivity_kind -> val definition_structure : inductive_kind * Decl_kinds.recursivity_kind * bool(**infer?*)* lident with_coercion * local_binder list * (local_decl_expr with_instance with_priority with_notation) list * - identifier * constr_expr option -> global_reference + Id.t * constr_expr option -> global_reference diff --git a/toplevel/search.ml b/toplevel/search.ml index ab3b9b728..b91b96d59 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -128,7 +128,7 @@ let filter_by_module (module_list:dir_path list) (accept:bool) in xor accept (filter_aux module_list) -let ref_eq = Globnames.encode_mind Coqlib.logic_module (id_of_string "eq"), 0 +let ref_eq = Globnames.encode_mind Coqlib.logic_module (Id.of_string "eq"), 0 let c_eq = mkInd ref_eq let gref_eq = IndRef ref_eq @@ -155,7 +155,7 @@ let filtered_search filter_function display_function ref = let rec id_from_pattern = function | PRef gr -> gr (* should be appear as a PRef (VarRef sp) !! - | PVar id -> Nametab.locate (make_qualid [] (string_of_id id)) + | PVar id -> Nametab.locate (make_qualid [] (Id.to_string id)) *) | PApp (p,_) -> id_from_pattern p | _ -> error "The pattern is not simple enough." @@ -177,11 +177,11 @@ let raw_search_rewrite extra_filter display_function pattern = let raw_search_by_head extra_filter display_function pattern = Errors.todo "raw_search_by_head" -let name_of_reference ref = string_of_id (basename_of_global ref) +let name_of_reference ref = Id.to_string (basename_of_global ref) let full_name_of_reference ref = let (dir,id) = repr_path (path_of_global ref) in - string_of_dirpath dir ^ "." ^ string_of_id id + string_of_dirpath dir ^ "." ^ Id.to_string id (* * functions to use the new Libtypes facility @@ -293,7 +293,7 @@ let interface_search flags = extract_flags [] [] [] [] false flags in let filter_function ref env constr = - let id = Names.string_of_id (Nametab.basename_of_global ref) in + let id = Names.Id.to_string (Nametab.basename_of_global ref) in let path = Libnames.dirpath (Nametab.path_of_global ref) in let toggle x b = if x then b else not b in let match_name (regexp, flag) = @@ -319,20 +319,20 @@ let interface_search flags = let ans = ref [] in let print_function ref env constr = let fullpath = repr_dirpath (Nametab.dirpath_of_global ref) in - let qualid = Nametab.shortest_qualid_of_global Idset.empty ref in + let qualid = Nametab.shortest_qualid_of_global Id.Set.empty ref in let (shortpath, basename) = Libnames.repr_qualid qualid in let shortpath = repr_dirpath shortpath in (* [shortpath] is a suffix of [fullpath] and we're looking for the missing prefix *) let rec prefix full short accu = match full, short with | _, [] -> - let full = List.rev_map string_of_id full in + let full = List.rev_map Id.to_string full in (full, accu) | _ :: full, m :: short -> - prefix full short (string_of_id m :: accu) + prefix full short (Id.to_string m :: accu) | _ -> assert false in - let (prefix, qualid) = prefix fullpath shortpath [string_of_id basename] in + let (prefix, qualid) = prefix fullpath shortpath [Id.to_string basename] in let answer = { Interface.coq_object_prefix = prefix; Interface.coq_object_qualid = qualid; diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml index 435258720..0da4fc8c9 100644 --- a/toplevel/toplevel.ml +++ b/toplevel/toplevel.ml @@ -198,7 +198,7 @@ let valid_buffer_loc ib dloc loc = from cycling. *) let make_prompt () = try - (Names.string_of_id (Pfedit.get_current_proof_name ())) ^ " < " + (Names.Id.to_string (Pfedit.get_current_proof_name ())) ^ " < " with _ -> "Coq < " @@ -207,7 +207,7 @@ let make_prompt () = let l' = ref l in let res = while List.length !l' > 1 do - pl := !pl ^ "|" Names.string_of_id x; + pl := !pl ^ "|" Names.Id.to_string x; l':=List.tl !l' done in let last = try List.hd !l' with _ -> in @@ -228,7 +228,7 @@ let make_emacs_prompt() = let pending = Pfedit.get_all_proof_names() in let pendingprompt = List.fold_left - (fun acc x -> acc ^ (if String.is_empty acc then "" else "|") ^ Names.string_of_id x) + (fun acc x -> acc ^ (if String.is_empty acc then "" else "|") ^ Names.Id.to_string x) "" pending in let proof_info = if dpth >= 0 then string_of_int dpth else "0" in if !Flags.print_emacs then statnum ^ " |" ^ pendingprompt ^ "| " ^ proof_info ^ " < " diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 71ae8a1ec..25d0fcec9 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -179,9 +179,9 @@ let make_cases s = | [] -> [] | (n,_)::l -> let n' = Namegen.next_name_away_in_cases_pattern n avoid in - string_of_id n' :: rename (n'::avoid) l in + Id.to_string n' :: rename (n'::avoid) l in let al' = rename [] al in - (string_of_id consname :: al') :: l) + (Id.to_string consname :: al') :: l) carr tarr [] | _ -> raise Not_found @@ -189,7 +189,7 @@ let make_cases s = let show_match id = let patterns = - try make_cases (string_of_id (snd id)) + try make_cases (Id.to_string (snd id)) with Not_found -> error "Unknown inductive type." in let pr_branch l = @@ -259,7 +259,7 @@ let print_namespace ns = begin match match_dirpath ns dir with | Some [] as y -> y | Some (a::ns') -> - if Int.equal (Names.id_ord a id) 0 then Some ns' + if Int.equal (Names.Id.compare a id) 0 then Some ns' else None | None -> None end @@ -272,7 +272,7 @@ let print_namespace ns = begin match match_modulepath ns mp with | Some [] as y -> y | Some (a::ns') -> - if Int.equal (Names.id_ord a id) 0 then Some ns' + if Int.equal (Names.Id.compare a id) 0 then Some ns' else None | None -> None end @@ -618,7 +618,7 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast = id binders_ast (Enforce mty_ast) [] in Dumpglob.dump_moddef loc mp "mod"; - if_verbose msg_info (str ("Module "^ string_of_id id ^" is declared")); + if_verbose msg_info (str ("Module "^ Id.to_string id ^" is declared")); Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = @@ -639,7 +639,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = in Dumpglob.dump_moddef loc mp "mod"; if_verbose msg_info - (str ("Interactive Module "^ string_of_id id ^" started")); + (str ("Interactive Module "^ Id.to_string id ^" started")); List.iter (fun (export,id) -> Option.iter @@ -660,14 +660,14 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = in Dumpglob.dump_moddef loc mp "mod"; if_verbose msg_info - (str ("Module "^ string_of_id id ^" is defined")); + (str ("Module "^ Id.to_string id ^" is defined")); Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export let vernac_end_module export (loc,id as lid) = let mp = Declaremods.end_module () in Dumpglob.dump_modref loc mp "mod"; - if_verbose msg_info (str ("Module "^ string_of_id id ^" is defined")); + if_verbose msg_info (str ("Module "^ Id.to_string id ^" is defined")); Option.iter (fun export -> vernac_import export [Ident lid]) export let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = @@ -687,7 +687,7 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = Modintern.interp_modtype id binders_ast mty_sign in Dumpglob.dump_moddef loc mp "modtype"; if_verbose msg_info - (str ("Interactive Module Type "^ string_of_id id ^" started")); + (str ("Interactive Module Type "^ Id.to_string id ^" started")); List.iter (fun (export,id) -> Option.iter @@ -707,12 +707,12 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = id binders_ast mty_sign mty_ast_l in Dumpglob.dump_moddef loc mp "modtype"; if_verbose msg_info - (str ("Module Type "^ string_of_id id ^" is defined")) + (str ("Module Type "^ Id.to_string id ^" is defined")) let vernac_end_modtype (loc,id) = let mp = Declaremods.end_modtype () in Dumpglob.dump_modref loc mp "modtype"; - if_verbose msg_info (str ("Module Type "^ string_of_id id ^" is defined")) + if_verbose msg_info (str ("Module Type "^ Id.to_string id ^" is defined")) let vernac_include l = Declaremods.declare_include Modintern.interp_modexpr_or_modtype l @@ -824,8 +824,8 @@ let vernac_set_used_variables l = if not (List.distinct l) then error "Used variables list contains duplicates"; let vars = Environ.named_context (Global.env ()) in List.iter (fun id -> - if not (List.exists (fun (id',_,_) -> id_eq id id') vars) then - error ("Unknown variable: " ^ string_of_id id)) + if not (List.exists (fun (id',_,_) -> Id.equal id id') vars) then + error ("Unknown variable: " ^ Id.to_string id)) l; set_used_variables l @@ -914,7 +914,7 @@ let vernac_declare_arguments local r l nargs flags = let sr = smart_global r in let inf_names = Impargs.compute_implicits_names (Global.env()) (Global.type_of_global sr) in - let string_of_name = function Anonymous -> "_" | Name id -> string_of_id id in + let string_of_name = function Anonymous -> "_" | Name id -> Id.to_string id in let rec check li ld ls = match li, ld, ls with | [], [], [] -> () | [], Anonymous::ld, (Some _)::ls when extra_scope_flag -> check li ld ls @@ -960,10 +960,10 @@ let vernac_declare_arguments local r l nargs flags = let sr', impl = List.fold_map (fun b -> function | (Anonymous, _,_, true, max), Name id -> assert false | (Name x, _,_, true, _), Anonymous -> - error ("Argument "^string_of_id x^" cannot be declared implicit.") + error ("Argument "^Id.to_string x^" cannot be declared implicit.") | (Name iid, _,_, true, max), Name id -> - b || not (id_eq iid id), Some (ExplByName id, max, false) - | (Name iid, _,_, _, _), Name id -> b || not (id_eq iid id), None + b || not (Id.equal iid id), Some (ExplByName id, max, false) + | (Name iid, _,_, _, _), Name id -> b || not (Id.equal iid id), None | _ -> b, None) sr (List.combine il inf_names) in sr || sr', List.map_filter (fun x -> x) impl) @@ -1412,7 +1412,7 @@ let interp_search_restriction = function open Search -let is_ident s = try ignore (check_ident s); true with UserError _ -> false +let is_ident s = try ignore (Id.check s); true with UserError _ -> false let interp_search_about_item = function | SearchSubPattern pat -> @@ -1537,7 +1537,7 @@ let vernac_abort = function | Some id -> Backtrack.mark_unreachable [snd id]; delete_proof id; - let s = string_of_id (snd id) in + let s = Id.to_string (snd id) in if_verbose msg_info (str ("Goal "^s^" aborted")) let vernac_abort_all () = diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4 index 6aade9479..aa3cc9485 100644 --- a/toplevel/whelp.ml4 +++ b/toplevel/whelp.ml4 @@ -69,13 +69,13 @@ let rec url_list_with_sep sep f = function | [a] -> f a | a::l -> f a; url_string sep; url_list_with_sep sep f l -let url_id id = url_string (string_of_id id) +let url_id id = url_string (Id.to_string id) let uri_of_dirpath dir = url_string "cic:/"; url_list_with_sep "/" url_id (List.rev dir) let error_whelp_unknown_reference ref = - let qid = Nametab.shortest_qualid_of_global Idset.empty ref in + let qid = Nametab.shortest_qualid_of_global Id.Set.empty ref in errorlabstrm "" (strbrk "Definitions of the current session, like " ++ pr_qualid qid ++ strbrk ", are not supported in Whelp.") @@ -102,7 +102,7 @@ let uri_of_ind_pointer l = let uri_of_global ref = match ref with - | VarRef id -> error ("Unknown Whelp reference: "^(string_of_id id)^".") + | VarRef id -> error ("Unknown Whelp reference: "^(Id.to_string id)^".") | ConstRef cst -> uri_of_repr_kn ref (repr_con cst); url_string ".con" | IndRef (kn,i) -> @@ -110,7 +110,7 @@ let uri_of_global ref = | ConstructRef ((kn,i),j) -> uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1;j] -let whelm_special = id_of_string "WHELM_ANON_VAR" +let whelm_special = Id.of_string "WHELM_ANON_VAR" let url_of_name = function | Name id -> url_id id |