Unify runtime error handling (#611)

Makefile

@@ -194,14 +194,14 @@ syntax:
 # High-level test and benchmarks commands
 ##########################################
 
-CATALA_OPTS ?=
+CATALAOPTS ?=
 CLERK_OPTS ?=
 
 CATALA_BIN=_build/default/$(COMPILER_DIR)/catala.exe
 CLERK_BIN=_build/default/$(BUILD_SYSTEM_DIR)/clerk.exe
 
 CLERK_TEST=$(CLERK_BIN) test --exe $(CATALA_BIN) \
-	$(CLERK_OPTS) $(if $(CATALA_OPTS),--catala-opts=$(CATALA_OPTS),)
+	$(CLERK_OPTS) $(if $(CATALAOPTS),--catala-opts=$(CATALAOPTS),)
 
 
 .FORCE:
@@ -234,7 +234,7 @@ testsuite: unit-tests
 
 #> reset-tests				: Update the expected test results from current run
 reset-tests: .FORCE $(CLERK_BIN)
-	$(CLERK_TEST) tests --reset
+	$(CLERK_TEST) tests doc --reset
 
 tests/%: .FORCE
 	$(CLERK_TEST) test $@

compiler/catala_utils/dune

@@ -3,7 +3,7 @@
  (public_name catala.catala_utils)
  (modules
   (:standard \ get_version))
- (libraries unix cmdliner ubase ocolor re bindlib catala.runtime_ocaml))
+ (libraries unix cmdliner ubase ocolor re))
 
 (executable
  (name get_version)

compiler/catala_utils/file.ml

@@ -180,6 +180,42 @@ let process_out ?check_exit cmd args =
     assert false
   with End_of_file -> Buffer.contents buf
 
+(* SIDE EFFECT AT MODULE LOAD: sets up a signal handler on SIGWINCH (window
+   resize) *)
+let () =
+  let default = 80 in
+  let get_terminal_cols () =
+    let count =
+      try (* terminfo *)
+          process_out "tput" ["cols"] |> int_of_string
+      with Failure _ -> (
+        try
+          (* stty *)
+          process_out "stty" ["size"]
+          |> fun s ->
+          let i = String.rindex s ' ' + 1 in
+          String.sub s (i + 1) (String.length s - i) |> int_of_string
+        with Failure _ | Not_found | Invalid_argument _ -> (
+          try int_of_string (Sys.getenv "COLUMNS")
+          with Not_found | Failure _ -> 0))
+    in
+    if count > 0 then count else default
+  in
+  let width = ref None in
+  let () =
+    try
+      Sys.set_signal 28 (* SIGWINCH *)
+        (Sys.Signal_handle (fun _ -> width := None))
+    with Invalid_argument _ -> ()
+  in
+  Message.set_terminal_width_function (fun () ->
+      match !width with
+      | Some n -> n
+      | None ->
+        let r = get_terminal_cols () in
+        width := Some r;
+        r)
+
 let check_directory d =
   try
     let d = Unix.realpath d in

compiler/catala_utils/message.ml

@@ -34,22 +34,39 @@ let unstyle_formatter ppf =
    [Format.sprintf] etc. functions (ignoring them) *)
 let () = ignore (unstyle_formatter Format.str_formatter)
 
+let terminal_columns, set_terminal_width_function =
+  let get_cols = ref (fun () -> 80) in
+  (fun () -> !get_cols ()), fun f -> get_cols := f
+
 (* Note: we could do the same for std_formatter, err_formatter... but we'd
    rather promote the use of the formatting functions of this module and the
    below std_ppf / err_ppf *)
 
-let has_color oc =
+let has_color_raw ~(tty : bool Lazy.t) =
   match Global.options.color with
   | Global.Never -> false
   | Always -> true
-  | Auto -> Unix.(isatty (descr_of_out_channel oc))
+  | Auto -> Lazy.force tty
+
+let has_color oc =
+  has_color_raw ~tty:(lazy Unix.(isatty (descr_of_out_channel oc)))
 
 (* Here we create new formatters to stderr/stdout that remain separate from the
    ones used by [Format.printf] / [Format.eprintf] (which remain unchanged) *)
 
 let formatter_of_out_channel oc =
+  let tty = lazy Unix.(isatty (descr_of_out_channel oc)) in
   let ppf = Format.formatter_of_out_channel oc in
