diff options
| -rw-r--r-- | doc/img/repl-mod.png | bin | 17604 -> 29938 bytes | |||
| -rw-r--r-- | elisp/geiser-doc.el | 32 | ||||
| -rw-r--r-- | scheme/guile/geiser/doc.scm | 62 | ||||
| -rw-r--r-- | scheme/guile/geiser/modules.scm | 34 | ||||
| -rw-r--r-- | scheme/guile/geiser/utils.scm | 8 | ||||
| -rw-r--r-- | scheme/racket/geiser/autodoc.rkt | 66 | ||||
| -rw-r--r-- | scheme/racket/geiser/eval.rkt | 12 | ||||
| -rw-r--r-- | scheme/racket/geiser/main.rkt | 16 | ||||
| -rw-r--r-- | scheme/racket/geiser/modules.rkt | 35 |
9 files changed, 149 insertions, 116 deletions
diff --git a/doc/img/repl-mod.png b/doc/img/repl-mod.png Binary files differindex a2dcb10..9814b7e 100644 --- a/doc/img/repl-mod.png +++ b/doc/img/repl-mod.png diff --git a/elisp/geiser-doc.el b/elisp/geiser-doc.el index 7d42ce5..b95242c 100644 --- a/elisp/geiser-doc.el +++ b/elisp/geiser-doc.el @@ -122,19 +122,22 @@ (define-button-type 'geiser-doc--button 'action 'geiser-doc--button-action - 'face 'geiser-font-lock-doc-link 'follow-link t) -(defun geiser-doc--insert-button (target module impl) +(defun geiser-doc--insert-button (target module impl &optional sign) (let ((link (geiser-doc--make-link target module impl)) - (text (format "%s" (or target module))) + (text (format "%s" (or (and sign (geiser-autodoc--str* sign)) + target + module))) (help (format "%smodule %s" (if target (format "%s in " target) "") (or module "<unknown>")))) - (insert-text-button text - :type 'geiser-doc--button - 'geiser-link link - 'help-echo help))) + (apply 'insert-text-button + `(,text + :type geiser-doc--button + ,@(and (not sign) (list 'face 'geiser-font-lock-doc-link)) + geiser-link ,link + help-echo ,help)))) (defun geiser-doc--xbutton-action (button) (when geiser-doc--buffer-link @@ -183,7 +186,7 @@ (insert (format "%s" title)) (insert "(" (format "%s" (car title))) (dolist (a (cdr title)) - (insert " " (if (eq a '\#:rest) "." (format "%s" a)))) + (insert " " (if (eq a :rest) "." (format "%s" a)))) (insert ")")) (put-text-property p (point) 'face 'geiser-font-lock-doc-title) (when top @@ -199,11 +202,12 @@ (geiser-doc--insert-title title) (newline) (dolist (w lst) - (let ((name (if (listp w) (car w) w)) - (info (and (listp w) (cdr w)))) + (let ((name (car w)) + (signature (cdr (assoc 'signature w))) + (info (cdr (assoc 'info w)))) (insert (format "\t- ")) (if module - (geiser-doc--insert-button name module impl) + (geiser-doc--insert-button name module impl signature) (geiser-doc--insert-button nil name impl)) (when info (insert (format " %s" info))) (newline))) @@ -262,7 +266,10 @@ With prefix argument, ask for symbol (with completion)." "Display information about a given module." (interactive) (let* ((module (or module (geiser-completion--read-module))) - (exports (geiser-doc--get-module-exports module)) + (msg (format "Retrieving documentation for %s ..." module)) + (exports (progn + (message "%s" msg) + (geiser-doc--get-module-exports module))) (impl (or impl geiser-impl--implementation))) (if (not exports) (message "No information available for %s" module) @@ -286,6 +293,7 @@ With prefix argument, ask for symbol (with completion)." (geiser-doc--make-link nil module impl))) (geiser-doc--insert-footer) (goto-char (point-min))) + (message "%s done" msg) (geiser-doc--pop-to-buffer)))) (defun geiser-doc-next (&optional forget-current) 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 @@ (string<? (symbol->string l) (symbol->string r))))) (sort! syms cmp))) +(define (make-symbol-sort sel) + (let ((cmp (lambda (a b) + (string<? (symbol->string (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 |
