describe.scm 9.5 KB

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