-  if has_color oc then color_formatter ppf else unstyle_formatter ppf
+  let ppf =
+    if has_color_raw ~tty then color_formatter ppf else unstyle_formatter ppf
+  in
+  let out, flush = Format.pp_get_formatter_output_functions ppf () in
+  let flush () =
+    if Lazy.force tty then Format.pp_set_margin ppf (terminal_columns ());
+    flush ()
+  in
+  Format.pp_set_formatter_output_functions ppf out flush;
+  ppf
 
 let std_ppf = lazy (formatter_of_out_channel stdout)
 let err_ppf = lazy (formatter_of_out_channel stderr)
@@ -196,22 +213,21 @@ module Content = struct
                     content
                 | some -> some
               in
-              pos, m
-            | Position { pos_message; pos } ->
-              let message =
-                match pos_message with Some m -> m | None -> fun _ -> ()
-              in
-              Some pos, message
-            | Outcome m -> None, m
-            | Suggestion sl -> None, fun ppf -> Suggestions.format ppf sl
+              pos, Some m
+            | Position { pos_message; pos } -> Some pos, pos_message
+            | Outcome m -> None, Some m
+            | Suggestion sl -> None, Some (fun ppf -> Suggestions.format ppf sl)
           in
           Option.iter
             (fun pos ->
               Format.fprintf ppf "@{<blue>%s@}: " (Pos.to_string_short pos))
             pos;
           pp_marker target ppf;
-          Format.pp_print_char ppf ' ';
-          Format.pp_print_string ppf (unformat message))
+          match message with
+          | Some message ->
+            Format.pp_print_char ppf ' ';
+            Format.pp_print_string ppf (unformat message)
+          | None -> ())
         ppf content;
       Format.pp_print_newline ppf ()
 end

compiler/catala_utils/message.mli

@@ -71,6 +71,7 @@ val unformat : (Format.formatter -> unit) -> string
     indents *)
 
 val has_color : out_channel -> bool
+val set_terminal_width_function : (unit -> int) -> unit
 
 (* {1 More general color-enabled formatting helpers}*)
 

compiler/dcalc/from_scopelang.ml

@@ -139,7 +139,8 @@ let tag_with_log_entry
   let m = mark_tany (Mark.get e) (Expr.pos e) in
 
   if Global.options.trace then
-    Expr.eappop ~op:(Log (l, markings)) ~tys:[TAny, Expr.pos e] ~args:[e] m
+    let pos = Expr.pos e in
+    Expr.eappop ~op:(Log (l, markings), pos) ~tys:[TAny, pos] ~args:[e] m
   else e
 
 (* In a list of exceptions, it is normally an error if more than a single one
@@ -264,7 +265,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
               ( var_ctx.scope_input_name,
                 Expr.make_abs
                   [| Var.make "_" |]
-                  (Expr.eemptyerror (Expr.with_ty m ty0))
+                  (Expr.eempty (Expr.with_ty m ty0))
                   [TAny, iopos]
                   pos )
           | Some var_ctx, Some e ->
@@ -565,12 +566,12 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
       let v, _ = TopdefName.Map.find (Mark.remove name) ctx.toplevel_vars in
       Expr.evar v m
     else Expr.eexternal ~name:(Mark.map (fun n -> External_value n) name) m
-  | EAppOp { op = Add_dat_dur _; args; tys } ->
+  | EAppOp { op = Add_dat_dur _, opos; args; tys } ->
     let args = List.map (translate_expr ctx) args in
-    Expr.eappop ~op:(Add_dat_dur ctx.date_rounding) ~args ~tys m
+    Expr.eappop ~op:(Add_dat_dur ctx.date_rounding, opos) ~args ~tys m
   | ( EVar _ | EAbs _ | ELit _ | EStruct _ | EStructAccess _ | ETuple _
-    | ETupleAccess _ | EInj _ | EEmptyError | EErrorOnEmpty _ | EArray _
-    | EIfThenElse _ | EAppOp _ ) as e ->
+    | ETupleAccess _ | EInj _ | EFatalError _ | EEmpty | EErrorOnEmpty _
+    | EArray _ | EIfThenElse _ | EAppOp _ ) as e ->
     Expr.map ~f:(translate_expr ctx) ~op:Operator.translate (e, m)
 
 (** The result of a rule translation is a list of assignments, with variables

compiler/desugared/ast.ml

@@ -187,7 +187,7 @@ let empty_rule
     (parameters : (Uid.MarkedString.info * typ) list Mark.pos option) : rule =
   {
     rule_just = Expr.box (ELit (LBool false), Untyped { pos });
-    rule_cons = Expr.box (EEmptyError, Untyped { pos });
+    rule_cons = Expr.box (EEmpty, Untyped { pos });
     rule_parameter =
       Option.map
         (Mark.map (List.map (fun (lbl, typ) -> Mark.map Var.make lbl, typ)))