Fatal error: exception End_of_file when partial-match with warn_error

[qexat]

Steps to reproduce

1. Start utop -warn-error "partial-match"
2. Enter let [] = [];;

Expected behavior

An error should be shown, derived from the partial match warning that would be produced without the warn error flag.

Actual behavior

UTop crashes with an exception End_of_file.

Full traceback

Fatal error: exception End_of_file
Raised at Stdlib__Scanf.scanf_bad_input in file "scanf.ml", line 1126, characters 9-16
Called from UTop.get_ocaml_error_message in file "src/lib/uTop.ml", lines 135-138, characters 4-56
Called from UTop.check_phrase in file "src/lib/uTop.ml", line 380, characters 31-58
Called from UTop_main.parse_and_check.(fun) in file "src/lib/uTop_main.ml", line 156, characters 23-47
Called from UTop.collect_formatters in file "src/lib/uTop.ml", line 179, characters 12-16
Re-raised at UTop.collect_formatters in file "src/lib/uTop.ml", line 184, characters 4-13
Called from UTop_main.parse_and_check in file "src/lib/uTop_main.ml", lines 148-163, characters 4-83
Called from UTop_main.read_phrase#exec in file "src/lib/uTop_main.ml", line 222, characters 23-69
Called from LTerm_read_line.term#process_keys in file "src/lTerm_read_line.ml", line 1158, characters 4-20
Called from LTerm_read_line.term#loop.(fun) in file "src/lTerm_read_line.ml", line 1189, characters 10-33
Called from Lwt.Sequential_composition.bind.create_result_promise_and_callback_if_deferred.callback in file "src/core/lwt.ml", line 1844, characters 16-19
Re-raised at Lwt.Miscellaneous.poll in file "src/core/lwt.ml", line 3123, characters 20-29
Called from Lwt_main.run.run_loop in file "src/unix/lwt_main.ml", line 27, characters 10-20
Called from Lwt_main.run in file "src/unix/lwt_main.ml", line 106, characters 8-13
Re-raised at Lwt_main.run in file "src/unix/lwt_main.ml", line 112, characters 4-13
Called from UTop_main.loop in file "src/lib/uTop_main.ml", lines 729-742, characters 4-5
Called from UTop_main.main_aux in file "src/lib/uTop_main.ml", line 1475, characters 8-17
Called from UTop_main.main_internal in file "src/lib/uTop_main.ml", line 1490, characters 4-25

Version

UTop: v2.14.0
OCaml: v5.2.0

UTop config

Note

The init.ml does not seem to be the cause of the issue. Renaming it to a different file such that UTop does not run it does not eliminate the bug.

No .ocamlinit.

~/.config/utoprc

! -*- conf-xdefaults -*-

! Copy this file to $XDG_CONFIG_HOME/utoprc (~/.config/utoprc)

! Common resources

profile:                  light
identifier.foreground:    none
module.foreground:        x-forestgreen
comment.foreground:       x-firebrick
doc.foreground:           x-violetred4
constant.foreground:      x-darkcyan
keyword.foreground:       x-purple
symbol.foreground:        x-purple
string.foreground:        x-violetred4
char.foreground:          x-violetred4
quotation.foreground:     x-purple
error.foreground:         red
directive.foreground:     x-mediumorchid4
parenthesis.background:   light-blue

! uncomment the next line to disable autoload files
! autoload: false

~/.config/utop/init.ml

#require "base"

open Base

let () = UTop.set_profile UTop.Dark

(* The actual definitions start here *)

(* Toplevel utils *)
let clear () = Stdlib.Sys.command "clear"
let fixcur () = Stdlib.Sys.command "fixcur"

