mirror of
https://github.com/CatalaLang/catala.git
synced 2024-11-08 07:51:43 +03:00
Specialise the Map.Not_found exception raised by Map.find
... and add a custom printer Since this is a very common bug, this patch should gain us a lot of time when debugging uncaught Not_found errors, because the element not found can now be printed straight away without the need for further debugging. The small cost is that one should remember to catch the correct specialised `Foo.Map.Not_found _` exception rather than the standard `Not_found` (which would type-check but not catch the exception). Using `find_opt` should be preferred anyway. Note that the other functions from the module `Map` that raise `Not_found` are not affected ; these functions are `choose`, `min/max_binding`, `find_first/last` which either take a predicate or fail on the empty map, so it wouldn't make sense for them (and we probably don't use them much).
This commit is contained in:
parent
9bac045d03
commit
bcde10242f
@ -29,6 +29,11 @@ end
|
||||
module type S = sig
|
||||
include Stdlib.Map.S
|
||||
|
||||
exception Not_found of key
|
||||
(* Slightly more informative [Not_found] exception *)
|
||||
|
||||
val find: key -> 'a t -> 'a
|
||||
|
||||
val keys : 'a t -> key list
|
||||
val values : 'a t -> 'a list
|
||||
val of_list : (key * 'a) list -> 'a t
|
||||
@ -65,11 +70,23 @@ module type S = sig
|
||||
unit
|
||||
(** Formats all bindings of the map in order using the given separator
|
||||
(default ["; "]) and binding indicator (default [" = "]). *)
|
||||
|
||||
end
|
||||
|
||||
module Make (Ord : OrderedType) : S with type key = Ord.t = struct
|
||||
include Stdlib.Map.Make (Ord)
|
||||
|
||||
exception Not_found of key
|
||||
|
||||
let () =
|
||||
Printexc.register_printer @@ function
|
||||
| Not_found k ->
|
||||
Some (Format.asprintf "key '%a' not found in map" Ord.format k)
|
||||
| _ -> None
|
||||
|
||||
let find k t =
|
||||
try find k t with Stdlib.Not_found -> raise (Not_found k)
|
||||
|
||||
let keys t = fold (fun k _ acc -> k :: acc) t [] |> List.rev
|
||||
let values t = fold (fun _ v acc -> v :: acc) t [] |> List.rev
|
||||
let of_list l = List.fold_left (fun m (k, v) -> add k v m) empty l
|
||||
|
@ -219,7 +219,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
|
||||
(fun constructor _ (d_cases, e_cases) ->
|
||||
let case_e =
|
||||
try EnumConstructor.Map.find constructor e_cases
|
||||
with Not_found ->
|
||||
with EnumConstructor.Map.Not_found _ ->
|
||||
Message.raise_spanned_error (Expr.pos e)
|
||||
"The constructor %a of enum %a%a is missing from this pattern \
|
||||
matching"
|
||||
@ -551,7 +551,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
|
||||
(SubScopeName.Map.find (Mark.remove s) ctx.subscope_vars)
|
||||
in
|
||||
Expr.evar v m
|
||||
with Not_found ->
|
||||
with ScopeVar.Map.Not_found _ | SubScopeName.Map.Not_found _ ->
|
||||
Message.raise_multispanned_error
|
||||
[
|
||||
Some "Incriminated variable usage:", Expr.pos e;
|
||||
@ -735,7 +735,7 @@ let translate_rule
|
||||
let called_scope_return_struct = subscope_sig.scope_sig_output_struct in
|
||||
let subscope_vars_defined =
|
||||
try SubScopeName.Map.find subindex ctx.subscope_vars
|
||||
with Not_found -> ScopeVar.Map.empty
|
||||
with SubScopeName.Map.Not_found _ -> ScopeVar.Map.empty
|
||||
in
|
||||
let subscope_var_not_yet_defined subvar =
|
||||
not (ScopeVar.Map.mem subvar subscope_vars_defined)
|
||||
@ -1091,7 +1091,7 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
|
||||
let scope_info =
|
||||
try
|
||||
ScopeName.Map.find scope_name (Program.module_ctx decl_ctx scope_path).ctx_scopes
|
||||
with Not_found -> Message.raise_spanned_error (Mark.get (ScopeName.get_info scope_name)) "Could not find scope %a%a" Print.path scope_path ScopeName.format scope_name
|
||||
with ScopeName.Map.Not_found _ -> Message.raise_spanned_error (Mark.get (ScopeName.get_info scope_name)) "Could not find scope %a%a" Print.path scope_path ScopeName.format scope_name
|
||||
in
|
||||
let scope_sig_in_fields =
|
||||
(* Output fields have already been generated and added to the program ctx at this point, because they are visible to the user (manipulated as the return type of ScopeCalls) ; but input fields are used purely internally and need to be created here to implement the call convention for scopes. *)
|
||||
|
@ -147,7 +147,7 @@ let rec disambiguate_constructor
|
||||
in
|
||||
let possible_c_uids =
|
||||
try Ident.Map.find (Mark.remove constructor) ctxt.constructor_idmap
|
||||
with Not_found -> raise_error_cons_not_found ctxt constructor
|
||||
with Ident.Map.Not_found _ -> raise_error_cons_not_found ctxt constructor
|
||||
in
|
||||
match path with
|
||||
| [] ->
|
||||
@ -160,18 +160,14 @@ let rec disambiguate_constructor
|
||||
possible_c_uids;
|
||||
EnumName.Map.choose possible_c_uids
|
||||
| [enum] -> (
|
||||
try
|
||||
(* The path is fully qualified *)
|
||||
let e_uid = Name_resolution.get_enum ctxt enum in
|
||||
try
|
||||
let c_uid = EnumName.Map.find e_uid possible_c_uids in
|
||||
e_uid, c_uid
|
||||
with Not_found ->
|
||||
with EnumName.Map.Not_found _ ->
|
||||
Message.raise_spanned_error pos "Enum %s does not contain case %s"
|
||||
(Mark.remove enum) (Mark.remove constructor)
|
||||
with Not_found ->
|
||||
Message.raise_spanned_error (Mark.get enum)
|
||||
"Enum %s has not been defined before" (Mark.remove enum))
|
||||
(Mark.remove enum) (Mark.remove constructor))
|
||||
| (modname, mpos)::path ->
|
||||
match ModuleName.Map.find_opt modname ctxt.modules with
|
||||
| None ->
|
||||
@ -413,11 +409,8 @@ let rec translate_expr
|
||||
let e = rec_helper e in
|
||||
let rec get_str ctxt = function
|
||||
| [] -> None
|
||||
| [c] -> (
|
||||
try Some (Name_resolution.get_struct ctxt c)
|
||||
with Not_found ->
|
||||
Message.raise_spanned_error (Mark.get c)
|
||||
"Structure %s was not declared" (Mark.remove c))
|
||||
| [c] ->
|
||||
Some (Name_resolution.get_struct ctxt c)
|
||||
| (modname, mpos) :: path ->
|
||||
match ModuleName.Map.find_opt modname ctxt.modules with
|
||||
| None ->
|
||||
@ -496,7 +489,7 @@ let rec translate_expr
|
||||
try
|
||||
StructName.Map.find s_uid
|
||||
(Ident.Map.find (Mark.remove f_name) ctxt.field_idmap)
|
||||
with Not_found ->
|
||||
with StructName.Map.Not_found _ | Ident.Map.Not_found _ ->
|
||||
Message.raise_spanned_error (Mark.get f_name)
|
||||
"This identifier should refer to a field of struct %s"
|
||||
(Mark.remove s_name)
|
||||
@ -526,11 +519,10 @@ let rec translate_expr
|
||||
| EnumInject (((path, (constructor, pos_constructor)), _), payload) -> (
|
||||
let get_possible_c_uids ctxt =
|
||||
try Ident.Map.find constructor ctxt.Name_resolution.constructor_idmap
|
||||
with Not_found ->
|
||||
with Ident.Map.Not_found _ ->
|
||||
raise_error_cons_not_found ctxt (constructor, pos_constructor)
|
||||
in
|
||||
let mark_constructor = Untyped { pos = pos_constructor } in
|
||||
|
||||
match path with
|
||||
| [] ->
|
||||
let possible_c_uids = get_possible_c_uids ctxt in
|
||||
@ -557,7 +549,6 @@ let rec translate_expr
|
||||
| enum :: rpath -> List.rev rpath, enum
|
||||
| _ -> assert false
|
||||
in
|
||||
try
|
||||
let ctxt = Name_resolution.module_ctx ctxt path in
|
||||
let possible_c_uids = get_possible_c_uids ctxt in
|
||||
(* The path has been qualified *)
|
||||
@ -572,12 +563,9 @@ let rec translate_expr
|
||||
| Some e' -> e'
|
||||
| None -> Expr.elit LUnit mark_constructor)
|
||||
~cons:c_uid ~name:e_uid emark
|
||||
with Not_found ->
|
||||
with EnumName.Map.Not_found _ ->
|
||||
Message.raise_spanned_error pos "Enum %s does not contain case %s"
|
||||
(Mark.remove enum) constructor
|
||||
with Not_found ->
|
||||
Message.raise_spanned_error (Mark.get enum)
|
||||
"Enum %s has not been defined" (Mark.remove enum)))
|
||||
(Mark.remove enum) constructor))
|
||||
| MatchWith (e1, (cases, _cases_pos)) ->
|
||||
let e1 = rec_helper e1 in
|
||||
let cases_d, e_uid =
|
||||
@ -1082,7 +1070,7 @@ let process_def
|
||||
Ident.Map.find (Mark.remove label_str) scope_def_ctxt.label_idmap
|
||||
in
|
||||
ExceptionToLabel (label_id, Mark.get label_str)
|
||||
with Not_found ->
|
||||
with Ident.Map.Not_found _ ->
|
||||
Message.raise_spanned_error (Mark.get label_str)
|
||||
"Unknown label for the scope variable %a: \"%s\""
|
||||
Ast.ScopeDef.format def_key (Mark.remove label_str))
|
||||
|
@ -199,7 +199,7 @@ let get_enum ctxt id =
|
||||
Some "Scope defined at", Mark.get (ScopeName.get_info sid);
|
||||
]
|
||||
"Expecting an enum, but found a scope"
|
||||
| exception Not_found ->
|
||||
| exception Ident.Map.Not_found _ ->
|
||||
Message.raise_spanned_error (Mark.get id) "No enum named %s found"
|
||||
(Mark.remove id)
|
||||
|
||||
@ -213,7 +213,7 @@ let get_struct ctxt id =
|
||||
Some "Enum defined at", Mark.get (EnumName.get_info eid);
|
||||
]
|
||||
"Expecting a struct, but found an enum"
|
||||
| exception Not_found ->
|
||||
| exception Ident.Map.Not_found _ ->
|
||||
Message.raise_spanned_error (Mark.get id) "No struct named %s found"
|
||||
(Mark.remove id)
|
||||
|
||||
@ -234,7 +234,7 @@ let get_scope ctxt id =
|
||||
Some "Structure defined at", Mark.get (StructName.get_info sid);
|
||||
]
|
||||
"Expecting an scope, but found a structure"
|
||||
| exception Not_found ->
|
||||
| exception Ident.Map.Not_found _ ->
|
||||
Message.raise_spanned_error (Mark.get id) "No scope named %s found"
|
||||
(Mark.remove id)
|
||||
|
||||
@ -581,7 +581,7 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) :
|
||||
StructName.Map.find str (Ident.Map.find id ctxt.field_idmap)
|
||||
in
|
||||
ScopeVar.Map.add v field svmap
|
||||
with Not_found -> svmap))
|
||||
with StructName.Map.Not_found _ | Ident.Map.Not_found _ -> svmap))
|
||||
sco.var_idmap ScopeVar.Map.empty
|
||||
in
|
||||
let typedefs =
|
||||
@ -738,7 +738,7 @@ let get_def_key
|
||||
try
|
||||
Some
|
||||
(Ident.Map.find (Mark.remove state) var_sig.var_sig_states_idmap)
|
||||
with Not_found ->
|
||||
with Ident.Map.Not_found _ ->
|
||||
Message.raise_multispanned_error
|
||||
[
|
||||
None, Mark.get state;
|
||||
|
@ -179,7 +179,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
|
||||
(?) *)
|
||||
let env_elt =
|
||||
try Env.find v env
|
||||
with Not_found ->
|
||||
with Var.Map.Not_found _ ->
|
||||
error e0 "Variable %a undefined [@[<hv>%a@]]" Print.var_debug v
|
||||
Env.print env
|
||||
in
|
||||
@ -689,7 +689,7 @@ let program_to_graph
|
||||
(G.add_vertex g v, var_vertices, env0), v
|
||||
| EVar var, _ -> (
|
||||
try (g, var_vertices, env0), Var.Map.find var var_vertices
|
||||
with Not_found -> (
|
||||
with Var.Map.Not_found _ -> (
|
||||
try
|
||||
let child, env = (Env.find var env0).base in
|
||||
let m = Mark.get child in
|
||||
@ -714,7 +714,7 @@ let program_to_graph
|
||||
else Var.Map.add var v var_vertices
|
||||
in
|
||||
(G.add_edge g v child_v, var_vertices, env), v
|
||||
with Not_found ->
|
||||
with Var.Map.Not_found _ ->
|
||||
Message.emit_warning "VAR NOT FOUND: %a" Print.var var;
|
||||
let v = G.V.create e in
|
||||
let g = G.add_vertex g v in
|
||||
|
@ -75,7 +75,7 @@ let rec lazy_eval :
|
||||
(?) *)
|
||||
let v_env =
|
||||
try Env.find v env
|
||||
with Not_found ->
|
||||
with Var.Map.Not_found _ ->
|
||||
error e0 "Variable %a undefined [@[<hv>%a@]]" Print.var_debug v
|
||||
Env.print env
|
||||
in
|
||||
|
@ -35,9 +35,9 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
|
||||
| EVar v ->
|
||||
let local_var =
|
||||
try A.EVar (Var.Map.find v ctxt.var_dict)
|
||||
with Not_found -> (
|
||||
with Var.Map.Not_found _ -> (
|
||||
try A.EFunc (Var.Map.find v ctxt.func_dict)
|
||||
with Not_found ->
|
||||
with Var.Map.Not_found _ ->
|
||||
Message.raise_spanned_error (Expr.pos expr)
|
||||
"Var not found in lambda→scalc: %a@\nknown: @[<hov>%a@]@\n"
|
||||
Print.var_debug v
|
||||
|
@ -107,7 +107,7 @@ let rec translate_expr (ctx : ctx) (e : D.expr) :
|
||||
try
|
||||
StructName.Map.find name
|
||||
(Ident.Map.find field ctx.decl_ctx.ctx_struct_fields)
|
||||
with Not_found ->
|
||||
with StructName.Map.Not_found _ | Ident.Map.Not_found _ ->
|
||||
(* Should not happen after disambiguation *)
|
||||
Message.raise_spanned_error (Expr.mark_pos m)
|
||||
"Field @{<yellow>\"%s\"@} does not belong to structure \
|
||||
|
@ -806,7 +806,7 @@ module DefaultBindlibCtxRename = struct
|
||||
|
||||
let get_suffix : string -> int -> ctxt -> int * ctxt =
|
||||
fun name suffix ctxt ->
|
||||
let n = try String.Map.find name ctxt with Not_found -> -1 in
|
||||
let n = try String.Map.find name ctxt with String.Map.Not_found _ -> -1 in
|
||||
let suffix = if suffix > n then suffix else n + 1 in
|
||||
suffix, String.Map.add name suffix ctxt
|
||||
|
||||
@ -826,7 +826,7 @@ module DefaultBindlibCtxRename = struct
|
||||
try
|
||||
let n = String.Map.find prefix ctxt in
|
||||
if suffix <= n then ctxt else String.Map.add prefix suffix ctxt
|
||||
with Not_found -> String.Map.add prefix suffix ctxt
|
||||
with String.Map.Not_found _ -> String.Map.add prefix suffix ctxt
|
||||
end
|
||||
|
||||
let rename_vars
|
||||
|
@ -561,7 +561,7 @@ let rec evaluate_expr :
|
||||
TArrow ([TStruct scope_info.in_struct_name, pos],
|
||||
(TStruct scope_info.out_struct_name, pos)),
|
||||
pos
|
||||
with Not_found ->
|
||||
with TopdefName.Map.Not_found _ | ScopeName.Map.Not_found _ ->
|
||||
Message.raise_spanned_error pos "Reference to %a%a could not be resolved"
|
||||
Print.path path Print.external_ref name
|
||||
in
|
||||
|
@ -517,14 +517,14 @@ and typecheck_expr_top_down :
|
||||
let fld_ty =
|
||||
let str =
|
||||
try A.StructName.Map.find name env.structs
|
||||
with Not_found ->
|
||||
with A.StructName.Map.Not_found _ ->
|
||||
Message.raise_spanned_error pos_e "No structure %a found"
|
||||
A.StructName.format name
|
||||
in
|
||||
let field =
|
||||
let candidate_structs =
|
||||
try A.Ident.Map.find field ctx.ctx_struct_fields
|
||||
with Not_found ->
|
||||
with A.Ident.Map.Not_found _ ->
|
||||
Message.raise_spanned_error
|
||||
(Expr.mark_pos context_mark)
|
||||
"Field @{<yellow>\"%s\"@} does not belong to structure \
|
||||
@ -532,7 +532,7 @@ and typecheck_expr_top_down :
|
||||
field A.StructName.format name
|
||||
in
|
||||
try A.StructName.Map.find name candidate_structs
|
||||
with Not_found ->
|
||||
with A.StructName.Map.Not_found _ ->
|
||||
Message.raise_spanned_error
|
||||
(Expr.mark_pos context_mark)
|
||||
"@[<hov>Field @{<yellow>\"%s\"@}@ does not belong to@ structure \
|
||||
@ -553,12 +553,12 @@ and typecheck_expr_top_down :
|
||||
let fld_ty =
|
||||
let str =
|
||||
try A.StructName.Map.find name env.structs
|
||||
with Not_found ->
|
||||
with A.StructName.Map.Not_found _ ->
|
||||
Message.raise_spanned_error pos_e "No structure %a found"
|
||||
A.StructName.format name
|
||||
in
|
||||
try A.StructField.Map.find field str
|
||||
with Not_found ->
|
||||
with A.StructField.Map.Not_found _ ->
|
||||
Message.raise_multispanned_error
|
||||
[
|
||||
None, pos_e;
|
||||
@ -697,14 +697,14 @@ and typecheck_expr_top_down :
|
||||
| A.External_value name ->
|
||||
(try
|
||||
ast_to_typ (A.TopdefName.Map.find name ctx.ctx_topdefs)
|
||||
with Not_found -> not_found A.TopdefName.format name)
|
||||
with A.TopdefName.Map.Not_found _ -> not_found A.TopdefName.format name)
|
||||
| A.External_scope name ->
|
||||
(try
|
||||
let scope_info = A.ScopeName.Map.find name ctx.ctx_scopes in
|
||||
ast_to_typ (TArrow ([TStruct scope_info.in_struct_name, pos_e],
|
||||
(TStruct scope_info.out_struct_name, pos_e)),
|
||||
pos_e)
|
||||
with Not_found -> not_found A.ScopeName.format name)
|
||||
with A.ScopeName.Map.Not_found _ -> not_found A.ScopeName.format name)
|
||||
in
|
||||
Expr.eexternal ~path ~name (mark_with_tau_and_unify ty)
|
||||
| A.ELit lit -> Expr.elit lit (ty_mark (lit_type lit))
|
||||
|
@ -88,7 +88,11 @@ end
|
||||
maps) *)
|
||||
module Map = struct
|
||||
open Generic
|
||||
open Map.Make (Generic)
|
||||
module M = Map.Make (Generic)
|
||||
open M
|
||||
|
||||
type k0 = M.key
|
||||
exception Not_found = M.Not_found
|
||||
|
||||
type nonrec ('e, 'x) t = 'x t
|
||||
|
||||
|
@ -58,6 +58,9 @@ end
|
||||
module Map : sig
|
||||
type ('e, 'x) t
|
||||
|
||||
type k0
|
||||
exception Not_found of k0
|
||||
|
||||
val empty : ('e, 'x) t
|
||||
val singleton : 'e var -> 'x -> ('e, 'x) t
|
||||
val add : 'e var -> 'x -> ('e, 'x) t -> ('e, 'x) t
|
||||
|
Loading…
Reference in New Issue
Block a user