diff --git a/man/utoprc.5 b/man/utoprc.5 index ef0c2f4..9ec3101 100644 --- a/man/utoprc.5 +++ b/man/utoprc.5 @@ -41,6 +41,7 @@ in The following style keys are used by utop: * identifier + * module * comment * doc * constant @@ -50,7 +51,9 @@ The following style keys are used by utop: * char * quotation * error + * directive * parenthesis + * blanks For each of these keys, the following sub-keys are used: diff --git a/src/uTop_console.ml b/src/uTop_console.ml index 029b9b8..fe9e92a 100644 --- a/src/uTop_console.ml +++ b/src/uTop_console.ml @@ -26,6 +26,7 @@ type styles = { mutable style_keyword : LTerm_style.t; mutable style_symbol : LTerm_style.t; mutable style_ident : LTerm_style.t; + mutable style_module : LTerm_style.t; mutable style_constant : LTerm_style.t; mutable style_char : LTerm_style.t; mutable style_string : LTerm_style.t; @@ -34,6 +35,7 @@ type styles = { mutable style_doc : LTerm_style.t; mutable style_blanks : LTerm_style.t; mutable style_error : LTerm_style.t; + mutable style_directive : LTerm_style.t; mutable style_paren : LTerm_style.t; } @@ -41,6 +43,7 @@ let styles = { style_keyword = LTerm_style.none; style_symbol = LTerm_style.none; style_ident = LTerm_style.none; + style_module = LTerm_style.none; style_constant = LTerm_style.none; style_char = LTerm_style.none; style_string = LTerm_style.none; @@ -49,6 +52,7 @@ let styles = { style_doc = LTerm_style.none; style_blanks = LTerm_style.none; style_error = LTerm_style.none; + style_directive = LTerm_style.none; style_paren = LTerm_style.none; } @@ -58,6 +62,7 @@ let init_resources () = 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_module <- LTerm_resources.get_style "module" 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; @@ -66,6 +71,7 @@ let init_resources () = 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; + styles.style_directive <- LTerm_resources.get_style "directive" res; styles.style_paren <- LTerm_resources.get_style "parenthesis" res; (match String.lowercase (LTerm_resources.get "profile" res) with | "light" -> UTop.set_profile UTop.Light @@ -120,46 +126,218 @@ object(self) let styled, position = super#stylise last in (* Syntax highlighting *) - - let tokens = UTop_lexer.lex_string (pending ^ LTerm_text.to_string styled) in + 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 let rec loop tokens = match tokens with | [] -> () | (token, start, stop, 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 - for i = 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; - loop rest - in - let rec skip tokens = + match token with + | Symbol -> + stylise start stop styles.style_symbol; + loop rest + | Lident -> + stylise start stop + (if String_set.mem src !UTop.keywords then + styles.style_keyword + else + styles.style_ident); + loop rest + | Uident -> + if String_set.mem src !UTop.keywords then begin + stylise start stop styles.style_keyword; + loop rest + end else + loop_after_uident start stop rest + | Constant -> + stylise start stop styles.style_constant; + loop rest + | Char -> + stylise start stop styles.style_char; + loop rest + | String _ -> + stylise start stop styles.style_string; + loop rest + | Quotation _ -> + stylise start stop styles.style_quotation; + loop rest + | Comment _ -> + stylise start stop styles.style_comment; + loop rest + | Doc _ -> + stylise start stop styles.style_doc; + loop rest + | Blanks -> + stylise start stop styles.style_blanks; + loop rest + | Error -> + stylise start stop styles.style_error; + loop rest + and loop_after_uident uid_start uid_stop tokens = match tokens with | [] -> () | (token, start, stop, src) :: rest -> - if stop = pending_length then - loop rest - else if stop > pending_length then - loop ((token, pending_length, stop, Zed_utf8.sub src (pending_length - start) (stop - pending_length)) :: rest) - else - skip rest + match token with + | Symbol -> + if src = "." then + stylise uid_start uid_stop styles.style_module + else + stylise uid_start uid_stop styles.style_ident; + stylise start stop styles.style_symbol; + loop rest + | Lident -> + stylise uid_start uid_stop styles.style_ident; + stylise start stop + (if String_set.mem src !UTop.keywords then + styles.style_keyword + else + styles.style_ident); + loop rest + | Uident -> + stylise uid_start uid_stop styles.style_ident; + if String_set.mem src !UTop.keywords then begin + stylise start stop styles.style_keyword; + loop rest + end else + loop_after_uident start stop rest + | Constant -> + stylise uid_start uid_stop styles.style_ident; + stylise start stop styles.style_constant; + loop rest + | Char -> + stylise uid_start uid_stop styles.style_ident; + stylise start stop styles.style_char; + loop rest + | String _ -> + stylise uid_start uid_stop styles.style_ident; + stylise start stop styles.style_string; + loop rest + | Quotation _ -> + stylise uid_start uid_stop styles.style_ident; + stylise start stop styles.style_quotation; + loop rest + | Comment _ -> + stylise uid_start uid_stop styles.style_ident; + stylise start stop styles.style_comment; + loop_after_uident uid_start uid_stop rest + | Doc _ -> + stylise uid_start uid_stop styles.style_ident; + stylise start stop styles.style_doc; + loop_after_uident uid_start uid_stop rest + | Blanks -> + stylise uid_start uid_stop styles.style_ident; + stylise start stop styles.style_blanks; + loop_after_uident uid_start uid_stop rest + | Error -> + stylise uid_start uid_stop styles.style_ident; + stylise start stop styles.style_error; + loop rest + and loop_sharp tokens = + match tokens with + | [] -> + () + | (token, start, stop, src) :: rest -> + match token with + | Symbol -> + if src = "#" then begin + stylise start stop styles.style_directive; + loop_directive rest + end else begin + stylise start stop styles.style_symbol; + loop rest + end + | Lident -> + stylise start stop + (if String_set.mem src !UTop.keywords then + styles.style_keyword + else + styles.style_ident); + loop rest + | Uident -> + if String_set.mem src !UTop.keywords then begin + stylise start stop styles.style_keyword; + loop rest + end else + loop_after_uident start stop rest + | Constant -> + stylise start stop styles.style_constant; + loop rest + | Char -> + stylise start stop styles.style_char; + loop rest + | String _ -> + stylise start stop styles.style_string; + loop rest + | Quotation _ -> + stylise start stop styles.style_quotation; + loop rest + | Comment _ -> + stylise start stop styles.style_comment; + loop_sharp rest + | Doc _ -> + stylise start stop styles.style_doc; + loop_sharp rest + | Blanks -> + stylise start stop styles.style_blanks; + loop_sharp rest + | Error -> + stylise start stop styles.style_error; + loop rest + and loop_directive tokens = + match tokens with + | [] -> + () + | (token, start, stop, src) :: rest -> + match token with + | Symbol -> + stylise start stop styles.style_symbol; + loop rest + | Lident -> + stylise start stop + (if String_set.mem src !UTop.keywords then + styles.style_keyword + else + styles.style_directive); + loop rest + | Uident -> + if String_set.mem src !UTop.keywords then begin + stylise start stop styles.style_keyword; + loop rest + end else + loop_after_uident start stop rest + | Constant -> + stylise start stop styles.style_constant; + loop rest + | Char -> + stylise start stop styles.style_char; + loop rest + | String _ -> + stylise start stop styles.style_string; + loop rest + | Quotation _ -> + stylise start stop styles.style_quotation; + loop rest + | Comment _ -> + stylise start stop styles.style_comment; + loop_directive rest + | Doc _ -> + stylise start stop styles.style_doc; + loop_directive rest + | Blanks -> + stylise start stop styles.style_blanks; + loop_directive rest + | Error -> + stylise start stop styles.style_error; + loop rest in - if pending_length = 0 then loop tokens else skip tokens; + let tokens = UTop_lexer.lex_string (pending ^ LTerm_text.to_string styled) in + loop_sharp tokens; (* Parenthesis matching. *) diff --git a/utoprc-dark b/utoprc-dark index 14de473..c84e81d 100644 --- a/utoprc-dark +++ b/utoprc-dark @@ -4,6 +4,7 @@ profile: dark identifier.foreground: none +module.foreground: x-palegreen comment.foreground: x-chocolate1 doc.foreground: x-light-salmon constant.foreground: x-aquamarine @@ -13,4 +14,5 @@ string.foreground: x-light-salmon char.foreground: x-light-salmon quotation.foreground: x-purple error.foreground: x-red +directive.foreground: x-lightsteelblue parenthesis.background: blue diff --git a/utoprc-light b/utoprc-light index aac1e1a..a2c6706 100644 --- a/utoprc-light +++ b/utoprc-light @@ -4,6 +4,7 @@ profile: light identifier.foreground: none +module.foreground: x-forestgreen comment.foreground: x-firebrick doc.foreground: x-violetred4 constant.foreground: x-darkcyan @@ -13,4 +14,5 @@ string.foreground: x-violetred4 char.foreground: x-violetred4 quotation.foreground: x-purple error.foreground: x-red +directive.foreground: x-mediumorchid4 parenthesis.background: light-blue