doc.scm (9692B)
1 ;;; doc.scm -- procedures providing documentation on scheme objects 2 3 ;; Copyright (C) 2009, 2010, 2018 Jose Antonio Ortega Ruiz 4 5 ;; This program is free software; you can redistribute it and/or 6 ;; modify it under the terms of the Modified BSD License. You should 7 ;; have received a copy of the license along with this program. If 8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. 9 10 ;; Start date: Sun Feb 08, 2009 18:44 11 12 (define-module (geiser doc) 13 #:export (autodoc 14 symbol-documentation 15 module-exports 16 object-signature) 17 #:use-module (geiser utils) 18 #:use-module (geiser modules) 19 #:use-module (system vm program) 20 #:use-module (system vm debug) 21 #:use-module (ice-9 session) 22 #:use-module (ice-9 documentation) 23 #:use-module (ice-9 regex) 24 #:use-module (ice-9 format) 25 #:use-module (oop goops) 26 #:use-module (srfi srfi-1)) 27 28 (define (autodoc ids) 29 (if (not (list? ids)) 30 '() 31 (map (lambda (id) (or (autodoc* id) (list id))) ids))) 32 33 (define* (autodoc* id) 34 (let ((args (obj-args (symbol->object id)))) 35 (and args 36 `(,@(signature id args) 37 ("module" . ,(symbol-module id)))))) 38 39 (define (object-signature name obj) 40 (let ((args (obj-args obj))) 41 (and args (signature name args)))) 42 43 (define (value-str obj) 44 (format #f "~:@y" obj)) 45 46 (define* (signature id args-list #:optional (detail #t)) 47 (define (arglst args kind) 48 (let ((args (assq-ref args kind))) 49 (cond ((or (not args) (null? args)) '()) 50 ((list? args) args) 51 (else (list args))))) 52 (define (mkargs as) 53 `(("required" ,@(arglst as 'required)) 54 ("optional" ,@(arglst as 'optional) 55 ,@(if (assq-ref as 'rest) (list "...") '())) 56 ("key" ,@(arglst as 'keyword)))) 57 (let* ((args-list (map mkargs (if (list? args-list) args-list '()))) 58 (value (and (and detail (null? args-list)) 59 (value-str (symbol->object id))))) 60 `(,id ("args" ,@args-list) ,@(if value `(("value" . ,value)) '())))) 61 62 (define default-macro-args '(((required ...)))) 63 64 (define geiser-args-key (gensym "geiser-args-key-")) 65 66 (define (obj-args obj) 67 (cond ((not obj) #f) 68 ((or (procedure? obj) (program? obj)) 69 (cond ((procedure-property obj geiser-args-key)) 70 ((arguments obj) => 71 (lambda (args) 72 (set-procedure-property! obj geiser-args-key args) 73 args)) 74 (else #f))) 75 ((and (macro? obj) (macro-transformer obj)) => macro-args) 76 ((macro? obj) default-macro-args) 77 (else 'variable))) 78 79 (define (program-arities prog) 80 (let ((addrs (program-address-range prog))) 81 (and (pair? addrs) (find-program-arities (car addrs))))) 82 83 (define (arguments proc) 84 (define (p-args prog) 85 (let ((as (map arity-arguments-alist (or (program-arities prog) '())))) 86 (and (not (null? as)) as))) 87 (define (clist f) (lambda (x) (let ((y (f x))) (and y (list y))))) 88 (cond ((is-a? proc <generic>) (generic-args proc)) 89 ((doc->args proc) => list) 90 ((procedure-property proc 'arglist) => (clist arglist->args)) 91 ((procedure-source proc) => (clist source->args)) 92 ((and (program? proc) (p-args proc))) 93 ((procedure-property proc 'arity) => (clist arity->args)) 94 (else #f))) 95 96 (define (source->args src) 97 (let ((formals (cadr src))) 98 (cond ((list? formals) `((required . ,formals))) 99 ((pair? formals) 100 `((required . ,(car formals)) (rest . ,(cdr formals)))) 101 (else #f)))) 102 103 (define (macro-args tf) 104 (define* (collect args #:optional (req '())) 105 (cond ((null? args) (arglist->args `(,(reverse req) #f #f r #f))) 106 ((symbol? args) (arglist->args `(,(reverse req) #f #f r ,args))) 107 ((and (pair? args) (symbol? (car args))) 108 (collect (cdr args) (cons (car args) req))) 109 (else #f))) 110 (let* ((pats (procedure-property tf 'patterns)) 111 (args (and pats (filter-map collect pats)))) 112 (or (and args (not (null? args)) args) default-macro-args))) 113 114 (define (arity->args art) 115 (define (gen-arg-names count) 116 (map (lambda (x) '_) (iota (max count 0)))) 117 (let ((req (car art)) 118 (opt (cadr art)) 119 (rest (caddr art))) 120 `(,@(if (> req 0) 121 (list (cons 'required (gen-arg-names req))) 122 '()) 123 ,@(if (> opt 0) 124 (list (cons 'optional (gen-arg-names opt))) 125 '()) 126 ,@(if rest (list (cons 'rest 'rest)) '())))) 127 128 (define (arglist->args arglist) 129 `((required . ,(car arglist)) 130 (optional . ,(cadr arglist)) 131 (keyword . ,(caddr arglist)) 132 (rest . ,(car (cddddr arglist))))) 133 134 (define (doc->args proc) 135 ;; Guile 2.0.9+ uses the (texinfo ...) modules to produce 136 ;; `guile-procedures.txt', and the output has a single hyphen, whereas 137 ;; `makeinfo' produces two hyphens. 138 (define proc-rx "--? Scheme Procedure: ([^[\n]+)\n") 139 (define proc-rx2 "--? Scheme Procedure: ([^[\n]+\\[[^\n]*(\n[^\n]+\\]+)?)") 140 (let ((doc (object-documentation proc))) 141 (and doc 142 (let ((match (or (string-match proc-rx doc) 143 (string-match proc-rx2 doc)))) 144 (and match 145 (parse-signature-string (match:substring match 1))))))) 146 147 (define (parse-signature-string str) 148 (define opt-arg-rx "\\[([^] ]+)\\]?") 149 (define opt-arg-rx2 "([^ ])+\\]+") 150 (let ((tokens (string-tokenize str))) 151 (if (< (length tokens) 2) 152 '() 153 (let loop ((tokens (cdr tokens)) (req '()) (opt '()) (rest #f)) 154 (cond ((null? tokens) 155 `((required ,@(map string->symbol (reverse! req))) 156 (optional ,@(map string->symbol (reverse! opt))) 157 ,@(if rest 158 (list (cons 'rest (string->symbol rest))) 159 '()))) 160 ((string=? "." (car tokens)) 161 (if (not (null? (cdr tokens))) 162 (loop (cddr tokens) req opt (cadr tokens)) 163 (loop '() req opt "rest"))) 164 ((or (string-match opt-arg-rx (car tokens)) 165 (string-match opt-arg-rx2 (car tokens))) 166 => (lambda (m) 167 (loop (cdr tokens) 168 req 169 (cons (match:substring m 1) opt) 170 rest))) 171 (else (loop (cdr tokens) 172 (cons (car tokens) req) 173 opt 174 rest))))))) 175 176 (define (generic-args gen) 177 (define (src> src1 src2) 178 (> (length (cadr src1)) (length (cadr src2)))) 179 (define (src m) 180 (catch #t 181 (lambda () (method-source m)) 182 (lambda (k . a) #f))) 183 (let* ((methods (generic-function-methods gen)) 184 (srcs (filter identity (map src methods)))) 185 (cond ((and (null? srcs) 186 (not (null? methods)) 187 (method-procedure (car methods))) => arguments) 188 ((not (null? srcs)) (list (source->args (car (sort! srcs src>))))) 189 (else '(((rest . rest))))))) 190 191 (define (symbol-documentation sym) 192 (let ((obj (symbol->object sym))) 193 (if obj 194 `(("signature" . ,(or (obj-signature sym obj #f) sym)) 195 ("docstring" . ,(docstring sym obj)))))) 196 197 (define (docstring sym obj) 198 (define (valuable?) 199 (not (or (macro? obj) (procedure? obj) (program? obj)))) 200 (with-output-to-string 201 (lambda () 202 (let* ((type (cond ((macro? obj) "A macro") 203 ((procedure? obj) "A procedure") 204 ((program? obj) "A compiled program") 205 (else "An object"))) 206 (modname (symbol-module sym)) 207 (doc (object-documentation obj))) 208 (display type) 209 (if modname 210 (begin 211 (display " in module ") 212 (display modname) 213 (display "."))) 214 (newline) 215 (if doc (begin (newline) (display doc))) 216 (if (valuable?) (begin (newline) 217 (display "Value:") 218 (newline) 219 (display " ") 220 (display (value-str obj)))))))) 221 222 (define* (obj-signature sym obj #:optional (detail #t)) 223 (let ((args (obj-args obj))) 224 (and args (signature sym args detail)))) 225 226 (define (module-exports mod-name) 227 (define elt-sort (make-symbol-sort car)) 228 (let* ((mod (catch #t 229 (lambda () (resolve-interface mod-name)) 230 (lambda args (resolve-module mod-name)))) 231 (elts (hash-fold classify-module-object 232 (list '() '() '()) 233 (module-obarray mod))) 234 (elts (map elt-sort elts)) 235 (subs (map (lambda (m) (list (module-name m))) 236 (submodules (resolve-module mod-name #f))))) 237 (list (cons "modules" subs) 238 (cons "procs" (car elts)) 239 (cons "syntax" (cadr elts)) 240 (cons "vars" (caddr elts))))) 241 242 (define (classify-module-object name var elts) 243 (let ((obj (and (variable-bound? var) 244 (variable-ref var)))) 245 (cond ((or (not obj) (module? obj)) elts) 246 ((or (procedure? obj) (program? obj)) 247 (list (cons (list name `("signature" . ,(obj-signature name obj))) 248 (car elts)) 249 (cadr elts) 250 (caddr elts))) 251 ((macro? obj) 252 (list (car elts) 253 (cons (list name `("signature" . ,(obj-signature name obj))) 254 (cadr elts)) 255 (caddr elts))) 256 (else (list (car elts) 257 (cadr elts) 258 (cons (list name) (caddr elts)))))))