diff options
Diffstat (limited to 'scheme')
| -rw-r--r-- | scheme/Makefile.am | 16 | ||||
| -rw-r--r-- | scheme/guile/geiser/completion.scm | 25 | ||||
| -rw-r--r-- | scheme/guile/geiser/doc.scm | 89 | ||||
| -rw-r--r-- | scheme/guile/geiser/emacs.scm | 3 | ||||
| -rw-r--r-- | scheme/guile/geiser/evaluation.scm | 64 | ||||
| -rw-r--r-- | scheme/guile/geiser/xref.scm | 9 | ||||
| -rw-r--r-- | scheme/plt/geiser/autodoc.ss | 101 | ||||
| -rw-r--r-- | scheme/plt/geiser/completions.ss | 27 | ||||
| -rw-r--r-- | scheme/plt/geiser/eval.ss | 45 |
9 files changed, 136 insertions, 243 deletions
diff --git a/scheme/Makefile.am b/scheme/Makefile.am new file mode 100644 index 0000000..01ed6ca --- /dev/null +++ b/scheme/Makefile.am @@ -0,0 +1,16 @@ + +nobase_dist_pkgdata_DATA = \ + guile/geiser/completion.scm \ + guile/geiser/doc.scm \ + guile/geiser/emacs.scm \ + guile/geiser/evaluation.scm \ + guile/geiser/modules.scm \ + guile/geiser/utils.scm \ + guile/geiser/xref.scm \ + plt/geiser.ss \ + plt/geiser/autodoc.ss \ + plt/geiser/completions.ss \ + plt/geiser/eval.ss \ + plt/geiser/locations.ss \ + plt/geiser/modules.ss \ + plt/geiser/utils.ss diff --git a/scheme/guile/geiser/completion.scm b/scheme/guile/geiser/completion.scm index f4342bb..564b8f5 100644 --- a/scheme/guile/geiser/completion.scm +++ b/scheme/guile/geiser/completion.scm @@ -31,28 +31,9 @@ #:use-module (ice-9 session) #:use-module (ice-9 regex)) -(define (completions prefix . context) - (let ((context (and (not (null? context)) (car context))) - (prefix (string-append "^" (regexp-quote prefix)))) - (append (filter (lambda (s) (string-match prefix s)) - (map symbol->string (local-bindings context))) - (sort! (map symbol->string (apropos-internal prefix)) string<?)))) - -(define (local-bindings form) - (define (body f) (if (> (length f) 2) (cddr f) '())) - (let loop ((form form) (bindings '())) - (cond ((not (pair? form)) bindings) - ((list? (car form)) - (loop (cdr form) (append (local-bindings (car form)) bindings))) - ((and (list? form) (< (length form) 2)) bindings) - ((memq (car form) '(define define* lambda)) - (loop (body form) (append (pair->list (cadr form)) bindings))) - ((and (memq (car form) '(let let* letrec letrec*)) - (list? (cadr form))) - (loop (body form) (append (map car (cadr form)) bindings))) - ((and (eq? 'let (car form)) (symbol? (cadr form))) - (loop (cons 'let (body form)) (cons (cadr form) bindings))) - (else (loop (cdr form) bindings))))) +(define (completions prefix) + (let ((prefix (string-append "^" (regexp-quote prefix)))) + (sort! (map symbol->string (apropos-internal prefix)) string<?))) (define (module-completions prefix) (let* ((prefix (string-append "^" (regexp-quote prefix))) diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm index c61502e..52f5625 100644 --- a/scheme/guile/geiser/doc.scm +++ b/scheme/guile/geiser/doc.scm @@ -37,82 +37,41 @@ #:use-module (oop goops) #:use-module (srfi srfi-1)) -(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-macro define-macro* - define-method define-class define-generic)) - (and (= 2 (length form)) - (memq (car form) defforms) - (car form))) - -(define (describe-application form) - (let* ((fun (car form)) - (args (obj-args (symbol->object fun)))) +(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 - (list (cons 'signature (signature fun args)) - (cons 'position (find-position args form)) - (cons 'module (symbol-module fun)))))) + `(,@(signature id args) + (module . ,(symbol-module id)))))) (define (object-signature name obj) (let ((args (obj-args obj))) (and args (signature name args)))) -(define (signature fun args) - (let ((req (arglst args 'required)) - (opt (arglst args 'optional)) - (key (arglst args 'keyword)) - (rest (assq-ref args 'rest))) - (let ((sgn `(,fun ,@req - ,@(if (not (null? opt)) (cons #:opt opt) '()) - ,@(if (not (null? key)) (cons #:key key) '())))) - (if rest `(,@sgn #:rest ,rest) sgn)))) - -(define (find-position args form) - (let* ((lf (length form)) - (lf-1 (- lf 1))) - (if (= 1 lf) 0 - (let ((req (length (arglst args 'required))) - (opt (length (arglst args 'optional))) - (keys (map (lambda (k) (symbol->keyword (if (list? k) (car k) k))) - (arglst args 'keyword))) - (rest (assq-ref args 'rest))) - (cond ((<= lf (+ 1 req)) lf-1) - ((<= lf (+ 1 req opt)) (if (> opt 0) lf lf-1)) - ((or (memq (last form) keys) - (memq (car (take-right form 2)) keys)) => - (lambda (sl) - (+ 2 req - (if (> opt 0) (+ 1 opt) 0) - (- (length keys) (length sl))))) - (else (+ 1 req - (if (> opt 0) (+ 1 opt) 0) - (if (null? keys) 0 (+ 1 (length keys))) - (if rest 2 0)))))))) - -(define (arglst args kind) - (let ((args (assq-ref args kind))) - (cond ((or (not args) (null? args)) '()) - ((list? args) args) - (else (list args))))) +(define (signature id args) + (define (arglst kind) + (let ((args (assq-ref args kind))) + (cond ((or (not args) (null? args)) '()) + ((list? args) args) + (else (list args))))) + `(,id + (args ,@(if (list? args) + `((required ,@(arglst 'required)) + (optional ,@(arglst 'optional) + ,@(let ((rest (assq-ref args 'rest))) + (if rest (list "...") '()))) + (key ,@(arglst 'keyword))) + '())))) (define (obj-args obj) (cond ((not obj) #f) ((or (procedure? obj) (program? obj)) (arguments obj)) ((macro? obj) (or (obj-args (macro-transformer obj)) '((required ...)))) - (else #f))) + (else 'variable))) (define (arguments proc) (cond diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm index edae487..2aa91da 100644 --- a/scheme/guile/geiser/emacs.scm +++ b/scheme/guile/geiser/emacs.scm @@ -39,7 +39,8 @@ ge:module-exports ge:module-location ge:callers - ge:callees) + ge:callees + ge:find-file) #:use-module (geiser evaluation) #:use-module ((geiser modules) :renamer (symbol-prefix-proc 'ge:)) #:use-module ((geiser completion) :renamer (symbol-prefix-proc 'ge:)) diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm index 537e145..cbc088e 100644 --- a/scheme/guile/geiser/evaluation.scm +++ b/scheme/guile/geiser/evaluation.scm @@ -47,53 +47,47 @@ (else (display (format "ERROR: ~a, args: ~a" (car args) (cdr args))))) `(error (key . ,(car args)))) -(define (evaluate form module-name evaluator) - (let ((module (or (and (list? module-name) - (resolve-module module-name)) - (current-module))) - (evaluator (lambda (f m) - (call-with-values (lambda () (evaluator f m)) list))) - (result #f) - (captured-stack #f) - (error #f)) +(define (ge:compile form module-name) + (let* ((module (or (and (list? module-name) + (resolve-module module-name)) + (current-module))) + (result #f) + (captured-stack #f) + (error #f) + (ev (lambda () + (save-module-excursion + (lambda () + (set-current-module module) + (set! result (call-with-values + (lambda () (compile form)) + (lambda vs + (map (lambda (v) + (with-output-to-string + (lambda () (write v)))) + vs))))))))) (let ((output (with-output-to-string (lambda () - (set! result - (catch #t - (lambda () - (start-stack 'geiser-eval (evaluator form module))) - (lambda args - (set! error #t) - (apply handle-error captured-stack args)) - (lambda args - (set! captured-stack (make-stack #t 1 13))))))))) + (catch #t + (lambda () (start-stack 'geiser-eval (ev))) + (lambda args + (set! error #t) + (apply handle-error captured-stack args)) + (lambda args + (set! captured-stack (make-stack #t 2 15)))))))) (write `(,(if error result (cons 'result result)) (output . ,output))) (newline)))) -(define (eval-compile form module) - (save-module-excursion - (lambda () - (set-current-module module) - (compile form)))) - -(define (ge:eval form module-name) - (evaluate form module-name eval)) - -(define (ge:compile form module-name) - (evaluate form module-name eval-compile)) +(define ge:eval ge:compile) (define (ge:compile-file path) - "Compile and load file, given its full @var{path}." - (evaluate `(and (compile-file ,path) - (load-compiled ,(compiled-file-name path))) - '(system base compile) - eval-compile)) + "Compile a file, given its full @var{path}." + (ge:compile `(compile-and-load ,path) '(geiser evaluation))) (define (ge:load-file path) "Load file, given its full @var{path}." - (evaluate `(load ,path) #f eval)) + (ge:compile `(load-compiled ,(compiled-file-name path)) '(geiser evaluation))) (define (ge:macroexpand form . all) (let ((all (and (not (null? all)) (car all)))) diff --git a/scheme/guile/geiser/xref.scm b/scheme/guile/geiser/xref.scm index f00f724..2336fb2 100644 --- a/scheme/guile/geiser/xref.scm +++ b/scheme/guile/geiser/xref.scm @@ -28,7 +28,8 @@ #:export (symbol-location generic-methods callers - callees) + callees + find-file) #:use-module (geiser utils) #:use-module (geiser modules) #:use-module (geiser doc) @@ -90,4 +91,10 @@ (and obj (map procedure-xref (procedure-callees obj))))) +(define (find-file path) + (let loop ((dirs %load-path)) + (if (null? dirs) #f + (let ((candidate (string-append (car dirs) "/" path))) + (if (file-exists? candidate) candidate (loop (cdr dirs))))))) + ;;; xref.scm ends here diff --git a/scheme/plt/geiser/autodoc.ss b/scheme/plt/geiser/autodoc.ss index 73ed24d..c43f8c9 100644 --- a/scheme/plt/geiser/autodoc.ss +++ b/scheme/plt/geiser/autodoc.ss @@ -31,39 +31,32 @@ (eval `(help ,symbol #:from ,mod))))) (eval `(help ,symbol)))) -(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 (find-signature path name fun)))) - (and sgn - (list (cons 'signature (format-signature fun sgn)) - (cons 'position (find-position sgn form)) - (cons 'module (module-path-name->name path)))))) +(define (autodoc ids) + (if (not (list? ids)) + '() + (map (lambda (id) (or (autodoc* id) (list id))) ids))) + +(define (autodoc* id) + (and + (symbol? id) + (let* ((loc (symbol-location* id)) + (name (car loc)) + (path (cdr loc)) + (sgn (and path (find-signature path name id)))) + (and sgn + `(,id + (name . ,name) + (args ,@(format-signature sgn)) + (module . ,(module-path-name->name path))))))) + +(define (format-signature sign) + (if (signature? sign) + `((required ,@(signature-required sign)) + (optional ,@(signature-optional sign) + ,@(let ((rest (signature-rest sign))) + (if rest (list "...") '()))) + (key ,@(signature-keys sign))) + '())) (define signatures (make-hash)) @@ -71,9 +64,7 @@ (define (find-signature path name local-name) (let ((path (if (path? path) (path->string path) path))) - (hash-ref! (hash-ref! signatures - path - (lambda () (parse-signatures path))) + (hash-ref! (hash-ref! signatures path (lambda () (parse-signatures path))) name (lambda () (infer-signature local-name))))) @@ -167,44 +158,6 @@ (opt-no (- max-val min-val))) (make-signature (args 0 min-val) (args min-val opt-no) '() #f))))) -(define (format-signature fun sign) - (cond ((symbol? sign) (cons fun sign)) - ((signature? sign) - (let ((req (signature-required sign)) - (opt (signature-optional sign)) - (keys (signature-keys sign)) - (rest (signature-rest sign))) - `(,fun - ,@req - ,@(if (null? opt) opt (cons '#:opt opt)) - ,@(if (null? keys) keys (cons '#:key keys)) - ,@(if rest (list '#:rest rest) '())))) - (else #f))) - -(define (find-position sign form) - (if (signature? sign) - (let* ((lf (length form)) - (lf-1 (- lf 1))) - (if (= 1 lf) 0 - (let ((req (length (signature-required sign))) - (opt (length (signature-optional sign))) - (keys (map (lambda (k) (symbol->keyword (if (list? k) (car k) k))) - (signature-keys sign))) - (rest (signature-rest sign))) - (cond ((<= lf (+ 1 req)) lf-1) - ((<= lf (+ 1 req opt)) (if (> opt 0) lf lf-1)) - ((or (memq (last form) keys) - (memq (car (take-right form 2)) keys)) => - (lambda (sl) - (+ 2 req - (if (> opt 0) (+ 1 opt) 0) - (- (length keys) (length sl))))) - (else (+ 1 req - (if (> opt 0) (+ 1 opt) 0) - (if (null? keys) 0 (+ 1 (length keys))) - (if rest 2 0))))))) - 0)) - (define (update-module-cache path . form) (when (and (string? path) (or (null? form) diff --git a/scheme/plt/geiser/completions.ss b/scheme/plt/geiser/completions.ss index 4537feb..15bc081 100644 --- a/scheme/plt/geiser/completions.ss +++ b/scheme/plt/geiser/completions.ss @@ -35,29 +35,10 @@ (filter (lambda (s) (string-prefix? prefix s)) (if sort? (sort lst string<?) lst))) -(define (symbol-completions prefix (context #f)) - (append (filter-prefix prefix - (map symbol->string (local-bindings context)) - #f) - (filter-prefix prefix - (map symbol->string (namespace-mapped-symbols)) - #t))) - -(define (local-bindings form) - (define (body f) (if (> (length f) 2) (cddr f) '())) - (let loop ((form form) (bindings '())) - (cond ((not (pair? form)) bindings) - ((list? (car form)) - (loop (cdr form) (append (local-bindings (car form)) bindings))) - ((and (list? form) (< (length form) 2)) bindings) - ((memq (car form) '(define define* lambda)) - (loop (body form) (append (pair->list (cadr form)) bindings))) - ((and (memq (car form) '(let let* letrec letrec*)) - (list? (cadr form))) - (loop (body form) (append (map car (cadr form)) bindings))) - ((and (eq? 'let (car form)) (symbol? (cadr form))) - (loop (cons 'let (body form)) (cons (cadr form) bindings))) - (else (loop (cdr form) bindings))))) +(define (symbol-completions prefix) + (filter-prefix prefix + (map symbol->string (namespace-mapped-symbols)) + #t)) (define (module-completions prefix) (filter-prefix prefix (module-list) #f)) diff --git a/scheme/plt/geiser/eval.ss b/scheme/plt/geiser/eval.ss index 8022a4c..5ae81ed 100644 --- a/scheme/plt/geiser/eval.ss +++ b/scheme/plt/geiser/eval.ss @@ -46,36 +46,37 @@ (vector-ref (struct->vector e) 0)) (define (set-last-error e) - (set! last-result `((error (key . ,(exn-key e)) - (subr) - (msg . ,(exn-message e)))))) + (set! last-result `((error (key . ,(exn-key e))))) + (display (exn-message e))) -(define (set-last-result v . vs) - (set! last-result `((result ,v ,@vs)))) +(define (write-value v) + (with-output-to-string + (lambda () (write v)))) + +(define (set-last-result . vs) + (set! last-result `((result ,@(map write-value vs))))) (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 (module-spec->namespace spec))) - set-last-result)) - last-result) + (let ((output + (with-output-to-string + (lambda () + (with-handlers ((exn? set-last-error)) + (update-module-cache spec form) + (call-with-values + (lambda () (eval form (module-spec->namespace spec))) + set-last-result)))))) + (append last-result `((output . ,output))))) (define compile-in eval-in) (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 () - (load-module file (current-output-port)))) - "done.")) - (load-module (and (path? current-path) - (path->string current-path))))) - last-result) + (let ((current-path (namespace->module-path-name (last-namespace))) + (result (eval-in `(load-module ,file (current-output-port)) + 'geiser/eval))) + (update-module-cache file) + (load-module (and (path? current-path) (path->string current-path))) + result)) (define compile-file load-file) |