1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
open GText
open Ideutils
type action =
| Insert of string * int * int (* content*pos*length *)
| Delete of string * int * int (* content*pos*length *)
let neg act = match act with
| Insert (s,i,l) -> Delete (s,i,l)
| Delete (s,i,l) -> Insert (s,i,l)
class undoable_view (tv:Gtk.textview Gtk.obj) =
let undo_lock = ref true in
object(self)
inherit GText.view tv as super
val history = (Stack.create () : action Stack.t)
val redo = (Queue.create () : action Queue.t)
val nredo = (Stack.create () : action Stack.t)
method private dump_debug =
if !debug then begin
prerr_endline "==========Stack top=============";
Stack.iter
(fun e -> match e with
| Insert(s,p,l) ->
Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l
| Delete(s,p,l) ->
Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l)
history;
Printf.eprintf "Stack size %d\n" (Stack.length history);
prerr_endline "==========Stack Bottom==========";
prerr_endline "==========Queue start=============";
Queue.iter
(fun e -> match e with
| Insert(s,p,l) ->
Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l
| Delete(s,p,l) ->
Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l)
redo;
Printf.eprintf "Stack size %d\n" (Queue.length redo);
prerr_endline "==========Queue End=========="
end
method clear_undo = Stack.clear history; Stack.clear nredo; Queue.clear redo
method undo = if !undo_lock then begin
undo_lock := false;
prerr_endline "UNDO";
try begin
let r =
match Stack.pop history with
| Insert(s,p,l) as act -> let start = self#buffer#get_iter_at_char p in
(self#buffer#delete_interactive
~start
~stop:(start#forward_chars l)
()) or
(Stack.push act history; false)
| Delete(s,p,l) as act ->
let iter = self#buffer#get_iter_at_char p in
(self#buffer#insert_interactive ~iter s) or
(Stack.push act history; false)
in if r then begin
process_pending ();
let act = Stack.pop history in
Queue.push act redo;
Stack.push act nredo
end;
undo_lock := true;
r
end
with Stack.Empty ->
undo_lock := true;
false
end else
(prerr_endline "UNDO DISCARDED"; true)
method redo = prerr_endline "REDO"; true
initializer
ignore (self#buffer#connect#mark_set
~callback:
(fun it tm -> if !undo_lock && not (Queue.is_empty redo) then begin
Stack.iter (fun e -> Stack.push (neg e) history) nredo;
Stack.clear nredo;
Queue.iter (fun e -> Stack.push e history) redo;
Queue.clear redo;
end)
);
ignore (self#buffer#connect#insert_text
~callback:
(fun it s ->
let pos = it#offset in
if Stack.is_empty history or
s=" " or s="\t" or s="\n" or
(match Stack.top history with
| Insert(old,opos,olen) ->
opos + olen <> pos
| _ -> true)
then Stack.push (Insert(s,it#offset,Glib.Utf8.length s)) history
else begin
match Stack.pop history with
| Insert(olds,offset,len) ->
Stack.push
(Insert(olds^s,
offset,
len+(Glib.Utf8.length s)))
history
| _ -> assert false
end;
self#dump_debug
));
ignore (self#buffer#connect#delete_range
~callback:
(fun ~start ~stop ->
if !undo_lock && not (Queue.is_empty redo) then begin
Queue.iter (fun e -> Stack.push e history) redo;
Queue.clear redo;
end;
let start_offset = start#offset in
let stop_offset = stop#offset in
let s = self#buffer#get_text ~start ~stop () in
if Stack.is_empty history or (match Stack.top history with
| Delete(old,opos,olen) ->
olen=1 or opos <> start_offset
| _ -> true
)
then
Stack.push
(Delete(s,
start_offset,
stop_offset - start_offset
))
history
else begin
match Stack.pop history with
| Delete(olds,offset,len) ->
Stack.push
(Delete(olds^s,
offset,
len+(Glib.Utf8.length s)))
history
| _ -> assert false
end;
self#dump_debug
))
end
let undoable_view ?(buffer:buffer option)
?editable ?cursor_visible ?wrap_mode
?packing ?show () =
let w = match buffer with
| None -> GtkText.View.create ()
| Some b -> GtkText.View.create_with_buffer b#as_buffer
in
GtkText.View.set w ?editable ?cursor_visible ?wrap_mode;
GObj.pack_return (new undoable_view w) ~packing ~show
|
