From aab5226dfe937861c54729744e8add15d931f758 Mon Sep 17 00:00:00 2001 From: jao Date: Mon, 20 Jul 2020 04:41:00 +0100 Subject: geiser -> src --- src/geiser/doc.scm | 258 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 258 insertions(+) create mode 100644 src/geiser/doc.scm (limited to 'src/geiser/doc.scm') 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 . + +;; 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-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))))))) -- cgit v1.2.3