glime.lisp 33.6 KB
Newer Older
1
2
3
4
;; $Id: //info.ravenbrook.com/project/gendl/master/genworks/emacs/gendl.lisp#5 $

(in-package :swank)

Dave Cooper's avatar
Dave Cooper committed
5
;;                            glime.lisp
6
7
8
9
;;           Nick Levine, Ravenbrook Limited, 2013-05-02
;;
;; 1.  INTRODUCTION
;;
Dave Cooper's avatar
Dave Cooper committed
10
11
;; The purpose of this document is to implement GENDL customizations
;; for SLIME (collectively known as "Glime(TM)")
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
;;
;; The following features have been implemented so far:
;;
;; * modeline and completion help for the keywords accepted by
;;   gendl:define-object,
;;
;; * modeline and completion help for the keywords accepted inside an
;;   :objects or :hidden-objects argument to gendl:define-object,
;;   gendl:make-object, or gendl:make-self.
;;
;; The intended readership is project developers.
;;
;; This document is not confidential. See end for copyright
;; information.

27
(defparameter *gendl-slime-release* "0.1.1")
28
29
30
31
32
33


;; 2.  TESTS
;;
;; It's handy to be able to test this outside of the SLIME environmemnt.
;;
34
;; '("define-object" "empty" nil ":objects" ("" %cursor-marker%))
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
;; ->
;; "(define-object name mixin-list &key ===> objects <=== &allow-other-keys)"

(defun gendl-autodoc-test (raw-form)
  (let ((*buffer-package* (find-package "GDL-USER"))
        (*buffer-readtable* *readtable*))
    (car (autodoc raw-form))))


;; 3.  MACROS

;; We need a (very, very) basic and portable advice facility. The
;; potentially dangerous assumption it makes is that the original
;; function won't be redefined behind our backs. I can't think of an
;; easy way to prevent users from doing that. On the other hand,
;; there's no reason why they should.

;; The #+lispworks conditionalisations immediately below are present
;; purely as development aids.

