ocaml/otherlibs/labltk/frx/frx_text.ml

230 lines
8.0 KiB
OCaml
Raw Normal View History

(***********************************************************************)
(* *)
(* MLTk, Tcl/Tk interface of Objective Caml *)
(* *)
(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
(* projet Cristal, INRIA Rocquencourt *)
(* Jacques Garrigue, Kyoto University RIMS *)
(* *)
(* Copyright 2002 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 found in the Objective Caml source tree. *)
(* *)
(***********************************************************************)
open Camltk
let version = "$Id$"
(*
* convert an integer to an absolute index
*)
let abs_index n =
TextIndex (LineChar(0,0), [CharOffset n])
let insertMark =
TextIndex(Mark "insert", [])
let currentMark =
TextIndex(Mark "current", [])
let textEnd =
TextIndex(End, [])
let textBegin =
TextIndex (LineChar(0,0), [])
(*
* Link a scrollbar and a text widget
*)
let scroll_link sb tx =
Text.configure tx [YScrollCommand (Scrollbar.set sb)];
Scrollbar.configure sb [ScrollCommand (Text.yview tx)]
(*
* Tk 4.0 has navigation in Text widgets, sometimes using scrolling
* sometimes using the insertion mark. It is a pain to add more
* compatible bindings. We do our own.
*)
let page_up tx = Text.yview tx (ScrollPage (-1))
and page_down tx = Text.yview tx (ScrollPage 1)
and line_up tx = Text.yview tx (ScrollUnit (-1))
and line_down tx = Text.yview tx (ScrollUnit 1)
and top tx = Text.yview_index tx textBegin
and bottom tx = Text.yview_index tx textEnd
let navigation_keys tx =
let tags = bindtags_get tx in
match tags with
(WidgetBindings t)::l when t = tx ->
bindtags tx ((WidgetBindings tx) :: (TagBindings "TEXT_RO") :: l)
| _ -> ()
let new_scrollable_text top options navigation =
let f = Frame.create top [] in
let tx = Text.create f options
and sb = Scrollbar.create f [] in
scroll_link sb tx;
(* IN THIS ORDER -- RESIZING *)
pack [sb] [Side Side_Right; Fill Fill_Y];
pack [tx] [Side Side_Left; Fill Fill_Both; Expand true];
if navigation then navigation_keys tx;
f, tx
(*
* Searching
*)
let patternv = Frx_misc.autodef Textvariable.create
and casev = Frx_misc.autodef Textvariable.create
let topsearch t =
(* The user interface *)
let top = Toplevel.create t [Class "TextSearch"] in
Wm.title_set top "Text search";
let f = Frame.create_named top "fpattern" [] in
let m = Label.create_named f "search" [Text "Search pattern"]
and e = Entry.create_named f "pattern"
[Relief Sunken; TextVariable (patternv()) ] in
let hgroup = Frame.create top []
and bgroup = Frame.create top [] in
let fdir = Frame.create hgroup []
and fmisc = Frame.create hgroup [] in
let direction = Textvariable.create_temporary fdir
and exactv = Textvariable.create_temporary fdir
in
let forw = Radiobutton.create_named fdir "forward"
[Text "Forward"; Variable direction; Value "f"]
and backw = Radiobutton.create_named fdir "backward"
[Text "Backward"; Variable direction; Value "b"]
and exact = Checkbutton.create_named fmisc "exact"
[Text "Exact match"; Variable exactv]
and case = Checkbutton.create_named fmisc "case"
[Text "Fold Case"; Variable (casev())]
and searchb = Button.create_named bgroup "search" [Text "Search"]
and contb = Button.create_named bgroup "continue" [Text "Continue"]
and dismissb = Button.create_named bgroup "dismiss"
[Text "Dismiss";
Command (fun () -> Text.tag_delete t ["search"]; destroy top)] in
Radiobutton.invoke forw;
pack [m][Side Side_Left];
pack [e][Side Side_Right; Fill Fill_X; Expand true];
pack [forw; backw] [Anchor W];
pack [exact; case] [Anchor W];
pack [fdir; fmisc] [Side Side_Left; Anchor Center];
pack [searchb; contb; dismissb] [Side Side_Left; Fill Fill_X];
pack [f;hgroup;bgroup] [Fill Fill_X; Expand true];
let current_index = ref textBegin in
let search cont = fun () ->
let opts = ref [] in
if Textvariable.get direction = "f" then
opts := Forwards :: !opts
else opts := Backwards :: !opts ;
if Textvariable.get exactv = "1" then
opts := Exact :: !opts;
if Textvariable.get (casev()) = "1" then
opts := Nocase :: !opts;
try
let forward = Textvariable.get direction = "f" in
let i = Text.search t !opts (Entry.get e)
(if cont then !current_index
else if forward then textBegin
else TextIndex(End, [CharOffset (-1)])) (* does not work with end *)
(if forward then textEnd
else textBegin) in
let found = TextIndex (i, []) in
current_index :=
TextIndex(i, [CharOffset (if forward then 1 else (-1))]);
Text.tag_delete t ["search"];
Text.tag_add t "search" found (TextIndex (i, [WordEnd]));
Text.tag_configure t "search"
[Relief Raised; BorderWidth (Pixels 1);
Background Red];
Text.see t found
with
Invalid_argument _ -> Bell.ring() in
bind e [[], KeyPressDetail "Return"]
(BindSet ([], fun _ -> search false ()));
Button.configure searchb [Command (search false)];
Button.configure contb [Command (search true)];
Tkwait.visibility top;
Focus.set e
let addsearch tx =
let tags = bindtags_get tx in
match tags with
(WidgetBindings t)::l when t = tx ->
bindtags tx ((WidgetBindings tx) :: (TagBindings "SEARCH") :: l)
| _ -> ()
(* We use Mod1 instead of Meta or Alt *)
let init () =
List.iter (function ev ->
tag_bind "TEXT_RO" ev
(BindSetBreakable ([Ev_Widget],
(fun ei -> page_up ei.ev_Widget; break()))))
[
[[], KeyPressDetail "BackSpace"];
[[], KeyPressDetail "Delete"];
[[], KeyPressDetail "Prior"];
[[], KeyPressDetail "b"];
[[Mod1], KeyPressDetail "v"]
];
List.iter (function ev ->
tag_bind "TEXT_RO" ev
(BindSetBreakable ([Ev_Widget],
(fun ei -> page_down ei.ev_Widget; break()))))
[
[[], KeyPressDetail "space"];
[[], KeyPressDetail "Next"];
[[Control], KeyPressDetail "v"]
];
List.iter (function ev ->
tag_bind "TEXT_RO" ev
(BindSetBreakable ([Ev_Widget],
(fun ei -> line_up ei.ev_Widget; break()))))
[
[[], KeyPressDetail "Up"];
[[Mod1], KeyPressDetail "z"]
];
List.iter (function ev ->
tag_bind "TEXT_RO" ev
(BindSetBreakable ([Ev_Widget],
(fun ei -> line_down ei.ev_Widget; break()))))
[
[[], KeyPressDetail "Down"];
[[Control], KeyPressDetail "z"]
];
List.iter (function ev ->
tag_bind "TEXT_RO" ev
(BindSetBreakable ([Ev_Widget],
(fun ei -> top ei.ev_Widget; break()))))
[
[[], KeyPressDetail "Home"];
[[Mod1], KeyPressDetail "less"]
];
List.iter (function ev ->
tag_bind "TEXT_RO" ev
(BindSetBreakable ([Ev_Widget],
(fun ei -> bottom ei.ev_Widget; break()))))
[
[[], KeyPressDetail "End"];
[[Mod1], KeyPressDetail "greater"]
];
List.iter (function ev ->
tag_bind "SEARCH" ev
(BindSetBreakable ([Ev_Widget],
(fun ei -> topsearch ei.ev_Widget; break()))))
[
[[Control], KeyPressDetail "s"]
]