haskal
/
utop
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

add colors 

Ignore-this: e67c18ee1f58d9af23b0a53af74f09d5

darcs-hash:20110726221146-c41ad-60551b96cbfff4cbb301fac6fa868ce0b0e22c42
This commit is contained in:
Jeremie Dimino 2011-07-27 00:11:46 +02:00
parent e24ad5eaae
commit e877a0ff72
8 changed files with 393 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src/uTop.ml
View File

@ -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
View File

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

176
src/uTop_console.ml
View File

@ -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 ();
]

2
src/uTop_console_top.mltop
View File

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

161
src/uTop_lexer.mll Normal file
View File

@ -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
}

21
src/uTop_token.ml Normal file
View File

@ -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

14
utoprc-dark Normal file
View File

@ -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

14
utoprc-light Normal file
View File

@ -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