1;;; Describe objects
2
3;; Copyright (C) 2001, 2009, 2011 Free Software Foundation, Inc.
4
5;;; This library is free software; you can redistribute it and/or
6;;; modify it under the terms of the GNU Lesser General Public
7;;; License as published by the Free Software Foundation; either
8;;; version 3 of the License, or (at your option) any later version.
9;;;
10;;; This library is distributed in the hope that it will be useful,
11;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13;;; Lesser General Public License for more details.
14;;;
15;;; You should have received a copy of the GNU Lesser General Public
16;;; License along with this library; if not, write to the Free Software
17;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19;;; Code:
20
21(define-module (system repl describe)
22  #:use-module (oop goops)
23  #:use-module (ice-9 regex)
24  #:use-module (ice-9 format)
25  #:use-module (ice-9 and-let-star)
26  #:export (describe))
27
28(define-method (describe (symbol <symbol>))
29  (format #t "`~s' is " symbol)
30  (if (not (defined? symbol))
31      (display "not defined in the current module.\n")
32      (describe-object (module-ref (current-module) symbol))))
33
34
35;;;
36;;; Display functions
37;;;
38
39(define (safe-class-name class)
40  (if (slot-bound? class 'name)
41      (class-name class)
42      class))
43
44(define-method (display-class class . args)
45  (let* ((name (safe-class-name class))
46	 (desc (if (pair? args) (car args) name)))
47    (if (eq? *describe-format* 'tag)
48	(format #t "@class{~a}{~a}" name desc)
49	(format #t "~a" desc))))
50
51(define (display-list title list)
52  (if title (begin (display title) (display ":\n\n")))
53  (if (null? list)
54      (display "(not defined)\n")
55      (for-each display-summary list)))
56
57(define (display-slot-list title instance list)
58  (if title (begin (display title) (display ":\n\n")))
59  (if (null? list)
60      (display "(not defined)\n")
61      (for-each (lambda (slot)
62		  (let ((name (slot-definition-name slot)))
63		    (display "Slot: ")
64		    (display name)
65		    (if (and instance (slot-bound? instance name))
66			(begin
67			  (display " = ")
68			  (display (slot-ref instance name))))
69		    (newline)))
70		list)))
71
72(define (display-file location)
73  (display "Defined in ")
74  (if (eq? *describe-format* 'tag)
75      (format #t "@location{~a}.\n" location)
76      (format #t "`~a'.\n" location)))
77
78(define (format-documentation doc)
79  (with-current-buffer (make-buffer #:text doc)
80    (lambda ()
81      (let ((regexp (make-regexp "@([a-z]*)(\\{([^}]*)\\})?")))
82	(do-while (match (re-search-forward regexp))
83	  (let ((key (string->symbol (match:substring match 1)))
84		(value (match:substring match 3)))
85	    (case key
86	      ((deffnx)
87	       (delete-region! (match:start match)
88			       (begin (forward-line) (point))))
89	      ((var)
90	       (replace-match! match 0 (string-upcase value)))
91	      ((code)
92	       (replace-match! match 0 (string-append "`" value "'")))))))
93      (display (string (current-buffer)))
94      (newline))))
95
96
97;;;
98;;; Top
99;;;
100
101(define description-table
102  (list
103   (cons <boolean>   "a boolean")
104   (cons <null>      "an empty list")
105   (cons <integer>   "an integer")
106   (cons <real>      "a real number")
107   (cons <complex>   "a complex number")
108   (cons <char>      "a character")
109   (cons <symbol>    "a symbol")
110   (cons <keyword>   "a keyword")
111   (cons <promise>   "a promise")
112   (cons <hook>      "a hook")
113   (cons <fluid>     "a fluid")
114   (cons <stack>     "a stack")
115   (cons <variable>  "a variable")
116   (cons <regexp>    "a regexp object")
117   (cons <module>    "a module object")
118   (cons <unknown>   "an unknown object")))
119
120(define-generic describe-object)
121(export describe-object)
122
123(define-method (describe-object (obj <top>))
124  (display-type obj)
125  (display-location obj)
126  (newline)
127  (display-value obj)
128  (newline)
129  (display-documentation obj))
130
131(define-generic display-object)
132(define-generic display-summary)
133(define-generic display-type)
134(define-generic display-value)
135(define-generic display-location)
136(define-generic display-description)
137(define-generic display-documentation)
138(export display-object display-summary display-type display-value
139	display-location display-description display-documentation)
140
141(define-method (display-object (obj <top>))
142  (write obj))
143
144(define-method (display-summary (obj <top>))
145  (display "Value: ")
146  (display-object obj)
147  (newline))
148
149(define-method (display-type (obj <top>))
150  (cond
151   ((eof-object? obj) (display "the end-of-file object"))
152   ((unspecified? obj) (display "unspecified"))
153   (else (let ((class (class-of obj)))
154	   (display-class class (or (assq-ref description-table class)
155				    (safe-class-name class))))))
156  (display ".\n"))
157
158(define-method (display-value (obj <top>))
159  (if (not (unspecified? obj))
160      (begin (display-object obj) (newline))))
161
162(define-method (display-location (obj <top>))
163  *unspecified*)
164
165(define-method (display-description (obj <top>))
166  (let* ((doc (with-output-to-string (lambda () (display-documentation obj))))
167	 (index (string-index doc #\newline)))
168    (display (substring doc 0 (1+ index)))))
169
170(define-method (display-documentation (obj <top>))
171  (display "Not documented.\n"))
172
173
174;;;
175;;; Pairs
176;;;
177
178(define-method (display-type (obj <pair>))
179  (cond
180   ((list? obj) (display-class <list> "a list"))
181   ((pair? (cdr obj)) (display "an improper list"))
182   (else (display-class <pair> "a pair")))
183  (display ".\n"))
184
185
186;;;
187;;; Strings
188;;;
189
190(define-method (display-type (obj <string>))
191  (if (read-only-string? 'obj)
192      (display "a read-only string")
193      (display-class <string> "a string"))
194  (display ".\n"))
195
196
197;;;
198;;; Procedures
199;;;
200
201(define-method (display-object (obj <procedure>))
202  (cond
203   ;; FIXME: VM programs, ...
204   (else
205    ;; Primitive procedure.  Let's lookup the dictionary.
206    (and-let* ((entry (lookup-procedure obj)))
207      (let ((name (entry-property entry 'name))
208	    (print-arg (lambda (arg)
209			 (display " ")
210			 (display (string-upcase (symbol->string arg))))))
211	(display "(")
212	(display name)
213	(and-let* ((args (entry-property entry 'args)))
214	  (for-each print-arg args))
215	(and-let* ((opts (entry-property entry 'opts)))
216	  (display " &optional")
217	  (for-each print-arg opts))
218	(and-let* ((rest (entry-property entry 'rest)))
219	  (display " &rest")
220	  (print-arg rest))
221	(display ")"))))))
222
223(define-method (display-summary (obj <procedure>))
224  (display "Procedure: ")
225  (display-object obj)
226  (newline)
227  (display "  ")
228  (display-description obj))
229
230(define-method (display-type (obj <procedure>))
231  (cond
232   ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
233   ((procedure-with-setter? obj)
234    (display-class <procedure-with-setter> "a procedure with setter"))
235   (else (display-class <procedure> "a procedure")))
236  (display ".\n"))
237
238(define-method (display-location (obj <procedure>))
239  (and-let* ((entry (lookup-procedure obj)))
240    (display-file (entry-file entry))))
241
242(define-method (display-documentation (obj <procedure>))
243  (cond ((or (procedure-documentation obj)
244             (and=> (lookup-procedure obj) entry-text))
245	 => format-documentation)
246	(else (next-method))))
247
248
249;;;
250;;; Classes
251;;;
252
253(define-method (describe-object (obj <class>))
254  (display-type obj)
255  (display-location obj)
256  (newline)
257  (display-documentation obj)
258  (newline)
259  (display-value obj))
260
261(define-method (display-summary (obj <class>))
262  (display "Class: ")
263  (display-class obj)
264  (newline)
265  (display "  ")
266  (display-description obj))
267
268(define-method (display-type (obj <class>))
269  (display-class <class> "a class")
270  (if (not (eq? (class-of obj) <class>))
271      (begin (display " of ") (display-class (class-of obj))))
272  (display ".\n"))
273
274(define-method (display-value (obj <class>))
275  (display-list "Class precedence list" (class-precedence-list obj))
276  (newline)
277  (display-list "Direct superclasses" (class-direct-supers obj))
278  (newline)
279  (display-list "Direct subclasses" (class-direct-subclasses obj))
280  (newline)
281  (display-slot-list "Direct slots" #f (class-direct-slots obj))
282  (newline)
283  (display-list "Direct methods" (class-direct-methods obj)))
284
285
286;;;
287;;; Instances
288;;;
289
290(define-method (display-type (obj <object>))
291  (display-class <object> "an instance")
292  (display " of class ")
293  (display-class (class-of obj))
294  (display ".\n"))
295
296(define-method (display-value (obj <object>))
297  (display-slot-list #f obj (class-slots (class-of obj))))
298
299
300;;;
301;;; Generic functions
302;;;
303
304(define-method (display-type (obj <generic>))
305  (display-class <generic> "a generic function")
306  (display " of class ")
307  (display-class (class-of obj))
308  (display ".\n"))
309
310(define-method (display-value (obj <generic>))
311  (display-list #f (generic-function-methods obj)))
312
313
314;;;
315;;; Methods
316;;;
317
318(define-method (display-object (obj <method>))
319  (display "(")
320  (let ((gf (method-generic-function obj)))
321    (display (if gf (generic-function-name gf) "#<anonymous>")))
322  (let loop ((args (method-specializers obj)))
323    (cond
324     ((null? args))
325     ((pair? args)
326      (display " ")
327      (display-class (car args))
328      (loop (cdr args)))
329     (else (display " . ") (display-class args))))
330  (display ")"))
331
332(define-method (display-summary (obj <method>))
333  (display "Method: ")
334  (display-object obj)
335  (newline)
336  (display "  ")
337  (display-description obj))
338
339(define-method (display-type (obj <method>))
340  (display-class <method> "a method")
341  (display " of class ")
342  (display-class (class-of obj))
343  (display ".\n"))
344
345(define-method (display-documentation (obj <method>))
346  (let ((doc (procedure-documentation (method-procedure obj))))
347    (if doc (format-documentation doc) (next-method))))
348