source: trunk/source/contrib/foy/source-comparison/source-compare-dialog.lisp @ 12731

Last change on this file since 12731 was 12731, checked in by gfoy, 11 years ago

Hemlock button action with no open Hemlock window.

File size: 20.5 KB
Line 
1;;;-*- Mode: Lisp; Package: SOURCE-COMPARE -*-
2
3;;; ----------------------------------------------------------------------------
4;;;
5;;;      source-compare-dialog.lisp, version 0.1b1
6;;;
7;;;      copyright © 2009 Glen Foy
8;;;      (Permission is granted to Clozure Associates to distribute this file.)
9;;;
10;;;      This file provides a GUI for Mark Kantrowitz's source-compare.lisp.
11;;;      See source-compare.lisp for documentation. 
12;;;
13;;;      The GUI portion is straight forward.  The browse buttons let you browse
14;;;      to select the two target files.  The Hemlock buttons will pull in the file
15;;;      in the top Hemlock window. 
16;;;
17;;;      When the utility prints a diff specification, Alt-Double-Click it to
18;;;      pull up the relevant code in Hemlock windows.  There are various types of
19;;;      diff specs.  A typical one looks like this: 559,565c544,546
20;;;     
21;;;      The most recent version will be available at: www.clairvaux.org/downloads/
22;;;
23;;;      This code is offered "as is" without warranty of any kind.
24;;;
25;;; ----------------------------------------------------------------------------
26
27(in-package "SOURCE-COMPARE")
28
29(defConstant %dialog-width% 675)
30(defConstant %dialog-height% 410)
31
32(defParameter *source-compare-dialog* nil)
33
34(defun open-source-compare-dialog ()
35  (#/makeKeyAndOrderFront: *source-compare-dialog* nil))
36
37#|
38(setq *source-compare-dialog* nil)
39
40(gui::execute-in-gui 'open-source-compare-dialog)
41|#
42
43;;; This includes a work-around for what appears to be a bug in the hemlock-frame
44;;; #/close method.  After a #/close, the window remains on the (#/orderedWindows *NSApp*)
45;;; list, but (hi::buffer-document buffer) in NIL.  Therefore the extra tests:
46(defun display-hemlock-position (path start-line &optional end-line)
47  (labels ((window-buffer (w)
48             (let* ((pane (slot-value w 'gui::pane))
49                    (hemlock-view (gui::text-pane-hemlock-view pane)))
50               (hi::hemlock-view-buffer hemlock-view)))
51           (window-with-path (target-path)
52             (gui::first-window-satisfying-predicate 
53              #'(lambda (w)
54                  (when (and (typep w 'gui::hemlock-frame)
55                             (not (typep w 'gui::hemlock-listener-frame)))
56                    (let* ((buffer (window-buffer w))
57                           (document (when buffer (hi::buffer-document buffer)))
58                           (buffer-path (when buffer (hi::buffer-pathname buffer))))
59                      (when (and document (stringp buffer-path))
60                        (string-equal target-path buffer-path))))))))
61    (let* ((w (window-with-path path))
62           (hemlock-view (cond (w 
63                                (gui::hemlock-view w))
64                               (t
65                                (let ((view (gui::cocoa-edit path)))
66                                  (when view
67                                    (setq w (#/window (hi::hemlock-view-pane view)))
68                                    view)))))
69           (text-pane (when w (slot-value w 'gui::pane)))
70           (text-view (when text-pane (gui::text-pane-text-view text-pane)))
71           (buffer (when hemlock-view (hi::hemlock-view-buffer hemlock-view)))
72           (hi::*current-buffer* buffer)
73           (start-mark (when (and buffer start-line)
74                         (let ((temp (hi::copy-mark (hi::buffer-start-mark buffer) :temporary)))
75                           (when (hi::line-offset temp (1- start-line))
76                             temp))))
77           (start-pos (when start-mark (hi::mark-absolute-position start-mark)))
78           (end-mark (when (and buffer end-line)
79                         (let ((temp (hi::copy-mark (hi::buffer-start-mark buffer) :temporary)))
80                           (when (hi::line-offset temp (1- end-line))
81                             (hi::line-end temp)))))
82           (end-pos (if end-mark 
83                      (hi::mark-absolute-position end-mark)
84                      (when (and start-pos start-mark)
85                        (let ((temp (hi::copy-mark start-mark :temporary)))
86;                          (when (hi::line-offset temp 1)
87                          (hi::mark-absolute-position (hi::line-end temp)))))))
88      (when (and w text-view start-mark start-pos)
89        (#/makeKeyAndOrderFront: w nil)
90        (when (and start-pos end-pos)
91          (ns:with-ns-range (range start-pos (- end-pos start-pos))
92            (#/scrollRangeToVisible: text-view range)
93            (#/setSelectedRange: text-view range))
94          (hi::move-mark (hi::buffer-point buffer) start-mark)
95          (gui::update-paren-highlight text-view))))))
96
97;;; ----------------------------------------------------------------------------
98;;;
99(defclass sc-text-view (ns:ns-text-view)
100  ()
101  (:metaclass ns:+ns-object))
102
103(objc:defmethod (#/mouseDown: :void) ((self sc-text-view) event)
104  (cond ((and (logtest #$NSAlternateKeyMask (#/modifierFlags event))
105              (= (#/clickCount event) 2))
106         ; (#/selectWord: self self)
107         (call-next-method event)
108         (let* ((range (#/selectedRange self))
109                (substring (#/substringWithRange: (#/string self) range)))
110           (process-diff-string (#/window self) (ccl::lisp-string-from-nsstring substring))))
111        (t
112         (call-next-method event))))
113
114;;; ----------------------------------------------------------------------------
115;;;
116(defClass SOURCE-COMPARE-WINDOW (ns:ns-window)
117  ((path-1 :initform nil :accessor path-1)
118   (path-1-field :foreign-type :id :initform nil :accessor path-1-field)
119   (path-2 :initform nil :accessor path-2)
120   (path-2-field :foreign-type :id :initform nil :accessor path-2-field)
121   (difference-pane :foreign-type :id :initform nil :accessor difference-pane)
122   (ignore-case-check-box :foreign-type :id :initform nil :accessor ignore-case-check-box)
123   (ignore-whitespace-check-box :foreign-type :id :initform nil :accessor ignore-whitespace-check-box)
124   (ignore-comments-check-box :foreign-type :id :initform nil :accessor ignore-comments-check-box)
125   (ignore-blank-lines-check-box :foreign-type :id :initform nil :accessor ignore-blank-lines-check-box)
126   (print-context-check-box :foreign-type :id :initform nil :accessor print-context-check-box)
127   (print-fancy-header-check-box :foreign-type :id :initform nil :accessor print-fancy-header-check-box)
128   (compare-button :initform nil :accessor compare-button)
129   (action-alist :initform nil :accessor action-alist))
130  (:metaclass ns:+ns-object))
131
132;;; This is called for all GUI actions.  The source-compare-window is always the target.
133;;; Doing it this way means we can use lambdas in the code below rather than
134;;; writing a bunch of objc functions.  Old MCL habits die hard.
135(objc:defmethod (#/interfaceAction: :void) ((w source-compare-window) (sender :id))
136  (let ((pair (assoc sender (action-alist w))))
137    (cond (pair
138           ;; dispatch:
139           (funcall (cdr pair) sender))
140          (t
141           (error "~%Action function not found for ~S" sender)))))
142
143(defmethod clear-difference-pane ((w source-compare-window))
144  (#/setString: (difference-pane w) #@""))
145
146(defmethod process-diff-string ((w source-compare-window) string)
147  (when (and string
148             (every #'(lambda (char)
149                        (member char
150                                '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
151                                      #\c #\a #\d #\,)))
152                    string))
153    (let* ((alpha-char-pos (find-if #'(lambda (char) (alpha-char-p char)) string))
154           (position (position alpha-char-pos string))
155           (lhs (subseq string 0 position))
156           (rhs (subseq string (1+ position)))
157           (lhs-comma (position #\, lhs))
158           (rhs-comma (position #\, rhs))
159           lhs-start lhs-end rhs-start rhs-end)
160     
161      (cond (lhs-comma
162             (setf lhs-start (read-from-string (subseq lhs 0 lhs-comma)))
163             (setf lhs-end (read-from-string (subseq lhs (1+ lhs-comma))))
164             (display-hemlock-position (path-1 w) lhs-start lhs-end))
165            (t
166             (setf lhs-start (read-from-string lhs))
167             (display-hemlock-position (path-1 w) lhs-start)))
168     
169      (cond (rhs-comma
170             (setf rhs-start (read-from-string (subseq rhs 0 rhs-comma)))
171             (setf rhs-end (read-from-string (subseq rhs (1+ rhs-comma))))
172             (display-hemlock-position (path-2 w) rhs-start rhs-end))
173            (t
174             (setf rhs-start (read-from-string rhs))
175             ;; single line
176             (display-hemlock-position (path-2 w) rhs-start))))))
177         
178(defMethod get-scmp-items ((w source-compare-window))
179  (append 
180   (make-path-items w)
181   (make-button-items w)
182   (make-check-boxes w)
183   (make-miscel-items w)))
184
185(defMethod make-check-boxes ((w source-compare-window))
186  (flet ((make-check-box (title x-coord y-coord x-dim y-dim checked-p)
187           (let ((box (#/alloc ns:ns-button)))
188             (ns:with-ns-rect (frame x-coord y-coord x-dim y-dim)
189               (#/initWithFrame: box frame))
190             (#/setButtonType: box #$NSSwitchButton)
191             (#/setTitle: box title)
192             (#/setState: box (if checked-p #$NSOnState #$NSOffState))
193             box)))
194    (list
195     (setf (ignore-case-check-box w)
196           (make-check-box #@"ignore case" 10 30 130 20 t))
197
198     (setf (ignore-comments-check-box w)
199           (make-check-box #@"ignore comments" 160 30 130 20 t))
200
201     (setf (ignore-whitespace-check-box w)
202           (make-check-box #@"ignore whitespace" 310 30 130 20 t))
203
204     (setf (ignore-blank-lines-check-box w)
205           (make-check-box #@"ignore blank lines" 10 10 130 20 t))
206
207     (setf (print-context-check-box w)
208           (make-check-box #@"ignore context lines" 160 10 140 20 t))
209
210     (setf (print-fancy-header-check-box w)
211           (make-check-box #@"print fancy header" 310 10 140 20 nil)))))
212
213(defMethod make-button-items ((w source-compare-window))
214  (flet ((make-button (title x-coord y-coord x-dim y-dim lambda)
215           (let ((button (#/alloc ns:ns-button)))
216             (ns:with-ns-rect (frame x-coord y-coord x-dim y-dim)
217               (#/initWithFrame: button frame)
218               (#/setButtonType: button #$NSMomentaryPushInButton)
219               (#/setImagePosition: button #$NSNoImage)
220               (#/setBezelStyle: button #$NSRoundedBezelStyle))
221             (#/setTitle: button title)
222             (#/setTarget: button w)
223             (#/setAction: button (ccl::@selector "interfaceAction:"))
224             (pushnew (cons button lambda) (action-alist w))
225             button))
226         (front-hemlock-window ()
227           (gui::first-window-satisfying-predicate 
228            #'(lambda (w)
229                (and (typep w 'gui::hemlock-frame)
230                     (not (typep w 'gui::hemlock-listener-frame))))))
231                     ;; (#/isKeyWindow w)))))
232         (window-pathname (w)
233           (when w
234             (let* ((pane (slot-value w 'gui::pane))
235                    (text-view (gui::text-pane-text-view pane))
236                    (buffer (gui::hemlock-buffer text-view)))
237               (hi::buffer-pathname buffer)))))
238
239    (list (make-button #@"Browse" 480 368 80 32
240                       #'(lambda (item)
241                           (declare (ignore item))
242                           (let ((path (gui::cocoa-choose-file-dialog :button-string "select")))
243                             (when path
244                               (clear-difference-pane w)
245                               (setf (path-1 w) path)
246                               (#/setStringValue: (path-1-field w) (ccl::%make-nsstring path))))))
247
248          (make-button #@"Browse" 480 338 80 32
249                       #'(lambda (item)
250                           (declare (ignore item))
251                           (let ((path (gui::cocoa-choose-file-dialog :button-string "select")))
252                             (when path
253                               (clear-difference-pane w)
254                               (setf (path-2 w) path)
255                               (#/setStringValue: (path-2-field w) (ccl::%make-nsstring path))))))
256
257          (make-button #@"Hemlock" 570 368 90 32
258                       #'(lambda (item)
259                           (declare (ignore item))
260                           (let* ((window (front-hemlock-window))
261                                  (path (when window (window-pathname window))))
262                             (when path 
263                               (clear-difference-pane w)
264                               (setf (path-1 w) path)
265                               (#/setStringValue: (path-1-field w) (ccl::%make-nsstring path))))))
266
267          (make-button #@"Hemlock" 570 338 90 32
268                       #'(lambda (item)
269                           (declare (ignore item))
270                           (let* ((window (front-hemlock-window))
271                                  (path (when window (window-pathname window))))
272                             (when path 
273                               (clear-difference-pane w)
274                               (setf (path-2 w) path)
275                               (#/setStringValue: (path-2-field w) (ccl::%make-nsstring path))))))
276
277          (make-button #@"Cancel" 480 10 80 32
278                       #'(lambda (item)
279                           (declare (ignore item))
280                           (#/close w)))
281
282          (setf (compare-button w)
283                (make-button #@"Compare" 570 10 90 32
284                             #'(lambda (item)
285                                 (declare (ignore item))
286                                 (compare w)))))))
287
288(defMethod compare ((w source-compare-window))
289
290  (cond ((and (path-1 w) (path-2 w))
291         (unless (probe-file (path-1 w))
292           (format t "~%; ¥ File: ~A does not exist." (path-1 w))
293           (return-from compare))
294         (unless (probe-file (path-2 w))
295           (format t "~%; ¥ File: ~A does not exist." (path-2 w))
296           (return-from compare))
297
298         (let ((stream (make-string-output-stream)))         
299           ;; out with the old
300           (#/setString: (difference-pane w) #@" ")
301           (source-compare (path-1 w) (path-2 w)
302                           :output-stream stream
303                           :ignore-case (eql (#/state (ignore-case-check-box w)) #$NSOnState)
304                           :ignore-whitespace (eql (#/state (ignore-whitespace-check-box w)) #$NSOnState)
305                           :ignore-comments (eql (#/state (ignore-comments-check-box w)) #$NSOnState)
306                           :ignore-blank-lines (eql (#/state (ignore-blank-lines-check-box w)) #$NSOnState)
307                           :print-context (eql (#/state (print-context-check-box w)) #$NSOnState)
308                           :print-fancy-header (eql (#/state (print-fancy-header-check-box w)) #$NSOnState))
309           (#/setString: (difference-pane w) (ccl::%make-nsstring (ccl::get-output-stream-string stream)))))
310        (t
311         (#/setString: (difference-pane w) #@"First enter two valid paths."))))
312
313(defMethod make-path-items ((w source-compare-window))
314  (let* ((small-sys-size (#/smallSystemFontSize ns:ns-font))
315         (small-sys-font (#/systemFontOfSize: ns:ns-font small-sys-size)))
316    (list
317     (setf (path-1-field w)
318           (let ((field (#/alloc ns:ns-text-field)))
319             (ns:with-ns-rect (frame 30 375 435 15)
320               (#/initWithFrame: field frame)
321               (#/setEditable: field nil)
322               (#/setDrawsBackground: field nil)
323               (#/setBordered: field nil)
324               (#/setFont: field small-sys-font)
325               (#/setStringValue: field #@""))
326             field))
327     
328     (setf (path-2-field w)
329           (let ((field (#/alloc ns:ns-text-field)))
330             (ns:with-ns-rect (frame 30 345 435 15)
331               (#/initWithFrame: field frame)
332               (#/setEditable: field nil)
333               (#/setDrawsBackground: field nil)
334               (#/setBordered: field nil)
335               (#/setFont: field small-sys-font)
336               (#/setStringValue: field #@""))
337             field)))))
338
339(defMethod make-miscel-items ((w source-compare-window))
340  (list
341   (let* ((scroll-view (#/alloc ns:ns-scroll-view))
342          (view (#/init (#/alloc sc-text-view))))
343     (ns:with-ns-rect (frame 4 60 650 200)
344       (#/initWithFrame: scroll-view frame))
345     (ns:with-ns-rect (frame 4 60 650 200)
346       (#/initWithFrame: view frame))
347     (#/insertText: view #@" ")
348     (#/setHasVerticalScroller: scroll-view t)
349     (#/setHasHorizontalScroller: scroll-view t)
350     (#/setBorderType: scroll-view #$NSBezelBorder)
351     (#/setDocumentView: scroll-view view)
352     (#/setEditable: view nil)
353     (setf (difference-pane w) view)
354     scroll-view)
355
356   (let* ((title (#/alloc ns:ns-text-field)))
357     (ns:with-ns-rect (frame 5 370 22 22)
358       (#/initWithFrame: title frame))
359     (#/setEditable: title nil)
360     (#/setDrawsBackground: title nil)
361     (#/setBordered: title nil)
362     ;; (#/setFont: title style-font)
363     (#/setStringValue: title #@"1:")
364     title)
365
366   (let ((box (#/alloc ns:ns-box)))
367      (ns:with-ns-rect (frame 25 370 450 40)
368        (#/initWithFrame: box frame))
369     (#/setTitle: box #@"")
370     box)
371
372   (let* ((title (#/alloc ns:ns-text-field)))
373     (ns:with-ns-rect (frame 5 340 22 22)
374       (#/initWithFrame: title frame))
375     (#/setEditable: title nil)
376     (#/setDrawsBackground: title nil)
377     (#/setBordered: title nil)
378     ;; (#/setFont: title style-font)
379     (#/setStringValue: title #@"2:")
380     title)
381
382   (let ((box (#/alloc ns:ns-box)))
383      (ns:with-ns-rect (frame 25 340 450 40)
384        (#/initWithFrame: box frame))
385     (#/setTitle: box #@"")
386     box)
387
388   (let* ((title (#/alloc ns:ns-text-field)))
389     (ns:with-ns-rect (frame 10 310 500 22)
390       (#/initWithFrame: title frame))
391     (#/setEditable: title nil)
392     (#/setDrawsBackground: title nil)
393     (#/setBordered: title nil)
394     ;; (#/setFont: title style-font)
395     (#/setStringValue: title #@"Mods required to make file 1 equivalent to file 2:")
396     title)
397
398  (let* ((small-sys-size (#/smallSystemFontSize ns:ns-font))
399         (small-sys-font (#/systemFontOfSize: ns:ns-font small-sys-size))
400         (title (#/alloc ns:ns-text-field)))
401    (ns:with-ns-rect (frame 10 290 500 22)
402      (#/initWithFrame: title frame))
403    (#/setEditable: title nil)
404    (#/setDrawsBackground: title nil)
405    (#/setBordered: title nil)
406    (#/setFont: title small-sys-font)
407    (#/setStringValue: title #@"(a = add, d = delete, c = change, < = file 1, > = file 2)")
408    title)
409
410  (let* ((small-sys-size (#/smallSystemFontSize ns:ns-font))
411         (small-sys-font (#/systemFontOfSize: ns:ns-font small-sys-size))
412         (title (#/alloc ns:ns-text-field)))
413    (ns:with-ns-rect (frame 10 270 500 22)
414      (#/initWithFrame: title frame))
415    (#/setEditable: title nil)
416    (#/setDrawsBackground: title nil)
417    (#/setBordered: title nil)
418    (#/setFont: title small-sys-font)
419    (#/setStringValue: title #@"(To display the relevant code, alt-double-click the difference spec, ie 559,565c544,546)")
420    title)))
421
422(setq *source-compare-dialog*
423      (let ((dialog (#/alloc source-compare-window)))
424        (ns:with-ns-rect (r 100 100 %dialog-width% %dialog-height%)
425          (#/initWithContentRect:styleMask:backing:defer: 
426           dialog
427           r
428           (logior  #$NSTitledWindowMask 
429                    #$NSClosableWindowMask 
430                    #$NSMiniaturizableWindowMask)
431           #$NSBackingStoreBuffered
432           #$NO))
433        (#/setTitle: dialog #@"Source Comparison")
434        (dolist (item (get-scmp-items dialog))
435          (#/addSubview: (#/contentView  dialog) item))
436        (#/setDefaultButtonCell: dialog (compare-button dialog))
437        (#/setReleasedWhenClosed: dialog nil)
438        (#/center dialog)
439        dialog))
440
441;;; ----------------------------------------------------------------------------
442;;; update the Tools Menu
443;;;
444(defParameter *tools-menu* 
445  (#/submenu (#/itemWithTitle: (#/mainMenu (ccl::application-ui-object ccl::*application*)) #@"Tools")))
446
447(let ((item (#/itemWithTitle: *tools-menu* #@"Source CompareÉ")))
448  (unless (%null-ptr-p item) (#/removeItem: *tools-menu* item))
449  (#/addItem: *tools-menu* (#/separatorItem ns:ns-menu-item))
450  (setf item (#/initWithTitle:action:keyEquivalent: (#/alloc ns:ns-menu-item)
451                                                    #@"Source CompareÉ"
452                                                    (ccl::@selector "interfaceAction:")
453                                                    #@""))
454  (#/setTarget: item *source-compare-dialog*)
455  (#/addItem: *tools-menu* item)
456  (pushnew (cons item
457                 #'(lambda (sender)
458                     (declare (ignore sender))
459                     (open-source-compare-dialog)))
460           (action-alist *source-compare-dialog*)))
461
462
463
464
465
466
467
468
469
470
Note: See TracBrowser for help on using the repository browser.