Improvements around external modules and error handling (#605)

build_system/clerk_driver.ml

@@ -607,16 +607,16 @@ let[@ocamlformat "disable"] static_base_rules =
 
 let gen_build_statements
     (include_dirs : string list)
-    (same_dir_modules : string list)
+    (same_dir_modules : (string * File.t) list)
     (item : Scan.item) : Nj.ninja =
   let open File in
   let ( ! ) = Var.( ! ) in
   let src = item.file_name in
   let modules = List.rev item.used_modules in
   let modfile ext modname =
-    if List.mem modname same_dir_modules then
-      (!Var.builddir / src /../ modname) ^ ext
-    else modname ^ ext
+    match List.assoc_opt modname same_dir_modules with
+    | Some f -> (!Var.builddir / Filename.remove_extension f) ^ ext
+    | None -> modname ^ ext
   in
   let inc x = !Var.builddir / x in
   let modd x = modfile "@module" x in
@@ -627,24 +627,15 @@ let gen_build_statements
       ~implicit_in:(List.map inc item.included_files @ List.map modd modules)
       ~outputs:[inc srcv]
   in
+  let target_file ext = (!Var.builddir / !Var.src) ^ "." ^ ext in
   let module_deps =
     Option.map
       (fun m ->
         Nj.build "phony"
-          ~inputs:
-            [
-              inc srcv;
-              (!Var.builddir / src /../ m) ^ ".cmi";
-              (!Var.builddir / src /../ m) ^ ".cmxs";
-            ]
+          ~inputs:[inc srcv; target_file "cmi"; target_file "cmxs"]
           ~outputs:[modd m])
       item.module_def
   in
-  let target_file ext =
-    match item.module_def with
-    | Some m -> (!Var.builddir / src /../ m) ^ "." ^ ext
-    | None -> (!Var.builddir / !Var.src) ^ "." ^ ext
-  in
   let ml_file = target_file "ml" in
   let py_file = target_file "py" in
   let ocaml, python =
@@ -667,15 +658,9 @@ let gen_build_statements
   in
   let ocamlopt =
     let obj =
-      let m =
-        match item.module_def with
-        | Some m -> m
-        | None -> Filename.(basename (remove_extension src))
-      in
-      let target ext = (!Var.builddir / src /../ m) ^ "." ^ ext in
       Nj.build "ocaml-object" ~inputs:[ml_file]
         ~implicit_in:(!Var.catala_exe :: List.map modd modules)
-        ~outputs:(List.map target ["mli"; "cmi"; "cmo"; "cmx"; "cmt"; "o"])
+        ~outputs:(List.map target_file ["mli"; "cmi"; "cmo"; "cmx"; "cmt"; "o"])
         ~vars:
           [
             ( Var.ocaml_flags,
@@ -715,9 +700,9 @@ let gen_build_statements
     !Var.catala_exe
     :: List.map
          (fun m ->
-           if List.mem m same_dir_modules then
-             (!Var.builddir / src /../ m) ^ ".cmxs"
-           else m ^ "@module")
+           match List.assoc_opt m same_dir_modules with
+           | Some f -> (!Var.builddir / Filename.remove_extension f) ^ ".cmxs"
+           | None -> m ^ "@module")
          modules
   in
   let interpret =
@@ -819,7 +804,10 @@ let gen_build_statements_dir
     (include_dirs : string list)
     (items : Scan.item list) : Nj.ninja =
   let same_dir_modules =
-    List.filter_map (fun item -> item.Scan.module_def) items
+    List.filter_map
+      (fun item ->
+        Option.map (fun name -> name, item.Scan.file_name) item.Scan.module_def)
+      items
   in
   Seq.flat_map
     (gen_build_statements include_dirs same_dir_modules)

compiler/driver.ml

@@ -1142,9 +1142,13 @@ let main () =
           | exception Sys_error _ ->
             Message.debug "Could not read plugin directory %s" d)
       plugins_dirs;
-    Dynlink.allow_only ["Runtime_ocaml__Runtime"];
-    (* We may use dynlink again, but only for runtime modules: no plugin
-       registration after this point *)
+    Dynlink.allow_only
+      (List.filter (( <> ) "Driver__Plugin") (Dynlink.all_units ()));
+    (* From here on, no plugin registration is allowed. However, the interpreter
+       may yet use Dynlink to load external modules. - TODO: This used to allow
+       only "Runtime_ocaml__Runtime", but forbidding external Catala modules to
+       use the OCaml Stdlib was a bit much. We should examine how to re-add some
+       more filtering here without being too restrictive. *)
     Plugin.list ()
   in
   let command = catala_t plugins in

compiler/lcalc/to_ocaml.ml

@@ -270,7 +270,7 @@ let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit =
       (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
       (Pos.get_law_info pos)
   | EmptyError -> Format.fprintf fmt "EmptyError"
-  | Crash -> Format.fprintf fmt "Crash"
+  | Crash s -> Format.fprintf fmt "(Crash %S)" s
   | NoValueProvided ->
     let pos = Mark.get exc in
     Format.fprintf fmt

compiler/scalc/to_c.ml

@@ -455,7 +455,7 @@ let rec format_statement
       | ConflictError _ -> "catala_conflict"
       | EmptyError -> "catala_empty"
       | NoValueProvided -> "catala_no_value_provided"
-      | Crash -> "catala_crash")
+      | Crash _ -> "catala_crash")
       (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
       (Pos.get_end_line pos) (Pos.get_end_column pos)
   | SIfThenElse { if_expr = cond; then_block = b1; else_block = b2 } ->

compiler/scalc/to_python.ml

@@ -259,7 +259,7 @@ let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit =
       (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
       (Pos.get_law_info pos)
   | EmptyError -> Format.fprintf fmt "EmptyError"
-  | Crash -> Format.fprintf fmt "Crash"
+  | Crash _ -> Format.fprintf fmt "Crash"
   | NoValueProvided ->
     Format.fprintf fmt
       "NoValueProvided(@[<hov 0>SourcePosition(@[<hov 0>filename=\"%s\",@ \

compiler/scalc/to_r.ml

@@ -265,7 +265,7 @@ let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit =
       (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
       (Pos.get_law_info pos)
   | EmptyError -> Format.fprintf fmt "catala_empty_error()"
-  | Crash -> Format.fprintf fmt "catala_crash()"
+  | Crash _ -> Format.fprintf fmt "catala_crash()"
   | NoValueProvided ->
     Format.fprintf fmt
       "catala_no_value_provided_error(@[<hov 0>catala_position(@[<hov \
@@ -279,7 +279,7 @@ let format_exception_name (fmt : Format.formatter) (exc : except) : unit =
   match exc with
   | ConflictError _ -> Format.fprintf fmt "catala_conflict_error"
   | EmptyError -> Format.fprintf fmt "catala_empty_error"
-  | Crash -> Format.fprintf fmt "catala_crash"
+  | Crash _ -> Format.fprintf fmt "catala_crash"
   | NoValueProvided -> Format.fprintf fmt "catala_no_value_provided_error"
 
 let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :

compiler/shared_ast/definitions.ml

@@ -382,7 +382,7 @@ type except =
   | ConflictError of Pos.t list
   | EmptyError
   | NoValueProvided
-  | Crash
+  | Crash of string
 
 (** {2 Markings} *)
 

compiler/shared_ast/interpreter.ml

@@ -129,7 +129,7 @@ let rec evaluate_operator
       | _ -> assert false
     in
     try f x y with
-    | Division_by_zero ->
+    | Runtime.Division_by_zero ->
       Message.error
         ~extra_pos:
           [
@@ -663,16 +663,21 @@ let rec evaluate_expr :
         Message.error ~pos "wrong function call, expected %d arguments, got %d"
           (Bindlib.mbinder_arity binder)
           (List.length args)
-    | ECustom { obj; targs; tret } ->
+    | ECustom { obj; targs; tret } -> (
       (* Applies the arguments one by one to the curried form *)
-      List.fold_left2
-        (fun fobj targ arg ->
-          (Obj.obj fobj : Obj.t -> Obj.t)
-            (val_to_runtime (fun ctx -> evaluate_expr ctx lang) ctx targ arg))
-        obj targs args
-      |> Obj.obj
-      |> fun o ->
-      runtime_to_val (fun ctx -> evaluate_expr ctx lang) ctx m tret o
+      match
+        List.fold_left2
+          (fun fobj targ arg ->
+            (Obj.obj fobj : Obj.t -> Obj.t)
+              (val_to_runtime (fun ctx -> evaluate_expr ctx lang) ctx targ arg))
+          obj targs args
+      with
+      | exception e ->
+        Format.ksprintf
+          (fun s -> raise (CatalaException (Crash s, pos)))
+          "@[<hv 2>This call to code from a module failed with:@ %s@]"
+          (Printexc.to_string e)
+      | o -> runtime_to_val (fun ctx -> evaluate_expr ctx lang) ctx m tret o)
     | _ ->
       Message.error ~pos "%a" Format.pp_print_text
         "function has not been reduced to a lambda at evaluation (should not \
@@ -927,9 +932,7 @@ let interp_failure_message ~pos = function
       "%a" Format.pp_print_text
       "There is a conflict between multiple valid consequences for assigning \
        the same variable."
-  | Crash ->
-    (* This constructor seems to be never used *)
-    Message.error ~pos ~internal:true "The interpreter crashed"
+  | Crash s -> Message.error ~pos "%s" s
   | EmptyError ->
     Message.error ~pos ~internal:true
       "A variable without valid definition escaped"
@@ -1087,10 +1090,7 @@ let load_runtime_modules prg =
   let load m =
     let obj_file =
       Dynlink.adapt_filename
-        File.(
-          Pos.get_file (Mark.get (ModuleName.get_info m))
-          /../ ModuleName.to_string m
-          ^ ".cmo")
+        File.(Pos.get_file (Mark.get (ModuleName.get_info m)) -.- "cmo")
     in
     if not (Sys.file_exists obj_file) then
       Message.error

compiler/shared_ast/print.ml

@@ -350,7 +350,7 @@ let except (fmt : Format.formatter) (exn : except) : unit =
     (match exn with
     | EmptyError -> "EmptyError"
     | ConflictError _ -> "ConflictError"
-    | Crash -> "Crash"
+    | Crash s -> Printf.sprintf "Crash %S" s
     | NoValueProvided -> "NoValueProvided")
 
 let var_debug fmt v =

runtimes/ocaml/runtime.ml

@@ -53,9 +53,34 @@ exception IndivisibleDurations
 exception ImpossibleDate
 exception NoValueProvided of source_position
 exception NotSameLength
+exception Division_by_zero (* Shadows the stdlib definition *)
 
-(* TODO: register exception printers for the above
-   (Printexc.register_printer) *)
+(* Register exceptions printers *)
+let () =
+  let pos () p =
+    Printf.sprintf "%s:%d.%d-%d.%d" p.filename p.start_line p.start_column
+      p.end_line p.end_column
+  in
+  let pr fmt = Printf.ksprintf (fun s -> Some s) fmt in
+  Printexc.register_printer
+  @@ function
+  | EmptyError -> pr "A variable couldn't be resolved"
+  | AssertionFailed p -> pr "At %a: Assertion failed" pos p
+  | ConflictError p -> pr "At %a: Conflicting exceptions" pos p
+  | UncomparableDurations -> pr "Ambiguous comparison between durations"
+  | IndivisibleDurations -> pr "Ambiguous division between durations"
+  | ImpossibleDate -> pr "Invalid date"
+  | NoValueProvided p ->
+    pr "At %a: No definition applied to this variable" pos p
+  | NotSameLength -> pr "Attempt to traverse lists of different lengths"
+  | Division_by_zero -> pr "Division by zero"
+  | _ -> None
+
+let () =
+  Printexc.set_uncaught_exception_handler
+  @@ fun exc bt ->
+  Printf.eprintf "[ERROR] %s\n%!" (Printexc.to_string exc);
+  if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt
 
 let round (q : Q.t) : Z.t =
   (* The mathematical formula is [round(q) = sgn(q) * floor(abs(q) + 0.5)].

runtimes/ocaml/runtime.mli

@@ -76,6 +76,7 @@ exception UncomparableDurations
 exception IndivisibleDurations
 exception ImpossibleDate
 exception NoValueProvided of source_position
+exception Division_by_zero (* Shadows the stdlib definition *)
 
 (** {1 Value Embedding} *)