]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/browser/lexical.ml
rebuilt
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-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