first working version

Ignore-this: 15e2821ceb34ae98bc62bf5e49d487d3

darcs-hash:20110726184310-c41ad-fa25fb6d2825eaf71e9d3151fc75031c0f59a513

_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
 
 # +-------------------------------------------------------------------+

_tags

@@ -1,7 +1,7 @@
 # -*- conf -*-
 
 <**/*.ml>: syntax_camlp4o, pkg_lwt.syntax
-<src/*>: use_compiler_libs, pkg_lambda-term
+<src/*>: use_compiler_libs, pkg_lambda-term, pkg_findlib
 
 # OASIS_START
 # OASIS_STOP

myocamlbuild.ml

@@ -50,16 +50,16 @@ let () =
 
              (* Expunge compiler modules *)
              rule "toplevel expunge"
-               ~dep:"src/utop_top.top"
+               ~dep:"%.top"
-               ~prod:"src/utop.byte"
+               ~prod:"%.byte"
-               (fun _ _ ->
+               (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(env "%.top");
-                        A"src/utop.byte";
+                        A(env "%.byte");
-                        A"Outcometree"; A"Topdirs"; A"Toploop";
+                        A"UTop"; A"Outcometree"; A"Topdirs"; A"Toploop";
                         S(List.map (fun x -> A x) (StringSet.elements modules))]))
-
          | _ ->
              ())
 

src/uTop.ml

@@ -0,0 +1,45 @@
+(*
+ * uTop.ml
+ * -------
+ * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
+ * 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"]

src/uTop.mli

@@ -0,0 +1,27 @@
+(*
+ * uTop.mli
+ * --------
+ * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
+ * 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. *)

src/uTop_console.ml

@@ -0,0 +1,166 @@
+(*
+ * uTop_console.ml
+ * ---------------
+ * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
+ * 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

src/uTop_console_top.mltop

@@ -0,0 +1,3 @@
+UTop
+UTop_private
+UTop_console

src/uTop_private.ml

@@ -0,0 +1,16 @@
+(*
+ * uTop_private.ml
+ * ---------------
+ * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
+ * 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)

src/utop_main.ml

@@ -1,10 +0,0 @@
-(*
- * utop_main.ml
- * ------------
- * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
- * Licence   : BSD3
- *
- * This file is a part of utop.
- *)
-
-

src/utop_top.mltop

@@ -1 +0,0 @@
-Utop_main