#+lispworks
(dspec:define-dspec-alias def-wrap (name)
  `(defun ,name))

(defmacro def-wrap (name lambda-list &body body)
  "Wrap BODY around the function defined by NAME. Locally defined #'PUNT
   will access the original definition."
  (let* ((args-var (gensym "ARGS-"))
         (cache-form `(unless (get ',name 'gendl-unwrapped)
                        (setf (get ',name 'gendl-unwrapped) (symbol-function ',name))))
         (wrapped-body `(,@(loop for next = (first body)
                                 while (or (stringp next)
                                           (and (consp next)
                                                (eq (car next) 'declare)))
                                 collect (pop body))
                         (flet ((punt (&rest ,args-var)
                                  (apply (get ',name 'gendl-unwrapped) ,args-var)))
                           ,@body))))
    #+lispworks
    `(dspec:def (def-wrap ,name)
       ,cache-form
       (let ((lw:*redefinition-action* :quiet))
         (defun ,name ,lambda-list ,@wrapped-body))
       ',name)
    #-lispworks
    `(progn
       ,cache-form
       (setf (symbol-function ',name)
             (lambda ,lambda-list ,@wrapped-body)))))


(defun wrap-test-original (x)
  (cons :original x))

(defun test-def-wrap ()
  (def-wrap wrap-test-original (x)
    (cons :wrapped (cdr (punt (1+ x)))))
  (assert (equal (wrap-test-original 3) '(:wrapped . 4)))
  (def-wrap wrap-test-original (x)
    (punt x))
  (assert (equal (wrap-test-original 3) '(:original . 3))))

(test-def-wrap)

unknown's avatar
unknown committed
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
;; I keep needing these.

(defmacro orf (location form &environment env)
  (multiple-value-bind (vars values new setter getter)
      (get-setf-expansion location env)
    (when (cdr new)
      (error "Can't work with setf-expansion for ~s - ~d values from setter ~s"
             location (length new) new))
    (let ((current (car new)))
      `(let* (,@(mapcar 'list vars values)
              (,current ,getter))
         (or ,current
             (progn (setf ,current ,form)
               ,setter))))))

#-:lispworks 
(defmacro when-let (binding &body body)
  (destructuring-bind (var val) binding
    `(let ((,var ,val))
       (when ,var
	 ,@body))))

#||
#-:lispworks
(defmacro when-let* (bindings &body body)
  (if bindings
      `(when-let ,(car bindings)
	 (when-let* ,(cdr bindings)
	   ,@body))
    `(progn ,@body)))
||#

unknown's avatar
unknown committed
131
132
133
134
135
136
137
138
139
140
;; We could do with more informative error handling than SLIME provides. Getting
;; this right can be quite a lot of work, but making a start is cheap.

(defmacro handling-whatever ((&rest options) &body body)
  (declare (ignore options))
  `(handler-bind ((serious-condition (lambda (condition)
                                       ;; Print the problem and decline to handle.
                                       (format *terminal-io* "~&;; Error: ~a~%" condition))))
     ,@body))

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

;; 4.  ADVISE SWANK FUNCTIONS
;;
;; The main defintions of the four functions wrapped below are all in
;; the contrib file swank-arglists.lisp.
;;
;; We use *autodoc-highlighting* to disable runaway hightlighting when
;; we're showing init-slots in the modeline. The method on
;; compute-enriched-decoded-arglist below might set *autodoc-highlighting*
;; to nil.

(defvar *autodoc-highlighting* t)

;; Used for modeline display of available arguments.
(def-wrap autodoc (raw-form &key print-right-margin)
  (let ((*autodoc-highlighting* *autodoc-highlighting*)
        ;; The default is to view symbols as if we were in the CL-USER
        ;; package. I can't see how this helps anybody, so I'm
        ;; disabling it.
        (*arglist-show-packages* nil))
    (punt raw-form :print-right-margin print-right-margin)))

(def-wrap form-path-to-arglist-path (form-path form arglist)
  (when *autodoc-highlighting*
    (punt form-path form arglist)))

;; There are two different paths which call find-subform-with-arglist. We
;; want to know which one we're on and we do this by binding
;; *grovelling-for-arglist*.

(defvar *grovelling-for-arglist* nil)

;; Used for (keyword) completion.
(def-wrap find-immediately-containing-arglist (form)
  (let ((*grovelling-for-arglist* t))
    (punt form)))

178
179
180
;; This might be useful further down.
(defvar *form-with-arglist*)

181
182
;; Invoked by both autodoc and find-immediately-containing-arglist.
(def-wrap find-subform-with-arglist (form)
unknown's avatar
unknown committed
183
184
185
186
187
188
  (handling-whatever ()
    (let ((*form-with-arglist* form))
      (if (and *grovelling-for-arglist*
               (eq (car form) 'gendl:define-object))
          (find-define-object-subform form #'punt)
        (punt form)))))
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


;; 5.  KEYWORDS ACCEPTED BY DEFINE-OBJECT, MAKE-OBJECT, MAKE-SELF

;;; We make gendl:define-object appear to have the same arglist as
;;; gendl::%define-object% (modulo three keywords which Dave Cooper
;;; says aren't in use.)

(defparameter *define-object-unsupported*
  '(:methods :no-vanilla-mixin? :query-slots))

;; See (defgeneric extra-keywords) in swank-arglists.lisp
(defmethod extra-keywords ((operator (eql 'gendl:define-object)) &rest arguments)
  (values (reverse (let ((unsupported *define-object-unsupported*))
		     (loop for keyword-arg in (arglist.keyword-args (compute-enriched-decoded-arglist 'gendl::%define-object% arguments))
			unless (find (keyword-arg.keyword keyword-arg) unsupported)
			collect keyword-arg)))
          t nil))

(defmethod extra-keywords ((operator (eql 'gendl:make-object)) &rest args)
  (or (keyword-args-from-class-input-slots (car args))
      (call-next-method)))

(defmethod extra-keywords ((operator (eql 'gendl:make-self)) &rest args)
  (or (keyword-args-from-class-input-slots (car args))
      (call-next-method)))

(defun keyword-args-from-class-input-slots (classname-form)
  (when (and (consp classname-form)
             (= (length classname-form) 2)
             (eq (car classname-form) 'quote))
    (let ((classname (cadr classname-form)))
      (multiple-value-bind (proceed input-slots)
          (class-input-slots classname)
        (when proceed
          (loop for slot in input-slots collect
                (make-keyword-arg slot slot nil)))))))



;; 6.  HELP ON SPECIFIC DEFINE-OBJECT KEYWORDS
;;
;; We use the swank interface for "enriching" an arglist. The method
;; below determines whether we're working on a specific keyword

;; A call might look like this:
;; (compute-enriched-decoded-arglist define-object (empty nil :objects (#s(swank::arglist-dummy :string-representation ""))))
;; Note that SLIME has already chopped everything to the right of the
;; cursor maker; editing
;;     (define-object empty () :objects ( ) :documentation ())
;; with the cursor here:              -->^<--
;; is the same as editing (define-object empty () :objects ()).
;;
;; See (defgeneric compute-enriched-decoded-arglist) in swank-arglists.lisp
(defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:define-object)) arguments)
  (multiple-value-bind (decoded-arglist determining-args any-enrichment)
      (call-next-method)
    (destructuring-bind (&optional name mixins &rest spec-pairs)
        arguments
      (declare (ignore name mixins))
      ;; Has the user got as far as the keyword list yet?
      (when spec-pairs
        ;; Which keyword are they working on?
        (multiple-value-bind (key values)
            (active-keyword spec-pairs)
          (when key
unknown's avatar
unknown committed
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
            (when-let (this-keyword-arg (find key (arglist.keyword-args decoded-arglist)
                                              :key 'keyword-arg.keyword))
              ;; Mangle the arglist structure: only show the keyword we're working on.
              (let ((local-arglist (copy-arglist decoded-arglist)))
                (setf (arglist.keyword-args local-arglist) (list this-keyword-arg)
                      (arglist.rest local-arglist) nil
                      (arglist.allow-other-keys-p local-arglist) t
                      ;; Disable highlighting.
                      *autodoc-highlighting* nil)
                (return-from compute-enriched-decoded-arglist
                  ;; If we can, make the init-slots for this keyword appear to be
                  ;; its default initargs. Behold! That makes them look just right.
                  (values (augment-gendl-define-object (keyword-arg.keyword this-keyword-arg)
                                                       local-arglist
                                                       values)
                          determining-args t))))))))
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
    ;; &allow-other-keys and &rest don't contribute anything here.
    (setf (arglist.rest decoded-arglist) nil
	  (arglist.allow-other-keys-p decoded-arglist) nil)
    (values decoded-arglist determining-args any-enrichment)))

(defgeneric augment-gendl-define-object (keyword arglist values)
  (:documentation
   "We're editing the value for gendl:define-object keyword KEYWORD. Return
    an arglist based on ARGLIST which conveys more information about the
    VALUES being edited."
   )
  (:method (keyword arglist values)
   (declare (ignore keyword values))
   arglist))


;; 6.1. Keyword support for :objects & :hidden-objects

(defmethod augment-gendl-define-object ((keyword (eql :objects)) arglist values)
  (augment-gendl-define-object-for-objects keyword arglist values))

(defmethod augment-gendl-define-object ((keyword (eql :hidden-objects)) arglist values)
  (augment-gendl-define-object-for-objects keyword arglist values))

;; Perform basic checks and then treat this as an implicit make-object.
(defun augment-gendl-define-object-for-objects (keyword arglist values)
  (let ((keyword-arg (or (find keyword (arglist.keyword-args arglist) :key 'keyword-arg.keyword)
                         ;; Shouldn't get here; playing it safe.
                         (return-from augment-gendl-define-object-for-objects arglist)))
        (value (let ((value (car (last values))))
                 (if (consp value)
                     value
                   (return-from augment-gendl-define-object-for-objects arglist)))))
    (setf (keyword-arg.default-arg keyword-arg) (implicit-make-object value)))
  arglist)

;; Value is the object-form on which the user is working. It'll be a
;; list consisting of lisp objects interspersed with SWANK arglist-dummies.
(defun implicit-make-object (value)
  (or (multiple-value-bind (proceed name type input-slots)
          (destructure-implicit-make-object value)
        (when proceed
          (let ((safe-name (let ((*read-eval* nil))
                             (read-from-string (undummy name)))))
	    ;; Note use of intern, to ensure hardwired symbols arrive in *package*.
            `((,safe-name :type ,type &key ,@input-slots) &rest ,(cautious-intern "MORE-OBJECTS")))))
      ;; We haven't got far enough to say anything yet.
      `((,(cautious-intern "NAME") &key type &allow-other-keys) &rest ,(cautious-intern "MORE-OBJECTS"))))


;; 7.  KEYWORD COMPLETION

(defun find-define-object-subform (form finder)
  (destructuring-bind (&optional name mixins &rest spec-pairs)
      (cdr form)
    (declare (ignore name mixins))
    ;; Has the user got onto the keyword list yet?
    (when spec-pairs
      ;; Which keyword are they working on?
      (multiple-value-bind (key values)
          (active-keyword spec-pairs)
        (when key
unknown's avatar
unknown committed
333
          (let ((value (car (last values))))
334
            ;; Can we do anything with this keyword?
unknown's avatar
unknown committed
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
            (when-let (new-form ;; (To do: hive this off as a separate GF.)
                                (case key
                                  ((:objects
                                    :hidden-objects) (let ((keywords (loop for x in (cdr value) until (arglist-dummy-p x) collect x)))
                                                       (multiple-value-bind (proceed name type input-slots)
                                                           (destructure-implicit-make-object
                                                            (cons (intern (undummy (car value))) keywords))
                                                         (declare (ignore name input-slots))
                                                         (if proceed
                                                             `(gendl:make-self ,type)
                                                           ;; Nothing useful found. Bail out.
                                                           (return-from find-define-object-subform
                                                             (values '(gendl:make-self)
                                                                     (make-arglist :key-p t
                                                                                   :keyword-args (unless (find :type keywords)
                                                                                                   (list (make-keyword-arg :type :type nil)))
                                                                                   :allow-other-keys-p t)))))))))

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
              ;; Apply original defintion of find-subform-with-arglist to gendl:make-self form.
              (return-from find-define-object-subform
                (funcall finder new-form))))))))
  ;; No? Apply original defintion of find-subform-with-arglist to original
  (funcall finder form))



;; 8.  DESTRUCTURING IMPLICIT MAKE-OBJECT FORMS

(defun destructure-implicit-make-object (form)
  "If FORM destructures as (SLOTNAME (quote CLASSNAME) ...) and CLASSNAME
   names a subclass of gendl:vanilla-mixin* then treturn four values: t,
   SLOTNAME, (quote CLASSNAME), and the class's init-slots. Otherwise
   return nil."
  (multiple-value-bind (name classname-form)
      (ignore-errors                                   ; catch destructuring-bind errors
        (destructuring-bind (name &key ((:type classname-form)) &allow-other-keys)
            (if (oddp (length form))                   ; is (cdr form) currently a well-formed plist?
                form
              (butlast form))
          (values name classname-form)))
    ;; CLASSNAME-FORM destructures as 'CLASSNAME.
    (let ((classname (when (and (listp classname-form)
                                (eq (car classname-form) 'quote))
                       (cadr classname-form))))
      (multiple-value-bind (proceed input-slots)
          (class-input-slots classname)
        (values proceed name classname-form input-slots)))))

(defun class-input-slots (classname)
  "Use message-list on a prototype instance of CLASSNAME to determine its
   required and optional input-slots. Return two values: t and the slots.
   If the class wasn't a subclass of gendl:vanilla-mixin* then return nil"
  (when (and classname
             (symbolp classname)
unknown's avatar
unknown committed
389
390
             (when-let (class (find-class classname nil))
               (subtypep class 'gendl:vanilla-mixin*)))
unknown's avatar
unknown committed
391
    (let ((prototype (gendl-class-prototype classname)))
392
393
      (values t
              (append (gendl:the-object prototype (message-list :category :required-input-slots))
394
                      (remove-if 'internal-name-p
395
396
                                 (gendl:the-object prototype (message-list :category :optional-input-slots))))))))

unknown's avatar
unknown committed
397
398
399
400
401
402
403
(defun gendl-class-prototype (class)
  "We could access the lisp implementation's CLOS class-prototype, but
can't expect that to have any boundp slots. For some of our uses that
doesn't matter. For others it does. So we'll make an object and cache it."
  (let ((class-name (etypecase class
                      (symbol class)
                      (class (class-name class)))))
unknown's avatar
unknown committed
404
405
    (orf (get class-name 'gendl-class-prototype)
         (gendl:make-object class))))
406
407
408
409
410
411
412

(defun internal-name-p (keyword)
  (let ((symbol-name (symbol-name keyword)))
    (and (char= (schar symbol-name 0) #\%)
         (char= (schar symbol-name (1- (length symbol-name))) #\%))))


unknown's avatar
unknown committed
413
414
415
;; 9.  HELP ON MESSAGES FOR GENDL:THE AND FRIENDS

;; We're only looking at the top of the reference-chain. See
416
;; http://paste.lisp.org/display/137274
unknown's avatar
unknown committed
417
418
419
420
421
;; Note that (the (slot-source :bar)) gives you info about the
;; specified :type of bar.  "You also have to establish the fact that
;; bar is indeed a GDL object and not some leaf-level value as with a
;; computed-slot (like a string or number). That can be done with
;; :return-category t."
422

Dave Cooper's avatar
Dave Cooper committed
423
424
425
426
427
428
(defparameter *message-locators*
  '(messages-in-this-form
    messages-from-classes)
  "A list of functions, each taking a (gendl:define-object ...) form,
each returning a list of proposed messages.")

429
(defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:the)) arguments)
Dave Cooper's avatar
Dave Cooper committed
430
  (declare (ignorable arguments))
unknown's avatar
unknown committed
431
432
433
434
435
436
437
438
439
440
  (or (embedded-the-arglist) (call-next-method)))

(defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:the-object)) arguments)
  (declare (ignorable arguments))
  (or (embedded-the-arglist) (call-next-method)))

(defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:the-child)) arguments)
  (declare (ignorable arguments))
  (or (embedded-the-arglist) (call-next-method)))

441
442
(defvar *this-the*)

unknown's avatar
unknown committed
443
(defun embedded-the-arglist ()
444
  (let* ((whole-form *form-with-arglist*)
unknown's avatar
unknown committed
445
446
447
448
449
450
451
452
453
         (*this-the* (or (this-the-from-form whole-form)
                         ;; The gend:the form isn't embedded inside a define-object. Bail out.
                         (return-from embedded-the-arglist
                           nil))))
    (when-let (messages (when (and (consp whole-form)
                                   (eq (car whole-form) 'gendl:define-object))
                          (remove-duplicates (loop for locator in *message-locators* append
                                                   (funcall locator whole-form))
                                             :from-end t)))
454
455
456
457
458
459
460
      (values (make-arglist :key-p t
			    :keyword-args (loop for message in messages collect
						(make-keyword-arg message message nil))
			    :provided-args nil
			    :allow-other-keys-p t
			    :rest 'reference-chain)
	      nil t))))
unknown's avatar
unknown committed
461

unknown's avatar
unknown committed
462

unknown's avatar
unknown committed
463
464
465
466
;; 9.1. Analyse the current gendl:the form

(defstruct (this-the
            (:constructor make-this-the (section slot-form the-form
467
                                                 &aux
unknown's avatar
unknown committed
468
469
                                                 (functionp (when (consp the-form)
                                                              (the-form-functionp (cdr the-form))))
unknown's avatar
unknown committed
470
471
472
473
474
475
476
                                                 (quantifiedp (quantified-objects-p section slot-form the-form)))))
  section
  slot-form
  the-form
  functionp
  quantifiedp)

unknown's avatar
unknown committed
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
;; Select "(the ... (..."
(defun the-form-functionp (form)
  (when form
    (or (and (consp (car form))
             (or (eq (cadr form) '%cursor-marker%)
                 (null (cdr form))))
        (the-form-functionp (cdr form)))))

;; If we are inside an :object or :hidden-object specification, and
;; one of the input keys is ":sequence", then "(the-child ..."  should
;; include display of the sequence messages as well as (in this case)
;; the user-visible messages for 'box.  Otherwise, the "sequence
;; messages" should be suppressed.
;;
;; http://paste.lisp.org/display/137258

unknown's avatar
unknown committed
493
494
495
496
497
498
499
500
501
(defun quantified-objects-p (section slot-form the-form)
  (and (case section
         ((objects hidden-objects) t))
       (destructuring-bind (operator &rest more)
           the-form
         (declare (ignore more))
         (case operator
           ((gendl:the-child)
            ;; It's a the-child inside an :object or :hidden-object.
unknown's avatar
unknown committed
502
            (not (null (find-key :sequence (cdr slot-form)))))))))
unknown's avatar
unknown committed
503
504

;; Try repeating the name of this function, many times, fast, and in a darkened room.
505

unknown's avatar
unknown committed
506
507
(defun this-the-from-form (form)
  ;; A bit like messages-in-this-form below, best done as a separate cycle.
unknown's avatar
unknown committed
508
  (when (eq (car form) 'gendl:define-object)
509
510
511
512
513
514
515
516
517
518
519
    (destructuring-bind (classname &optional mixins
				   &key input-slots computed-slots objects hidden-objects functions methods
				   &allow-other-keys)
	(cdr form)
      (declare (ignore classname mixins))
      (loop for section in (list input-slots computed-slots objects hidden-objects functions methods)
	 as section-name in '(input-slots computed-slots objects hidden-objects functions methods)
	 do
	 (loop for item in section
	    when (consp item)
	    do
unknown's avatar
unknown committed
520
521
522
	    (when-let (form-with-cursor-marker (form-with-cursor-marker item))
	      (return-from this-the-from-form
                (make-this-the section-name item form-with-cursor-marker))))))))
523

unknown's avatar
unknown committed
524
525
526
527
528
529
530
531

(defun form-with-cursor-marker (form)
  ;; Return, if any, the innermost (the ...) form containing the
  ;; cursor-marker.
  (loop for thing in form
        do
        (cond ((eq thing '%cursor-marker%) (return form))
              ((consp thing)
unknown's avatar
unknown committed
532
533
534
535
536
537
               (when-let (inner-form (form-with-cursor-marker thing))
                 (if (and (consp inner-form)
                          (case (car inner-form)
                            ((gendl:the gendl:the-child gendl:the-object) t)))
                     (return inner-form)
                   (return thing)))))))
unknown's avatar
unknown committed
538
539
540


;; 9.2. Messages which we can deduce from the current form.
541
542
543

(defun messages-in-this-form (form)
  "Do what define-object itself does, to figure out the messages being
unknown's avatar
unknown committed
544
545
defined by this form. As a side effect, set *this-the* to the
gendl:the (etc) form under construction."
546
547
548
549
550
551
552
553
554
555
556
557
  (destructuring-bind (classname &optional mixins
                                 &key input-slots computed-slots objects hidden-objects functions methods
                                 &allow-other-keys)
      (cdr form)
    (declare (ignore classname mixins))
    ;; [logic lifted from gendl::with-gdl-message-symbols]
    (loop for section in (list input-slots computed-slots objects hidden-objects functions methods)
          append
          (with-buffer-syntax ()
            (let ((keyword (find-package :keyword)))
              (loop for item in section
                    for symbol = (cond ((symbolp item) item)
unknown's avatar
unknown committed
558
559
                                       ((consp item) (unless (form-with-cursor-marker item)
                                                       ;; Exclude the message we're in the process of creating.
560
561
562
563
564
565
566
567
568
569
570
                                                       (let ((first (gendl::first-symbol item)))
                                                         (typecase first
                                                           (symbol first)
                                                           (arglist-dummy (from-string (arglist-dummy.string-representation first))))))))
                    when symbol
                    collect
                    (if (eq (symbol-package symbol) keyword)
                        symbol
                      (intern (symbol-name symbol) keyword))))))))


unknown's avatar
unknown committed
571
572
573
574
575
576
577
578
579
580
581
;; 9.3. Messages which we can deduce from mixin classes.

(defparameter *messages-to-suppress*
  (list :aggregate :all-mixins :children-uncached :direct-mixins :documentation
	:hidden? :leaves-uncached :message-documentation :message-list :mixins :name-for-display
	:restore-all-defaults! :restore-tree! :root :root-path-local :root? :safe-children
	:safe-hidden-children :slot-documentation :slot-source :slot-status :update! :visible-children
	:write-snapshot))

(defparameter *messages-to-suppress-when-not-sequence-member*
  (list :first? :index :last?))
582
583
584

(defun messages-from-classes (form)
  "Use message-list to find out what the messages might be."
unknown's avatar
unknown committed
585
  (let* ((starting-classes (starting-classes form))
unknown's avatar
unknown committed
586
587
588
         (mixins (remove-duplicates (append (mapcar 'class-name starting-classes)
                                            (loop for class in starting-classes append
                                                  (gendl:the-object (gendl-class-prototype class) all-mixins)))
589
590
                                    :from-end t))
         (messages (remove-duplicates (loop for class in mixins
unknown's avatar
unknown committed
591
592
593
594
                                            append (sort (messages-from-class class)
                                                         'string<)))))
    (filter-sequence-messages messages)))

unknown's avatar
unknown committed
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
(defun starting-classes (form)
  (destructuring-bind (classname &optional mixins &rest keywords)
      (cdr form)
    (declare (ignore keywords))
    (let ((this-class (or (the-child-class)
                          (safe-find-class classname))))
      (if this-class
          ;; It's a either a (the-child ...) class , or a redefinition
          ;; (which includes: clicking on an existing defintion).
          (the-reference-chain this-class)
        ;; New definition. Hit the superclasses.
        (loop for classname in mixins
              for class = (safe-find-class classname)
              when class collect class)))))

;; If we're in a the-child inside an :objects or :hidden-objects clause and can find
;; a class for the :type, return that.
(defun the-child-class ()
  (when (boundp '*this-the*)
    (let ((this-the *this-the*))
      (when (and (case (this-the-section this-the)
                   ((objects hidden-objects) t))
                 (eq (car (this-the-the-form this-the)) 'gendl:the-child))
        (object-slot-form-class (cdr (this-the-slot-form this-the)))))))

(defun object-slot-form-class (slot-form)
  (multiple-value-bind (typep quoted-type)
      (find-key :type slot-form)
    (declare (ignore typep))
    (when (and (consp quoted-type)
               (eq (car quoted-type) 'quote)
               (symbolp (cadr quoted-type)))
      (find-class (cadr quoted-type) nil))))

(defun the-reference-chain (class)
  (unless (arglist-dummy-p class)
    (when (boundp '*this-the*)
      (let* ((this-the *this-the*)
             (the-form (this-the-the-form this-the))
             (reference-chain (case (car the-form)
                                ((gendl:the gendl:the-child) (cdr the-form))
                                ((gendl:the-object)          (cddr the-form)))))
        (loop for reference in reference-chain do
              (setf class (or (reference-class reference class)
                              (return))))))
    (list class)))

(defun reference-class (reference class)
  (if (or (arglist-dummy-p reference)
          (consp reference)                         ; function call
          (eq reference '%cursor-marker%))
      class
    (let* ((prototype (gendl-class-prototype class))
           (slot-source (gendl:the-object prototype (slot-source (glisp:intern reference :keyword)))))
      (object-slot-form-class (cadr slot-source)))))
650
651
652
653
654
655
656
657
658
659
660
661
662

;; [gendl] make your own defparameter for now, but flag it that it
;; might be redundant with something we already have defined
(defparameter *internal-packages*
  (loop for designator in
        '(:gendl :geom-base :surf :gwl :yadd :tasty)
        collect
        (find-package designator)))

(defun messages-from-class (class)
  "Return a list of messages. Take anything from a user-defined class (not
in one of the *internal-packages*), otherwise filter for non-nil message-remarks."
  (unless (find class '(gendl::gdl-basis standard-object t))
unknown's avatar
unknown committed
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
    (multiple-value-bind (functionp current)
        (when-let (this-the (when (boundp '*this-the*) *this-the*))
          (values (this-the-functionp this-the)
                  ;; Use this to check we don't return the current slot as a potential message.
                  ;; But messages -- as in (the message-list) -- are keywords and this isn't...
                  (when-let (current (car (this-the-slot-form this-the)))
                    (glisp:intern current :keyword))))
      (let* ((prototype (gendl-class-prototype class))
             (all-messages (gendl:the-object prototype
                                             (message-list :message-type :local
                                                           :filter (if (find (symbol-package class)
                                                                             *internal-packages*)
                                                                       (lambda (category keyword)
                                                                         (declare (ignore category))
                                                                         (not (or (eq keyword current)
                                                                                  (find keyword *messages-to-suppress*)
                                                                                  (null (gendl:the-object prototype (message-remarks keyword))))))
unknown's avatar
unknown committed
680
681
                                                                     (lambda (category keyword)
                                                                       (declare (ignore category))
unknown's avatar
unknown committed
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
                                                                       (not (eq keyword current)))))))
             (sequences (loop for message in all-messages
                              for source = (cadr (gendl:the-object prototype (slot-source message)))
                              when (and (consp source)
                                        (find-key :sequence source))
                              collect message))
             (functions (gendl:the-object prototype (message-list :category :functions
                                                                  :message-type :local))))
        ;; Preserve order
        (loop for message in all-messages
              for found = (and functions
                               (not (null (find message functions))))
              when (or (eq found functionp)
                       (and sequences
                            (find message sequences)))
              collect message)))))
unknown's avatar
unknown committed
698
699
700
701
702
703

(defun filter-sequence-messages (messages)
  (if (and (boundp '*this-the*)
           (this-the-quantifiedp *this-the*))
      messages
    ;; Again, we preserve order
unknown's avatar
unknown committed
704
705
706
707
    (let ((suppress *messages-to-suppress-when-not-sequence-member*))
      (loop for message in messages
            unless (find message suppress)
            collect message))))
708
709
710


;; 10.  UTILITIES
711

unknown's avatar
unknown committed
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
(defun cautious-intern (string)
  (if (eq (readtable-case *readtable*) :preserve)
      ;; Allegro modern mode?
      (intern (string-downcase string))
    (intern string)))

(defmethod safe-find-class ((self symbol)) (find-class self nil))
(defmethod safe-find-class ((self class))  self)
(defmethod safe-find-class ((self t))      nil)

;; Look graciously for key: don't assume list is correctly formed for destructuring-bind.
(defun find-key (key plist)
  (loop for (k v) on plist by #'cddr
        when (eq k key)
        do (return (values k v))))

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
;; List is of form (:keyword stuff :keyword stuff ...); the final stuff may be missing.
;; Return the final (:keyword stuff) pair as two values, provided stuff is a list.
;; Otherwise return nil.
(defun active-keyword (list)
  (let ((key nil)
        (stuff nil))
    (loop (setf key (pop list))
          (if list
              (setf stuff (pop list))
            (return-from active-keyword
              nil))
          (unless list
            (return)))
    (when (listp stuff)
      (values key stuff))))

(defun test-active-keyword ()
  (loop for (list . result) in '((() . nil)
                                 ((:foo) . nil)
                                 ((:foo bar) . nil)
                                 ((:foo (bar)) . (:foo (bar)))
                                 ((:foo (bar) :baz) . nil)
                                 ((:foo (bar) :baz ()) . (:baz nil))
                                 )
        do
        (multiple-value-bind (keyword stuff)
            (active-keyword list)
          (if keyword
              (assert (equal (list keyword stuff) result))
            (null result)))))

(test-active-keyword)


;; A.  REFERENCES
;;
;;
;; B.  HISTORY
;;
;; 2013-05-02 NDL Created.
;;
;; 2013-05-09 NDL Version 0.1 as http://paste.lisp.org/display/137088
;;
;; 2013-05-10 NDL Added *gendl-slime-release*.
;;                Release 0.1.1 as http://paste.lisp.org/display/137101
;;
;;
;; C.  COPYRIGHT
;;
;; Copyright 2013 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file.  If not, see
;; <http://www.gnu.org/licenses/>.