diff --git a/src/lib/uTop.cppo.ml b/src/lib/uTop.cppo.ml index 2096943..02cc6c8 100644 --- a/src/lib/uTop.cppo.ml +++ b/src/lib/uTop.cppo.ml @@ -80,6 +80,8 @@ let topfind_verbose, get_topfind_verbose, set_topfind_verbose = make_variable fa let end_and_accept_current_phrase : LTerm_read_line.action = Edit (Custom (fun () -> assert false)) +let set_margin_function f = UTop_private.set_margin_function f + (* +-----------------------------------------------------------------+ | Keywords | +-----------------------------------------------------------------+ *) @@ -104,7 +106,7 @@ let add_keyword kwd = keywords := String_set.add kwd !keywords let get_message func x = let buffer = Buffer.create 1024 in let pp = Format.formatter_of_buffer buffer in - Format.pp_set_margin pp (S.value size).cols; + UTop_private.set_margin pp; func pp x; Format.pp_print_flush pp (); Buffer.contents buffer @@ -112,7 +114,7 @@ let get_message func x = let get_ocaml_error_message exn = let buffer = Buffer.create 1024 in let pp = Format.formatter_of_buffer buffer in - Format.pp_set_margin pp (S.value size).cols; + UTop_private.set_margin pp; Errors.report_error pp exn; Format.pp_print_flush pp (); let str = Buffer.contents buffer in @@ -143,10 +145,9 @@ let collect_formatters buf pps f = and out_spaces n = for i = 1 to n do Buffer.add_char buf ' ' done in let out_functions = { Format.out_string; out_flush; out_newline; out_spaces } in (* Replace formatter functions. *) - let cols = (S.value size).cols in List.iter (fun pp -> - Format.pp_set_margin pp cols; + UTop_private.set_margin pp; Format.pp_set_formatter_out_functions pp out_functions) pps; try diff --git a/src/lib/uTop.mli b/src/lib/uTop.mli index 987fc93..b7ecfcb 100644 --- a/src/lib/uTop.mli +++ b/src/lib/uTop.mli @@ -73,6 +73,16 @@ val get_show_box : unit -> bool val set_show_box : bool -> unit (** Modifies {!show_box}. *) +val set_margin_function : (LTerm_geom.size -> int option) -> unit + (** Margin of the standard and error formatters as a function of the screen size. + + The default is: + + {[ + fun size -> Some (max 80 size.cols) + ]} + *) + (** Syntax. *) type syntax = | Normal diff --git a/src/lib/uTop_main.cppo.ml b/src/lib/uTop_main.cppo.ml index 5bdb138..af93a77 100644 --- a/src/lib/uTop_main.cppo.ml +++ b/src/lib/uTop_main.cppo.ml @@ -585,10 +585,6 @@ let rec read_phrase term = read_phrase term | exn -> Lwt.fail exn) -let update_margin pp cols = - if Format.pp_get_margin pp () <> cols then - Format.pp_set_margin pp cols - let print_error term msg = LTerm.set_style term styles.style_error >>= fun () -> Lwt_io.print msg >>= fun () -> @@ -628,13 +624,12 @@ let rec loop term = (* Rewrite toplevel expressions. *) let phrase = rewrite phrase in (* Set the margin of standard formatters. *) - let cols = (LTerm.size term).cols in - update_margin Format.std_formatter cols; - update_margin Format.err_formatter cols; + UTop_private.set_margin Format.std_formatter; + UTop_private.set_margin Format.err_formatter; (* Formatter to get the output phrase. *) let buffer = Buffer.create 1024 in let pp = Format.formatter_of_buffer buffer in - Format.pp_set_margin pp (LTerm.size term).cols; + UTop_private.set_margin pp; (try Env.reset_cache_toplevel (); if !Clflags.dump_parsetree then Printast.top_phrase pp phrase; diff --git a/src/lib/uTop_private.ml b/src/lib/uTop_private.ml index 8756833..ba64c57 100644 --- a/src/lib/uTop_private.ml +++ b/src/lib/uTop_private.ml @@ -29,3 +29,13 @@ let error_style = ref LTerm_style.none (* Config from ~/.utoprc *) let autoload = ref true + +let margin_function, set_margin_function = + S.create ~eq:( == ) (fun (size : LTerm_geom.size) -> Some (min 80 size.cols)) + +let margin = S.app margin_function size + +let set_margin pp = + match S.value margin with + | None -> () + | Some n -> if Format.pp_get_margin pp () <> n then Format.pp_set_margin pp n