diff --git a/_oasis b/_oasis index 164e7b9..204a2a0 100644 --- a/_oasis +++ b/_oasis @@ -14,14 +14,7 @@ BuildTools: ocamlbuild Plugins: DevFiles (0.2), META (0.2) Synopsis: utop Description: Universal toplevel for OCaml - -# +-------------------------------------------------------------------+ -# | Flags | -# +-------------------------------------------------------------------+ - -Flag gtk - Description: Build the GTK interface - Default: false +FilesAB: src/lib/uTop_version.ml.ab # +-------------------------------------------------------------------+ # | The toplevel | @@ -35,36 +28,38 @@ Library "optcomp" CompiledObject: byte Library utop - Path: src/common - Modules: UTop - InternalModules: UTop_private - BuildDepends: findlib, lambda-term (>= 1.1), lwt.syntax + Path: src/lib + Modules: + UTop, + UTop_main + InternalModules: + UTop_private, + UTop_version, + UTop_lexer, + UTop_token, + UTop_complete, + UTop_styles + BuildDepends: findlib, lambda-term (>= 1.1), lwt.syntax, threads XMETADescription: utop configuration XMETARequires: findlib, lambda-term +Library "utop-camlp4" + FindlibName: camlp4 + FindlibParent: utop + Path: src/camlp4 + InternalModules: UTop_camlp4 + BuildDepends: utop, camlp4 + XMETAType: syntax + XMETADescription: Camlp4 integration + Executable utop Install: true - Path: src/console + Path: src/top CompiledObject: byte - MainIs: uTop_console_top.ml - BuildDepends: utop, findlib, lambda-term, lwt.syntax - -Executable "utop-emacs" - Install: true - Path: src/emacs - CompiledObject: byte - MainIs: uTop_emacs_top.ml + MainIs: uTop_top.ml BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads DataFiles: utop.el ($datadir/emacs/site-lisp) -Executable "utop-gtk" - Install$: flag(gtk) - Build$: flag(gtk) - Path: src/gtk - CompiledObject: byte - MainIs: uTop_gtk_top.ml - BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads, lablgtk2, lwt.glib - # +-------------------------------------------------------------------+ # | Doc | # +-------------------------------------------------------------------+ diff --git a/_tags b/_tags index 94befe2..c3301cf 100644 --- a/_tags +++ b/_tags @@ -6,8 +6,8 @@ # Do not use optcomp on syntax extensions : -pa_optcomp -# Completion needs compiler interfaces -: use_compiler_libs +# Use compiler interfaces +: use_compiler_libs # OASIS_START # OASIS_STOP diff --git a/boring b/boring index 7185c79..8ec1466 100644 --- a/boring +++ b/boring @@ -2,3 +2,4 @@ ^utop-.*\.tar\.gz$ ^setup\.data$ ^setup\.log$ +^src/lib/uTop_version.ml$ diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 3396a71..862d9cb 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -10,9 +10,6 @@ (* OASIS_START *) (* OASIS_STOP *) -(* List of toplevels. *) -let toplevels = ["console"; "emacs"; "gtk"] - let () = dispatch (fun hook -> @@ -23,17 +20,12 @@ let () = | After_rules -> (* Copy tags from *.byte to *.top *) - List.iter - (fun name -> - let src = "src" / name / ("uTop_" ^ name ^ "_top.byte") - and dst = "src" / name / ("uTop_" ^ name ^ "_top.top") in - tag_file - dst - (List.filter - (* Remove the "file:..." tag and syntax extensions. *) - (fun tag -> not (String.is_prefix "file:" tag) && not (String.is_suffix tag ".syntax")) - (Tags.elements (tags_of_pathname src)))) - toplevels; + tag_file + "src/top/uTop_top.top" + (List.filter + (* Remove the "file:..." tag and syntax extensions. *) + (fun tag -> not (String.is_prefix "file:" tag) && not (String.is_suffix tag ".syntax")) + (Tags.elements (tags_of_pathname "src/top/uTop_top.byte"))); (* Use -linkpkg for creating toplevels *) flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg"; @@ -95,6 +87,6 @@ let () = Cmd (S [A (stdlib / "expunge"); A (env "%.top"); A (env "%.byte"); - A "UTop"; S(List.map (fun x -> A x) (StringSet.elements modules))])) + A "UTop"; A "UTop_private"; S(List.map (fun x -> A x) (StringSet.elements modules))])) | _ -> ()) diff --git a/src/camlp4/uTop_camlp4.ml b/src/camlp4/uTop_camlp4.ml new file mode 100644 index 0000000..1f32e2e --- /dev/null +++ b/src/camlp4/uTop_camlp4.ml @@ -0,0 +1,62 @@ +(* + * uTop_camlp4.ml + * -------------- + * Copyright : (c) 2012, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +open Lexing +open Camlp4 +open Camlp4.PreCast + +module Ast2pt = Camlp4.Struct.Camlp4Ast2OCamlAst.Make(Ast) + +external cast_toplevel_phrase : Camlp4_import.Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase = "%identity" + +let print_camlp4_error pp exn = + Format.fprintf pp "@[<0>%a@]" Camlp4.ErrorHandler.print exn; + Format.pp_print_flush pp () + +let parse_toplevel_phrase_camlp4 str eos_is_error = + let eof = ref false in + try + let token_stream = Gram.filter (Gram.lex_string (Loc.mk UTop.input_name) str) in + let token_stream = + Stream.from + (fun _ -> + match Stream.next token_stream with + | (EOI, _) as x -> + eof := true; + Some x + | x -> + Some x) + in + match Gram.parse_tokens_after_filter Syntax.top_phrase token_stream with + | Some str_item -> + let str_item = AstFilters.fold_topphrase_filters (fun t filter -> filter t) str_item in + UTop.Value (cast_toplevel_phrase (Ast2pt.phrase str_item)) + | None -> + raise UTop.Need_more + with exn -> + if !eof && not eos_is_error then + raise UTop.Need_more + else + let locs, exn = + match exn with + | Loc.Exc_located (loc, exn) -> + ([(Loc.start_off loc,Loc.stop_off loc)], exn) + | exn -> + ([], exn) + in + UTop.Error (locs, UTop.get_message print_camlp4_error exn) + +let () = + UTop.set_camlp4 true; + UTop.parse_toplevel_phrase := parse_toplevel_phrase_camlp4; + (* Force camlp4 to display its error message. *) + try + ignore (!Toploop.parse_toplevel_phrase (Lexing.from_string "")) + with _ -> + () diff --git a/src/common/uTop.mli b/src/common/uTop.mli deleted file mode 100644 index 657293b..0000000 --- a/src/common/uTop.mli +++ /dev/null @@ -1,99 +0,0 @@ -(* - * 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. *) - -val keywords : Set.Make(String).t ref - (** The set of OCaml keywords. *) - -val add_keyword : string -> unit - (** Add a new OCaml keyword. *) - -type ui = Console | GTK | Emacs - (** The user interface in use. *) - -val get_ui : unit -> ui - (** Returns the user interface in use. *) - -(** {6 GTK specific utilities} *) - -val exec_in_gui : (unit -> unit) -> unit - (** [exec_in_gui f] executes [f] in the thread that handle the - UI. The only use of this function is to call [window#show ()] on - Windows: - - Since windows are attached to a thread on Windows and utop - handle the UI in a separate thread, doing [window#show ()] in - the toplevel UI will not work. *) - -(** {6 Console/GTK specific configuration} *) - -type profile = Dark | Light - (** Profile for colors. *) - -val profile : profile React.signal - (** The color profile. It defaults to {!Dark}. This is used by the - default prompt to choose colors. *) - -val set_profile : profile -> unit - (** Sets the color profile. *) - -val smart_accept : bool ref - (** If [true], then only lines terminated with ";;" will be sent to - ocaml, otherwise the input will always be sent to ocaml when the - user press Enter. It default to [true]. *) - -val size : LTerm_geom.size React.signal - (** The current size of the terminal. This is used only in the - console UI. *) - -val key_sequence : LTerm_key.t list React.signal - (** The current key sequence entered by the user. This is used only - in the console UI. *) - -val time : float ref - (** The time of the beginning of the current command. *) - -val prompt : LTerm_text.t React.signal ref - (** The current prompt. - - For compatibility with ocaml error printing, it must ends with a - line of length 2 in the console UI. *) - -val prompt_continue : LTerm_text.t React.signal ref - (** The prompt used to continue unterminated phrase. - - For compatibility with ocaml error printing, it must ends with a - line of length 2 in the console UI. *) - -val prompt_comment : LTerm_text.t React.signal ref - (** The prompt used to continue unterminated comments. - - For compatibility with ocaml error printing, it must ends with a - line of length 2 in the console UI. *) - -(** {6 Hooks} *) - -val new_command_hooks : (unit -> unit) Lwt_sequence.t - (** Functions called before each new command. *) - -val at_new_command : (unit -> unit) -> unit - (** [at_new_command f] adds [f] to the hooks executed before each - new commands. *) - -val new_prompt_hooks : (unit -> unit) Lwt_sequence.t - (** Functions executed before each new prompt, including - continuation prompts. *) - -val at_new_prompt : (unit -> unit) -> unit - (** [at_new_prompt f] adds [f] to the hooks executed before each new - prompt. *) diff --git a/src/console/uTop_console.ml b/src/console/uTop_console.ml deleted file mode 100644 index e8daf76..0000000 --- a/src/console/uTop_console.ml +++ /dev/null @@ -1,276 +0,0 @@ -(* - * uTop_console.ml - * --------------- - * Copyright : (c) 2011, Jeremie Dimino - * Licence : BSD3 - * - * This file is a part of utop. - *) - -(* Main for console mode. *) - -open CamomileLibraryDyn.Camomile -open Lwt -open Lwt_react -open LTerm_text -open LTerm_geom -open UTop_token -open UTop_styles - -module String_set = Set.Make(String) - -let () = UTop_private.set_ui UTop_private.Console - -(* +-----------------------------------------------------------------+ - | History | - +-----------------------------------------------------------------+ *) - -let history = ref [] - -let init_history () = - let hist_name = Filename.concat LTerm_resources.home ".utop-history" in - (* Save history on exit. *) - Lwt_main.at_exit (fun () -> LTerm_read_line.save_history hist_name !history); - (* Load history. *) - lwt h = LTerm_read_line.load_history hist_name in - history := h; - return () - -(* +-----------------------------------------------------------------+ - | The read-line class | - +-----------------------------------------------------------------+ *) - -(* The pending line to add to the history. *) -let pending = ref None - -let lparen = UChar.of_char '(' -let rparen = UChar.of_char ')' -let lbrace = UChar.of_char '{' -let rbrace = UChar.of_char '}' -let lbracket = UChar.of_char '[' -let rbracket = UChar.of_char ']' - -let rec last = function - | [] -> None - | [x] -> Some x - | _ :: l -> last l - -class read_line ~term ~prompt = - let pending = - match !pending with - | None -> "" - | Some line -> line ^ "\n" - in - let pending_length = Zed_utf8.length pending in -object(self) - inherit LTerm_read_line.read_line ~history:!history () as super - inherit [Zed_utf8.t] LTerm_read_line.term term as super_term - - method exec = function - | LTerm_read_line.Accept :: actions when !UTop.smart_accept && S.value self#mode = LTerm_read_line.Edition -> begin - Zed_macro.add self#macro LTerm_read_line.Accept; - let tokens = UTop_lexer.lex_string (pending ^ Zed_rope.to_string (Zed_edit.text self#edit)) in - match last tokens with - | Some (Symbol, _, _, ";;") -> - return self#eval - | _ -> - self#insert (UChar.of_char '\n'); - self#exec actions - end - | actions -> - super_term#exec actions - - method stylise last = - let styled, position = super#stylise last in - - (* Syntax highlighting *) - let stylise start stop token_style = - for i = max 0 (start - pending_length) to stop - pending_length - 1 do - let ch, style = styled.(i) in - styled.(i) <- (ch, LTerm_style.merge token_style style) - done - in - UTop_styles.stylise stylise (UTop_lexer.lex_string (pending ^ LTerm_text.to_string styled)); - - (* Parenthesis matching. *) - if not last then LTerm_text.stylise_parenthesis styled position styles.style_paren; - - (styled, position) - - method completion = - let pos, words = UTop_complete.complete (pending ^ Zed_rope.to_string self#input_prev) in - if pos < pending_length then self#set_completion 0 [] else self#set_completion (pos - pending_length) words - - initializer - (* Set the source signal for the size of the terminal. *) - UTop_private.set_size self#size; - (* Set the source signal for the key sequence. *) - UTop_private.set_key_sequence self#key_sequence; - (* Set the prompt. *) - self#set_prompt prompt; - (* Call hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks -end - -(* +-----------------------------------------------------------------+ - | 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 - -(* Is it the first time [read_input] is called ? *) -let first_run = ref true - -(* 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 = - match prompt with - | "# " -> - (* Reset completion. *) - UTop_complete.reset (); - - (* increment the command counter. *) - UTop_private.set_count (S.value UTop_private.count + 1); - - (* Add the previous line to the history. *) - (match !pending with - | None -> - () - | Some line -> - history := LTerm_read_line.add_entry line !history; - pending := None); - - (* Call hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks; - - !UTop.prompt - - | "* " -> - !UTop.prompt_comment - - | " " -> - !UTop.prompt_continue - - | _ -> - Printf.ksprintf failwith "unknown prompt %S" prompt - in - - (* Read interactively user input. *) - let txt = Lwt_main.run ( - try_lwt - lwt () = - if !first_run then begin - first_run := false; - LTerm.fprint term "Type #utop_help for help about using utop.\n\n" - end else - return () - in - (new read_line ~term ~prompt:prompt_to_display)#run - finally - LTerm.flush term - ) in - - pending := Some (match !pending with - | None -> txt - | Some line -> line ^ "\n" ^ 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) - -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) - -let init_read_interactive_input () = - (* Open the standard terminal. *) - lwt term = Lazy.force LTerm.stdout in - (* If standard channels are connected to a tty, use interactive - read-line and display a welcome message: *) - if LTerm.incoming_is_a_tty term && LTerm.outgoing_is_a_tty term then begin - Toploop.read_interactive_input := (read_input term); - - (* Create a context to render the welcome message. *) - let size = LTerm.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]); - - (* On Windows we must make sure we are not at the end of screen. *) - lwt () = - if LTerm.windows term then - LTerm.fprint term "\n\n\n\n" - else - return () - in - - (* Render to the screen. *) - lwt () = LTerm.print_box term ~delta:(if LTerm.windows term then -4 else 0) 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 - -(* +-----------------------------------------------------------------+ - | Initialization | - +-----------------------------------------------------------------+ *) - -lwt () = join [ - init_history (); - UTop_styles.load (); - init_read_interactive_input (); - LTerm_inputrc.load (); -] diff --git a/src/console/uTop_console_top.mltop b/src/console/uTop_console_top.mltop deleted file mode 100644 index cea99fe..0000000 --- a/src/console/uTop_console_top.mltop +++ /dev/null @@ -1,5 +0,0 @@ -UTop_console -UTop_lexer -UTop_token -UTop_complete -UTop_styles diff --git a/src/emacs/uTop_emacs.ml b/src/emacs/uTop_emacs.ml deleted file mode 100644 index 742ba79..0000000 --- a/src/emacs/uTop_emacs.ml +++ /dev/null @@ -1,218 +0,0 @@ -(* - * uTop_emacs.ml - * ------------- - * Copyright : (c) 2011, Jeremie Dimino - * Licence : BSD3 - * - * This file is a part of utop. - *) - -(* Main for emacs mode. *) - -open Lwt - -let () = UTop_private.set_ui UTop_private.Emacs - -(* Copy standard output, which will be used to send commands. *) -let command_oc = Unix.out_channel_of_descr (Unix.dup Unix.stdout) - -(* +-----------------------------------------------------------------+ - | Sending commands to Emacs | - +-----------------------------------------------------------------+ *) - -(* Mutex used to send commands to Emacs. *) -let command_mutex = Mutex.create () - -let send command argument = - Mutex.lock command_mutex; - output_string command_oc command; - output_char command_oc ':'; - output_string command_oc argument; - output_char command_oc '\n'; - flush command_oc; - Mutex.unlock command_mutex - -(* +-----------------------------------------------------------------+ - | Standard outputs redirection | - +-----------------------------------------------------------------+ *) - -(* The output of ocaml (stdout and stderr) is redirected so the emacs - parts of celtop can recognize it. *) - -(* Continuously copy the output of ocaml to Emacs. *) -let rec copy_output which ic = - let line = input_line ic in - send which line; - copy_output which ic - -(* Create a thread which redirect the given output: *) -let redirect which fd = - let fdr, fdw = Unix.pipe () in - Unix.dup2 fdw fd; - Unix.close fdw; - Thread.create (copy_output which) (Unix.in_channel_of_descr fdr) - -(* Redirects stdout and stderr: *) -let _ = redirect "stdout" Unix.stdout -let _ = redirect "stderr" Unix.stderr - -(* +-----------------------------------------------------------------+ - | Input | - +-----------------------------------------------------------------+ *) - -(* The text typed by the user. *) -let input = ref "" - -(* The position of the text already sent to ocaml in {!input}. *) -let pos = ref 0 - -let read_line () = - let behavior = Sys.signal Sys.sigint Sys.Signal_ignore in - try - let line = Lwt_main.run (Lwt_io.read_line_opt Lwt_io.stdin) in - Sys.set_signal Sys.sigint behavior; - line - with exn -> - Sys.set_signal Sys.sigint behavior; - raise exn - -let read_command () = - match read_line () with - | None -> - None - | Some line -> - match try Some (String.index line ':') with Not_found -> None with - | None -> - send "stderr" "':' missing!"; - exit 1 - | Some idx -> - Some (String.sub line 0 idx, String.sub line (idx + 1) (String.length line - (idx + 1))) - -let read_data ?(final_newline = true) () = - let buf = Buffer.create 1024 in - let rec loop first = - match read_command () with - | None -> - send "stderr" "'end' command missing!"; - exit 1 - | Some ("data", data) -> - if not first then Buffer.add_char buf '\n'; - Buffer.add_string buf data; - loop false - | Some ("end", _) -> - if final_newline then Buffer.add_char buf '\n'; - Buffer.contents buf - | Some (command, argument) -> - Printf.ksprintf (send "stderr") "'data' or 'end' command expected, got %S!" command; - exit 1 - in - loop true - -let rec read_input prompt buffer length = - if !pos = String.length !input then begin - (match prompt with - | "# " -> - (* New phrase. *) - - (* Reset completion. *) - UTop_complete.reset (); - - (* Increment the command counter. *) - UTop_private.set_count (React.S.value UTop_private.count + 1); - - (* Call hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks; - Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks; - - send "prompt" ""; - - | "* " | " " -> - (* Continuation of the current phrase. *) - - (* Call hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks; - - send "continue" "" - | _ -> - Printf.ksprintf (send "stderr") "unrecognized prompt %S!" prompt; - exit 1); - loop prompt buffer length - end else begin - (* There is still some pending input. *) - let i = ref 0 in - while !i < length && !pos < String.length !input do - buffer.[!i] <- (!input).[!pos]; - incr i; - incr pos - done; - (!i, false) - end - -and process prompt buffer length command argument = - match command with - | "input" -> - input := read_data (); - pos := 0; - read_input prompt buffer length - | "complete" -> - let input = read_data ~final_newline:false () in - let start, words = UTop_complete.complete input in - let words = List.map fst words in - let prefix = LTerm_read_line.common_prefix words in - let index = String.length input - start in - let suffix = - if index > 0 && index <= String.length prefix then - String.sub prefix index (String.length prefix - index) - else - "" - in - if suffix = "" then begin - send "completion-start" ""; - List.iter (fun word -> send "completion" word) words; - send "completion-stop" ""; - end else - send "completion-word" suffix; - loop prompt buffer length - | command -> - Printf.ksprintf (send "stderr") "unrecognized command %S!" command; - exit 1 - -and loop prompt buffer length = - match read_command () with - | None -> - (0, true) - | Some (command, argument) -> - process prompt buffer length command argument - -let () = Toploop.read_interactive_input := read_input - -(* +-----------------------------------------------------------------+ - | Hacks | - +-----------------------------------------------------------------+ *) - -(* Force camlp4 to display its welcome message when it is loaded. *) - -let () = - List.iter - (fun directive -> - let orig = - try - match Hashtbl.find Toploop.directive_table directive with - | Toploop.Directive_none func -> - func - | _ -> - ignore - with Not_found -> - ignore - in - Hashtbl.replace Toploop.directive_table directive - (Toploop.Directive_none - (fun () -> - orig (); - (* Parse something so camlp4 will display its welcome - message. *) - try - ignore (!Toploop.parse_toplevel_phrase (Lexing.from_string "")) - with _ -> - ()))) - ["camlp4o"; "camlp4r"] diff --git a/src/emacs/uTop_emacs_top.mltop b/src/emacs/uTop_emacs_top.mltop deleted file mode 100644 index 2dbc006..0000000 --- a/src/emacs/uTop_emacs_top.mltop +++ /dev/null @@ -1,4 +0,0 @@ -UTop_emacs -UTop_lexer -UTop_token -UTop_complete diff --git a/src/gtk/uTop_gtk.ml b/src/gtk/uTop_gtk.ml deleted file mode 100644 index c432ca0..0000000 --- a/src/gtk/uTop_gtk.ml +++ /dev/null @@ -1,485 +0,0 @@ -(* - * uTop_gtk.ml - * ----------- - * Copyright : (c) 2011, Jeremie Dimino - * Licence : BSD3 - * - * This file is a part of utop. - *) - -open Lwt -open Lwt_react -open UTop_styles - -let () = UTop_private.set_ui UTop_private.GTK - -(* Copy stderr for errors. *) -let stderr_fd = Unix.dup Unix.stderr -let stderr = Unix.out_channel_of_descr stderr_fd - -(* Logs to the original stderr: *) -let () = - Lwt_log.default := Lwt_log.channel ~close_mode:`Close ~channel:(Lwt_io.of_fd ~mode:Lwt_io.output (Lwt_unix.of_unix_file_descr ~blocking:true ~set_flags:false stderr_fd)) () - -(* Just to prevent ocaml from doing stuppid things with the - terminal. *) -let () = Unix.putenv "TERM" "dumb" - -(* +-----------------------------------------------------------------+ - | Utils | - +-----------------------------------------------------------------+ *) - -let colors_16 = [| - (0x00, 0x00, 0x00); - (0xcd, 0x00, 0x00); - (0x00, 0xcd, 0x00); - (0xcd, 0xcd, 0x00); - (0x00, 0x00, 0xee); - (0xcd, 0x00, 0xcd); - (0x00, 0xcd, 0xcd); - (0xe5, 0xe5, 0xe5); - (0x7f, 0x7f, 0x7f); - (0xff, 0x00, 0x00); - (0x00, 0xff, 0x00); - (0xff, 0xff, 0x00); - (0x5c, 0x5c, 0xff); - (0xff, 0x00, 0xff); - (0x00, 0xff, 0xff); - (0xff, 0xff, 0xff); -|] - -let color_of_term_color default = function - | LTerm_style.Default -> - default () - | LTerm_style.Index n -> - if n >= 0 && n <= 15 then - let r, g, b = colors_16.(n) in - `RGB (r * 65535 / 255, g * 65535 / 255, b * 65535 / 255) - else - default () - | LTerm_style.RGB (r, g, b) -> - `RGB (r * 65535 / 255, g * 65535 / 255, b * 65535 / 255) - -let default_foreground () = - match S.value UTop.profile with - | UTop.Dark -> `WHITE - | UTop.Light -> `BLACK - -let default_background () = - match S.value UTop.profile with - | UTop.Dark -> `BLACK - | UTop.Light -> `WHITE - -(* +-----------------------------------------------------------------+ - | History | - +-----------------------------------------------------------------+ *) - -let history = ref [] - -let init_history () = - let hist_name = Filename.concat LTerm_resources.home ".utop-history" in - (* Save history on exit. *) - Lwt_main.at_exit (fun () -> LTerm_read_line.save_history hist_name !history); - (* Load history. *) - lwt h = LTerm_read_line.load_history hist_name in - history := h; - return () - -(* +-----------------------------------------------------------------+ - | Glib main loop | - +-----------------------------------------------------------------+ *) - -(* Initializes GTK. *) -let _ = GMain.init ~setlocale:false () - -let () = - UTop_private.exec_in_gui := - (fun job -> - ignore (Glib.Timeout.add ~ms:0 ~callback:(fun () -> job (); false))) - -(* The glib main loop. *) -let main () = - while true do - Lwt_glib.iter true - done - -(* Start the glib main loop in another thread. *) -let _ = Thread.create main () - -(* +-----------------------------------------------------------------+ - | GTK ui | - +-----------------------------------------------------------------+ *) - -(* Create the main window. *) -let window = GWindow.window ~title:"utop" ~width:800 ~height:600 ~allow_shrink:true () - -(* The scrolled window which contains the edition widget. *) -let scrolled_window = GBin.scrolled_window ~packing:window#add ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () - -(* Create the edition widget which will contains ocaml output. *) -let edit = GText.view ~packing:scrolled_window#add ~editable:false () - -(* The edition buffer. *) -let edit_buffer = edit#buffer - -(* Uneditable text tag. *) -let frozen = edit#buffer#create_tag [`EDITABLE false] - -(* Start of prompt. *) -let prompt_start = ref 0 - -(* End of prompt. *) -let prompt_stop = ref 0 - -(* Mutex used to protect access to [edit#buffer], [prompt_start] and - [prompt_stop]. *) -let edit_mutex = Mutex.create () - -(* [true] iff the current insertion is done by the computer and not by - the user. *) -let computer_insertion = ref false - -(* Exit when the window is closed. *) -let _ = - window#connect#destroy (fun () -> - (* Destroy the main window immedlatly, - because the saving of history may take - a while. *) - window#destroy (); - exit 0) - -(* Condition which is signaled when the user press Return. *) -let accept_cond = Lwt_condition.create () - -(* Notification used to notify the main thread that input is - available. *) -let notification = Lwt_unix.make_notification (Lwt_condition.signal accept_cond) - -(* Accept current input when the user press Return. *) -let _ = - edit#event#connect#key_press - (fun ev -> - if GdkEvent.Key.keyval ev = GdkKeysyms._Return then - Lwt_unix.send_notification notification; - false) - -(* +-----------------------------------------------------------------+ - | Styling | - +-----------------------------------------------------------------+ *) - -(* Is there pending data ? *) -let pending = ref false - -(* Input sent to ocaml but not yet finished. *) -let pending_string = ref "" - -(* Length of pending input, in unicode characters. *) -let pending_length = ref 0 - -let gdk_color spec = Gdk.Color.alloc ~colormap:edit#misc#colormap spec - -let tag_of_term_style style = - let props = [] in - let props = if LTerm_style.bold style = Some true then `WEIGHT `BOLD :: props else props in - let props = if LTerm_style.underline style = Some true then `UNDERLINE `SINGLE :: props else props in - let props = - if LTerm_style.reverse style = Some true then - let props = - match LTerm_style.foreground style with - | Some color -> `BACKGROUND_GDK (gdk_color (color_of_term_color default_foreground color)) :: props - | None -> `BACKGROUND_GDK (gdk_color (default_foreground ())) :: props - in - let props = - match LTerm_style.background style with - | Some color -> `FOREGROUND_GDK (gdk_color (color_of_term_color default_background color)) :: props - | None -> `FOREGROUND_GDK (gdk_color (default_background ())) :: props - in - props - else - let props = - match LTerm_style.foreground style with - | Some color -> `FOREGROUND_GDK (gdk_color (color_of_term_color default_foreground color)) :: props - | None -> props - in - let props = - match LTerm_style.background style with - | Some color -> `BACKGROUND_GDK (gdk_color (color_of_term_color default_background color)) :: props - | None -> props - in - props - in - edit_buffer#create_tag props - -(* Handle buffer modifications. *) -let changed argv = - if not !computer_insertion then begin - Mutex.lock edit_mutex; - let start = edit_buffer#get_iter (`OFFSET !prompt_stop) and stop = edit_buffer#end_iter in - (* First remove all tags from the input. *) - edit_buffer#remove_all_tags ~start ~stop; - (* Syntax highlighting. *) - let stylise start stop style = - let start = !prompt_stop + max 0 (start - !pending_length) and stop = !prompt_stop + stop - !pending_length in - if start < stop then begin - let start = edit_buffer#get_iter (`OFFSET start) and stop = edit_buffer#get_iter (`OFFSET stop) in - edit_buffer#apply_tag ~start ~stop (tag_of_term_style style) - end - in - UTop_styles.stylise stylise (UTop_lexer.lex_string (!pending_string ^ edit_buffer#get_text ~start ~stop ())); - Mutex.unlock edit_mutex - end - -let _ = - GtkSignal.connect_by_name - edit_buffer#as_buffer - ~name:"changed" - ~callback:(Gobject.Closure.create changed) - ~after:false - -(* Insert the prompt. *) -let insert_prompt ?(locked = true) prompt = - if locked then Mutex.lock edit_mutex; - computer_insertion := true; - let iter = edit_buffer#get_iter (`OFFSET !prompt_start) in - (* Remove the previous prompt. *) - if !prompt_start < !prompt_stop then begin - edit_buffer#delete ~start:iter ~stop:(edit_buffer#get_iter (`OFFSET !prompt_stop)) - end; - (* Insert the text of the new one. *) - edit_buffer#insert ~iter ~tags:[frozen] (LTerm_text.to_string prompt); - (* Update the end of prompt. *) - prompt_stop := iter#offset; - (* Stylise it. *) - let stylise start stop style = - if start < stop then begin - let start = edit_buffer#get_iter (`OFFSET (start + !prompt_start)) and stop = edit_buffer#get_iter (`OFFSET (stop + !prompt_start)) in - edit_buffer#apply_tag ~start ~stop (tag_of_term_style style) - end - in - let rec loop i j style = - if j = Array.length prompt then - stylise i j style - else begin - let _, style' = prompt.(j) in - if LTerm_style.equal style style' then - loop i (j + 1) style - else begin - stylise i j style; - loop j (j + 1) style' - end - end - in - loop 0 0 LTerm_style.none; - computer_insertion := false; - if locked then Mutex.unlock edit_mutex - -(* The current prompt. *) -let current_prompt, set_current_prompt = S.create ~eq:(==) (S.const [||]) - -(* Update the prompt when it change. *) -let () = - E.keep - (E.map - (fun prompt -> - (* Update it only if we are editing. *) - if edit#editable then insert_prompt ~locked:true prompt) - (S.changes (S.switch (S.value current_prompt) (S.changes current_prompt)))) - -(* +-----------------------------------------------------------------+ - | Standard outputs redirections | - +-----------------------------------------------------------------+ *) - -let copy ic = - while true do - let line = input_line ic in - Mutex.lock edit_mutex; - (* Insert the line before the prompt. *) - let iter = edit_buffer#get_iter (`OFFSET !prompt_start) in - computer_insertion := true; - edit_buffer#insert ~iter ~tags:[frozen] line; - edit_buffer#insert ~iter ~tags:[frozen] "\n"; - computer_insertion := false; - (* Advance the prompt. *) - let delta = iter#offset - !prompt_start in - prompt_start := !prompt_start + delta; - prompt_stop := !prompt_stop + delta; - Mutex.unlock edit_mutex - done - -let redirect fd = - let fdr, fdw = Unix.pipe () in - Unix.dup2 fdw fd; - Unix.close fdw; - Thread.create copy (Unix.in_channel_of_descr fdr) - -let _ = redirect Unix.stdout -let _ = redirect Unix.stderr - -(* +-----------------------------------------------------------------+ - | OCaml 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 - -let rec read_input prompt buffer length = - if !pos = String.length !input then begin - (match prompt with - | "# " -> - (* New phrase. *) - - (* Reset completion. *) - UTop_complete.reset (); - - (* Increment the command counter. *) - UTop_private.set_count (React.S.value UTop_private.count + 1); - - (* Call hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks; - Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks; - - Mutex.lock edit_mutex; - - (* Add the previous line to the history. *) - if !pending then begin - history := LTerm_read_line.add_entry !pending_string !history; - pending := false; - pending_string := ""; - pending_length := 0 - end; - - (* Insert the prompt. *) - let offset = edit_buffer#end_iter#offset in - prompt_start := offset; - prompt_stop := offset; - insert_prompt ~locked:false (S.value !UTop.prompt); - - Mutex.unlock edit_mutex; - - set_current_prompt !UTop.prompt - - | " " -> - (* Continuation of the current phrase. *) - - (* Call hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks; - - (* Insert the prompt. *) - Mutex.lock edit_mutex; - let offset = edit_buffer#end_iter#offset in - prompt_start := offset; - prompt_stop := offset; - insert_prompt ~locked:false (S.value !UTop.prompt_continue); - Mutex.unlock edit_mutex; - - set_current_prompt !UTop.prompt_continue - - | "* " -> - (* Continuation of the current phrase (in a comment). *) - - (* Call hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks; - - (* Insert the prompt. *) - Mutex.lock edit_mutex; - let offset = edit_buffer#end_iter#offset in - prompt_start := offset; - prompt_stop := offset; - insert_prompt ~locked:false (S.value !UTop.prompt_comment); - Mutex.unlock edit_mutex; - - set_current_prompt !UTop.prompt_comment - - | _ -> - (* Unknown prompt: error. *) - - let dialog = GWindow.dialog ~title:"error" () in - ignore (GMisc.label ~text:(Printf.sprintf "unrecognized prompt %S!" prompt) ~packing:dialog#vbox#add ()); - dialog#add_button_stock `OK `OK; - ignore (dialog#run ()); - exit 1); - - (* Make the buffer editable. *) - edit#set_editable true; - - (* Wait for the user to press Return. *) - let () = Lwt_main.run (Lwt_condition.wait accept_cond) in - - (* Make the buffer uneditable while ocaml is executing things. *) - edit#set_editable false; - - Mutex.lock edit_mutex; - (* Get the user input. *) - let start = edit_buffer#get_iter (`OFFSET !prompt_stop) and stop = edit_buffer#end_iter in - let text = edit_buffer#get_text ~start ~stop () in - (* Froze the input. *) - edit_buffer#apply_tag ~start ~stop frozen; - (* Advance the prompt. *) - let offset = stop#offset in - prompt_start := offset; - prompt_stop := offset; - Mutex.unlock edit_mutex; - - input := text; - pos := 0; - - (* Add current input to pending input. *) - if !pending then begin - pending_string := !pending_string ^ "\n" ^ text; - pending_length := !pending_length + 1 + Zed_utf8.length text - end else begin - pending := true; - pending_string := text; - pending_length := Zed_utf8.length text - end; - - read_input prompt buffer length - end else begin - (* There is still some pending input. *) - let i = ref 0 in - while !i < length && !pos < String.length !input do - buffer.[!i] <- (!input).[!pos]; - incr i; - incr pos - done; - (!i, false) - end - -let () = Toploop.read_interactive_input := read_input - -(* +-----------------------------------------------------------------+ - | Initialization | - +-----------------------------------------------------------------+ *) - -lwt () = join [ - init_history (); - UTop_styles.load (); -] - -(* Set the font of the edition buffer. *) -let () = - match styles.style_font with - | Some font -> edit#misc#modify_font_by_name font - | None -> () - -(* Set foreground color. *) -let () = - match styles.style_foreground with - | Some color -> - edit#misc#modify_text [(`NORMAL, color_of_term_color default_foreground color)] - | None -> - edit#misc#modify_text [(`NORMAL, default_foreground ())] - -(* Set background color. *) -let () = - match styles.style_background with - | Some color -> - edit#misc#modify_base [(`NORMAL, color_of_term_color default_background color)] - | None -> - edit#misc#modify_base [(`NORMAL, default_background ())] - -(* Show the window in the GUI thread, this is needed for windows. *) -let () = UTop.exec_in_gui window#show diff --git a/src/gtk/uTop_gtk_top.mltop b/src/gtk/uTop_gtk_top.mltop deleted file mode 100644 index 160e569..0000000 --- a/src/gtk/uTop_gtk_top.mltop +++ /dev/null @@ -1,5 +0,0 @@ -UTop_gtk -UTop_lexer -UTop_token -UTop_complete -UTop_styles diff --git a/src/lib/errors.mli b/src/lib/errors.mli new file mode 100644 index 0000000..5d10804 --- /dev/null +++ b/src/lib/errors.mli @@ -0,0 +1,3 @@ +(* Must be the same as driver/errors.mli from ocaml sources. *) +open Format +val report_error : formatter -> exn -> unit diff --git a/src/common/uTop.ml b/src/lib/uTop.ml similarity index 52% rename from src/common/uTop.ml rename to src/lib/uTop.ml index 129e3b7..e6026a2 100644 --- a/src/common/uTop.ml +++ b/src/lib/uTop.ml @@ -15,15 +15,44 @@ open LTerm_style module String_set = Set.Make(String) +let version = UTop_version.version + (* +-----------------------------------------------------------------+ - | UI | + | Hooks | +-----------------------------------------------------------------+ *) -type ui = UTop_private.ui = Console | GTK | Emacs +let new_command_hooks = Lwt_sequence.create () +let at_new_command f = ignore (Lwt_sequence.add_l f new_command_hooks) + +(* +-----------------------------------------------------------------+ + | Config | + +-----------------------------------------------------------------+ *) + +type ui = UTop_private.ui = Console | Emacs let get_ui () = S.value UTop_private.ui -let exec_in_gui f = !UTop_private.exec_in_gui f +type profile = Dark | Light + +let profile, set_profile = S.create Dark + +let size = UTop_private.size + +let key_sequence = UTop_private.key_sequence + +let count = UTop_private.count + +let time = ref 0. + +let () = at_new_command (fun () -> time := Unix.time ()) + +let make_variable ?eq x = + let signal, set = S.create ?eq x in + (signal, (fun () -> S.value signal), set) + +let camlp4, get_camlp4, set_camlp4 = make_variable true +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 (* +-----------------------------------------------------------------+ | Keywords | @@ -43,33 +72,167 @@ let keywords = ref (List.fold_left (fun set kwd -> String_set.add kwd set) Strin let add_keyword kwd = keywords := String_set.add kwd !keywords (* +-----------------------------------------------------------------+ - | Hooks | + | Error reporting | +-----------------------------------------------------------------+ *) -let new_command_hooks = Lwt_sequence.create () -let at_new_command f = ignore (Lwt_sequence.add_l f new_command_hooks) -let new_prompt_hooks = Lwt_sequence.create () -let at_new_prompt f = ignore (Lwt_sequence.add_l f new_prompt_hooks) +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; + func pp x; + Format.pp_print_flush pp (); + Buffer.contents buffer + +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; + Errors.report_error pp exn; + Format.pp_print_flush pp (); + let str = Buffer.contents buffer in + try + Scanf.sscanf + str + "Characters %d-%d:\n%[\000-\255]" + (fun start stop msg -> ((start, stop), msg)) + with _ -> + ((0, 0), str) (* +-----------------------------------------------------------------+ - | Prompts | + | Parsing | +-----------------------------------------------------------------+ *) -type profile = Dark | Light +type location = int * int -let profile, set_profile = S.create Dark +type 'a result = + | Value of 'a + | Error of location list * string -let smart_accept = ref true +exception Need_more -let size = UTop_private.size +#if ocaml_version <= (3, 12, 1) +let input_name = "" +#else +let input_name = "//toplevel//" +#endif -let key_sequence = UTop_private.key_sequence +let lexbuf_of_string eof str = + let pos = ref 0 in + Lexing.from_function + (fun buf len -> + if !pos = String.length str then begin + eof := true; + 0 + end else begin + let len = min len (String.length str - !pos) in + String.blit str !pos buf 0 len; + pos := !pos + len; + len + end) -let count = UTop_private.count +let mkloc loc = + (loc.Location.loc_start.Lexing.pos_cnum, + loc.Location.loc_end.Lexing.pos_cnum) -let time = ref 0. +let parse_toplevel_phrase_default str eos_is_error = + let eof = ref false in + let lexbuf = lexbuf_of_string eof str in + try + (* Try to parse the phrase. *) + let phrase = Parse.toplevel_phrase lexbuf in + Value phrase + with + | _ when !eof && not eos_is_error -> + (* This is not an error, we just need more input. *) + raise Need_more + | End_of_file -> + (* If the string is empty, do not report an error. *) + raise Need_more + | Lexer.Error (error, loc) -> + Error ([mkloc loc], get_message Lexer.report_error error) + | Syntaxerr.Error (Syntaxerr.Unclosed (opening_loc, opening, closing_loc, closing)) -> + Error ([mkloc opening_loc; mkloc closing_loc], + Printf.sprintf "Syntax error: '%s' expected, the highlighted '%s' might be unmatched" closing opening) + | Syntaxerr.Error (Syntaxerr.Applicative_path loc) -> + Error ([mkloc loc], + "Syntax error: applicative paths of the form F(X).t are not supported when the option -no-app-funct is set.") + | Syntaxerr.Error (Syntaxerr.Other loc) -> + Error ([mkloc loc], + "Syntax error") + | Syntaxerr.Escape_error | Parsing.Parse_error -> + Error ([mkloc (Location.curr lexbuf)], + "Syntax error") + | exn -> + Error ([], "Unknown parsing error (please report it to the utop project): " ^ Printexc.to_string exn) -let () = at_new_prompt (fun () -> time := Unix.time ()) +let parse_toplevel_phrase = ref parse_toplevel_phrase_default + +(* +-----------------------------------------------------------------+ + | Safety checking | + +-----------------------------------------------------------------+ *) + +let null = Format.make_formatter (fun str ofs len -> ()) ignore + +let rec last head tail = + match tail with + | [] -> + head + | head :: tail -> + last head tail + +(* Check that the given phrase can be evaluated without typing/compile + errors. *) +let check_phrase phrase = + match phrase with + | Parsetree.Ptop_dir _ -> + None + | Parsetree.Ptop_def [] -> + None + | Parsetree.Ptop_def (item :: items) -> + let loc = { + Location.loc_start = item.Parsetree.pstr_loc.Location.loc_start; + Location.loc_end = (last item items).Parsetree.pstr_loc.Location.loc_end; + Location.loc_ghost = false; + } in + (* Backup. *) + let snap = Btype.snapshot () in + let env = !Toploop.toplevel_env in + (* Construct "module _(_ : sig end) = struct end" in + order to test the typing and compilation of [items] without + evaluating them. *) + let wrapped_items = { + Parsetree.pmod_loc = loc; + Parsetree.pmod_desc = Parsetree.Pmod_structure (item :: items); + } in + let empty_sig = { + Parsetree.pmty_loc = loc; + Parsetree.pmty_desc = Parsetree.Pmty_signature []; + } in + let funct = { + Parsetree.pmod_loc = loc; + Parsetree.pmod_desc = Parsetree.Pmod_functor ("_", empty_sig, wrapped_items); + } in + let top_def = { + Parsetree.pstr_loc = loc; + Parsetree.pstr_desc = Parsetree.Pstr_module ("_", funct); + } in + let check_phrase = Parsetree.Ptop_def [top_def] in + try + let _ = Toploop.execute_phrase false null check_phrase in + (* The phrase is safe. *) + Toploop.toplevel_env := env; + Btype.backtrack snap; + None + with exn -> + (* The phrase contains errors. *) + Toploop.toplevel_env := env; + Btype.backtrack snap; + let loc, msg = get_ocaml_error_message exn in + Some ([loc], msg) + +(* +-----------------------------------------------------------------+ + | Prompt | + +-----------------------------------------------------------------+ *) let make_prompt ui profile count size key_sequence (recording, macro_count, macro_counter) = let tm = Unix.localtime !time in @@ -81,9 +244,6 @@ let make_prompt ui profile count size key_sequence (recording, macro_count, macr match ui with | Emacs -> [||] - | GTK -> - eval [B_fg (color lcyan blue); - S (Printf.sprintf "utop[%d]> " count)] | Console -> let bold = profile = Dark in let txta = @@ -130,6 +290,16 @@ let make_prompt ui profile count size key_sequence (recording, macro_count, macr S " }─"; ] in + let second_line = + eval [ + S "\n"; + B_bold bold; + B_fg (rgb 0xe3 0xaa 0x73); + S "utop"; + B_fg (color lgreen green); + S " $ "; + ] + in Array.append ( if Array.length txta + Array.length txtb > size.cols then Array.sub (Array.append txta txtb) 0 size.cols @@ -141,7 +311,7 @@ let make_prompt ui profile count size key_sequence (recording, macro_count, macr (UChar.of_int 0x2500, { none with foreground = Some (color lcyan blue); bold = Some bold }); txtb; ] - ) [|(UChar.of_char '#', { none with foreground = Some (color lgreen green) }); (UChar.of_char ' ', none)|] + ) second_line let prompt = ref ( S.l6 make_prompt @@ -156,9 +326,6 @@ let prompt = ref ( (Zed_macro.counter LTerm_read_line.macro)) ) -let prompt_continue = ref (S.map (fun profile -> [|(UChar.of_char '>', { none with foreground = Some (if profile = Dark then lgreen else green) }); (UChar.of_char ' ', LTerm_style.none)|]) profile) -let prompt_comment = ref (S.map (fun profile -> [|(UChar.of_char '*', { none with foreground = Some (if profile = Dark then lgreen else green) }); (UChar.of_char ' ', LTerm_style.none)|]) profile) - (* +-----------------------------------------------------------------+ | Help | +-----------------------------------------------------------------+ *) @@ -252,14 +419,72 @@ For a complete description of utop, look at the utop(1) manual page.")); macro; flush stdout)) +(* +-----------------------------------------------------------------+ + | Camlp4 | + +-----------------------------------------------------------------+ *) + +let print_error msg = + lwt term = Lazy.force LTerm.stdout in + lwt () = LTerm.set_style term !UTop_private.error_style in + lwt () = Lwt_io.print msg in + lwt () = LTerm.set_style term LTerm_style.none in + LTerm.flush term + +let handle_findlib_error = function + | Failure msg -> + Lwt_main.run (print_error msg) + | Fl_package_base.No_such_package(pkg, reason) -> + Lwt_main.run (print_error (Printf.sprintf "No such package: %s%S\n" pkg (if reason <> "" then " - " ^ reason else ""))) + | Fl_package_base.Package_loop pkg -> + Lwt_main.run (print_error (Printf.sprintf "Package requires itself: %s\n" pkg)) + | exn -> + raise exn + +let () = + Hashtbl.add + Toploop.directive_table + "camlp4o" + (Toploop.Directive_none + (fun () -> + set_phrase_terminator ";;"; + try + Topfind.syntax "camlp4o"; + Topfind.load_deeply ["utop.camlp4"] + with exn -> + handle_findlib_error exn)); + + Hashtbl.add + Toploop.directive_table + "camlp4r" + (Toploop.Directive_none + (fun () -> + set_phrase_terminator ";"; + try + Topfind.syntax "camlp4r"; + Topfind.load_deeply ["utop.camlp4"] + with exn -> + handle_findlib_error exn)) + (* +-----------------------------------------------------------------+ | Initialization | +-----------------------------------------------------------------+ *) let () = + (* "utop" is an internal library so it is not passed as "-package" + to "ocamlfind ocamlmktop". *) + Topfind.don't_load ["utop"]; (* Add findlib path so Topfind is available and it won't be initialized twice if the user does [#use "topfind"]. *) Topdirs.dir_directory (Findlib.package_directory "findlib"); (* Make UTop accessible. *) Topdirs.dir_directory (Findlib.package_directory "utop") +(* +-----------------------------------------------------------------+ + | Deprecated | + +-----------------------------------------------------------------+ *) + +let smart_accept = ref true +let new_prompt_hooks = Lwt_sequence.create () +let at_new_prompt f = ignore (Lwt_sequence.add_l f new_prompt_hooks) +let prompt_continue = ref (S.const [| |]) +let prompt_comment = ref (S.const [| |]) diff --git a/src/lib/uTop.mli b/src/lib/uTop.mli new file mode 100644 index 0000000..1ae6cd9 --- /dev/null +++ b/src/lib/uTop.mli @@ -0,0 +1,182 @@ +(* + * uTop.mli + * -------- + * Copyright : (c) 2011, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +(** UTop configuration. *) + +open React + +val version : string + (** Version of utop. *) + +val count : int React.signal + (** The number of commands already executed. *) + +val keywords : Set.Make(String).t ref + (** The set of OCaml keywords. *) + +val add_keyword : string -> unit + (** Add a new OCaml keyword. *) + +type ui = Console | Emacs + (** The user interface in use. *) + +val get_ui : unit -> ui + (** Returns the user interface in use. *) + +val camlp4 : bool signal + (** [true] if the lexer should recognize camlp4 quotations. This + variable is automatically set to [true] when you type [#camlp4o] + or [#camlp4r]. *) + +val get_camlp4 : unit -> bool + (** Returns the current value of {!camlp4}. *) + +val set_camlp4 : bool -> unit + (** Modifies {!camlp4}. *) + +val phrase_terminator : string signal + (** The phrase terminator. It is ";;" by default and ";" when you + use revised syntax. *) + +val get_phrase_terminator : unit -> string + (** Returns the value of {!phrase_terminator}. *) + +val set_phrase_terminator : string -> unit + (** Modifies {!phrase_terminator}. *) + +val auto_run_lwt : bool signal + (** If [true] (the default) toplevel lwt expressions are + automatically run with [Lwt_main.run]. i.e. if you type: + + {[ + Lwt_io.printl "Hello, world" + ]} + + this will be replaced by: + + {[ + Lwt_main.run (Lwt_io.printl "Hello, world") + ]} + *) + +val get_auto_run_lwt : unit -> bool + (** Returns the value of {!auto_run_lwt}. *) + +val set_auto_run_lwt : bool -> unit + (** Modifies {!auto_run_lwt}. *) + +(** {6 Console specific configuration} *) + +type profile = Dark | Light + (** Profile for colors. *) + +val profile : profile React.signal + (** The color profile. It defaults to {!Dark}. This is used by the + default prompt to choose colors. *) + +val set_profile : profile -> unit + (** Sets the color profile. *) + +val size : LTerm_geom.size React.signal + (** The current size of the terminal. This is used only in the + console UI. *) + +val key_sequence : LTerm_key.t list React.signal + (** The current key sequence entered by the user. This is used only + in the console UI. *) + +val time : float ref + (** The time of the beginning of the current command. *) + +val prompt : LTerm_text.t React.signal ref + (** The prompt. *) + +(** {6 Hooks} *) + +val new_command_hooks : (unit -> unit) Lwt_sequence.t + (** Functions called before each new command. *) + +val at_new_command : (unit -> unit) -> unit + (** [at_new_command f] adds [f] to the hooks executed before each + new commands. *) + +(** {6 Parsing} *) + +type location = int * int + (** Type of a string-location. It is composed of a start and stop + offsets (in bytes). *) + +(** Result of a function processing a programx. *) +type 'a result = + | Value of 'a + (** The function succeeded and returned this value. *) + | Error of location list * string + (** The function failed. Arguments are a list of locations to + highlight in the source and an error message. *) + +exception Need_more + (** Exception raised by a parser when it need more data. *) + +val parse_toplevel_phrase : (string -> bool -> Parsetree.toplevel_phrase result) ref + (** [parse_toplevel_phrase] is the function used to parse a phrase + typed in the toplevel. + + Its arguments are: + - [input]: the string to parse + - [eos_is_error] + + If [eos_is_error] is [true] and the parser reach the end of + input, then {!Parse_failure} should be returned. + + If [eos_is_error] is [false] and the parser reach the end of + input, the exception {!Need_more} must be thrown. + + Except for {!Need_more}, the function must not raise any + exception. *) + +val parse_toplevel_phrase_default : string -> bool -> Parsetree.toplevel_phrase result + (** The default parser. It uses the standard ocaml parser. *) + +val input_name : string + (** The name you must use in location to let ocaml know that it is + from the toplevel. *) + +val lexbuf_of_string : bool ref -> string -> Lexing.lexbuf + (** [lexbuf_of_string eof str] is the same as [Lexing.from_string + str] except that if the lexer reach the end of [str] then [eof] is + set to [true]. *) + +(** {6 Helpers} *) + +val get_message : (Format.formatter -> 'a -> unit) -> 'a -> string + (** [get_message printer x] applies [printer] on [x] and + returns everything it prints as a string. *) + +val get_ocaml_error_message : exn -> location * string + (** [get_ocaml_error_message exn] returns the location and error + message for the exception [exn] which must be an exception from + the compiler. *) + +val check_phrase : Parsetree.toplevel_phrase -> (location list * string) option + (** [check_phrase phrase] checks that [phrase] can be executed + without typing or compilation errors. It returns [None] if + [phrase] is OK and an error message otherwise. + + If the result is [None] it is guaranteed that + [Toploop.execute_phrase] won't raise any exception. *) + +(**/**) + +(* These variables are not used and deprecated: *) + +val prompt_continue : LTerm_text.t React.signal ref +val prompt_comment : LTerm_text.t React.signal ref +val smart_accept : bool ref +val new_prompt_hooks : (unit -> unit) Lwt_sequence.t +val at_new_prompt : (unit -> unit) -> unit diff --git a/src/common/uTop_complete.ml b/src/lib/uTop_complete.ml similarity index 99% rename from src/common/uTop_complete.ml rename to src/lib/uTop_complete.ml index 0e9990c..267b200 100644 --- a/src/common/uTop_complete.ml +++ b/src/lib/uTop_complete.ml @@ -344,7 +344,7 @@ let add_fields_of_type decl acc = let add_names_of_type decl acc = match decl.type_kind with | Type_variant constructors -> -#if ocaml_version >= (3, 13) +#if ocaml_version >= (3, 13, 0) List.fold_left (fun acc (name, _, _) -> add name acc) acc constructors #else List.fold_left (fun acc (name, _) -> add name acc) acc constructors @@ -644,7 +644,7 @@ let rec filter tokens = +-----------------------------------------------------------------+ *) let complete str = - let tokens = UTop_lexer.lex_string str in + let tokens = UTop_lexer.lex_string ~camlp4:(UTop.get_camlp4 ()) str in (* Filter blanks and comments. *) let tokens = filter tokens in match tokens with diff --git a/src/common/uTop_complete.mli b/src/lib/uTop_complete.mli similarity index 100% rename from src/common/uTop_complete.mli rename to src/lib/uTop_complete.mli diff --git a/src/lib/uTop_lexer.mli b/src/lib/uTop_lexer.mli new file mode 100644 index 0000000..534581d --- /dev/null +++ b/src/lib/uTop_lexer.mli @@ -0,0 +1,15 @@ +(* + * uTop_lexer.mli + * -------------- + * Copyright : (c) 2012, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +val lex_string : ?camlp4 : bool -> string -> (UTop_token.t * int * int * string) list + (** [lex_string str] returns all the tokens contained in [str]. It + returns a list of [(token, start_index, stop_index, + contents)]. Indexes are in unicode characters. + + If [camlp4] is [true] then quotations are parsed. *) diff --git a/src/common/uTop_lexer.mll b/src/lib/uTop_lexer.mll similarity index 68% rename from src/common/uTop_lexer.mll rename to src/lib/uTop_lexer.mll index c700488..c3a3979 100644 --- a/src/common/uTop_lexer.mll +++ b/src/lib/uTop_lexer.mll @@ -19,13 +19,10 @@ let blank = [' ' '\009' '\012'] let lowercase = ['a'-'z' '_'] let uppercase = ['A'-'Z'] let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] +let lident = lowercase identchar* +let uident = uppercase identchar* let ident = (lowercase|uppercase) identchar* -let locname = ident -let not_star_symbolchar = - ['$' '!' '%' '&' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~' '\\'] -let symbolchar = '*' | not_star_symbolchar -let quotchar = - ['!' '%' '&' '+' '-' '.' '/' ':' '=' '?' '@' '^' '|' '~' '\\' '*'] + let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f'] let decimal_literal = ['0'-'9'] ['0'-'9' '_']* @@ -42,37 +39,19 @@ let float_literal = ('.' ['0'-'9' '_']* )? (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? -let safe_delimchars = ['%' '&' '/' '@' '^'] +let symbolchar = + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] -let delimchars = safe_delimchars | ['|' '<' '>' ':' '=' '.'] - -let left_delims = ['(' '[' '{'] -let right_delims = [')' ']' '}'] - -let left_delimitor = - left_delims delimchars* safe_delimchars (delimchars|left_delims)* - | '(' (['|' ':'] delimchars*)? - | '[' ['|' ':']? - | ['[' '{'] delimchars* '<' - | '{' (['|' ':'] delimchars*)? - -let right_delimitor = - (delimchars|right_delims)* safe_delimchars (delimchars|right_delims)* right_delims - | (delimchars* ['|' ':'])? ')' - | ['|' ':']? ']' - | '>' delimchars* [']' '}'] - | (delimchars* ['|' ':'])? '}' - -rule token = parse +rule token fallback = parse | ('\n' | blank)+ { Blanks } | "true" { Constant } | "false" { Constant } - | lowercase identchar* + | lident { Lident } - | uppercase identchar* + | uident { Uident } | int_literal "l" { Constant } @@ -104,24 +83,37 @@ rule token = parse { Doc (comment 0 lexbuf) } | "(*" { Comment (comment 0 lexbuf) } - | '<' (':' ident)? ('@' locname)? '<' - { Quotation (quotation lexbuf) } - | ( "#" | "`" | "'" | "," | "." | ".." | ":" | "::" - | ":=" | ":>" | ";" | ";;" | "_" - | left_delimitor | right_delimitor ) - { Symbol } - | ['~' '?' '!' '=' '<' '>' '|' '&' '@' '^' '+' '-' '*' '/' '%' '\\' '$'] symbolchar* + | "" + { fallback lexbuf } + +and token_fallback = parse + | "(" | ")" + | "[" | "]" + | "{" | "}" + | "`" + | "#" + | "," + | ";" | ";;" + | symbolchar+ { Symbol } | uchar { Error } | eof { raise End_of_file } +and token_fallback_camlp4 = parse + | '<' (':' ident)? ('@' lident)? '<' + { Quotation (quotation lexbuf) } + | "" + { token_fallback lexbuf } + and comment depth = parse | "(*" { comment (depth + 1) lexbuf } | "*)" { if depth > 0 then comment (depth - 1) lexbuf else true } + | '"' + { string lexbuf && comment depth lexbuf } | uchar { comment depth lexbuf } | eof @@ -140,16 +132,27 @@ and string = parse and quotation = parse | ">>" { true } + | '$' + { antiquotation lexbuf } | uchar { quotation lexbuf } | eof { false } +and antiquotation = parse + | '$' + { quotation lexbuf } + | eof + { false } + | "" + { ignore (token token_fallback_camlp4 lexbuf); antiquotation lexbuf } + { - let lex_string str = + let lex_string ?(camlp4=false) str = + let fallback = if camlp4 then token_fallback_camlp4 else token_fallback in let lexbuf = Lexing.from_string str in let rec loop idx ofs_a = - match try Some (token lexbuf) with End_of_file -> None with + match try Some (token fallback lexbuf) with End_of_file -> None with | Some token -> let ofs_b = Lexing.lexeme_end lexbuf in let src = String.sub str ofs_a (ofs_b - ofs_a) in diff --git a/src/lib/uTop_main.ml b/src/lib/uTop_main.ml new file mode 100644 index 0000000..d44f485 --- /dev/null +++ b/src/lib/uTop_main.ml @@ -0,0 +1,685 @@ +(* + * uTop_main.ml + * ------------ + * Copyright : (c) 2011, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +open CamomileLibraryDyn.Camomile +open Lwt +open Lwt_react +open LTerm_text +open LTerm_geom +open UTop_token +open UTop_styles +open UTop_private + +module String_set = Set.Make(String) + +(* +-----------------------------------------------------------------+ + | History | + +-----------------------------------------------------------------+ *) + +let history = ref [] + +let init_history () = + let hist_name = Filename.concat LTerm_resources.home ".utop-history" in + (* Save history on exit. *) + Lwt_main.at_exit (fun () -> LTerm_read_line.save_history hist_name !history); + (* Load history. *) + lwt h = LTerm_read_line.load_history hist_name in + history := h; + return () + +(* +-----------------------------------------------------------------+ + | offset --> index | + +-----------------------------------------------------------------+ *) + +(* Return the index (in unicode characters) of the character starting + a offset (in bytes) [ofs] in [str]. *) +let index_of_offset src ofs = + let rec aux idx ofs' = + if ofs' = ofs then + idx + else if ofs' > ofs then + idx - 1 + else if ofs' = String.length src then + -1 + else + aux (idx + 1) (Zed_utf8.unsafe_next src ofs') + in + aux 0 0 + +let convert_locs str locs = List.map (fun (a, b) -> (index_of_offset str a, index_of_offset str b)) locs + +(* +-----------------------------------------------------------------+ + | The read-line class | + +-----------------------------------------------------------------+ *) + +let parse_and_check input eos_is_error = + match !UTop.parse_toplevel_phrase input eos_is_error with + | UTop.Error (locs, msg) -> + UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n") + | UTop.Value phrase -> + match UTop.check_phrase phrase with + | None -> + UTop.Value phrase + | Some (locs, msg) -> + UTop.Error (convert_locs input locs, msg) + +(* Read a phrase. If the result is a value, it is guaranteed to by a + valid phrase (i.e. typable and compilable). *) +class read_phrase ~term = object(self) + inherit [Parsetree.toplevel_phrase UTop.result] LTerm_read_line.engine ~history:!history () as super + inherit [Parsetree.toplevel_phrase UTop.result] LTerm_read_line.term term as super_term + + val mutable return_value = None + + method eval = + match return_value with + | Some x -> + x + | None -> + assert false + + method exec = function + | LTerm_read_line.Accept :: actions when !UTop.smart_accept && S.value self#mode = LTerm_read_line.Edition -> begin + Zed_macro.add self#macro LTerm_read_line.Accept; + (* Try to parse the input. *) + let input = Zed_rope.to_string (Zed_edit.text self#edit) in + (* Toploop does that: *) + Location.reset (); + try + let result = parse_and_check input false in + return_value <- Some result; + history := LTerm_read_line.add_entry input !history; + return result + with UTop.Need_more -> + (* Input not finished, continue. *) + self#insert (UChar.of_char '\n'); + self#exec actions + end + | actions -> + super_term#exec actions + + method stylise last = + let styled, position = super#stylise last in + + (* Syntax highlighting *) + let stylise start stop token_style = + for i = start to stop - 1 do + let ch, style = styled.(i) in + styled.(i) <- (ch, LTerm_style.merge token_style style) + done + in + UTop_styles.stylise stylise (UTop_lexer.lex_string ~camlp4:(UTop.get_camlp4 ()) (LTerm_text.to_string styled)); + + if not last then + (* Parenthesis matching. *) + LTerm_text.stylise_parenthesis styled position styles.style_paren + else begin + match return_value with + | Some (UTop.Error (locs, _)) -> + (* Highlight error locations. *) + List.iter + (fun (start, stop) -> + for i = start to stop - 1 do + let ch, style = styled.(i) in + styled.(i) <- (ch, { style with LTerm_style.underline = Some true }) + done) + locs + | _ -> + () + end; + + (styled, position) + + method completion = + let pos, words = UTop_complete.complete (Zed_rope.to_string self#input_prev) in + self#set_completion pos words + + initializer + (* Set the source signal for the size of the terminal. *) + UTop_private.set_size self#size; + (* Set the source signal for the key sequence. *) + UTop_private.set_key_sequence self#key_sequence; + (* Set the prompt. *) + self#set_prompt !UTop.prompt +end + +(* +-----------------------------------------------------------------+ + | Out phrase printing | + +-----------------------------------------------------------------+ *) + +let print_out_phrase term printer pp out_phrase = + flush stdout; + flush stderr; + (match out_phrase with + | Outcometree.Ophr_exception _ -> + if Printexc.backtrace_status () then begin + Printexc.print_backtrace stdout; + flush stdout + end + | _ -> + ()); + let buffer = Buffer.create 1024 in + let pp = Format.formatter_of_buffer buffer in + Format.pp_set_margin pp (LTerm.size term).cols; + printer pp out_phrase; + Format.pp_print_flush pp (); + let string = Buffer.contents buffer in + let styled = LTerm_text.of_string string in + let stylise start stop token_style = + for i = start to stop - 1 do + let ch, style = styled.(i) in + styled.(i) <- (ch, LTerm_style.merge token_style style) + done + in + UTop_styles.stylise stylise (UTop_lexer.lex_string string); + Lwt_main.run (LTerm.fprints term styled) + +(* +-----------------------------------------------------------------+ + | Lwt_main.run auto-insertion | + +-----------------------------------------------------------------+ *) + +let longident_lwt_main_run = Longident.Ldot (Longident.Lident "Lwt_main", "run") + +let is_eval = function + | { Parsetree.pstr_desc = Parsetree.Pstr_eval _ } -> true + | _ -> false + +let insert_lwt_main_run phrase = + match phrase with + | Parsetree.Ptop_def pstr -> + let env = !Toploop.toplevel_env in + let lwt_main_run_is_the_real_one = + try + match Env.lookup_value longident_lwt_main_run env with + | Path.Pdot (Path.Pident id, "run", 0), _ -> + Ident.persistent id + | _ -> + false + with Not_found -> + false + in + if lwt_main_run_is_the_real_one && List.exists is_eval pstr then + let tstr, _, _ = Typemod.type_structure env pstr Location.none in + Parsetree.Ptop_def + (List.map2 + (fun pstr_item tstr_item -> + match pstr_item, tstr_item with + | { Parsetree.pstr_desc = Parsetree.Pstr_eval e; Parsetree.pstr_loc = loc }, + Typedtree.Tstr_eval { + Typedtree.exp_type = { + Types.desc = + Types.Tconstr (Path.Pdot (Path.Pident id, "t", -1), _, _) + } + } -> + if Ident.persistent id && Ident.name id = "Lwt" then { + Parsetree.pstr_desc = + Parsetree.Pstr_eval { + Parsetree.pexp_desc = + Parsetree.Pexp_apply + ({ Parsetree.pexp_desc = Parsetree.Pexp_ident longident_lwt_main_run; Parsetree.pexp_loc = loc }, + [("", e)]); + Parsetree.pexp_loc = loc; + }; + Parsetree.pstr_loc = loc; + } else + pstr_item + | _ -> + pstr_item) + pstr tstr) + else + phrase + | Parsetree.Ptop_dir _ -> + phrase + +(* +-----------------------------------------------------------------+ + | Main loop | + +-----------------------------------------------------------------+ *) + +let rec read_phrase term = + try_lwt + (new read_phrase ~term)#run + with Sys.Break -> + lwt () = LTerm.fprintl term "Interrupted." in + read_phrase term + +let update_margin pp cols = + if Format.pp_get_margin pp () <> cols then + Format.pp_set_margin pp cols + +let print_error msg = + lwt term = Lazy.force LTerm.stdout in + lwt () = LTerm.set_style term styles.style_error in + lwt () = Lwt_io.print msg in + lwt () = LTerm.set_style term LTerm_style.none in + LTerm.flush term + +let rec loop term = + (* Reset completion. *) + UTop_complete.reset (); + + (* increment the command counter. *) + UTop_private.set_count (S.value UTop_private.count + 1); + + (* Call hooks. *) + Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks; + + (* Read interactively user input. *) + let phrase_opt = + Lwt_main.run ( + try_lwt + match_lwt read_phrase term with + | UTop.Value phrase -> + return (Some phrase) + | UTop.Error (_, msg) -> + lwt () = print_error msg in + return None + finally + LTerm.flush term + ) + in + + match phrase_opt with + | Some phrase -> + (* Add Lwt_main.run to toplevel evals. *) + let phrase = if UTop.get_auto_run_lwt () then insert_lwt_main_run phrase else 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; + (* No exception can be raised at this stage. *) + ignore (Toploop.execute_phrase true Format.std_formatter phrase); + loop term + | None -> + loop term + +(* +-----------------------------------------------------------------+ + | Welcome message | + +-----------------------------------------------------------------+ *) + +let welcome term = + (* Create a context to render the welcome message. *) + let size = LTerm.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 = Printf.sprintf "Welcome to utop version %s (using OCaml version %s)!" UTop.version Sys.ocaml_version 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 + + (* Move to after the box. *) + lwt () = LTerm.fprint term "\n" in + + LTerm.flush term + +(* +-----------------------------------------------------------------+ + | Classic mode | + +-----------------------------------------------------------------+ *) + +let read_input_classic 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) + +(* +-----------------------------------------------------------------+ + | Emacs mode | + +-----------------------------------------------------------------+ *) + +module Emacs(M : sig end) = struct + + (* Copy standard output, which will be used to send commands. *) + let command_oc = Unix.out_channel_of_descr (Unix.dup Unix.stdout) + + let split_lines str = + let rec aux i j = + if j = String.length str then + [] + else if str.[j] = '\n' then + String.sub str i (j - i) :: aux (j + 1) (j + 1) + else + aux i (j + 1) + in + aux 0 0 + + (* +---------------------------------------------------------------+ + | Sending commands to Emacs | + +---------------------------------------------------------------+ *) + + (* Mutex used to send commands to Emacs. *) + let command_mutex = Mutex.create () + + let send command argument = + Mutex.lock command_mutex; + output_string command_oc command; + output_char command_oc ':'; + output_string command_oc argument; + output_char command_oc '\n'; + flush command_oc; + Mutex.unlock command_mutex + + (* Keep the [utop-phrase-terminator] variable of the emacs part in sync. *) + let () = + S.keep (S.map (send "phrase-terminator") UTop.phrase_terminator) + + (* +---------------------------------------------------------------+ + | Standard outputs redirection | + +---------------------------------------------------------------+ *) + + (* The output of ocaml (stdout and stderr) is redirected so the + emacs parts of utop can recognize it. *) + + (* Continuously copy the output of ocaml to Emacs. *) + let rec copy_output which ic = + let line = input_line ic in + send which line; + copy_output which ic + + (* Create a thread which redirect the given output: *) + let redirect which fd = + let fdr, fdw = Unix.pipe () in + Unix.dup2 fdw fd; + Unix.close fdw; + Thread.create (copy_output which) (Unix.in_channel_of_descr fdr) + + (* Redirects stdout and stderr: *) + let _ = redirect "stdout" Unix.stdout + let _ = redirect "stderr" Unix.stderr + + (* +---------------------------------------------------------------+ + | Loop | + +---------------------------------------------------------------+ *) + + let read_line () = + let behavior = Sys.signal Sys.sigint Sys.Signal_ignore in + try + let line = Lwt_main.run (Lwt_io.read_line_opt Lwt_io.stdin) in + Sys.set_signal Sys.sigint behavior; + line + with exn -> + Sys.set_signal Sys.sigint behavior; + raise exn + + let read_command () = + match read_line () with + | None -> + None + | Some line -> + match try Some (String.index line ':') with Not_found -> None with + | None -> + send "stderr" "':' missing!"; + exit 1 + | Some idx -> + Some (String.sub line 0 idx, String.sub line (idx + 1) (String.length line - (idx + 1))) + + let read_data ?(final_newline = true) () = + let buf = Buffer.create 1024 in + let rec loop first = + match read_command () with + | None -> + send "stderr" "'end' command missing!"; + exit 1 + | Some ("data", data) -> + if not first then Buffer.add_char buf '\n'; + Buffer.add_string buf data; + loop false + | Some ("end", _) -> + if final_newline then Buffer.add_char buf '\n'; + Buffer.contents buf + | Some (command, argument) -> + Printf.ksprintf (send "stderr") "'data' or 'end' command expected, got %S!" command; + exit 1 + in + loop true + + let process_input eos_is_error = + match parse_and_check (read_data ()) eos_is_error with + | UTop.Value phrase -> + send "accept" ""; + (* Add Lwt_main.run to toplevel evals. *) + let phrase = if UTop.get_auto_run_lwt () then insert_lwt_main_run phrase else phrase in + (* No exception can be raised at this stage. *) + ignore (Toploop.execute_phrase true Format.std_formatter phrase) + | UTop.Error (locs, msg) -> + send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs)); + List.iter (send "stderr") (split_lines msg) + + let rec loop () = + (* Reset completion. *) + UTop_complete.reset (); + + (* Increment the command counter. *) + UTop_private.set_count (S.value UTop_private.count + 1); + + (* Call hooks. *) + Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks; + + (* Tell emacs we are ready. *) + send "prompt" ""; + + loop_commands () + + and loop_commands () = + match read_command () with + | None -> + () + | Some ("input", "allow-incomplete") -> + let continue = + try + process_input false; + false + with UTop.Need_more -> + send "continue" ""; + true + in + if continue then + loop_commands () + else + loop () + | Some ("input", "") -> + process_input true; + loop () + | Some ("complete", _) -> + let input = read_data ~final_newline:false () in + let start, words = UTop_complete.complete input in + let words = List.map fst words in + let prefix = LTerm_read_line.common_prefix words in + let index = String.length input - start in + let suffix = + if index > 0 && index <= String.length prefix then + String.sub prefix index (String.length prefix - index) + else + "" + in + if suffix = "" then begin + send "completion-start" ""; + List.iter (fun word -> send "completion" word) words; + send "completion-stop" ""; + end else + send "completion-word" suffix; + loop_commands () + | Some (command, _) -> + Printf.ksprintf (send "stderr") "unrecognized command %S!" command; + exit 1 +end + +(* +-----------------------------------------------------------------+ + | Entry point | + +-----------------------------------------------------------------+ *) + +let emacs_mode = ref false +let preload_objects = ref [] + +let prepare () = + Toploop.set_paths (); + try + let res = List.for_all (Topdirs.load_file Format.err_formatter) (List.rev !preload_objects) in + !Toploop.toplevel_startup_hook (); + res + with exn -> + try + Errors.report_error Format.err_formatter exn; + false + with exn -> + Format.eprintf "Uncaught exception: %s\n" (Printexc.to_string exn); + false + +let read_script_from_stdin () = + let args = Array.sub Sys.argv !Arg.current (Array.length Sys.argv - !Arg.current) in + if prepare () && Toploop.run_script Format.err_formatter "" args then + exit 0 + else + exit 2 + +let file_argument name = + if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma" then + preload_objects := name :: !preload_objects + else begin + let args = Array.sub Sys.argv !Arg.current (Array.length Sys.argv - !Arg.current) in + if prepare () && Toploop.run_script Format.err_formatter name args then + exit 0 + else + exit 2 + end + +let print_version () = + Printf.printf "The universal toplevel for OCaml, version %s, compiled for OCaml version %s\n" UTop.version Sys.ocaml_version; + exit 0 + +let print_version_num () = + Printf.printf "%s\n" UTop.version + +let args = Arg.align [ +#if ocaml_version >= (3, 13, 0) + "-absname", Arg.Set Location.absname, " Show absolute filenames in error message"; +#endif + "-I", Arg.String (fun dir -> Clflags.include_dirs := Misc.expand_directory Config.standard_library dir :: !Clflags.include_dirs), " Add to the list of include directories"; + "-init", Arg.String (fun s -> Clflags.init_file := Some s), " Load instead of default init file"; + "-labels", Arg.Clear Clflags.classic, " Use commuting label mode"; + "-no-app-funct", Arg.Clear Clflags.applicative_functors, " Deactivate applicative functors"; + "-noassert", Arg.Set Clflags.noassert, " Do not compile assertion checks"; + "-nolabels", Arg.Set Clflags.classic, " Ignore non-optional labels in types"; + "-nostdlib", Arg.Set Clflags.no_std_include, " Do not add default directory to the list of include directories"; + "-principal", Arg.Set Clflags.principal, " Check principality of type inference"; + "-rectypes", Arg.Set Clflags.recursive_types, " Allow arbitrary recursive types"; + "-stdin", Arg.Unit read_script_from_stdin, " Read script from standard input"; + "-strict-sequence", Arg.Set Clflags.strict_sequence, " Left-hand part of a sequence must have type unit"; + "-unsafe", Arg.Set Clflags.fast, " Do not compile bounds checking on array and string access"; + "-version", Arg.Unit print_version, " Print version and exit"; + "-vnum", Arg.Unit print_version_num, " Print version number and exit"; + "-w", Arg.String (Warnings.parse_options false), + Printf.sprintf + " Enable or disable warnings according to :\n\ + \ + enable warnings in \n\ + \ - disable warnings in \n\ + \ @ enable warnings in and treat them as errors\n\ + \ can be:\n\ + \ a single warning number\n\ + \ .. a range of consecutive warning numbers\n\ + \ a predefined set\n\ + \ default setting is %S" Warnings.defaults_w; + "-warn-error", Arg.String (Warnings.parse_options true), + Printf.sprintf + " Enable or disable error status for warnings according to \n\ + \ See option -w for the syntax of .\n\ + \ 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"; +] + +let usage = "Usage: utop [script-file [arguments]]\noptions are:" + +let common_init () = + (* Initializes toplevel environment. *) + Toploop.initialize_toplevel_env (); + (* Set the global input name. *) + Location.input_name := UTop.input_name; + (* Make sure SIGINT is catched while executing OCaml code. *) + Sys.catch_break true; + (* Load user's .ocamlinit file. *) + match !Clflags.init_file with + | Some fn -> + if Sys.file_exists fn then + ignore (Toploop.use_silently Format.err_formatter fn) + else + Printf.eprintf "Init file not found: \"%s\".\n" fn + | None -> + if Sys.file_exists ".ocamlinit" then + ignore (Toploop.use_silently Format.err_formatter ".ocamlinit") + else + let fn = Filename.concat LTerm_resources.home ".ocamlinit" in + if Sys.file_exists fn then + ignore (Toploop.use_silently Format.err_formatter fn) + +let main () = + Arg.parse args file_argument usage; + if not (prepare ()) then exit 2; + if !emacs_mode then begin + UTop_private.set_ui UTop_private.Emacs; + let module Emacs = Emacs (struct end) in + Printf.printf "Welcome to utop version %s (using OCaml version %s)!\n\n%!" UTop.version Sys.ocaml_version; + common_init (); + Emacs.loop () + end else begin + UTop_private.set_ui UTop_private.Console; + let term = Lwt_main.run (Lazy.force LTerm.stdout) in + if LTerm.incoming_is_a_tty term && LTerm.outgoing_is_a_tty term then begin + (* Set the initial size. *) + UTop_private.set_size (S.const (LTerm.size term)); + (* Install our out phrase printer. *) + Toploop.print_out_phrase := print_out_phrase term !Toploop.print_out_phrase; + (* Load user data. *) + Lwt_main.run (join [init_history (); UTop_styles.load (); LTerm_inputrc.load ()]); + (* Display a welcome message. *) + Lwt_main.run (welcome term); + (* Common initialization. *) + common_init (); + (* Print help message. *) + print_string "\nType #utop_help for help about using utop.\n\n"; + flush stdout; + (* Main loop. *) + try + loop term + with LTerm_read_line.Interrupt -> + () + end else begin + (* Use the standard toplevel. Just make sure that Lwt threads can + run while reading phrases. *) + Toploop.read_interactive_input := read_input_classic; + Toploop.loop Format.std_formatter + end + end; + (* Don't let the standard toplevel run... *) + exit 0 diff --git a/src/lib/uTop_main.mli b/src/lib/uTop_main.mli new file mode 100644 index 0000000..b3b9606 --- /dev/null +++ b/src/lib/uTop_main.mli @@ -0,0 +1,11 @@ +(* + * uTop_main.mli + * ------------- + * Copyright : (c) 2012, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +val main : unit -> unit + (** Start utop. *) diff --git a/src/common/uTop_private.ml b/src/lib/uTop_private.ml similarity index 65% rename from src/common/uTop_private.ml rename to src/lib/uTop_private.ml index be491c7..4a87469 100644 --- a/src/common/uTop_private.ml +++ b/src/lib/uTop_private.ml @@ -11,16 +11,16 @@ 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) + (S.switch (S.const { LTerm_geom.rows = 25; LTerm_geom.cols = 80 }) ev, set_size) let key_sequence, set_key_sequence = let ev, set_key_sequence = E.create () in (S.switch (S.const ([] : LTerm_key.t list)) ev, set_key_sequence) -let count, set_count = S.create(-1) +let count, set_count = S.create (-1) -type ui = Console | GTK | Emacs +type ui = Console | Emacs let ui, set_ui = S.create Console -let exec_in_gui : ((unit -> unit) -> unit) ref = ref (fun f -> f ()) +let error_style = ref LTerm_style.none diff --git a/src/common/uTop_styles.ml b/src/lib/uTop_styles.ml similarity index 99% rename from src/common/uTop_styles.ml rename to src/lib/uTop_styles.ml index d2bbde2..07fbdc4 100644 --- a/src/common/uTop_styles.ml +++ b/src/lib/uTop_styles.ml @@ -82,6 +82,7 @@ let load () = | "dark" -> UTop.set_profile UTop.Dark | "" -> () | str -> raise (LTerm_resources.Error (Printf.sprintf "invalid profile %S" str))); + UTop_private.error_style := styles.style_error; return () with Unix.Unix_error(Unix.ENOENT, _, _) -> return () diff --git a/src/common/uTop_styles.mli b/src/lib/uTop_styles.mli similarity index 100% rename from src/common/uTop_styles.mli rename to src/lib/uTop_styles.mli diff --git a/src/common/uTop_token.ml b/src/lib/uTop_token.ml similarity index 100% rename from src/common/uTop_token.ml rename to src/lib/uTop_token.ml diff --git a/src/lib/uTop_version.ml.ab b/src/lib/uTop_version.ml.ab new file mode 100644 index 0000000..dbe78f7 --- /dev/null +++ b/src/lib/uTop_version.ml.ab @@ -0,0 +1,10 @@ +(* + * uTop_version.ml.ab + * ------------------ + * Copyright : (c) 2012, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +let version = "$(pkg_version)" diff --git a/src/top/uTop_start.ml b/src/top/uTop_start.ml new file mode 100644 index 0000000..305785b --- /dev/null +++ b/src/top/uTop_start.ml @@ -0,0 +1,10 @@ +(* + * uTop_start.ml + * ------------- + * Copyright : (c) 2012, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +let () = UTop_main.main () diff --git a/src/top/uTop_top.mltop b/src/top/uTop_top.mltop new file mode 100644 index 0000000..ad35180 --- /dev/null +++ b/src/top/uTop_top.mltop @@ -0,0 +1 @@ +UTop_start diff --git a/src/emacs/utop.el b/src/top/utop.el similarity index 77% rename from src/emacs/utop.el rename to src/top/utop.el index 1df8e0d..30e6a10 100644 --- a/src/emacs/utop.el +++ b/src/top/utop.el @@ -48,7 +48,7 @@ with Emacs to provide an enhanced environment." :version "1.0" :group 'applications) -(defcustom utop-command "utop-emacs" +(defcustom utop-command "utop" "The command to execute for utop." :type 'string :group 'utop) @@ -70,7 +70,8 @@ This hook is only run if exiting actually kills the buffer." :group 'utop) (defface utop-prompt - '((t (:foreground "Cyan1"))) + '((((background dark)) (:foreground "Cyan1")) + (((background light)) (:foreground "blue"))) "The face used to highlight the prompt." :group 'utop) @@ -81,13 +82,18 @@ This hook is only run if exiting actually kills the buffer." (defface utop-stderr nil - "The face used to highlight messages commong from stderr." + "The face used to highlight messages comming from stderr." :group 'utop) (defface utop-frozen '((t (:bold t))) "The face used to highlight text that has been sent to utop.") +(defface utop-error + '((t (:foreground "#ff4040" :bold t :underline t))) + "The face used to highlight errors in phrases." + :group 'utop) + ;; +-----------------------------------------------------------------+ ;; | Constants | ;; +-----------------------------------------------------------------+ @@ -107,9 +113,9 @@ This hook is only run if exiting actually kills the buffer." (defvar utop-mode-map (let ((map (make-sparse-keymap))) - (define-key map [return] 'utop-send-input) - (define-key map [(control ?m)] 'utop-send-input) - (define-key map [(control ?j)] 'utop-send-input) + (define-key map [return] 'utop-eval-input-or-newline) + (define-key map [(control ?m)] 'utop-eval-input-or-newline) + (define-key map [(control ?j)] 'utop-eval-input-or-newline) (define-key map [home] 'utop-bol) (define-key map [(control ?a)] 'utop-bol) (define-key map [(meta ?p)] 'utop-history-goto-prev) @@ -127,9 +133,6 @@ This hook is only run if exiting actually kills the buffer." (defvar utop-prompt-max 0 "The point at the end of the current prompt.") -(defvar utop-last-prompt 0 - "The contents of the last displayed prompt.") - (defvar utop-output "" "The output of the utop sub-process not yet processed.") @@ -145,9 +148,6 @@ This hook is only run if exiting actually kills the buffer." (defvar utop-history-next nil "The history after the cursor.") -(defvar utop-pending nil - "The text not yet added to the history.") - (defvar utop-completion nil "Current completion.") @@ -166,6 +166,16 @@ before the end of prompt.") (defvar utop-initial-command nil "Initial phrase to evaluate.") +(defvar utop-phrase-terminator ";;" + "The OCaml phrase terminator.") + +(defvar utop-pending-input nil + "The phrase to add to history if it is accepted by OCaml.") + +(defvar utop-pending-position nil + "The position of the cursor in the phrase sent to OCaml (where +to add the newline character if it is not accepted).") + ;; +-----------------------------------------------------------------+ ;; | Utils | ;; +-----------------------------------------------------------------+ @@ -318,6 +328,16 @@ before the end of prompt.") ;; Move the point to the end of buffer in all utop windows (utop-goto-point-max-all-windows)) +(defun utop-insert-phrase-terminator () + "Insert the phrase terminator at the end of buffer." + ;; Search the longest suffix of the input which is a prefix of the + ;; phrase terminator + (let* ((end (point-max)) (pos (max utop-prompt-max (- end (length utop-phrase-terminator))))) + (while (not (string-prefix-p (buffer-substring-no-properties pos end) utop-phrase-terminator)) + (setq pos (1+ pos))) + ;; Insert only the missing part + (insert (substring utop-phrase-terminator (- end pos))))) + (defun utop-process-line (line) "Process one line from the utop sub-process." ;; Extract the command and its argument @@ -330,20 +350,15 @@ before the end of prompt.") ;; Output on stderr ((string= command "stderr") (utop-insert-output argument 'utop-stderr)) + ;; Synchronisation of the phrase terminator + ((string= command "phrase-terminator") + (setq utop-phrase-terminator argument)) ;; A new prompt ((string= command "prompt") (let ((prompt (apply utop-prompt ()))) - ;; Push pending input to the history if it is different from - ;; the top of the history - (when (and utop-pending (or (null utop-history) (not (string= utop-pending (car utop-history))))) - (push utop-pending utop-history)) - ;; Clear pending input - (setq utop-pending nil) ;; Reset history (setq utop-history-prev utop-history) (setq utop-history-next nil) - ;; Save current prompt - (setq utop-last-prompt prompt) ;; Insert the new prompt (utop-insert-prompt prompt) ;; Increment the command number @@ -351,16 +366,42 @@ before the end of prompt.") ;; Send the initial command if any (when utop-initial-command (goto-char (point-max)) - (insert utop-initial-command ";;") + (insert utop-initial-command) + (utop-insert-phrase-terminator) (setq utop-initial-command nil) - (utop-send-input)))) - ;; Continuation of previous input + (utop-eval-input)))) + ;; Input has been accepted + ((string= command "accept") + ;; Push input to the history if it is different from the top + ;; of the history + (when (or (null utop-history) (not (string= utop-pending-input (car utop-history)))) + (push utop-pending-input utop-history)) + ;; Add a newline character at the end of the buffer + (goto-char (point-max)) + (insert "\n") + ;; Make input frozen + (add-text-properties utop-prompt-max (point-max) '(face utop-frozen)) + ;; Highlight errors + (let ((offsets (split-string argument "," t))) + (while offsets + (let ((a (string-to-int (car offsets))) + (b (string-to-int (car (cdr offsets))))) + (add-text-properties (+ utop-prompt-max a) (+ utop-prompt-max b) '(face utop-error)) + (setq offsets (cdr (cdr offsets)))))) + ;; Make everything read-only + (add-text-properties (point-min) (point-max) utop-non-editable-properties) + ;; Advance the prompt + (setq utop-prompt-min (point-max)) + (setq utop-prompt-max (point-max))) + ;; Continue editiong ((string= command "continue") - ;; Reset history - (setq utop-history-prev utop-history) - (setq utop-history-next nil) - ;; Insert the last prompt - (utop-insert-prompt utop-last-prompt)) + ;; Add a newline character at the position where the user + ;; pressed enter + (when utop-pending-position + (goto-char (+ utop-prompt-max utop-pending-position)) + (insert "\n")) + ;; Reset the state + (set-utop-state 'edit)) ;; Complete with a word ((string= command "completion-word") (set-utop-state 'edit) @@ -402,53 +443,57 @@ before the end of prompt.") ;; | Sending data to the utop sub-process | ;; +-----------------------------------------------------------------+ -(defun utop-send-input () - "Send the text typed at current prompt to the utop -sub-process." - (interactive) - (with-current-buffer utop-buffer-name - (when (eq utop-state 'edit) - (utop-perform - ;; We are now waiting for ocaml - (set-utop-state 'wait) - ;; Push input to pending input - (let ((input (buffer-substring-no-properties utop-prompt-max (point-max)))) - (if utop-pending - (setq utop-pending (concat utop-pending "\n" input)) - (setq utop-pending input)) - ;; Goto the end of the buffer - (goto-char (point-max)) - ;; Terminate input by a newline - (insert "\n") - ;; Move the point to the end of buffer of all utop windows - (utop-goto-point-max-all-windows) - ;; Make everything read-only - (add-text-properties (point-min) (point-max) utop-non-editable-properties) - (let ((start utop-prompt-max) (stop (point-max))) - ;; Set the frozen face for the text we just sent. - (add-text-properties start stop '(face utop-frozen)) - ;; Move the prompt to the end of the buffer - (setq utop-prompt-min stop) - (setq utop-prompt-max stop) - ;; Send all lines to utop - (let ((lines (split-string input "\n"))) - (process-send-string utop-process "input:\n") - (while lines - ;; Send the line - (process-send-string utop-process (concat "data:" (car lines) "\n")) - ;; Remove it and continue - (setq lines (cdr lines))) - (process-send-string utop-process "end:\n")))))))) +(defun utop-eval-input (&optional allow-incomplete auto-end) + "Send the current input to the utop process and let ocaml +evaluate it. -(defun utop-end-phrase-and-send-input () - "End the current phrase and send it to ocaml." +If ALLOW-INCOMPLETE is non-nil and the phrase is not terminated, +then a newline character will be inserted and edition will +continue. + +If AUTO-END is non-nill then ALLOW-INCOMPLETE is ignored and a +phrase terminator (;; or ; if using revised syntax) will be +automatically inserted by utop." (interactive) (with-current-buffer utop-buffer-name (when (eq utop-state 'edit) - (goto-char (point-max)) - (when (= utop-prompt-max (point-max)) (insert "()")) - (insert ";;") - (utop-send-input)))) + ;; Clear saved pending position + (setq utop-pending-position nil) + ;; Insert the phrase terminator if requested + (cond + (auto-end + (utop-insert-phrase-terminator)) + (allow-incomplete + ;; Save cursor position + (setq utop-pending-position (- (point) utop-prompt-max)) + ;; If the point is before the prompt, insert the newline + ;; character at the end + (when (< utop-pending-position 0) + (setq utop-pending-position (- (point) utop-prompt-max))))) + (let* ((input (buffer-substring-no-properties utop-prompt-max (point-max))) + (lines (split-string input "\n"))) + ;; Save for history + (setq utop-pending-input input) + ;; We are now waiting for ocaml + (set-utop-state 'wait) + ;; Send all lines to utop + (process-send-string utop-process (if (and allow-incomplete (not auto-end)) "input:allow-incomplete\n" "input:\n")) + (while lines + ;; Send the line + (process-send-string utop-process (concat "data:" (car lines) "\n")) + ;; Remove it and continue + (setq lines (cdr lines))) + (process-send-string utop-process "end:\n"))))) + +(defun utop-eval-input-or-newline () + "Same as (`utop-eval-input' t nil)." + (interactive) + (utop-eval-input t nil)) + +(defun utop-eval-input-auto-end () + "Same as (`utop-eval-input' nil t)." + (interactive) + (utop-eval-input nil t)) ;; +-----------------------------------------------------------------+ ;; | Completion | @@ -518,9 +563,10 @@ sub-process." ((eq utop-state 'edit) ;; Insert it at the end of the utop buffer (goto-char (point-max)) - (insert text ";;") - ;; Send input to utop now - (utop-send-input)) + (insert text) + ;; Send input to utop now, telling it to automatically add the + ;; phrase terminator + (utop-eval-input nil t)) ((eq utop-state 'wait) ;; utop is starting, save the initial command to send (setq utop-initial-command text)))))) @@ -624,6 +670,54 @@ To automatically do that just add these lines to your .emacs: ;; Make the whole buffer read-only (add-text-properties (point-min) (point-max) utop-non-editable-properties))))))))) +;; +-----------------------------------------------------------------+ +;; | ocamlfind package loading | +;; +-----------------------------------------------------------------+ + +(defun utop-ocamlfind-list-packages () + "Return the list of all findlib packages with their version." + (let ((lines (split-string (shell-command-to-string "ocamlfind list") "[ \t]*\r?\n"))) + (let ((packages)) + ;; Split lines and extract package names and versions + (mapc + (lambda (line) + (when (string-match "\\([^ \t(]*\\)[ \t]*(version:[ \t]*\\([^)]*\\))" line) + (push (cons (match-string 1 line) (match-string 2 line)) packages))) + lines) + (nreverse packages)))) + +(defun utop-require () + "Show the list of findlib packages." + (interactive) + ;; Get the list of packages + (let ((packages (utop-ocamlfind-list-packages))) + (save-excursion + (with-output-to-temp-buffer "*Findlib packages*" + (set-buffer standard-output) + (let ((inhibit-read-only t)) + (insert "Choose a findlib package to load:\n\n") + (let ((max-name-length 0)) + ;; Find the longest package name + (mapc + (lambda (package) + (setq max-name-length (max max-name-length (length (car package))))) + packages) + (setq max-name-length (1+ (max max-name-length 16))) + ;; Insert headers + (insert "Package name") + (insert-char 32 (- max-name-length 12)) + (insert "Version\n") + ;; Insert buttons + (while packages + (let* ((package (car packages)) + (name (car package)) + (version (cdr package))) + (insert-text-button name 'face nil) + (insert-char 32 (- max-name-length (length name))) + (insert version "\n")) + (setq packages (cdr packages))) + (goto-char (point-min)))))))) + ;; +-----------------------------------------------------------------+ ;; | Menu | ;; +-----------------------------------------------------------------+ @@ -649,7 +743,7 @@ To automatically do that just add these lines to your .emacs: ["Start OCaml" utop t] ["Interrupt OCaml" utop-interrupt :active (utop-is-running)] ["Kill OCaml" utop-kill :active (utop-is-running)] - ["Evaluate Phrase" utop-end-phrase-and-send-input :active (and (utop-is-running) (eq utop-state 'edit))] + ["Evaluate Phrase" utop-eval-input-auto-end :active (and (utop-is-running) (eq utop-state 'edit))] "---" ["Customize utop" (customize-group 'utop) t] "---" @@ -675,7 +769,7 @@ To automatically do that just add these lines to your .emacs: (setq utop-completion nil) ;; Create the sub-process - (setq utop-process (start-process "utop" (current-buffer) utop-command)) + (setq utop-process (start-process "utop" (current-buffer) utop-command "-emacs")) ;; Filter the output of the sub-process with our filter function (set-process-filter utop-process 'utop-process-output) @@ -706,6 +800,9 @@ To automatically do that just add these lines to your .emacs: (make-local-variable 'utop-inhibit-check) (make-local-variable 'utop-state) (make-local-variable 'utop-initial-command) + (make-local-variable 'utop-phrase-terminator) + (make-local-variable 'utop-pending-input) + (make-local-variable 'utop-pending-position) ;; Set the major mode (setq major-mode 'utop-mode) diff --git a/syntax/pa_optcomp.ml b/syntax/pa_optcomp.ml index 5d511e8..7b4d9f4 100644 --- a/syntax/pa_optcomp.ml +++ b/syntax/pa_optcomp.ml @@ -70,7 +70,7 @@ let env = ref Env.empty let define id value = env := Env.add id value !env let _ = - define "ocaml_version" (Scanf.sscanf Sys.ocaml_version "%d.%d" (fun major minor -> Tuple [Int major; Int minor])) + define "ocaml_version" (Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun major minor patchlevel -> Tuple [Int major; Int minor; Int patchlevel])) let dirs = ref [] let add_include_dir dir = dirs := dir :: !dirs diff --git a/utoprc-dark b/utoprc-dark index c1a0d78..7a73d2c 100644 --- a/utoprc-dark +++ b/utoprc-dark @@ -15,7 +15,7 @@ symbol.foreground: x-cyan1 string.foreground: x-light-salmon char.foreground: x-light-salmon quotation.foreground: x-purple -error.foreground: x-red +error.foreground: red directive.foreground: x-lightsteelblue parenthesis.background: blue diff --git a/utoprc-light b/utoprc-light index d232007..2235e06 100644 --- a/utoprc-light +++ b/utoprc-light @@ -15,7 +15,7 @@ symbol.foreground: x-purple string.foreground: x-violetred4 char.foreground: x-violetred4 quotation.foreground: x-purple -error.foreground: x-red +error.foreground: red directive.foreground: x-mediumorchid4 parenthesis.background: light-blue