Initial revision

[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / applications / browser / lexical.ml

diff --git a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/browser/lexical.ml b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/browser/lexical.ml
new file mode 100644 (file)
index 0000000..9acb9c0
--- /dev/null
+++ b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/browser/lexical.ml
@@ -0,0 +1,155 @@
+(* $Id$ *)
+
+open Parser
+
+type tags = [`none|`control|`define|`structure|`char|`infix|`label|`uident]
+
+let colors : (tags * GDraw.color) list Lazy.t =
+  lazy
+    (List.map ~f:(fun (tag,col) -> tag, `COLOR (GDraw.color (`NAME col)))
+       [ `control, "blue";
+        `define, "forestgreen";
+        `structure, "purple";
+        `char, "gray40";
+        `infix, "indianred4";
+        `label, "brown";
+        `uident, "midnightblue";
+         `none, "black" ])
+
+let tag ?(start=0) ?stop:pend (tw : GEdit.text) =
+  let pend = Gaux.default tw#length ~opt:pend in
+  let colors = Lazy.force colors in
+  tw#freeze ();
+  let position = tw#position
+  and text = tw#get_chars ~start ~stop:pend in
+  let replace ~start:pstart ~stop:pend ~tag =
+    if pend > pstart then begin
+      tw#delete_text ~start:(start+pstart) ~stop:(start+pend);
+      tw#set_point (start+pstart);
+      tw#insert ~foreground:(List.assoc tag colors)
+       (String.sub text ~pos:pstart ~len:(pend-pstart));
+    end
+  and next_lf = ref (-1) in
+  let colorize ~start:rstart ~stop:rend ~tag =
+    let rstart = ref rstart in
+    while !rstart < rend do
+      if !next_lf < !rstart then begin
+       try next_lf := String.index_from text !rstart '\n'
+       with Not_found -> next_lf := pend-start
+      end;
+      replace ~start:!rstart ~stop:(min !next_lf rend) ~tag;
+      rstart := !next_lf + 1
+    done
+  in
+  let buffer = Lexing.from_string text
+  and last = ref (EOF, 0, 0)
+  and last_pos = ref 0 in
+  try
+    while true do
+    let token = Lexer.token buffer
+    and start = Lexing.lexeme_start buffer
+    and stop = Lexing.lexeme_end buffer in
+    let tag =
+      match token with
+        AMPERAMPER
+      | AMPERSAND
+      | BARBAR
+      | DO | DONE
+      | DOWNTO
+      | ELSE
+      | FOR
+      | IF
+      | LAZY
+      | MATCH
+      | OR
+      | THEN
+      | TO
+      | TRY
+      | WHEN
+      | WHILE
+      | WITH
+          -> `control
+      | AND
+      | AS
+      | BAR
+      | CLASS
+      | CONSTRAINT
+      | EXCEPTION
+      | EXTERNAL
+      | FUN
+      | FUNCTION
+      | FUNCTOR
+      | IN
+      | INHERIT
+      | INITIALIZER
+      | LET
+      | METHOD
+      | MODULE
+      | MUTABLE
+      | NEW
+      | OF
+      | PARSER
+      | PRIVATE
+      | REC
+      | TYPE
+      | VAL
+      | VIRTUAL
+          -> `define
+      | BEGIN
+      | END
+      | INCLUDE
+      | OBJECT
+      | OPEN
+      | SIG
+      | STRUCT
+          -> `structure
+      | CHAR _
+      | STRING _
+          -> `char
+      | BACKQUOTE
+      | INFIXOP1 _
+      | INFIXOP2 _
+      | INFIXOP3 _
+      | INFIXOP4 _
+      | PREFIXOP _
+      | QUESTION2
+      | SHARP
+          -> `infix
+      | LABEL _
+      | OPTLABEL _
+      | QUESTION
+      | TILDE
+          -> `label
+      | UIDENT _ -> `uident
+      | LIDENT _ ->
+          begin match !last with
+            (QUESTION | TILDE), _, _ -> `label
+          | _ -> `none
+          end
+      | COLON ->
+          begin match !last with
+            LIDENT _, lstart, lstop when lstop = start ->
+              colorize ~tag:`none ~start:!last_pos ~stop:lstart;
+              colorize ~tag:`label ~start:lstart ~stop;
+              last_pos := stop;
+              `none
+          | _ -> `none
+          end
+      | EOF -> raise End_of_file
+      | _ -> `none
+    in
+    if tag <> `none then begin
+      colorize ~tag:`none ~start:!last_pos ~stop:start;
+      colorize ~tag ~start ~stop;
+      last_pos := stop
+    end;
+    last := (token, start, stop)
+    done
+  with exn ->
+    colorize ~tag:`none ~start:!last_pos ~stop:(pend-start);
+    tw#thaw ();
+    tw#set_position position;
+    tw#set_point position;
+    match exn with
+      End_of_file | Lexer.Error _ -> ()
+    | _ -> raise exn