(*************************************************************************)
(*                                                                       *)
(*                         OCaml LablTk library                          *)
(*                                                                       *)
(*            Jacques Garrigue, Kyoto University RIMS                    *)
(*                                                                       *)
(*   Copyright 1999 Institut National de Recherche en Informatique et    *)
(*   en Automatique and Kyoto University.  All rights reserved.          *)
(*   This file is distributed under the terms of the GNU Library         *)
(*   General Public License, with the special exception on linking       *)
(*   described in file ../../../LICENSE.                                 *)
(*                                                                       *)
(*************************************************************************)

(* $Id$ *)

open StdLabels
open Tk
open Jg_tk
open Parser

let tags =
  ["control"; "define"; "structure"; "char";
   "infix"; "label"; "uident"]
and colors =
    ["blue"; "forestgreen"; "purple"; "gray40";
     "indianred4"; "saddlebrown"; "midnightblue"]

let init_tags tw =
  List.iter2 tags colors ~f:
  begin fun tag col ->
    Text.tag_configure tw ~tag ~foreground:(`Color col)
  end;
  Text.tag_configure tw ~tag:"error" ~foreground:`Red;
  Text.tag_configure tw ~tag:"error" ~relief:`Raised;
  Text.tag_raise tw ~tag:"error"

let tag ?(start=tstart) ?(stop=tend) tw =
  let tpos c = (Text.index tw ~index:start, [`Char c]) in
  let text = Text.get tw ~start ~stop in
  let buffer = Lexing.from_string text in
  Location.init buffer "";
  Location.input_name := "";
  List.iter tags
    ~f:(fun tag -> Text.tag_remove tw ~start ~stop ~tag);
  let last = ref (EOF, 0, 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
      | PRIVATE
      | REC
      | TYPE
      | VAL
      | VIRTUAL
          -> "define"
      | BEGIN
      | END
      | INCLUDE
      | OBJECT
      | OPEN
      | SIG
      | STRUCT
          -> "structure"
      | CHAR _
      | STRING _
          -> "char"
      | BACKQUOTE
      | INFIXOP1 _
      | INFIXOP2 _
      | INFIXOP3 _
      | INFIXOP4 _
      | PREFIXOP _
      | HASH
          -> "infix"
      | LABEL _
      | OPTLABEL _
      | QUESTION
      | TILDE
          -> "label"
      | UIDENT _ -> "uident"
      | LIDENT _ ->
          begin match !last with
            (QUESTION | TILDE), _, _ -> "label"
          | _ -> ""
          end
      | COLON ->
          begin match !last with
            LIDENT _, lstart, lstop ->
              if lstop = start then
                Text.tag_add tw ~tag:"label"
                  ~start:(tpos lstart) ~stop:(tpos stop);
              ""
          | _ -> ""
          end
      | EOF -> raise End_of_file
      | _ -> ""
    in
    if tag <> "" then
      Text.tag_add tw ~tag ~start:(tpos start) ~stop:(tpos stop);
    last := (token, start, stop)
    done
  with
    End_of_file -> ()
  | Lexer.Error (err, loc) -> ()