CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Specialise the Map.Not_found exception raised by Map.find

Browse Source 
... 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:
Louis Gesbert 2023-08-15 16:57:52 +02:00
parent 9bac045d03
commit bcde10242f
13 changed files with 61 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
compiler/catala_utils/map.ml
View File

@ -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

8
compiler/dcalc/from_scopelang.ml
View File

@ -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. *)

32
compiler/desugared/from_surface.ml
View File

@ -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))

10
compiler/desugared/name_resolution.ml
View File

@ -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;

6
compiler/plugins/explain.ml
View File

@ -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

2
compiler/plugins/lazy_interp.ml
View File

@ -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

4
compiler/scalc/from_lcalc.ml
View File

@ -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

2
compiler/scopelang/from_desugared.ml
View File

@ -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 \

4
compiler/shared_ast/expr.ml
View File

@ -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

2
compiler/shared_ast/interpreter.ml
View File

@ -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

14
compiler/shared_ast/typing.ml
View File

@ -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))

6
compiler/shared_ast/var.ml
View File

@ -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

3
compiler/shared_ast/var.mli
View File

@ -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