Merge pull request #452 from rgrinberg/findlib-exn

Avoid catching wildcard exceptions when calling Findlib.find

src/findlib.ml

@@ -248,6 +248,21 @@ module Pkg_step1 = struct
     }
 end
 
+module External_dep_conflicts_with_local_lib = struct
+  type t =
+    { package             : string
+    ; required_by         : string
+    ; required_locally_in : Path.t
+    ; defined_locally_in  : Path.t
+    }
+end
+
+type error =
+  | Package_not_available of Package_not_available.t
+  | External_dep_conflicts_with_local_lib of External_dep_conflicts_with_local_lib.t
+
+exception Findlib of error
+
 let parse_package t ~name ~parent_dir ~vars ~required_by =
   let pkg_dir = Vars.get vars "directory" [] in
   let dir =
@@ -478,18 +493,16 @@ let load_meta t ~fq_name ~required_by =
       Hashtbl.add t.packages ~key:pkg.package.name ~data:status
     )
 
-exception Package_not_available of Package_not_available.t
-
 let find_exn t ~required_by name =
   match Hashtbl.find t.packages name with
   | Some (Present x) -> x
-  | Some (Not_available na) -> raise (Package_not_available na)
+  | Some (Not_available na) -> raise (Findlib (Package_not_available na))
   | None ->
     load_meta t ~fq_name:name ~required_by;
     match Hashtbl.find t.packages name with
     | Some (Present x) -> x
     | Some (Not_available pnf) ->
-      raise (Package_not_available pnf)
+      raise (Findlib (Package_not_available pnf))
     | None ->
       let na : Package_not_available.t =
         { package = name
@@ -498,40 +511,29 @@ let find_exn t ~required_by name =
         }
       in
       Hashtbl.add t.packages ~key:name ~data:(Not_available na);
-      raise (Package_not_available na)
+      raise (Findlib (Package_not_available na))
 
 let find t ~required_by name =
   match find_exn t ~required_by name with
-  | exception (Package_not_available _) -> None
+  | exception (Findlib (Package_not_available _)) -> None
   | x -> Some x
 
 let available t ~required_by name =
   match find_exn t name ~required_by with
   | (_ : package) -> true
-  | exception (Package_not_available _) -> false
-
-module External_dep_conflicts_with_local_lib = struct
-  type t =
-    { package             : string
-    ; required_by         : string
-    ; required_locally_in : Path.t
-    ; defined_locally_in  : Path.t
-    }
-end
-
-exception External_dep_conflicts_with_local_lib of External_dep_conflicts_with_local_lib.t
+  | exception (Findlib (Package_not_available _)) -> false
 
 let check_deps_consistency ~required_by ~local_public_libs pkg requires =
   List.iter requires ~f:(fun pkg' ->
     match String_map.find pkg'.name local_public_libs with
     | None -> ()
     | Some path ->
-      raise (External_dep_conflicts_with_local_lib
-               { package             = pkg'.name
-               ; required_by         = pkg.name
-               ; required_locally_in = required_by
-               ; defined_locally_in  = path
-               }))
+      raise (Findlib (External_dep_conflicts_with_local_lib
+                        { package             = pkg'.name
+                        ; required_by         = pkg.name
+                        ; required_locally_in = required_by
+                        ; defined_locally_in  = path
+                        })))
 
 let closure ~required_by ~local_public_libs pkgs =
   remove_dups_preserve_order

src/findlib.mli

@@ -22,8 +22,6 @@ module Package_not_available : sig
   val explain : Format.formatter -> reason -> unit
 end
 
-exception Package_not_available of Package_not_available.t
-
 module External_dep_conflicts_with_local_lib : sig
   type t =
     { package             : string
@@ -33,7 +31,11 @@ module External_dep_conflicts_with_local_lib : sig
     }
 end
 
-exception External_dep_conflicts_with_local_lib of External_dep_conflicts_with_local_lib.t
+type error =
+  | Package_not_available of Package_not_available.t
+  | External_dep_conflicts_with_local_lib of External_dep_conflicts_with_local_lib.t
+
+exception Findlib of error
 
 (** Findlib database *)
 type t

src/lib_db.ml

@@ -45,7 +45,7 @@ let find_exn t ~from name =
 
 let find t ~from name =
   match find_exn t ~from name with
-  | exception _ -> None
+  | exception (Findlib.Findlib _) -> None
   | x -> Some x
 
 let find_internal t ~from name =
@@ -165,7 +165,7 @@ let interpret_lib_dep t ~dir lib_dep =
             List.map (String_set.elements required) ~f:(find_exn t ~from:dir)
           with
           | l           -> Some l
-          | exception _ -> None)
+          | exception (Findlib.Findlib _) -> None)
     with
     | Some l -> Inl l
     | None ->

src/main.ml

@@ -113,7 +113,7 @@ let report_error ?(map_fname=fun x->x) ppf exn ~backtrace =
   | Fatal_error msg ->
     Format.fprintf ppf "%s\n" (String.capitalize_ascii msg);
     false
-  | Findlib.Package_not_available { package; required_by; reason } ->
+  | Findlib.Findlib (Findlib.Package_not_available { package; required_by; reason }) ->
     Format.fprintf ppf
       "@{<error>Error@}: External library %S %s.\n" package
       (match reason with
@@ -142,8 +142,8 @@ let report_error ?(map_fname=fun x->x) ppf exn ~backtrace =
       (List.map !Clflags.external_lib_deps_hint ~f:quote_for_shell
        |> String.concat ~sep:" ");
     false
-  | Findlib.External_dep_conflicts_with_local_lib
-      { package; required_by; required_locally_in; defined_locally_in } ->
+  | Findlib.Findlib (Findlib.External_dep_conflicts_with_local_lib {
+    package; required_by; required_locally_in; defined_locally_in }) ->
     Format.fprintf ppf
       "@{<error>Error@}: Conflict between internal and external version of library %S:\n\
        - it is defined locally in %s\n\