From 1d725a8c087b66b2cd2c0e5006c376faf612d6ff Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Sun, 21 Nov 2010 01:56:02 +0100 Subject: Better module help We now display procedure signatures in module help, and keep a cache in Guile, using procedure properties. --- scheme/guile/geiser/doc.scm | 62 +++++++++++++++++++++++++++++-------- scheme/guile/geiser/modules.scm | 34 +-------------------- scheme/guile/geiser/utils.scm | 8 +++++ scheme/racket/geiser/autodoc.rkt | 66 +++++++++++++++++++++++++++++++++------- scheme/racket/geiser/eval.rkt | 12 ++------ scheme/racket/geiser/main.rkt | 16 +++++++--- scheme/racket/geiser/modules.rkt | 35 ++------------------- 7 files changed, 129 insertions(+), 104 deletions(-) (limited to 'scheme') diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm index 902f2a3..345febd 100644 --- a/scheme/guile/geiser/doc.scm +++ b/scheme/guile/geiser/doc.scm @@ -12,6 +12,7 @@ (define-module (geiser doc) #:export (autodoc symbol-documentation + module-exports object-signature) #:use-module (geiser utils) #:use-module (geiser modules) @@ -58,9 +59,17 @@ (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)) (arguments obj)) + ((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))) @@ -121,17 +130,12 @@ (define (doc->args proc) (define proc-rx "-- Scheme Procedure: ([^[\n]+)\n") (define proc-rx2 "-- Scheme Procedure: ([^[\n]+\\[[^\n]*(\n[^\n]+\\]+)?)") - (cond ((procedure-property proc 'geiser-document-args)) - ((object-documentation proc) - => (lambda (doc) - (let* ((match (or (string-match proc-rx doc) - (string-match proc-rx2 doc))) - (args (and match - (parse-signature-string - (match:substring match 1))))) - (set-procedure-property! proc 'geiser-document-args args) - args))) - (else #f))) + (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 "\\[([^] ]+)\\]?") @@ -204,4 +208,36 @@ (let ((args (obj-args obj))) (and args (signature sym args)))) -;;; doc.scm ends here +(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))))))) diff --git a/scheme/guile/geiser/modules.scm b/scheme/guile/geiser/modules.scm index a1697a7..df53acb 100644 --- a/scheme/guile/geiser/modules.scm +++ b/scheme/guile/geiser/modules.scm @@ -15,7 +15,7 @@ module-path find-module all-modules - module-exports + submodules module-location) #:use-module (geiser utils) #:use-module (system vm program) @@ -76,35 +76,3 @@ (list mod) cs))) -(define (module-exports mod-name) - (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 sort-symbols! elts)) - (subs (map module-name (submodules (resolve-module mod-name #f))))) - (list (cons 'modules (append subs - (map (lambda (m) - `(,@mod-name ,m)) (car elts)))) - (cons 'procs (cadr elts)) - (cons 'vars (caddr elts))))) - -(define (classify-module-object name var elts) - (let ((obj (and (variable-bound? var) - (variable-ref var)))) - (cond ((not obj) elts) - ((and (module? obj) (eq? (module-kind obj) 'directory)) - (list (cons name (car elts)) - (cadr elts) - (caddr elts))) - ((or (procedure? obj) (program? obj) (macro? obj)) - (list (car elts) - (cons name (cadr elts)) - (caddr elts))) - (else (list (car elts) - (cadr elts) - (cons name (caddr elts))))))) - -;;; modules.scm ends here diff --git a/scheme/guile/geiser/utils.scm b/scheme/guile/geiser/utils.scm index 01dfaa0..632fe76 100644 --- a/scheme/guile/geiser/utils.scm +++ b/scheme/guile/geiser/utils.scm @@ -14,6 +14,7 @@ symbol->object pair->list sort-symbols! + make-symbol-sort gensym?) #:use-module (ice-9 regex)) @@ -37,6 +38,13 @@ (stringstring l) (symbol->string r))))) (sort! syms cmp))) +(define (make-symbol-sort sel) + (let ((cmp (lambda (a b) + (stringstring (sel a)) + (symbol->string (sel b)))))) + (lambda (syms) + (sort! syms cmp)))) + (define (gensym? sym) (and (symbol? sym) (gensym-name? (format "~A" sym)))) diff --git a/scheme/racket/geiser/autodoc.rkt b/scheme/racket/geiser/autodoc.rkt index ce6553f..e9c6a07 100644 --- a/scheme/racket/geiser/autodoc.rkt +++ b/scheme/racket/geiser/autodoc.rkt @@ -11,9 +11,14 @@ #lang racket -(provide autodoc update-signature-cache get-help) +(provide autodoc module-exports update-signature-cache get-help) -(require geiser/utils geiser/modules geiser/locations scheme/help) +(require racket/help + syntax/modcode + syntax/modresolve + geiser/utils + geiser/modules + geiser/locations) (define (get-help symbol mod) (with-handlers ([exn? (lambda (_) @@ -25,7 +30,7 @@ '() (map (lambda (id) (or (autodoc* id) (list id))) ids))) -(define (autodoc* id) +(define (autodoc* id (extra #t)) (define (val) (with-handlers ([exn? (const "")]) (format "~.a" (namespace-variable-value id)))) @@ -34,13 +39,20 @@ (let* ([loc (symbol-location* id)] [name (car loc)] [path (cdr loc)] - [sgns (and path (find-signatures path name id))]) + [sgns (and path (find-signatures path name id))] + [value (if (and extra sgns (not (list? sgns))) + (list (cons 'value (val))) + '())] + [mod (if (and extra sgns path) + (list (cons 'module + (module-path-name->name path))) + '())]) (and sgns `(,id (name . ,name) - (value . ,(if (list? sgns) "" (val))) (args ,@(if (list? sgns) (map format-signature sgns) '())) - (module . ,(module-path-name->name path))))))) + ,@value + ,@mod))))) (define (format-signature sign) (if (signature? sign) @@ -178,12 +190,44 @@ [(list? arity) (map arity->signature arity)] [else (list (arity->signature arity))])) -(define (update-signature-cache path . form) +(define (update-signature-cache path (form #f)) (when (and (string? path) - (or (null? form) - (and (list? (car form)) - (not (null? (car form))) - (memq (caar form) + (or (not form) + (and (list? form) + (not (null? form)) + (memq (car form) '(define-syntax-rule struct define-syntax define set! define-struct))))) (hash-remove! signatures path))) + +(define (module-exports mod) + (define (value id) + (with-handlers ([exn? (const #f)]) + (dynamic-require mod id (const #f)))) + (define (contracted id) + (let ([v (value id)]) + (if (has-contract? v) + (list id (cons 'info (contract-name (value-contract v)))) + (entry id)))) + (define (entry id) + (let ((sign (eval `(,autodoc* ',id #f) + (module-spec->namespace mod #f #f)))) + (if sign (list id (cons 'signature sign)) (list id)))) + (define (extract-ids ls) + (append-map (lambda (idls) + (map car (cdr idls))) + ls)) + (define (classify-ids ids) + (let loop ([ids ids] [procs '()] [vars '()]) + (cond [(null? ids) + `((procs ,@(map entry (reverse procs))) + (vars ,@(map list (reverse vars))))] + [(procedure? (value (car ids))) + (loop (cdr ids) (cons (car ids) procs) vars)] + [else (loop (cdr ids) procs (cons (car ids) vars))]))) + (let-values ([(reg syn) + (module-compiled-exports + (get-module-code (resolve-module-path mod #f)))]) + (let ([syn (map contracted (extract-ids syn))] + [reg (extract-ids reg)]) + `((syntax ,@syn) ,@(classify-ids reg))))) diff --git a/scheme/racket/geiser/eval.rkt b/scheme/racket/geiser/eval.rkt index 12c77ae..f1f3f51 100644 --- a/scheme/racket/geiser/eval.rkt +++ b/scheme/racket/geiser/eval.rkt @@ -12,14 +12,12 @@ #lang racket (provide eval-in - compile-in load-file - compile-file macroexpand make-repl-reader) -(require geiser/enter geiser/modules geiser/autodoc) +(require geiser/enter geiser/modules) (require errortrace/errortrace-lib) (define last-result (void)) @@ -55,17 +53,11 @@ (define (eval-in form spec lang) (write (call-with-result (lambda () - (update-signature-cache spec form) (eval form (module-spec->namespace spec lang))))) (newline)) -(define compile-in eval-in) - (define (load-file file) - (load-module file (current-output-port) (last-namespace)) - (update-signature-cache file)) - -(define compile-file load-file) + (load-module file (current-output-port) (last-namespace))) (define (macroexpand form . all) (let ([all (and (not (null? all)) (car all))]) diff --git a/scheme/racket/geiser/main.rkt b/scheme/racket/geiser/main.rkt index 4915b68..0c7de4e 100644 --- a/scheme/racket/geiser/main.rkt +++ b/scheme/racket/geiser/main.rkt @@ -32,10 +32,18 @@ geiser/autodoc) (define (geiser:eval lang) - (lambda (form spec) (eval-in form spec lang))) -(define geiser:compile compile-in) -(define geiser:load-file load-file) -(define geiser:compile-file compile-file) + (lambda (form spec) + (update-signature-cache spec form) + (eval-in form spec lang))) + +(define geiser:compile geiser:eval) + +(define (geiser:load-file file) + (update-signature-cache file) + (load-file file)) + +(define geiser:compile-file geiser:load-file) + (define geiser:autodoc autodoc) (define geiser:help get-help) (define geiser:completions symbol-completions) diff --git a/scheme/racket/geiser/modules.rkt b/scheme/racket/geiser/modules.rkt index 0591a92..8e85570 100644 --- a/scheme/racket/geiser/modules.rkt +++ b/scheme/racket/geiser/modules.rkt @@ -18,10 +18,9 @@ namespace->module-path-name module-path-name->name module-spec->path-name - module-list - module-exports) + module-list) -(require srfi/13 syntax/modresolve syntax/modcode geiser/enter) +(require srfi/13 geiser/enter) (define (ensure-module-spec spec) (cond [(symbol? spec) spec] @@ -141,38 +140,8 @@ (update-module-cache) module-cache) -(define (module-exports mod) - (define (value id) - (with-handlers ([exn? (const #f)]) - (dynamic-require mod id (const #f)))) - (define (contracted id) - (let ([v (value id)]) - (if (has-contract? v) - (cons id (contract-name (value-contract v))) - id))) - (define (extract-ids ls) - (append-map (lambda (idls) - (map car (cdr idls))) - ls)) - (define (classify-ids ids) - (let loop ([ids ids] [procs '()] [vars '()]) - (cond [(null? ids) - `((procs ,@(map contracted (reverse procs))) - (vars ,@(map contracted (reverse vars))))] - [(procedure? (value (car ids))) - (loop (cdr ids) (cons (car ids) procs) vars)] - [else (loop (cdr ids) procs (cons (car ids) vars))]))) - (let-values ([(reg syn) - (module-compiled-exports - (get-module-code (resolve-module-path mod #f)))]) - (let ([syn (map contracted (extract-ids syn))] - [reg (extract-ids reg)]) - `((syntax ,@syn) ,@(classify-ids reg))))) - (define (startup) (thread update-module-cache) (void)) (startup) - -;;; modules.rkt ends here -- cgit v1.2.3