← Back to branch summary

~ubuntu-branches/ubuntu/hardy/ocaml-doc/hardy

« back to all changes in this revision

Viewing changes to examples/camltk/mytext.ml

  • Committer: Bazaar Package Importer
  • Author(s): Samuel Mimram
  • Date: 2007-09-08 01:49:22 UTC
  • mfrom: (0.1.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070908014922-lvihyehz0ndq7suu
Tags: 3.10-1
* New upstream release.
* Removed camlp4 documentation since it is not up-to-date.
* Updated to standards version 3.7.2, no changes needed.
* Updated my email address.

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/camltk/mytext.ml
1
 
(***********************************************************************)
2
 
(*                                                                     *)
3
 
(*                           Objective Caml                            *)
4
 
(*                                                                     *)
5
 
(*               Pierre Weis, projet Cristal, INRIA Rocquencourt       *)
6
 
(*                                                                     *)
7
 
(* Copyright 2001, 2004 Institut National de Recherche en Informatique *)
8
 
(* et en Automatique. All rights reserved. This file is distributed    *)
9
 
(* only by permission.                                                 *)
10
 
(*                                                                     *)
11
 
(***********************************************************************)
12
 
 
13
 
(* $Id: mytext.ml,v 1.2 2004/07/07 09:39:15 weis Exp $ *)
14
 
 
15
 
(* A text widget with kill and yank capabilities ``� la'' Emacs. *)
16
 
 
17
 
open Tk;;
18
 
 
19
 
let top = openTk ();;
20
 
 
21
 
let scroll_link sb tx =
22
 
  Text.configure tx [YScrollCommand (Scrollbar.set sb)];
23
 
  Scrollbar.configure sb [ScrollCommand (Text.yview tx)];;
24
 
 
25
 
let f = Frame.create top [];;
26
 
let text = Text.create f [];;
27
 
let scrollbar = Scrollbar.create f [];;
28
 
 
29
 
(* kill buffer *)
30
 
let kill_ring = ref [];;
31
 
 
32
 
let add_to_kill_ring s = kill_ring := s :: !kill_ring;;
33
 
 
34
 
let get_killed_text () =
35
 
 match !kill_ring with
36
 
 | [] -> ""
37
 
 | s :: l -> s;;
38
 
 
39
 
(* Note: for the text widgets, the insertion cursor is 
40
 
    not TextIndex (Insert, []),
41
 
    but TextIndex (Mark  "insert", []) *) 
42
 
let insertMark = TextIndex (Mark "insert", []);;
43
 
let eol_insertMark = TextIndex (Mark "insert", [LineEnd]);;
44
 
 
45
 
let kill () =
46
 
  let s = Text.get text insertMark eol_insertMark in
47
 
  add_to_kill_ring s;
48
 
  prerr_endline ("Killed: " ^ s);
49
 
  Text.delete text insertMark eol_insertMark;;
50
 
 
51
 
let yank () =
52
 
 let s = get_killed_text () in
53
 
 Text.insert text insertMark s [];
54
 
 prerr_endline ("Yanked: " ^ s);;
55
 
 
56
 
let yank_more () =
57
 
  let ring = !kill_ring in
58
 
  let more = ref ring in
59
 
  let rec get_killed_more () =
60
 
    match !more with
61
 
    | [] -> more := ring; get_killed_more ()
62
 
    | s :: l -> more := l; s in
63
 
  let insert_killed_more () =
64
 
    let s = get_killed_more () in
65
 
    prerr_endline ("Yanked more: " ^ s);
66
 
    Text.insert text insertMark s [] in
67
 
  insert_killed_more ();
68
 
  bind text [[Alt], KeyPressDetail "y"]
69
 
     (BindSet ([], fun _ -> insert_killed_more ()));;
70
 
 
71
 
let main () =
72
 
  scroll_link scrollbar text;
73
 
 
74
 
  pack [text; scrollbar][Side Side_Left; Fill Fill_Y];
75
 
  pack [f][];
76
 
 
77
 
  bind text [[Control], KeyPressDetail "y"]
78
 
     (BindSet ([], fun _ -> yank ()));
79
 
 
80
 
  bind text [[Alt], KeyPressDetail "y"]
81
 
     (BindSet ([], fun _ -> yank_more () ));
82
 
 
83
 
  bind text [[Control], KeyPressDetail "k"]
84
 
     (BindSet ([], fun _ -> kill () ));
85
 
 
86
 
  bind text [[Control], KeyPressDetail "c"]
87
 
     (BindSet ([], fun _ -> exit 0 ));
88
 
 
89
 
  mainLoop ();;
90
 
 
91
 
main ();;
92