add colors
Ignore-this: e67c18ee1f58d9af23b0a53af74f09d5 darcs-hash:20110726221146-c41ad-60551b96cbfff4cbb301fac6fa868ce0b0e22c42
This commit is contained in:
Jeremie Dimino
parent
e24ad5eaae
commit
e877a0ff72
16
src/uTop.ml
16
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. *)
|
||||
|
|
|
|||
25
src/uTop.mli
25
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. *)
|
||||
|
|
|
|||
|
|
@ -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,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
|
||||
(* This is a new command. *)
|
||||
|
||||
match prompt with
|
||||
| "# " ->
|
||||
(* 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 ();
|
||||
]
|
||||
|
|
|
|||
|
|
@ -1 +1,3 @@
|
|||
UTop_console
|
||||
UTop_lexer
|
||||
UTop_token
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue