Move Code_error to Stdune.Exn

This exception is useful outside of jbuilder

src/action.ml

@@ -852,7 +852,7 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
     (match Path.kind path with
      | External _ ->
        (* Internally we make sure never to do that, and [Unexpanded.*expand] check that *)
-       Sexp.code_error
+       Exn.code_error
          "(mkdir ...) is not supported for paths outside of the workspace"
          [ "mkdir", Path.sexp_of_t path ]
      | Local path ->

src/build_interpret.ml

@@ -208,7 +208,7 @@ module Rule = struct
           if Path.parent path <> dir then
             match loc with
             | None ->
-              Sexp.code_error "rule has targets in different directories"
+              Exn.code_error "rule has targets in different directories"
                 [ "targets", Sexp.To_sexp.list Path.sexp_of_t
                                (List.map targets ~f:Target.path)
                 ]

src/build_system.ml

@@ -1448,7 +1448,7 @@ let get_collector t ~dir =
     collector
   | Failed_to_load -> raise Already_reported
   | Loaded _ | Forward _ ->
-    Sexp.code_error
+    Exn.code_error
       (if Path.is_in_source_tree dir then
          "Build_system.get_collector called on source directory"
        else if dir = Path.build_dir then
@@ -1477,7 +1477,7 @@ let prefix_rules t prefix ~f =
   begin match Build_interpret.targets prefix with
   | [] -> ()
   | targets ->
-    Sexp.code_error "Build_system.prefix_rules' prefix contains targets"
+    Exn.code_error "Build_system.prefix_rules' prefix contains targets"
       ["targets", Path.Set.sexp_of_t (Build_interpret.Target.paths targets)]
   end;
   let prefix =

src/env.ml

@@ -41,7 +41,7 @@ let of_unix arr =
   |> List.map ~f:(fun s ->
     match String.lsplit2 s ~on:'=' with
     | None ->
-      Sexp.code_error "Env.of_unix: entry without '=' found in the environ"
+      Exn.code_error "Env.of_unix: entry without '=' found in the environ"
         ["var", Sexp.To_sexp.string s]
     | Some (k, v) -> (k, v))
   |> Map.of_list_multi

src/errors.ml

@@ -1,5 +1,4 @@
 exception Fatal_error of string
-exception Code_error of string
 exception Already_reported
 
 let err_buf = Buffer.create 128
@@ -14,7 +13,7 @@ let kerrf fmt ~f =
     err_ppf fmt
 
 let code_errorf fmt =
-  kerrf fmt ~f:(fun s -> raise (Code_error s))
+  kerrf fmt ~f:(fun s -> Stdune.Exn.code_error s [])
 
 let die fmt =
   kerrf fmt ~f:(fun s -> raise (Fatal_error s))

src/errors.mli

@@ -12,11 +12,6 @@
 (** A fatal error, that should be reported to the user in a nice way *)
 exception Fatal_error of string
 
-(* CR-soon diml: replace the [string] argument by [Usexp.t] *)
-(** An programming error in the code of jbuilder, that should be reported upstream. The
-    error message shouldn't try to be developper friendly rather than user friendly.  *)
-exception Code_error of string
-
 (* CR-soon diml: we won't need this once we can generate rules dynamically *)
 (** Raised for errors that have already been reported to the user and shouldn't be
     reported again. This might happen when trying to build a dependency that has already

src/jbuild.ml

@@ -596,7 +596,7 @@ module Sub_system_info = struct
     let () =
       match Sub_system_name.Table.get all name with
       | Some _ ->
-        Sexp.code_error "Sub_system_info.register: already registered"
+        Exn.code_error "Sub_system_info.register: already registered"
           [ "name", Sexp.To_sexp.string (Sub_system_name.to_string name) ];
       | None ->
         Sub_system_name.Table.set all ~key:name ~data:(Some (module M : S));

src/lib.ml

@@ -600,7 +600,7 @@ let already_in_table (info : Info.t) name x =
       List [Sexp.unsafe_atom_of_string "Hidden";
             Path.sexp_of_t path; Sexp.atom reason]
   in
-  Sexp.code_error
+  Exn.code_error
     "Lib_db.DB: resolver returned name that's already in the table"
     [ "name"            , Sexp.atom name
     ; "returned_lib"    , to_sexp (info.src_dir, name)
@@ -1061,7 +1061,7 @@ module DB = struct
   let get_compile_info t ?(allow_overlaps=false) name =
     match find_even_when_hidden t name with
     | None ->
-      Sexp.code_error "Lib.DB.get_compile_info got library that doesn't exist"
+      Exn.code_error "Lib.DB.get_compile_info got library that doesn't exist"
         [ "name", Sexp.To_sexp.string name ]
     | Some lib ->
       let t = Option.some_if (not allow_overlaps) t in

src/ocamldep.ml

@@ -13,7 +13,7 @@ module Dep_graph = struct
     match Module.Name.Map.find t.per_module m.name with
     | Some x -> x
     | None ->
-      Sexp.code_error "Ocamldep.Dep_graph.deps_of"
+      Exn.code_error "Ocamldep.Dep_graph.deps_of"
         [ "dir", Path.sexp_of_t t.dir
         ; "modules", Sexp.To_sexp.(list Module.Name.t)
                        (Module.Name.Map.keys t.per_module)

src/ordered_set_lang.ml

@@ -235,7 +235,7 @@ module Unexpanded = struct
           match String.Map.find files_contents fn with
           | Some x -> x
           | None ->
-            Sexp.code_error
+            Exn.code_error
               "Ordered_set_lang.Unexpanded.expand"
               [ "included-file", Quoted_string fn
               ; "files", Sexp.To_sexp.(list string)

src/path.ml

@@ -290,7 +290,7 @@ let reach t ~from =
   match is_local t, is_local from with
   | false, _ -> t
   | true, false ->
-    Sexp.code_error "Path.reach called with invalid combination"
+    Exn.code_error "Path.reach called with invalid combination"
       [ "t"   , sexp_of_t t
       ; "from", sexp_of_t from
       ]
@@ -300,7 +300,7 @@ let reach_for_running t ~from =
   match is_local t, is_local from with
   | false, _ -> t
   | true, false ->
-    Sexp.code_error "Path.reach_for_running called with invalid combination"
+    Exn.code_error "Path.reach_for_running called with invalid combination"
       [ "t"   , sexp_of_t t
       ; "from", sexp_of_t from
       ]
@@ -325,7 +325,7 @@ let is_descendant t ~of_ =
 
 let append a b =
   if not (is_local b) then
-    Sexp.code_error "Path.append called with non-local second path"
+    Exn.code_error "Path.append called with non-local second path"
       [ "a", sexp_of_t a
       ; "b", sexp_of_t b
       ];
@@ -391,7 +391,7 @@ let drop_build_context t =
 
 let drop_build_context_exn t =
   match extract_build_context t with
-  | None -> Sexp.code_error "Path.drop_build_context_exn" [ "t", sexp_of_t t ]
+  | None -> Exn.code_error "Path.drop_build_context_exn" [ "t", sexp_of_t t ]
   | Some (_, t) -> t
 
 let drop_optional_build_context t =
@@ -424,7 +424,7 @@ let explode_exn t =
   else if is_local t then
     String.split t ~on:'/'
   else
-    Sexp.code_error "Path.explode_exn"
+    Exn.code_error "Path.explode_exn"
       ["path", Sexp.atom_or_quoted_string t]
 
 let exists t = Sys.file_exists (to_string t)
@@ -456,7 +456,7 @@ let extend_basename t ~suffix = t ^ suffix
 
 let insert_after_build_dir_exn =
   let error a b =
-    Sexp.code_error
+    Exn.code_error
       "Path.insert_after_build_dir_exn"
       [ "path"  , Sexp.unsafe_atom_of_string a
       ; "insert", Sexp.unsafe_atom_of_string b

src/report_error.ml

@@ -49,14 +49,14 @@ let report_with_backtrace exn =
           else
             Format.fprintf ppf "%s\n" (String.capitalize msg)
       }
-    | Code_error msg ->
+    | Stdune.Exn.Code_error sexp ->
       { p with
         backtrace = true
       ; pp = fun ppf ->
           Format.fprintf ppf "@{<error>Internal error, please report upstream \
                               including the contents of _build/log.@}\n\
-                              Description: %s\n"
-            msg
+                              Description: %a\n"
+            Usexp.pp sexp
       }
     | Unix.Unix_error (err, func, fname) ->
       { p with pp = fun ppf ->

src/scope.ml

@@ -27,7 +27,7 @@ module DB = struct
       | Some scope -> scope
       | None ->
         if Path.is_root d || not (Path.is_local d) then
-          Sexp.code_error "Scope.DB.find_by_dir got an invalid path"
+          Exn.code_error "Scope.DB.find_by_dir got an invalid path"
             [ "dir"    , Path.sexp_of_t dir
             ; "context", Sexp.To_sexp.string t.context
             ];
@@ -41,7 +41,7 @@ module DB = struct
     match Scope_name_map.find t.by_name name with
     | Some x -> x
     | None ->
-      Sexp.code_error "Scope.DB.find_by_name"
+      Exn.code_error "Scope.DB.find_by_name"
         [ "name"   , Sexp.To_sexp.(option string) name
         ; "context", Sexp.To_sexp.string t.context
         ; "names",
@@ -60,7 +60,7 @@ module DB = struct
           Sexp.To_sexp.(pair (option string) Path.sexp_of_t)
             (scope.name, scope.root)
         in
-        Sexp.code_error "Scope.DB.create got two scopes with the same name"
+        Exn.code_error "Scope.DB.create got two scopes with the same name"
           [ "scope1", to_sexp scope1
           ; "scope2", to_sexp scope2
           ]

src/sexp.ml

@@ -3,12 +3,6 @@ open Import
 include (Usexp : module type of struct include Usexp end
          with module Loc := Usexp.Loc)
 
-let code_error message vars =
-  code_errorf "%a" pp
-    (List (Usexp.atom_or_quoted_string message
-           :: List.map vars ~f:(fun (name, value) ->
-             List [Usexp.atom_or_quoted_string name; value])))
-
 let buf_len = 65_536
 
 let load ~fname ~mode =

src/sexp.mli

@@ -2,8 +2,6 @@ open Import
 
 include module type of struct include Usexp end with module Loc := Usexp.Loc
 
-val code_error : string -> (string * t) list -> _
-
 val load : fname:string -> mode:'a Parser.Mode.t -> 'a
 val load_many_as_one : fname:string -> Ast.t
 

src/stdune/exn.ml

@@ -1,5 +1,7 @@
 type t = exn
 
+exception Code_error of Usexp.t
+
 external raise         : exn -> _ = "%raise"
 external raise_notrace : exn -> _ = "%raise_notrace"
 external reraise       : exn -> _ = "%reraise"
@@ -11,6 +13,13 @@ let protectx x ~f ~finally =
 
 let protect ~f ~finally = protectx () ~f ~finally
 
+let code_error message vars =
+  Code_error
+    (Usexp.List (Usexp.atom_or_quoted_string message
+                 :: List.map vars ~f:(fun (name, value) ->
+                   Usexp.List [Usexp.atom_or_quoted_string name; value])))
+  |> raise
+
 include
   ((struct
     [@@@warning "-32-3"]

src/stdune/exn.mli

@@ -1,5 +1,11 @@
 (** Exceptions *)
 
+(** An programming error, that should be reported upstream. The error message
+    shouldn't try to be developer friendly rather than user friendly. *)
+exception Code_error of Usexp.t
+
+val code_error : string -> (string * Usexp.t) list -> _
+
 type t = exn
 
 external raise         : exn -> _ = "%raise"

src/stdune/jbuild

@@ -2,4 +2,4 @@
  ((name stdune)
   (public_name jbuilder.stdune)
   (synopsis "[Internal] Standard library of Dune")
-  (libraries (caml unix))))
+  (libraries (caml unix usexp))))

src/syntax.ml

@@ -26,14 +26,14 @@ module Versioned_parser = struct
 
   let make l =
     if List.is_empty l then
-      Sexp.code_error "Syntax.Versioned_parser.make got empty list" [];
+      Exn.code_error "Syntax.Versioned_parser.make got empty list" [];
     match
       List.map l ~f:(fun ((major, minor), p) -> (major, (minor, p)))
       |> Int_map.of_list
     with
     | Ok x -> x
     | Error _ ->
-      Sexp.code_error
+      Exn.code_error
         "Syntax.Versioned_parser.make"
         [ "versions", Sexp.To_sexp.list Version.sexp_of_t (List.map l ~f:fst) ]