Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
- index 4472155..c217cf9 100644
- --- a/toplevel/genprintval.ml
- +++ b/toplevel/genprintval.ml
- @@ -45,7 +45,7 @@ module type S =
- val remove_printer : Path.t -> unit
- val outval_of_untyped_exception : t -> Outcometree.out_value
- val outval_of_value :
- - int -> int ->
- + int option -> int option ->
- (int -> t -> Types.type_expr -> Outcometree.out_value option) ->
- Env.t -> t -> type_expr -> Outcometree.out_value
- end
- @@ -166,13 +166,16 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
- (* The main printing function *)
- + let unopt default = function None -> default | Some x -> x
- +
- let outval_of_value max_steps max_depth check_depth env obj ty =
- - let printer_steps = ref max_steps in
- + let printer_steps = ref (unopt 0 max_steps) in
- let rec tree_of_val depth obj ty =
- decr printer_steps;
- - if !printer_steps < 0 || depth < 0 then Oval_ellipsis
- + if (max_steps <> None && !printer_steps < 0) ||
- + (max_depth <> None && depth < 0) then Oval_ellipsis
- else begin
- try
- find_printer env ty obj
- @@ -193,7 +196,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
- Some x -> x
- | None ->
- let rec tree_of_conses tree_list obj =
- - if !printer_steps < 0 || depth < 0 then
- + if (max_steps <> None && !printer_steps < 0) ||
- + (max_depth <> None && depth < 0) then
- Oval_ellipsis :: tree_list
- else if O.is_block obj then
- let tree =
- @@ -213,7 +217,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
- Some x -> x
- | None ->
- let rec tree_of_items tree_list i =
- - if !printer_steps < 0 || depth < 0 then
- + if (max_steps <> None && !printer_steps < 0) ||
- + (max_depth <> None && depth < 0) then
- Oval_ellipsis :: tree_list
- else if i < length then
- let tree =
- @@ -370,6 +375,6 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
- Some x -> x
- | None -> outval_of_untyped_exception bucket
- - in tree_of_val max_depth obj ty
- + in tree_of_val (unopt 0 max_depth) obj ty
- end
- diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli
- index 8ddf079..d6b6948 100644
- --- a/toplevel/genprintval.mli
- +++ b/toplevel/genprintval.mli
- @@ -41,7 +41,7 @@ module type S =
- val remove_printer : Path.t -> unit
- val outval_of_untyped_exception : t -> Outcometree.out_value
- val outval_of_value :
- - int -> int ->
- + int option -> int option ->
- (int -> t -> Types.type_expr -> Outcometree.out_value option) ->
- Env.t -> t -> type_expr -> Outcometree.out_value
- end
- diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml
- index 9741d17..4879fa1 100644
- --- a/toplevel/opttopdirs.ml
- +++ b/toplevel/opttopdirs.ml
- @@ -170,6 +170,14 @@ let _ =
- (Directive_int(fun n -> max_printer_depth := n));
- Hashtbl.add directive_table "print_length"
- (Directive_int(fun n -> max_printer_steps := n));
- + Hashtbl.add directive_table "print_all"
- + (Directive_none(fun () -> print_kind := `All));
- + Hashtbl.add directive_table "print_wide"
- + (Directive_none(fun () -> print_kind := `Wide));
- + Hashtbl.add directive_table "print_deep"
- + (Directive_none(fun () -> print_kind := `Deep));
- + Hashtbl.add directive_table "print_default"
- + (Directive_none(fun () -> print_kind := `Default));
- (* Set various compiler flags *)
- diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
- index a679f8c..7a99c16 100644
- --- a/toplevel/topdirs.ml
- +++ b/toplevel/topdirs.ml
- @@ -321,6 +321,14 @@ let _ =
- (Directive_int(fun n -> max_printer_depth := n));
- Hashtbl.add directive_table "print_length"
- (Directive_int(fun n -> max_printer_steps := n));
- + Hashtbl.add directive_table "print_all"
- + (Directive_none(fun () -> print_kind := `All));
- + Hashtbl.add directive_table "print_wide"
- + (Directive_none(fun () -> print_kind := `Wide));
- + Hashtbl.add directive_table "print_deep"
- + (Directive_none(fun () -> print_kind := `Deep));
- + Hashtbl.add directive_table "print_default"
- + (Directive_none(fun () -> print_kind := `Default));
- (* Set various compiler flags *)
- diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
- index 636fe15..1f12792 100644
- --- a/toplevel/toploop.ml
- +++ b/toplevel/toploop.ml
- @@ -74,6 +74,17 @@ module Printer = Genprintval.Make(Obj)(EvalPath)
- let max_printer_depth = ref 100
- let max_printer_steps = ref 300
- +let print_kind = ref (`Default : [`Default | `Wide | `Deep | `All ])
- +
- +let get_max_printer_depth () =
- + match !print_kind with
- + | `Default | `Wide -> Some !max_printer_depth
- + | `Deep | `All -> None
- +let get_max_printer_steps () =
- + match !print_kind with
- + | `Default | `Deep -> Some !max_printer_steps
- + | `Wide | `All -> None
- +
- let print_out_value = Oprint.out_value
- let print_out_type = Oprint.out_type
- let print_out_class_type = Oprint.out_class_type
- @@ -85,7 +96,7 @@ let print_out_phrase = Oprint.out_phrase
- let print_untyped_exception ppf obj =
- !print_out_value ppf (Printer.outval_of_untyped_exception obj)
- let outval_of_value env obj ty =
- - Printer.outval_of_value !max_printer_steps !max_printer_depth
- + Printer.outval_of_value (get_max_printer_steps ()) (get_max_printer_depth ())
- (fun _ _ _ -> None) env obj ty
- let print_value env obj ppf ty =
- !print_out_value ppf (outval_of_value env obj ty)
- diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
- index da607de..4b3acde 100644
- --- a/toplevel/toploop.mli
- +++ b/toplevel/toploop.mli
- @@ -74,6 +74,7 @@ val remove_printer : Path.t -> unit
- val max_printer_depth: int ref
- val max_printer_steps: int ref
- +val print_kind: [`Default | `Wide | `Deep | `All ] ref
- (* Hooks for external parsers and printers *)
Add Comment
Please, Sign In to add comment
