add colors for modules and directives

Ignore-this: 318635e4f07f427549dbe99980e4c46f

darcs-hash:20110803083828-c41ad-f2e8bf6cdfb2991b965725e356dac9bc64a906fc

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:
 

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 stylise start stop token_style =
-    let tokens = UTop_lexer.lex_string (pending ^ LTerm_text.to_string styled) in
+      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
-              match token with
+              | Symbol ->
-                | Symbol -> styles.style_symbol
+                  stylise start stop styles.style_symbol;
-                | Lident -> if String_set.mem src !UTop.keywords then styles.style_keyword else styles.style_ident
+                  loop rest
-                | Uident -> styles.style_ident
+              | Lident ->
-                | Constant -> styles.style_constant
+                  stylise start stop
-                | Char -> styles.style_char
+                    (if String_set.mem src !UTop.keywords then
-                | String _ -> styles.style_string
+                       styles.style_keyword
-                | Quotation _ -> styles.style_quotation
+                     else
-                | Comment _ -> styles.style_comment
+                       styles.style_ident);
-                | Doc _ -> styles.style_doc
+                  loop rest
-                | Blanks -> styles.style_blanks
+              | Uident ->
-                | Error -> styles.style_error
+                  if String_set.mem src !UTop.keywords then begin
-            in
+                    stylise start stop styles.style_keyword;
-            for i = start - pending_length to stop - pending_length - 1 do
+                    loop rest
-              let ch, style = styled.(i) in
+                  end else
-              styled.(i) <- (ch, LTerm_style.merge token_style style)
+                    loop_after_uident start stop rest
-            done;
+              | Constant ->
-            loop rest
+                  stylise start stop styles.style_constant;
-    in
+                  loop rest
-    let rec skip tokens =
+              | 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
+            match token with
-              loop rest
+              | Symbol ->
-            else if stop > pending_length then
+                  if src = "." then
-              loop ((token, pending_length, stop, Zed_utf8.sub src (pending_length - start) (stop - pending_length)) :: rest)
+                    stylise uid_start uid_stop styles.style_module
-            else
+                  else
-              skip rest
+                    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. *)
 

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

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