(*************************************************************************)

(*                                                                       *)

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

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