reflection.scm 21 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579
  1. ;;;; (texinfo reflection) -- documenting Scheme as stexinfo
  2. ;;;;
  3. ;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
  4. ;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
  5. ;;;;
  6. ;;;; This library is free software; you can redistribute it and/or
  7. ;;;; modify it under the terms of the GNU Lesser General Public
  8. ;;;; License as published by the Free Software Foundation; either
  9. ;;;; version 3 of the License, or (at your option) any later version.
  10. ;;;;
  11. ;;;; This library is distributed in the hope that it will be useful,
  12. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  14. ;;;; Lesser General Public License for more details.
  15. ;;;;
  16. ;;;; You should have received a copy of the GNU Lesser General Public
  17. ;;;; License along with this library; if not, write to the Free Software
  18. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19. ;;;;
  20. ;;; Commentary:
  21. ;;
  22. ;;Routines to generate @code{stexi} documentation for objects and
  23. ;;modules.
  24. ;;
  25. ;;Note that in this context, an @dfn{object} is just a value associated
  26. ;;with a location. It has nothing to do with GOOPS.
  27. ;;
  28. ;;; Code:
  29. (define-module (texinfo reflection)
  30. #:use-module ((srfi srfi-1) #:select (append-map))
  31. #:use-module (oop goops)
  32. #:use-module (texinfo)
  33. #:use-module (texinfo plain-text)
  34. #:use-module (ice-9 session)
  35. #:use-module (ice-9 documentation)
  36. #:use-module ((sxml transform) #:select (pre-post-order))
  37. #:export (module-stexi-documentation
  38. script-stexi-documentation
  39. object-stexi-documentation
  40. package-stexi-standard-copying
  41. package-stexi-standard-titlepage
  42. package-stexi-generic-menu
  43. package-stexi-standard-menu
  44. package-stexi-extended-menu
  45. package-stexi-standard-prologue
  46. package-stexi-documentation
  47. package-stexi-documentation-for-include))
  48. ;; List for sorting the definitions in a module
  49. (define defs
  50. '(deftp defcv defivar deftypeivar defop deftypeop defmethod
  51. deftypemethod defopt defvr defvar deftypevr deftypevar deffn
  52. deftypefn defmac defspec defun deftypefun))
  53. (define (sort-defs ordering a b)
  54. (define (def x)
  55. ;; a and b are lists of the form ((anchor ...) (def* ...)...)
  56. (cadr x))
  57. (define (name x)
  58. (cadr (assq 'name (cdadr (def x)))))
  59. (define (priority x)
  60. (list-index defs (car (def x))))
  61. (define (order x)
  62. (or (list-index ordering (string->symbol (name x)))
  63. ;; if the def is not in the list, a big number
  64. 1234567890))
  65. (define (compare-in-order proc eq? < . args)
  66. (if (not (eq? (proc a) (proc b)))
  67. (< (proc a) (proc b))
  68. (or (null? args)
  69. (apply compare-in-order args))))
  70. (compare-in-order order = <
  71. priority = <
  72. name string=? string<=?))
  73. (define (list*-join l infix restfix)
  74. (let lp ((in l) (out '()))
  75. (cond ((null? in) (reverse! out))
  76. ((symbol? in) (reverse! (cons* in restfix out)))
  77. (else (lp (cdr in) (if (null? out)
  78. (list (car in))
  79. (cons* (car in) infix out)))))))
  80. (define (process-args args)
  81. (map (lambda (x) (if (string? x) x (object->string x)))
  82. (list*-join (or args '())
  83. " " " . ")))
  84. (define (get-proc-args proc)
  85. (cond
  86. ((procedure-arguments proc)
  87. => (lambda (args)
  88. (let ((required-args (assq-ref args 'required))
  89. (optional-args (assq-ref args 'optional))
  90. (keyword-args (assq-ref args 'keyword))
  91. (rest-arg (assq-ref args 'rest)))
  92. (process-args
  93. (append
  94. ;; start with the required args...
  95. (map symbol->string required-args)
  96. ;; add any optional args if needed...
  97. (map (lambda (a)
  98. (if (list? a)
  99. (format #f "[~a = ~s]" (car a) (cadr a))
  100. (format #f "[~a]" a)))
  101. optional-args)
  102. ;; now the keyword args..
  103. (map (lambda (a)
  104. (if (pair? a)
  105. (format #f "[~a]" (car a))
  106. (format #f "[#:~a]" a)))
  107. keyword-args)
  108. ;; now the rest arg...
  109. (if rest-arg
  110. (list "." (symbol->string rest-arg))
  111. '()))))))))
  112. (define (macro-arguments name type transformer)
  113. (process-args
  114. (case type
  115. ((syntax-rules)
  116. (let ((patterns (procedure-property transformer 'patterns)))
  117. (if (pair? patterns)
  118. (car patterns)
  119. '())))
  120. ((identifier-syntax)
  121. '())
  122. ((defmacro)
  123. (or (procedure-property transformer 'defmacro-args)
  124. '()))
  125. (else
  126. ;; a procedural (syntax-case) macro. how to document these?
  127. '()))))
  128. (define (macro-additional-stexi name type transformer)
  129. (case type
  130. ((syntax-rules)
  131. (let ((patterns (procedure-property transformer 'patterns)))
  132. (if (pair? patterns)
  133. (map (lambda (x)
  134. `(defspecx (% (name ,name)
  135. (arguments ,@(process-args x)))))
  136. (cdr patterns))
  137. '())))
  138. (else
  139. '())))
  140. (define many-space? (make-regexp "[[:space:]][[:space:]][[:space:]]"))
  141. (define initial-space? (make-regexp "^[[:space:]]"))
  142. (define (string->stexi str)
  143. (or (and (or (not str) (string-null? str))
  144. '(*fragment*))
  145. (and (or (string-index str #\@)
  146. (and (not (regexp-exec many-space? str))
  147. (not (regexp-exec initial-space? str))))
  148. (false-if-exception
  149. (texi-fragment->stexi str)))
  150. `(*fragment* (verbatim ,str))))
  151. (define method-formals
  152. (and (defined? 'method-formals) method-formals))
  153. (define (method-stexi-arguments method)
  154. (cond
  155. (method-formals
  156. (let lp ((formals (method-formals method))
  157. (specializers (method-specializers method))
  158. (out '()))
  159. (define (arg-texinfo formal specializer)
  160. `(" (" (var ,(symbol->string formal)) " "
  161. (code ,(symbol->string (class-name specializer))) ")"))
  162. (cond
  163. ((null? formals) (reverse out))
  164. ((pair? formals)
  165. (lp (cdr formals) (cdr specializers)
  166. (append (reverse (arg-texinfo (car formals) (car specializers)))
  167. out)))
  168. (else
  169. (append (reverse out) (arg-texinfo formals specializers)
  170. (list "..."))))))
  171. ((method-source method)
  172. (let lp ((bindings (cadr (method-source method))) (out '()))
  173. (define (arg-texinfo arg)
  174. `(" (" (var ,(symbol->string (car arg))) " "
  175. (code ,(symbol->string (cadr arg))) ")"))
  176. (cond
  177. ((null? bindings)
  178. (reverse out))
  179. ((not (pair? (car bindings)))
  180. (append (reverse out) (arg-texinfo bindings) (list "...")))
  181. (else
  182. (lp (cdr bindings)
  183. (append (reverse (arg-texinfo (car bindings))) out))))))
  184. (else (warn method) '())))
  185. (define* (object-stexi-documentation object #:optional (name "[unknown]")
  186. #:key (force #f))
  187. (if (symbol? name)
  188. (set! name (symbol->string name)))
  189. (let ((stexi ((lambda (x)
  190. (cond ((string? x) (string->stexi x))
  191. ((and (pair? x) (eq? (car x) '*fragment*)) x)
  192. (force `(*fragment*))
  193. (else #f)))
  194. (object-documentation
  195. (if (is-a? object <method>)
  196. (method-procedure object)
  197. object)))))
  198. (define (make-def type args)
  199. `(,type (% ,@args) ,@(cdr stexi)))
  200. (cond
  201. ((not stexi) #f)
  202. ;; stexi is now a list, headed by *fragment*.
  203. ((and (pair? (cdr stexi)) (pair? (cadr stexi))
  204. (memq (caadr stexi) defs))
  205. ;; it's already a deffoo.
  206. stexi)
  207. ((is-a? object <class>)
  208. (make-def 'deftp `((name ,name)
  209. (category "Class"))))
  210. ((is-a? object <macro>)
  211. (let* ((proc (macro-transformer object))
  212. (type (and proc (procedure-property proc 'macro-type))))
  213. `(defspec (% (name ,name)
  214. (arguments ,@(macro-arguments name type proc)))
  215. ,@(macro-additional-stexi name type proc)
  216. ,@(cdr stexi))))
  217. ((is-a? object <procedure>)
  218. (make-def 'defun `((name ,name)
  219. (arguments ,@(get-proc-args object)))))
  220. ((is-a? object <method>)
  221. (make-def 'deffn `((category "Method")
  222. (name ,name)
  223. (arguments ,@(method-stexi-arguments object)))))
  224. ((is-a? object <generic>)
  225. `(*fragment*
  226. ,(make-def 'deffn `((name ,name)
  227. (category "Generic")))
  228. ,@(map
  229. (lambda (method)
  230. (object-stexi-documentation method name #:force force))
  231. (generic-function-methods object))))
  232. (else
  233. (make-def 'defvar `((name ,name)))))))
  234. (define (module-name->node-name sym-name)
  235. (string-join (map symbol->string sym-name) " "))
  236. ;; this copied from (ice-9 session); need to find a better way
  237. (define (module-filename name)
  238. (let* ((name (map symbol->string name))
  239. (reverse-name (reverse name))
  240. (leaf (car reverse-name))
  241. (dir-hint-module-name (reverse (cdr reverse-name)))
  242. (dir-hint (apply string-append
  243. (map (lambda (elt)
  244. (string-append elt "/"))
  245. dir-hint-module-name))))
  246. (%search-load-path (in-vicinity dir-hint leaf))))
  247. (define (read-module name)
  248. (let ((filename (module-filename name)))
  249. (if filename
  250. (let ((port (open-input-file filename)))
  251. (let lp ((out '()) (form (read port)))
  252. (if (eof-object? form)
  253. (reverse out)
  254. (lp (cons form out) (read port)))))
  255. '())))
  256. (define (module-export-list sym-name)
  257. (define (module-form-export-list form)
  258. (and (pair? form)
  259. (eq? (car form) 'define-module)
  260. (equal? (cadr form) sym-name)
  261. (and=> (memq #:export (cddr form)) cadr)))
  262. (let lp ((forms (read-module sym-name)))
  263. (cond ((null? forms) '())
  264. ((module-form-export-list (car forms)) => identity)
  265. (else (lp (cdr forms))))))
  266. (define* (module-stexi-documentation sym-name
  267. #:key (docs-resolver
  268. (lambda (name def) def)))
  269. "Return documentation for the module named @var{sym-name}. The
  270. documentation will be formatted as @code{stexi}
  271. (@pxref{texinfo,texinfo})."
  272. (let* ((commentary (and=> (module-commentary sym-name)
  273. (lambda (x) (string-trim-both x #\newline))))
  274. (stexi (string->stexi commentary))
  275. (node-name (module-name->node-name sym-name))
  276. (name-str (with-output-to-string
  277. (lambda () (display sym-name))))
  278. (module (resolve-interface sym-name))
  279. (export-list (module-export-list sym-name)))
  280. (define (anchor-name sym)
  281. (string-append node-name " " (symbol->string sym)))
  282. (define (make-defs)
  283. (sort!
  284. (module-map
  285. (lambda (sym var)
  286. `((anchor (% (name ,(anchor-name sym))))
  287. ,@((lambda (x)
  288. (if (eq? (car x) '*fragment*)
  289. (cdr x)
  290. (list x)))
  291. (if (variable-bound? var)
  292. (docs-resolver
  293. sym
  294. (object-stexi-documentation (variable-ref var) sym
  295. #:force #t))
  296. (begin
  297. (warn "variable unbound!" sym)
  298. `(defvar (% (name ,(symbol->string sym)))
  299. "[unbound!]"))))))
  300. module)
  301. (lambda (a b) (sort-defs export-list a b))))
  302. `(texinfo (% (title ,name-str))
  303. (node (% (name ,node-name)))
  304. (section "Overview")
  305. ,@(cdr stexi)
  306. (section "Usage")
  307. ,@(apply append! (make-defs)))))
  308. (define (script-stexi-documentation scriptpath)
  309. "Return documentation for given script. The documentation will be
  310. taken from the script's commentary, and will be returned in the
  311. @code{stexi} format (@pxref{texinfo,texinfo})."
  312. (let ((commentary (file-commentary scriptpath)))
  313. `(texinfo (% (title ,(basename scriptpath)))
  314. (node (% (name ,(basename scriptpath))))
  315. ,@(if commentary
  316. (cdr
  317. (string->stexi
  318. (string-trim-both commentary #\newline)))
  319. '()))))
  320. (cond
  321. ((defined? 'add-value-help-handler!)
  322. (add-value-help-handler!
  323. (lambda (name value)
  324. (stexi->plain-text
  325. (object-stexi-documentation value name #:force #t))))
  326. (add-name-help-handler!
  327. (lambda (name)
  328. (and (list? name)
  329. (and-map symbol? name)
  330. (stexi->plain-text (module-stexi-documentation name)))))))
  331. ;; we could be dealing with an old (ice-9 session); fondle it to get
  332. ;; module-commentary
  333. (define module-commentary (@@ (ice-9 session) module-commentary))
  334. (define (package-stexi-standard-copying name version updated years
  335. copyright-holder permissions)
  336. "Create a standard texinfo @code{copying} section.
  337. @var{years} is a list of years (as integers) in which the modules
  338. being documented were released. All other arguments are strings."
  339. `(copying
  340. (para "This manual is for " ,name
  341. " (version " ,version ", updated " ,updated ")")
  342. (para "Copyright " ,(string-join (map number->string years) ",")
  343. " " ,copyright-holder)
  344. (quotation
  345. (para ,permissions))))
  346. (define (package-stexi-standard-titlepage name version updated authors)
  347. "Create a standard GNU title page.
  348. @var{authors} is a list of @code{(@var{name} . @var{email})}
  349. pairs. All other arguments are strings.
  350. Here is an example of the usage of this procedure:
  351. @smallexample
  352. (package-stexi-standard-titlepage
  353. \"Foolib\"
  354. \"3.2\"
  355. \"26 September 2006\"
  356. '((\"Alyssa P Hacker\" . \"alyssa@@example.com\"))
  357. '(2004 2005 2006)
  358. \"Free Software Foundation, Inc.\"
  359. \"Standard GPL permissions blurb goes here\")
  360. @end smallexample
  361. "
  362. `(;(setchapternewpage (% (all "odd"))) makes manuals too long
  363. (titlepage
  364. (title ,name)
  365. (subtitle "version " ,version ", updated " ,updated)
  366. ,@(map (lambda (pair)
  367. `(author ,(car pair)
  368. " (" (email ,(cdr pair)) ")"))
  369. authors)
  370. (page)
  371. (vskip (% (all "0pt plus 1filll")))
  372. (insertcopying))))
  373. (define (package-stexi-generic-menu name entries)
  374. "Create a menu from a generic alist of entries, the car of which
  375. should be the node name, and the cdr the description. As an exception,
  376. an entry of @code{#f} will produce a separator."
  377. (define (make-entry node description)
  378. `("* " ,node "::"
  379. ,(make-string (max (- 21 (string-length node)) 2) #\space)
  380. ,@description "\n"))
  381. `((ifnottex
  382. (node (% (name "Top")))
  383. (top (% (title ,name)))
  384. (insertcopying)
  385. (menu
  386. ,@(apply
  387. append
  388. (map
  389. (lambda (entry)
  390. (if entry
  391. (make-entry (car entry) (cdr entry))
  392. '("\n")))
  393. entries))))
  394. (iftex
  395. (shortcontents))))
  396. (define (package-stexi-standard-menu name modules module-descriptions
  397. extra-entries)
  398. "Create a standard top node and menu, suitable for processing
  399. by makeinfo."
  400. (package-stexi-generic-menu
  401. name
  402. (let ((module-entries (map cons
  403. (map module-name->node-name modules)
  404. module-descriptions))
  405. (separate-sections (lambda (x) (if (null? x) x (cons #f x)))))
  406. `(,@module-entries
  407. ,@(separate-sections extra-entries)))))
  408. (define (package-stexi-extended-menu name module-pairs script-pairs
  409. extra-entries)
  410. "Create an \"extended\" menu, like the standard menu but with a
  411. section for scripts."
  412. (package-stexi-generic-menu
  413. name
  414. (let ((module-entries (map cons
  415. (map module-name->node-name
  416. (map car module-pairs))
  417. (map cdr module-pairs)))
  418. (script-entries (map cons
  419. (map basename (map car script-pairs))
  420. (map cdr script-pairs)))
  421. (separate-sections (lambda (x) (if (null? x) x (cons #f x)))))
  422. `(,@module-entries
  423. ,@(separate-sections script-entries)
  424. ,@(separate-sections extra-entries)))))
  425. (define (package-stexi-standard-prologue name filename category
  426. description copying titlepage
  427. menu)
  428. "Create a standard prologue, suitable for later serialization
  429. to texinfo and .info creation with makeinfo.
  430. Returns a list of stexinfo forms suitable for passing to
  431. @code{package-stexi-documentation} as the prologue. @xref{texinfo
  432. reflection package-stexi-documentation}, @ref{texinfo reflection
  433. package-stexi-standard-titlepage,package-stexi-standard-titlepage},
  434. @ref{texinfo reflection
  435. package-stexi-standard-copying,package-stexi-standard-copying},
  436. and @ref{texinfo reflection
  437. package-stexi-standard-menu,package-stexi-standard-menu}."
  438. `(,copying
  439. (dircategory (% (category ,category)))
  440. (direntry
  441. "* " ,name ": (" ,filename "). " ,description ".")
  442. ,@titlepage
  443. ,@menu))
  444. (define (stexi->chapter stexi)
  445. (pre-post-order
  446. stexi
  447. `((texinfo . ,(lambda (tag attrs node . body)
  448. `(,node
  449. (chapter ,@(assq-ref (cdr attrs) 'title))
  450. ,@body)))
  451. (*text* . ,(lambda (tag text) text))
  452. (*default* . ,(lambda args args)))))
  453. (define* (package-stexi-documentation modules name filename
  454. prologue epilogue
  455. #:key
  456. (module-stexi-documentation-args
  457. '())
  458. (scripts '()))
  459. "Create stexi documentation for a @dfn{package}, where a
  460. package is a set of modules that is released together.
  461. @var{modules} is expected to be a list of module names, where a
  462. module name is a list of symbols. The stexi that is returned will
  463. be titled @var{name} and a texinfo filename of @var{filename}.
  464. @var{prologue} and @var{epilogue} are lists of stexi forms that
  465. will be spliced into the output document before and after the
  466. generated modules documentation, respectively.
  467. @xref{texinfo reflection package-stexi-standard-prologue}, to
  468. create a conventional GNU texinfo prologue.
  469. @var{module-stexi-documentation-args} is an optional argument that, if
  470. given, will be added to the argument list when
  471. @code{module-texi-documentation} is called. For example, it might be
  472. useful to define a @code{#:docs-resolver} argument."
  473. (define (verify-modules-list l)
  474. (define (all pred l)
  475. (and (pred (car l))
  476. (or (null? (cdr l)) (all pred (cdr l)))))
  477. (false-if-exception
  478. (all (lambda (x) (all symbol? x)) modules)))
  479. (if (not (verify-modules-list modules))
  480. (error "expected modules to be a list of a list of symbols"
  481. modules))
  482. `(texinfo
  483. (% (title ,name)
  484. (filename ,filename))
  485. ,@prologue
  486. ,@(append-map (lambda (mod)
  487. (stexi->chapter
  488. (apply module-stexi-documentation
  489. mod module-stexi-documentation-args)))
  490. modules)
  491. ,@(append-map (lambda (script)
  492. (stexi->chapter
  493. (script-stexi-documentation script)))
  494. scripts)
  495. ,@epilogue))
  496. (define* (package-stexi-documentation-for-include modules module-descriptions
  497. #:key
  498. (module-stexi-documentation-args '()))
  499. "Create stexi documentation for a @dfn{package}, where a
  500. package is a set of modules that is released together.
  501. @var{modules} is expected to be a list of module names, where a
  502. module name is a list of symbols. Returns an stexinfo fragment.
  503. Unlike @code{package-stexi-documentation}, this function simply produces
  504. a menu and the module documentations instead of producing a full texinfo
  505. document. This can be useful if you write part of your manual by hand,
  506. and just use @code{@@include} to pull in the automatically generated
  507. parts.
  508. @var{module-stexi-documentation-args} is an optional argument that, if
  509. given, will be added to the argument list when
  510. @code{module-texi-documentation} is called. For example, it might be
  511. useful to define a @code{#:docs-resolver} argument."
  512. (define (make-entry node description)
  513. `("* " ,node "::"
  514. ,(make-string (max (- 21 (string-length node)) 2) #\space)
  515. ,@description "\n"))
  516. `(*fragment*
  517. (menu
  518. ,@(append-map (lambda (modname desc)
  519. (make-entry (module-name->node-name modname)
  520. desc))
  521. modules
  522. module-descriptions))
  523. ,@(append-map (lambda (modname)
  524. (stexi->chapter
  525. (apply module-stexi-documentation
  526. modname
  527. module-stexi-documentation-args)))
  528. modules)))
  529. ;;; arch-tag: bbe2bc03-e16d-4a9e-87b9-55225dc9836c