From 8da31fbdceac0854cdafc5b274cd371dbe9b0d57 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Wed, 6 Feb 2013 17:22:03 -0500 Subject: [PATCH] allow to hide identifiers starting with a '_' Enabled by default. --- src/lib/uTop.ml | 1 + src/lib/uTop.mli | 20 +++++++++- src/lib/uTop_main.ml | 89 +++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 107 insertions(+), 3 deletions(-) diff --git a/src/lib/uTop.ml b/src/lib/uTop.ml index d8b9eab..0c5163f 100644 --- a/src/lib/uTop.ml +++ b/src/lib/uTop.ml @@ -64,6 +64,7 @@ type syntax = | Camlp4o | Camlp4r +let hide_reserved, get_hide_reserved, set_hide_reserved = make_variable true let syntax, get_syntax, set_syntax = make_variable Normal let phrase_terminator, get_phrase_terminator, set_phrase_terminator = make_variable ";;" let auto_run_lwt, get_auto_run_lwt, set_auto_run_lwt = make_variable true diff --git a/src/lib/uTop.mli b/src/lib/uTop.mli index 6e6cac8..1e2a93b 100644 --- a/src/lib/uTop.mli +++ b/src/lib/uTop.mli @@ -29,6 +29,24 @@ type ui = Console | Emacs val get_ui : unit -> ui (** Returns the user interface in use. *) +val hide_reserved : bool signal + (** If [true] (the default) identifiers starting with a '_' will be hidden from the + output. i.e. the following phrase won't produces any output: + + {[ + let _x = 1 + ]} + + This is for hidding variables created by code generators for internal use. It can + also be set by the command line option [-hide-reserved]. + *) + +val get_hide_reserved : unit -> bool + (** Returns the value of {!hide_reserved}. *) + +val set_hide_reserved : bool -> unit + (** Modifies {!hide_reserved}. *) + (** Syntax. *) type syntax = | Normal @@ -90,7 +108,7 @@ val set_auto_run_lwt : bool -> unit val auto_run_async : bool signal (** If [true] (the default) toplevel Async expressions are - automatically run with in a separate thread with + automatically run with in a separate thread with [Thread_safe.block_on_async_exn]. i.e. if you type: {[ diff --git a/src/lib/uTop_main.ml b/src/lib/uTop_main.ml index 3c30e1d..44483e6 100644 --- a/src/lib/uTop_main.ml +++ b/src/lib/uTop_main.ml @@ -201,7 +201,7 @@ let fix_string str = loop ofs end -let print_out_phrase term string = +let render_out_phrase term string = let string = fix_string string in let styled = LTerm_text.of_string string in let stylise loc token_style = @@ -213,6 +213,90 @@ let print_out_phrase term string = UTop_styles.stylise stylise (UTop_lexer.lex_string (UTop.get_syntax ()) string); Lwt_main.run (LTerm.fprints term styled) +let orig_print_out_signature = !Toploop.print_out_signature +let orig_print_out_phrase = !Toploop.print_out_phrase + +let rec map_items unwrap wrap items = + match items with + | [] -> + [] + | item :: items -> + let sig_item, _ = unwrap item in + let name, rec_status = + match sig_item with + | Outcometree.Osig_class (_, name, _, _, rs) + | Outcometree.Osig_class_type (_, name, _, _, rs) + | Outcometree.Osig_module (name, _, rs) + | Outcometree.Osig_type ((name, _, _, _, _), rs) -> + (name, rs) + | Outcometree.Osig_exception (name, _) + | Outcometree.Osig_modtype (name, _) + | Outcometree.Osig_value (name, _, _) -> + (name, Outcometree.Orec_not) + in + let keep = name = "" || name.[0] <> '_' in + if keep then + item :: map_items unwrap wrap items + else + (* Replace the [Orec_next] at the head of items by [Orec_first] *) + let items = + match items with + | [] -> + [] + | item :: items' -> + let sig_item, extra = unwrap item in + match sig_item with + | Outcometree.Osig_class (a, name, b, c, rs) -> + if rs = Outcometree.Orec_next then + wrap (Outcometree.Osig_class (a, name, b, c, Outcometree.Orec_first)) extra :: items' + else + items + | Outcometree.Osig_class_type (a, name, b, c, rs) -> + if rs = Outcometree.Orec_next then + wrap (Outcometree.Osig_class_type (a, name, b, c, Outcometree.Orec_first)) extra :: items' + else + items + | Outcometree.Osig_module (name, a, rs) -> + if rs = Outcometree.Orec_next then + wrap (Outcometree.Osig_module (name, a, Outcometree.Orec_first)) extra :: items' + else + items + | Outcometree.Osig_type ((name, a, b, c, d), rs) -> + if rs = Outcometree.Orec_next then + wrap (Outcometree.Osig_type ((name, a, b, c, d), Outcometree.Orec_first)) extra :: items' + else + items + | Outcometree.Osig_exception _ + | Outcometree.Osig_modtype _ + | Outcometree.Osig_value _ -> + items + in + map_items unwrap wrap items + +let print_out_signature pp items = + if UTop.get_hide_reserved () then + orig_print_out_signature pp (map_items (fun x -> (x, ())) (fun x () -> x) items) + else + orig_print_out_signature pp items + +let print_out_phrase pp phrase = + if UTop.get_hide_reserved () then + let phrase = + match phrase with + | Outcometree.Ophr_eval _ + | Outcometree.Ophr_exception _ -> + phrase + | Outcometree.Ophr_signature items -> + Outcometree.Ophr_signature (map_items (fun x -> x) (fun x y -> (x, y)) items) + in + orig_print_out_phrase pp phrase + else + orig_print_out_phrase pp phrase + +let () = + Toploop.print_out_signature := print_out_signature; + Toploop.print_out_phrase := print_out_phrase + (* +-----------------------------------------------------------------+ | Toplevel expression rewriting | +-----------------------------------------------------------------+ *) @@ -459,7 +543,7 @@ let rec loop term = match phrase with | Parsetree.Ptop_def _ -> (* The string is an output phrase, colorize it. *) - print_out_phrase term string + render_out_phrase term string | Parsetree.Ptop_dir _ -> (* The string is an error message. *) Lwt_main.run (print_error term string) @@ -862,6 +946,7 @@ let args = Arg.align [ \ Default setting is %S" Warnings.defaults_warn_error; "-warn-help", Arg.Unit Warnings.help_warnings, " Show description of warning numbers"; "-emacs", Arg.Set emacs_mode, " Run in emacs mode"; + "-hide-reserved", Arg.Bool UTop.set_hide_reserved, " Hide identifiers starting with a '_'"; ] #if ocaml_version >= (4, 01, 0)