(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* 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 OCaml 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"] ]