helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/applications/browser/lexical.ml

   1 (* $Id$ *)
   2
   3 open Parser
   4
   5 type tags = [`none|`control|`define|`structure|`char|`infix|`label|`uident]
   6
   7 let colors : (tags * GDraw.color) list Lazy.t =
   8   lazy
   9     (List.map ~f:(fun (tag,col) -> tag, `COLOR (GDraw.color (`NAME col)))
  10        [ `control, "blue";
  11          `define, "forestgreen";
  12          `structure, "purple";
  13          `char, "gray40";
  14          `infix, "indianred4";
  15          `label, "brown";
  16          `uident, "midnightblue";
  17          `none, "black" ])
  18
  19 let tag ?(start=0) ?stop:pend (tw : GEdit.text) =
  20   let pend = Gaux.default tw#length ~opt:pend in
  21   let colors = Lazy.force colors in
  22   tw#freeze ();
  23   let position = tw#position
  24   and text = tw#get_chars ~start ~stop:pend in
  25   let replace ~start:pstart ~stop:pend ~tag =
  26     if pend > pstart then begin
  27       tw#delete_text ~start:(start+pstart) ~stop:(start+pend);
  28       tw#set_point (start+pstart);
  29       tw#insert ~foreground:(List.assoc tag colors)
  30         (String.sub text ~pos:pstart ~len:(pend-pstart));
  31     end
  32   and next_lf = ref (-1) in
  33   let colorize ~start:rstart ~stop:rend ~tag =
  34     let rstart = ref rstart in
  35     while !rstart < rend do
  36       if !next_lf < !rstart then begin
  37         try next_lf := String.index_from text !rstart '\n'
  38         with Not_found -> next_lf := pend-start
  39       end;
  40       replace ~start:!rstart ~stop:(min !next_lf rend) ~tag;
  41       rstart := !next_lf + 1
  42     done
  43   in
  44   let buffer = Lexing.from_string text
  45   and last = ref (EOF, 0, 0)
  46   and last_pos = ref 0 in
  47   try
  48     while true do
  49     let token = Lexer.token buffer
  50     and start = Lexing.lexeme_start buffer
  51     and stop = Lexing.lexeme_end buffer in
  52     let tag =
  53       match token with
  54         AMPERAMPER
  55       | AMPERSAND
  56       | BARBAR
  57       | DO | DONE
  58       | DOWNTO
  59       | ELSE
  60       | FOR
  61       | IF
  62       | LAZY
  63       | MATCH
  64       | OR
  65       | THEN
  66       | TO
  67       | TRY
  68       | WHEN
  69       | WHILE
  70       | WITH
  71           -> `control
  72       | AND
  73       | AS
  74       | BAR
  75       | CLASS
  76       | CONSTRAINT
  77       | EXCEPTION
  78       | EXTERNAL
  79       | FUN
  80       | FUNCTION
  81       | FUNCTOR
  82       | IN
  83       | INHERIT
  84       | INITIALIZER
  85       | LET
  86       | METHOD
  87       | MODULE
  88       | MUTABLE
  89       | NEW
  90       | OF
  91       | PARSER
  92       | PRIVATE
  93       | REC
  94       | TYPE
  95       | VAL
  96       | VIRTUAL
  97           -> `define
  98       | BEGIN
  99       | END
 100       | INCLUDE
 101       | OBJECT
 102       | OPEN
 103       | SIG
 104       | STRUCT
 105           -> `structure
 106       | CHAR _
 107       | STRING _
 108           -> `char
 109       | BACKQUOTE
 110       | INFIXOP1 _
 111       | INFIXOP2 _
 112       | INFIXOP3 _
 113       | INFIXOP4 _
 114       | PREFIXOP _
 115       | QUESTION2
 116       | SHARP
 117           -> `infix
 118       | LABEL _
 119       | OPTLABEL _
 120       | QUESTION
 121       | TILDE
 122           -> `label
 123       | UIDENT _ -> `uident
 124       | LIDENT _ ->
 125           begin match !last with
 126             (QUESTION | TILDE), _, _ -> `label
 127           | _ -> `none
 128           end
 129       | COLON ->
 130           begin match !last with
 131             LIDENT _, lstart, lstop when lstop = start ->
 132               colorize ~tag:`none ~start:!last_pos ~stop:lstart;
 133               colorize ~tag:`label ~start:lstart ~stop;
 134               last_pos := stop;
 135               `none
 136           | _ -> `none
 137           end
 138       | EOF -> raise End_of_file
 139       | _ -> `none
 140     in
 141     if tag <> `none then begin
 142       colorize ~tag:`none ~start:!last_pos ~stop:start;
 143       colorize ~tag ~start ~stop;
 144       last_pos := stop
 145     end;
 146     last := (token, start, stop)
 147     done
 148   with exn ->
 149     colorize ~tag:`none ~start:!last_pos ~stop:(pend-start);
 150     tw#thaw ();
 151     tw#set_position position;
 152     tw#set_point position;
 153     match exn with
 154       End_of_file | Lexer.Error _ -> ()
 155     | _ -> raise exn