diff --git a/src/uTop.ml b/src/uTop.ml index fd36dd6..3795465 100644 --- a/src/uTop.ml +++ b/src/uTop.ml @@ -13,6 +13,21 @@ open LTerm_text open LTerm_geom open LTerm_style +module String_set = Set.Make(String) + +let default_keywords = [ + "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; + "done"; "downto"; "else"; "end"; "exception"; "external"; + "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; + "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module"; + "mutable"; "new"; "object"; "of"; "open"; "private"; "rec"; "sig"; + "struct"; "then"; "to"; "try"; "type"; "val"; "virtual"; + "when"; "while"; "with"; "try_lwt"; "finally"; "for_lwt"; "lwt"; +] + +let keywords = ref (List.fold_left (fun set kwd -> String_set.add kwd set) String_set.empty default_keywords) +let add_keyword kwd = keywords := String_set.add kwd !keywords + let size = UTop_private.size let count = UTop_private.count @@ -39,6 +54,7 @@ let make_prompt count size = let prompt = ref (S.l2 make_prompt count size) let prompt_continue = ref (S.const [|(UChar.of_char '>', { none with foreground = Some lgreen }); (UChar.of_char ' ', LTerm_style.none)|]) +let prompt_comment = ref (S.const [|(UChar.of_char '*', { none with foreground = Some lgreen }); (UChar.of_char ' ', LTerm_style.none)|]) let () = (* Do not load packages linked with the toplevel. *) diff --git a/src/uTop.mli b/src/uTop.mli index 636367b..803b2a8 100644 --- a/src/uTop.mli +++ b/src/uTop.mli @@ -12,16 +12,31 @@ 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. *) + (** {6 Console specific configuration} *) val size : LTerm_geom.size React.signal (** The current size of the terminal. *) val prompt : LTerm_text.t React.signal ref - (** The current prompt. For compatibility with ocaml, it must ends - with a line of length 2. *) + (** The current prompt. + + For compatibility with ocaml error printing, it must ends with a + line of length 2. *) val prompt_continue : LTerm_text.t React.signal ref - (** The prompt used to continue unterminated commands. For - compatibility with ocaml, it must ends with a line of length - 2. *) + (** The prompt used to continue unterminated phrase. + + For compatibility with ocaml error printing, it must ends with a + line of length 2. *) + +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. *) diff --git a/src/uTop_console.ml b/src/uTop_console.ml index 9f42757..7a2472f 100644 --- a/src/uTop_console.ml +++ b/src/uTop_console.ml @@ -13,21 +13,59 @@ open Lwt open Lwt_react open LTerm_text open LTerm_geom +open UTop_token + +module String_set = Set.Make(String) (* +-----------------------------------------------------------------+ - | The read-line class | + | Resources | +-----------------------------------------------------------------+ *) -class read_line ~term ~history ~prompt = object(self) - inherit LTerm_read_line.read_line ~history () - inherit [Zed_utf8.t] LTerm_read_line.term term +type styles = { + mutable style_keyword : LTerm_style.t; + mutable style_symbol : LTerm_style.t; + mutable style_ident : LTerm_style.t; + mutable style_constant : LTerm_style.t; + mutable style_char : LTerm_style.t; + mutable style_string : LTerm_style.t; + mutable style_quotation : LTerm_style.t; + mutable style_comment : LTerm_style.t; + mutable style_doc : LTerm_style.t; + mutable style_blanks : LTerm_style.t; + mutable style_error : LTerm_style.t; +} - initializer - (* Set the source signal for the size of the terminal. *) - UTop_private.set_size self#size; - (* Set the prompt. *) - self#set_prompt prompt -end +let styles = { + style_keyword = LTerm_style.none; + style_symbol = LTerm_style.none; + style_ident = LTerm_style.none; + style_constant = LTerm_style.none; + style_char = LTerm_style.none; + style_string = LTerm_style.none; + style_quotation = LTerm_style.none; + style_comment = LTerm_style.none; + style_doc = LTerm_style.none; + style_blanks = LTerm_style.none; + style_error = LTerm_style.none; +} + +let init_resources () = + try_lwt + lwt res = LTerm_resources.load (Filename.concat (try Sys.getenv "HOME" with Not_found -> "") ".utoprc") in + styles.style_keyword <- LTerm_resources.get_style "keyword" res; + styles.style_symbol <- LTerm_resources.get_style "symbol" res; + styles.style_ident <- LTerm_resources.get_style "identifier" res; + styles.style_constant <- LTerm_resources.get_style "constant" res; + styles.style_char <- LTerm_resources.get_style "char" res; + styles.style_string <- LTerm_resources.get_style "string" res; + styles.style_quotation <- LTerm_resources.get_style "quotation" res; + styles.style_comment <- LTerm_resources.get_style "comment" res; + styles.style_doc <- LTerm_resources.get_style "doc" res; + styles.style_blanks <- LTerm_resources.get_style "blanks" res; + styles.style_error <- LTerm_resources.get_style "error" res; + return () + with Unix.Unix_error(Unix.ENOENT, _, _) -> + return () (* +-----------------------------------------------------------------+ | History | @@ -35,12 +73,79 @@ end let history = ref [] -let () = +let init_history () = let hist_name = Filename.concat (try Sys.getenv "HOME" with Not_found -> "") ".utop-history" in (* Save history on exit. *) Lwt_main.at_exit (fun () -> LTerm_read_line.save_history hist_name !history); (* Load history. *) - history := Lwt_main.run (LTerm_read_line.load_history hist_name) + 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 "" + +class read_line ~term ~prompt = object(self) + inherit LTerm_read_line.read_line ~history:!history () as super + inherit [Zed_utf8.t] LTerm_read_line.term term + + method stylise = + let styled, position = super#stylise in + let tokens = UTop_lexer.lex_string (!pending ^ LTerm_text.to_string styled) in + let rec loop ofs_a tokens = + match tokens with + | [] -> + () + | (token, src) :: rest -> + let token_style = + match token with + | Symbol -> styles.style_symbol + | Lident -> if String_set.mem src !UTop.keywords then styles.style_keyword else styles.style_ident + | Uident -> styles.style_ident + | Constant -> styles.style_constant + | Char -> styles.style_char + | String -> styles.style_string + | Quotation -> styles.style_quotation + | Comment -> styles.style_comment + | Doc -> styles.style_doc + | Blanks -> styles.style_blanks + | Error -> styles.style_error + in + let ofs_b = ofs_a + Zed_utf8.length src in + for i = ofs_a to ofs_b - 1 do + let ch, style = styled.(i) in + styled.(i) <- (ch, LTerm_style.merge token_style style) + done; + loop ofs_b rest + in + let pending_length = Zed_utf8.length !pending in + let rec skip idx tokens = + match tokens with + | [] -> + assert false + | (token, src) :: rest -> + let len = Zed_utf8.length src in + let idx' = idx + len in + if idx' = pending_length then + loop 0 rest + else if idx' > pending_length then + loop 0 ((token, Zed_utf8.sub src (pending_length - idx) (len - (pending_length - idx))) :: rest) + else + skip idx' rest + in + if pending_length = 0 then loop 0 tokens else skip 0 tokens; + (styled, position) + + initializer + (* Set the source signal for the size of the terminal. *) + UTop_private.set_size self#size; + (* Set the prompt. *) + self#set_prompt prompt +end (* +-----------------------------------------------------------------+ | Toplevel integration | @@ -52,9 +157,6 @@ let input = ref "" (* The position of the text already sent to ocaml in {!input}. *) let pos = ref 0 -(* The pending line to add to the history. *) -let pending = ref "" - (* The read function given to ocaml. *) let rec read_input term prompt buffer len = try @@ -62,24 +164,30 @@ let rec read_input term prompt buffer len = (* We need to get more input from the user. *) let prompt_to_display = - if prompt = "# " then begin - (* This is a new command. *) + match prompt with + | "# " -> + (* increment the command counter. *) + UTop_private.set_count (S.value UTop_private.count + 1); - (* increment the command counter. *) - UTop_private.set_count (S.value UTop_private.count + 1); + (* Add the previous line to the history. *) + history := LTerm_read_line.add_entry !pending !history; + pending := ""; - (* Add the previous line to the history. *) - history := LTerm_read_line.add_entry !pending !history; - pending := ""; + !UTop.prompt - !UTop.prompt - end else - !UTop.prompt_continue + | "* " -> + !UTop.prompt_comment + + | " " -> + !UTop.prompt_continue + + | _ -> + Printf.ksprintf failwith "unknown prompt %S" prompt in (* Read interactively user input. *) let txt = Lwt_main.run ( - lwt txt = (new read_line ~term ~history:!history ~prompt:prompt_to_display)#run in + lwt txt = (new read_line ~term ~prompt:prompt_to_display)#run in lwt () = LTerm.flush term in return txt ) in @@ -104,10 +212,6 @@ let rec read_input term prompt buffer len = with LTerm_read_line.Interrupt -> (0, true) -(* +-----------------------------------------------------------------+ - | Integration for when the input is not a terminal | - +-----------------------------------------------------------------+ *) - let read_input_non_interactive prompt buffer len = let rec loop i = if i = len then @@ -125,7 +229,7 @@ let read_input_non_interactive prompt buffer len = in Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >> loop 0) -lwt () = +let init_read_interactive_input () = (* If standard channels are connected to a tty, use interactive read-line and display a welcome message: *) if Unix.isatty Unix.stdin && Unix.isatty Unix.stdout then begin @@ -164,3 +268,13 @@ lwt () = Toploop.read_interactive_input := read_input_non_interactive; return () end + +(* +-----------------------------------------------------------------+ + | Initialization | + +-----------------------------------------------------------------+ *) + +lwt () = join [ + init_history (); + init_resources (); + init_read_interactive_input (); +] diff --git a/src/uTop_console_top.mltop b/src/uTop_console_top.mltop index 20d7e64..2797b35 100644 --- a/src/uTop_console_top.mltop +++ b/src/uTop_console_top.mltop @@ -1 +1,3 @@ UTop_console +UTop_lexer +UTop_token diff --git a/src/uTop_lexer.mll b/src/uTop_lexer.mll new file mode 100644 index 0000000..0d1f331 --- /dev/null +++ b/src/uTop_lexer.mll @@ -0,0 +1,161 @@ +(* + * uTop_lexer.mll + * -------------- + * Copyright : (c) 2011, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +(* Lexer for the OCaml language. *) + +{ + open UTop_token +} + +let uchar = ['\x00' - '\x7f'] | _ [ '\x80' - '\xbf' ]* + +let blank = [' ' '\009' '\012'] +let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] +let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] +let identchar = + ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] +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' '_']* +let hex_literal = + '0' ['x' 'X'] hexa_char ['0'-'9' 'A'-'F' 'a'-'f' '_']* +let oct_literal = + '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* +let bin_literal = + '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* +let int_literal = + decimal_literal | hex_literal | oct_literal | bin_literal +let float_literal = + ['0'-'9'] ['0'-'9' '_']* + ('.' ['0'-'9' '_']* )? + (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? + +let safe_delimchars = ['%' '&' '/' '@' '^'] + +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 + | ('\n' | blank)+ + { Blanks } + | "true" + { Constant } + | "false" + { Constant } + | lowercase identchar* + { Lident } + | uppercase identchar* + { Uident } + | int_literal "l" + { Constant } + | int_literal "L" + { Constant } + | int_literal "n" + { Constant } + | int_literal + { Constant } + | float_literal + { Constant } + | '"' + { string lexbuf; String } + | "'" [^'\'' '\\'] "'" + { Char } + | "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\'' 'x' '0'-'9'] eof + { Char } + | "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] "'" + { Char } + | "'\\" (['0'-'9'] ['0'-'9'] | 'x' hexa_char) eof + { Char } + | "'\\" (['0'-'9'] ['0'-'9'] ['0'-'9'] | 'x' hexa_char hexa_char) eof + { Char } + | "'\\" (['0'-'9'] ['0'-'9'] ['0'-'9'] | 'x' hexa_char hexa_char) "'" + { Char } + | "'\\" uchar + { Error } + | "(**" + { comment 0 lexbuf; Doc } + | "(*" + { comment 0 lexbuf; Comment } + | '<' (':' ident)? ('@' locname)? '<' + { quotation lexbuf; Quotation } + | ( "#" | "`" | "'" | "," | "." | ".." | ":" | "::" + | ":=" | ":>" | ";" | ";;" | "_" + | left_delimitor | right_delimitor ) + { Symbol } + | ['~' '?' '!' '=' '<' '>' '|' '&' '@' '^' '+' '-' '*' '/' '%' '\\' '$'] symbolchar* + { Symbol } + | uchar + { Error } + | eof + { raise End_of_file } + +and comment depth = parse + | "(*" + { comment (depth + 1) lexbuf } + | "*)" + { if depth > 0 then comment (depth - 1) lexbuf } + | uchar + { comment depth lexbuf } + | eof + { () } + +and string = parse + | '"' + { () } + | "\\\"" + { string lexbuf } + | uchar + { string lexbuf } + | eof + { () } + +and quotation = parse + | ">>" + { () } + | uchar + { quotation lexbuf } + | eof + { () } + +{ + let lex_string str = + let lexbuf = Lexing.from_string str in + let rec loop ofs_a = + match try Some (token lexbuf) with End_of_file -> None with + | Some token -> + let ofs_b = Lexing.lexeme_end lexbuf in + (token, String.sub str ofs_a (ofs_b - ofs_a)) :: loop ofs_b + | None -> + [] + in + loop 0 +} diff --git a/src/uTop_token.ml b/src/uTop_token.ml new file mode 100644 index 0000000..4efe789 --- /dev/null +++ b/src/uTop_token.ml @@ -0,0 +1,21 @@ +(* + * uTop_token.ml + * ------------- + * Copyright : (c) 2011, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of utop. + *) + +type t = + | Symbol + | Lident + | Uident + | Constant + | Char + | String + | Quotation + | Comment + | Doc + | Blanks + | Error diff --git a/utoprc-dark b/utoprc-dark new file mode 100644 index 0000000..57224c1 --- /dev/null +++ b/utoprc-dark @@ -0,0 +1,14 @@ +! -*- conf-xdefaults -*- + +! Copy this file to ~/.utoprc + +identifier.foreground: none +comment.foreground: x-chocolate1 +doc.foreground: x-light-salmon +constant.foreground: x-aquamarine +keyword.foreground: x-cyan1 +symbol.foreground: x-cyan1 +string.foreground: x-light-salmon +char.foreground: x-light-salmon +quotation.foreground: x-purple +error.foreground: x-red diff --git a/utoprc-light b/utoprc-light new file mode 100644 index 0000000..55f5941 --- /dev/null +++ b/utoprc-light @@ -0,0 +1,14 @@ +! -*- conf-xdefaults -*- + +! Copy this file to ~/.utoprc + +identifier.foreground: none +comment.foreground: x-firebrick +doc.foreground: x-rosybrown +constant.foreground: x-cadetblue +keyword.foreground: x-purple +symbol.foreground: x-purple +string.foreground: x-rosybrown +char.foreground: x-rosybrown +quotation.foreground: x-purple +error.foreground: x-red