diff options
130 files changed, 735 insertions, 730 deletions
diff --git a/checker/check.ml b/checker/check.ml index 863cf7b2c..8565e96fc 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -247,12 +247,12 @@ let locate_qualified_library qid = let error_unmapped_dir qid = let prefix = qid.dirpath in - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str "Cannot load " ++ pr_path qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirlist prefix ++ fnl ()) let error_lib_not_found qid = - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str"Cannot find library " ++ pr_path qid ++ str" in loadpath") let try_locate_absolute_library dir = @@ -313,18 +313,18 @@ let intern_from_file (dir, f) = let () = close_in ch in let ch = open_in_bin f in if not (String.equal (Digest.channel ch pos) checksum) then - errorlabstrm "intern_from_file" (str "Checksum mismatch"); + user_err ~hdr:"intern_from_file" (str "Checksum mismatch"); let () = close_in ch in if dir <> sd.md_name then - errorlabstrm "intern_from_file" + user_err ~hdr:"intern_from_file" (name_clash_message dir sd.md_name f); if tasks <> None || discharging <> None then - errorlabstrm "intern_from_file" + user_err ~hdr:"intern_from_file" (str "The file "++str f++str " contains unfinished tasks"); if opaque_csts <> None then begin Feedback.msg_notice(str " (was a vio file) "); Option.iter (fun (_,_,b) -> if not b then - errorlabstrm "intern_from_file" + user_err ~hdr:"intern_from_file" (str "The file "++str f++str " is still a .vio")) opaque_csts; Validate.validate !Flags.debug Values.v_univopaques opaque_csts; diff --git a/checker/checker.ml b/checker/checker.ml index 0c411ae44..06d0cd1c0 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -213,7 +213,9 @@ let report () = (str "." ++ spc () ++ str "Please report.") let guill s = str "\"" ++ str s ++ str "\"" -let where s = +let where = function +| None -> mt () +| Some s -> if !Flags.debug then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) let rec explain_exn = function diff --git a/checker/modops.ml b/checker/modops.ml index b720fb621..aba9da2fe 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -33,7 +33,7 @@ let error_no_such_label_sub l l1 = Label.to_string l^" is missing in "^l1^".") let error_not_a_module_loc loc s = - user_err_loc (loc,"",str ("\""^Label.to_string s^"\" is not a module")) + user_err ~loc (str ("\""^Label.to_string s^"\" is not a module")) let error_not_a_module s = error_not_a_module_loc Loc.ghost s diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index 11cd742ba..53d80c6d5 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -89,6 +89,6 @@ let import file clib univs digest = let unsafe_import file clib univs digest = let env = !genv in if !Flags.debug then check_imports Feedback.msg_warning clib.comp_name env clib.comp_deps - else check_imports (errorlabstrm"unsafe_import") clib.comp_name env clib.comp_deps; + else check_imports (user_err ~hdr:"unsafe_import") clib.comp_name env clib.comp_deps; check_engagement env clib.comp_enga; full_add_module clib.comp_name clib.comp_mod univs digest diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index a7b5c61e9..fb1e805c1 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -21,6 +21,18 @@ The following type aliases where removed Context.section_context ... it was just an alias for "Context.Named.t" which is still available +* ML API * + +** Error handling ** + +- All error functions now take an optional parameter `?loc:Loc.t`. For + functions that used to carry a suffix `_loc`, such suffix has been + dropped. + +- `errorlabstrm` has been removed in favor of `user_err`. + +- The header parameter to `user_err` has been made optional. + ========================================= = CHANGES BETWEEN COQ V8.5 AND COQ V8.6 = ========================================= diff --git a/doc/refman/RefMan-tus.tex b/doc/refman/RefMan-tus.tex index 3e2988676..797b0aded 100644 --- a/doc/refman/RefMan-tus.tex +++ b/doc/refman/RefMan-tus.tex @@ -1012,7 +1012,7 @@ the different kinds of errors used in \Coq{} : \fun{val Std.error : string -> 'a} {For simple error messages} -\fun{val Std.errorlabstrm : string -> std\_ppcmds -> 'a} +\fun{val Std.user_err : ?loc:Loc.t -> string -> std\_ppcmds -> 'a} {See Section~\ref{PrettyPrinter} : this can be used if the user want to display a term or build a complex error message} diff --git a/engine/evd.ml b/engine/evd.ml index 913856a8d..e9fc74600 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -386,8 +386,7 @@ let add_name_newly_undefined naming evk evi (evtoid, idtoev as names) = | Misctypes.IntroAnonymous -> None | Misctypes.IntroIdentifier id -> if Idmap.mem id idtoev then - user_err_loc - (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id); + user_err (str "Already an existential evar of name " ++ pr_id id); Some id | Misctypes.IntroFresh id -> let id = Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 17ff898b0..6e821ea5a 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -34,7 +34,7 @@ exception Timeout exception TacticFailure of exn let _ = CErrors.register_handler begin function - | Timeout -> CErrors.errorlabstrm "Some timeout function" (Pp.str"Timeout!") + | Timeout -> CErrors.user_err ~hdr:"Some timeout function" (Pp.str"Timeout!") | Exception e -> CErrors.print e | TacticFailure e -> CErrors.print e | _ -> Pervasives.raise CErrors.Unhandled diff --git a/engine/proofview.ml b/engine/proofview.ml index 576569cf5..51b3a7260 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -365,7 +365,7 @@ let set_nosuchgoals_hook f = nosuchgoals_hook := f let _ = CErrors.register_handler begin function | NoSuchGoals n -> let suffix = !nosuchgoals_hook n in - CErrors.errorlabstrm "" + CErrors.user_err (str "No such " ++ str (String.plural n "goal") ++ str "." ++ pr_non_empty_arg (fun x -> x) suffix) | _ -> raise CErrors.Unhandled @@ -451,7 +451,7 @@ let _ = CErrors.register_handler begin function str"Incorrect number of goals" ++ spc() ++ str"(expected "++int i++str(String.plural i " tactic") ++ str")." in - CErrors.errorlabstrm "" errmsg + CErrors.user_err errmsg | _ -> raise CErrors.Unhandled end @@ -845,11 +845,11 @@ let tclPROGRESS t = if not test then tclUNIT res else - tclZERO (CErrors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) + tclZERO (CErrors.UserError (Some "Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) exception Timeout let _ = CErrors.register_handler begin function - | Timeout -> CErrors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") + | Timeout -> CErrors.user_err ~hdr:"Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") | _ -> Pervasives.raise CErrors.Unhandled end diff --git a/engine/uState.ml b/engine/uState.ml index c35f97b2e..c66af02bb 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -255,8 +255,8 @@ let universe_context ?names ctx = let l = try UNameMap.find (Id.to_string id) (fst ctx.uctx_names) with Not_found -> - user_err_loc (loc, "universe_context", - str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") + user_err ~loc ~hdr:"universe_context" + (str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc)) pl ([], [], levels) in @@ -269,8 +269,8 @@ let universe_context ?names ctx = Option.default Loc.ghost info.uloc with Not_found -> Loc.ghost in - user_err_loc (loc, "universe_context", - (str(CString.plural n "Universe") ++ spc () ++ + user_err ~loc ~hdr:"universe_context" + ((str(CString.plural n "Universe") ++ spc () ++ Univ.LSet.pr (pr_uctx_level ctx) left ++ spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.")) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 08f49ae5d..4171eb20d 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -100,7 +100,7 @@ let is_undo cmd = match cmd with (** Check whether a command is forbidden by CoqIDE *) let coqide_cmd_checks (loc,ast) = - let user_error s = CErrors.user_err_loc (loc, "CoqIde", str s) in + let user_error s = CErrors.user_err ~loc ~hdr:"CoqIde" (str s) in if is_debug ast then user_error "Debug mode not available within CoqIDE"; if is_known_option ast then @@ -301,7 +301,7 @@ let dirpath_of_string_list s = let id = try Nametab.full_name_module qid with Not_found -> - CErrors.errorlabstrm "Search.interface_search" + CErrors.user_err ~hdr:"Search.interface_search" (str "Module " ++ str path ++ str " not found.") in id diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 04429851f..59c24900d 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -382,18 +382,18 @@ let rec prod_constr_expr c = function let coerce_reference_to_id = function | Ident (_,id) -> id | Qualid (loc,_) -> - CErrors.user_err_loc (loc, "coerce_reference_to_id", - str "This expression should be a simple identifier.") + CErrors.user_err ~loc ~hdr:"coerce_reference_to_id" + (str "This expression should be a simple identifier.") let coerce_to_id = function | CRef (Ident (loc,id),_) -> (loc,id) - | a -> CErrors.user_err_loc - (constr_loc a,"coerce_to_id", - str "This expression should be a simple identifier.") + | a -> CErrors.user_err ~loc:(constr_loc a) + ~hdr:"coerce_to_id" + (str "This expression should be a simple identifier.") let coerce_to_name = function | CRef (Ident (loc,id),_) -> (loc,Name id) | CHole (loc,_,_,_) -> (loc,Anonymous) - | a -> CErrors.user_err_loc - (constr_loc a,"coerce_to_name", - str "This expression should be a name.") + | a -> CErrors.user_err + ~loc:(constr_loc a) ~hdr:"coerce_to_name" + (str "This expression should be a name.") diff --git a/interp/constrextern.ml b/interp/constrextern.ml index e71daef99..f7fcbb4ee 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -94,8 +94,8 @@ let is_record indsp = let encode_record r = let indsp = global_inductive r in if not (is_record indsp) then - user_err_loc (loc_of_reference r,"encode_record", - str "This type is not a structure type."); + user_err ~loc:(loc_of_reference r) ~hdr:"encode_record" + (str "This type is not a structure type."); indsp module PrintingRecordRecord = diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 30016dedc..630f8d140 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -154,17 +154,17 @@ let explain_internalization_error e = | BadPatternsNumber (n1,n2) -> explain_bad_patterns_number n1 n2 in pp ++ str "." -let error_bad_inductive_type loc = - user_err_loc (loc,"",str +let error_bad_inductive_type ?loc = + user_err ?loc (str "This should be an inductive type applied to patterns.") -let error_parameter_not_implicit loc = - user_err_loc (loc,"", str +let error_parameter_not_implicit ?loc = + user_err ?loc (str "The parameters do not bind in patterns;" ++ spc () ++ str "they must be replaced by '_'.") -let error_ldots_var loc = - user_err_loc (loc,"",str "Special token " ++ pr_id ldots_var ++ +let error_ldots_var ?loc = + user_err ?loc (str "Special token " ++ pr_id ldots_var ++ str " is for use in the Notation command.") (**********************************************************************) @@ -262,15 +262,15 @@ let pr_scope_stack = function | l -> str "scope stack " ++ str "[" ++ prlist_with_sep pr_comma str l ++ str "]" -let error_inconsistent_scope loc id scopes1 scopes2 = - user_err_loc (loc,"set_var_scope", - pr_id id ++ str " is here used in " ++ +let error_inconsistent_scope ?loc id scopes1 scopes2 = + user_err ?loc ~hdr:"set_var_scope" + (pr_id id ++ str " is here used in " ++ pr_scope_stack scopes2 ++ strbrk " while it was elsewhere used in " ++ pr_scope_stack scopes1) -let error_expect_binder_notation_type loc id = - user_err_loc (loc,"", - pr_id id ++ +let error_expect_binder_notation_type ?loc id = + user_err ?loc + (pr_id id ++ str " is expected to occur in binding position in the right-hand side.") let set_var_scope loc id istermvar env ntnvars = @@ -284,12 +284,12 @@ let set_var_scope loc id istermvar env ntnvars = | Some (tmp, scope) -> let s1 = make_current_scope tmp scope in let s2 = make_current_scope env.tmp_scope env.scopes in - if not (List.equal String.equal s1 s2) then error_inconsistent_scope loc id s1 s2 + if not (List.equal String.equal s1 s2) then error_inconsistent_scope ~loc id s1 s2 end in match typ with | NtnInternTypeBinder -> - if istermvar then error_expect_binder_notation_type loc id + if istermvar then error_expect_binder_notation_type ~loc id | NtnInternTypeConstr -> (* We need sometimes to parse idents at a constr level for factorization and we cannot enforce this constraint: @@ -366,19 +366,19 @@ let check_hidden_implicit_parameters id impls = | (Inductive indparams,_,_,_) -> Id.List.mem id indparams | _ -> false) impls then - errorlabstrm "" (strbrk "A parameter of an inductive type " ++ + user_err (strbrk "A parameter of an inductive type " ++ pr_id id ++ strbrk " is not allowed to be used as a bound variable in the type of its constructor.") let push_name_env ?(global_level=false) ntnvars implargs env = function | loc,Anonymous -> if global_level then - user_err_loc (loc,"", str "Anonymous variables not allowed"); + user_err ~loc (str "Anonymous variables not allowed"); env | loc,Name id -> check_hidden_implicit_parameters id env.impls ; if Id.Map.is_empty ntnvars && Id.equal id ldots_var - then error_ldots_var loc; + then error_ldots_var ~loc; set_var_scope loc id false env ntnvars; if global_level then Dumpglob.dump_definition (loc,id) true "var" else Dumpglob.dump_binding loc id; @@ -764,7 +764,7 @@ let string_of_ty = function let gvar (loc, id) us = match us with | None -> GVar (loc, id) | Some _ -> - user_err_loc (loc, "", str "Variable " ++ pr_id id ++ + user_err ~loc (str "Variable " ++ pr_id id ++ str " cannot have a universe instance") let intern_var genv (ltacvars,ntnvars) namedctx loc id us = @@ -788,12 +788,12 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id us = (* Is [id] the special variable for recursive notations *) else if Id.equal id ldots_var then if Id.Map.is_empty ntnvars - then error_ldots_var loc + then error_ldots_var ~loc else gvar (loc,id) us, [], [], [] else if Id.Set.mem id ltacvars.ltac_bound then (* Is [id] bound to a free name in ltac (this is an ltac error message) *) - user_err_loc (loc,"intern_var", - str "variable " ++ pr_id id ++ str " should be bound to a term.") + user_err ~loc ~hdr:"intern_var" + (str "variable " ++ pr_id id ++ str " should be bound to a term.") else (* Is [id] a goal or section variable *) let _ = Context.Named.lookup id namedctx in @@ -825,7 +825,7 @@ let find_appl_head_data c = | x -> x,[],[],[] let error_not_enough_arguments loc = - user_err_loc (loc,"",str "Abbreviation is not applied enough.") + user_err ~loc (str "Abbreviation is not applied enough.") let check_no_explicitation l = let is_unset (a, b) = match b with None -> false | Some _ -> true in @@ -834,7 +834,7 @@ let check_no_explicitation l = | [] -> () | (_, None) :: _ -> assert false | (_, Some (loc, _)) :: _ -> - user_err_loc (loc,"",str"Unexpected explicitation of the argument of an abbreviation.") + user_err ~loc (str"Unexpected explicitation of the argument of an abbreviation.") let dump_extended_global loc = function | TrueGlobal ref -> (*feedback_global loc ref;*) Dumpglob.add_glob loc ref @@ -847,7 +847,7 @@ let intern_reference ref = let qid = qualid_of_reference ref in let r = try intern_extended_global_of_qualid qid - with Not_found -> error_global_not_found_loc (fst qid) (snd qid) + with Not_found -> error_global_not_found ~loc:(fst qid) (snd qid) in Smartlocate.global_of_extended_global r @@ -872,7 +872,7 @@ let intern_qualid loc qid intern env lvar us args = | Some _, GApp (loc, GRef (loc', ref, None), arg) -> GApp (loc, GRef (loc', ref, us), arg) | Some _, _ -> - user_err_loc (loc, "", str "Notation " ++ pr_qualid qid ++ + user_err ~loc (str "Notation " ++ pr_qualid qid ++ str " cannot have a universe instance, its expanded head does not start with a reference") in @@ -888,7 +888,7 @@ let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args = | Qualid (loc, qid) -> let r,projapp,args2 = try intern_qualid loc qid intern env ntnvars us args - with Not_found -> error_global_not_found_loc loc qid + with Not_found -> error_global_not_found ~loc qid in let x, imp, scopes, l = find_appl_head_data r in (x,imp,scopes,l), args2 @@ -904,7 +904,7 @@ let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args = (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then (gvar (loc,id) us, [], [], []), args - else error_global_not_found_loc loc qid + else error_global_not_found ~loc qid let interp_reference vars r = let (r,_,_,_),_ = @@ -982,7 +982,7 @@ let check_number_of_pattern loc n l = let check_or_pat_variables loc ids idsl = if List.exists (fun ids' -> not (List.eq_set Id.equal ids ids')) idsl then - user_err_loc (loc, "", str + user_err ~loc (str "The components of this disjunctive pattern must bind the same variables.") (** Use only when params were NOT asked to the user. @@ -991,7 +991,7 @@ let check_constructor_length env loc cstr len_pl pl0 = let n = len_pl + List.length pl0 in if Int.equal n (Inductiveops.constructor_nallargs cstr) then false else (Int.equal n (Inductiveops.constructor_nalldecls cstr) || - (error_wrong_numarg_constructor_loc loc env cstr + (error_wrong_numarg_constructor ~loc env cstr (Inductiveops.constructor_nrealargs cstr))) let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 = @@ -1016,14 +1016,14 @@ let add_implicits_check_constructor_length env loc c len_pl1 pl2 = let nargs = Inductiveops.constructor_nallargs c in let nargs' = Inductiveops.constructor_nalldecls c in let impls_st = implicits_of_global (ConstructRef c) in - add_implicits_check_length (error_wrong_numarg_constructor_loc loc env c) + add_implicits_check_length (error_wrong_numarg_constructor ~loc env c) nargs nargs' impls_st len_pl1 pl2 let add_implicits_check_ind_length env loc c len_pl1 pl2 = let nallargs = inductive_nallargs_env env c in let nalldecls = inductive_nalldecls_env env c in let impls_st = implicits_of_global (IndRef c) in - add_implicits_check_length (error_wrong_numarg_inductive_loc loc env c) + add_implicits_check_length (error_wrong_numarg_inductive ~loc env c) nallargs nalldecls impls_st len_pl1 pl2 (** Do not raise NotEnoughArguments thanks to preconditions*) @@ -1034,7 +1034,7 @@ let chop_params_pattern loc ind args with_letin = assert (nparams <= List.length args); let params,args = List.chop nparams args in List.iter (function PatVar(_,Anonymous) -> () - | PatVar (loc',_) | PatCstr(loc',_,_,_) -> error_parameter_not_implicit loc') params; + | PatVar (loc',_) | PatCstr(loc',_,_,_) -> error_parameter_not_implicit ~loc:loc') params; args let find_constructor loc add_params ref = @@ -1042,10 +1042,10 @@ let find_constructor loc add_params ref = | ConstructRef cstr -> cstr | IndRef _ -> let error = str "There is an inductive name deep in a \"in\" clause." in - user_err_loc (loc, "find_constructor", error) + user_err ~loc ~hdr:"find_constructor" error | ConstRef _ | VarRef _ -> let error = str "This reference is not a constructor." in - user_err_loc (loc, "find_constructor", error) + user_err ~loc ~hdr:"find_constructor" error in cstr, match add_params with | Some nb_args -> @@ -1083,8 +1083,8 @@ let sort_fields ~complete loc fields completer = let gr = global_reference_of_reference first_field_ref in (gr, Recordops.find_projection gr) with Not_found -> - user_err_loc (loc_of_reference first_field_ref, "intern", - pr_reference first_field_ref ++ str": Not a projection") + user_err ~loc:(loc_of_reference first_field_ref) ~hdr:"intern" + (pr_reference first_field_ref ++ str": Not a projection") in (* the number of parameters *) let nparams = record.Recordops.s_EXPECTEDPARAM in @@ -1113,7 +1113,7 @@ let sort_fields ~complete loc fields completer = by a let-in in the record declaration (its value is fixed from other fields). *) if first_field && not regular && complete then - user_err_loc (loc, "", str "No local fields allowed in a record construction.") + user_err ~loc (str "No local fields allowed in a record construction.") else if first_field then build_proj_list projs proj_kinds (idx+1) ~acc_first_idx:idx acc else if not regular && complete then @@ -1126,7 +1126,7 @@ let sort_fields ~complete loc fields completer = | None :: projs -> if complete then (* we don't want anonymous fields *) - user_err_loc (loc, "", str "This record contains anonymous fields.") + user_err ~loc (str "This record contains anonymous fields.") else (* anonymous arguments don't appear in proj_kinds *) build_proj_list projs proj_kinds (idx+1) ~acc_first_idx acc @@ -1140,15 +1140,14 @@ let sort_fields ~complete loc fields completer = | (field_ref, field_value) :: fields -> let field_glob_ref = try global_reference_of_reference field_ref with Not_found -> - user_err_loc (loc_of_reference field_ref, "intern", - str "The field \"" ++ pr_reference field_ref ++ str "\" does not exist.") in + user_err ~loc:(loc_of_reference field_ref) ~hdr:"intern" + (str "The field \"" ++ pr_reference field_ref ++ str "\" does not exist.") in let remaining_projs, (field_index, _) = let the_proj (idx, glob_ref) = eq_gr field_glob_ref glob_ref in try CList.extract_first the_proj remaining_projs with Not_found -> - user_err_loc - (loc, "", - str "This record contains fields of different records.") + user_err ~loc + (str "This record contains fields of different records.") in index_fields fields remaining_projs ((field_index, field_value) :: acc) | [] -> @@ -1219,7 +1218,7 @@ let drop_notations_pattern looked_for = if top then looked_for g else match g with ConstructRef _ -> () | _ -> raise Not_found with Not_found -> - error_invalid_pattern_notation loc + error_invalid_pattern_notation ~loc in let test_kind top = if top then looked_for else function ConstructRef _ -> () | _ -> raise Not_found @@ -1344,8 +1343,8 @@ let drop_notations_pattern looked_for = List.map2 (fun x -> in_not false loc (x,snd scopes) fullsubst []) argscs1 pl @ List.map (in_pat false scopes) args, []) | NList (x,y,iter,terminator,lassoc) -> - if not (List.is_empty args) then user_err_loc - (loc,"",strbrk "Application of arguments to a recursive notation not supported in patterns."); + if not (List.is_empty args) then user_err ~loc + (strbrk "Application of arguments to a recursive notation not supported in patterns."); (try (* All elements of the list are in scopes (scopt,subscopes) *) let (l,(scopt,subscopes)) = Id.Map.find x substlist in @@ -1360,7 +1359,7 @@ let drop_notations_pattern looked_for = | NHole _ -> let () = assert (List.is_empty args) in RCPatAtom (loc, None) - | t -> error_invalid_pattern_notation loc + | t -> error_invalid_pattern_notation ~loc in in_pat true let rec intern_pat genv aliases pat = @@ -1412,11 +1411,11 @@ let intern_ind_pattern genv scopes pat = let no_not = try drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) scopes pat - with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type loc + with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type ~loc in match no_not with | RCPatCstr (loc, head, expl_pl, pl) -> - let c = (function IndRef ind -> ind | _ -> error_bad_inductive_type loc) head in + let c = (function IndRef ind -> ind | _ -> error_bad_inductive_type ~loc) head in let with_letin, pl2 = add_implicits_check_ind_length genv loc c (List.length expl_pl) pl in let idslpl1 = List.rev_map (intern_pat genv empty_alias) expl_pl in @@ -1424,8 +1423,8 @@ let intern_ind_pattern genv scopes pat = (with_letin, match product_of_cases_patterns [] (List.rev_append idslpl1 idslpl2) with | _,[_,pl] -> (c,chop_params_pattern loc c pl with_letin) - | _ -> error_bad_inductive_type loc) - | x -> error_bad_inductive_type (raw_cases_pattern_expr_loc x) + | _ -> error_bad_inductive_type ~loc) + | x -> error_bad_inductive_type ~loc:(raw_cases_pattern_expr_loc x) (**********************************************************************) (* Utilities for application *) @@ -1464,10 +1463,10 @@ let extract_explicit_arg imps args = let id = match pos with | ExplByName id -> if not (exists_implicit_name id imps) then - user_err_loc - (loc,"",str "Wrong argument name: " ++ pr_id id ++ str "."); + user_err ~loc + (str "Wrong argument name: " ++ pr_id id ++ str "."); if Id.Map.mem id eargs then - user_err_loc (loc,"",str "Argument name " ++ pr_id id + user_err ~loc (str "Argument name " ++ pr_id id ++ str " occurs more than once."); id | ExplByPos (p,_id) -> @@ -1477,11 +1476,11 @@ let extract_explicit_arg imps args = if not (is_status_implicit imp) then failwith "imp"; name_of_implicit imp with Failure _ (* "nth" | "imp" *) -> - user_err_loc - (loc,"",str"Wrong argument position: " ++ int p ++ str ".") + user_err ~loc + (str"Wrong argument position: " ++ int p ++ str ".") in if Id.Map.mem id eargs then - user_err_loc (loc,"",str"Argument at position " ++ int p ++ + user_err ~loc (str"Argument at position " ++ int p ++ str " is mentioned more than once."); id in (Id.Map.add id (loc, a) eargs, rargs) @@ -1532,7 +1531,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = (function | BDRawDef a -> a | BDPattern (loc,_,_,_,_) -> - Loc.raise loc (Stream.Error "pattern with quote not allowed after fix")) rbl in + Loc.raise ~loc (Stream.Error "pattern with quote not allowed after fix")) rbl in ((n, ro), bl, intern_type env' ty, env')) dl in let idl = Array.map2 (fun (_,_,_,_,bd) (a,b,c,env') -> let env'' = List.fold_left_i (fun i en name -> @@ -1636,7 +1635,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = in begin match fields with - | None -> user_err_loc (loc, "intern", str"No constructor inference.") + | None -> user_err ~loc ~hdr:"intern" (str"No constructor inference.") | Some (n, constrname, args) -> let pars = List.make n (CHole (loc, None, Misctypes.IntroAnonymous, None)) in let app = CAppExpl (loc, (None, constrname,None), List.rev_append pars args) in @@ -1859,7 +1858,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = | (imp::impl', []) -> if not (Id.Map.is_empty eargs) then (let (id,(loc,_)) = Id.Map.choose eargs in - user_err_loc (loc,"",str "Not enough non implicit \ + user_err ~loc (str "Not enough non implicit \ arguments to accept the argument bound to " ++ pr_id id ++ str".")); [] @@ -1890,8 +1889,8 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = intern env c with InternalizationError (loc,e) -> - user_err_loc (loc,"internalize", - explain_internalization_error e) + user_err ~loc ~hdr:"internalize" + (explain_internalization_error e) (**************************************************************************) (* Functions to translate constr_expr into glob_constr *) @@ -1930,7 +1929,7 @@ let intern_pattern globalenv patt = intern_cases_pattern globalenv (None,[]) empty_alias patt with InternalizationError (loc,e) -> - user_err_loc (loc,"internalize",explain_internalization_error e) + user_err ~loc ~hdr:"internalize" (explain_internalization_error e) (*********************************************************************) @@ -2041,13 +2040,13 @@ let intern_context global_level env impl_env binders = (function | BDRawDef a -> a | BDPattern (loc,_,_,_,_) -> - Loc.raise loc (Stream.Error "pattern with quote not allowed here")) bl in + Loc.raise ~loc (Stream.Error "pattern with quote not allowed here")) bl in (env, bl)) ({ids = extract_ids env; unb = false; tmp_scope = None; scopes = []; impls = impl_env}, []) binders in (lenv.impls, List.map snd bl) with InternalizationError (loc,e) -> - user_err_loc (loc,"internalize", explain_internalization_error e) + user_err ~loc ~hdr:"internalize" (explain_internalization_error e) let interp_rawcontext_evars env evdref k bl = let (env, par, _, impls) = diff --git a/interp/coqlib.ml b/interp/coqlib.ml index 588637b76..9539980f0 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -86,7 +86,7 @@ let check_required_library d = (Loc.ghost,make_qualid (DirPath.make (List.rev prefix)) m) *) (* or failing ...*) - errorlabstrm "Coqlib.check_required_library" + user_err ~hdr:"Coqlib.check_required_library" (str "Library " ++ pr_dirpath dir ++ str " has to be required first.") (************************************************************************) diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 4d9386b9d..bfa01532f 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -29,12 +29,12 @@ let generalizable_table = Summary.ref Id.Pred.empty ~name:"generalizable-ident" let declare_generalizable_ident table (loc,id) = if not (Id.equal id (root_of_id id)) then - user_err_loc(loc,"declare_generalizable_ident", - (pr_id id ++ str + user_err ~loc ~hdr:"declare_generalizable_ident" + ((pr_id id ++ str " is not declarable as generalizable identifier: it must have no trailing digits, quote, or _")); 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")) + user_err ~loc ~hdr:"declare_generalizable_ident" + ((pr_id id++str" is already declared as a generalizable identifier")) else Id.Pred.add id table let add_generalizable gen table = @@ -80,8 +80,8 @@ let is_freevar ids env x = (* Auxiliary functions for the inference of implicitly quantified variables. *) let ungeneralizable loc id = - user_err_loc (loc, "Generalization", - str "Unbound and ungeneralizable variable " ++ pr_id id) + user_err ~loc ~hdr:"Generalization" + (str "Unbound and ungeneralizable variable " ++ pr_id id) let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = let found loc id bdvars l = @@ -205,7 +205,7 @@ let combine_params avoid fn applied needed = | Anonymous -> false in if not (List.exists is_id needed) then - user_err_loc (loc,"",str "Wrong argument name: " ++ Nameops.pr_id id); + user_err ~loc (str "Wrong argument name: " ++ Nameops.pr_id id); true | _ -> false) applied in @@ -239,7 +239,7 @@ let combine_params avoid fn applied needed = aux (t' :: ids) avoid' app need | (x,_) :: _, [] -> - user_err_loc (Constrexpr_ops.constr_loc x,"",str "Typeclass does not expect more arguments") + user_err ~loc:(Constrexpr_ops.constr_loc x) (str "Typeclass does not expect more arguments") in aux [] avoid applied needed let combine_params_freevar = diff --git a/interp/modintern.ml b/interp/modintern.ml index e5dce5ccf..d4ade7058 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -26,16 +26,16 @@ let error_not_a_module_loc kind loc qid = | ModType -> Modops.ModuleTypingError (Modops.NotAModuleType s) | ModAny -> ModuleInternalizationError (NotAModuleNorModtype s) in - Loc.raise loc e + Loc.raise ~loc e let error_application_to_not_path loc me = - Loc.raise loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me)) + Loc.raise ~loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me)) let error_incorrect_with_in_module loc = - Loc.raise loc (ModuleInternalizationError IncorrectWithInModule) + Loc.raise ~loc (ModuleInternalizationError IncorrectWithInModule) let error_application_to_module_type loc = - Loc.raise loc (ModuleInternalizationError IncorrectModuleApplication) + Loc.raise ~loc (ModuleInternalizationError IncorrectModuleApplication) (** Searching for a module name in the Nametab. diff --git a/interp/notation.ml b/interp/notation.ml index 6279622bf..29d1f01eb 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -98,7 +98,7 @@ let declare_scope scope = scope_map := String.Map.add scope empty_scope !scope_map let error_unknown_scope sc = - errorlabstrm "Notation" + user_err ~hdr:"Notation" (str "Scope " ++ str sc ++ str " is not declared.") let find_scope scope = @@ -211,7 +211,7 @@ let remove_delimiters scope = let sc = find_scope scope in let newsc = { sc with delimiters = None } in match sc.delimiters with - | None -> CErrors.errorlabstrm "" (str "No bound key for scope " ++ str scope ++ str ".") + | None -> CErrors.user_err (str "No bound key for scope " ++ str scope ++ str ".") | Some key -> scope_map := String.Map.add scope newsc !scope_map; try @@ -223,8 +223,8 @@ let remove_delimiters scope = let find_delimiters_scope loc key = try String.Map.find key !delimiters_map with Not_found -> - user_err_loc - (loc, "find_delimiters", str "Unknown scope delimiting key " ++ str key ++ str ".") + user_err ~loc ~hdr:"find_delimiters" + (str "Unknown scope delimiting key " ++ str key ++ str ".") (* Uninterpretation tables *) @@ -340,8 +340,8 @@ let declare_string_interpreter sc dir interp (patl,uninterp,inpat) = let check_required_module loc sc (sp,d) = try let _ = Nametab.global_of_path sp in () with Not_found -> - user_err_loc (loc,"prim_token_interpreter", - str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ str (List.last d) ++ str ".") + user_err ~loc ~hdr:"prim_token_interpreter" + (str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ str (List.last d) ++ str ".") (* Look if some notation or numeral printer in [scope] can be used in the scope stack [scopes], and if yes, using delimiters or not *) @@ -461,8 +461,8 @@ let interp_prim_token_gen g loc p local_scopes = let p_as_ntn = try notation_of_prim_token p with Not_found -> "" in try find_interpretation p_as_ntn (find_prim_token g loc p) scopes with Not_found -> - user_err_loc (loc,"interp_prim_token", - (match p with + user_err ~loc ~hdr:"interp_prim_token" + ((match p with | Numeral n -> str "No interpretation for numeral " ++ str (to_string n) | String s -> str "No interpretation for string " ++ qs s) ++ str ".") @@ -486,8 +486,8 @@ let interp_notation loc ntn local_scopes = let scopes = make_current_scopes local_scopes in try find_interpretation ntn (find_notation ntn) scopes with Not_found -> - user_err_loc - (loc,"",str "Unknown interpretation for notation \"" ++ str ntn ++ str "\".") + user_err ~loc + (str "Unknown interpretation for notation \"" ++ str ntn ++ str "\".") let uninterp_notations c = List.map_append (fun key -> keymap_find key !notations_key_table) @@ -893,11 +893,11 @@ let global_reference_of_notation test (ntn,(sc,c,_)) = | _ -> None let error_ambiguous_notation loc _ntn = - user_err_loc (loc,"",str "Ambiguous notation.") + user_err ~loc (str "Ambiguous notation.") let error_notation_not_reference loc ntn = - user_err_loc (loc,"", - str "Unable to interpret " ++ quote (str ntn) ++ + user_err ~loc + (str "Unable to interpret " ++ quote (str ntn) ++ str " as a reference.") let interp_notation_as_global_reference loc test ntn sc = @@ -1020,8 +1020,8 @@ let add_notation_extra_printing_rule ntn k v = let p, pp, gr = String.Map.find ntn !notation_rules in String.Map.add ntn (p, (k,v) :: pp, gr) !notation_rules with Not_found -> - user_err_loc (Loc.ghost,"add_notation_extra_printing_rule", - str "No such Notation.") + user_err ~hdr:"add_notation_extra_printing_rule" + (str "No such Notation.") (**********************************************************************) (* Synchronisation with reset *) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index fcb4a345e..af87aae1b 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -242,8 +242,8 @@ let split_at_recursive_part c = let subtract_loc loc1 loc2 = Loc.make_loc (fst (Loc.unloc loc1),fst (Loc.unloc loc2)-1) let check_is_hole id = function GHole _ -> () | t -> - user_err_loc (loc_of_glob_constr t,"", - strbrk "In recursive notation with binders, " ++ pr_id id ++ + user_err ~loc:(loc_of_glob_constr t) + (strbrk "In recursive notation with binders, " ++ pr_id id ++ strbrk " is expected to come without type.") let pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b' @@ -292,8 +292,8 @@ let compare_recursive_parts found f f' (iterator,subc) = let loc1 = loc_of_glob_constr iterator in let loc2 = loc_of_glob_constr (Option.get !terminator) in (* Here, we would need a loc made of several parts ... *) - user_err_loc (subtract_loc loc1 loc2,"", - str "Both ends of the recursive pattern are the same.") + user_err ~loc:(subtract_loc loc1 loc2) + (str "Both ends of the recursive pattern are the same.") | Some (x,y,Some lassoc) -> let newfound,x,y,lassoc = if List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi2 !found) || @@ -333,8 +333,8 @@ let notation_constr_and_vars_of_glob_constr a = | 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,"", - str "Cannot find where the recursive pattern starts.") + user_err ~loc + (str "Cannot find where the recursive pattern starts.") | c -> aux' c and aux' = function @@ -386,7 +386,7 @@ let check_variables nenv (found,foundrec,foundrecbinding) = let vars = Id.Map.filter filter nenv.ninterp_var_type in let check_recvar x = if Id.List.mem x found then - errorlabstrm "" (pr_id x ++ + user_err (pr_id x ++ strbrk " should only be used in the recursive part of a pattern.") in let check (x, y) = check_recvar x; check_recvar y in let () = List.iter check foundrec in @@ -405,7 +405,7 @@ let check_variables nenv (found,foundrec,foundrecbinding) = in let check_pair s x y where = if not (List.mem_f (pair_equal Id.equal Id.equal) (x,y) where) then - errorlabstrm "" (strbrk "in the right-hand side, " ++ pr_id x ++ + user_err (strbrk "in the right-hand side, " ++ pr_id x ++ str " and " ++ pr_id y ++ strbrk " should appear in " ++ str s ++ str " position as part of a recursive pattern.") in let check_type x typ = diff --git a/interp/reserve.ml b/interp/reserve.ml index 388ca0805..a4d4f4027 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -86,13 +86,13 @@ let in_reserved : Id.t * notation_constr -> obj = let declare_reserved_type_binding (loc,id) t = if not (Id.equal id (root_of_id id)) then - user_err_loc(loc,"declare_reserved_type", - (pr_id id ++ str + user_err ~loc ~hdr:"declare_reserved_type" + ((pr_id id ++ str " is not reservable: it must have no trailing digits, quote, or _")); begin try 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")) + user_err ~loc ~hdr:"declare_reserved_type" + ((pr_id id++str" is already bound to a type")) with Not_found -> () end; add_anonymous_leaf (in_reserved (id,t)) diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 478774219..178c1c1f9 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -46,7 +46,7 @@ let locate_global_with_alias ?(head=false) (loc,qid) = if head then global_of_extended_global_head ref else global_of_extended_global ref with Not_found -> - user_err_loc (loc,"",pr_qualid qid ++ + user_err ~loc (pr_qualid qid ++ str " is bound to a notation that does not denote a reference.") let global_inductive_with_alias r = @@ -54,14 +54,14 @@ let global_inductive_with_alias r = try match locate_global_with_alias lqid with | IndRef ind -> ind | ref -> - user_err_loc (loc_of_reference r,"global_inductive", - pr_reference r ++ spc () ++ str "is not an inductive type.") - with Not_found -> Nametab.error_global_not_found_loc loc qid + user_err ~loc:(loc_of_reference r) ~hdr:"global_inductive" + (pr_reference r ++ spc () ++ str "is not an inductive type.") + with Not_found -> Nametab.error_global_not_found ~loc qid let global_with_alias ?head r = let (loc,qid as lqid) = qualid_of_reference r in try locate_global_with_alias ?head lqid - with Not_found -> Nametab.error_global_not_found_loc loc qid + with Not_found -> Nametab.error_global_not_found ~loc qid let smart_global ?head = function | AN r -> diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index d2dcbd92a..870b4bbcf 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -30,7 +30,7 @@ let add_syntax_constant kn c onlyparse = let load_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = if Nametab.exists_cci sp then - errorlabstrm "cache_syntax_constant" + user_err ~hdr:"cache_syntax_constant" (pr_id (basename sp) ++ str " already exists"); add_syntax_constant kn pat onlyparse; Nametab.push_syndef (Nametab.Until i) sp kn diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 2b860173a..0f894019b 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -32,8 +32,8 @@ let _ = Goptions.declare_bool_option { (**********************************************************************) (* Miscellaneous *) -let error_invalid_pattern_notation loc = - user_err_loc (loc,"",str "Invalid notation for pattern.") +let error_invalid_pattern_notation ?loc = + user_err ?loc (str "Invalid notation for pattern.") (**********************************************************************) (* Functions on constr_expr *) @@ -175,8 +175,8 @@ let split_at_annot bl na = | LocalRawDef _ as x :: rest -> aux (x :: acc) rest | LocalPattern _ :: rest -> assert false | [] -> - user_err_loc(loc,"", - str "No parameter named " ++ Nameops.pr_id id ++ str".") + user_err ~loc + (str "No parameter named " ++ Nameops.pr_id id ++ str".") in aux [] bl (* Used in correctness and interface *) diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 58edd4ddf..ac98331c6 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -46,4 +46,4 @@ val patntn_loc : (** For cases pattern parsing errors *) -val error_invalid_pattern_notation : Loc.t -> 'a +val error_invalid_pattern_notation : ?loc:Loc.t -> 'a diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 008955d80..52f0730f3 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -902,7 +902,7 @@ let compile fail_on_error ?universes:(universes=0) env c = Feedback.msg_debug (dump_bytecodes init_code !fun_code fv)) ; Some (init_code,!fun_code, Array.of_list fv) with TooLargeInductive tname -> - let fn = if fail_on_error then CErrors.errorlabstrm "compile" else + let fn = if fail_on_error then CErrors.user_err ?loc:None ~hdr:"compile" else (fun x -> Feedback.msg_warning x) in (Pp.(fn (str "Cannot compile code for virtual machine as it uses inductive " ++ diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index f176ca579..ae3679ddd 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -818,7 +818,7 @@ let export ?except senv dir = try join_safe_environment ?except senv with e -> let e = CErrors.push e in - CErrors.errorlabstrm "export" (CErrors.iprint e) + CErrors.user_err ~hdr:"export" (CErrors.iprint e) in assert(senv.future_cst = []); let () = check_current_library dir senv in @@ -854,7 +854,7 @@ let import lib cst vodigest senv = check_required senv.required lib.comp_deps; check_engagement senv.env lib.comp_enga; if DirPath.equal (ModPath.dp senv.modpath) lib.comp_name then - CErrors.errorlabstrm "Safe_typing.import" + CErrors.user_err ~hdr:"Safe_typing.import" (Pp.strbrk "Cannot load a library with the same name as the current one."); let mp = MPfile lib.comp_name in let mb = lib.comp_mod in diff --git a/kernel/term.ml b/kernel/term.ml index 15f187e5c..08f888868 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -465,7 +465,7 @@ let rec to_lambda n prod = match kind_of_term prod with | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) | Cast (c,_,_) -> to_lambda n c - | _ -> errorlabstrm "to_lambda" (mt ()) + | _ -> user_err ~hdr:"to_lambda" (mt ()) let rec to_prod n lam = if Int.equal n 0 then @@ -474,7 +474,7 @@ let rec to_prod n lam = match kind_of_term lam with | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) | Cast (c,_,_) -> to_prod n c - | _ -> errorlabstrm "to_prod" (mt ()) + | _ -> user_err ~hdr:"to_prod" (mt ()) let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 7a5ac7a39..d8774944e 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -277,7 +277,7 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) if not (Id.Set.subset inferred_set declared_set) then let l = Id.Set.elements (Idset.diff inferred_set declared_set) in let n = List.length l in - errorlabstrm "" (Pp.(str "The following section " ++ + user_err (Pp.(str "The following section " ++ str (String.plural n "variable") ++ str " " ++ str (String.conjugate_verb_to_be n) ++ str " used but not declared:" ++ diff --git a/lib/cErrors.ml b/lib/cErrors.ml index 1459141d1..38ed3f5ba 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -26,25 +26,24 @@ let _ = let make_anomaly ?label pp = Anomaly (label, pp) -let anomaly ?loc ?label pp = match loc with - | None -> raise (Anomaly (label, pp)) - | Some loc -> Loc.raise loc (Anomaly (label, pp)) +let anomaly ?loc ?label pp = + Loc.raise ?loc (Anomaly (label, pp)) let is_anomaly = function | Anomaly _ -> true | _ -> false -exception UserError of string * std_ppcmds (* User errors *) -let error string = raise (UserError("_", str string)) -let errorlabstrm l pps = raise (UserError(l,pps)) - -exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *) -let alreadydeclared pps = raise (AlreadyDeclared(pps)) +exception UserError of string option * std_ppcmds (* User errors *) let todo s = prerr_string ("TODO: "^s^"\n") -let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm)) -let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s) +let user_err ?loc ?hdr strm = Loc.raise ?loc (UserError (hdr, strm)) +let error string = user_err (str string) + +let invalid_arg ?loc s = Loc.raise ?loc (Invalid_argument s) + +exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *) +let alreadydeclared pps = raise (AlreadyDeclared(pps)) exception Timeout exception Drop @@ -113,7 +112,7 @@ let iprint_no_report (e, info) = let _ = register_handler begin function | UserError(s, pps) -> - hov 0 (str "Error: " ++ where (Some s) ++ pps) + hov 0 (str "Error: " ++ where s ++ pps) | _ -> raise Unhandled end diff --git a/lib/cErrors.mli b/lib/cErrors.mli index e5dad93fd..5cffc725d 100644 --- a/lib/cErrors.mli +++ b/lib/cErrors.mli @@ -33,15 +33,21 @@ val is_anomaly : exn -> bool This is mostly provided for compatibility. Please avoid doing specific tricks with anomalies thanks to it. See rather [noncritical] below. *) -exception UserError of string * std_ppcmds +exception UserError of string option * std_ppcmds +(** Main error signaling exception. It carries a header plus a pretty printing + doc *) + +val user_err : ?loc:Loc.t -> ?hdr:string -> std_ppcmds -> 'a +(** Main error raising primitive. [user_err ?loc ?hdr pp] signals an + error [pp] with optional header and location [hdr] [loc] *) + val error : string -> 'a -val errorlabstrm : string -> std_ppcmds -> 'a -val user_err_loc : Loc.t * string * std_ppcmds -> 'a +(** [error s] just calls [user_error "_" (str s)] *) exception AlreadyDeclared of std_ppcmds val alreadydeclared : std_ppcmds -> 'a -val invalid_arg_loc : Loc.t * string -> 'a +val invalid_arg : ?loc:Loc.t -> string -> 'a (** [todo] is for running of an incomplete code its implementation is "do nothing" (or print a message), but this function should not be diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index 78fa84f33..18b26254d 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -45,7 +45,7 @@ let create ~name ~category ?(default=Enabled) pp = | Disabled -> () | AsError -> let loc = Option.default !current_loc loc in - CErrors.user_err_loc (loc,"_",pp x) + CErrors.user_err ~loc (pp x) | Enabled -> let msg = pp x ++ spc () ++ str "[" ++ str name ++ str "," ++ diff --git a/lib/loc.ml b/lib/loc.ml index 0f9864a9a..e373a760c 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -71,6 +71,9 @@ let add_loc e loc = Exninfo.add e location loc let get_loc e = Exninfo.get e location -let raise loc e = - let info = Exninfo.add Exninfo.null location loc in - Exninfo.iraise (e, info) +let raise ?loc e = + match loc with + | None -> raise e + | Some loc -> + let info = Exninfo.add Exninfo.null location loc in + Exninfo.iraise (e, info) diff --git a/lib/loc.mli b/lib/loc.mli index c08e097a8..bb88f8642 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -51,7 +51,7 @@ val add_loc : Exninfo.info -> t -> Exninfo.info val get_loc : Exninfo.info -> t option (** Retrieving the optional location of an exception *) -val raise : t -> exn -> 'a +val raise : ?loc:t -> exn -> 'a (** [raise loc e] is the same as [Pervasives.raise (add_loc e loc)]. *) (** {5 Location utilities} *) diff --git a/lib/system.ml b/lib/system.ml index af9aa5c07..0f610b8d5 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -132,7 +132,7 @@ let find_file_in_path ?(warn=true) paths filename = let root = Filename.dirname filename in root, filename else - CErrors.errorlabstrm "System.find_file_in_path" + CErrors.user_err ~hdr:"System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename)) else (* the name is considered to be the transcription as a relative @@ -140,7 +140,7 @@ let find_file_in_path ?(warn=true) paths filename = to be locate respecting case *) try where_in_path ~warn paths filename with Not_found -> - CErrors.errorlabstrm "System.find_file_in_path" + CErrors.user_err ~hdr:"System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ str "on loadpath")) @@ -163,7 +163,7 @@ let is_in_system_path filename = let open_trapping_failure name = try open_out_bin name with e when CErrors.noncritical e -> - CErrors.errorlabstrm "System.open" (str "Can't open " ++ str name) + CErrors.user_err ~hdr:"System.open" (str "Can't open " ++ str name) let warn_cannot_remove_file = CWarnings.create ~name:"cannot-remove-file" ~category:"filesystem" @@ -175,7 +175,7 @@ let try_remove filename = warn_cannot_remove_file filename let error_corrupted file s = - CErrors.errorlabstrm "System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") + CErrors.user_err ~hdr:"System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") let input_binary_int f ch = try input_binary_int ch @@ -252,7 +252,7 @@ let extern_state magic filename val_0 = let () = try_remove filename in iraise reraise with Sys_error s -> - CErrors.errorlabstrm "System.extern_state" (str "System error: " ++ str s) + CErrors.user_err ~hdr:"System.extern_state" (str "System error: " ++ str s) let intern_state magic filename = try @@ -261,12 +261,12 @@ let intern_state magic filename = close_in channel; v with Sys_error s -> - CErrors.errorlabstrm "System.intern_state" (str "System error: " ++ str s) + CErrors.user_err ~hdr:"System.intern_state" (str "System error: " ++ str s) let with_magic_number_check f a = try f a with Bad_magic_number {filename=fname;actual=actual;expected=expected} -> - CErrors.errorlabstrm "with_magic_number_check" + CErrors.user_err ~hdr:"with_magic_number_check" (str"File " ++ str fname ++ strbrk" has bad magic number " ++ int actual ++ str" (expected " ++ int expected ++ str")." ++ spc () ++ diff --git a/library/declare.ml b/library/declare.ml index 3d063225f..cc8415cf4 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -462,8 +462,8 @@ let do_universe poly l = let in_section = Lib.sections_are_opened () in let () = if poly && not in_section then - user_err_loc (Loc.ghost, "Constraint", - str"Cannot declare polymorphic universes outside sections") + user_err ~hdr:"Constraint" + (str"Cannot declare polymorphic universes outside sections") in let l = List.map (fun (l, id) -> @@ -496,20 +496,20 @@ let do_constraint poly l = fun (loc, id) -> try Idmap.find id names with Not_found -> - user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) + user_err ~loc ~hdr:"Constraint" (str "Undeclared universe " ++ pr_id id) in let in_section = Lib.sections_are_opened () in let () = if poly && not in_section then - user_err_loc (Loc.ghost, "Constraint", - str"Cannot declare polymorphic constraints outside sections") + user_err ~hdr:"Constraint" + (str"Cannot declare polymorphic constraints outside sections") in let check_poly loc p loc' p' = if poly then () else if p || p' then let loc = if p then loc else loc' in - user_err_loc (loc, "Constraint", - str "Cannot declare a global constraint on " ++ + user_err ~loc ~hdr:"Constraint" + (str "Cannot declare a global constraint on " ++ str "a polymorphic universe, use " ++ str "Polymorphic Constraint instead") in diff --git a/library/declaremods.ml b/library/declaremods.ml index b2806a1ac..3a263b1e1 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -166,13 +166,13 @@ let consistency_checks exists dir dirinfo = let globref = try Nametab.locate_dir (qualid_of_dirpath dir) with Not_found -> - errorlabstrm "consistency_checks" + user_err ~hdr:"consistency_checks" (pr_dirpath dir ++ str " should already exist!") in assert (eq_global_dir_reference globref dirinfo) else if Nametab.exists_dir dir then - errorlabstrm "consistency_checks" + user_err ~hdr:"consistency_checks" (pr_dirpath dir ++ str " already exists") let compute_visibility exists i = diff --git a/library/goptions.ml b/library/goptions.ml index 1cf25987b..813bf30a3 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -36,7 +36,7 @@ type option_state = { let nickname table = String.concat " " table let error_undeclared_key key = - errorlabstrm "Goptions" (str (nickname key) ++ str ": no table or option of this type") + user_err ~hdr:"Goptions" (str (nickname key) ++ str ": no table or option of this type") (****************************************************************************) (* 1- Tables *) diff --git a/library/impargs.ml b/library/impargs.ml index 07b6b2bae..ea2805b67 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -340,14 +340,14 @@ let check_correct_manual_implicits autoimps l = List.iter (function | ExplByName id,(b,fi,forced) -> if not forced then - errorlabstrm "" + user_err (str "Wrong or non-dependent implicit argument name: " ++ pr_id id ++ str ".") | ExplByPos (i,_id),_t -> if i<1 || i>List.length autoimps then - errorlabstrm "" + user_err (str "Bad implicit argument number: " ++ int i ++ str ".") else - errorlabstrm "" + user_err (str "Cannot set implicit argument number " ++ int i ++ str ": it has no name.")) l @@ -661,7 +661,7 @@ let check_inclusion l = let check_rigidity isrigid = if not isrigid then - errorlabstrm "" (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") + user_err (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") let projection_implicits env p impls = let pb = Environ.lookup_projection p env in diff --git a/library/lib.ml b/library/lib.ml index a5a9a0194..749cc4ff3 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -78,7 +78,7 @@ let classify_segment seg = | (_,ClosedModule _) :: stk -> clean acc stk | (_,OpenedSection _) :: _ -> error "there are still opened sections" | (_,OpenedModule (ty,_,_,_)) :: _ -> - errorlabstrm "Lib.classify_segment" + user_err ~hdr:"Lib.classify_segment" (str "there are still opened " ++ str (module_kind ty) ++ str "s") | (_,FrozenState _) :: stk -> clean acc stk in @@ -270,7 +270,7 @@ let start_mod is_type export id mp fs = else Nametab.exists_module dir in if exists then - errorlabstrm "open_module" (pr_id id ++ str " already exists"); + user_err ~hdr:"open_module" (pr_id id ++ str " already exists"); add_entry (make_oname id) (OpenedModule (is_type,export,prefix,fs)); path_prefix := prefix; prefix @@ -280,7 +280,7 @@ let start_modtype = start_mod true None let error_still_opened string oname = let id = basename (fst oname) in - errorlabstrm "" + user_err (str "The " ++ str string ++ str " " ++ pr_id id ++ str " is still opened.") let end_mod is_type = @@ -325,7 +325,7 @@ let end_compilation_checks dir = try match snd (find_entry_p is_opening_node) with | OpenedSection _ -> error "There are some open sections." | OpenedModule (ty,_,_,_) -> - errorlabstrm "Lib.end_compilation_checks" + user_err ~hdr:"Lib.end_compilation_checks" (str "There are some open " ++ str (module_kind ty) ++ str "s.") | _ -> assert false with Not_found -> () @@ -377,7 +377,7 @@ let find_opening_node id = let oname,entry = find_entry_p is_opening_node in let id' = basename (fst oname) in if not (Names.Id.equal id id') then - errorlabstrm "Lib.find_opening_node" + user_err ~hdr:"Lib.find_opening_node" (str "Last block to end has name " ++ pr_id id' ++ str "."); entry with Not_found -> error "There is nothing to end." @@ -520,7 +520,7 @@ let open_section id = let dir = add_dirpath_suffix olddir id in let prefix = dir, (mp, add_dirpath_suffix oldsec id) in if Nametab.exists_section dir then - errorlabstrm "open_section" (pr_id id ++ str " already exists."); + user_err ~hdr:"open_section" (pr_id id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:`No in add_entry (make_oname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) diff --git a/library/library.ml b/library/library.ml index d44f796a7..3086e3d18 100644 --- a/library/library.ml +++ b/library/library.ml @@ -131,7 +131,7 @@ let find_library dir = let try_find_library dir = try find_library dir with Not_found -> - errorlabstrm "Library.find_library" + user_err ~hdr:"Library.find_library" (str "Unknown library " ++ pr_dirpath dir) let register_library_filename dir f = @@ -329,12 +329,12 @@ let locate_qualified_library ?root ?(warn = true) qid = let error_unmapped_dir qid = let prefix, _ = repr_qualid qid in - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ()) let error_lib_not_found qid = - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str"Cannot find library " ++ pr_qualid qid ++ str" in loadpath") let try_locate_absolute_library dir = @@ -378,7 +378,7 @@ let access_table what tables dp i = let t = try fetch_delayed f with Faulty f -> - errorlabstrm "Library.access_table" + user_err ~hdr:"Library.access_table" (str "The file " ++ str f ++ str " (bound to " ++ str dir_path ++ str ") is inaccessible or corrupted,\ncannot load some " ++ str what ++ str " in it.\n") @@ -463,7 +463,7 @@ let rec intern_library (needed, contents) (dir, f) from = let f = match f with Some f -> f | None -> try_locate_absolute_library dir in let m = intern_from_file f in if not (DirPath.equal dir m.library_name) then - errorlabstrm "load_physical_library" + user_err ~hdr:"load_physical_library" (str "The file " ++ str f ++ str " contains library" ++ spc () ++ pr_dirpath m.library_name ++ spc () ++ str "and not library" ++ spc() ++ pr_dirpath dir); @@ -477,7 +477,7 @@ and intern_library_deps libs dir m from = and intern_mandatory_library caller from libs (dir,d) = let digest, libs = intern_library libs (dir, None) (Some from) in if not (Safe_typing.digest_match ~actual:digest ~required:d) then - errorlabstrm "" (str "Compiled library " ++ pr_dirpath caller ++ + user_err (str "Compiled library " ++ pr_dirpath caller ++ str " (in file " ++ str from ++ str ") makes inconsistent assumptions \ over library " ++ pr_dirpath dir); libs @@ -582,8 +582,8 @@ let require_library_from_dirpath modrefl export = let safe_locate_module (loc,qid) = try Nametab.locate_module qid with Not_found -> - user_err_loc - (loc,"import_library", pr_qualid qid ++ str " is not a module") + user_err ~loc ~hdr:"import_library" + (pr_qualid qid ++ str " is not a module") let import_module export modl = (* Optimization: libraries in a raw in the list are imported @@ -607,8 +607,8 @@ let import_module export modl = flush acc; try Declaremods.import_module export mp; aux [] l with Not_found -> - user_err_loc (loc,"import_library", - pr_qualid dir ++ str " is not a module")) + user_err ~loc ~hdr:"import_library" + (pr_qualid dir ++ str " is not a module")) | [] -> flush acc in aux [] modl @@ -619,7 +619,7 @@ let check_coq_overwriting p id = let l = DirPath.repr p in let is_empty = match l with [] -> true | _ -> false in if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then - errorlabstrm "" + user_err (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ pr_id id ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") @@ -632,7 +632,7 @@ let check_module_name s = (if c = '\'' then str "\"'\"" else (str "'" ++ str (String.make 1 c) ++ str "'")) ++ strbrk " is not allowed in module names\n" in - let err c = errorlabstrm "" (msg c) in + let err c = user_err (msg c) in match String.get s 0 with | 'a' .. 'z' | 'A' .. 'Z' -> for i = 1 to (String.length s)-1 do @@ -668,10 +668,10 @@ let load_library_todo f = let tasks, _, _ = System.marshal_in_segment f ch in let (s5 : seg_proofs), _, _ = System.marshal_in_segment f ch in close_in ch; - if tasks = None then errorlabstrm "restart" (str"not a .vio file"); - if s2 = None then errorlabstrm "restart" (str"not a .vio file"); - if s3 = None then errorlabstrm "restart" (str"not a .vio file"); - if pi3 (Option.get s2) then errorlabstrm "restart" (str"not a .vio file"); + if tasks = None then user_err ~hdr:"restart" (str"not a .vio file"); + if s2 = None then user_err ~hdr:"restart" (str"not a .vio file"); + if s3 = None then user_err ~hdr:"restart" (str"not a .vio file"); + if pi3 (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); longf, s0, s1, Option.get s2, Option.get s3, Option.get tasks, s5 (************************************************************************) @@ -687,7 +687,7 @@ let current_deps () = let current_reexports () = !libraries_exports_list let error_recursively_dependent_library dir = - errorlabstrm "" + user_err (strbrk "Unable to use logical name " ++ pr_dirpath dir ++ strbrk " to save current library because" ++ strbrk " it already depends on a library of this name.") @@ -734,7 +734,7 @@ let save_library_to ?todo dir f otab = except Int.Set.empty in let is_done_or_todo i x = Future.is_val x || Int.Set.mem i except in Array.iteri (fun i x -> - if not(is_done_or_todo i x) then CErrors.errorlabstrm "library" + if not(is_done_or_todo i x) then CErrors.user_err ~hdr:"library" Pp.(str"Proof object "++int i++str" is not checked nor to be checked")) opaque_table; let sd = { diff --git a/library/nametab.ml b/library/nametab.ml index fa5db37ed..b76048e89 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -16,10 +16,8 @@ open Globnames exception GlobalizationError of qualid -let error_global_not_found_loc loc q = - Loc.raise loc (GlobalizationError q) - -let error_global_not_found q = raise (GlobalizationError q) +let error_global_not_found ?loc q = + Loc.raise ?loc (GlobalizationError q) (* Kinds of global names *) @@ -455,11 +453,11 @@ let global r = try match locate_extended qid with | TrueGlobal ref -> ref | SynDef _ -> - user_err_loc (loc,"global", - str "Unexpected reference to a notation: " ++ - pr_qualid qid) + user_err ~loc ~hdr:"global" + (str "Unexpected reference to a notation: " ++ + pr_qualid qid) with Not_found -> - error_global_not_found_loc loc qid + error_global_not_found ~loc qid (* Exists functions ********************************************************) @@ -534,8 +532,8 @@ let global_inductive r = match global r with | IndRef ind -> ind | ref -> - user_err_loc (loc_of_reference r,"global_inductive", - pr_reference r ++ spc () ++ str "is not an inductive type") + user_err ~loc:(loc_of_reference r) ~hdr:"global_inductive" + (pr_reference r ++ spc () ++ str "is not an inductive type") (********************************************************************) diff --git a/library/nametab.mli b/library/nametab.mli index a8a0572b3..d20c399b6 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -60,8 +60,7 @@ open Globnames exception GlobalizationError of qualid (** Raises a globalization error *) -val error_global_not_found_loc : Loc.t -> qualid -> 'a -val error_global_not_found : qualid -> 'a +val error_global_not_found : ?loc:Loc.t -> qualid -> 'a (** {6 Register visibility of things } *) diff --git a/library/universes.ml b/library/universes.ml index db95607f1..32eb35386 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -337,7 +337,7 @@ let existing_instance ctx inst = and a2 = Instance.to_array (UContext.instance ctx) in let len1 = Array.length a1 and len2 = Array.length a2 in if not (len1 == len2) then - CErrors.errorlabstrm "Universes" + CErrors.user_err ~hdr:"Universes" (str "Polymorphic constant expected " ++ int len2 ++ str" levels but was given " ++ int len1) else () diff --git a/ltac/g_ltac.ml4 b/ltac/g_ltac.ml4 index 9f2c0a93e..c67af33e2 100644 --- a/ltac/g_ltac.ml4 +++ b/ltac/g_ltac.ml4 @@ -36,8 +36,8 @@ let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c let reference_to_id = function | Libnames.Ident (loc, id) -> (loc, id) | Libnames.Qualid (loc,_) -> - CErrors.user_err_loc (loc, "", - str "This expression should be a simple identifier.") + CErrors.user_err ~loc + (str "This expression should be a simple identifier.") let tactic_mode = Gram.entry_create "vernac:tactic_command" diff --git a/ltac/rewrite.ml b/ltac/rewrite.ml index b559864bd..8e74249de 100644 --- a/ltac/rewrite.ml +++ b/ltac/rewrite.ml @@ -1502,7 +1502,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul Evar.Set.fold (fun ev acc -> if not (Evd.is_defined acc ev) then - errorlabstrm "rewrite" + user_err ~hdr:"rewrite" (str "Unsolved constraint remaining: " ++ spc () ++ Evd.pr_evar_info (Evd.find acc ev)) else Evd.remove acc ev) diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml index 673ac832a..2fed0e14f 100644 --- a/ltac/tacentries.ml +++ b/ltac/tacentries.ml @@ -429,8 +429,8 @@ let register_ltac local tacl = let kn = Lib.make_kn id in let id_pp = pr_id id in let () = if is_defined_tac kn then - CErrors.user_err_loc (loc, "", - str "There is already an Ltac named " ++ id_pp ++ str".") + CErrors.user_err ~loc + (str "There is already an Ltac named " ++ id_pp ++ str".") in let is_shadowed = try @@ -446,8 +446,8 @@ let register_ltac local tacl = let kn = try Nametab.locate_tactic (snd (qualid_of_reference ident)) with Not_found -> - CErrors.user_err_loc (loc, "", - str "There is no Ltac named " ++ pr_reference ident ++ str ".") + CErrors.user_err ~loc + (str "There is no Ltac named " ++ pr_reference ident ++ str ".") in UpdateTac kn, body in diff --git a/ltac/tacenv.ml b/ltac/tacenv.ml index c709ab114..e3c2b4ad5 100644 --- a/ltac/tacenv.ml +++ b/ltac/tacenv.ml @@ -65,7 +65,7 @@ let interp_ml_tactic { mltac_name = s; mltac_index = i } = let () = if Array.length tacs <= i then raise Not_found in tacs.(i) with Not_found -> - CErrors.errorlabstrm "" + CErrors.user_err (str "The tactic " ++ pr_tacname s ++ str " is not installed.") (***************************************************************************) diff --git a/ltac/tacintern.ml b/ltac/tacintern.ml index c5bb0ed07..cd791398d 100644 --- a/ltac/tacintern.ml +++ b/ltac/tacintern.ml @@ -32,11 +32,8 @@ open Locus let dloc = Loc.ghost -let error_global_not_found_loc (loc,qid) = - error_global_not_found_loc loc qid - -let error_tactic_expected loc = - user_err_loc (loc,"",str "Tactic expected.") +let error_tactic_expected ?loc = + user_err ?loc (str "Tactic expected.") (** Generic arguments *) @@ -85,7 +82,7 @@ let intern_hyp ist (loc,id as locid) = else if find_ident id ist then (dloc,id) else - Pretype_errors.error_var_not_found_loc loc id + Pretype_errors.error_var_not_found ~loc id let intern_or_var f ist = function | ArgVar locid -> ArgVar (intern_hyp ist locid) @@ -99,7 +96,7 @@ let intern_global_reference ist = function | r -> let loc,_ as lqid = qualid_of_reference r in try ArgArg (loc,locate_global_with_alias lqid) - with Not_found -> error_global_not_found_loc lqid + with Not_found -> error_global_not_found (snd lqid) let intern_ltac_variable ist = function | Ident (loc,id) -> @@ -143,7 +140,7 @@ let intern_isolated_tactic_reference strict ist r = try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) with Not_found -> (* Reference not found *) - error_global_not_found_loc (qualid_of_reference r) + error_global_not_found (snd (qualid_of_reference r)) (* Internalize an applied tactic reference *) @@ -159,7 +156,7 @@ let intern_applied_tactic_reference ist r = try intern_applied_global_tactic_reference r with Not_found -> (* Reference not found *) - error_global_not_found_loc (qualid_of_reference r) + error_global_not_found (snd (qualid_of_reference r)) (* Intern a reference parsed in a non-tactic entry *) @@ -180,7 +177,7 @@ let intern_non_tactic_reference strict ist r = TacGeneric ipat | _ -> (* Reference not found *) - error_global_not_found_loc (qualid_of_reference r) + error_global_not_found (snd (qualid_of_reference r)) let intern_message_token ist = function | (MsgString _ | MsgInt _ as x) -> x @@ -291,7 +288,7 @@ let intern_evaluable_global_reference ist r = with Not_found -> match r with | Ident (loc,id) when not !strict_check -> EvalVarRef id - | _ -> error_global_not_found_loc lqid + | _ -> error_global_not_found (snd lqid) let intern_evaluable_reference_or_by_notation ist = function | AN r -> intern_evaluable_global_reference ist r @@ -463,8 +460,8 @@ let rec intern_match_goal_hyps ist ?(as_type=false) lfun = function (* Utilities *) let extract_let_names lrc = let fold accu ((loc, name), _) = - if Id.Set.mem name accu then user_err_loc - (loc, "glob_tactic", str "This variable is bound several times.") + if Id.Set.mem name accu then user_err ~loc + ~hdr:"glob_tactic" (str "This variable is bound several times.") else Id.Set.add name accu in List.fold_left fold Id.Set.empty lrc @@ -641,7 +638,7 @@ and intern_tactic_as_arg loc onlytac ist a = | TacGeneric _ as a -> TacArg (loc,a) | Tacexp a -> a | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> - if onlytac then error_tactic_expected loc else TacArg (loc,a) + if onlytac then error_tactic_expected ~loc else TacArg (loc,a) and intern_tactic_or_tacarg ist = intern_tactic false ist @@ -751,7 +748,7 @@ let print_ltac id = ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined with Not_found -> - errorlabstrm "print_ltac" + user_err ~hdr:"print_ltac" (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") (** Registering *) diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml index ddebac5ab..177867abd 100644 --- a/ltac/tacinterp.ml +++ b/ltac/tacinterp.ml @@ -168,7 +168,7 @@ module Value = struct let pr_v = Pptactic.pr_value Pptactic.ltop v in let Val.Dyn (tag, _) = v in let tag = Val.pr tag in - errorlabstrm "" (str "Type error: value " ++ pr_v ++ str " is a " ++ tag + user_err (str "Type error: value " ++ pr_v ++ str " is a " ++ tag ++ str " while type " ++ Val.pr wit ++ str " was expected.") let unbox wit v ans = match ans with @@ -315,8 +315,8 @@ let append_trace trace v = (* Dynamically check that an argument is a tactic *) let coerce_to_tactic loc id v = let v = Value.normalize v in - let fail () = user_err_loc - (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") + let fail () = user_err ~loc + (str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") in let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then @@ -371,7 +371,7 @@ let debugging_exception_step ist signal_anomaly e pp = pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) let error_ltac_variable loc id env v s = - user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ + user_err ~loc (str "Ltac variable " ++ pr_id id ++ strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ strbrk "which cannot be coerced to " ++ str s ++ str".") @@ -404,8 +404,8 @@ let interp_intro_pattern_naming_var loc ist env sigma id = let interp_int ist locid = try try_interp_ltac_var coerce_to_int ist None locid with Not_found -> - user_err_loc(fst locid,"interp_int", - str "Unbound variable " ++ pr_id (snd locid) ++ str".") + user_err ~loc:(fst locid) ~hdr:"interp_int" + (str "Unbound variable " ++ pr_id (snd locid) ++ str".") let interp_int_or_var ist = function | ArgVar locid -> interp_int ist locid @@ -427,7 +427,7 @@ let interp_hyp ist env sigma (loc,id as locid) = with Not_found -> (* Then look if bound in the proof context at calling time *) if is_variable env id then id - else Loc.raise loc (Logic.RefinerError (Logic.NoSuchHyp id)) + else Loc.raise ~loc (Logic.RefinerError (Logic.NoSuchHyp id)) let interp_hyp_list_as_list ist env sigma (loc,id as x) = try coerce_to_hyp_list env (Id.Map.find id ist.lfun) @@ -449,7 +449,7 @@ let interp_reference ist env sigma = function with Not_found -> try VarRef (get_id (Environ.lookup_named id env)) - with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) + with Not_found -> error_global_not_found ~loc (qualid_of_ident id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in @@ -465,14 +465,14 @@ let interp_evaluable ist env sigma = function with Not_found -> match r with | EvalConstRef _ -> r - | _ -> error_global_not_found_loc loc (qualid_of_ident id) + | _ -> error_global_not_found ~loc (qualid_of_ident id) end | ArgArg (r,None) -> r | ArgVar (loc, id) -> try try_interp_ltac_var (coerce_to_evaluable_ref env) ist (Some (env,sigma)) (loc, id) with Not_found -> try try_interp_evaluable env (loc, id) - with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) + with Not_found -> error_global_not_found ~loc (qualid_of_ident id) (* Interprets an hypothesis name *) let interp_occurrences ist occs = @@ -739,7 +739,7 @@ let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = Inr (pattern_of_constr env sigma c) in (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) with Not_found -> - error_global_not_found_loc loc (qualid_of_ident id)) + error_global_not_found ~loc (qualid_of_ident id)) | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) | Inr c -> Inr (interp_typed_pattern ist env sigma c) in interp_occurrences ist occs, p @@ -795,8 +795,8 @@ let interp_may_eval f ist env sigma = function !evdref , c with | Not_found -> - user_err_loc (loc, "interp_may_eval", - str "Unbound context identifier" ++ pr_id s ++ str".")) + user_err ~loc ~hdr:"interp_may_eval" + (str "Unbound context identifier" ++ pr_id s ++ str".")) | ConstrTypeOf c -> let (sigma,c_interp) = f ist env sigma c in Typing.type_of ~refresh:true env sigma c_interp @@ -1032,8 +1032,8 @@ let interp_destruction_arg ist gl arg = } | keep,ElimOnAnonHyp n as x -> x | keep,ElimOnIdent (loc,id) -> - let error () = user_err_loc (loc, "", - strbrk "Cannot coerce " ++ pr_id id ++ + let error () = user_err ~loc + (strbrk "Cannot coerce " ++ pr_id id ++ strbrk " neither to a quantified hypothesis nor to a term.") in let try_cast_id id' = @@ -1043,7 +1043,7 @@ let interp_destruction_arg ist gl arg = (keep, ElimOnConstr { delayed = begin fun env sigma -> try Sigma.here (constr_of_id env id', NoBindings) sigma with Not_found -> - user_err_loc (loc, "interp_destruction_arg", + user_err ~loc ~hdr:"interp_destruction_arg" ( pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.") end }) in @@ -1111,7 +1111,7 @@ let read_pattern lfun ist env sigma = function (* Reads the hypotheses of a Match Context rule *) let cons_and_check_name id l = if Id.List.mem id l then - user_err_loc (dloc,"read_match_goal_hyps", + user_err ~hdr:"read_match_goal_hyps" ( str "Hypothesis pattern-matching variable " ++ pr_id id ++ str " used twice in the same pattern.") else id::l @@ -1867,7 +1867,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let (sigma, c) = interp_constr ist env sigma c in Sigma.Unsafe.of_pair (c, sigma) with e when to_catch e (* Hack *) -> - errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") + user_err (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") end } in Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) end } diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index bec891f7f..f19759470 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -109,7 +109,7 @@ let get_current_file () = let set_current_file ~fname = current_file := fname -let err loc str = Loc.raise (Compat.to_coqloc loc) (Error.E str) +let err loc str = Loc.raise ~loc:(Compat.to_coqloc loc) (Error.E str) let bad_token str = raise (Error.E (Bad_token str)) diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index 18bc8d664..170dd7c55 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -188,7 +188,7 @@ module GrammarMake (L:LexerSig) : GrammarSig = struct with Exc_located (loc,e) -> let loc' = Loc.get_loc (Exninfo.info e) in let loc = match loc' with None -> to_coqloc loc | Some loc -> loc in - Loc.raise loc e + Loc.raise ~loc e let entry_print ft x = Entry.print ft x let srules' = Gramext.srules diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 65d49cb45..0dbe08231 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -71,7 +71,7 @@ let error_level_assoc p current expected = | Extend.LeftA -> str "left" | Extend.RightA -> str "right" | Extend.NonA -> str "non" in - errorlabstrm "" + user_err (str "Level " ++ int p ++ str " is already declared " ++ pr_assoc current ++ str " associative while it is now expected to be " ++ pr_assoc expected ++ str " associative.") diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 74994c5e3..7021e5270 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -55,9 +55,9 @@ let mk_fixb (id,bl,ann,body,(loc,tyc)) = let mk_cofixb (id,bl,ann,body,(loc,tyc)) = let _ = Option.map (fun (aloc,_) -> - CErrors.user_err_loc - (aloc,"Constr:mk_cofixb", - Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in + CErrors.user_err ~loc:aloc + ~hdr:"Constr:mk_cofixb" + (Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in let ty = match tyc with Some ty -> ty | None -> CHole (loc, None, IntroAnonymous, None) in @@ -380,14 +380,14 @@ GEXTEND Gram [ p = pattern; lp = LIST1 NEXT -> (match p with | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, None, lp) - | CPatCstr (_, r, None, l2) -> CErrors.user_err_loc - (cases_pattern_expr_loc p, "compound_pattern", - Pp.str "Nested applications not supported.") + | CPatCstr (_, r, None, l2) -> CErrors.user_err + ~loc:(cases_pattern_expr_loc p) ~hdr:"compound_pattern" + (Pp.str "Nested applications not supported.") | CPatCstr (_, r, l1, l2) -> CPatCstr (!@loc, r, l1 , l2@lp) | CPatNotation (_, n, s, l) -> CPatNotation (!@loc, n , s, l@lp) - | _ -> CErrors.user_err_loc - (cases_pattern_expr_loc p, "compound_pattern", - Pp.str "Such pattern cannot have arguments.")) + | _ -> CErrors.user_err + ~loc:(cases_pattern_expr_loc p) ~hdr:"compound_pattern" + (Pp.str "Such pattern cannot have arguments.")) |"@"; r = Prim.reference; lp = LIST0 NEXT -> CPatCstr (!@loc, r, Some lp, []) ] | "1" LEFTA diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index b90e06cd3..820514b08 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -28,7 +28,7 @@ let my_int_of_string loc s = if n > 1024 * 2048 then raise Exit; n with Failure _ | Exit -> - CErrors.user_err_loc (loc,"",Pp.str "Cannot support a so large number.") + CErrors.user_err ~loc (Pp.str "Cannot support a so large number.") GEXTEND Gram GLOBAL: @@ -93,7 +93,7 @@ GEXTEND Gram ; ne_string: [ [ s = STRING -> - if s="" then CErrors.user_err_loc(!@loc, "", Pp.str"Empty string."); s + if s="" then CErrors.user_err ~loc:(!@loc) (Pp.str"Empty string."); s ] ] ; ne_lstring: diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 199ef9fce..3c2c45c72 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -135,9 +135,9 @@ let mk_fix_tac (loc,id,bl,ann,ty) = let mk_cofix_tac (loc,id,bl,ann,ty) = let _ = Option.map (fun (aloc,_) -> - user_err_loc - (aloc,"Constr:mk_cofix_tac", - Pp.str"Annotation forbidden in cofix expression.")) ann in + user_err ~loc:aloc + ~hdr:"Constr:mk_cofix_tac" + (Pp.str"Annotation forbidden in cofix expression.")) ann in (id,CProdN(loc,bl,ty)) (* Functions overloaded by quotifier *) @@ -192,7 +192,7 @@ let merge_occurrences loc cl = function | None -> if Locusops.clause_with_generic_occurrences cl then (None, cl) else - user_err_loc (loc,"",str "Found an \"at\" clause without \"with\" clause.") + user_err ~loc (str "Found an \"at\" clause without \"with\" clause.") | Some (occs, p) -> let ans = match occs with | AllOccurrences -> cl @@ -204,9 +204,9 @@ let merge_occurrences loc cl = function { cl with onhyps = Some [(occs, id), l] } | _ -> if Locusops.clause_with_generic_occurrences cl then - user_err_loc (loc,"",str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") + user_err ~loc (str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") else - user_err_loc (loc,"",str "Cannot use clause \"at\" twice.") + user_err ~loc (str "Cannot use clause \"at\" twice.") end in (Some p, ans) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index c09693b36..7cb897cf7 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -115,7 +115,7 @@ GEXTEND Gram | Some (SelectNth g) -> c (Some g) | None -> c None | _ -> - VernacError (UserError ("",str"Typing and evaluation commands, cannot be used with the \"all:\" selector.")) + VernacError (UserError (None,str"Typing and evaluation commands, cannot be used with the \"all:\" selector.")) end ] ] ; located_vernac: diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 930ab333a..aedecc15c 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -458,7 +458,7 @@ let cc_tactic depth additionnal_terms = end } let cc_fail gls = - errorlabstrm "Congruence" (Pp.str "congruence failed.") + user_err ~hdr:"Congruence" (Pp.str "congruence failed.") let congruence_tac depth l = Tacticals.New.tclORELSE diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index a862423e9..f68c01b18 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -90,8 +90,8 @@ let rec add_vars_of_simple_pattern globs = function (* Loc.raise loc (UserError ("simple_pattern",str "\"as\" is not allowed here"))*) | CPatOr (loc, _)-> - Loc.raise loc - (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) + Loc.raise ~loc + (UserError (Some "simple_pattern",str "\"(_ | _)\" is not allowed here")) | CPatDelimiters (_,_,p) -> add_vars_of_simple_pattern globs p | CPatCstr (_,_,pl1,pl2) -> @@ -328,7 +328,7 @@ let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = let _ = let expected = mib.Declarations.mind_nparams - num_params in if not (Int.equal (List.length params) expected) then - errorlabstrm "suppose it is" + user_err ~hdr:"suppose it is" (str "Wrong number of extra arguments: " ++ (if Int.equal expected 0 then str "none" else int expected) ++ spc () ++ str "expected.") in @@ -348,7 +348,7 @@ let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = Thesis (Plain) -> Glob_term.GSort(Loc.ghost,GProp) | Thesis (For rec_occ) -> if not (Id.List.mem rec_occ pat_vars) then - errorlabstrm "suppose it is" + user_err ~hdr:"suppose it is" (str "Variable " ++ Nameops.pr_id rec_occ ++ str " does not occur in pattern."); Glob_term.GSort(Loc.ghost,GProp) diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 0fbe04b86..e19dc86c4 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -46,7 +46,7 @@ let clear ids { it = goal; sigma } = let (hyps, concl) = try Evarutil.clear_hyps_in_evi env evdref sign cl ids with Evarutil.ClearDependencyError (id, _) -> - errorlabstrm "" (str "Cannot clear " ++ pr_id id) + user_err (str "Cannot clear " ++ pr_id id) in let sigma = !evdref in let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in @@ -1083,12 +1083,12 @@ let thesis_for obj typ per_info env= let cind,all_args=decompose_app typ in let ind,u = destInd cind in let _ = if not (eq_ind ind per_info.per_ind) then - errorlabstrm "thesis_for" + user_err ~hdr:"thesis_for" ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str"cannot give an induction hypothesis (wrong inductive type).") in let params,args = List.chop per_info.per_nparams all_args in let _ = if not (List.for_all2 eq_constr params per_info.per_params) then - errorlabstrm "thesis_for" + user_err ~hdr:"thesis_for" ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str "cannot give an induction hypothesis (wrong parameters).") in let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index ff66d915f..5e7d810c9 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -293,7 +293,7 @@ let pr_long_global ref = pr_path (Nametab.path_of_global ref) (*S Warning and Error messages. *) -let err s = errorlabstrm "Extraction" s +let err s = user_err ~hdr:"Extraction" s let warn_extraction_axiom_to_realize = CWarnings.create ~name:"extraction-axiom-to-realize" ~category:"extraction" diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 234c3e75e..cc699e5d3 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -611,7 +611,7 @@ let build_scheme fas = try Smartlocate.global_with_alias f with Not_found -> - errorlabstrm "FunInd.build_scheme" + user_err ~hdr:"FunInd.build_scheme" (str "Cannot find " ++ Libnames.pr_reference f) in let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in @@ -645,7 +645,7 @@ let build_case_scheme fa = let (_,f,_) = fa in try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f)) with Not_found -> - errorlabstrm "FunInd.build_case_scheme" + user_err ~hdr:"FunInd.build_case_scheme" (str "Cannot find " ++ Libnames.pr_reference f) in let first_fun,u = destConst funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 4d02c77c8..de2e5ea4e 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -631,7 +631,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ + user_err (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in @@ -663,7 +663,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ + user_err (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in @@ -1198,7 +1198,7 @@ let rec compute_cst_params relnames params = function | GSort _ -> params | GHole _ -> params | GIf _ | GRec _ | GCast _ -> - raise (UserError("compute_cst_params", str "Not handled case")) + raise (UserError(Some "compute_cst_params", str "Not handled case")) and compute_cst_params_from_app acc (params,rtl) = match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 01e5ef7fb..4e561fc7e 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -406,7 +406,7 @@ let is_free_in id = | GIf(_,cond,_,br1,br2) -> is_free_in cond || is_free_in br1 || is_free_in br2 - | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GRec _ -> raise (UserError(None,str "Not handled GRec")) | GSort _ -> false | GHole _ -> false | GCast (_,b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t @@ -502,7 +502,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern lhs, replace_var_by_pattern rhs ) - | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GRec _ -> raise (UserError(None,str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> @@ -655,7 +655,7 @@ let zeta_normalize = zeta_normalize_term lhs, zeta_normalize_term rhs ) - | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GRec _ -> raise (UserError(None,str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 51cf7f4f4..99b04898b 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -43,7 +43,7 @@ let functional_induction with_clean c princl pat = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' with Not_found -> - errorlabstrm "" (str "Cannot find induction information on "++ + user_err (str "Cannot find induction information on "++ Printer.pr_lconstr (mkConst c') ) in match Tacticals.elimination_sort_of_goal g with @@ -71,11 +71,11 @@ let functional_induction with_clean c princl pat = (b,a) (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) with Not_found -> (* This one is neither defined ! *) - errorlabstrm "" (str "Cannot find induction principle for " + user_err (str "Cannot find induction principle for " ++Printer.pr_lconstr (mkConst c') ) in (princ,NoBindings, Tacmach.pf_unsafe_type_of g' princ,g') - | _ -> raise (UserError("",str "functional induction must be used with a function" )) + | _ -> raise (UserError(None,str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> princ,binding,Tacmach.pf_unsafe_type_of g princ,g @@ -176,7 +176,7 @@ let build_newrecursive l = match body_opt with | Some body -> (fixna,bll,ar,body) - | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") + | None -> user_err ~hdr:"Function" (str "Body of Function must be given") ) l in build_newrecursive l' @@ -322,7 +322,7 @@ let error_error names e = in match e with | Building_graph e -> - errorlabstrm "" + user_err (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) @@ -392,7 +392,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [(((_,fname),pl),_,bl,ret_type,body),_] when not is_rec -> - let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in Command.do_definition fname (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) pl @@ -631,7 +631,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let pre_hook pconstants = @@ -657,7 +657,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let fixpoint_exprl = [fixpoint_expr] in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in - let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) @@ -835,9 +835,9 @@ let make_graph (f_ref:global_reference) = | ConstRef c -> begin try c,Global.lookup_constant c with Not_found -> - raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) + raise (UserError (None,str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) end - | _ -> raise (UserError ("", str "Not a function reference") ) + | _ -> raise (UserError (None, str "Not a function reference") ) in (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom !" diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index f56e92414..a45effb16 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -49,7 +49,7 @@ let locate_constant ref = let locate_with_msg msg f x = try f x - with Not_found -> raise (CErrors.UserError("", msg)) + with Not_found -> raise (CErrors.UserError(None, msg)) let filter_map filter f = @@ -73,7 +73,7 @@ let chop_rlambda_n = | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b | _ -> - raise (CErrors.UserError("chop_rlambda_n", + raise (CErrors.UserError(Some "chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) in chop_lambda_n [] @@ -85,7 +85,7 @@ let chop_rprod_n = else match rt with | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> raise (CErrors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) + | _ -> raise (CErrors.UserError(Some "chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] @@ -110,7 +110,7 @@ let const_of_id id = in try Constrintern.locate_reference princ_ref with Not_found -> - CErrors.errorlabstrm "IndFun.const_of_id" + CErrors.user_err ~hdr:"IndFun.const_of_id" (str "cannot find " ++ Nameops.pr_id id) let def_of_const t = diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 0178c44d0..c8b4e4833 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -1000,7 +1000,7 @@ let invfun qhyp f = let f = match f with | ConstRef f -> f - | _ -> raise (CErrors.UserError("",str "Not a function")) + | _ -> raise (CErrors.UserError(None,str "Not a function")) in try let finfos = find_Function_infos f in @@ -1045,19 +1045,19 @@ let invfun qhyp f g = functional_inversion kn hid f2 f_correct g with | Failure "" -> - errorlabstrm "" (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") + user_err (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") | Option.IsNone -> if do_observe () then error "Cannot use equivalence with graph for any side of the equality" - else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) | Not_found -> if do_observe () then error "No graph found for any side of equality" - else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) end - | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") + | _ -> user_err (Ppconstr.pr_id hid ++ str " must be an equality ") end) qhyp end diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 14550a9fc..7cbe787c3 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -903,7 +903,7 @@ let find_Function_infos_safe (id:Id.t): Indfun_common.function_info = locate_constant f_ref in try find_Function_infos (kn_of_id id) with Not_found -> - errorlabstrm "indfun" (Nameops.pr_id id ++ str " has no functional scheme") + user_err ~hdr:"indfun" (Nameops.pr_id id ++ str " has no functional scheme") (** [merge id1 id2 args1 args2 id] builds and declares a new inductive type called [id], representing the merged graphs of both graphs diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 65f96c831..f43251bc5 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -307,7 +307,7 @@ let check_not_nested forbidden e = | Rel _ -> () | Var x -> if Id.List.mem x forbidden - then errorlabstrm "Recdef.check_not_nested" + then user_err ~hdr:"Recdef.check_not_nested" (str "check_not_nested: failure " ++ pr_id x) | Meta _ | Evar _ | Sort _ -> () | Cast(e,_,t) -> check_not_nested e;check_not_nested t @@ -327,7 +327,7 @@ let check_not_nested forbidden e = try check_not_nested e with UserError(_,p) -> - errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) + user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = @@ -442,7 +442,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info with e when CErrors.noncritical e -> - errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Lambda(n,t,b) -> begin @@ -450,7 +450,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info with e when CErrors.noncritical e -> - errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Case(ci,t,a,l) -> begin @@ -478,7 +478,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = jinfo.apP (f,args) expr_info continuation_tac in travel_args jinfo expr_info.is_main_branch new_continuation_tac new_infos - | Case _ -> errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") + | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_lconstr expr_info.info) end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} @@ -723,8 +723,8 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) )) with - | UserError("Refiner.thensn_tac3",_) - | UserError("Refiner.tclFAIL_s",_) -> + | UserError(Some "Refiner.thensn_tac3",_) + | UserError(Some "Refiner.tclFAIL_s",_) -> (observe_tac (str "is computable " ++ Printer.pr_lconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) )) g diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 4ed907951..367a13333 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -263,7 +263,7 @@ let rtauto_tac gls= let _= if Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) gl != InProp - then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in + then user_err ~hdr:"rtauto" (Pp.str "goal should be in Prop") in let glf=make_form gamma gls gl in let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in let formula= @@ -282,7 +282,7 @@ let rtauto_tac gls= let prf = try project (search_fun (init_state [] formula)) with Not_found -> - errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in + user_err ~hdr:"rtauto" (Pp.str "rtauto couldn't find any proof") in let search_end_time = System.get_time () in let _ = if !verbose then begin diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 90f5f8e63..a5e2211d8 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -79,7 +79,7 @@ let add_map s m = protect_maps := String.Map.add s m !protect_maps let lookup_map map = try String.Map.find map !protect_maps with Not_found -> - errorlabstrm"lookup_map"(str"map "++qs map++str"not found") + user_err ~hdr:"lookup_map" (str"map "++qs map++str"not found") let protect_red map env sigma c = kl (create_clos_infos all env) @@ -348,13 +348,13 @@ let find_ring_structure env sigma l = let check c = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then - errorlabstrm "ring" + user_err ~hdr:"ring" (str"arguments of ring_simplify do not have all the same type") in List.iter check cl'; (try ring_for_carrier ty with Not_found -> - errorlabstrm "ring" + user_err ~hdr:"ring" (str"cannot find a declared ring structure over"++ spc()++str"\""++pr_constr ty++str"\"")) | [] -> assert false @@ -828,13 +828,13 @@ let find_field_structure env sigma l = let check c = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then - errorlabstrm "field" + user_err ~hdr:"field" (str"arguments of field_simplify do not have all the same type") in List.iter check cl'; (try field_for_carrier ty with Not_found -> - errorlabstrm "field" + user_err ~hdr:"field" (str"cannot find a declared field structure over"++ spc()++str"\""++pr_constr ty++str"\"")) | [] -> assert false diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index ff1db8cf5..5fb0bb664 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -61,8 +61,8 @@ DECLARE PLUGIN "ssrmatching_plugin" type loc = Loc.t let dummy_loc = Loc.ghost -let errorstrm = CErrors.errorlabstrm "ssrmatching" -let loc_error loc msg = CErrors.user_err_loc (loc, msg, str msg) +let errorstrm = CErrors.user_err ~hdr:"ssrmatching" +let loc_error loc msg = CErrors.user_err ~loc ~hdr:msg (str msg) let ppnl = Feedback.msg_info (* 0 cost pp function. Active only if env variable SSRDEBUG is set *) diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index e18d19ced..ed8cc6ab0 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -52,8 +52,8 @@ let interp_ascii_string dloc s = if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2] then int_of_string s else - user_err_loc (dloc,"interp_ascii_string", - str "Expects a single character or a three-digits ascii code.") in + user_err ~loc:dloc ~hdr:"interp_ascii_string" + (str "Expects a single character or a three-digits ascii code.") in interp_ascii dloc p let uninterp_ascii r = diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index a9eb126b4..ab262fea7 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -47,8 +47,8 @@ let nat_of_int dloc n = mk_nat ref_O n end else - user_err_loc (dloc, "nat_of_int", - str "Cannot interpret a negative number as a number of type nat") + user_err ~hdr:"nat_of_int" + (str "Cannot interpret a negative number as a number of type nat") (************************************************************************) (* Printing via scopes *) diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index f65f9b791..a25ddb062 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -100,7 +100,7 @@ let int31_of_pos_bigint dloc n = GApp (dloc, ref_construct, List.rev (args 31 n)) let error_negative dloc = - CErrors.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.") + CErrors.user_err ~loc:dloc ~hdr:"interp_int31" (Pp.str "int31 are only non-negative numbers.") let interp_int31 dloc n = if is_pos_or_zero n then @@ -189,7 +189,7 @@ let bigN_of_pos_bigint dloc n = GApp (dloc, ref_constructor, args) let bigN_error_negative dloc = - CErrors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.") + CErrors.user_err ~loc:dloc ~hdr:"interp_bigN" (Pp.str "bigN are only non-negative numbers.") let interp_bigN dloc n = if is_pos_or_zero n then diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index 60803a369..b7b5fb8a5 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -57,8 +57,8 @@ let pos_of_bignat dloc x = pos_of x let error_non_positive dloc = - user_err_loc (dloc, "interp_positive", - str "Only strictly positive numbers in type \"positive\".") + user_err ~loc:dloc ~hdr:"interp_positive" + (str "Only strictly positive numbers in type \"positive\".") let interp_positive dloc n = if is_strictly_pos n then pos_of_bignat dloc n @@ -113,7 +113,7 @@ let n_of_binnat dloc pos_or_neg n = GRef (dloc, glob_N0, None) let error_negative dloc = - user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".") + user_err ~loc:dloc ~hdr:"interp_N" (str "No negative numbers in type \"N\".") let n_of_int dloc n = if is_pos_or_zero n then n_of_binnat dloc true n diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 2d8173f94..4cda689e9 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -48,22 +48,22 @@ type pattern_matching_error = exception PatternMatchingError of env * evar_map * pattern_matching_error -let raise_pattern_matching_error (loc,env,sigma,te) = - Loc.raise loc (PatternMatchingError(env,sigma,te)) +let raise_pattern_matching_error ?loc (env,sigma,te) = + Loc.raise ?loc (PatternMatchingError(env,sigma,te)) -let error_bad_pattern_loc loc env sigma cstr ind = - raise_pattern_matching_error - (loc, env, sigma, BadPattern (cstr,ind)) +let error_bad_pattern ?loc env sigma cstr ind = + raise_pattern_matching_error ?loc + (env, sigma, BadPattern (cstr,ind)) -let error_bad_constructor_loc loc env cstr ind = +let error_bad_constructor ?loc env cstr ind = raise_pattern_matching_error - (loc, env, Evd.empty, BadConstructor (cstr,ind)) + (env, Evd.empty, BadConstructor (cstr,ind)) -let error_wrong_numarg_constructor_loc loc env c n = - raise_pattern_matching_error (loc, env, Evd.empty, WrongNumargConstructor(c,n)) +let error_wrong_numarg_constructor ?loc env c n = + raise_pattern_matching_error (env, Evd.empty, WrongNumargConstructor(c,n)) -let error_wrong_numarg_inductive_loc loc env c n = - raise_pattern_matching_error (loc, env, Evd.empty, WrongNumargInductive(c,n)) +let error_wrong_numarg_inductive ?loc env c n = + raise_pattern_matching_error (env, Evd.empty, WrongNumargInductive(c,n)) let rec list_try_compile f = function | [a] -> f a @@ -482,32 +482,31 @@ let check_and_adjust_constructor env ind cstrs = function let args' = adjust_local_defs loc (args, List.rev ci.cs_args) in PatCstr (loc, cstr, args', alias) with NotAdjustable -> - error_wrong_numarg_constructor_loc loc env cstr nb_args_constr + error_wrong_numarg_constructor ~loc env cstr nb_args_constr else (* Try to insert a coercion *) try Coercion.inh_pattern_coerce_to loc env pat ind' ind with Not_found -> - error_bad_constructor_loc loc env cstr ind + error_bad_constructor ~loc env cstr ind let check_all_variables env sigma typ mat = List.iter (fun eqn -> match current_pattern eqn with | PatVar (_,id) -> () | PatCstr (loc,cstr_sp,_,_) -> - error_bad_pattern_loc loc env sigma cstr_sp typ) + error_bad_pattern ~loc env sigma cstr_sp typ) mat let check_unused_pattern env eqn = if not !(eqn.used) then - raise_pattern_matching_error - (eqn.eqn_loc, env, Evd.empty, UnusedClause eqn.patterns) + raise_pattern_matching_error ~loc:eqn.eqn_loc (env, Evd.empty, UnusedClause eqn.patterns) let set_used_pattern eqn = eqn.used := true let extract_rhs pb = match pb.mat with - | [] -> errorlabstrm "build_leaf" (msg_may_need_inversion()) + | [] -> user_err ~hdr:"build_leaf" (msg_may_need_inversion()) | eqn::_ -> set_used_pattern eqn; eqn.rhs @@ -1308,8 +1307,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let submat = adjust_impossible_cases pb pred tomatch submat in let () = match submat with | [] -> - raise_pattern_matching_error - (Loc.ghost, pb.env, Evd.empty, NonExhaustive (complete_history history)) + raise_pattern_matching_error (pb.env, Evd.empty, NonExhaustive (complete_history history)) | _ -> () in @@ -1836,8 +1834,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = | None -> [LocalAssum (na, lift n typ)] | Some b -> [LocalDef (na, lift n b, lift n typ)]) | Some (loc,_,_) -> - user_err_loc (loc,"", - str"Unexpected type annotation for a term of non inductive type.")) + user_err ~loc + (str"Unexpected type annotation for a term of non inductive type.")) | IsInd (term,IndType(indf,realargs),_) -> let indf' = if dolift then lift_inductive_family n indf else indf in let ((ind,u),_) = dest_ind_family indf' in @@ -1847,7 +1845,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = match t with | Some (loc,ind',realnal) -> if not (eq_ind ind ind') then - user_err_loc (loc,"",str "Wrong inductive type."); + user_err ~loc (str "Wrong inductive type."); if not (Int.equal nrealargs_ctxt (List.length realnal)) then anomaly (Pp.str "Ill-formed 'in' clause in cases"); List.rev realnal @@ -2038,11 +2036,11 @@ let constr_of_pat env evdref arsign pat avoid = let cind = inductive_of_constructor cstr in let IndType (indf, _) = try find_rectype env ( !evdref) (lift (-(List.length realargs)) ty) - with Not_found -> error_case_not_inductive env + with Not_found -> error_case_not_inductive env !evdref {uj_val = ty; uj_type = Typing.unsafe_type_of env !evdref ty} in let (ind,u), params = dest_ind_family indf in - if not (eq_ind ind cind) then error_bad_constructor_loc l env cstr ind; + if not (eq_ind ind cind) then error_bad_constructor ~loc:l env cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in diff --git a/pretyping/cases.mli b/pretyping/cases.mli index ba566f374..6bc61f6dd 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -28,9 +28,9 @@ type pattern_matching_error = exception PatternMatchingError of env * evar_map * pattern_matching_error -val error_wrong_numarg_constructor_loc : Loc.t -> env -> constructor -> int -> 'a +val error_wrong_numarg_constructor : ?loc:Loc.t -> env -> constructor -> int -> 'a -val error_wrong_numarg_inductive_loc : Loc.t -> env -> inductive -> int -> 'a +val error_wrong_numarg_inductive : ?loc:Loc.t -> env -> inductive -> int -> 'a val irrefutable : env -> cases_pattern -> bool diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 4f265e76c..30d100af9 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -538,7 +538,7 @@ let inheritance_graph () = let coercion_of_reference r = let ref = Nametab.global r in if not (coercion_exists ref) then - errorlabstrm "try_add_coercion" + user_err ~hdr:"try_add_coercion" (Nametab.pr_global_env Id.Set.empty ref ++ str" is not a coercion."); ref diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 553786f58..2b860ae9c 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -411,7 +411,7 @@ let inh_tosort_force loc env evd j = let j2 = on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env j2) with Not_found | NoCoercion -> - error_not_a_type_loc loc env evd j + error_not_a_type ~loc env evd j let inh_coerce_to_sort loc env evd j = let typ = whd_all env evd j.uj_type in @@ -505,16 +505,16 @@ let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t = else raise NoSubtacCoercion with | NoSubtacCoercion when not resolve_tc || not !use_typeclasses_for_conversion -> - error_actual_type_loc loc env best_failed_evd cj t e + error_actual_type ~loc env best_failed_evd cj t e | NoSubtacCoercion -> let evd' = saturate_evd env evd in try if evd' == evd then - error_actual_type_loc loc env best_failed_evd cj t e + error_actual_type ~loc env best_failed_evd cj t e else inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (_evd,_error) -> - error_actual_type_loc loc env best_failed_evd cj t e + error_actual_type ~loc env best_failed_evd cj t e in let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 85125a502..cad5551c1 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -67,15 +67,15 @@ let isomorphic_to_tuple lc = Int.equal (Array.length lc) 1 let encode_bool r = let (x,lc) = encode_inductive r in if not (has_two_constructors lc) then - user_err_loc (loc_of_reference r,"encode_if", - str "This type has not exactly two constructors."); + user_err ~loc:(loc_of_reference r) ~hdr:"encode_if" + (str "This type has not exactly two constructors."); x let encode_tuple r = let (x,lc) = encode_inductive r in if not (isomorphic_to_tuple lc) then - user_err_loc (loc_of_reference r,"encode_tuple", - str "This type cannot be seen as a tuple type."); + user_err ~loc:(loc_of_reference r) ~hdr:"encode_tuple" + (str "This type cannot be seen as a tuple type."); x module PrintingInductiveMake = diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 31fb1174a..cd7ce89e0 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1253,7 +1253,7 @@ let consider_remaining_unif_problems env aux evd pbs progress (pb :: stuck) end | UnifFailure (evd,reason) -> - Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb) + Pretype_errors.error_cannot_unify ~loc:(loc_of_conv_pb evd pb) env evd ~reason (t1, t2)) | _ -> if progress then aux evd stuck false [] @@ -1262,7 +1262,7 @@ let consider_remaining_unif_problems env | [] -> (* We're finished *) evd | (pbty,env,t1,t2 as pb) :: _ -> (* There remains stuck problems *) - Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb) + Pretype_errors.error_cannot_unify ~loc:(loc_of_conv_pb evd pb) env evd (t1, t2) in let (evd,pbs) = extract_all_conv_pbs evd in diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 29eb00c61..06f619410 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -135,7 +135,7 @@ let define_pure_evar_as_lambda env evd evk = let evd1,(na,dom,rng) = match kind_of_term typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ - | _ -> error_not_product_loc Loc.ghost env evd typ in + | _ -> error_not_product env evd typ in let avoid = ids_of_named_context (evar_context evi) in let id = next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in @@ -191,7 +191,7 @@ let split_tycon loc env evd tycon = | App (c,args) when isEvar c -> let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in real_split evd' (mkApp (lam,args)) - | _ -> error_not_product_loc loc env evd c + | _ -> error_not_product ~loc env evd c in match tycon with | None -> evd,(Anonymous,None,None) diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 1f9573862..4b9cf415f 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -37,7 +37,7 @@ let explain_occurrence_error = function | IncorrectInValueOccurrence id -> explain_incorrect_in_value_occurrence id let error_occurrences_error e = - errorlabstrm "" (explain_occurrence_error e) + user_err (explain_occurrence_error e) let error_invalid_occurrence occ = error_occurrences_error (InvalidOccurrence occ) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 39aeb41f7..9cf91a947 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -55,7 +55,7 @@ let is_private mib = let check_privacy_block mib = if is_private mib then - errorlabstrm ""(str"case analysis on a private inductive type") + user_err (str"case analysis on a private inductive type") (**********************************************************************) (* Building case analysis schemes *) @@ -594,7 +594,7 @@ let lookup_eliminator ind_sp s = (* using short name (e.g. for "eq_rec") *) try Nametab.locate (qualid_of_ident id) with Not_found -> - errorlabstrm "default_elim" + user_err ~hdr:"default_elim" (strbrk "Cannot find the elimination combinator " ++ pr_id id ++ strbrk ", the elimination of the inductive definition " ++ pr_global_env Id.Set.empty (IndRef ind_sp) ++ diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 214e19fec..29f57144a 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -355,7 +355,7 @@ let make_case_or_project env indf ci pred c branches = let mib, _ = Inductive.lookup_mind_specif env ind in if (* dependent *) not (noccurn 1 t) && not (has_dependent_elim mib) then - errorlabstrm "make_case_or_project" + user_err ~hdr:"make_case_or_project" Pp.(str"Dependent case analysis not allowed" ++ str" on inductive type " ++ Names.MutInd.print (fst ind)) in diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index fe73b6105..9dcb5d2a5 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -204,7 +204,7 @@ let error_instantiate_pattern id l = | [_] -> "is" | _ -> "are" in - errorlabstrm "" (str "Cannot substitute the term bound to " ++ pr_id id + user_err (str "Cannot substitute the term bound to " ++ pr_id id ++ strbrk " in pattern because the term refers to " ++ pr_enum pr_id l ++ strbrk " which " ++ str is ++ strbrk " not bound in the pattern.") @@ -315,7 +315,7 @@ let rec subst_pattern subst pat = let mkPLambda na b = PLambda(na,PMeta None,b) let rev_it_mkPLambda = List.fold_right mkPLambda -let err loc pp = user_err_loc (loc,"pattern_of_glob_constr", pp) +let err ?loc pp = user_err ?loc ~hdr:"pattern_of_glob_constr" pp let warn_cast_in_pattern = CWarnings.create ~name:"cast-in-pattern" ~category:"automation" @@ -387,7 +387,7 @@ let rec pat_of_raw metas vars = function rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas nvars p)) | (None | Some (GHole _)), _ -> PMeta None | Some p, None -> - user_err_loc (loc,"",strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") + user_err ~loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") in let info = { cip_style = sty; @@ -400,12 +400,12 @@ let rec pat_of_raw metas vars = function one non-trivial branch. These facts are used in [Constrextern]. *) PCase (info, pred, pat_of_raw metas vars c, brs) - | r -> err (loc_of_glob_constr r) (Pp.str "Non supported pattern.") + | r -> err ~loc:(loc_of_glob_constr r) (Pp.str "Non supported pattern.") and pats_of_glob_branches loc metas vars ind brs = let get_arg = function | PatVar(_,na) -> na - | PatCstr(loc,_,_,_) -> err loc (Pp.str "Non supported pattern.") + | PatCstr(loc,_,_,_) -> err ~loc (Pp.str "Non supported pattern.") in let rec get_pat indexes = function | [] -> false, [] @@ -414,10 +414,10 @@ and pats_of_glob_branches loc metas vars ind brs = let () = match ind with | Some sp when eq_ind sp indsp -> () | _ -> - err loc (Pp.str "All constructors must be in the same inductive type.") + err ~loc (Pp.str "All constructors must be in the same inductive type.") in if Int.Set.mem (j-1) indexes then - err loc + err ~loc (str "No unique branch for " ++ int j ++ str"-th constructor."); let lna = List.map get_arg lv in let vars' = List.rev lna @ vars in @@ -425,7 +425,7 @@ and pats_of_glob_branches loc metas vars ind brs = let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in ext, ((j-1, tags, pat) :: pats) - | (loc,_,_,_) :: _ -> err loc (Pp.str "Non supported pattern.") + | (loc,_,_,_) :: _ -> err ~loc (Pp.str "Non supported pattern.") in get_pat Int.Set.empty brs diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 00b6100c0..5b0958695 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -64,43 +64,42 @@ let precatchable_exception = function | Nametab.GlobalizationError _ -> true | _ -> false -let raise_pretype_error (loc,env,sigma,te) = - Loc.raise loc (PretypeError(env,sigma,te)) +let raise_pretype_error ?loc (env,sigma,te) = + Loc.raise ?loc (PretypeError(env,sigma,te)) -let raise_located_type_error (loc,env,sigma,te) = - Loc.raise loc (PretypeError(env,sigma,TypingError te)) +let raise_type_error ?loc (env,sigma,te) = + Loc.raise ?loc (PretypeError(env,sigma,TypingError te)) - -let error_actual_type_loc loc env sigma {uj_val=c;uj_type=actty} expty reason = +let error_actual_type ?loc env sigma {uj_val=c;uj_type=actty} expty reason = let j = {uj_val=c;uj_type=actty} in - raise_pretype_error - (loc, env, sigma, ActualTypeNotCoercible (j, expty, reason)) + raise_pretype_error ?loc + (env, sigma, ActualTypeNotCoercible (j, expty, reason)) -let error_cant_apply_not_functional_loc loc env sigma rator randl = - raise_located_type_error - (loc, env, sigma, CantApplyNonFunctional (rator, Array.of_list randl)) +let error_cant_apply_not_functional ?loc env sigma rator randl = + raise_type_error ?loc + (env, sigma, CantApplyNonFunctional (rator, Array.of_list randl)) -let error_cant_apply_bad_type_loc loc env sigma (n,c,t) rator randl = - raise_located_type_error - (loc, env, sigma, +let error_cant_apply_bad_type ?loc env sigma (n,c,t) rator randl = + raise_type_error ?loc + (env, sigma, CantApplyBadType ((n,c,t), rator, Array.of_list randl)) -let error_ill_formed_branch_loc loc env sigma c i actty expty = - raise_located_type_error - (loc, env, sigma, IllFormedBranch (c, i, actty, expty)) +let error_ill_formed_branch ?loc env sigma c i actty expty = + raise_type_error + ?loc (env, sigma, IllFormedBranch (c, i, actty, expty)) -let error_number_branches_loc loc env sigma cj expn = - raise_located_type_error (loc, env, sigma, NumberBranches (cj, expn)) +let error_number_branches ?loc env sigma cj expn = + raise_type_error ?loc (env, sigma, NumberBranches (cj, expn)) -let error_case_not_inductive_loc loc env sigma cj = - raise_located_type_error (loc, env, sigma, CaseNotInductive cj) +let error_case_not_inductive ?loc env sigma cj = + raise_type_error ?loc (env, sigma, CaseNotInductive cj) -let error_ill_typed_rec_body_loc loc env sigma i na jl tys = - raise_located_type_error - (loc, env, sigma, IllTypedRecBody (i, na, jl, tys)) +let error_ill_typed_rec_body ?loc env sigma i na jl tys = + raise_type_error ?loc + (env, sigma, IllTypedRecBody (i, na, jl, tys)) -let error_not_a_type_loc loc env sigma j = - raise_located_type_error (loc, env, sigma, NotAType j) +let error_not_a_type ?loc env sigma j = + raise_type_error ?loc (env, sigma, NotAType j) (*s Implicit arguments synthesis errors. It is hard to find a precise location. *) @@ -108,15 +107,12 @@ let error_not_a_type_loc loc env sigma j = let error_occur_check env sigma ev c = raise (PretypeError (env, sigma, UnifOccurCheck (ev,c))) -let error_unsolvable_implicit loc env sigma evk explain = - Loc.raise loc +let error_unsolvable_implicit ?loc env sigma evk explain = + Loc.raise ?loc (PretypeError (env, sigma, UnsolvableImplicit (evk, explain))) -let error_cannot_unify_loc loc env sigma ?reason (m,n) = - Loc.raise loc (PretypeError (env, sigma,CannotUnify (m,n,reason))) - -let error_cannot_unify env sigma ?reason (m,n) = - raise (PretypeError (env, sigma,CannotUnify (m,n,reason))) +let error_cannot_unify ?loc env sigma ?reason (m,n) = + Loc.raise ?loc (PretypeError (env, sigma,CannotUnify (m,n,reason))) let error_cannot_unify_local env sigma (m,n,sn) = raise (PretypeError (env, sigma,CannotUnifyLocal (m,n,sn))) @@ -140,21 +136,21 @@ let error_non_linear_unification env sigma hdmeta t = (*s Ml Case errors *) -let error_cant_find_case_type_loc loc env sigma expr = - raise_pretype_error (loc, env, sigma, CantFindCaseType expr) +let error_cant_find_case_type ?loc env sigma expr = + raise_pretype_error ?loc (env, sigma, CantFindCaseType expr) (*s Pretyping errors *) -let error_unexpected_type_loc loc env sigma actty expty = - raise_pretype_error (loc, env, sigma, UnexpectedType (actty, expty)) +let error_unexpected_type ?loc env sigma actty expty = + raise_pretype_error ?loc (env, sigma, UnexpectedType (actty, expty)) -let error_not_product_loc loc env sigma c = - raise_pretype_error (loc, env, sigma, NotProduct c) +let error_not_product ?loc env sigma c = + raise_pretype_error ?loc (env, sigma, NotProduct c) (*s Error in conversion from AST to glob_constr *) -let error_var_not_found_loc loc s = - raise_pretype_error (loc, empty_env, Evd.empty, VarNotFound s) +let error_var_not_found ?loc s = + raise_pretype_error ?loc (empty_env, Evd.empty, VarNotFound s) (*s Typeclass errors *) @@ -166,7 +162,7 @@ let unsatisfiable_constraints env evd ev comp = | Some ev -> let loc, kind = Evd.evar_source ev evd in let err = UnsatisfiableConstraints (Some (ev, kind), comp) in - Loc.raise loc (PretypeError (env,evd,err)) + Loc.raise ~loc (PretypeError (env,evd,err)) let unsatisfiable_exception exn = match exn with diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 880f48e5f..73f81923f 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -64,35 +64,35 @@ exception PretypeError of env * Evd.evar_map * pretype_error val precatchable_exception : exn -> bool (** Raising errors *) -val error_actual_type_loc : - Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr -> +val error_actual_type : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr -> unification_error -> 'b -val error_cant_apply_not_functional_loc : - Loc.t -> env -> Evd.evar_map -> +val error_cant_apply_not_functional : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> unsafe_judgment list -> 'b -val error_cant_apply_bad_type_loc : - Loc.t -> env -> Evd.evar_map -> int * constr * constr -> +val error_cant_apply_bad_type : + ?loc:Loc.t -> env -> Evd.evar_map -> int * constr * constr -> unsafe_judgment -> unsafe_judgment list -> 'b -val error_case_not_inductive_loc : - Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b +val error_case_not_inductive : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b -val error_ill_formed_branch_loc : - Loc.t -> env -> Evd.evar_map -> +val error_ill_formed_branch : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> pconstructor -> constr -> constr -> 'b -val error_number_branches_loc : - Loc.t -> env -> Evd.evar_map -> +val error_number_branches : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> int -> 'b -val error_ill_typed_rec_body_loc : - Loc.t -> env -> Evd.evar_map -> +val error_ill_typed_rec_body : + ?loc:Loc.t -> env -> Evd.evar_map -> int -> Name.t array -> unsafe_judgment array -> types array -> 'b -val error_not_a_type_loc : - Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b +val error_not_a_type : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b @@ -101,15 +101,12 @@ val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b val error_occur_check : env -> Evd.evar_map -> existential_key -> constr -> 'b val error_unsolvable_implicit : - Loc.t -> env -> Evd.evar_map -> existential_key -> + ?loc:Loc.t -> env -> Evd.evar_map -> existential_key -> Evd.unsolvability_explanation option -> 'b -val error_cannot_unify_loc : Loc.t -> env -> Evd.evar_map -> +val error_cannot_unify : ?loc:Loc.t -> env -> Evd.evar_map -> ?reason:unification_error -> constr * constr -> 'b -val error_cannot_unify : env -> Evd.evar_map -> ?reason:unification_error -> - constr * constr -> 'b - val error_cannot_unify_local : env -> Evd.evar_map -> constr * constr * constr -> 'b val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map -> @@ -126,20 +123,20 @@ val error_non_linear_unification : env -> Evd.evar_map -> (** {6 Ml Case errors } *) -val error_cant_find_case_type_loc : - Loc.t -> env -> Evd.evar_map -> constr -> 'b +val error_cant_find_case_type : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b (** {6 Pretyping errors } *) -val error_unexpected_type_loc : - Loc.t -> env -> Evd.evar_map -> constr -> constr -> 'b +val error_unexpected_type : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> constr -> 'b -val error_not_product_loc : - Loc.t -> env -> Evd.evar_map -> constr -> 'b +val error_not_product : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b (** {6 Error in conversion from AST to glob_constr } *) -val error_var_not_found_loc : Loc.t -> Id.t -> 'b +val error_var_not_found : ?loc:Loc.t -> Id.t -> 'b (** {6 Typeclass errors } *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index af8bcb3f6..385e100e2 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -161,7 +161,7 @@ let search_guard loc env possible_indexes fixdefs = with TypeError _ -> ()) (List.combinations possible_indexes); let errmsg = "Cannot guess decreasing argument of fix." in - user_err_loc (loc,"search_guard", Pp.str errmsg) + user_err ~loc ~hdr:"search_guard" (Pp.str errmsg) with Found indexes -> indexes) (* To force universe name declaration before use *) @@ -212,8 +212,8 @@ let interp_universe_level_name evd (loc,s) = with Not_found -> if not (is_strict_universe_declarations ()) then new_univ_level_variable ~loc ~name:s univ_rigid evd - else user_err_loc (loc, "interp_universe_level_name", - Pp.(str "Undeclared universe: " ++ str s)) + else user_err ~loc ~hdr:"interp_universe_level_name" + (Pp.(str "Undeclared universe: " ++ str s)) let interp_universe ?loc evd = function | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in @@ -299,7 +299,7 @@ let check_extra_evars_are_solved env current_sigma pending = match k with | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () | _ -> - error_unsolvable_implicit loc env current_sigma evk None) pending + error_unsolvable_implicit ~loc env current_sigma evk None) pending (* [check_evars] fails if some unresolved evar remains *) @@ -314,7 +314,7 @@ let check_evars env initial_sigma sigma c = let (loc,k) = evar_source evk sigma in match k with | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () - | _ -> Pretype_errors.error_unsolvable_implicit loc env sigma evk None) + | _ -> Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None) | _ -> Constr.iter proc_rec c in proc_rec c @@ -360,7 +360,7 @@ let evar_type_fixpoint loc env evdref lna lar vdefj = for i = 0 to lt-1 do if not (e_cumul env.ExtraEnv.env evdref (vdefj.(i)).uj_type (lift lt lar.(i))) then - error_ill_typed_rec_body_loc loc env.ExtraEnv.env !evdref + error_ill_typed_rec_body ~loc env.ExtraEnv.env !evdref i lna vdefj lar done @@ -374,9 +374,9 @@ let check_instance loc subst = function | [] -> () | (id,_) :: _ -> if List.mem_assoc id subst then - user_err_loc (loc,"",pr_id id ++ str "appears more than once.") + user_err ~loc (pr_id id ++ str "appears more than once.") else - user_err_loc (loc,"",str "No such variable in the signature of the existential variable: " ++ pr_id id ++ str ".") + user_err ~loc (str "No such variable in the signature of the existential variable: " ++ pr_id id ++ str ".") (* used to enforce a name in Lambda when the type constraints itself is named, hence possibly dependent *) @@ -391,7 +391,7 @@ let ltac_interp_name { ltac_idents ; ltac_genargs } = function try Name (Id.Map.find id ltac_idents) with Not_found -> if Id.Map.mem id ltac_genargs then - errorlabstrm "" (str"Ltac variable"++spc()++ pr_id id ++ + user_err (str"Ltac variable"++spc()++ pr_id id ++ spc()++str"is not bound to an identifier."++spc()++ str"It cannot be used in a binder.") else n @@ -413,14 +413,14 @@ let invert_ltac_bound_name lvar env id0 id = let id' = Id.Map.find id lvar.ltac_idents in try mkRel (pi1 (lookup_rel_id id' (rel_context env))) with Not_found -> - errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++ + user_err (str "Ltac variable " ++ pr_id id0 ++ str " depends on pattern variable name " ++ pr_id id ++ str " which is not bound in current context.") let protected_get_type_of env sigma c = try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c with Retyping.RetypeError _ -> - errorlabstrm "" + user_err (str "Cannot reinterpret " ++ quote (print_constr c) ++ str " in the current environment.") @@ -456,8 +456,8 @@ let pretype_id pretype k0 loc env evdref lvar id = (* and build a nice error message *) if Id.Map.mem id lvar.ltac_genargs then begin let Geninterp.Val.Dyn (typ, _) = Id.Map.find id lvar.ltac_genargs in - user_err_loc (loc,"", - str "Variable " ++ pr_id id ++ str " should be bound to a term but is \ + user_err ~loc + (str "Variable " ++ pr_id id ++ str " should be bound to a term but is \ bound to a " ++ Geninterp.Val.pr typ ++ str ".") end; (* Check if [id] is a section or goal variable *) @@ -465,7 +465,7 @@ let pretype_id pretype k0 loc env evdref lvar id = { uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id env) } with Not_found -> (* [id] not found, standard error message *) - error_var_not_found_loc loc id + error_var_not_found ~loc id let evar_kind_of_term sigma c = kind_of_term (whd_evar sigma c) @@ -488,16 +488,16 @@ let pretype_global loc rigid env evd gr us = let arr = Univ.Instance.to_array (Univ.UContext.instance ctx) in let len = Array.length arr in if len != List.length l then - user_err_loc (loc, "pretype", - str "Universe instance should have length " ++ int len) + user_err ~loc ~hdr:"pretype" + (str "Universe instance should have length " ++ int len) else let evd, l' = List.fold_left (fun (evd, univs) l -> let evd, l = interp_universe_level_name loc evd l in (evd, l :: univs)) (evd, []) l in if List.exists (fun l -> Univ.Level.is_prop l) l' then - user_err_loc (loc, "pretype", - str "Universe instances cannot contain Prop, polymorphic" ++ + user_err ~loc ~hdr:"pretype" + (str "Universe instances cannot contain Prop, polymorphic" ++ str " universe instances must be greater or equal to Set."); evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) in @@ -512,7 +512,7 @@ let pretype_ref loc evdref env ref us = (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal variables *) - Pretype_errors.error_var_not_found_loc loc id) + Pretype_errors.error_var_not_found ~loc id) | ref -> let evd, c = pretype_global loc univ_flexible env !evdref ref us in let () = evdref := evd in @@ -568,7 +568,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let evk = try Evd.evar_key id !evdref with Not_found -> - user_err_loc (loc,"",str "Unknown existential variable.") in + user_err ~loc (str "Unknown existential variable.") in let hyps = evar_filtered_context (Evd.find !evdref evk) in let args = pretype_instance k0 resolve_tc env evdref lvar loc hyps evk inst in let c = mkEvar (evk, args) in @@ -751,9 +751,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | _ -> let hj = pretype empty_tycon env evdref lvar c in - error_cant_apply_not_functional_loc - (Loc.merge floc argloc) env.ExtraEnv.env !evdref - resj [hj] + error_cant_apply_not_functional + ~loc:(Loc.merge floc argloc) env.ExtraEnv.env !evdref + resj [hj] in let resj = apply_rec env 1 fj candargs args in let resj = @@ -846,15 +846,15 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre try find_rectype env.ExtraEnv.env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env.ExtraEnv.env !evdref cj + error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj in let cstrs = get_constructors env.ExtraEnv.env indf in if not (Int.equal (Array.length cstrs) 1) then - user_err_loc (loc,"",str "Destructing let is only for inductive types" ++ + user_err ~loc (str "Destructing let is only for inductive types" ++ str " with one constructor."); let cs = cstrs.(0) in if not (Int.equal (List.length nal) cs.cs_nargs) then - user_err_loc (loc,"", str "Destructing let on this type expects " ++ + user_err ~loc:loc (str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables."); let fsign, record = match get_projections env.ExtraEnv.env indf with @@ -920,7 +920,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre if noccur_between 1 cs.cs_nargs ccl then lift (- cs.cs_nargs) ccl else - error_cant_find_case_type_loc loc env.ExtraEnv.env !evdref + error_cant_find_case_type ~loc env.ExtraEnv.env !evdref cj.uj_val in (* let ccl = refresh_universes ccl in *) let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in @@ -936,11 +936,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre try find_rectype env.ExtraEnv.env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env.ExtraEnv.env !evdref cj in + error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj in let cstrs = get_constructors env.ExtraEnv.env indf in if not (Int.equal (Array.length cstrs) 2) then - user_err_loc (loc,"", - str "If is only for inductive types with two constructors."); + user_err ~loc + (str "If is only for inductive types with two constructors."); let arsgn = let arsgn,_ = get_arity env.ExtraEnv.env indf in @@ -1022,9 +1022,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let (evd,b) = Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else - error_actual_type_loc loc env.ExtraEnv.env !evdref cj tval + error_actual_type ~loc env.ExtraEnv.env !evdref cj tval (ConversionFailed (env.ExtraEnv.env,cty,tval)) - else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ + else user_err ~loc (str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> let cj = pretype empty_tycon env evdref lvar c in @@ -1033,7 +1033,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else - error_actual_type_loc loc env.ExtraEnv.env !evdref cj tval + error_actual_type ~loc env.ExtraEnv.env !evdref cj tval (ConversionFailed (env.ExtraEnv.env,cty,tval)) end | _ -> @@ -1061,7 +1061,7 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = let t' = env |> lookup_named id |> NamedDecl.get_type in if is_conv env.ExtraEnv.env !evdref t t' then mkVar id, update else raise Not_found with Not_found -> - user_err_loc (loc,"",str "Cannot interpret " ++ + user_err ~loc (str "Cannot interpret " ++ pr_existential_key !evdref evk ++ str " in current context: no binding for " ++ pr_id id ++ str ".") in ((id,c)::subst, update) in @@ -1099,8 +1099,8 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function | Some v -> if e_cumul env.ExtraEnv.env evdref v tj.utj_val then tj else - error_unexpected_type_loc - (loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v + error_unexpected_type + ~loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v let ise_pretype_gen flags env sigma lvar kind c = let env = make_env env in diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 284af0cb1..cda052b79 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -291,7 +291,7 @@ let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x) (*s High-level declaration of a canonical structure *) let error_not_structure ref = - errorlabstrm "object_declare" + user_err ~hdr:"object_declare" (Nameops.pr_id (basename_of_global ref) ++ str" is not a structure object.") let check_and_decompose_canonical_structure ref = diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 8259876c2..7ee70d9e0 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1205,7 +1205,7 @@ let pb_equal = function | Reduction.CONV -> Reduction.CONV let report_anomaly _ = - let e = UserError ("", Pp.str "Conversion test raised an anomaly") in + let e = UserError (None, Pp.str "Conversion test raised an anomaly") in let e = CErrors.push e in iraise e diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 160b3bc3f..7da738508 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -41,7 +41,7 @@ exception Elimconst exception Redelimination let error_not_evaluable r = - errorlabstrm "error_not_evaluable" + user_err ~hdr:"error_not_evaluable" (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r ++ spc () ++ str "to an evaluable reference.") @@ -989,7 +989,7 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> incr pos; if ok then begin if Option.has_some nested then - errorlabstrm "" (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (!pos-1) ++ str "."); + user_err (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (!pos-1) ++ str "."); (* Skip inner occurrences for stable counting of occurrences *) if locs != [] then ignore (traverse_below (Some (!pos-1)) envc t); @@ -1155,13 +1155,13 @@ let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> let check_privacy env ind = let spec = Inductive.lookup_mind_specif env (fst ind) in if Inductive.is_private spec then - errorlabstrm "" (str "case analysis on a private type.") + user_err (str "case analysis on a private type.") else ind let check_not_primitive_record env ind = let spec = Inductive.lookup_mind_specif env (fst ind) in if Inductive.is_primitive_record spec then - errorlabstrm "" (str "case analysis on a primitive record type: " ++ + user_err (str "case analysis on a primitive record type: " ++ str "use projections or let instead.") else ind @@ -1178,14 +1178,14 @@ let reduce_to_ind_gen allow_product env sigma t = if allow_product then elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) else - errorlabstrm "" (str"Not an inductive definition.") + user_err (str"Not an inductive definition.") | _ -> (* Last chance: we allow to bypass the Opaque flag (as it was partially the case between V5.10 and V8.1 *) let t' = whd_all env sigma t in match kind_of_term (fst (decompose_app t')) with | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) - | _ -> errorlabstrm "" (str"Not an inductive product.") + | _ -> user_err (str"Not an inductive product.") in elimrec env t [] @@ -1235,7 +1235,7 @@ let one_step_reduce env sigma c = applist (redrec (c,[])) let error_cannot_recognize ref = - errorlabstrm "" + user_err (str "Cannot recognize a statement based on " ++ Nametab.pr_global_env Id.Set.empty ref ++ str".") diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 213eecc6b..8feb34e3e 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1588,7 +1588,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let ids = ids_of_named_context (named_context env) in if name == Anonymous then next_ident_away_in_goal x ids else if mem_named_context x (named_context env) then - errorlabstrm "Unification.make_abstraction_core" + user_err ~hdr:"Unification.make_abstraction_core" (str "The variable " ++ Nameops.pr_id x ++ str " is already declared.") else x @@ -1602,7 +1602,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = if indirectly_dependent c d depdecls then (* Told explicitly not to abstract over [d], but it is dependent *) let id' = indirect_dependency d depdecls in - errorlabstrm "" (str "Cannot abstract over " ++ Nameops.pr_id id' + user_err (str "Cannot abstract over " ++ Nameops.pr_id id' ++ str " without also abstracting or erasing " ++ Nameops.pr_id hyp ++ str ".") else diff --git a/printing/prettyp.ml b/printing/prettyp.ml index f56f83e17..3d0b07a1e 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -702,7 +702,7 @@ let read_sec_context r = let dir = try Nametab.locate_section qid with Not_found -> - user_err_loc (loc,"read_sec_context", str "Unknown section.") in + user_err ~loc ~hdr:"read_sec_context" (str "Unknown section.") in let rec get_cxt in_cxt = function | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest -> if DirPath.equal dir dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest @@ -737,8 +737,8 @@ let print_any_name = function if not (DirPath.is_empty dir) then raise Not_found; str |> Global.lookup_named |> NamedDecl.set_id str |> print_named_decl with Not_found -> - errorlabstrm - "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") + user_err + ~hdr:"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") let print_name = function | ByNotation (loc,ntn,sc) -> @@ -831,7 +831,7 @@ let index_of_class cl = try fst (class_info cl) with Not_found -> - errorlabstrm "index_of_class" + user_err ~hdr:"index_of_class" (pr_class cl ++ spc() ++ str "not a defined class.") let print_path_between cls clt = @@ -841,7 +841,7 @@ let print_path_between cls clt = try lookup_path_between_class (i,j) with Not_found -> - errorlabstrm "index_cl_of_id" + user_err ~hdr:"index_cl_of_id" (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt ++ str ".") in diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 0a90e0dbd..fad656223 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -155,7 +155,7 @@ let error_incompatible_inst clenv mv = let na = meta_name clenv.evd mv in match na with Name id -> - errorlabstrm "clenv_assign" + user_err ~hdr:"clenv_assign" (str "An incompatible instantiation has already been found for " ++ pr_id id) | _ -> @@ -417,11 +417,11 @@ let qhyp_eq h1 h2 = match h1, h2 with let check_bindings bl = match List.duplicates qhyp_eq (List.map pi2 bl) with | NamedHyp s :: _ -> - errorlabstrm "" + user_err (str "The variable " ++ pr_id s ++ str " occurs more than once in binding list."); | AnonHyp n :: _ -> - errorlabstrm "" + user_err (str "The position " ++ int n ++ str " occurs more than once in binding list.") | [] -> () @@ -435,7 +435,7 @@ let explain_no_such_bound_variable evd id = if na != Anonymous then out_name na :: l else l in let mvl = List.fold_left fold [] (Evd.meta_list evd) in - errorlabstrm "Evd.meta_with_name" + user_err ~hdr:"Evd.meta_with_name" (str"No such bound variable " ++ pr_id id ++ (if mvl == [] then str " (no bound variables at all in the expression)." else @@ -460,7 +460,7 @@ let meta_with_name evd id = | ([n],_|_,[n]) -> n | _ -> - errorlabstrm "Evd.meta_with_name" + user_err ~hdr:"Evd.meta_with_name" (str "Binder name \"" ++ pr_id id ++ strbrk "\" occurs more than once in clause.") @@ -469,12 +469,12 @@ let meta_of_binder clause loc mvs = function | AnonHyp n -> try List.nth mvs (n-1) with (Failure _|Invalid_argument _) -> - errorlabstrm "" (str "No such binder.") + user_err (str "No such binder.") let error_already_defined b = match b with | NamedHyp id -> - errorlabstrm "" + user_err (str "Binder name \"" ++ pr_id id ++ str"\" already defined with incompatible value.") | AnonHyp n -> @@ -527,7 +527,7 @@ let clenv_constrain_last_binding c clenv = clenv_assign_binding clenv k c let error_not_right_number_missing_arguments n = - errorlabstrm "" + user_err (strbrk "Not the right number of missing arguments (expected " ++ int n ++ str ").") @@ -641,7 +641,7 @@ let explain_no_such_bound_variable holes id = | [id] -> str "(possible name is: " ++ pr_id id ++ str ")." | _ -> str "(possible names are: " ++ pr_enum pr_id mvl ++ str ")." in - errorlabstrm "" (str "No such bound variable " ++ pr_id id ++ expl) + user_err (str "No such bound variable " ++ pr_id id ++ expl) let evar_with_name holes id = let map h = match h.hole_name with @@ -653,7 +653,7 @@ let evar_with_name holes id = | [] -> explain_no_such_bound_variable holes id | [h] -> h.hole_evar | _ -> - errorlabstrm "" + user_err (str "Binder name \"" ++ pr_id id ++ str "\" occurs more than once in clause.") @@ -664,7 +664,7 @@ let evar_of_binder holes = function let h = List.nth holes (pred n) in h.hole_evar with e when CErrors.noncritical e -> - errorlabstrm "" (str "No such binder.") + user_err (str "No such binder.") let define_with_type sigma env ev c = let t = Retyping.get_type_of env sigma ev in diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 5f0cc73d2..ff0df9179 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -54,8 +54,8 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = env sigma ltac_var (Pretyping.OfType evi.evar_concl) rawc with e when CErrors.noncritical e -> let loc = Glob_ops.loc_of_glob_constr rawc in - user_err_loc - (loc,"", str "Instance is not well-typed in the environment of " ++ + user_err ~loc + (str "Instance is not well-typed in the environment of " ++ pr_existential_key sigma evk ++ str ".") in define_and_solve_constraints evk typed_c env (evars_reset_evd sigma' sigma) diff --git a/proofs/logic.ml b/proofs/logic.ml index e12fe5d70..5aba6b614 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -153,7 +153,7 @@ let reorder_context env sign ord = | top::ord' when mem_q top moved_hyps -> let ((d,h),mh) = find_q top moved_hyps in if occur_vars_in_decl env h d then - errorlabstrm "reorder_context" + user_err ~hdr:"reorder_context" (str "Cannot move declaration " ++ pr_id top ++ spc() ++ str "before " ++ pr_sequence pr_id @@ -184,7 +184,7 @@ let check_decl_position env sign d = let needed = global_vars_set_of_decl env d in let deps = dependency_closure env (named_context_of_val sign) needed in if Id.List.mem x deps then - errorlabstrm "Logic.check_decl_position" + user_err ~hdr:"Logic.check_decl_position" (str "Cannot create self-referring hypothesis " ++ pr_id x); x::deps @@ -254,7 +254,7 @@ let move_hyp toleft (left,declfrom,right) hto = if not (move_location_eq hto (MoveAfter hyp)) then (first, d::middle) else - errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id (NamedDecl.get_id declfrom) ++ + user_err ~hdr:"move_hyp" (str "Cannot move " ++ pr_id (NamedDecl.get_id declfrom) ++ Miscprint.pr_move_location pr_id hto ++ str (if toleft then ": it occurs in " else ": it depends on ") ++ pr_id hyp ++ str ".") @@ -289,7 +289,7 @@ let move_hyp toleft (left,declfrom,right) hto = variables only in Application and Case *) let error_unsupported_deep_meta c = - errorlabstrm "" (strbrk "Application of lemmas whose beta-iota normal " ++ + user_err (strbrk "Application of lemmas whose beta-iota normal " ++ strbrk "form contains metavariables deep inside the term is not " ++ strbrk "supported; try \"refine\" instead.") @@ -501,10 +501,10 @@ let convert_hyp check sign sigma d = let c = NamedDecl.get_value d' in let env = Global.env_of_context sign in if check && not (is_conv env sigma (NamedDecl.get_type d) (NamedDecl.get_type d')) then - errorlabstrm "Logic.convert_hyp" + user_err ~hdr:"Logic.convert_hyp" (str "Incorrect change of the type of " ++ pr_id id ++ str "."); if check && not (Option.equal (is_conv env sigma) b c) then - errorlabstrm "Logic.convert_hyp" + user_err ~hdr:"Logic.convert_hyp" (str "Incorrect change of the body of "++ pr_id id ++ str "."); if check then reorder := check_decl_position env sign d; d) in @@ -537,7 +537,7 @@ let prim_refiner r sigma goal = t,cl,sigma else (if !check && mem_named_context id (named_context_of_val sign) then - errorlabstrm "Logic.prim_refiner" + user_err ~hdr:"Logic.prim_refiner" (str "Variable " ++ pr_id id ++ str " is already declared."); push_named_context_val (LocalAssum (id,t)) sign,t,cl,sigma) in let (sg2,ev2,sigma) = diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index e4bae2012..86c2b7a57 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -131,7 +131,7 @@ let solve ?with_end_tac gi info_lvl tac pr = | CList.IndexOutOfRange -> match gi with | Vernacexpr.SelectNth i -> let msg = str "No such goal: " ++ int i ++ str "." in - CErrors.errorlabstrm "" msg + CErrors.user_err msg | _ -> assert false let by tac = Proof_global.with_current_proof (fun _ -> solve (Vernacexpr.SelectNth 1) None tac) @@ -228,7 +228,7 @@ let solve_by_implicit_tactic env sigma evk = when Context.Named.equal (Environ.named_context_of_val evi.evar_hyps) (Environ.named_context env) -> - let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (CErrors.UserError ("",Pp.str"Proof is not complete."))) []) in + let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (CErrors.UserError (None,Pp.str"Proof is not complete."))) []) in (try let c = Evarutil.nf_evars_universes sigma evi.evar_concl in if Evarutil.has_undefined_evars sigma c then raise Exit; diff --git a/proofs/proof.ml b/proofs/proof.ml index 5fe29653d..16278b456 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -68,9 +68,9 @@ let _ = CErrors.register_handler begin function | CannotUnfocusThisWay -> CErrors.error "This proof is focused, but cannot be unfocused this way" | NoSuchGoals (i,j) when Int.equal i j -> - CErrors.errorlabstrm "Focus" Pp.(str"No such goal (" ++ int i ++ str").") + CErrors.user_err ~hdr:"Focus" Pp.(str"No such goal (" ++ int i ++ str").") | NoSuchGoals (i,j) -> - CErrors.errorlabstrm "Focus" Pp.( + CErrors.user_err ~hdr:"Focus" Pp.( str"Not every goal in range ["++ int i ++ str","++int j++str"] exist." ) | FullyUnfocused -> CErrors.error "The proof is not focused" diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 17cc92803..f3ca19a90 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -204,8 +204,8 @@ let discard (loc,id) = let n = List.length !pstates in discard_gen id; if Int.equal (List.length !pstates) n then - CErrors.user_err_loc - (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs ()) + CErrors.user_err ~loc + ~hdr:"Pfedit.delete_proof" (str"No such proof" ++ msg_proofs ()) let discard_current () = if List.is_empty !pstates then raise NoCurrentProof else pstates := List.tl !pstates @@ -410,7 +410,7 @@ let return_proof ?(allow_partial=false) () = let evd = let error s = let prf = str " (in proof " ++ Id.print pid ++ str ")" in - raise (CErrors.UserError("last tactic before Qed",s ++ prf)) + raise (CErrors.UserError(Some "last tactic before Qed",s ++ prf)) in try Proof.return proof with | Proof.UnfinishedProof -> @@ -521,7 +521,7 @@ module Bullet = struct (function | FailedBullet (b,sugg) -> let prefix = str"Wrong bullet " ++ pr_bullet b ++ str" : " in - CErrors.errorlabstrm "Focus" (prefix ++ suggest_on_error sugg) + CErrors.user_err ~hdr:"Focus" (prefix ++ suggest_on_error sugg) | _ -> raise CErrors.Unhandled) diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 8a9ce4f94..41ad7d94e 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -73,7 +73,7 @@ let set_strategy_one ref l = let cb = Global.lookup_constant sp in (match cb.const_body with | OpaqueDef _ -> - errorlabstrm "set_transparent_const" + user_err ~hdr:"set_transparent_const" (str "Cannot make" ++ spc () ++ Nametab.pr_global_env Id.Set.empty (ConstRef sp) ++ spc () ++ str "transparent because it was declared opaque."); @@ -175,19 +175,19 @@ let red_expr_tab = Summary.ref String.Map.empty ~name:"Declare Reduction" let declare_reduction s f = if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab - then errorlabstrm "Redexpr.declare_reduction" + then user_err ~hdr:"Redexpr.declare_reduction" (str "There is already a reduction expression of name " ++ str s) else reduction_tab := String.Map.add s f !reduction_tab let check_custom = function | ExtraRedExpr s -> if not (String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab) - then errorlabstrm "Redexpr.check_custom" (str "Reference to undefined reduction expression " ++ str s) + then user_err ~hdr:"Redexpr.check_custom" (str "Reference to undefined reduction expression " ++ str s) |_ -> () let decl_red_expr s e = if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab - then errorlabstrm "Redexpr.decl_red_expr" + then user_err ~hdr:"Redexpr.decl_red_expr" (str "There is already a reduction expression of name " ++ str s) else begin check_custom e; @@ -247,7 +247,7 @@ let reduction_of_red_expr env = with Not_found -> (try reduction_of_red_expr (String.Map.find s !red_expr_tab) with Not_found -> - errorlabstrm "Redexpr.reduction_of_red_expr" + user_err ~hdr:"Redexpr.reduction_of_red_expr" (str "unknown user-defined reduction \"" ++ str s ++ str "\""))) | CbvVm o -> (contextualize cbv_vm cbv_vm o, VMcast) | CbvNative o -> (contextualize cbv_native cbv_native o, NATIVEcast) diff --git a/proofs/refiner.ml b/proofs/refiner.ml index fdd0df445..9a0b56b84 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -61,7 +61,7 @@ let tclIDTAC_MESSAGE s gls = Feedback.msg_info (hov 0 s); tclIDTAC gls (* General failure tactic *) -let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" (str s) +let tclFAIL_s s gls = user_err ~hdr:"Refiner.tclFAIL_s" (str s) (* A special exception for levels for the Fail tactic *) exception FailError of int * std_ppcmds Lazy.t @@ -83,7 +83,7 @@ let thens3parts_tac tacfi tac tacli (sigr,gs) = let nf = Array.length tacfi in let nl = Array.length tacli in let ng = List.length gs in - if ng<nf+nl then errorlabstrm "Refiner.thensn_tac" (str "Not enough subgoals."); + if ng<nf+nl then user_err ~hdr:"Refiner.thensn_tac" (str "Not enough subgoals."); let gll = (List.map_i (fun i -> apply_sig_tac sigr (if i<nf then tacfi.(i) else if i>=ng-nl then tacli.(nl-ng+i) else tac)) @@ -165,14 +165,14 @@ the goal unchanged *) let tclWEAK_PROGRESS tac ptree = let rslt = tac ptree in if Goal.V82.weak_progress rslt ptree then rslt - else errorlabstrm "Refiner.WEAK_PROGRESS" (str"Failed to progress.") + else user_err ~hdr:"Refiner.WEAK_PROGRESS" (str"Failed to progress.") (* PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves the goal unchanged *) let tclPROGRESS tac ptree = let rslt = tac ptree in if Goal.V82.progress rslt ptree then rslt - else errorlabstrm "Refiner.PROGRESS" (str"Failed to progress.") + else user_err ~hdr:"Refiner.PROGRESS" (str"Failed to progress.") (* Same as tclWEAK_PROGRESS but fails also if tactics generates several goals, one of them being identical to the original goal *) @@ -183,7 +183,7 @@ let tclNOTSAMEGOAL (tac : tactic) goal = let rslt = tac goal in let {it=gls;sigma=sigma} = rslt in if List.exists (same_goal goal sigma) gls - then errorlabstrm "Refiner.tclNOTSAMEGOAL" + then user_err ~hdr:"Refiner.tclNOTSAMEGOAL" (str"Tactic generated a subgoal identical to the original goal.") else rslt @@ -317,7 +317,7 @@ let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl) let tclDO n t = let rec dorec k = - if k < 0 then errorlabstrm "Refiner.tclDO" + if k < 0 then user_err ~hdr:"Refiner.tclDO" (str"Wrong argument : Do needs a positive integer."); if Int.equal k 0 then tclIDTAC else if Int.equal k 1 then t else (tclTHEN t (dorec (k-1))) diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 6149e3a11..2ab3b9c59 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -224,7 +224,7 @@ let compute_proof_name locality = function if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) then - user_err_loc (loc,"",pr_id id ++ str " already exists."); + user_err ~loc (pr_id id ++ str " already exists."); id, pl | None -> next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()), None @@ -337,7 +337,7 @@ let get_proof proof do_guard hook opacity = let check_exist = List.iter (fun (loc,id) -> if not (Nametab.exists_cci (Lib.make_path id)) then - user_err_loc (loc,"",pr_id id ++ str " does not exist.") + user_err ~loc (pr_id id ++ str " does not exist.") ) let universe_proof_terminator compute_guard hook = diff --git a/stm/stm.ml b/stm/stm.ml index cf9fa5492..482bbe4c2 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1038,7 +1038,7 @@ end = struct (* {{{ *) | _ -> VtUnknown, VtNow with | Not_found -> - CErrors.errorlabstrm "undo_vernac_classifier" + CErrors.user_err ~hdr:"undo_vernac_classifier" (str "Cannot undo") end (* }}} *) @@ -1106,7 +1106,7 @@ let proof_block_delimiters = ref [] let register_proof_block_delimiter name static dynamic = if List.mem_assoc name !proof_block_delimiters then - CErrors.errorlabstrm "STM" (str "Duplicate block delimiter " ++ str name); + CErrors.user_err ~hdr:"STM" (str "Duplicate block delimiter " ++ str name); proof_block_delimiters := (name, (static,dynamic)) :: !proof_block_delimiters let mk_doc_node id = function @@ -1141,7 +1141,7 @@ let detect_proof_block id name = VCS.create_proof_block decl name end with Not_found -> - CErrors.errorlabstrm "STM" + CErrors.user_err ~hdr:"STM" (str "Unknown proof block delimiter " ++ str name) ) (****************************** THE SCHEDULER *********************************) @@ -1706,7 +1706,7 @@ end = struct (* {{{ *) List.for_all (Context.Named.Declaration.for_all (Evarutil.is_ground_term sigma0)) Evd.(evar_context g)) then - CErrors.errorlabstrm "STM" (strbrk("the par: goal selector supports ground "^ + CErrors.user_err ~hdr:"STM" (strbrk("the par: goal selector supports ground "^ "goals only")) else begin let (i, ast) = r_ast in @@ -1719,7 +1719,7 @@ end = struct (* {{{ *) let t = Evarutil.nf_evar sigma t in if Evarutil.is_ground_term sigma t then RespBuiltSubProof (t, Evd.evar_universe_context sigma) - else CErrors.errorlabstrm "STM" (str"The solution is not ground") + else CErrors.user_err ~hdr:"STM" (str"The solution is not ground") end) () with e when CErrors.noncritical e -> RespError (CErrors.print e) @@ -2056,7 +2056,7 @@ let known_state ?(redefine_qed=false) ~cache id = | _ -> assert false end with Not_found -> - CErrors.errorlabstrm "STM" + CErrors.user_err ~hdr:"STM" (str "Unknown proof block delimiter " ++ str name) in @@ -2405,7 +2405,7 @@ let handle_failure (e, info) vcs tty = let snapshot_vio ldir long_f_dot_vo = finish (); if List.length (VCS.branches ()) > 1 then - CErrors.errorlabstrm "stm" (str"Cannot dump a vio with open proofs"); + CErrors.user_err ~hdr:"stm" (str"Cannot dump a vio with open proofs"); Library.save_library_to ~todo:(dump_snapshot ()) ldir long_f_dot_vo (Global.opaque_tables ()) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 475005648..7628b7885 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -65,7 +65,7 @@ let raw_find_base bas = String.Map.find bas !rewtab let find_base bas = try raw_find_base bas with Not_found -> - errorlabstrm "AutoRewrite" + user_err ~hdr:"AutoRewrite" (str "Rewriting base " ++ str bas ++ str " does not exist.") let find_rewrites bas = @@ -294,8 +294,8 @@ let find_applied_relation metas loc env sigma c left2right = match decompose_applied_relation metas env sigma c ctype left2right with | Some c -> c | None -> - user_err_loc (loc, "decompose_applied_relation", - str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ + user_err ~loc ~hdr:"decompose_applied_relation" + (str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ spc () ++ str"of this term does not end with an applied relation.") (* To add rewriting rules to a base *) diff --git a/tactics/eauto.ml b/tactics/eauto.ml index ba9a2d95c..ba2195070 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -97,8 +97,8 @@ let prolog_tac l n = in let l = List.map map l in try (prolog l n gl) - with UserError ("Refiner.tclFIRST",_) -> - errorlabstrm "Prolog.prolog" (str "Prolog failed.") + with UserError (Some "Refiner.tclFIRST",_) -> + user_err ~hdr:"Prolog.prolog" (str "Prolog failed.") end open Auto @@ -431,7 +431,7 @@ let cons a l = a :: l let autounfolds db occs cls gl = let unfolds = List.concat (List.map (fun dbname -> let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in let hyps = pf_ids_of_hyps gl in @@ -498,7 +498,7 @@ let autounfold_one db cl = let st = List.fold_left (fun (i,c) dbname -> let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db diff --git a/tactics/equality.ml b/tactics/equality.ml index d078532b5..d4b372837 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -361,7 +361,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = let _ = Global.lookup_constant c1' in c1' with Not_found -> - errorlabstrm "Equality.find_elim" + user_err ~hdr:"Equality.find_elim" (str "Cannot find rewrite principle " ++ pr_label l' ++ str ".") end | _ -> destConstRef pr1 @@ -890,7 +890,7 @@ let build_selector env sigma dirn c ind special default = on (c bool true) = (c bool false) CP : changed assert false in a more informative error *) - errorlabstrm "Equality.construct_discriminator" + user_err ~hdr:"Equality.construct_discriminator" (str "Cannot discriminate on inductive constructors with \ dependent types.") in let (indp,_) = dest_ind_family indf in @@ -976,7 +976,7 @@ let apply_on_clause (f,t) clause = let argmv = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv - | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in + | _ -> user_err (str "Ill-formed clause applicator.")) in clenv_fchain ~with_univs:false argmv f_clause clause let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = @@ -1054,7 +1054,7 @@ let discrEverywhere with_evars = else (* <= 8.2 compat *) tryAllHypsAndConcl (discrSimpleClause with_evars)) (* (fun gls -> - errorlabstrm "DiscrEverywhere" (str"No discriminable equalities.")) + user_err ~hdr:"DiscrEverywhere" (str"No discriminable equalities.")) *) let discr_tac with_evars = function | None -> discrEverywhere with_evars @@ -1727,7 +1727,7 @@ let subst_one_var dep_proof_ok x = let hyps = Proofview.Goal.hyps gl in let test hyp _ = is_eq_x gl x hyp in Context.Named.fold_outside test ~init:() hyps; - errorlabstrm "Subst" + user_err ~hdr:"Subst" (str "Cannot find any non-recursive equality over " ++ pr_id x ++ str".") with FoundHyp res -> res in diff --git a/tactics/hints.ml b/tactics/hints.ml index a74fceb8f..4b43a9e69 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -633,7 +633,7 @@ let current_pure_db () = List.map snd (Hintdbmap.bindings (Hintdbmap.remove "v62" !searchtable)) let error_no_such_hint_database x = - errorlabstrm "Hints" (str "No such Hint database: " ++ str x ++ str ".") + user_err ~hdr:"Hints" (str "No such Hint database: " ++ str x ++ str ".") (**************************************************************************) (* Definition of the summary *) @@ -775,7 +775,7 @@ let make_resolves env sigma flags pri poly ?name cr = [make_exact_entry env sigma pri poly ?name; make_apply_entry env sigma flags pri poly ?name] in if List.is_empty ents then - errorlabstrm "Hint" + user_err ~hdr:"Hint" (pr_lconstr c ++ spc() ++ (if pi1 flags then str"cannot be used as a hint." else str "can be used as a hint only for eauto.")); @@ -818,7 +818,7 @@ let make_mode ref m = let n = List.length ctx in let m' = Array.of_list m in if not (n == Array.length m') then - errorlabstrm "Hint" + user_err ~hdr:"Hint" (pr_global ref ++ str" has " ++ int n ++ str" arguments while the mode declares " ++ int (Array.length m')) else m' @@ -1412,6 +1412,6 @@ let run_hint tac k = match !warn_hint with else Proofview.tclBIND (k tac.obj) (fun x -> warn tac x) | `STRICT -> if is_imported tac then k tac.obj - else Proofview.tclZERO (UserError ("", (str "Tactic failure."))) + else Proofview.tclZERO (UserError (None, (str "Tactic failure."))) let repr_hint h = h.obj diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 36770925f..72c3523da 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -452,7 +452,7 @@ let find_this_eq_data_decompose gl eqn = try (*first_match (match_eq eqn) inversible_equalities*) find_eq_data eqn with PatternMatchingFailure -> - errorlabstrm "" (str "No primitive equality found.") in + user_err (str "No primitive equality found.") in let eq_args = try extract_eq_args gl eq_args with PatternMatchingFailure -> diff --git a/tactics/inv.ml b/tactics/inv.ml index 575710ecc..291bc0965 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -77,7 +77,7 @@ let make_inv_predicate env evd indf realargs id status concl = (hyps_arity,concl) | Dep dflt_concl -> if not (occur_var env id concl) then - errorlabstrm "make_inv_predicate" + user_err ~hdr:"make_inv_predicate" (str "Current goal does not depend on " ++ pr_id id ++ str"."); (* We abstract the conclusion of goal with respect to realargs and c to * be concl in order to rewrite and have @@ -441,7 +441,7 @@ let raw_inversion inv_kind id status names = try pf_apply Tacred.reduce_to_atomic_ind gl (pf_unsafe_type_of gl c) with UserError _ -> let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in - CErrors.errorlabstrm "" msg + CErrors.user_err msg in let IndType (indf,realargs) = find_rectype env sigma t in let evdref = ref sigma in diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 1639ec54c..d80e86241 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -185,7 +185,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = let ind = try find_rectype env sigma i with Not_found -> - errorlabstrm "inversion_scheme" (no_inductive_inconstr env sigma i) + user_err ~hdr:"inversion_scheme" (no_inductive_inconstr env sigma i) in let (invEnv,invGoal) = compute_first_inversion_scheme env sigma ind sort dep_option @@ -195,7 +195,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = (global_vars env invGoal) (ids_of_named_context (named_context invEnv))); (* - errorlabstrm "lemma_inversion" + user_err ~hdr:"lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) let pf = Proof.start (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in @@ -249,8 +249,8 @@ let add_inversion_lemma_exn na com comsort bool tac = try add_inversion_lemma na env sigma c sort bool tac with - | UserError ("Case analysis",s) -> (* Reference to Indrec *) - errorlabstrm "Inv needs Nodep Prop Set" s + | UserError (Some "Case analysis",s) -> (* Reference to Indrec *) + user_err ~hdr:"Inv needs Nodep Prop Set" s (* ================================= *) (* Applying a given inversion lemma *) @@ -263,10 +263,10 @@ let lemInv id c gls = Proofview.V82.of_tactic (Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false) gls with | NoSuchBinding -> - errorlabstrm "" + user_err (hov 0 (pr_constr c ++ spc () ++ str "does not refer to an inversion lemma.")) | UserError (a,b) -> - errorlabstrm "LemInv" + user_err ~hdr:"LemInv" (str "Cannot refine current goal with the lemma " ++ pr_lconstr_env (Refiner.pf_env gls) (Refiner.project gls) c) diff --git a/tactics/tactic_matching.ml b/tactics/tactic_matching.ml index a5ccd500c..ef45ee47e 100644 --- a/tactics/tactic_matching.ml +++ b/tactics/tactic_matching.ml @@ -105,7 +105,7 @@ let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) = (merged, Id.Map.merge merge lcm lm) let matching_error = - CErrors.UserError ("tactic matching" , Pp.str "No matching clauses for match.") + CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") let imatching_error = (matching_error, Exninfo.null) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index ae2307190..203d97542 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -173,14 +173,14 @@ let check_or_and_pattern_size check_and loc names branchsigns = let n = Array.length branchsigns in let msg p1 p2 = strbrk "a conjunctive pattern made of " ++ int p1 ++ (if p1 == p2 then mt () else str " or " ++ int p2) ++ str " patterns" in let err1 p1 p2 = - user_err_loc (loc,"",str "Expects " ++ msg p1 p2 ++ str ".") in + user_err ~loc (str "Expects " ++ msg p1 p2 ++ str ".") in let errn n = - user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n + user_err ~loc (str "Expects a disjunctive pattern with " ++ int n ++ str " branches.") in let err1' p1 p2 = - user_err_loc (loc,"",strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in + user_err ~loc (strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in let errforthcoming loc = - user_err_loc (loc,"",strbrk "Unexpected non atomic pattern.") in + user_err ~loc (strbrk "Unexpected non atomic pattern.") in match names with | IntroAndPattern l -> if not (Int.equal n 1) then errn n; @@ -312,7 +312,7 @@ module New = struct tclZERO (Refiner.FailError (lvl,lazy msg)) let tclZEROMSG ?loc msg = - let err = UserError ("", msg) in + let err = UserError (None, msg) in let info = match loc with | None -> Exninfo.null | Some loc -> Loc.add_loc Exninfo.null loc @@ -509,7 +509,7 @@ module New = struct | [] -> () | (evk,evi) :: _ -> let (loc,_) = evi.Evd.evar_source in - Pretype_errors.error_unsolvable_implicit loc env sigma evk None + Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None let tclWITHHOLES accept_unresolved_holes tac sigma = tclEVARMAP >>= fun sigma_initial -> @@ -644,7 +644,7 @@ module New = struct | Var id -> string_of_id id | _ -> "\b" in - errorlabstrm "Tacticals.general_elim_then_using" + user_err ~hdr:"Tacticals.general_elim_then_using" (str "The elimination combinator " ++ str name_elim ++ str " is unknown.") in let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b54624f89..85b6e8de9 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -185,7 +185,7 @@ let introduction ?(check=true) id = let store = Proofview.Goal.extra gl in let env = Proofview.Goal.env gl in let () = if check && mem_named_context id hyps then - errorlabstrm "Tactics.introduction" + user_err ~hdr:"Tactics.introduction" (str "Variable " ++ pr_id id ++ str " is already declared.") in let open Context.Named.Declaration in @@ -258,7 +258,7 @@ let clear_dependency_msg env sigma id = function Printer.pr_existential env sigma ev ++ str"." let error_clear_dependency env sigma id err = - errorlabstrm "" (clear_dependency_msg env sigma id err) + user_err (clear_dependency_msg env sigma id err) let replacing_dependency_msg env sigma id = function | Evarutil.OccurHypInSimpleClause None -> @@ -272,7 +272,7 @@ let replacing_dependency_msg env sigma id = function Printer.pr_existential env sigma ev ++ str"." let error_replacing_dependency env sigma id err = - errorlabstrm "" (replacing_dependency_msg env sigma id err) + user_err (replacing_dependency_msg env sigma id err) (* This tactic enables the user to remove hypotheses from the signature. * Some care is taken to prevent him from removing variables that are @@ -352,7 +352,7 @@ let rename_hyp repl = let () = try let elt = Id.Set.choose (Id.Set.inter dst mods) in - CErrors.errorlabstrm "" (pr_id elt ++ str " is already used") + CErrors.user_err (pr_id elt ++ str " is already used") with Not_found -> () in (** All is well *) @@ -425,7 +425,7 @@ let find_name mayrepl decl naming gl = match naming with let ids_of_hyps = Tacmach.New.pf_ids_of_hyps gl in let id' = next_ident_away id ids_of_hyps in if not mayrepl && not (Id.equal id' id) then - user_err_loc (loc,"",pr_id id ++ str" is already used."); + user_err ~loc (pr_id id ++ str" is already used."); id (**************************************************************) @@ -510,7 +510,7 @@ let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> if not (eq_mind sp sp') then error "Fixpoints should be on the same mutual inductive declaration."; if mem_named_context f (named_context_of_val sign) then - errorlabstrm "Logic.prim_refiner" + user_err ~hdr:"Logic.prim_refiner" (str "Name " ++ pr_id f ++ str " already used in the environment"); mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in @@ -601,7 +601,7 @@ let pf_reduce_decl redfun where decl gl = match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str " has no value."); + user_err (pr_id id ++ str " has no value."); LocalAssum (id,redfun' ty) | LocalDef (id,b,ty) -> let b' = if where != InHypTypeOnly then redfun' b else b in @@ -702,7 +702,7 @@ let pf_e_reduce_decl redfun where decl gl = match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str " has no value."); + user_err (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = redfun sigma ty in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> @@ -742,7 +742,7 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigm match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str " has no value."); + user_err (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> @@ -780,12 +780,12 @@ let check_types env sigma mayneedglobalcheck deep newc origc = isSort (whd_all env sigma t2) then (mayneedglobalcheck := true; sigma) else - errorlabstrm "convert-check-hyp" (str "Types are incompatible.") + user_err ~hdr:"convert-check-hyp" (str "Types are incompatible.") else sigma end else if not (isSort (whd_all env sigma t1)) then - errorlabstrm "convert-check-hyp" (str "Not a type.") + user_err ~hdr:"convert-check-hyp" (str "Not a type.") else sigma (* Now we introduce different instances of the previous tacticals *) @@ -794,7 +794,7 @@ let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun en let sigma = Sigma.to_evar_map sigma in let sigma = check_types env sigma mayneedglobalcheck deep t' c in let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in - if not b then errorlabstrm "convert-check-hyp" (str "Not convertible."); + if not b then user_err ~hdr:"convert-check-hyp" (str "Not convertible."); Sigma.Unsafe.of_pair (t', sigma) end } @@ -888,7 +888,7 @@ let reduce redexp cl = let unfold_constr = function | ConstRef sp -> unfold_in_concl [AllOccurrences,EvalConstRef sp] | VarRef id -> unfold_in_concl [AllOccurrences,EvalVarRef id] - | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.") + | _ -> user_err ~hdr:"unfold_constr" (str "Cannot unfold a non-constant.") (*******************************************) (* Introduction tactics *) @@ -1081,7 +1081,7 @@ let depth_of_quantified_hypothesis red h gl = match lookup_hypothesis_as_renamed_gen red h gl with | Some depth -> depth | None -> - errorlabstrm "lookup_quantified_hypothesis" + user_err ~hdr:"lookup_quantified_hypothesis" (str "No " ++ msg_quantified_hypothesis h ++ strbrk " in current goal" ++ (if red then strbrk " even after head-reduction" else mt ()) ++ @@ -1230,7 +1230,7 @@ let cut c = let error_uninstantiated_metas t clenv = let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in let id = match na with Name id -> id | _ -> anomaly (Pp.str "unnamed dependent meta") - in errorlabstrm "" (str "Cannot find an instance for " ++ pr_id id ++ str".") + in user_err (str "Cannot find an instance for " ++ pr_id id ++ str".") let check_unresolved_evars_of_metas sigma clenv = (* This checks that Metas turned into Evars by *) @@ -1363,7 +1363,7 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags let indmv = (match kind_of_term (nth_arg i elimclause.templval.rebus) with | Meta mv -> mv - | _ -> errorlabstrm "elimination_clause" + | _ -> user_err ~hdr:"elimination_clause" (str "The type of elimination clause is not well-formed.")) in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in @@ -1528,7 +1528,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) try match List.remove Int.equal indmv (clenv_independent elimclause) with | [a] -> a | _ -> failwith "" - with Failure _ -> errorlabstrm "elimination_clause" + with Failure _ -> user_err ~hdr:"elimination_clause" (str "The type of elimination clause is not well-formed.") in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in let hyp = mkVar id in @@ -1537,7 +1537,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in if Term.eq_constr hyp_typ new_hyp_typ then - errorlabstrm "general_rewrite_in" + user_err ~hdr:"general_rewrite_in" (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id id sigma elimclause'' (fun id -> Proofview.tclUNIT ()) @@ -2017,7 +2017,7 @@ let clear_body ids = let map = function | LocalAssum (id,t) as decl -> let () = if List.mem_f Id.equal id ids then - errorlabstrm "" (str "Hypothesis " ++ pr_id id ++ str " is not a local definition") + user_err (str "Hypothesis " ++ pr_id id ++ str " is not a local definition") in decl | LocalDef (id,_,t) as decl -> @@ -2147,7 +2147,7 @@ let check_number_of_constructors expctdnumopt i nconstr = if Int.equal i 0 then error "The constructors are numbered starting from 1."; begin match expctdnumopt with | Some n when not (Int.equal n nconstr) -> - errorlabstrm "Tactics.check_number_of_constructors" + user_err ~hdr:"Tactics.check_number_of_constructors" (str "Not an inductive goal with " ++ int n ++ str (String.plural n " constructor") ++ str ".") | _ -> () end; @@ -2236,7 +2236,7 @@ let error_unexpected_extra_pattern loc bound pat = | IntroNaming (IntroIdentifier _) -> "name", (String.plural nb " introduction pattern"), "no" | _ -> "introduction pattern", "", "none" in - user_err_loc (loc,"",str "Unexpected " ++ str s1 ++ str " (" ++ + user_err ~loc (str "Unexpected " ++ str s1 ++ str " (" ++ (if Int.equal nb 0 then (str s3 ++ str s2) else (str "at most " ++ int nb ++ str s2)) ++ spc () ++ str (if Int.equal nb 1 then "was" else "were") ++ @@ -2476,8 +2476,8 @@ and prepare_intros_loc loc with_evars dft destopt = function (fun _ l -> clear_wildcards l) in fun id -> intro_pattern_action loc with_evars true true ipat [] destopt tac id) - | IntroForthcoming _ -> user_err_loc - (loc,"",str "Introduction pattern for one hypothesis expected.") + | IntroForthcoming _ -> user_err ~loc + (str "Introduction pattern for one hypothesis expected.") let intro_patterns_bound_to with_evars n destopt = intro_patterns_core with_evars true [] [] [] destopt @@ -2643,7 +2643,7 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = | IntroFresh heq_base -> fresh_id_in_env [id] heq_base env | IntroIdentifier id -> if List.mem id (ids_of_named_context (named_context env)) then - user_err_loc (loc,"",pr_id id ++ str" is already used."); + user_err ~loc (pr_id id ++ str" is already used."); id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in @@ -2725,7 +2725,7 @@ let enough_by na t tac = forward false (Some (Some tac)) (ipat_of_name na) t let generalized_name c t ids cl = function | Name id as na -> if Id.List.mem id ids then - errorlabstrm "" (pr_id id ++ str " is already used."); + user_err (pr_id id ++ str " is already used."); na | Anonymous -> match kind_of_term c with @@ -2885,7 +2885,7 @@ let specialize (c,lbind) ipat = let tstack = chk tstack in let term = applist(thd,List.map (nf_evar clause.evd) tstack) in if occur_meta term then - errorlabstrm "" (str "Cannot infer an instance for " ++ + user_err (str "Cannot infer an instance for " ++ pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ str "."); @@ -2930,7 +2930,7 @@ let unfold_body x = (** We normalize the given hypothesis immediately. *) let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in let xval = match Context.Named.lookup x hyps with - | LocalAssum _ -> errorlabstrm "unfold_body" + | LocalAssum _ -> user_err ~hdr:"unfold_body" (pr_id x ++ str" is not a defined hypothesis.") | LocalDef (_,xval,_) -> xval in @@ -3027,7 +3027,7 @@ let safe_dest_intro_patterns with_evars avoid thin dest pat tac = Proofview.tclORELSE (dest_intro_patterns with_evars avoid thin dest pat tac) begin function (e, info) -> match e with - | UserError ("move_hyp",_) -> + | UserError (Some "move_hyp",_) -> (* May happen e.g. with "destruct x using s" with an hypothesis which is morally an induction hypothesis to be "MoveLast" if known as such but which is considered instead as a subterm of @@ -3426,7 +3426,7 @@ let make_up_names n ind_opt cname = let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in - errorlabstrm "Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") + user_err ~hdr:"Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") let glob = Universes.constr_of_global @@ -4043,7 +4043,7 @@ let recolle_clenv i params args elimclause gl = (fun x -> match kind_of_term x with | Meta mv -> mv - | _ -> errorlabstrm "elimination_clause" + | _ -> user_err ~hdr:"elimination_clause" (str "The type of the elimination clause is not well-formed.")) arr in let k = match i with -1 -> Array.length lindmv - List.length args | _ -> i in @@ -4188,7 +4188,7 @@ let clear_unselected_context id inhyps cls = Proofview.Goal.nf_enter { enter = begin fun gl -> if occur_var (Tacmach.New.pf_env gl) id (Tacmach.New.pf_concl gl) && cls.concl_occs == NoOccurrences - then errorlabstrm "" + then user_err (str "Conclusion must be mentioned: it depends on " ++ pr_id id ++ str "."); match cls.onhyps with @@ -4387,7 +4387,7 @@ let induction_gen_l isrec with_evars elim names lc = let lc = List.map (function | (c,None) -> c | (c,Some(loc,eqname)) -> - user_err_loc (loc,"",str "Do not know what to do with " ++ + user_err ~loc (str "Do not know what to do with " ++ Miscprint.pr_intro_pattern_naming eqname)) lc in let rec atomize_list l = match l with diff --git a/tools/coqdep.ml b/tools/coqdep.ml index a7c32e1d6..a9f1b7376 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -526,5 +526,5 @@ let _ = try coqdep () with CErrors.UserError(s,p) -> - let pp = if s <> "_" then Pp.(str s ++ str ": " ++ p) else p in + let pp = (match s with | None -> p | Some s -> Pp.(str s ++ str ": " ++ p)) in Feedback.msg_error pp diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 81e17ffb5..5171473a1 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -341,7 +341,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = let rec find i = if Id.equal avoid.(n-i) s then avoid.(n-i-x) else (if i<n then find (i+1) - else errorlabstrm "AutoIndDecl.do_replace_lb" + else user_err ~hdr:"AutoIndDecl.do_replace_lb" (str "Var " ++ pr_id s ++ str " seems unknown.") ) in mkVar (find 1) @@ -399,7 +399,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let rec find i = if Id.equal avoid.(n-i) s then avoid.(n-i-x) else (if i<n then find (i+1) - else errorlabstrm "AutoIndDecl.do_replace_bl" + else user_err ~hdr:"AutoIndDecl.do_replace_bl" (str "Var " ++ pr_id s ++ str " seems unknown.") ) in mkVar (find 1) @@ -507,7 +507,7 @@ let eqI ind l = (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) and e, eff = try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff - with Not_found -> errorlabstrm "AutoIndDecl.eqI" + with Not_found -> user_err ~hdr:"AutoIndDecl.eqI" (str "The boolean equality on " ++ pr_mind (fst ind) ++ str " is needed."); in (if Array.equal eq_constr eA [||] then e else mkApp(e,eA)), eff @@ -634,7 +634,7 @@ let side_effect_of_mode = function let make_bl_scheme mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then - errorlabstrm "" + user_err (str "Automatic building of boolean->Leibniz lemmas not supported"); let ind = (mind,0) in let nparams = mib.mind_nparams in @@ -757,7 +757,7 @@ let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") let make_lb_scheme mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then - errorlabstrm "" + user_err (str "Automatic building of Leibniz->boolean lemmas not supported"); let ind = (mind,0) in let nparams = mib.mind_nparams in diff --git a/toplevel/class.ml b/toplevel/class.ml index 6d53ec9d8..0dc799014 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -98,7 +98,7 @@ let class_of_global = function | IndRef sp -> CL_IND sp | VarRef id -> CL_SECVAR id | ConstructRef _ as c -> - errorlabstrm "class_of_global" + user_err ~hdr:"class_of_global" (str "Constructors, such as " ++ Printer.pr_global c ++ str ", cannot be used as a class.") @@ -177,7 +177,7 @@ let ident_key_of_class = function (* Identity coercion *) let error_not_transparent source = - errorlabstrm "build_id_coercion" + user_err ~hdr:"build_id_coercion" (pr_class source ++ str " must be a transparent constant.") let build_id_coercion idf_opt source poly = @@ -208,7 +208,7 @@ let build_id_coercion idf_opt source poly = (Reductionops.is_conv_leq env sigma (Typing.unsafe_type_of env sigma val_f) typ_f) then - errorlabstrm "" (strbrk + user_err (strbrk "Cannot be defined as coercion (maybe a bad number of arguments).") in let idf = @@ -284,7 +284,7 @@ let add_new_coercion_core coef stre poly source target isid = let try_add_new_coercion_core ref ~local c d e f = try add_new_coercion_core ref (loc_of_bool local) c d e f with CoercionError e -> - errorlabstrm "try_add_new_coercion_core" + user_err ~hdr:"try_add_new_coercion_core" (explain_coercion_error ref e ++ str ".") let try_add_new_coercion ref ~local poly = diff --git a/toplevel/classes.ml b/toplevel/classes.ml index a6fb48749..ad4a13c21 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -68,8 +68,9 @@ let existing_instance glob g pri = match class_of_constr r with | Some (_, ((tc,u), _)) -> add_instance (new_instance tc pri glob (*FIXME*) (Flags.use_polymorphic_flag ()) c) - | None -> user_err_loc (loc_of_reference g, "declare_instance", - Pp.str "Constant does not build instances of a declared type class.") + | None -> user_err ~loc:(loc_of_reference g) + ~hdr:"declare_instance" + (Pp.str "Constant does not build instances of a declared type class.") 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 @@ -170,7 +171,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p Name id -> let sp = Lib.make_path id in if Nametab.exists_cci sp then - errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists."); + user_err ~hdr:"new_instance" (Nameops.pr_id id ++ Pp.str " already exists."); id | Anonymous -> let i = Nameops.add_suffix (id_of_class k) "_instance_0" in diff --git a/toplevel/command.ml b/toplevel/command.ml index bd8e870b4..caa20b534 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -59,8 +59,8 @@ let rec complete_conclusion a cs = function | CHole (loc, k, _, _) -> let (has_no_args,name,params) = a in if not has_no_args then - user_err_loc (loc,"", - strbrk"Cannot infer the non constant arguments of the conclusion of " + user_err ~loc + (strbrk"Cannot infer the non constant arguments of the conclusion of " ++ pr_id cs ++ str "."); let args = List.map (fun id -> CRef(Ident(loc,id),None)) params in CAppExpl (loc,(None,Ident(loc,name),None),List.rev args) @@ -332,7 +332,7 @@ let do_assumptions kind nl l = match l with | (Discharge, _, _) when Lib.sections_are_opened () -> let loc = fst id in let msg = Pp.str "Section variables cannot be polymorphic." in - user_err_loc (loc, "", msg) + user_err ~loc msg | _ -> () in do_assumptions_bound_univs coe kind nl id (Some pl) c @@ -344,7 +344,7 @@ let do_assumptions kind nl l = match l with let loc = fst id in let msg = Pp.str "Assumptions with bound universes can only be defined one at a time." in - user_err_loc (loc, "", msg) + user_err ~loc msg in (coe, (List.map map idl, c)) in @@ -440,7 +440,7 @@ let interp_ind_arity env evdref ind = let t, impls = understand_tcc_evars env evdref ~expected_type:IsType c, imps in let pseudo_poly = check_anonymous_type c in let () = if not (Reduction.is_arity env t) then - user_err_loc (constr_loc ind.ind_arity, "", str "Not an arity") + user_err ~loc:(constr_loc ind.ind_arity) (str "Not an arity") in t, pseudo_poly, impls @@ -555,7 +555,7 @@ let check_named (loc, na) = match na with | Name _ -> () | Anonymous -> let msg = str "Parameters must be named." in - user_err_loc (loc, "", msg) + user_err ~loc msg let check_param = function @@ -956,9 +956,9 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let relty = Typing.unsafe_type_of env !evdref rel in let relargty = let error () = - user_err_loc (constr_loc r, - "Command.build_wellfounded", - Printer.pr_constr_env env !evdref rel ++ str " is not an homogeneous binary relation.") + user_err ~loc:(constr_loc r) + ~hdr:"Command.build_wellfounded" + (Printer.pr_constr_env env !evdref rel ++ str " is not an homogeneous binary relation.") in try let ctx, ar = Reductionops.splay_prod_n env !evdref 2 relty in @@ -1314,7 +1314,7 @@ let do_program_fixpoint local poly l = match n with | Some n -> mkIdentC (snd n) | None -> - errorlabstrm "do_program_fixpoint" + user_err ~hdr:"do_program_fixpoint" (str "Recursive argument required for well-founded fixpoints") in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn @@ -1328,7 +1328,7 @@ let do_program_fixpoint local poly l = do_program_recursive local poly fixkind fixl ntns | _, _ -> - errorlabstrm "do_program_fixpoint" + user_err ~hdr:"do_program_fixpoint" (str "Well-founded fixpoints not allowed in mutually recursive blocks") let check_safe () = diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index d9cd574a0..59ee95b31 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -136,7 +136,7 @@ let get_compat_version = function | "8.3" -> Flags.V8_3 | "8.2" -> Flags.V8_2 | ("8.1" | "8.0") as s -> - CErrors.errorlabstrm "get_compat_version" + CErrors.user_err ~hdr:"get_compat_version" (str "Compatibility with version " ++ str s ++ str " not supported.") - | s -> CErrors.errorlabstrm "get_compat_version" + | s -> CErrors.user_err ~hdr:"get_compat_version" (str "Unknown compatibility version \"" ++ str s ++ str "\".") diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 6d57a21dc..85d0b6194 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -87,7 +87,7 @@ let declare_scheme_object s aux f = try let _ = Hashtbl.find scheme_object_table key in (* let aux_msg = if aux="" then "" else " (with key "^aux^")" in*) - errorlabstrm "IndTables.declare_scheme_object" + user_err ~hdr:"IndTables.declare_scheme_object" (str "Scheme object " ++ str key ++ str " already declared.") with Not_found -> Hashtbl.add scheme_object_table key (s,f); diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index f9e6c207c..e0b861e0a 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -193,7 +193,7 @@ let try_declare_scheme what f internal names kn = in match msg with | None -> () - | Some msg -> iraise (UserError ("", msg), snd e) + | Some msg -> iraise (UserError (None, msg), snd e) let beq_scheme_msg mind = let mib = Global.lookup_mind mind in diff --git a/toplevel/locality.ml b/toplevel/locality.ml index 154f787ef..03640676e 100644 --- a/toplevel/locality.ml +++ b/toplevel/locality.ml @@ -18,7 +18,7 @@ let check_locality locality_flag = match locality_flag with | Some b -> let s = if b then "Local" else "Global" in - CErrors.errorlabstrm "Locality.check_locality" + CErrors.user_err ~hdr:"Locality.check_locality" (str "This command does not support the \"" ++ str s ++ str "\" prefix.") | None -> () diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index a1edb7139..cd244bf63 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -238,7 +238,7 @@ let rec find_pattern nt xl = function | _, Break s :: _ | Break s :: _, _ -> error ("A break occurs on one side of \"..\" but not on the other side.") | _, Terminal s :: _ | Terminal s :: _, _ -> - errorlabstrm "Metasyntax.find_pattern" + user_err ~hdr:"Metasyntax.find_pattern" (str "The token \"" ++ str s ++ str "\" occurs on one side of \"..\" but not on the other side.") | _, [] -> error msg_expected_form_of_recursive_notation @@ -300,7 +300,7 @@ let rec get_notation_vars = function let vars = get_notation_vars sl in if Id.equal id ldots_var then vars else if Id.List.mem id vars then - errorlabstrm "Metasyntax.get_notation_vars" + user_err ~hdr:"Metasyntax.get_notation_vars" (str "Variable " ++ pr_id id ++ str " occurs more than once.") else id::vars @@ -314,7 +314,7 @@ let analyze_notation_tokens l = recvars, List.subtract Id.equal vars (List.map snd recvars), l let error_not_same_scope x y = - errorlabstrm "Metasyntax.error_not_name_scope" + user_err ~hdr:"Metasyntax.error_not_name_scope" (str "Variables " ++ pr_id x ++ str " and " ++ pr_id y ++ str " must be in the same scope.") (**********************************************************************) @@ -390,7 +390,7 @@ let check_open_binder isopen sl m = | _ -> assert false in if isopen && not (List.is_empty sl) then - errorlabstrm "" (str "as " ++ pr_id m ++ + user_err (str "as " ++ pr_id m ++ str " is a non-closed binder, no such \"" ++ prlist_with_sep spc pr_token sl ++ strbrk "\" is allowed to occur.") @@ -661,7 +661,7 @@ let pr_level ntn (from,args) = prlist_with_sep pr_comma (pr_arg_level from) args let error_incompatible_level ntn oldprec prec = - errorlabstrm "" + user_err (str "Notation " ++ str ntn ++ str " is already defined" ++ spc() ++ pr_level ntn oldprec ++ spc() ++ str "while it is now required to be" ++ spc() ++ @@ -731,7 +731,7 @@ let interp_modifiers modl = | SetEntryType (s,typ) :: l -> let id = Id.of_string s in if Id.List.mem_assoc id etyps then - errorlabstrm "Metasyntax.interp_modifiers" + user_err ~hdr:"Metasyntax.interp_modifiers" (str s ++ str " is already assigned to an entry or constr level."); interp assoc level ((id,typ)::etyps) format extra l | SetItemLevel ([],n) :: l -> @@ -739,7 +739,7 @@ let interp_modifiers modl = | SetItemLevel (s::idl,n) :: l -> let id = Id.of_string s in if Id.List.mem_assoc id etyps then - errorlabstrm "Metasyntax.interp_modifiers" + user_err ~hdr:"Metasyntax.interp_modifiers" (str s ++ str " is already assigned to an entry or constr level."); let typ = ETConstr (n,()) in interp assoc level ((id,typ)::etyps) format extra (SetItemLevel (idl,n)::l) @@ -770,7 +770,7 @@ let check_infix_modifiers modifiers = let check_useless_entry_types recvars mainvars etyps = let vars = let (l1,l2) = List.split recvars in l1@l2@mainvars in match List.filter (fun (x,etyp) -> not (List.mem x vars)) etyps with - | (x,_)::_ -> errorlabstrm "Metasyntax.check_useless_entry_types" + | (x,_)::_ -> user_err ~hdr:"Metasyntax.check_useless_entry_types" (pr_id x ++ str " is unbound in the notation.") | _ -> () @@ -813,7 +813,7 @@ let join_auxiliary_recursive_types recvars etyps = | None, Some ytyp -> (x,ytyp)::typs | Some xtyp, Some ytyp when Pervasives.(=) xtyp ytyp -> typs (* FIXME *) | Some xtyp, Some ytyp -> - errorlabstrm "" + user_err (strbrk "In " ++ pr_id x ++ str " .. " ++ pr_id y ++ strbrk ", both ends have incompatible types.")) recvars etyps diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml index fbd1e6033..f9e0bc34a 100644 --- a/toplevel/mltop.ml +++ b/toplevel/mltop.ml @@ -124,13 +124,13 @@ let ml_load s = | (UserError _ | Failure _ | Not_found as u) -> Exninfo.iraise (u, snd e) | exc -> let msg = report_on_load_obj_error exc in - errorlabstrm "Mltop.load_object" (str"Cannot link ml-object " ++ + user_err ~hdr:"Mltop.load_object" (str"Cannot link ml-object " ++ str s ++ str" to Coq code (" ++ msg ++ str ").")) | WithoutTop -> try Dynlink.loadfile s; s with Dynlink.Error a -> - errorlabstrm "Mltop.load_object" + user_err ~hdr:"Mltop.load_object" (strbrk "while loading " ++ str s ++ strbrk ": " ++ str (Dynlink.error_message a)) @@ -151,7 +151,7 @@ let dir_ml_use s = if Dynlink.is_native then " Loading ML code works only in bytecode." else "" in - errorlabstrm "Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo) + user_err ~hdr:"Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo) (* Adds a path to the ML paths *) let add_ml_dir s = @@ -221,7 +221,7 @@ let get_ml_object_suffix name = let file_of_name name = let suffix = get_ml_object_suffix name in let fail s = - errorlabstrm "Mltop.load_object" + user_err ~hdr:"Mltop.load_object" (str"File not found on loadpath : " ++ str s ++ str"\n" ++ str"Loadpath: " ++ str(String.concat ":" !coq_mlpath_copy)) in if not (Filename.is_relative name) then @@ -355,7 +355,7 @@ let trigger_ml_object verb cache reinit ?path name = add_loaded_module name (known_module_path name); if cache then perform_cache_obj name end else if not has_dynlink then - errorlabstrm "Mltop.trigger_ml_object" + user_err ~hdr:"Mltop.trigger_ml_object" (str "Dynamic link not supported (module " ++ str name ++ str ")") else begin let file = file_of_name (Option.default name path) in diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index b3c1623e0..aa1a489c2 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -36,7 +36,7 @@ let check_evars env evm = | Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_,_,false) -> () | _ -> - Pretype_errors.error_unsolvable_implicit loc env evm key None) + Pretype_errors.error_unsolvable_implicit ~loc env evm key None) (Evd.undefined_map evm) type oblinfo = @@ -260,7 +260,7 @@ let safe_init_constant md name () = Coqlib.gen_constant "Obligations" md name let hide_obligation = safe_init_constant tactics_module "obligation" -let pperror cmd = CErrors.errorlabstrm "Program" cmd +let pperror cmd = CErrors.user_err ~hdr:"Program" cmd let error s = pperror (str s) let reduce c = @@ -400,7 +400,7 @@ let rec prod_app t n = | Prod (_,_,b) -> subst1 n b | LetIn (_, b, t, b') -> prod_app (subst1 b b') n | _ -> - errorlabstrm "prod_app" + user_err ~hdr:"prod_app" (str"Needed a product, but didn't find one" ++ fnl ()) @@ -446,7 +446,7 @@ let from_prg : program_info ProgMap.t ref = let close sec = if not (ProgMap.is_empty !from_prg) then let keys = map_keys !from_prg in - errorlabstrm "Program" + user_err ~hdr:"Program" (str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++ prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++ (str (if Int.equal (List.length keys) 1 then " has " else " have ") ++ @@ -720,7 +720,7 @@ let get_prog name = let progs = Id.Set.elements (ProgMap.domain prg_infos) in let prog = List.hd progs in let progs = prlist_with_sep pr_comma Nameops.pr_id progs in - errorlabstrm "" + user_err (str "More than one program with unsolved obligations: " ++ progs ++ str "; use the \"of\" clause to specify, as in \"Obligation 1 of " ++ Nameops.pr_id prog ++ str "\"")) @@ -987,7 +987,7 @@ and solve_obligation_by_tac prg obls i tac = let (e, _) = CErrors.push e in match e with | Refiner.FailError (_, s) -> - user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s) + user_err ~loc:(fst obl.obl_location) ~hdr:"solve_obligation" (Lazy.force s) | e -> None (* FIXME really ? *) and solve_prg_obligations prg ?oblset tac = diff --git a/toplevel/record.ml b/toplevel/record.ml index 9d14bdf4c..de056fa9b 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -104,7 +104,7 @@ let typecheck_params_and_fields def id pl t ps nots fs = let error bk (loc, name) = match bk, name with | Default _, Anonymous -> - user_err_loc (loc, "record", str "Record parameters must be named") + user_err ~loc ~hdr:"record" (str "Record parameters must be named") | _ -> () in List.iter @@ -129,7 +129,7 @@ let typecheck_params_and_fields def id pl t ps nots fs = sred, true | None -> s, false else s, false) - | _ -> user_err_loc (constr_loc t,"", str"Sort expected.")) + | _ -> user_err ~loc:(constr_loc t) (str"Sort expected.")) | None -> let uvarkind = Evd.univ_flexible_alg in mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), true @@ -210,7 +210,7 @@ let warning_or_error coe indsp err = | _ -> (pr_id fi ++ strbrk " cannot be defined because it is not typable.") in - if coe then errorlabstrm "structure" st; + if coe then user_err ~hdr:"structure" st; Flags.if_verbose Feedback.msg_info (hov 0 st) type field_status = @@ -237,7 +237,7 @@ let subst_projection fid l c = | Projection t -> lift depth t | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k | NoProjection Anonymous -> - errorlabstrm "" (str "Field " ++ pr_id fid ++ + user_err (str "Field " ++ pr_id fid ++ str " depends on the " ++ pr_nth (k-depth-1) ++ str " field which has no name.") else @@ -541,8 +541,8 @@ let declare_existing_class g = match g with | ConstRef x -> add_constant_class x | IndRef x -> add_inductive_class x - | _ -> user_err_loc (Loc.dummy_loc, "declare_existing_class", - Pp.str"Unsupported class type, only constants and inductives are allowed") + | _ -> user_err ~hdr:"declare_existing_class" + (Pp.str"Unsupported class type, only constants and inductives are allowed") open Vernacexpr diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index de3d14483..3d573b365 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -70,7 +70,7 @@ let disable_drop = function | Drop -> CErrors.error "Drop is forbidden." | e -> e -let user_error loc s = CErrors.user_err_loc (loc,"_",str s) +let user_error loc s = CErrors.user_err ~loc ~hdr:"_" (str s) (* Opening and closing a channel. Open it twice when verbose: the first channel is used to read the commands, and the second one to print them. diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 10bbdc358..6e632999c 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -385,9 +385,9 @@ let err_unmapped_library loc ?from qid = | Some from -> str " and prefix " ++ pr_dirpath from ++ str "." in - user_err_loc - (loc,"locate_library", - strbrk "Cannot find a physical path bound to logical path matching suffix " ++ + user_err ~loc + ~hdr:"locate_library" + (strbrk "Cannot find a physical path bound to logical path matching suffix " ++ pr_dirpath dir ++ prefix) let err_notfound_library loc ?from qid = @@ -396,9 +396,8 @@ let err_notfound_library loc ?from qid = | Some from -> str " with prefix " ++ pr_dirpath from ++ str "." in - user_err_loc - (loc,"locate_library", - strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) + user_err ~loc ~hdr:"locate_library" + (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) let print_located_library r = let (loc,qid) = qualid_of_reference r in @@ -489,7 +488,7 @@ let vernac_start_proof locality p kind l lettop = | None -> ()) l; if not(refining ()) then if lettop then - errorlabstrm "Vernacentries.StartProof" + user_err ~hdr:"Vernacentries.StartProof" (str "Let declarations can only be used in proof editing mode."); start_proof_and_print (local, p, Proof kind) l no_hook @@ -610,15 +609,15 @@ let vernac_combined_scheme lid l = let vernac_universe loc poly l = if poly && not (Lib.sections_are_opened ()) then - user_err_loc (loc, "vernac_universe", - str"Polymorphic universes can only be declared inside sections, " ++ + user_err ~loc ~hdr:"vernac_universe" + (str"Polymorphic universes can only be declared inside sections, " ++ str "use Monomorphic Universe instead"); do_universe poly l let vernac_constraint loc poly l = if poly && not (Lib.sections_are_opened ()) then - user_err_loc (loc, "vernac_constraint", - str"Polymorphic universe constraints can only be declared" + user_err ~loc ~hdr:"vernac_constraint" + (str"Polymorphic universe constraints can only be declared" ++ str " inside sections, use Monomorphic Constraint instead"); do_constraint poly l @@ -860,7 +859,7 @@ let vernac_set_used_variables e = let vars = Environ.named_context env in List.iter (fun id -> if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then - errorlabstrm "vernac_set_used_variables" + user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ pr_id id)) l; let _, to_clear = set_used_variables l in @@ -979,9 +978,9 @@ let vernac_declare_arguments locality r l nargs flags = | [], Anonymous::ld, (Some _)::ls when extra_scope_flag -> check li ld ls | [], _::_, (Some _)::ls when extra_scope_flag -> error "Extra notation scopes can be set on anonymous arguments only" - | [], x::_, _ -> errorlabstrm "vernac_declare_arguments" + | [], x::_, _ -> user_err ~hdr:"vernac_declare_arguments" (str "Extra argument " ++ pr_name x ++ str ".") - | l, [], _ -> errorlabstrm "vernac_declare_arguments" + | l, [], _ -> user_err ~hdr:"vernac_declare_arguments" (str "The following arguments are not declared: " ++ prlist_with_sep pr_comma pr_name l ++ str ".") | _::li, _::ld, _::ls -> check li ld ls @@ -1024,7 +1023,7 @@ let vernac_declare_arguments locality r l nargs flags = let sr', impl = List.fold_map (fun b -> function | (Anonymous, _,_, true, max), Name id -> assert false | (Name x, _,_, true, _), Anonymous -> - errorlabstrm "vernac_declare_arguments" + user_err ~hdr:"vernac_declare_arguments" (str "Argument " ++ pr_id x ++ str " cannot be declared implicit.") | (Name iid, _,_, true, max), Name id -> set_renamed iid id; @@ -1038,7 +1037,7 @@ let vernac_declare_arguments locality r l nargs flags = some_renaming_specified l in if some_renaming_specified then if not (List.mem `Rename flags) then - errorlabstrm "vernac_declare_arguments" + user_err ~hdr:"vernac_declare_arguments" (str "To rename arguments the \"rename\" flag must be specified." ++ match !renamed_arg with | None -> mt () @@ -1082,7 +1081,7 @@ let vernac_declare_arguments locality r l nargs flags = | ConstRef _ as c -> Reductionops.ReductionBehaviour.set (make_section_locality locality) c (rargs, nargs, flags) - | _ -> errorlabstrm "" (strbrk "Modifiers of the behavior of the simpl tactic are relevant for constants only.") + | _ -> user_err (strbrk "Modifiers of the behavior of the simpl tactic are relevant for constants only.") end; if not (some_renaming_specified || some_implicits_specified || @@ -1503,7 +1502,7 @@ let print_about_hyp_globs ref_or_by_not glnumopt = | Some n,AN (Ident (_loc,id)) -> (* goal number given, catch if wong *) (try get_nth_goal n,id with - Failure _ -> errorlabstrm "print_about_hyp_globs" + Failure _ -> user_err ~hdr:"print_about_hyp_globs" (str "No such goal: " ++ int n ++ str ".")) | _ , _ -> raise NoHyp in let hyps = pf_hyps gl in @@ -1579,8 +1578,8 @@ let global_module r = let (loc,qid) = qualid_of_reference r in try Nametab.full_name_module qid with Not_found -> - user_err_loc (loc, "global_module", - str "Module/section " ++ pr_qualid qid ++ str " not found.") + user_err ~loc ~hdr:"global_module" + (str "Module/section " ++ pr_qualid qid ++ str " not found.") let interp_search_restriction = function | SearchOutside l -> (List.map global_module l, true) @@ -1602,7 +1601,7 @@ let interp_search_about_item env = (fun _ -> true) s sc in GlobSearchSubPattern (Pattern.PRef ref) with UserError _ -> - errorlabstrm "interp_search_about_item" + user_err ~hdr:"interp_search_about_item" (str "Unable to interp \"" ++ str s ++ str "\" either as a reference or as an identifier component") let vernac_search s gopt r = @@ -1882,12 +1881,12 @@ let interp ?proof ~loc locality poly c = | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n") (* The STM should handle that, but LOAD bypasses the STM... *) - | VernacAbort id -> CErrors.errorlabstrm "" (str "Abort cannot be used through the Load command") - | VernacAbortAll -> CErrors.errorlabstrm "" (str "AbortAll cannot be used through the Load command") - | VernacRestart -> CErrors.errorlabstrm "" (str "Restart cannot be used through the Load command") - | VernacUndo _ -> CErrors.errorlabstrm "" (str "Undo cannot be used through the Load command") - | VernacUndoTo _ -> CErrors.errorlabstrm "" (str "UndoTo cannot be used through the Load command") - | VernacBacktrack _ -> CErrors.errorlabstrm "" (str "Backtrack cannot be used through the Load command") + | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") + | VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command") + | VernacRestart -> CErrors.user_err (str "Restart cannot be used through the Load command") + | VernacUndo _ -> CErrors.user_err (str "Undo cannot be used through the Load command") + | VernacUndoTo _ -> CErrors.user_err (str "UndoTo cannot be used through the Load command") + | VernacBacktrack _ -> CErrors.user_err (str "Backtrack cannot be used through the Load command") (* Proof management *) | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t,None)] false @@ -2019,7 +2018,7 @@ let with_fail b f = let (e, _) = CErrors.push e in match e with | HasNotFailed -> - errorlabstrm "Fail" (str "The command has not failed!") + user_err ~hdr:"Fail" (str "The command has not failed!") | HasFailed msg -> if is_verbose () || !test_mode || !ide_slave then Feedback.msg_info (str "The command has indeed failed with message:" ++ fnl () ++ msg) diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index d81e3d6b5..f26ef460d 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -22,7 +22,7 @@ let vinterp_add depr s f = try Hashtbl.add vernac_tab s (depr, f) with Failure _ -> - errorlabstrm "vinterp_add" + user_err ~hdr:"vinterp_add" (str"Cannot add the vernac command " ++ str (fst s) ++ str" twice.") let overwriting_vinterp_add s f = @@ -37,7 +37,7 @@ let vinterp_map s = try Hashtbl.find vernac_tab s with Failure _ | Not_found -> - errorlabstrm "Vernac Interpreter" + user_err ~hdr:"Vernac Interpreter" (str"Cannot find vernac command " ++ str (fst s) ++ str".") let vinterp_init () = Hashtbl.clear vernac_tab |