From cdd90c3af5a1a0fcd206293e8c8cb584b575e4f0 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Mon, 4 May 2009 01:05:33 +0200 Subject: PLT: autodoc (without argument positions). --- elisp/geiser-plt.el | 1 + scheme/plt/geiser.ss | 4 +- scheme/plt/geiser/autodoc.ss | 160 +++++++++++++++++++++++++++++++++++++++++ scheme/plt/geiser/eval.ss | 4 +- scheme/plt/geiser/locations.ss | 7 +- scheme/plt/geiser/utils.ss | 43 +++++++---- 6 files changed, 198 insertions(+), 21 deletions(-) create mode 100644 scheme/plt/geiser/autodoc.ss diff --git a/elisp/geiser-plt.el b/elisp/geiser-plt.el index 6526ae6..b93dc1d 100644 --- a/elisp/geiser-plt.el +++ b/elisp/geiser-plt.el @@ -138,6 +138,7 @@ This function uses `geiser-plt-init-file' if it exists." (let+ 1) (let-values 1) (let/ec 1) + (match defun) (mixin 2) (module defun) (opt-lambda 1) diff --git a/scheme/plt/geiser.ss b/scheme/plt/geiser.ss index bbb083d..767b13b 100644 --- a/scheme/plt/geiser.ss +++ b/scheme/plt/geiser.ss @@ -36,13 +36,13 @@ geiser/make-repl-reader) (compile-enforce-module-constants #f) - (require geiser/eval geiser/completions geiser/locations) + (require geiser/eval geiser/completions geiser/locations geiser/autodoc) (define geiser/eval eval-in) (define geiser/compile compile-in) (define geiser/load-file load-file) (define geiser/compile-file compile-file) - (define (geiser/autodoc . x) #f) + (define geiser/autodoc autodoc) (define geiser/completions completions) (define geiser/symbol-location symbol-location) (define geiser/macroexpand macroexpand) diff --git a/scheme/plt/geiser/autodoc.ss b/scheme/plt/geiser/autodoc.ss new file mode 100644 index 0000000..bcd1218 --- /dev/null +++ b/scheme/plt/geiser/autodoc.ss @@ -0,0 +1,160 @@ +;; autodoc.ss -- support for autodoc + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Sun May 03, 2009 14:45 + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +#lang scheme + +(provide autodoc update-module-cache) + +(require geiser/utils geiser/locations) + +(define (autodoc form) + (cond ((null? form) #f) + ((symbol? form) (describe-application (list form))) + ((not (pair? form)) #f) + ((not (list? form)) (autodoc (pair->list form))) + ((define-head? form) => autodoc) + (else (autodoc/list form)))) + +(define (autodoc/list form) + (let ((lst (last form))) + (cond ((and (symbol? lst) (describe-application (list lst)))) + ((and (pair? lst) (not (memq (car lst) '(quote))) (autodoc lst))) + (else (describe-application form))))) + +(define (define-head? form) + (define defforms '(-define + define define-values + define-method define-class define-generic define-struct + define-syntax define-syntaxes -define-syntax)) + (and (= 2 (length form)) + (memq (car form) defforms) + (car form))) + +(define (describe-application form) + (let* ((fun (car form)) + (loc (symbol-location* fun)) + (name (car loc)) + (path (cdr loc)) + (sgn (and path (signature path name fun)))) + (and sgn + (list (cons 'signature (cons fun sgn)) + (cons 'position 0) + (cons 'module (module-path-name->name path)))))) + +(define signatures (make-hash)) + +(define (signature path name local-name) + (let ((path (if (path? path) (path->string path) path))) + (hash-ref! (hash-ref! signatures + path + (lambda () (parse-signatures path))) + name + (lambda () (infer-signature local-name))))) + +(define (parse-signatures path) + (let ((result (make-hasheq))) + (with-handlers ((exn? (lambda (e) result))) + (with-input-from-file path + (lambda () + (parameterize ((read-accept-reader #t)) + (let loop ((stx (read-syntax path))) + (cond ((eof-object? stx) void) + ((syntax->datum stx) => + (lambda (datum) + (parse-datum! datum result) + (loop (read-syntax path)))) + (else void))))))) + result)) + +(define (parse-datum! datum store) + (match datum + ((list 'module name lang forms ...) + (for-each (lambda (f) (parse-datum! f store)) forms)) + ((list 'define (list name formals ...) body ...) + (add-signature! name formals store)) + ((list 'define name (list 'lambda formals body ...)) + (add-signature! name formals store)) + (_ void))) + +(define (add-signature! name formals store) + (hash-set! store name (parse-formals formals))) + +(define (parse-formals formals) + (let loop ((formals formals) (req '()) (opt '()) (keys '())) + (cond ((null? formals) (make-signature req opt keys #f)) + ((symbol? formals) (make-signature req opt keys formals)) + ((pair? (car formals)) (loop (cdr formals) + req + (cons (car formals) opt) + keys)) + ((keyword? (car formals)) (let* ((kname (keyword->symbol (car formals))) + (arg-id (cadr formals)) + (name (if (pair? arg-id) + (list kname (cadr arg-id)) + kname))) + (loop (cddr formals) + req + opt + (cons name keys)))) + (else (loop (cdr formals) (cons (car formals) req) opt keys))))) + +(define (make-signature req opt keys rest) + `(,@(reverse req) + ,@(if (null? opt) opt + (cons '#:opt (reverse opt))) + ,@(if (null? keys) keys + (cons '#:key (reverse keys))) + ,@(if rest (list '#:rest rest) '()))) + +(define (update-module-cache path . form) + (when (and (string? path) + (or (null? form) + (and (list? (car form)) + (not (null? (car form))) + (memq (caar form) '(define))))) + (hash-remove! signatures path))) + +(define (infer-signature name) + (let ((value (namespace-variable-value name (lambda () #f)))) + (and (procedure? value) + (arity->signature (procedure-arity value))))) + +(define (arity->signature arity) + (cond ((number? arity) + (make-signature (gen-arg-names 1 arity) '() '() #f)) + ((arity-at-least? arity) + (make-signature (gen-arg-names 1 (arity-at-least-value arity)) + '() '() 'rest)) + (else + (let ((arg (map (lambda (a) + (if (number? a) a (list (arity-at-least-value a) '...))) + arity))) + (make-signature (list arg) '() '() #f))))) + +(define (gen-arg-names fst count) + (let* ((letts (list->vector '(#\x #\y #\z #\u #\v #\w #\t))) + (len (vector-length letts)) + (lett (lambda (n) (vector-ref letts (modulo n len))))) + (reverse (map (lambda (n) (string->symbol (format "~a" (lett (- n 1))))) + (build-list (max count 1) (lambda (n) (+ n fst))))))) + +;;; autodoc.ss ends here diff --git a/scheme/plt/geiser/eval.ss b/scheme/plt/geiser/eval.ss index 9c6534e..694802a 100644 --- a/scheme/plt/geiser/eval.ss +++ b/scheme/plt/geiser/eval.ss @@ -33,7 +33,7 @@ macroexpand make-repl-reader) -(require scheme/enter geiser/utils) +(require scheme/enter geiser/utils geiser/autodoc) (define last-result (void)) (define nowhere (open-output-nowhere)) @@ -85,6 +85,7 @@ (define (eval-in form spec) (set-last-result (void)) (with-handlers ((exn? set-last-error)) + (update-module-cache spec form) (call-with-values (lambda () (eval form (ensure-namespace spec))) set-last-result)) @@ -95,6 +96,7 @@ (define (load-file file) (with-handlers ((exn? set-last-error)) (let ((current-path (namespace->module-path-name (last-namespace)))) + (update-module-cache file) (set-last-result (string-append (with-output-to-string (lambda () diff --git a/scheme/plt/geiser/locations.ss b/scheme/plt/geiser/locations.ss index b738a48..d1c5cb7 100644 --- a/scheme/plt/geiser/locations.ss +++ b/scheme/plt/geiser/locations.ss @@ -27,12 +27,13 @@ #lang scheme (provide symbol-location + symbol-location* symbol-module-name symbol-module-path-name) (require geiser/utils) -(define (%symbol-location sym) +(define (symbol-location* sym) (let* ((id (namespace-symbol->identifier sym)) (binding (and id (identifier-binding id)))) (if (list? binding) @@ -43,13 +44,13 @@ (cons sym #f)))) (define (symbol-location sym) - (let* ((loc (%symbol-location sym)) + (let* ((loc (symbol-location* sym)) (name (car loc)) (path (cdr loc))) (list (cons 'name name) (cons 'file (if (path? path) (path->string path) '()))))) -(define symbol-module-path-name (compose cdr %symbol-location)) +(define symbol-module-path-name (compose cdr symbol-location*)) (define symbol-module-name (compose module-path-name->name symbol-module-path-name)) diff --git a/scheme/plt/geiser/utils.ss b/scheme/plt/geiser/utils.ss index 9a774df..258a55d 100644 --- a/scheme/plt/geiser/utils.ss +++ b/scheme/plt/geiser/utils.ss @@ -26,24 +26,37 @@ #lang scheme -(provide module-path-name->name) +(provide module-path-name->name + pair->list + keyword->symbol) (require srfi/13) (define (module-path-name->name path) - (if (path? path) - (let* ((path (path->string path)) - (cpaths (map path->string (current-library-collection-paths))) - (prefix-len (lambda (p) - (let ((pl (string-length p))) - (if (= pl (string-prefix-length p path)) pl 0)))) - (lens (map prefix-len cpaths)) - (real-path (substring path (apply max lens)))) - (if (absolute-path? real-path) - (call-with-values (lambda () (split-path path)) - (lambda (_ basename __) basename)) - (regexp-replace "\\.[^./]*$" real-path ""))) - "")) - + (cond ((path? path) + (let* ((path (path->string path)) + (cpaths (map (compose path->string path->directory-path) + (current-library-collection-paths))) + (prefix-len (lambda (p) + (let ((pl (string-length p))) + (if (= pl (string-prefix-length p path)) pl 0)))) + (lens (map prefix-len cpaths)) + (real-path (substring path (apply max lens)))) + (if (absolute-path? real-path) + (call-with-values (lambda () (split-path path)) + (lambda (_ basename __) (path->string basename))) + (regexp-replace "\\.[^./]*$" real-path "")))) + ((eq? path '#%kernel) "(kernel)") + ((string? path) path) + ((symbol? path) (symbol->string path)) + (else ""))) + +(define (pair->list pair) + (let loop ((d pair) (s '())) + (cond ((null? d) (reverse s)) + ((symbol? d) (reverse (cons d s))) + (else (loop (cdr d) (cons (car d) s)))))) + +(define keyword->symbol (compose string->symbol keyword->string)) ;;; utils.ss ends here -- cgit v1.2.3