module/system/repl/describe.scm

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