summaryrefslogtreecommitdiff
path: root/ide/undo.ml
blob: 0951ab5e132fb59ef3c3b9bea6d1d9f75cd84824 (plain)
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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

open Ideutils
open GText
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.text_view] 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 false (* !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
	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
(* INCORRECT: is called even while undoing...
   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 ->
		 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;
(*		 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:GText.buffer option) =
  GtkText.View.make_params []
    ~cont:(GContainer.pack_container
	     ~create:
	     (fun pl -> let w = match buffer with
	      | None -> GtkText.View.create []
	      | Some b -> GtkText.View.create_with_buffer b#as_buffer
	      in
	      Gobject.set_params w pl; ((new undoable_view w):undoable_view)))