From bcde10242fb8a8f7e7011ff0e96266b46e121ff1 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Tue, 15 Aug 2023 16:57:52 +0200 Subject: [PATCH] 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). --- compiler/catala_utils/map.ml | 17 ++++++++++++++ compiler/dcalc/from_scopelang.ml | 8 +++---- compiler/desugared/from_surface.ml | 32 +++++++++------------------ compiler/desugared/name_resolution.ml | 10 ++++----- compiler/plugins/explain.ml | 6 ++--- compiler/plugins/lazy_interp.ml | 2 +- compiler/scalc/from_lcalc.ml | 4 ++-- compiler/scopelang/from_desugared.ml | 2 +- compiler/shared_ast/expr.ml | 4 ++-- compiler/shared_ast/interpreter.ml | 2 +- compiler/shared_ast/typing.ml | 14 ++++++------ compiler/shared_ast/var.ml | 6 ++++- compiler/shared_ast/var.mli | 3 +++ 13 files changed, 61 insertions(+), 49 deletions(-) diff --git a/compiler/catala_utils/map.ml b/compiler/catala_utils/map.ml index 64790791..28c088eb 100644 --- a/compiler/catala_utils/map.ml +++ b/compiler/catala_utils/map.ml @@ -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 diff --git a/compiler/dcalc/from_scopelang.ml b/compiler/dcalc/from_scopelang.ml index 1ed339b1..131af240 100644 --- a/compiler/dcalc/from_scopelang.ml +++ b/compiler/dcalc/from_scopelang.ml @@ -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. *) diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index dac41054..8dfd9011 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -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)) diff --git a/compiler/desugared/name_resolution.ml b/compiler/desugared/name_resolution.ml index 4684e853..cee3ae12 100644 --- a/compiler/desugared/name_resolution.ml +++ b/compiler/desugared/name_resolution.ml @@ -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; diff --git a/compiler/plugins/explain.ml b/compiler/plugins/explain.ml index bf40036e..6fa22cf2 100644 --- a/compiler/plugins/explain.ml +++ b/compiler/plugins/explain.ml @@ -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 [@[%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 diff --git a/compiler/plugins/lazy_interp.ml b/compiler/plugins/lazy_interp.ml index 55f8b82b..958ff8ed 100644 --- a/compiler/plugins/lazy_interp.ml +++ b/compiler/plugins/lazy_interp.ml @@ -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 [@[%a@]]" Print.var_debug v Env.print env in diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index 86f6506e..1b231006 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -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: @[%a@]@\n" Print.var_debug v diff --git a/compiler/scopelang/from_desugared.ml b/compiler/scopelang/from_desugared.ml index a8862598..1a91507d 100644 --- a/compiler/scopelang/from_desugared.ml +++ b/compiler/scopelang/from_desugared.ml @@ -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 @{\"%s\"@} does not belong to structure \ diff --git a/compiler/shared_ast/expr.ml b/compiler/shared_ast/expr.ml index 55ed0a5d..10ff445d 100644 --- a/compiler/shared_ast/expr.ml +++ b/compiler/shared_ast/expr.ml @@ -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 diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 5a9ff702..22254725 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -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 diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index b2cda58d..d83d3b1c 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -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 @{\"%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) "@[Field @{\"%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)) diff --git a/compiler/shared_ast/var.ml b/compiler/shared_ast/var.ml index ebbd04a3..d3f33e3c 100644 --- a/compiler/shared_ast/var.ml +++ b/compiler/shared_ast/var.ml @@ -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 diff --git a/compiler/shared_ast/var.mli b/compiler/shared_ast/var.mli index dbff7d86..b6257242 100644 --- a/compiler/shared_ast/var.mli +++ b/compiler/shared_ast/var.mli @@ -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