123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348 |
- ;;; Describe objects
- ;; Copyright (C) 2001, 2009, 2011 Free Software Foundation, Inc.
- ;;; This library is free software; you can redistribute it and/or
- ;;; modify it under the terms of the GNU Lesser General Public
- ;;; License as published by the Free Software Foundation; either
- ;;; version 3 of the License, or (at your option) any later version.
- ;;;
- ;;; This library 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
- ;;; Lesser General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU Lesser General Public
- ;;; License along with this library; if not, write to the Free Software
- ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
- ;;; Code:
- (define-module (system repl describe)
- #:use-module (oop goops)
- #:use-module (ice-9 regex)
- #:use-module (ice-9 format)
- #:use-module (ice-9 and-let-star)
- #:export (describe))
- (define-method (describe (symbol <symbol>))
- (format #t "`~s' is " symbol)
- (if (not (defined? symbol))
- (display "not defined in the current module.\n")
- (describe-object (module-ref (current-module) symbol))))
- ;;;
- ;;; Display functions
- ;;;
- (define (safe-class-name class)
- (if (slot-bound? class 'name)
- (class-name class)
- class))
- (define-method (display-class class . args)
- (let* ((name (safe-class-name class))
- (desc (if (pair? args) (car args) name)))
- (if (eq? *describe-format* 'tag)
- (format #t "@class{~a}{~a}" name desc)
- (format #t "~a" desc))))
- (define (display-list title list)
- (if title (begin (display title) (display ":\n\n")))
- (if (null? list)
- (display "(not defined)\n")
- (for-each display-summary list)))
- (define (display-slot-list title instance list)
- (if title (begin (display title) (display ":\n\n")))
- (if (null? list)
- (display "(not defined)\n")
- (for-each (lambda (slot)
- (let ((name (slot-definition-name slot)))
- (display "Slot: ")
- (display name)
- (if (and instance (slot-bound? instance name))
- (begin
- (display " = ")
- (display (slot-ref instance name))))
- (newline)))
- list)))
- (define (display-file location)
- (display "Defined in ")
- (if (eq? *describe-format* 'tag)
- (format #t "@location{~a}.\n" location)
- (format #t "`~a'.\n" location)))
- (define (format-documentation doc)
- (with-current-buffer (make-buffer #:text doc)
- (lambda ()
- (let ((regexp (make-regexp "@([a-z]*)(\\{([^}]*)\\})?")))
- (do-while (match (re-search-forward regexp))
- (let ((key (string->symbol (match:substring match 1)))
- (value (match:substring match 3)))
- (case key
- ((deffnx)
- (delete-region! (match:start match)
- (begin (forward-line) (point))))
- ((var)
- (replace-match! match 0 (string-upcase value)))
- ((code)
- (replace-match! match 0 (string-append "`" value "'")))))))
- (display (string (current-buffer)))
- (newline))))
- ;;;
- ;;; Top
- ;;;
- (define description-table
- (list
- (cons <boolean> "a boolean")
- (cons <null> "an empty list")
- (cons <integer> "an integer")
- (cons <real> "a real number")
- (cons <complex> "a complex number")
- (cons <char> "a character")
- (cons <symbol> "a symbol")
- (cons <keyword> "a keyword")
- (cons <promise> "a promise")
- (cons <hook> "a hook")
- (cons <fluid> "a fluid")
- (cons <stack> "a stack")
- (cons <variable> "a variable")
- (cons <regexp> "a regexp object")
- (cons <module> "a module object")
- (cons <unknown> "an unknown object")))
- (define-generic describe-object)
- (export describe-object)
- (define-method (describe-object (obj <top>))
- (display-type obj)
- (display-location obj)
- (newline)
- (display-value obj)
- (newline)
- (display-documentation obj))
- (define-generic display-object)
- (define-generic display-summary)
- (define-generic display-type)
- (define-generic display-value)
- (define-generic display-location)
- (define-generic display-description)
- (define-generic display-documentation)
- (export display-object display-summary display-type display-value
- display-location display-description display-documentation)
- (define-method (display-object (obj <top>))
- (write obj))
- (define-method (display-summary (obj <top>))
- (display "Value: ")
- (display-object obj)
- (newline))
- (define-method (display-type (obj <top>))
- (cond
- ((eof-object? obj) (display "the end-of-file object"))
- ((unspecified? obj) (display "unspecified"))
- (else (let ((class (class-of obj)))
- (display-class class (or (assq-ref description-table class)
- (safe-class-name class))))))
- (display ".\n"))
- (define-method (display-value (obj <top>))
- (if (not (unspecified? obj))
- (begin (display-object obj) (newline))))
- (define-method (display-location (obj <top>))
- *unspecified*)
- (define-method (display-description (obj <top>))
- (let* ((doc (with-output-to-string (lambda () (display-documentation obj))))
- (index (string-index doc #\newline)))
- (display (substring doc 0 (1+ index)))))
- (define-method (display-documentation (obj <top>))
- (display "Not documented.\n"))
- ;;;
- ;;; Pairs
- ;;;
- (define-method (display-type (obj <pair>))
- (cond
- ((list? obj) (display-class <list> "a list"))
- ((pair? (cdr obj)) (display "an improper list"))
- (else (display-class <pair> "a pair")))
- (display ".\n"))
- ;;;
- ;;; Strings
- ;;;
- (define-method (display-type (obj <string>))
- (if (read-only-string? 'obj)
- (display "a read-only string")
- (display-class <string> "a string"))
- (display ".\n"))
- ;;;
- ;;; Procedures
- ;;;
- (define-method (display-object (obj <procedure>))
- (cond
- ;; FIXME: VM programs, ...
- (else
- ;; Primitive procedure. Let's lookup the dictionary.
- (and-let* ((entry (lookup-procedure obj)))
- (let ((name (entry-property entry 'name))
- (print-arg (lambda (arg)
- (display " ")
- (display (string-upcase (symbol->string arg))))))
- (display "(")
- (display name)
- (and-let* ((args (entry-property entry 'args)))
- (for-each print-arg args))
- (and-let* ((opts (entry-property entry 'opts)))
- (display " &optional")
- (for-each print-arg opts))
- (and-let* ((rest (entry-property entry 'rest)))
- (display " &rest")
- (print-arg rest))
- (display ")"))))))
- (define-method (display-summary (obj <procedure>))
- (display "Procedure: ")
- (display-object obj)
- (newline)
- (display " ")
- (display-description obj))
- (define-method (display-type (obj <procedure>))
- (cond
- ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
- ((procedure-with-setter? obj)
- (display-class <procedure-with-setter> "a procedure with setter"))
- (else (display-class <procedure> "a procedure")))
- (display ".\n"))
- (define-method (display-location (obj <procedure>))
- (and-let* ((entry (lookup-procedure obj)))
- (display-file (entry-file entry))))
- (define-method (display-documentation (obj <procedure>))
- (cond ((or (procedure-documentation obj)
- (and=> (lookup-procedure obj) entry-text))
- => format-documentation)
- (else (next-method))))
- ;;;
- ;;; Classes
- ;;;
- (define-method (describe-object (obj <class>))
- (display-type obj)
- (display-location obj)
- (newline)
- (display-documentation obj)
- (newline)
- (display-value obj))
- (define-method (display-summary (obj <class>))
- (display "Class: ")
- (display-class obj)
- (newline)
- (display " ")
- (display-description obj))
- (define-method (display-type (obj <class>))
- (display-class <class> "a class")
- (if (not (eq? (class-of obj) <class>))
- (begin (display " of ") (display-class (class-of obj))))
- (display ".\n"))
- (define-method (display-value (obj <class>))
- (display-list "Class precedence list" (class-precedence-list obj))
- (newline)
- (display-list "Direct superclasses" (class-direct-supers obj))
- (newline)
- (display-list "Direct subclasses" (class-direct-subclasses obj))
- (newline)
- (display-slot-list "Direct slots" #f (class-direct-slots obj))
- (newline)
- (display-list "Direct methods" (class-direct-methods obj)))
- ;;;
- ;;; Instances
- ;;;
- (define-method (display-type (obj <object>))
- (display-class <object> "an instance")
- (display " of class ")
- (display-class (class-of obj))
- (display ".\n"))
- (define-method (display-value (obj <object>))
- (display-slot-list #f obj (class-slots (class-of obj))))
- ;;;
- ;;; Generic functions
- ;;;
- (define-method (display-type (obj <generic>))
- (display-class <generic> "a generic function")
- (display " of class ")
- (display-class (class-of obj))
- (display ".\n"))
- (define-method (display-value (obj <generic>))
- (display-list #f (generic-function-methods obj)))
- ;;;
- ;;; Methods
- ;;;
- (define-method (display-object (obj <method>))
- (display "(")
- (let ((gf (method-generic-function obj)))
- (display (if gf (generic-function-name gf) "#<anonymous>")))
- (let loop ((args (method-specializers obj)))
- (cond
- ((null? args))
- ((pair? args)
- (display " ")
- (display-class (car args))
- (loop (cdr args)))
- (else (display " . ") (display-class args))))
- (display ")"))
- (define-method (display-summary (obj <method>))
- (display "Method: ")
- (display-object obj)
- (newline)
- (display " ")
- (display-description obj))
- (define-method (display-type (obj <method>))
- (display-class <method> "a method")
- (display " of class ")
- (display-class (class-of obj))
- (display ".\n"))
- (define-method (display-documentation (obj <method>))
- (let ((doc (procedure-documentation (method-procedure obj))))
- (if doc (format-documentation doc) (next-method))))
|