(* Combinators *)
let fork (f : 'a -> 'b) (g : 'a -> 'c) (a : 'a) : 'b * 'c = f a, g a
let id (a : 'a) : 'a = a

(* Kisp-inspired functions *)
let cps (func : 'a -> 'b -> 'c) (left : 'a) (right : 'b) (next : 'c -> 'd) : 'd =
  next (func left right)
;;

let inductive
  (operation : 'a -> 'b -> 'b)
  (fixpoint : 'a -> 'b option)
  (decreasing : 'a -> 'a)
  : 'a -> 'b
  =
  fun (value : 'a) : 'b ->
  let rec func_aux (current : 'a) (get_previous : 'b -> 'b) : 'b =
    match fixpoint current with
    | Some value -> get_previous value
    | None -> func_aux (decreasing current) (fun a -> operation current (get_previous a))
  in
  func_aux value (fun a -> a)
;;

let infix (left : 'a) (op : 'a -> 'b -> 'c) (right : 'b) : 'c = op left right
let cps_add : int -> int -> (int -> 'a) -> 'a = cps ( + )
let cps_sub : int -> int -> (int -> 'a) -> 'a = cps ( - )
let cps_mul : int -> int -> (int -> 'a) -> 'a = cps ( * )
let cps_div : int -> int -> (int -> 'a) -> 'a = cps ( / )
let cps_id : 'a -> 'a = id

(* Missing built-ins *)
let compose (left : 'a -> 'b) (right : 'b -> 'c) (value : 'a) : 'c =
  value |> left |> right
;;

(* Operators *)
let ( $. ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c = compose
let ( ~$ ) : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c = Fn.flip
let ( !@ ) : 'a -> ('a -> 'b -> 'c) -> 'b -> 'c = infix
let ( !+ ) : int -> int -> (int -> 'a) -> 'a = cps_add
let ( !- ) : int -> int -> (int -> 'a) -> 'a = cps_sub
let ( !* ) : int -> int -> (int -> 'a) -> 'a = cps_mul
let ( !/ ) : int -> int -> (int -> 'a) -> 'a = cps_div
let ( !. ) : 'a -> 'a = cps_id

(* Cursed *)
external bl : int -> bool = "%identity"
external ( => ) : bool -> bool -> bool = "%lessequal"

(* Custom modules *)
module type SYNTAX_HIGHLIGHTER_MINIMAL = sig
  val render_constant_name : string -> string
  val render_identifier : string -> string
  val render_keyword : string -> string
  val render_operator : string -> string
  val render_string : string -> string
  val render_type_name : string -> string
end

module type SYNTAX_HIGHLIGHTER = sig
  include SYNTAX_HIGHLIGHTER_MINIMAL

  val render_class_name : string -> string
  val render_constant_builtin_name : string -> string
  val render_function_name : string -> string
  val render_grouper : level:int -> string -> string
  val render_module_name : string -> string
  val render_number : string -> string
  val render_parameter : string -> string
  val render_punctuation : string -> string
  val render_regular_expression : string -> string
  val render_relation : string -> string
  val render_space : string -> string
  val render_type_builtin : string -> string
  val render_type_variable : string -> string
end

module SyntaxHighlighterFactory (Minimal : SYNTAX_HIGHLIGHTER_MINIMAL) :
  SYNTAX_HIGHLIGHTER = struct
  let render_class_name = Minimal.render_type_name
  let render_constant_builtin_name = Minimal.render_constant_name
  let render_function_name = Minimal.render_identifier
  let render_grouper ~(level : int) (lexeme : string) : string = lexeme
  let render_module_name = Minimal.render_type_name
  let render_number = Minimal.render_constant_name
  let render_parameter = Minimal.render_identifier
  let render_punctuation (lexeme : string) : string = lexeme
  let render_regular_expression = Minimal.render_string
  let render_relation = Minimal.render_operator
  let render_space (lexeme : string) : string = "\x1b[2;97m" ^ lexeme ^ "\x1b[22;39m"
  let render_type_builtin = Minimal.render_type_name
  let render_type_variable = Minimal.render_identifier

  include Minimal
end