(* $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