(*************************************************************************)
(*                                                                       *)
(*                Objective Caml 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

let get_all tw = Text.get tw ~start:tstart ~stop:(tposend 1)

let tag_and_see tw ~tag ~start ~stop =
  Text.tag_remove tw ~start:(tpos 0) ~stop:tend ~tag;
  Text.tag_add tw ~start ~stop ~tag;
  try
    Text.see tw ~index:(`Tagfirst tag, []);
    Text.mark_set tw ~mark:"insert" ~index:(`Tagfirst tag, [])
  with Protocol.TkError _ -> ()

let output tw ~buf ~pos ~len =
  Text.insert tw ~index:tend ~text:(String.sub buf ~pos ~len)

let add_scrollbar tw =
  let sb = Scrollbar.create (Winfo.parent tw) ~command:(Text.yview tw)
  in Text.configure tw ~yscrollcommand:(Scrollbar.set sb); sb

let create_with_scrollbar parent =
  let frame = Frame.create parent in
  let tw = Text.create frame in
  frame, tw, add_scrollbar tw

let goto_tag tw ~tag =
  let index = (`Tagfirst tag, []) in
  try Text.see tw ~index;
      Text.mark_set tw ~index ~mark:"insert"
  with Protocol.TkError _ -> ()

let search_string tw =
  let tl = Jg_toplevel.titled "Search" in
  Wm.transient_set tl ~master:(Winfo.toplevel tw);
  let fi = Frame.create tl
  and fd = Frame.create tl
  and fm = Frame.create tl
  and buttons = Frame.create tl
  and direction = Textvariable.create ~on:tl ()
  and mode = Textvariable.create ~on:tl ()
  and count = Textvariable.create ~on:tl ()
  in
  let label = Label.create fi ~text:"Pattern:"
  and text = Entry.create fi ~width:20
  and back = Radiobutton.create fd ~variable:direction
               ~text:"Backwards" ~value:"backward"
  and forw = Radiobutton.create fd ~variable:direction
               ~text:"Forwards" ~value:"forward"
  and exact = Radiobutton.create fm ~variable:mode
                ~text:"Exact" ~value:"exact"
  and nocase = Radiobutton.create fm ~variable:mode
                 ~text:"No case" ~value:"nocase"
  and regexp =  Radiobutton.create fm ~variable:mode
                 ~text:"Regexp" ~value:"regexp"
  in
  let search = Button.create buttons ~text:"Search" ~command:
    begin fun () ->
    try
      let pattern = Entry.get text in
      let dir, ofs = match Textvariable.get direction with
          "forward" -> `Forwards, 1
        | "backward" -> `Backwards, -1
        | _ -> assert false
      and mode = match Textvariable.get mode with "exact" -> [`Exact]
                 | "nocase" -> [`Nocase] | "regexp" -> [`Regexp] | _ -> []
      in
      let ndx =
        Text.search tw ~pattern ~switches:([dir;`Count count] @ mode)
          ~start:(`Mark "insert", [`Char ofs])
      in
      tag_and_see tw ~tag:"sel" ~start:(ndx,[])
        ~stop:(ndx,[`Char(int_of_string (Textvariable.get count))])
    with Invalid_argument _ -> ()
    end
  and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in

  Focus.set text;
  Jg_bind.return_invoke text ~button:search;
  Jg_bind.escape_destroy tl;
  Textvariable.set direction "forward";
  Textvariable.set mode "nocase";
  pack [label] ~side:`Left;
  pack [text] ~side:`Right ~fill:`X ~expand:true;
  pack [back; forw] ~side:`Left;
  pack [exact; nocase; regexp] ~side:`Left;
  pack [search; ok] ~side:`Left ~fill:`X ~expand:true;
  pack [fi; fd; fm; buttons] ~side:`Top ~fill:`X