From 95a67bb1f7e55343d9c69f1071ebca07984e8d31 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Tue, 26 Jul 2011 20:43:10 +0200 Subject: [PATCH] first working version Ignore-this: 15e2821ceb34ae98bc62bf5e49d487d3 darcs-hash:20110726184310-c41ad-fa25fb6d2825eaf71e9d3151fc75031c0f59a513 --- _oasis | 2 +- _tags | 2 +- myocamlbuild.ml | 15 ++-- src/uTop.ml | 45 ++++++++++ src/uTop.mli | 27 ++++++ src/uTop_console.ml | 166 +++++++++++++++++++++++++++++++++++++ src/uTop_console_top.mltop | 3 + src/uTop_private.ml | 16 ++++ src/utop_main.ml | 10 --- src/utop_top.mltop | 1 - 10 files changed, 266 insertions(+), 21 deletions(-) create mode 100644 src/uTop.ml create mode 100644 src/uTop.mli create mode 100644 src/uTop_console.ml create mode 100644 src/uTop_console_top.mltop create mode 100644 src/uTop_private.ml delete mode 100644 src/utop_main.ml delete mode 100644 src/utop_top.mltop diff --git a/_oasis b/_oasis index 97e1d1f..2d2eb7f 100644 --- a/_oasis +++ b/_oasis @@ -22,7 +22,7 @@ Executable utop Install: true Path: src CompiledObject: byte - MainIs: utop.ml + MainIs: uTop_console_top.ml BuildDepends: findlib, lambda-term, lwt.syntax # +-------------------------------------------------------------------+ diff --git a/_tags b/_tags index 788bcad..22bb72d 100644 --- a/_tags +++ b/_tags @@ -1,7 +1,7 @@ # -*- conf -*- <**/*.ml>: syntax_camlp4o, pkg_lwt.syntax -: use_compiler_libs, pkg_lambda-term +: use_compiler_libs, pkg_lambda-term, pkg_findlib # OASIS_START # OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml index f8bea03..4cdd512 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -50,16 +50,16 @@ let () = (* Expunge compiler modules *) rule "toplevel expunge" - ~dep:"src/utop_top.top" - ~prod:"src/utop.byte" - (fun _ _ -> + ~dep:"%.top" + ~prod:"%.byte" + (fun env _ -> (* Build the list of dependencies. *) let deps = Findlib.topological_closure [Findlib.query "lambda-term"; Findlib.query "findlib"] in (* Build the set of locations of dependencies. *) let locs = List.fold_left (fun set pkg -> StringSet.add pkg.Findlib.location set) StringSet.empty deps in (* Directories to search for .cmi: *) - let directories = StringSet.add stdlib_path (StringSet.add "src" locs) in + let directories = StringSet.add stdlib_path locs in (* Construct the set of modules to keep by listing .cmi files: *) let modules = @@ -76,11 +76,10 @@ let () = directories StringSet.empty in Cmd(S[A(stdlib_path / "expunge"); - A"src/utop_top.top"; - A"src/utop.byte"; - A"Outcometree"; A"Topdirs"; A"Toploop"; + A(env "%.top"); + A(env "%.byte"); + A"UTop"; A"Outcometree"; A"Topdirs"; A"Toploop"; S(List.map (fun x -> A x) (StringSet.elements modules))])) - | _ -> ()) diff --git a/src/uTop.ml b/src/uTop.ml new file mode 100644 index 0000000..11a8ccf --- /dev/null +++ b/src/uTop.ml @@ -0,0 +1,45 @@ +(* + * uTop.ml + * ------- + * Copyright : (c) 2011, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +open CamomileLibraryDyn.Camomile +open Lwt_react +open LTerm_text +open LTerm_geom +open LTerm_style + +let size = UTop_private.size + +let count = UTop_private.count + +let make_prompt count size = + let tm = Unix.localtime (Unix.time ()) in + let txt = + eval [ + B_bold true; + B_fg lcyan; + S "─( "; + B_fg lmagenta; S(Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg; + S " )─< "; + B_fg lyellow; S(Printf.sprintf "command %d" count); E_fg; + S " >─"; + ] in + Array.append ( + if Array.length txt > size.cols then + Array.sub txt 0 size.cols + else + Array.append txt (Array.make (size.cols - Array.length txt) (UChar.of_int 0x2500, { none with foreground = Some lcyan })) + ) [|(UChar.of_char '#', { none with foreground = Some lgreen }); (UChar.of_char ' ', none)|] + +let prompt = ref (S.l2 make_prompt count size) + +let prompt_continue = ref (S.const [|(UChar.of_char '>', { none with foreground = Some lgreen }); (UChar.of_char ' ', LTerm_style.none)|]) + +let () = + (* Do not load packages linked with the toplevel. *) + Topfind.don't_load_deeply ["findlib"; "lambda-term"] diff --git a/src/uTop.mli b/src/uTop.mli new file mode 100644 index 0000000..636367b --- /dev/null +++ b/src/uTop.mli @@ -0,0 +1,27 @@ +(* + * uTop.mli + * -------- + * Copyright : (c) 2011, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +(** UTop configuration. *) + +val count : int React.signal + (** The number of commands already executed. *) + +(** {6 Console specific configuration} *) + +val size : LTerm_geom.size React.signal + (** The current size of the terminal. *) + +val prompt : LTerm_text.t React.signal ref + (** The current prompt. For compatibility with ocaml, it must ends + with a line of length 2. *) + +val prompt_continue : LTerm_text.t React.signal ref + (** The prompt used to continue unterminated commands. For + compatibility with ocaml, it must ends with a line of length + 2. *) diff --git a/src/uTop_console.ml b/src/uTop_console.ml new file mode 100644 index 0000000..9f42757 --- /dev/null +++ b/src/uTop_console.ml @@ -0,0 +1,166 @@ +(* + * uTop_console.ml + * --------------- + * Copyright : (c) 2011, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +(* Main for console mode. *) + +open Lwt +open Lwt_react +open LTerm_text +open LTerm_geom + +(* +-----------------------------------------------------------------+ + | The read-line class | + +-----------------------------------------------------------------+ *) + +class read_line ~term ~history ~prompt = object(self) + inherit LTerm_read_line.read_line ~history () + inherit [Zed_utf8.t] LTerm_read_line.term term + + initializer + (* Set the source signal for the size of the terminal. *) + UTop_private.set_size self#size; + (* Set the prompt. *) + self#set_prompt prompt +end + +(* +-----------------------------------------------------------------+ + | History | + +-----------------------------------------------------------------+ *) + +let history = ref [] + +let () = + let hist_name = Filename.concat (try Sys.getenv "HOME" with Not_found -> "") ".utop-history" in + (* Save history on exit. *) + Lwt_main.at_exit (fun () -> LTerm_read_line.save_history hist_name !history); + (* Load history. *) + history := Lwt_main.run (LTerm_read_line.load_history hist_name) + +(* +-----------------------------------------------------------------+ + | Toplevel integration | + +-----------------------------------------------------------------+ *) + +(* The text typed by the user. *) +let input = ref "" + +(* The position of the text already sent to ocaml in {!input}. *) +let pos = ref 0 + +(* The pending line to add to the history. *) +let pending = ref "" + +(* The read function given to ocaml. *) +let rec read_input term prompt buffer len = + try + if !pos = String.length !input then begin + (* We need to get more input from the user. *) + + let prompt_to_display = + if prompt = "# " then begin + (* This is a new command. *) + + (* increment the command counter. *) + UTop_private.set_count (S.value UTop_private.count + 1); + + (* Add the previous line to the history. *) + history := LTerm_read_line.add_entry !pending !history; + pending := ""; + + !UTop.prompt + end else + !UTop.prompt_continue + in + + (* Read interactively user input. *) + let txt = Lwt_main.run ( + lwt txt = (new read_line ~term ~history:!history ~prompt:prompt_to_display)#run in + lwt () = LTerm.flush term in + return txt + ) in + + pending := !pending ^ txt; + + (* Add a newline character at the end. *) + input := txt ^ "\n"; + pos := 0; + + read_input term prompt buffer len + end else begin + (* There is still some pending input. *) + let i = ref 0 in + while !i < len && !pos < String.length !input do + buffer.[!i] <- (!input).[!pos]; + incr i; + incr pos + done; + (!i, false) + end + with LTerm_read_line.Interrupt -> + (0, true) + +(* +-----------------------------------------------------------------+ + | Integration for when the input is not a terminal | + +-----------------------------------------------------------------+ *) + +let read_input_non_interactive prompt buffer len = + let rec loop i = + if i = len then + return (i, false) + else + Lwt_io.read_char_opt Lwt_io.stdin >>= function + | Some c -> + buffer.[i] <- c; + if c = '\n' then + return (i + 1, false) + else + loop (i + 1) + | None -> + return (i, true) + in + Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >> loop 0) + +lwt () = + (* If standard channels are connected to a tty, use interactive + read-line and display a welcome message: *) + if Unix.isatty Unix.stdin && Unix.isatty Unix.stdout then begin + (* Open the standard terminal. *) + lwt term = Lazy.force LTerm.stdout in + + Toploop.read_interactive_input := (read_input term); + + (* Create a context to render the welcome message. *) + lwt size = LTerm.get_size term in + let size = { rows = 3; cols = size.cols } in + let matrix = LTerm_draw.make_matrix size in + let ctx = LTerm_draw.context matrix size in + + (* Draw the message in a box. *) + + let message = "Welcome to utop!" in + + LTerm_draw.fill_style ctx LTerm_style.({ none with foreground = Some lcyan }); + + LTerm_draw.draw_hline ctx 0 0 size.cols LTerm_draw.Light; + LTerm_draw.draw_frame ctx { + row1 = 0; + row2 = 3; + col1 = (size.cols - (String.length message + 4)) / 2; + col2 = (size.cols + (String.length message + 4)) / 2; + } LTerm_draw.Light; + + LTerm_draw.draw_styled ctx 1 ((size.cols - String.length message) / 2) (eval [B_fg LTerm_style.yellow; S message]); + + (* Render to the screen. *) + lwt () = LTerm.print_box term matrix in + LTerm.flush term + end else begin + (* Otherwise fallback to classic non-interactive mode: *) + Toploop.read_interactive_input := read_input_non_interactive; + return () + end diff --git a/src/uTop_console_top.mltop b/src/uTop_console_top.mltop new file mode 100644 index 0000000..fc72883 --- /dev/null +++ b/src/uTop_console_top.mltop @@ -0,0 +1,3 @@ +UTop +UTop_private +UTop_console diff --git a/src/uTop_private.ml b/src/uTop_private.ml new file mode 100644 index 0000000..65c0b08 --- /dev/null +++ b/src/uTop_private.ml @@ -0,0 +1,16 @@ +(* + * uTop_private.ml + * --------------- + * Copyright : (c) 2011, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +open Lwt_react + +let size, set_size = + let ev, set_size = E.create () in + (S.switch (S.const { LTerm_geom.rows = 0; LTerm_geom.cols = 0 }) ev, set_size) + +let count, set_count = S.create(-1) diff --git a/src/utop_main.ml b/src/utop_main.ml deleted file mode 100644 index 705e801..0000000 --- a/src/utop_main.ml +++ /dev/null @@ -1,10 +0,0 @@ -(* - * utop_main.ml - * ------------ - * Copyright : (c) 2011, Jeremie Dimino - * Licence : BSD3 - * - * This file is a part of utop. - *) - - diff --git a/src/utop_top.mltop b/src/utop_top.mltop deleted file mode 100644 index 8d618a0..0000000 --- a/src/utop_top.mltop +++ /dev/null @@ -1 +0,0 @@ -Utop_main