add colors

Ignore-this: e67c18ee1f58d9af23b0a53af74f09d5

darcs-hash:20110726221146-c41ad-60551b96cbfff4cbb301fac6fa868ce0b0e22c42

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. *)

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
+  (** The current prompt.
-      with a line of length 2. *)
+
+      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
+  (** The prompt used to continue unterminated phrase.
-      compatibility with ocaml, it must ends with a line of length
+
-      2. *)
+      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. *)

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)
+type styles = {
-  inherit LTerm_read_line.read_line ~history ()
+  mutable style_keyword : LTerm_style.t;
-  inherit [Zed_utf8.t] LTerm_read_line.term term
+  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
+let styles = {
-    (* Set the source signal for the size of the terminal. *)
+  style_keyword = LTerm_style.none;
-    UTop_private.set_size self#size;
+  style_symbol = LTerm_style.none;
-    (* Set the prompt. *)
+  style_ident = LTerm_style.none;
-    self#set_prompt prompt
+  style_constant = LTerm_style.none;
-end
+  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,9 +164,8 @@ 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
+        match prompt with
-          (* This is a new command. *)
+          | "# " ->
-
               (* increment the command counter. *)
               UTop_private.set_count (S.value UTop_private.count + 1);
 
@@ -73,13 +174,20 @@ let rec read_input term prompt buffer len =
               pending := "";
 
               !UTop.prompt
-        end else
+
+          | "* " ->
+              !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 ();
+]

src/uTop_console_top.mltop

@@ -1 +1,3 @@
 UTop_console
+UTop_lexer
+UTop_token

src/uTop_lexer.mll

@@ -0,0 +1,161 @@
+(*
+ * uTop_lexer.mll
+ * --------------
+ * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
+ * 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
+}

src/uTop_token.ml

@@ -0,0 +1,21 @@
+(*
+ * uTop_token.ml
+ * -------------
+ * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
+ * Licence   : BSD3
+ *
+ * This file is a part of utop.
+ *)
+
+type t =
+  | Symbol
+  | Lident
+  | Uident
+  | Constant
+  | Char
+  | String
+  | Quotation
+  | Comment
+  | Doc
+  | Blanks
+  | Error

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

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