Source

dotfiles / emacs.d / slime-2012-01-20 / contrib / slime-presentations.el

Mike Steder ddf7185 












































































































































































































































































































































































































































































































































































































































































































































































































































































  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
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846

(define-slime-contrib slime-presentations
  "Imitate LispM presentations."
  (:authors "Alan Ruttenberg  <alanr-l@mumble.net>"
            "Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de>")
  (:license "GPL")
  (:slime-dependencies slime-repl)
  (:swank-dependencies swank-presentations)
  (:on-load
   (add-hook 'slime-repl-mode-hook
             (lambda ()
               ;; Respect the syntax text properties of presentation.
               (set (make-local-variable 'parse-sexp-lookup-properties) t)
               (slime-add-local-hook 'after-change-functions 
                                     'slime-after-change-function)))
   (add-hook 'slime-event-hooks 'slime-dispatch-presentation-event)
   (setq slime-write-string-function 'slime-presentation-write)
   (add-hook 'slime-repl-return-hooks 'slime-presentation-on-return-pressed)
   (add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input)
   (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open)
   (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations)
   (add-hook 'slime-edit-definition-hooks 'slime-edit-presentation)
   (setq slime-inspector-insert-ispec-function 'slime-presentation-inspector-insert-ispec)
   (setq sldb-insert-frame-variable-value-function 
         'slime-presentation-sldb-insert-frame-variable-value)
   (slime-presentation-init-keymaps)
   (slime-presentation-add-easy-menu)))

(defface slime-repl-output-mouseover-face
  (if (featurep 'xemacs)
      '((t (:bold t)))
    (if (slime-face-inheritance-possible-p)
        '((t
           (:box
            (:line-width 1 :color "black" :style released-button)
            :inherit
            slime-repl-inputed-output-face)))
      '((t (:box (:line-width 1 :color "black"))))))
  "Face for Lisp output in the SLIME REPL, when the mouse hovers over it"
  :group 'slime-repl)

(defface slime-repl-inputed-output-face
  '((((class color) (background light)) (:foreground "Red"))
    (((class color) (background dark)) (:foreground "Red"))
    (t (:slant italic)))
  "Face for the result of an evaluation in the SLIME REPL."
  :group 'slime-repl)

;; FIXME: This conditional is not right - just used because the code
;; here does not work in XEmacs.
(when (boundp 'text-property-default-nonsticky)
  (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky
	   :test 'equal)
  (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky
	   :test 'equal))

(make-variable-buffer-local
 (defvar slime-presentation-start-to-point (make-hash-table)))

(defun slime-mark-presentation-start (id &optional target)
  "Mark the beginning of a presentation with the given ID.
TARGET can be nil (regular process output) or :repl-result."
  (setf (gethash id slime-presentation-start-to-point) 
        ;; We use markers because text can also be inserted before this presentation.
        ;; (Output arrives while we are writing presentations within REPL results.)
        (copy-marker (slime-output-target-marker target) nil)))

(defun slime-mark-presentation-start-handler (process string)
  (if (and string (string-match "<\\([-0-9]+\\)" string))
      (let* ((match (substring string (match-beginning 1) (match-end 1)))
             (id (car (read-from-string match))))
        (slime-mark-presentation-start id))))

(defun slime-mark-presentation-end (id &optional target)
  "Mark the end of a presentation with the given ID.
TARGET can be nil (regular process output) or :repl-result."
  (let ((start (gethash id slime-presentation-start-to-point)))
    (remhash id slime-presentation-start-to-point)
    (when start
      (let* ((marker (slime-output-target-marker target))
             (buffer (and marker (marker-buffer marker))))
        (with-current-buffer buffer
          (let ((end (marker-position marker)))
            (slime-add-presentation-properties start end
                                               id nil)))))))

(defun slime-mark-presentation-end-handler (process string)
  (if (and string (string-match ">\\([-0-9]+\\)" string))
      (let* ((match (substring string (match-beginning 1) (match-end 1)))
             (id (car (read-from-string match))))
        (slime-mark-presentation-end id))))

(defstruct slime-presentation text id)

(defvar slime-presentation-syntax-table
  (let ((table (copy-syntax-table lisp-mode-syntax-table)))
    ;; We give < and > parenthesis syntax, so that #< ... > is treated
    ;; as a balanced expression.  This allows to use C-M-k, C-M-SPC,
    ;; etc. to deal with a whole presentation.  (For Lisp mode, this
    ;; is not desirable, since we do not wish to get a mismatched
    ;; paren highlighted everytime we type < or >.)
    (modify-syntax-entry ?< "(>" table)
    (modify-syntax-entry ?> ")<" table)
    table)
  "Syntax table for presentations.")

(defun slime-add-presentation-properties (start end id result-p)
  "Make the text between START and END a presentation with ID.
RESULT-P decides whether a face for a return value or output text is used."
  (let* ((text (buffer-substring-no-properties start end))
         (presentation (make-slime-presentation :text text :id id)))
    (let ((inhibit-modification-hooks t))
      (add-text-properties start end
                           `(modification-hooks (slime-after-change-function)
                             insert-in-front-hooks (slime-after-change-function)
                             insert-behind-hooks (slime-after-change-function)
                             syntax-table ,slime-presentation-syntax-table
                             rear-nonsticky t))
      ;; Use the presentation as the key of a text property
      (case (- end start)
        (0)
        (1
         (add-text-properties start end
                              `(slime-repl-presentation ,presentation
                                ,presentation :start-and-end)))
        (t
         (add-text-properties start (1+ start) 
                              `(slime-repl-presentation ,presentation
                                ,presentation :start))
         (when (> (- end start) 2)
           (add-text-properties (1+ start) (1- end)
                                `(,presentation :interior)))
         (add-text-properties (1- end) end
                              `(slime-repl-presentation ,presentation
                                ,presentation :end))))
      ;; Also put an overlay for the face and the mouse-face.  This enables
      ;; highlighting of nested presentations.  However, overlays get lost
      ;; when we copy a presentation; their removal is also not undoable.
      ;; In these cases the mouse-face text properties need to take over ---
      ;; but they do not give nested highlighting.
      (slime-ensure-presentation-overlay start end presentation))))

(defun slime-ensure-presentation-overlay (start end presentation)
  (unless (find presentation (overlays-at start)
                :key (lambda (overlay) 
                       (overlay-get overlay 'slime-repl-presentation)))
    (let ((overlay (make-overlay start end (current-buffer) t nil)))
      (overlay-put overlay 'slime-repl-presentation presentation)
      (overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face)
      (overlay-put overlay 'help-echo 
                   (if (eq major-mode 'slime-repl-mode)
                       "mouse-2: copy to input; mouse-3: menu"
                     "mouse-2: inspect; mouse-3: menu"))
      (overlay-put overlay 'face 'slime-repl-inputed-output-face)
      (overlay-put overlay 'keymap slime-presentation-map))))
  
(defun slime-remove-presentation-properties (from to presentation)
  (let ((inhibit-read-only t)) 
    (remove-text-properties from to
                            `(,presentation t syntax-table t rear-nonsticky t))
    (when (eq (get-text-property from 'slime-repl-presentation) presentation)
      (remove-text-properties from (1+ from) `(slime-repl-presentation t)))
    (when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation)
      (remove-text-properties (1- to) to `(slime-repl-presentation t)))
    (dolist (overlay (overlays-at from))
      (when (eq (overlay-get overlay 'slime-repl-presentation) presentation)
        (delete-overlay overlay)))))

(defun slime-insert-presentation (string output-id &optional rectangle)
  "Insert STRING in current buffer and mark it as a presentation 
corresponding to OUTPUT-ID.  If RECTANGLE is true, indent multi-line
strings to line up below the current point."
  (flet ((insert-it ()
                    (if rectangle 
                        (slime-insert-indented string)
                      (insert string))))
    (let ((start (point)))
      (insert-it)
      (slime-add-presentation-properties start (point) output-id t))))

(defun slime-presentation-whole-p (presentation start end &optional object)
  (let ((object (or object (current-buffer))))
    (string= (etypecase object
               (buffer (with-current-buffer object
                         (buffer-substring-no-properties start end)))
               (string (substring-no-properties object start end)))
             (slime-presentation-text presentation))))

(defun slime-presentations-around-point (point &optional object)
  (let ((object (or object (current-buffer))))
    (loop for (key value . rest) on (text-properties-at point object) by 'cddr
          when (slime-presentation-p key)
          collect key)))

(defun slime-presentation-start-p (tag)
  (memq tag '(:start :start-and-end)))

(defun slime-presentation-stop-p (tag)
  (memq tag '(:end :start-and-end)))

(defun* slime-presentation-start (point presentation
                                        &optional (object (current-buffer)))
  "Find start of `presentation' at `point' in `object'.
Return buffer index and whether a start-tag was found."
  (let* ((this-presentation (get-text-property point presentation object)))
    (while (not (slime-presentation-start-p this-presentation))
      (let ((change-point (previous-single-property-change 
                           point presentation object)))
        (unless change-point
          (return-from slime-presentation-start
            (values (etypecase object
                      (buffer (with-current-buffer object 1))
                      (string 0))
                    nil)))
        (setq this-presentation (get-text-property change-point 
                                                   presentation object))
        (unless this-presentation
          (return-from slime-presentation-start 
            (values point nil)))
        (setq point change-point)))
    (values point t)))

(defun* slime-presentation-end (point presentation
                                      &optional (object (current-buffer)))
  "Find end of presentation at `point' in `object'.  Return buffer
index (after last character of the presentation) and whether an
end-tag was found."
  (let* ((this-presentation (get-text-property point presentation object)))
    (while (not (slime-presentation-stop-p this-presentation))
      (let ((change-point (next-single-property-change 
                           point presentation object)))
        (unless change-point
          (return-from slime-presentation-end
            (values (etypecase object
                      (buffer (with-current-buffer object (point-max)))
                      (string (length object))) 
                    nil)))
        (setq point change-point)
        (setq this-presentation (get-text-property point 
                                                   presentation object))))
    (if this-presentation 
        (let ((after-end (next-single-property-change point
                                                      presentation object)))
          (if (not after-end)
              (values (etypecase object
                        (buffer (with-current-buffer object (point-max)))
                        (string (length object))) 
                      t)
              (values after-end t)))
        (values point nil))))

(defun* slime-presentation-bounds (point presentation 
                                         &optional (object (current-buffer)))
  "Return start index and end index of `presentation' around `point'
in `object', and whether the presentation is complete."
  (multiple-value-bind (start good-start)
      (slime-presentation-start point presentation object)
    (multiple-value-bind (end good-end)
        (slime-presentation-end point presentation object)
      (values start end 
              (and good-start good-end
                   (slime-presentation-whole-p presentation 
                                               start end object))))))

(defun slime-presentation-around-point (point &optional object)
  "Return presentation, start index, end index, and whether the
presentation is complete."
  (let ((object (or object (current-buffer)))
        (innermost-presentation nil)
        (innermost-start 0)
        (innermost-end most-positive-fixnum))
    (dolist (presentation (slime-presentations-around-point point object))
      (multiple-value-bind (start end whole-p)
          (slime-presentation-bounds point presentation object)
        (when whole-p 
          (when (< (- end start) (- innermost-end innermost-start))
            (setq innermost-start start
                  innermost-end end
                  innermost-presentation presentation)))))
    (values innermost-presentation
            innermost-start innermost-end)))

(defun slime-presentation-around-or-before-point (point &optional object)
  (let ((object (or object (current-buffer))))
    (multiple-value-bind (presentation start end whole-p)
        (slime-presentation-around-point point object)
      (if (or presentation (= point (point-min)))
          (values presentation start end whole-p)
        (slime-presentation-around-point (1- point) object)))))

(defun slime-presentation-around-or-before-point-or-error (point)
  (multiple-value-bind (presentation start end whole-p)
      (slime-presentation-around-or-before-point point)
    (unless presentation
      (error "No presentation at point"))
    (values presentation start end whole-p)))

(defun* slime-for-each-presentation-in-region (from to function &optional (object (current-buffer)))
  "Call `function' with arguments `presentation', `start', `end',
`whole-p' for every presentation in the region `from'--`to' in the
string or buffer `object'."
  (flet ((handle-presentation (presentation point)
                              (multiple-value-bind (start end whole-p)
                                  (slime-presentation-bounds point presentation object)
                                (funcall function presentation start end whole-p))))
    ;; Handle presentations active at `from'.
    (dolist (presentation (slime-presentations-around-point from object))
      (handle-presentation presentation from))
    ;; Use the `slime-repl-presentation' property to search for new presentations.
    (let ((point from))
      (while (< point to)
        (setq point (next-single-property-change point 'slime-repl-presentation object to))
        (let* ((presentation (get-text-property point 'slime-repl-presentation object))
               (status (get-text-property point presentation object)))
          (when (slime-presentation-start-p status)
            (handle-presentation presentation point)))))))

;; XEmacs compatibility hack, from message by Stephen J. Turnbull on
;; xemacs-beta@xemacs.org of 18 Mar 2002
(unless (boundp 'undo-in-progress)
  (defvar undo-in-progress nil
   "Placeholder defvar for XEmacs compatibility from SLIME.")
  (defadvice undo-more (around slime activate)
     (let ((undo-in-progress t)) ad-do-it)))

(defun slime-after-change-function (start end &rest ignore)
  "Check all presentations within and adjacent to the change.
When a presentation has been altered, change it to plain text."
  (let ((inhibit-modification-hooks t))
    (let ((real-start (max 1 (1- start)))
          (real-end   (min (1+ (buffer-size)) (1+ end)))
          (any-change nil))
      ;; positions around the change
      (slime-for-each-presentation-in-region 
       real-start real-end
       (lambda (presentation from to whole-p)
         (cond
          (whole-p
           (slime-ensure-presentation-overlay from to presentation))
          ((not undo-in-progress)
           (slime-remove-presentation-properties from to 
                                                 presentation)
           (setq any-change t)))))
      (when any-change
        (undo-boundary)))))

(defun slime-presentation-around-click (event)
  "Return the presentation around the position of the mouse-click EVENT.
If there is no presentation, signal an error.
Also return the start position, end position, and buffer of the presentation."
  (when (and (featurep 'xemacs) (not (button-press-event-p event)))
    (error "Command must be bound to a button-press-event"))
  (let ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event))))
        (window (if (featurep 'xemacs) (event-window event) (caadr event))))
    (with-current-buffer (window-buffer window)
      (multiple-value-bind (presentation start end)
          (slime-presentation-around-point point)
        (unless presentation
          (error "No presentation at click"))
        (values presentation start end (current-buffer))))))

(defun slime-check-presentation (from to buffer presentation)
  (unless (slime-eval `(cl:nth-value 1 (swank:lookup-presented-object
                                        ',(slime-presentation-id presentation))))
    (with-current-buffer buffer
      (slime-remove-presentation-properties from to presentation))))

(defun slime-copy-or-inspect-presentation-at-mouse (event)
  (interactive "e") ; no "@" -- we don't want to select the clicked-at window
  (multiple-value-bind (presentation start end buffer)
      (slime-presentation-around-click event)
    (slime-check-presentation start end buffer presentation)
    (if (with-current-buffer buffer
          (eq major-mode 'slime-repl-mode))
        (slime-copy-presentation-at-mouse-to-repl event)
        (slime-inspect-presentation-at-mouse event))))

(defun slime-inspect-presentation (presentation start end buffer)
  (let ((reset-p 
	 (with-current-buffer buffer
	   (not (eq major-mode 'slime-inspector-mode)))))
    (slime-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p)
		      'slime-open-inspector)))

(defun slime-inspect-presentation-at-mouse (event)
  (interactive "e")
  (multiple-value-bind (presentation start end buffer) 
      (slime-presentation-around-click event)
    (slime-inspect-presentation presentation start end buffer)))

(defun slime-inspect-presentation-at-point (point)
  (interactive "d")
  (multiple-value-bind (presentation start end) 
      (slime-presentation-around-or-before-point-or-error point)
    (slime-inspect-presentation presentation start end (current-buffer))))


(defun slime-M-.-presentation (presentation start end buffer &optional where)
  (let* ((id (slime-presentation-id presentation))
	 (presentation-string (format "Presentation %s" id))
	 (location (slime-eval `(swank:find-definition-for-thing
				 (swank:lookup-presented-object
				  ',(slime-presentation-id presentation))))))
    (slime-edit-definition-cont
     (and location (list (make-slime-xref :dspec `(,presentation-string)
					  :location location)))
     presentation-string
     where)))

(defun slime-M-.-presentation-at-mouse (event)
  (interactive "e")
  (multiple-value-bind (presentation start end buffer) 
      (slime-presentation-around-click event)
    (slime-M-.-presentation presentation start end buffer)))

(defun slime-M-.-presentation-at-point (point)
  (interactive "d")
  (multiple-value-bind (presentation start end) 
      (slime-presentation-around-or-before-point-or-error point)
    (slime-M-.-presentation presentation start end (current-buffer))))

(defun slime-edit-presentation (name &optional where)
  (if (or current-prefix-arg (not (equal (slime-symbol-at-point) name)))
      nil ; NAME came from user explicitly, so decline.
      (multiple-value-bind (presentation start end whole-p)
	  (slime-presentation-around-or-before-point (point))
	(when presentation
	  (slime-M-.-presentation presentation start end (current-buffer) where)))))


(defun slime-copy-presentation-to-repl (presentation start end buffer)
  (let ((presentation-text 
	 (with-current-buffer buffer
	   (buffer-substring start end))))
    (unless (eql major-mode 'slime-repl-mode)
      (slime-switch-to-output-buffer))
    (flet ((do-insertion ()
	     (unless (looking-back "\\s-" (- (point) 1))
	       (insert " "))
	     (insert presentation-text)
	     (unless (or (eolp) (looking-at "\\s-"))
	       (insert " "))))
      (if (>= (point) slime-repl-prompt-start-mark)
	  (do-insertion)
	(save-excursion
	  (goto-char (point-max))
	  (do-insertion))))))

(defun slime-copy-presentation-at-mouse-to-repl (event)
  (interactive "e")
  (multiple-value-bind (presentation start end buffer) 
      (slime-presentation-around-click event)
    (slime-copy-presentation-to-repl presentation start end buffer)))

(defun slime-copy-presentation-at-point-to-repl (point)
  (interactive "d")
  (multiple-value-bind (presentation start end) 
      (slime-presentation-around-or-before-point-or-error point)
    (slime-copy-presentation-to-repl presentation start end (current-buffer))))

(defun slime-copy-presentation-at-mouse-to-point (event)
  (interactive "e")
  (multiple-value-bind (presentation start end buffer) 
      (slime-presentation-around-click event)
    (let ((presentation-text 
           (with-current-buffer buffer
             (buffer-substring start end))))
      (when (not (string-match "\\s-"
                               (buffer-substring (1- (point)) (point))))
        (insert " "))
      (insert presentation-text)
      (slime-after-change-function (point) (point))
      (when (and (not (eolp)) (not (looking-at "\\s-")))
        (insert " ")))))

(defun slime-copy-presentation-to-kill-ring (presentation start end buffer)
  (let ((presentation-text 
           (with-current-buffer buffer
             (buffer-substring start end))))
    (kill-new presentation-text)
    (message "Saved presentation \"%s\" to kill ring" presentation-text)))

(defun slime-copy-presentation-at-mouse-to-kill-ring (event)
  (interactive "e")
  (multiple-value-bind (presentation start end buffer) 
      (slime-presentation-around-click event)
    (slime-copy-presentation-to-kill-ring presentation start end buffer)))

(defun slime-copy-presentation-at-point-to-kill-ring (point)
  (interactive "d")
  (multiple-value-bind (presentation start end) 
      (slime-presentation-around-or-before-point-or-error point)
    (slime-copy-presentation-to-kill-ring presentation start end (current-buffer))))
  
(defun slime-describe-presentation (presentation)
  (slime-eval-describe 
     `(swank::describe-to-string
       (swank:lookup-presented-object ',(slime-presentation-id presentation)))))

(defun slime-describe-presentation-at-mouse (event)
  (interactive "@e")
  (multiple-value-bind (presentation) (slime-presentation-around-click event)
    (slime-describe-presentation presentation)))

(defun slime-describe-presentation-at-point (point)
  (interactive "d")
  (multiple-value-bind (presentation) 
      (slime-presentation-around-or-before-point-or-error point)
    (slime-describe-presentation presentation)))

(defun slime-pretty-print-presentation (presentation)
  (slime-eval-describe 
     `(swank::swank-pprint
       (cl:list
        (swank:lookup-presented-object ',(slime-presentation-id presentation))))))

(defun slime-pretty-print-presentation-at-mouse (event)
  (interactive "@e")
  (multiple-value-bind (presentation) (slime-presentation-around-click event)
    (slime-pretty-print-presentation presentation)))

(defun slime-pretty-print-presentation-at-point (point)
  (interactive "d")
  (multiple-value-bind (presentation) 
      (slime-presentation-around-or-before-point-or-error point)
    (slime-pretty-print-presentation presentation)))

(defun slime-mark-presentation (point)
  (interactive "d")
  (multiple-value-bind (presentation start end) 
      (slime-presentation-around-or-before-point-or-error point)
    (goto-char start)
    (push-mark end nil t)))

(defun slime-previous-presentation (&optional arg)
  "Move point to the beginning of the first presentation before point.
With ARG, do this that many times.
A negative argument means move forward instead."
  (interactive "p")
  (unless arg (setq arg 1))
  (slime-next-presentation (- arg)))

(defun slime-next-presentation (&optional arg)
  "Move point to the beginning of the next presentation after point.
With ARG, do this that many times.
A negative argument means move backward instead."
  (interactive "p")
  (unless arg (setq arg 1))
  (cond
   ((plusp arg)
    (dotimes (i arg)
      ;; First skip outside the current surrounding presentation (if any)
      (multiple-value-bind (presentation start end) 
	  (slime-presentation-around-point (point))
	(when presentation
	  (goto-char end)))
      (let ((p (next-single-property-change (point) 'slime-repl-presentation)))
	(unless p 
	  (error "No next presentation"))
	(multiple-value-bind (presentation start end) 
	    (slime-presentation-around-or-before-point-or-error p)
	  (goto-char start)))))
   ((minusp arg)
    (dotimes (i (- arg))
      ;; First skip outside the current surrounding presentation (if any)
      (multiple-value-bind (presentation start end)
	  (slime-presentation-around-point (point))
	(when presentation
	  (goto-char start)))
      (let ((p (previous-single-property-change (point) 'slime-repl-presentation)))
	(unless p 
	  (error "No previous presentation"))
	(multiple-value-bind (presentation start end) 
	    (slime-presentation-around-or-before-point-or-error p)
	  (goto-char start)))))))

(defvar slime-presentation-map (make-sparse-keymap))

(define-key  slime-presentation-map [mouse-2] 'slime-copy-or-inspect-presentation-at-mouse)
(define-key  slime-presentation-map [mouse-3] 'slime-presentation-menu)

(when (featurep 'xemacs)
  (define-key  slime-presentation-map [button2] 'slime-copy-or-inspect-presentation-at-mouse)
  (define-key  slime-presentation-map [button3] 'slime-presentation-menu))

;; protocol for handling up a menu.
;; 1. Send lisp message asking for menu choices for this object. 
;;    Get back list of strings.
;; 2. Let used choose
;; 3. Call back to execute menu choice, passing nth and string of choice

(defun slime-menu-choices-for-presentation (presentation buffer from to choice-to-lambda)
  "Return a menu for `presentation' at `from'--`to' in `buffer', suitable for `x-popup-menu'."
  (let* ((what (slime-presentation-id presentation))
         (choices (with-current-buffer buffer
                    (slime-eval 
                     `(swank::menu-choices-for-presentation-id ',what)))))
    (flet ((savel (f) ;; IMPORTANT - xemacs can't handle lambdas in x-popup-menu. So give them a name
            (let ((sym (gensym)))
              (setf (gethash sym choice-to-lambda) f)
              sym)))
    (etypecase choices
      (list
       `(,(format "Presentation %s" what)
         ("" 
	  ("Find Definition" . ,(savel 'slime-M-.-presentation-at-mouse))
          ("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse))
          ("Describe" . ,(savel 'slime-describe-presentation-at-mouse))
          ("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse))
          ("Copy to REPL" . ,(savel 'slime-copy-presentation-at-mouse-to-repl))
          ("Copy to kill ring" . ,(savel 'slime-copy-presentation-at-mouse-to-kill-ring))
          ,@(unless buffer-read-only 
              `(("Copy to point" . ,(savel 'slime-copy-presentation-at-mouse-to-point))))
          ,@(let ((nchoice 0))
              (mapcar 
               (lambda (choice)
                 (incf nchoice)
                 (cons choice 
                       (savel `(lambda ()
                          (interactive)
                          (slime-eval 
                           '(swank::execute-menu-choice-for-presentation-id
                             ',what ,nchoice ,(nth (1- nchoice) choices)))))))
               choices)))))
      (symbol                           ; not-present
       (with-current-buffer buffer
         (slime-remove-presentation-properties from to presentation))
       (sit-for 0)                      ; allow redisplay
       `("Object no longer recorded" 
         ("sorry" . ,(if (featurep 'xemacs) nil '(nil)))))))))

(defun slime-presentation-menu (event)
  (interactive "e")
  (let* ((point (if (featurep 'xemacs) (event-point event) 
                  (posn-point (event-end event))))
         (window (if (featurep 'xemacs) (event-window event) (caadr event)))
         (buffer (window-buffer window))
         (choice-to-lambda (make-hash-table)))
    (multiple-value-bind (presentation from to)
        (with-current-buffer buffer
          (slime-presentation-around-point point))
      (unless presentation
        (error "No presentation at event position"))
      (let ((menu (slime-menu-choices-for-presentation 
                   presentation buffer from to choice-to-lambda)))
        (let ((choice (x-popup-menu event menu)))
          (when choice
            (call-interactively (gethash choice choice-to-lambda))))))))

(defun slime-presentation-expression (presentation)
  "Return a string that contains a CL s-expression accessing 
the presented object."
  (let ((id (slime-presentation-id presentation)))
    (etypecase id
      (number
       ;; Make sure it works even if *read-base* is not 10.
       (format "(swank:lookup-presented-object-or-lose %d.)" id))
      (list
       ;; for frame variables and inspector parts
       (format "(swank:lookup-presented-object-or-lose '%s)" id)))))

(defun slime-buffer-substring-with-reified-output (start end)
  (let ((str-props (buffer-substring start end))
        (str-no-props (buffer-substring-no-properties start end)))
    (slime-reify-old-output str-props str-no-props)))

(defun slime-reify-old-output (str-props str-no-props)
  (let ((pos (slime-property-position 'slime-repl-presentation str-props)))
    (if (null pos)
        str-no-props
        (multiple-value-bind (presentation start-pos end-pos whole-p)
            (slime-presentation-around-point pos str-props)
          (if (not presentation)
              str-no-props
              (concat (substring str-no-props 0 pos)
                      ;; Eval in the reader so that we play nice with quote.
                      ;; -luke (19/May/2005)
                      "#." (slime-presentation-expression presentation)
                      (slime-reify-old-output (substring str-props end-pos)
                                              (substring str-no-props end-pos))))))))



(defun slime-repl-grab-old-output (replace)
  "Resend the old REPL output at point.  
If replace it non-nil the current input is replaced with the old
output; otherwise the new input is appended."
  (multiple-value-bind (presentation beg end) 
      (slime-presentation-around-or-before-point (point))
    (slime-check-presentation beg end (current-buffer) presentation)
    (let ((old-output (buffer-substring beg end))) ;;keep properties
      ;; Append the old input or replace the current input
      (cond (replace (goto-char slime-repl-input-start-mark))
            (t (goto-char (point-max))
               (unless (eq (char-before) ?\ )
                 (insert " "))))
      (delete-region (point) (point-max))
      (let ((inhibit-read-only t))
        (insert old-output)))))

;;; Presentation-related key bindings, non-context menu

(defvar slime-presentation-command-map nil
  "Keymap for presentation-related commands. Bound to a prefix key.")

(defvar slime-presentation-bindings
  '((?i slime-inspect-presentation-at-point)
    (?d slime-describe-presentation-at-point)
    (?w slime-copy-presentation-at-point-to-kill-ring)
    (?r slime-copy-presentation-at-point-to-repl)
    (?p slime-previous-presentation)
    (?n slime-next-presentation)
    (?\  slime-mark-presentation)))

(defun slime-presentation-init-keymaps ()
  (slime-init-keymap 'slime-presentation-command-map nil t 
		     slime-presentation-bindings)
  (define-key slime-presentation-command-map "\M-o" 'slime-clear-presentations)
  ;; C-c C-v is the prefix for the presentation-command map.
  (define-key slime-prefix-map "\C-v" slime-presentation-command-map))

(defun slime-presentation-around-or-before-point-p ()
  (multiple-value-bind (presentation beg end) 
      (slime-presentation-around-or-before-point (point))
    presentation))

(defvar slime-presentation-easy-menu
  (let ((P '(slime-presentation-around-or-before-point-p)))
    `("Presentations"
      [ "Find Definition" slime-M-.-presentation-at-point ,P ]
      [ "Inspect" slime-inspect-presentation-at-point ,P ]
      [ "Describe" slime-describe-presentation-at-point ,P ]
      [ "Pretty-print" slime-pretty-print-presentation-at-point ,P ]
      [ "Copy to REPL" slime-copy-presentation-at-point-to-repl ,P ]
      [ "Copy to kill ring" slime-copy-presentation-at-point-to-kill-ring ,P ]
      [ "Mark" slime-mark-presentation ,P ]
      "--"
      [ "Previous presentation" slime-previous-presentation ]
      [ "Next presentation" slime-next-presentation ]
      "--"
      [ "Clear all presentations" slime-clear-presentations ])))

(defun slime-presentation-add-easy-menu ()
  (easy-menu-define menubar-slime-presentation slime-mode-map "Presentations" slime-presentation-easy-menu)
  (easy-menu-define menubar-slime-presentation slime-repl-mode-map "Presentations" slime-presentation-easy-menu)
  (easy-menu-define menubar-slime-presentation sldb-mode-map "Presentations" slime-presentation-easy-menu)
  (easy-menu-define menubar-slime-presentation slime-inspector-mode-map "Presentations" slime-presentation-easy-menu)
  (easy-menu-add slime-presentation-easy-menu 'slime-mode-map)
  (easy-menu-add slime-presentation-easy-menu 'slime-repl-mode-map)
  (easy-menu-add slime-presentation-easy-menu 'sldb-mode-map)
  (easy-menu-add slime-presentation-easy-menu 'slime-inspector-mode-map))

;;; hook functions (hard to isolate stuff)

(defun slime-dispatch-presentation-event (event)
  (destructure-case event
    ((:presentation-start id &optional target)
     (slime-mark-presentation-start id target)
     t)
    ((:presentation-end id &optional target)
     (slime-mark-presentation-end id target)
     t)
    (t nil)))

(defun slime-presentation-write-result (string)
  (with-current-buffer (slime-output-buffer)
    (let ((marker (slime-output-target-marker :repl-result)))
      (goto-char marker)
      (slime-propertize-region `(face slime-repl-result-face
                                      rear-nonsticky (face))
        (insert string))
      ;; Move the input-start marker after the REPL result.
      (set-marker marker (point)))
    (slime-repl-show-maximum-output)))

(defun slime-presentation-write (string &optional target)
  (case target
    ((nil)                              ; Regular process output
     (slime-repl-emit string))
    (:repl-result                       
     (slime-presentation-write-result string))
    (t (slime-emit-to-target string target))))

(defun slime-presentation-current-input (&optional until-point-p)
  "Return the current input as string.
The input is the region from after the last prompt to the end of
buffer. Presentations of old results are expanded into code."
  (slime-buffer-substring-with-reified-output  slime-repl-input-start-mark
					       (point-max)))

(defun slime-presentation-on-return-pressed ()
  (when (and (car (slime-presentation-around-or-before-point (point)))
             (< (point) slime-repl-input-start-mark))
    (slime-repl-grab-old-output end-of-input)
    (slime-repl-recenter-if-needed)
    t))

(defun slime-presentation-on-stream-open (stream)
  (require 'bridge)
  (defun bridge-insert (process output)
    (slime-output-filter process (or output "")))
  (install-bridge)
  (setq bridge-destination-insert nil)
  (setq bridge-source-insert nil)
  (setq bridge-handlers 
	(list* '("<" . slime-mark-presentation-start-handler) 
	       '(">" . slime-mark-presentation-end-handler)
	       bridge-handlers)))

(defun slime-clear-presentations ()
  "Forget all objects associated to SLIME presentations.
This allows the garbage collector to remove these objects
even on Common Lisp implementations without weak hash tables."
  (interactive)
  (slime-eval-async `(swank:clear-repl-results))
  (unless (eql major-mode 'slime-repl-mode)
    (slime-switch-to-output-buffer))
  (slime-for-each-presentation-in-region 1 (1+ (buffer-size)) 
					 (lambda (presentation from to whole-p)
					   (slime-remove-presentation-properties from to 
										 presentation))))

(defun slime-presentation-inspector-insert-ispec (ispec)
  (if (stringp ispec)
      (insert ispec)
    (destructure-case ispec
      ((:value string id)
       (slime-propertize-region 
           (list 'slime-part-number id 
                 'mouse-face 'highlight
                 'face 'slime-inspector-value-face)
         (slime-insert-presentation string `(:inspected-part ,id) t)))
      ((:label string)
       (insert (slime-inspector-fontify label string)))
      ((:action string id)
       (slime-insert-propertized (list 'slime-action-number id
                                       'mouse-face 'highlight
                                       'face 'slime-inspector-action-face)
                                 string)))))

(defun slime-presentation-sldb-insert-frame-variable-value (value frame index)
  (slime-insert-presentation
   (in-sldb-face local-value value)
   `(:frame-var ,slime-current-thread ,(car frame) ,index) t))

(provide 'slime-presentations)