summaryrefslogtreecommitdiff
path: root/src/geiser/doc.scm
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2020-07-20 04:41:00 +0100
committerjao <jao@gnu.org>2020-07-20 04:41:00 +0100
commitaab5226dfe937861c54729744e8add15d931f758 (patch)
tree7397e3edaffb23d5efb6aad1762681834faabfa3 /src/geiser/doc.scm
parent20043b13bb9756079d73c68ffd3942cecedb2b9e (diff)
downloadgeiser-guile-aab5226dfe937861c54729744e8add15d931f758.tar.gz
geiser-guile-aab5226dfe937861c54729744e8add15d931f758.tar.bz2
geiser -> src
Diffstat (limited to 'src/geiser/doc.scm')
-rw-r--r--src/geiser/doc.scm258
1 files changed, 258 insertions, 0 deletions
diff --git a/src/geiser/doc.scm b/src/geiser/doc.scm
new file mode 100644
index 0000000..9f28f7f
--- /dev/null
+++ b/src/geiser/doc.scm
@@ -0,0 +1,258 @@
+;;; doc.scm -- procedures providing documentation on scheme objects
+
+;; Copyright (C) 2009, 2010, 2018 Jose Antonio Ortega Ruiz
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the Modified BSD License. You should
+;; have received a copy of the license along with this program. If
+;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
+
+;; Start date: Sun Feb 08, 2009 18:44
+
+(define-module (geiser doc)
+ #:export (autodoc
+ symbol-documentation
+ module-exports
+ object-signature)
+ #:use-module (geiser utils)
+ #:use-module (geiser modules)
+ #:use-module (system vm program)
+ #:use-module (system vm debug)
+ #:use-module (ice-9 session)
+ #:use-module (ice-9 documentation)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 format)
+ #:use-module (oop goops)
+ #:use-module (srfi srfi-1))
+
+(define (autodoc ids)
+ (if (not (list? ids))
+ '()
+ (map (lambda (id) (or (autodoc* id) (list id))) ids)))
+
+(define* (autodoc* id)
+ (let ((args (obj-args (symbol->object id))))
+ (and args
+ `(,@(signature id args)
+ ("module" . ,(symbol-module id))))))
+
+(define (object-signature name obj)
+ (let ((args (obj-args obj)))
+ (and args (signature name args))))
+
+(define (value-str obj)
+ (format #f "~:@y" obj))
+
+(define* (signature id args-list #:optional (detail #t))
+ (define (arglst args kind)
+ (let ((args (assq-ref args kind)))
+ (cond ((or (not args) (null? args)) '())
+ ((list? args) args)
+ (else (list args)))))
+ (define (mkargs as)
+ `(("required" ,@(arglst as 'required))
+ ("optional" ,@(arglst as 'optional)
+ ,@(if (assq-ref as 'rest) (list "...") '()))
+ ("key" ,@(arglst as 'keyword))))
+ (let* ((args-list (map mkargs (if (list? args-list) args-list '())))
+ (value (and (and detail (null? args-list))
+ (value-str (symbol->object id)))))
+ `(,id ("args" ,@args-list) ,@(if value `(("value" . ,value)) '()))))
+
+(define default-macro-args '(((required ...))))
+
+(define geiser-args-key (gensym "geiser-args-key-"))
+
+(define (obj-args obj)
+ (cond ((not obj) #f)
+ ((or (procedure? obj) (program? obj))
+ (cond ((procedure-property obj geiser-args-key))
+ ((arguments obj) =>
+ (lambda (args)
+ (set-procedure-property! obj geiser-args-key args)
+ args))
+ (else #f)))
+ ((and (macro? obj) (macro-transformer obj)) => macro-args)
+ ((macro? obj) default-macro-args)
+ (else 'variable)))
+
+(define (program-arities prog)
+ (let ((addrs (program-address-range prog)))
+ (when (pair? addrs) (find-program-arities (car addrs)))))
+
+(define (arguments proc)
+ (define (p-args prog)
+ (let ((as (map arity-arguments-alist (or (program-arities prog) '()))))
+ (and (not (null? as)) as)))
+ (define (clist f) (lambda (x) (let ((y (f x))) (and y (list y)))))
+ (cond ((is-a? proc <generic>) (generic-args proc))
+ ((doc->args proc) => list)
+ ((procedure-property proc 'arglist) => (clist arglist->args))
+ ((procedure-source proc) => (clist source->args))
+ ((and (program? proc) (p-args proc)))
+ ((procedure-property proc 'arity) => (clist arity->args))
+ (else #f)))
+
+(define (source->args src)
+ (let ((formals (cadr src)))
+ (cond ((list? formals) `((required . ,formals)))
+ ((pair? formals)
+ `((required . ,(car formals)) (rest . ,(cdr formals))))
+ (else #f))))
+
+(define (macro-args tf)
+ (define* (collect args #:optional (req '()))
+ (cond ((null? args) (arglist->args `(,(reverse req) #f #f r #f)))
+ ((symbol? args) (arglist->args `(,(reverse req) #f #f r ,args)))
+ ((and (pair? args) (symbol? (car args)))
+ (collect (cdr args) (cons (car args) req)))
+ (else #f)))
+ (let* ((pats (procedure-property tf 'patterns))
+ (args (and pats (filter-map collect pats))))
+ (or (and args (not (null? args)) args) default-macro-args)))
+
+(define (arity->args art)
+ (define (gen-arg-names count)
+ (map (lambda (x) '_) (iota (max count 0))))
+ (let ((req (car art))
+ (opt (cadr art))
+ (rest (caddr art)))
+ `(,@(if (> req 0)
+ (list (cons 'required (gen-arg-names req)))
+ '())
+ ,@(if (> opt 0)
+ (list (cons 'optional (gen-arg-names opt)))
+ '())
+ ,@(if rest (list (cons 'rest 'rest)) '()))))
+
+(define (arglist->args arglist)
+ `((required . ,(car arglist))
+ (optional . ,(cadr arglist))
+ (keyword . ,(caddr arglist))
+ (rest . ,(car (cddddr arglist)))))
+
+(define (doc->args proc)
+ ;; Guile 2.0.9+ uses the (texinfo ...) modules to produce
+ ;; `guile-procedures.txt', and the output has a single hyphen, whereas
+ ;; `makeinfo' produces two hyphens.
+ (define proc-rx "--? Scheme Procedure: ([^[\n]+)\n")
+ (define proc-rx2 "--? Scheme Procedure: ([^[\n]+\\[[^\n]*(\n[^\n]+\\]+)?)")
+ (let ((doc (object-documentation proc)))
+ (and doc
+ (let ((match (or (string-match proc-rx doc)
+ (string-match proc-rx2 doc))))
+ (and match
+ (parse-signature-string (match:substring match 1)))))))
+
+(define (parse-signature-string str)
+ (define opt-arg-rx "\\[([^] ]+)\\]?")
+ (define opt-arg-rx2 "([^ ])+\\]+")
+ (let ((tokens (string-tokenize str)))
+ (if (< (length tokens) 2)
+ '()
+ (let loop ((tokens (cdr tokens)) (req '()) (opt '()) (rest #f))
+ (cond ((null? tokens)
+ `((required ,@(map string->symbol (reverse! req)))
+ (optional ,@(map string->symbol (reverse! opt)))
+ ,@(if rest
+ (list (cons 'rest (string->symbol rest)))
+ '())))
+ ((string=? "." (car tokens))
+ (if (not (null? (cdr tokens)))
+ (loop (cddr tokens) req opt (cadr tokens))
+ (loop '() req opt "rest")))
+ ((or (string-match opt-arg-rx (car tokens))
+ (string-match opt-arg-rx2 (car tokens)))
+ => (lambda (m)
+ (loop (cdr tokens)
+ req
+ (cons (match:substring m 1) opt)
+ rest)))
+ (else (loop (cdr tokens)
+ (cons (car tokens) req)
+ opt
+ rest)))))))
+
+(define (generic-args gen)
+ (define (src> src1 src2)
+ (> (length (cadr src1)) (length (cadr src2))))
+ (define (src m)
+ (catch #t
+ (lambda () (method-source m))
+ (lambda (k . a) #f)))
+ (let* ((methods (generic-function-methods gen))
+ (srcs (filter identity (map src methods))))
+ (cond ((and (null? srcs)
+ (not (null? methods))
+ (method-procedure (car methods))) => arguments)
+ ((not (null? srcs)) (list (source->args (car (sort! srcs src>)))))
+ (else '(((rest . rest)))))))
+
+(define (symbol-documentation sym)
+ (let ((obj (symbol->object sym)))
+ (if obj
+ `(("signature" . ,(or (obj-signature sym obj #f) sym))
+ ("docstring" . ,(docstring sym obj))))))
+
+(define (docstring sym obj)
+ (define (valuable?)
+ (not (or (macro? obj) (procedure? obj) (program? obj))))
+ (with-output-to-string
+ (lambda ()
+ (let* ((type (cond ((macro? obj) "A macro")
+ ((procedure? obj) "A procedure")
+ ((program? obj) "A compiled program")
+ (else "An object")))
+ (modname (symbol-module sym))
+ (doc (object-documentation obj)))
+ (display type)
+ (if modname
+ (begin
+ (display " in module ")
+ (display modname)
+ (display ".")))
+ (newline)
+ (if doc (begin (newline) (display doc)))
+ (if (valuable?) (begin (newline)
+ (display "Value:")
+ (newline)
+ (display " ")
+ (display (value-str obj))))))))
+
+(define* (obj-signature sym obj #:optional (detail #t))
+ (let ((args (obj-args obj)))
+ (and args (signature sym args detail))))
+
+(define (module-exports mod-name)
+ (define elt-sort (make-symbol-sort car))
+ (let* ((mod (catch #t
+ (lambda () (resolve-interface mod-name))
+ (lambda args (resolve-module mod-name))))
+ (elts (hash-fold classify-module-object
+ (list '() '() '())
+ (module-obarray mod)))
+ (elts (map elt-sort elts))
+ (subs (map (lambda (m) (list (module-name m)))
+ (submodules (resolve-module mod-name #f)))))
+ (list (cons "modules" subs)
+ (cons "procs" (car elts))
+ (cons "syntax" (cadr elts))
+ (cons "vars" (caddr elts)))))
+
+(define (classify-module-object name var elts)
+ (let ((obj (and (variable-bound? var)
+ (variable-ref var))))
+ (cond ((or (not obj) (module? obj)) elts)
+ ((or (procedure? obj) (program? obj))
+ (list (cons (list name `("signature" . ,(obj-signature name obj)))
+ (car elts))
+ (cadr elts)
+ (caddr elts)))
+ ((macro? obj)
+ (list (car elts)
+ (cons (list name `("signature" . ,(obj-signature name obj)))
+ (cadr elts))
+ (caddr elts)))
+ (else (list (car elts)
+ (cadr elts)
+ (cons (list name) (caddr elts)))))))