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

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

Mark Kantrowitz's source-compare.lisp with a GUI.

File size: 20.4 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           (let* ((pane (slot-value w 'gui::pane))
234                  (text-view (gui::text-pane-text-view pane))
235                  (buffer (gui::hemlock-buffer text-view)))
236             (hi::buffer-pathname buffer))))
237
238    (list (make-button #@"Browse" 480 368 80 32
239                       #'(lambda (item)
240                           (declare (ignore item))
241                           (let ((path (gui::cocoa-choose-file-dialog :button-string "select")))
242                             (when path
243                               (clear-difference-pane w)
244                               (setf (path-1 w) path)
245                               (#/setStringValue: (path-1-field w) (ccl::%make-nsstring path))))))
246
247          (make-button #@"Browse" 480 338 80 32
248                       #'(lambda (item)
249                           (declare (ignore item))
250                           (let ((path (gui::cocoa-choose-file-dialog :button-string "select")))
251                             (when path
252                               (clear-difference-pane w)
253                               (setf (path-2 w) path)
254                               (#/setStringValue: (path-2-field w) (ccl::%make-nsstring path))))))
255
256          (make-button #@"Hemlock" 570 368 90 32
257                       #'(lambda (item)
258                           (declare (ignore item))
259                           (let* ((window (front-hemlock-window))
260                                  (path (window-pathname window)))
261                             (when path 
262                               (clear-difference-pane w)
263                               (setf (path-1 w) path)
264                               (#/setStringValue: (path-1-field w) (ccl::%make-nsstring path))))))
265
266          (make-button #@"Hemlock" 570 338 90 32
267                       #'(lambda (item)
268                           (declare (ignore item))
269                           (let* ((window (front-hemlock-window))
270                                  (path (window-pathname window)))
271                             (when path 
272                               (clear-difference-pane w)
273                               (setf (path-2 w) path)
274                               (#/setStringValue: (path-2-field w) (ccl::%make-nsstring path))))))
275
276          (make-button #@"Cancel" 480 10 80 32
277                       #'(lambda (item)
278                           (declare (ignore item))
279                           (#/close w)))
280
281          (setf (compare-button w)
282                (make-button #@"Compare" 570 10 90 32
283                             #'(lambda (item)
284                                 (declare (ignore item))
285                                 (compare w)))))))
286
287(defMethod compare ((w source-compare-window))
288
289  (cond ((and (path-1 w) (path-2 w))
290         (unless (probe-file (path-1 w))
291           (format t "~%; ¥ File: ~A does not exist." (path-1 w))
292           (return-from compare))
293         (unless (probe-file (path-2 w))
294           (format t "~%; ¥ File: ~A does not exist." (path-2 w))
295           (return-from compare))
296
297         (let ((stream (make-string-output-stream)))         
298           ;; out with the old
299           (#/setString: (difference-pane w) #@" ")
300           (source-compare (path-1 w) (path-2 w)
301                           :output-stream stream
302                           :ignore-case (eql (#/state (ignore-case-check-box w)) #$NSOnState)
303                           :ignore-whitespace (eql (#/state (ignore-whitespace-check-box w)) #$NSOnState)
304                           :ignore-comments (eql (#/state (ignore-comments-check-box w)) #$NSOnState)
305                           :ignore-blank-lines (eql (#/state (ignore-blank-lines-check-box w)) #$NSOnState)
306                           :print-context (eql (#/state (print-context-check-box w)) #$NSOnState)
307                           :print-fancy-header (eql (#/state (print-fancy-header-check-box w)) #$NSOnState))
308           (#/setString: (difference-pane w) (ccl::%make-nsstring (ccl::get-output-stream-string stream)))))
309        (t
310         (#/setString: (difference-pane w) #@"First enter two valid paths."))))
311
312(defMethod make-path-items ((w source-compare-window))
313  (let* ((small-sys-size (#/smallSystemFontSize ns:ns-font))
314         (small-sys-font (#/systemFontOfSize: ns:ns-font small-sys-size)))
315    (list
316     (setf (path-1-field w)
317           (let ((field (#/alloc ns:ns-text-field)))
318             (ns:with-ns-rect (frame 30 375 435 15)
319               (#/initWithFrame: field frame)
320               (#/setEditable: field nil)
321               (#/setDrawsBackground: field nil)
322               (#/setBordered: field nil)
323               (#/setFont: field small-sys-font)
324               (#/setStringValue: field #@""))
325             field))
326     
327     (setf (path-2-field w)
328           (let ((field (#/alloc ns:ns-text-field)))
329             (ns:with-ns-rect (frame 30 345 435 15)
330               (#/initWithFrame: field frame)
331               (#/setEditable: field nil)
332               (#/setDrawsBackground: field nil)
333               (#/setBordered: field nil)
334               (#/setFont: field small-sys-font)
335               (#/setStringValue: field #@""))
336             field)))))
337
338(defMethod make-miscel-items ((w source-compare-window))
339  (list
340   (let* ((scroll-view (#/alloc ns:ns-scroll-view))
341          (view (#/init (#/alloc sc-text-view))))
342     (ns:with-ns-rect (frame 4 60 650 200)
343       (#/initWithFrame: scroll-view frame))
344     (ns:with-ns-rect (frame 4 60 650 200)
345       (#/initWithFrame: view frame))
346     (#/insertText: view #@" ")
347     (#/setHasVerticalScroller: scroll-view t)
348     (#/setHasHorizontalScroller: scroll-view t)
349     (#/setBorderType: scroll-view #$NSBezelBorder)
350     (#/setDocumentView: scroll-view view)
351     (#/setEditable: view nil)
352     (setf (difference-pane w) view)
353     scroll-view)
354
355   (let* ((title (#/alloc ns:ns-text-field)))
356     (ns:with-ns-rect (frame 5 370 22 22)
357       (#/initWithFrame: title frame))
358     (#/setEditable: title nil)
359     (#/setDrawsBackground: title nil)
360     (#/setBordered: title nil)
361     ;; (#/setFont: title style-font)
362     (#/setStringValue: title #@"1:")
363     title)
364
365   (let ((box (#/alloc ns:ns-box)))
366      (ns:with-ns-rect (frame 25 370 450 40)
367        (#/initWithFrame: box frame))
368     (#/setTitle: box #@"")
369     box)
370
371   (let* ((title (#/alloc ns:ns-text-field)))
372     (ns:with-ns-rect (frame 5 340 22 22)
373       (#/initWithFrame: title frame))
374     (#/setEditable: title nil)
375     (#/setDrawsBackground: title nil)
376     (#/setBordered: title nil)
377     ;; (#/setFont: title style-font)
378     (#/setStringValue: title #@"2:")
379     title)
380
381   (let ((box (#/alloc ns:ns-box)))
382      (ns:with-ns-rect (frame 25 340 450 40)
383        (#/initWithFrame: box frame))
384     (#/setTitle: box #@"")
385     box)
386
387   (let* ((title (#/alloc ns:ns-text-field)))
388     (ns:with-ns-rect (frame 10 310 500 22)
389       (#/initWithFrame: title frame))
390     (#/setEditable: title nil)
391     (#/setDrawsBackground: title nil)
392     (#/setBordered: title nil)
393     ;; (#/setFont: title style-font)
394     (#/setStringValue: title #@"Mods required to make file 1 equivalent to file 2:")
395     title)
396
397  (let* ((small-sys-size (#/smallSystemFontSize ns:ns-font))
398         (small-sys-font (#/systemFontOfSize: ns:ns-font small-sys-size))
399         (title (#/alloc ns:ns-text-field)))
400    (ns:with-ns-rect (frame 10 290 500 22)
401      (#/initWithFrame: title frame))
402    (#/setEditable: title nil)
403    (#/setDrawsBackground: title nil)
404    (#/setBordered: title nil)
405    (#/setFont: title small-sys-font)
406    (#/setStringValue: title #@"(a = add, d = delete, c = change, < = file 1, > = file 2)")
407    title)
408
409  (let* ((small-sys-size (#/smallSystemFontSize ns:ns-font))
410         (small-sys-font (#/systemFontOfSize: ns:ns-font small-sys-size))
411         (title (#/alloc ns:ns-text-field)))
412    (ns:with-ns-rect (frame 10 270 500 22)
413      (#/initWithFrame: title frame))
414    (#/setEditable: title nil)
415    (#/setDrawsBackground: title nil)
416    (#/setBordered: title nil)
417    (#/setFont: title small-sys-font)
418    (#/setStringValue: title #@"(To display the relevant code, alt-double-click the difference spec, ie 559,565c544,546)")
419    title)))
420
421(setq *source-compare-dialog*
422      (let ((dialog (#/alloc source-compare-window)))
423        (ns:with-ns-rect (r 100 100 %dialog-width% %dialog-height%)
424          (#/initWithContentRect:styleMask:backing:defer: 
425           dialog
426           r
427           (logior  #$NSTitledWindowMask 
428                    #$NSClosableWindowMask 
429                    #$NSMiniaturizableWindowMask)
430           #$NSBackingStoreBuffered
431           #$NO))
432        (#/setTitle: dialog #@"Source Comparison")
433        (dolist (item (get-scmp-items dialog))
434          (#/addSubview: (#/contentView  dialog) item))
435        (#/setDefaultButtonCell: dialog (compare-button dialog))
436        (#/setReleasedWhenClosed: dialog nil)
437        (#/center dialog)
438        dialog))
439
440;;; ----------------------------------------------------------------------------
441;;; update the Tools Menu
442;;;
443(defParameter *tools-menu* 
444  (#/submenu (#/itemWithTitle: (#/mainMenu (ccl::application-ui-object ccl::*application*)) #@"Tools")))
445
446(let ((item (#/itemWithTitle: *tools-menu* #@"Source CompareÉ")))
447  (unless (%null-ptr-p item) (#/removeItem: *tools-menu* item))
448  (#/addItem: *tools-menu* (#/separatorItem ns:ns-menu-item))
449  (setf item (#/initWithTitle:action:keyEquivalent: (#/alloc ns:ns-menu-item)
450                                                    #@"Source CompareÉ"
451                                                    (ccl::@selector "interfaceAction:")
452                                                    #@""))
453  (#/setTarget: item *source-compare-dialog*)
454  (#/addItem: *tools-menu* item)
455  (pushnew (cons item
456                 #'(lambda (sender)
457                     (declare (ignore sender))
458                     (open-source-compare-dialog)))
459           (action-alist *source-compare-dialog*)))
460
461
462
463
464
465
466
467
468
469
Note: See TracBrowser for help on using the repository browser.