From ee5412e57af6f22b623cbe772fec2f0af91038d7 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Sun, 14 Jun 2009 01:23:41 +0200 Subject: Guile: better stack trace display. --- scheme/guile/geiser/evaluation.scm | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) (limited to 'scheme') diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm index 537e145..de08d17 100644 --- a/scheme/guile/geiser/evaluation.scm +++ b/scheme/guile/geiser/evaluation.scm @@ -67,7 +67,7 @@ (set! error #t) (apply handle-error captured-stack args)) (lambda args - (set! captured-stack (make-stack #t 1 13))))))))) + (set! captured-stack (make-stack #t 2 15))))))))) (write `(,(if error result (cons 'result result)) (output . ,output))) (newline)))) @@ -78,22 +78,17 @@ (set-current-module module) (compile form)))) -(define (ge:eval form module-name) - (evaluate form module-name eval)) - +(define ge:eval ge:compile) (define (ge:compile form module-name) (evaluate form module-name eval-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)))) -- cgit v1.2.3 From c042571626977f12916d59966ea94ded44d8cf32 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Sun, 14 Jun 2009 22:05:23 +0200 Subject: Guile: Bug fix in the latest evaluation code changes. --- scheme/guile/geiser/evaluation.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'scheme') diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm index de08d17..3e38843 100644 --- a/scheme/guile/geiser/evaluation.scm +++ b/scheme/guile/geiser/evaluation.scm @@ -78,10 +78,11 @@ (set-current-module module) (compile form)))) -(define ge:eval ge:compile) (define (ge:compile form module-name) (evaluate form module-name eval-compile)) +(define ge:eval ge:compile) + (define (ge:compile-file path) "Compile a file, given its full @var{path}." (ge:compile `(compile-and-load ,path) '(geiser evaluation))) -- cgit v1.2.3 From 547363acef3c40350382bea812a533c6dbd532cc Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Tue, 16 Jun 2009 23:14:34 +0200 Subject: PLT: Output included in retorts. --- scheme/plt/geiser/eval.ss | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) (limited to 'scheme') diff --git a/scheme/plt/geiser/eval.ss b/scheme/plt/geiser/eval.ss index 8022a4c..ec86370 100644 --- a/scheme/plt/geiser/eval.ss +++ b/scheme/plt/geiser/eval.ss @@ -46,9 +46,8 @@ (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))) + (output . ,(exn-message e))))) (define (set-last-result v . vs) (set! last-result `((result ,v ,@vs)))) @@ -57,10 +56,13 @@ (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 ((out + (with-output-to-string + (lambda () + (call-with-values + (lambda () (eval form (module-spec->namespace spec))) + set-last-result))))) + (append last-result `((output . ,out)))))) (define compile-in eval-in) -- cgit v1.2.3 From 184fd00d6f3bd1ca3ad0e6c1d93731d649668f4a Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Wed, 17 Jun 2009 01:57:36 +0200 Subject: PLT: Fixing the fix. --- scheme/plt/geiser/eval.ss | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) (limited to 'scheme') diff --git a/scheme/plt/geiser/eval.ss b/scheme/plt/geiser/eval.ss index ec86370..1ac94a3 100644 --- a/scheme/plt/geiser/eval.ss +++ b/scheme/plt/geiser/eval.ss @@ -46,23 +46,23 @@ (vector-ref (struct->vector e) 0)) (define (set-last-error e) - (set! last-result `((error (key . ,(exn-key e))) - (output . ,(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 (eval-in form spec) (set-last-result (void)) - (with-handlers ((exn? set-last-error)) - (update-module-cache spec form) - (let ((out - (with-output-to-string - (lambda () + (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 . ,out)))))) + set-last-result)))))) + (append last-result `((output . ,output))))) (define compile-in eval-in) -- cgit v1.2.3 From 841766449b9dc14d40186a67cdceda26fc6ca4ff Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Fri, 19 Jun 2009 16:52:03 +0200 Subject: Guile: backtrace buttonization. --- elisp/geiser-guile.el | 38 ++++++++++++++++++++++++++++++++++++++ scheme/guile/geiser/emacs.scm | 3 ++- scheme/guile/geiser/xref.scm | 9 ++++++++- 3 files changed, 48 insertions(+), 2 deletions(-) (limited to 'scheme') diff --git a/elisp/geiser-guile.el b/elisp/geiser-guile.el index 44a4e9f..ed2a555 100644 --- a/elisp/geiser-guile.el +++ b/elisp/geiser-guile.el @@ -120,6 +120,44 @@ This function uses `geiser-guile-init-file' if it exists." (save-excursion (skip-syntax-backward "^(>") (1- (point)))) (save-excursion (skip-syntax-backward "^-()>") (point)))) + +;;; Error display +(defvar geiser-guile--file-cache (make-hash-table :test 'equal)) + +(defun geiser-guile--resolve-file (file) + (when (and (stringp file) (not (string-equal file "unknown file"))) + (if (file-name-absolute-p file) file + (or (gethash file geiser-guile--file-cache) + (puthash file + (geiser-eval--send/result `(:eval ((:ge find-file) ,file))) + geiser-guile--file-cache))))) + +(defconst geiser-guile--file-rx + "^In \\([^\n:]+\\):\n *\\([[:digit:]]+\\|\\?\\):") + +(defun geiser-guile--find-files () + (save-excursion + (while (re-search-forward geiser-guile--file-rx nil t) + (let ((file (match-string 1)) + (beg (match-beginning 1)) + (end (match-end 1)) + (line (string-to-number (or (match-string 2) "0")))) + (let ((file (geiser-guile--resolve-file file))) + (when file + (geiser-edit--make-link beg end file line 0))))))) + +(defun geiser-guile-display-error (module key msg) + (when key + (insert "Error: ") + (geiser--insert-with-face (format "%s" key) 'bold) + (newline 2)) + (when msg + (let ((p (point))) + (insert msg) + (goto-char p) + (geiser-guile--find-files))) + t) + ;;; Trying to ascertain whether a buffer is Guile Scheme: 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/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 -- cgit v1.2.3 From ba38e61e768a5e2b6ccdebc09262e3186a8cf15b Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Mon, 29 Jun 2009 00:27:28 +0200 Subject: PLT: Better load/compile file results reporting. --- scheme/plt/geiser/eval.ss | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) (limited to 'scheme') diff --git a/scheme/plt/geiser/eval.ss b/scheme/plt/geiser/eval.ss index 1ac94a3..435b73b 100644 --- a/scheme/plt/geiser/eval.ss +++ b/scheme/plt/geiser/eval.ss @@ -67,17 +67,12 @@ (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) -- cgit v1.2.3 From 710d0cec8854a4e89f4948d49e614f286913f711 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Thu, 2 Jul 2009 05:29:04 +0200 Subject: Simpler, nicer, more efficient handling of evaluation results. It comes with a pony too. --- elisp/geiser-connection.el | 1 - elisp/geiser-debug.el | 10 +++++--- elisp/geiser-eval.el | 9 ++++++- elisp/geiser-syntax.el | 10 -------- scheme/guile/geiser/evaluation.scm | 51 ++++++++++++++++++-------------------- scheme/plt/geiser/eval.ss | 8 ++++-- 6 files changed, 45 insertions(+), 44 deletions(-) (limited to 'scheme') diff --git a/elisp/geiser-connection.el b/elisp/geiser-connection.el index 0ec6405..4f8592b 100644 --- a/elisp/geiser-connection.el +++ b/elisp/geiser-connection.el @@ -165,7 +165,6 @@ (goto-char (point-min)) (re-search-forward "((\\(result\\|error\\)\\>") (goto-char (match-beginning 0)) - (geiser-syntax--prepare-scheme-for-elisp-reader) (let ((form (read (current-buffer)))) (if (listp form) form (error)))) (error `((error (key . geiser-con-error)) diff --git a/elisp/geiser-debug.el b/elisp/geiser-debug.el index ec2e93e..6d795df 100644 --- a/elisp/geiser-debug.el +++ b/elisp/geiser-debug.el @@ -59,7 +59,7 @@ ;;; Displaying retorts -(defun geiser-debug--display-retort (what ret) +(defun geiser-debug--display-retort (what ret &optional res) (let* ((err (geiser-eval--retort-error ret)) (key (geiser-eval--error-key err)) (output (geiser-eval--retort-output ret)) @@ -69,6 +69,9 @@ (erase-buffer) (insert what) (newline 2) + (when res + (insert res) + (newline 2)) (unless (geiser-impl--display-error impl module key output) (when err (insert (geiser-eval--error-str err) "\n\n")) (when output (insert output "\n\n"))) @@ -88,10 +91,11 @@ (wrapped (if wrap (geiser-debug--wrap-region str) str)) (code `(,(if compile :comp :eval) (:scm ,wrapped))) (ret (geiser-eval--send/wait code)) + (res (geiser-eval--retort-result-str ret)) (err (geiser-eval--retort-error ret))) (when and-go (funcall and-go)) - (when (not err) (message (format "=> %S" (geiser-eval--retort-result ret)))) - (geiser-debug--display-retort str ret))) + (when (not err) (message "%s" res)) + (geiser-debug--display-retort str ret res))) (defun geiser-debug--expand-region (start end all wrap) (let* ((str (buffer-substring-no-properties start end)) diff --git a/elisp/geiser-eval.el b/elisp/geiser-eval.el index 90be67c..428d057 100644 --- a/elisp/geiser-eval.el +++ b/elisp/geiser-eval.el @@ -145,7 +145,14 @@ EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be supported.")) (defun geiser-eval--retort-result (ret) (let ((values (cdr (assoc 'result ret)))) - (if (> (length values) 1) (cons :values values) (car values)))) + (and (stringp (car values)) + (ignore-errors (car (read-from-string (car values))))))) + +(defun geiser-eval--retort-result-str (ret) + (let ((values (cdr (assoc 'result ret)))) + (if values + (concat "=> " (mapconcat 'identity values "\n=> ")) + "(No value)")))) (defsubst geiser-eval--retort-output (ret) (cdr (assoc 'output ret))) (defsubst geiser-eval--retort-error (ret) (cdr (assoc 'error ret))) diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el index c70aacb..db1c842 100644 --- a/elisp/geiser-syntax.el +++ b/elisp/geiser-syntax.el @@ -84,16 +84,6 @@ (geiser-popup--define syntax " *geiser syntax analyst*" scheme-mode) -(defun geiser-syntax--prepare-scheme-for-elisp-reader () - (let ((end (save-excursion - (goto-char (point-max)) - (and (re-search-backward "(output \\. \"" nil t) - (point))))) - (save-excursion - (while (re-search-forward "#(" end t) (replace-match "(vector ")) - (goto-char (point-min)) - (while (re-search-forward "#" end t) (replace-match "\\\\#"))))) - (defsubst geiser-syntax--del-sexp (arg) (let ((p (point))) (forward-sexp arg) diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm index 3e38843..c2147a1 100644 --- a/scheme/guile/geiser/evaluation.scm +++ b/scheme/guile/geiser/evaluation.scm @@ -47,40 +47,37 @@ (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 + (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 2 15))))))))) + (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:compile form module-name) - (evaluate form module-name eval-compile)) - (define ge:eval ge:compile) (define (ge:compile-file path) diff --git a/scheme/plt/geiser/eval.ss b/scheme/plt/geiser/eval.ss index 435b73b..5ae81ed 100644 --- a/scheme/plt/geiser/eval.ss +++ b/scheme/plt/geiser/eval.ss @@ -49,8 +49,12 @@ (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)) -- cgit v1.2.3 From d3df979d3e02bc68c36a9b243881a3ad638e3af9 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Thu, 9 Jul 2009 04:45:10 +0200 Subject: Guile: unbreaking evaluation. --- scheme/guile/geiser/evaluation.scm | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) (limited to 'scheme') diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm index c2147a1..cbc088e 100644 --- a/scheme/guile/geiser/evaluation.scm +++ b/scheme/guile/geiser/evaluation.scm @@ -56,14 +56,15 @@ (error #f) (ev (lambda () (save-module-excursion - (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)))))))) + (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 () -- cgit v1.2.3 From 94be6173b640411e8205778fc7e080f6fbdac9dc Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Fri, 7 Aug 2009 00:11:52 +0200 Subject: kludgy fix for opt/key/rest markers in autodoc --- elisp/geiser-autodoc.el | 6 +++--- scheme/guile/geiser/doc.scm | 6 +++--- scheme/plt/geiser/autodoc.ss | 6 +++--- 3 files changed, 9 insertions(+), 9 deletions(-) (limited to 'scheme') diff --git a/elisp/geiser-autodoc.el b/elisp/geiser-autodoc.el index f6d36a8..0449032 100644 --- a/elisp/geiser-autodoc.el +++ b/elisp/geiser-autodoc.el @@ -97,10 +97,10 @@ when `geiser-autodoc-display-module-p' is on." (defun geiser-autodoc--insert-arg (arg current pos) (let ((p (point)) - (str (format "%s" (if (eq arg '\#:rest) "." arg))) - (face (cond ((eq '\#:opt arg) + (str (format "%s" (if (eq arg 'geiser-rest_marker) "." arg))) + (face (cond ((eq 'geiser-opt_marker arg) 'geiser-font-lock-autodoc-optional-arg-marker) - ((eq '\#:key arg) + ((eq 'geiser-key_marker arg) 'geiser-font-lock-autodoc-key-arg-marker) ((= current pos) 'geiser-font-lock-autodoc-current-arg) diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm index c61502e..e7640e6 100644 --- a/scheme/guile/geiser/doc.scm +++ b/scheme/guile/geiser/doc.scm @@ -76,9 +76,9 @@ (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)))) + ,@(if (not (null? opt)) (cons 'geiser-opt_marker opt) '()) + ,@(if (not (null? key)) (cons 'geiser-key_maker key) '())))) + (if rest `(,@sgn 'geiser-rest_marker ,rest) sgn)))) (define (find-position args form) (let* ((lf (length form)) diff --git a/scheme/plt/geiser/autodoc.ss b/scheme/plt/geiser/autodoc.ss index 73ed24d..6607a94 100644 --- a/scheme/plt/geiser/autodoc.ss +++ b/scheme/plt/geiser/autodoc.ss @@ -176,9 +176,9 @@ (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) '())))) + ,@(if (null? opt) opt (cons 'geiser-opt_marker opt)) + ,@(if (null? keys) keys (cons 'geiser-key_maker keys)) + ,@(if rest (list 'geiser-rest_marker rest) '())))) (else #f))) (define (find-position sign form) -- cgit v1.2.3 From db34b16737120ac0c6951c32b8d1aa838491cf84 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Mon, 10 Aug 2009 15:35:59 +0200 Subject: Guile: fix for rest marker in autodoc. --- scheme/guile/geiser/doc.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'scheme') diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm index e7640e6..3f060e3 100644 --- a/scheme/guile/geiser/doc.scm +++ b/scheme/guile/geiser/doc.scm @@ -78,7 +78,7 @@ (let ((sgn `(,fun ,@req ,@(if (not (null? opt)) (cons 'geiser-opt_marker opt) '()) ,@(if (not (null? key)) (cons 'geiser-key_maker key) '())))) - (if rest `(,@sgn 'geiser-rest_marker ,rest) sgn)))) + (if rest `(,@sgn geiser-rest_marker ,rest) sgn)))) (define (find-position args form) (let* ((lf (length form)) -- cgit v1.2.3 From 283e6f040449bb4f740991956007332c48308b38 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Mon, 17 Aug 2009 04:18:02 +0200 Subject: Simpler, more correct and efficient autodoc implementation. Not that it was difficult: it's replacing an ugly kludge. --- elisp/geiser-autodoc.el | 148 ++++++++++++++++++++++--------------------- elisp/geiser-syntax.el | 27 ++++++++ scheme/guile/geiser/doc.scm | 85 ++++++------------------- scheme/plt/geiser/autodoc.ss | 97 ++++++++-------------------- 4 files changed, 149 insertions(+), 208 deletions(-) (limited to 'scheme') diff --git a/elisp/geiser-autodoc.el b/elisp/geiser-autodoc.el index 1225f87..16ca9ac 100644 --- a/elisp/geiser-autodoc.el +++ b/elisp/geiser-autodoc.el @@ -46,14 +46,6 @@ 'font-lock-function-name-face geiser-autodoc "highlighting procedure name in autodoc messages") -(geiser-custom--defface autodoc-optional-arg-marker - 'font-lock-keyword-face - geiser-autodoc "highlighting #:opt marker in autodoc messages") - -(geiser-custom--defface autodoc-key-arg-marker - 'font-lock-keyword-face - geiser-autodoc "highlighting #:key marker in autodoc messages") - (defcustom geiser-autodoc-delay 0.3 "Delay before autodoc messages are fetched and displayed, in seconds." :type 'number @@ -74,82 +66,92 @@ when `geiser-autodoc-display-module-p' is on." ;;; Procedure arguments: (make-variable-buffer-local - (defvar geiser-autodoc--last nil)) - -(make-variable-buffer-local - (defvar geiser-autodoc--last-result nil)) - -(defun geiser-autodoc--function-args (form) - (if (equal (car geiser-autodoc--last) form) (cdr geiser-autodoc--last) - (when form - (let ((res (geiser-eval--send/result - `(:eval ((:ge autodoc) (quote (:scm ,form)))) - 500))) - (when (and res (listp res)) - (unless (equalp res geiser-autodoc--last-result) - (setq geiser-autodoc--last-result res) - (setq geiser-autodoc--last - (cons form - (geiser-autodoc--str (cdr (assoc 'signature res)) - (or (cdr (assoc 'position res)) 0) - (cdr (assoc 'module res)))))) - (cdr geiser-autodoc--last)))))) - -(defun geiser-autodoc--insert-arg (arg current pos) - (let ((p (point)) - (str (format "%s" (cond ((eq arg 'geiser-rest_marker) ".") - ((eq arg 'geiser-opt_marker) "#:opt") - ((eq arg 'geiser-key_marker) "#:key") - (t arg)))) - (face (cond ((eq 'geiser-opt_marker arg) - 'geiser-font-lock-autodoc-optional-arg-marker) - ((eq 'geiser-key_marker arg) - 'geiser-font-lock-autodoc-key-arg-marker) - ((= current pos) - 'geiser-font-lock-autodoc-current-arg) - (t nil)))) - (insert str) - (when (listp arg) - (save-excursion - (replace-regexp "(quote \\(.*\\))" "'\\1" nil p (point)) - (replace-string "nil" "()" t p (point)))) - (when face (put-text-property p (point) 'face face)))) + (defvar geiser-autodoc--cached-signatures nil)) + +(defun geiser-autodoc--get-signatures (funs) + (when funs + (let ((missing) (cached)) + (if (not geiser-autodoc--cached-signatures) + (setq missing funs) + (dolist (f funs) + (let ((cf (assq f geiser-autodoc--cached-signatures))) + (if cf (push cf cached) + (push f missing))))) + (unless cached + (setq geiser-autodoc--cached-signatures nil)) + (if (not missing) + geiser-autodoc--cached-signatures + (let ((res (geiser-eval--send/result `(:eval ((:ge autodoc) + (quote ,missing))) + 500))) + (when res + (setq geiser-autodoc--cached-signatures (append cached res)))))))) + +(defun geiser-autodoc--insert-args (args current &optional pos) + (dolist (a args) + (let ((p (point))) + (insert (format "%s" a)) + (when (or (and (numberp pos) + (numberp current) + (setq current (1+ current)) + (= (1+ pos) current)) + (and (symbolp current) + (listp a) + (eq current (car a)))) + (put-text-property p (point) 'face 'geiser-font-lock-autodoc-current-arg) + (setq pos nil current nil))) + (insert " ")) + (when args (backward-char)) + current) (defsubst geiser-autodoc--proc-name (proc module) (let ((str (if module (format geiser-autodoc-procedure-name-format module proc) proc))) - (put-text-property 0 (length str) - 'face 'geiser-font-lock-autodoc-procedure-name - str) - str)) - -(defun geiser-autodoc--str (signature pos module) - (when (consp signature) - (let* ((proc (car signature)) - (args (cdr signature)) - (len (if (listp args) (length args) 0)) - (current 1) - (pos (if (> pos len) len pos))) - (if (eq args 'variable) - (geiser-autodoc--proc-name proc module) - (save-current-buffer - (set-buffer (geiser-syntax--font-lock-buffer)) - (erase-buffer) - (insert (format "(%s" (geiser-autodoc--proc-name proc module))) - (dolist (a args) - (insert " ") - (geiser-autodoc--insert-arg a current pos) - (setq current (1+ current))) - (insert ")") - (buffer-string)))))) + (propertize str 'face 'geiser-font-lock-autodoc-procedure-name))) + +(defun geiser-autodoc--str (proc desc signature) + ;; (message "composing %s with desc %s and signature %s" proc desc signature) + (let ((cpos 1) + (pos (second desc)) + (prev (third desc)) + (module (cdr (assoc 'module signature))) + (reqs (cdr (assoc 'required signature))) + (opts (cdr (assoc 'optional signature))) + (keys (cdr (assoc 'key signature)))) + (save-current-buffer + (set-buffer (geiser-syntax--font-lock-buffer)) + (erase-buffer) + (insert (format "(%s " (geiser-autodoc--proc-name proc module))) + (setq cpos + (geiser-autodoc--insert-args reqs cpos (and (not (zerop pos)) pos))) + (when opts + (insert " [") + (setq cpos (geiser-autodoc--insert-args opts cpos pos)) + (when keys + (insert " [") + (geiser-autodoc--insert-args keys prev nil) + (insert "]")) + (insert "]")) + (insert ")") + (buffer-string)))) + +(defun geiser-autodoc--autodoc (path) + (let* ((funs (nreverse (mapcar 'car path))) + (signs (geiser-autodoc--get-signatures funs))) + (when signs + (catch 'signature + (dolist (f funs) + (let ((signature (cdr (assq f signs)))) + (when signature + (throw 'signature (geiser-autodoc--str f (assq f path) signature))))))))) ;;; Autodoc function: (defun geiser-autodoc--eldoc-function () (condition-case e - (geiser-autodoc--function-args (geiser-syntax--get-partial-sexp)) + (geiser-autodoc--autodoc (geiser-syntax--scan-sexps)) (error (format "Autodoc not available (%s)" (error-message-string e))))) diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el index db1c842..475a556 100644 --- a/elisp/geiser-syntax.el +++ b/elisp/geiser-syntax.el @@ -94,6 +94,33 @@ (defsubst geiser-syntax--beginning-of-form () (memq (char-after (point)) '(?\" ?\())) +(defun geiser-syntax--scan-sexp () + (let ((p (point)) + (n -1) + prev + head) + (ignore-errors + (backward-up-list) + (save-excursion + (forward-char) + (skip-syntax-forward "^_w" p) + (when (setq head (symbol-at-point)) + (while (< (point) p) + (setq n (1+ n)) + (setq prev (symbol-at-point)) + (forward-sexp)))) + (if head (list head n prev) 'skip)))) + +(defun geiser-syntax--scan-sexps () + (save-excursion + (goto-char (or (nth 8 (syntax-ppss)) (point))) + (let* ((sap (symbol-at-point)) + (path (and sap `((,sap 0)))) + s) + (while (setq s (geiser-syntax--scan-sexp)) + (when (listp s) (push s path))) + path))) + (defun geiser-syntax--complete-partial-sexp (buffer begin end) (geiser-syntax--with-buffer (erase-buffer) diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm index 3f060e3..d951f1c 100644 --- a/scheme/guile/geiser/doc.scm +++ b/scheme/guile/geiser/doc.scm @@ -37,76 +37,33 @@ #: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 'geiser-opt_marker opt) '()) - ,@(if (not (null? key)) (cons 'geiser-key_maker key) '())))) - (if rest `(,@sgn geiser-rest_marker ,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 + (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) diff --git a/scheme/plt/geiser/autodoc.ss b/scheme/plt/geiser/autodoc.ss index 6607a94..2fe3a83 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) + ,@(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)) @@ -167,44 +160,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 'geiser-opt_marker opt)) - ,@(if (null? keys) keys (cons 'geiser-key_maker keys)) - ,@(if rest (list 'geiser-rest_marker 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) -- cgit v1.2.3 From 18db590dece0f88c3f2bd850a3158bb50605e2c6 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Mon, 17 Aug 2009 16:23:45 +0200 Subject: Well, i said that it was better, not that it was perfect. Autodoc buglets and support for displaying module variables too. --- elisp/geiser-autodoc.el | 54 ++++++++++++++++++++++---------------------- elisp/geiser-doc.el | 5 +++- elisp/geiser-syntax.el | 20 ++++++++-------- scheme/guile/geiser/doc.scm | 16 ++++++++----- scheme/plt/geiser/autodoc.ss | 6 ++--- 5 files changed, 54 insertions(+), 47 deletions(-) (limited to 'scheme') diff --git a/elisp/geiser-autodoc.el b/elisp/geiser-autodoc.el index 16ca9ac..1d876dd 100644 --- a/elisp/geiser-autodoc.el +++ b/elisp/geiser-autodoc.el @@ -79,8 +79,7 @@ when `geiser-autodoc-display-module-p' is on." (push f missing))))) (unless cached (setq geiser-autodoc--cached-signatures nil)) - (if (not missing) - geiser-autodoc--cached-signatures + (if (not missing) geiser-autodoc--cached-signatures (let ((res (geiser-eval--send/result `(:eval ((:ge autodoc) (quote ,missing))) 500))) @@ -111,33 +110,34 @@ when `geiser-autodoc-display-module-p' is on." (propertize str 'face 'geiser-font-lock-autodoc-procedure-name))) (defun geiser-autodoc--str (proc desc signature) - ;; (message "composing %s with desc %s and signature %s" proc desc signature) - (let ((cpos 1) - (pos (second desc)) - (prev (third desc)) - (module (cdr (assoc 'module signature))) - (reqs (cdr (assoc 'required signature))) - (opts (cdr (assoc 'optional signature))) - (keys (cdr (assoc 'key signature)))) - (save-current-buffer - (set-buffer (geiser-syntax--font-lock-buffer)) - (erase-buffer) - (insert (format "(%s " (geiser-autodoc--proc-name proc module))) - (setq cpos - (geiser-autodoc--insert-args reqs cpos (and (not (zerop pos)) pos))) - (when opts - (insert " [") - (setq cpos (geiser-autodoc--insert-args opts cpos pos)) - (when keys - (insert " [") - (geiser-autodoc--insert-args keys prev nil) - (insert "]")) - (insert "]")) - (insert ")") - (buffer-string)))) + (let ((args (cdr (assoc 'args signature))) + (module (cdr (assoc 'module signature)))) + (if (not args) (geiser-autodoc--proc-name proc module) + (let ((cpos 1) + (pos (or (second desc) 0)) + (prev (third desc)) + (reqs (cdr (assoc 'required args))) + (opts (cdr (assoc 'optional args))) + (keys (cdr (assoc 'key args)))) + (save-current-buffer + (set-buffer (geiser-syntax--font-lock-buffer)) + (erase-buffer) + (insert (format "(%s " (geiser-autodoc--proc-name proc module))) + (setq cpos + (geiser-autodoc--insert-args reqs cpos (and (not (zerop pos)) pos))) + (when opts + (insert " [") + (setq cpos (geiser-autodoc--insert-args opts cpos pos)) + (when keys + (insert " [") + (geiser-autodoc--insert-args keys prev nil) + (insert "]")) + (insert "]")) + (insert ")") + (buffer-string)))))) (defun geiser-autodoc--autodoc (path) - (let* ((funs (nreverse (mapcar 'car path))) + (let* ((funs (mapcar 'car path)) (signs (geiser-autodoc--get-signatures funs))) (when signs (catch 'signature diff --git a/elisp/geiser-doc.el b/elisp/geiser-doc.el index adef4c6..61c50f5 100644 --- a/elisp/geiser-doc.el +++ b/elisp/geiser-doc.el @@ -26,6 +26,7 @@ (require 'geiser-impl) (require 'geiser-completion) +(require 'geiser-autodoc) (require 'geiser-eval) (require 'geiser-syntax) (require 'geiser-popup) @@ -174,7 +175,9 @@ (message "No documentation available for '%s'" symbol) (geiser-doc--with-buffer (erase-buffer) - (geiser-doc--insert-title (cdr (assoc 'signature ds))) + (geiser-doc--insert-title (geiser-autodoc--str (format "%s" symbol) + nil + (cdr (assoc 'signature ds)))) (newline) (insert (or (cdr (assoc 'docstring ds)) "")) (goto-line (point-min)) diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el index 475a556..6cadf61 100644 --- a/elisp/geiser-syntax.el +++ b/elisp/geiser-syntax.el @@ -97,29 +97,31 @@ (defun geiser-syntax--scan-sexp () (let ((p (point)) (n -1) - prev - head) + prev head) (ignore-errors (backward-up-list) (save-excursion (forward-char) - (skip-syntax-forward "^_w" p) + (skip-syntax-forward "^_w(" p) (when (setq head (symbol-at-point)) (while (< (point) p) (setq n (1+ n)) (setq prev (symbol-at-point)) (forward-sexp)))) - (if head (list head n prev) 'skip)))) + (if head (list head n (and (> n 1) prev)) 'skip)))) (defun geiser-syntax--scan-sexps () (save-excursion (goto-char (or (nth 8 (syntax-ppss)) (point))) (let* ((sap (symbol-at-point)) - (path (and sap `((,sap 0)))) - s) - (while (setq s (geiser-syntax--scan-sexp)) - (when (listp s) (push s path))) - path))) + (fst (and sap (geiser-syntax--scan-sexp))) + (path (and fst + (cond ((not (listp fst)) `((,sap 0))) + ((eq sap (car fst)) (list fst)) + (t (list fst (list sap 0))))))) + (while (setq fst (geiser-syntax--scan-sexp)) + (when (listp fst) (push fst path))) + (nreverse path)))) (defun geiser-syntax--complete-partial-sexp (buffer begin end) (geiser-syntax--with-buffer diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm index d951f1c..bc4acd9 100644 --- a/scheme/guile/geiser/doc.scm +++ b/scheme/guile/geiser/doc.scm @@ -37,6 +37,8 @@ #:use-module (oop goops) #:use-module (srfi srfi-1)) +(define *an-object* #t) + (define (autodoc ids) (if (not (list? ids)) '() @@ -59,17 +61,19 @@ ((list? args) args) (else (list args))))) `(,id - (required ,@(arglst 'required)) - (optional ,@(arglst 'optional) - ,@(let ((rest (assq-ref args 'rest))) - (if rest (list "...") '()))) - (key ,@(arglst 'keyword)))) + (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/plt/geiser/autodoc.ss b/scheme/plt/geiser/autodoc.ss index 2fe3a83..c43f8c9 100644 --- a/scheme/plt/geiser/autodoc.ss +++ b/scheme/plt/geiser/autodoc.ss @@ -46,7 +46,7 @@ (and sgn `(,id (name . ,name) - ,@(format-signature sgn) + (args ,@(format-signature sgn)) (module . ,(module-path-name->name path))))))) (define (format-signature sign) @@ -64,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))))) -- cgit v1.2.3 From 203c989e07b43afb34f2c795cbda8126e9c0d327 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Mon, 17 Aug 2009 16:26:38 +0200 Subject: Leftover removed. --- scheme/guile/geiser/doc.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'scheme') diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm index bc4acd9..52f5625 100644 --- a/scheme/guile/geiser/doc.scm +++ b/scheme/guile/geiser/doc.scm @@ -37,8 +37,6 @@ #:use-module (oop goops) #:use-module (srfi srfi-1)) -(define *an-object* #t) - (define (autodoc ids) (if (not (list? ids)) '() -- cgit v1.2.3 From 5a7373cd2da209e8a58b35060c0b29bd18398957 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Tue, 18 Aug 2009 06:16:57 +0200 Subject: Yet another deklugdification: locals scanning moved to elisp. ... and say goodbye to the ugly parse partial sexp, reducing not only sloppy code, but also duplication and data transfers. --- elisp/geiser-completion.el | 5 +- elisp/geiser-syntax.el | 101 +++++++++++++++++++------------------ scheme/guile/geiser/completion.scm | 25 ++------- scheme/plt/geiser/completions.ss | 27 ++-------- 4 files changed, 62 insertions(+), 96 deletions(-) (limited to 'scheme') diff --git a/elisp/geiser-completion.el b/elisp/geiser-completion.el index 799280e..28aef12 100644 --- a/elisp/geiser-completion.el +++ b/elisp/geiser-completion.el @@ -148,9 +148,8 @@ terminates a current completion." (defsubst geiser-completion--symbol-list (prefix) (delete-duplicates - (geiser-eval--send/result - `(:eval ((:ge completions) ,prefix - (quote (:scm ,(or (geiser-syntax--get-partial-sexp) "()")))))) + (append (mapcar (lambda (s) (format "%s" s)) (geiser-syntax--locals-around-point)) + (geiser-eval--send/result `(:eval ((:ge completions) ,prefix)))) :test 'string=)) (defsubst geiser-completion--module-list (prefix) diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el index 6cadf61..6af04a1 100644 --- a/elisp/geiser-syntax.el +++ b/elisp/geiser-syntax.el @@ -84,15 +84,11 @@ (geiser-popup--define syntax " *geiser syntax analyst*" scheme-mode) -(defsubst geiser-syntax--del-sexp (arg) - (let ((p (point))) - (forward-sexp arg) - (delete-region p (point)))) +(defsubst geiser-syntax--skip-comment/string () + (goto-char (or (nth 8 (syntax-ppss)) (point)))) -(defconst geiser-syntax--placeholder (format "___%s___" (random 100))) - -(defsubst geiser-syntax--beginning-of-form () - (memq (char-after (point)) '(?\" ?\())) +(defsubst geiser-syntax--nesting-level () + (or (nth 0 (syntax-ppss)) 0)) (defun geiser-syntax--scan-sexp () (let ((p (point)) @@ -112,7 +108,7 @@ (defun geiser-syntax--scan-sexps () (save-excursion - (goto-char (or (nth 8 (syntax-ppss)) (point))) + (geiser-syntax--skip-comment/string) (let* ((sap (symbol-at-point)) (fst (and sap (geiser-syntax--scan-sexp))) (path (and fst @@ -123,46 +119,55 @@ (when (listp fst) (push fst path))) (nreverse path)))) -(defun geiser-syntax--complete-partial-sexp (buffer begin end) - (geiser-syntax--with-buffer - (erase-buffer) - (insert-buffer-substring-no-properties buffer begin end) - (when (not (geiser-syntax--beginning-of-form)) - (skip-syntax-backward "-<>") - (delete-region (point) (point-max))) - (let ((p (nth 8 (syntax-ppss)))) - (when p ;; inside a comment or string - (delete-region p (point-max)) - (insert geiser-syntax--placeholder))) - (when (cond ((eq (char-after (1- (point))) ?\)) - (geiser-syntax--del-sexp -1) t) - ((geiser-syntax--beginning-of-form) - (delete-region (point) (point-max)) t) - ((memq (char-after (1- (point))) (list ?. ?@ ?, ?\' ?\` ?\# ?\\)) - (skip-syntax-backward "^-(") - (delete-region (point) (point-max)) - t)) - (insert geiser-syntax--placeholder)) +(defun geiser-syntax--read-list (p) + (let ((list (ignore-errors (read (current-buffer))))) + (if (and list (< (point) p)) + list + (goto-char p) + nil))) + +(defconst geiser-syntax--delim-regexp "\\(?:[\s-\s<\s>$\n]+\\)") + +(defconst geiser-syntax--ident-regexp + (format "\\(?:%s\\([^ (]+?\\)\\)" geiser-syntax--delim-regexp)) + +(defconst geiser-syntax--let-regexp + (format "\\=(let\\(?:\\*\\|rec\\|%s\\|%s\\)%s*(" + geiser-syntax--ident-regexp + geiser-syntax--delim-regexp + geiser-syntax--delim-regexp)) + +(defconst geiser-syntax--ldefine-regexp + (format "\\=(define%s%s" geiser-syntax--ident-regexp geiser-syntax--delim-regexp)) + +(defconst geiser-syntax--define-regexp + (format "\\=(\\(?:define\\|lambda\\)%s(" geiser-syntax--delim-regexp)) + +(defun geiser-syntax--locals-around-point () + (when (eq major-mode 'scheme-mode) (save-excursion - (goto-char (point-min)) - (while (re-search-forward "[.@,'`#\\\\]" nil t) - (replace-match "" nil nil)) - (goto-char (point-min)) - (while (re-search-forward "\\[" nil t) - (replace-match "(" nil nil)) - (goto-char (point-min)) - (while (re-search-forward "\\]" nil t) - (replace-match ")" nil nil))) - (let ((depth (nth 0 (parse-partial-sexp (point-min) (point))))) - (unless (zerop depth) (insert (make-string depth ?\))))) - (when (< (point-min) (point)) (buffer-substring (point-min) (point))))) - -(defsubst geiser-syntax--get-partial-sexp () - (unless (zerop (nth 0 (syntax-ppss))) - (let* ((end (if (geiser-syntax--beginning-of-form) (1+ (point)) - (save-excursion (skip-syntax-forward "^-\"<>()") (point)))) - (begin (save-excursion (beginning-of-defun) (point)))) - (geiser-syntax--complete-partial-sexp (current-buffer) begin end)))) + (geiser-syntax--skip-comment/string) + (let ((ids)) + (while (not (zerop (geiser-syntax--nesting-level))) + (let ((p (point))) + (backward-up-list) + (save-excursion + (while (< (point) p) + (cond ((re-search-forward geiser-syntax--let-regexp p t) + (when (match-string 1) (push (intern (match-string 1)) ids)) + (backward-char 1) + (dolist (l (nreverse (geiser-syntax--read-list p))) + (when (and (listp l) (symbolp (car l))) + (push (car l) ids)))) + ((re-search-forward geiser-syntax--ldefine-regexp p t) + (when (match-string 1) (push (intern (match-string 1)) ids))) + ((re-search-forward geiser-syntax--define-regexp p t) + (backward-char 1) + (dolist (s (nreverse (geiser-syntax--read-list p))) + (let ((sn (if (listp s) (car s) s))) + (when (symbolp sn) (push sn ids))))) + (t (goto-char (1+ p)))))))) + (nreverse ids))))) ;;; Fontify strings as Scheme code: 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 (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)) stringstring (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)) -- cgit v1.2.3 From c5b6f124e8197c4e20278fb3f24086ee56f0e529 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Sun, 23 Aug 2009 02:58:13 +0200 Subject: Autotoolification. --- .gitignore | 11 ++++++ AUTHORS | 0 INSTALL | 0 Makefile.am | 1 + NEWS | 0 configure.ac | 33 ++++++++++++++++ elisp/Makefile.am | 31 +++++++++++++++ elisp/geiser-install.el.in | 5 +++ elisp/geiser-reload.el | 96 ++++++++++++++++++++++++++++++++++++++++++++++ elisp/geiser-version.el.in | 12 ++++++ elisp/geiser.el | 77 ++++--------------------------------- scheme/Makefile.am | 16 ++++++++ 12 files changed, 213 insertions(+), 69 deletions(-) create mode 100644 AUTHORS create mode 100644 INSTALL create mode 100644 Makefile.am create mode 100644 NEWS create mode 100644 configure.ac create mode 100644 elisp/Makefile.am create mode 100644 elisp/geiser-install.el.in create mode 100644 elisp/geiser-reload.el create mode 100644 elisp/geiser-version.el.in create mode 100644 scheme/Makefile.am (limited to 'scheme') diff --git a/.gitignore b/.gitignore index 106f9fe..c1eb482 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,14 @@ /scheme/guile/geiser/eval.go /scheme/guile/geiser/introspection.go /scheme/guile/geiser/file.go +/Makefile +/Makefile.in +/aclocal.m4 +/configure +/elisp-comp +/elisp/Makefile.in +/install-sh +/missing +/scheme/Makefile.in +/scheme/guile/Makefile.in +/scheme/guile/geiser/Makefile.in diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..e69de29 diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..e69de29 diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..c1d4ac4 --- /dev/null +++ b/Makefile.am @@ -0,0 +1 @@ +SUBDIRS = elisp scheme diff --git a/NEWS b/NEWS new file mode 100644 index 0000000..e69de29 diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000..f8ed7ec --- /dev/null +++ b/configure.ac @@ -0,0 +1,33 @@ +# Copyright (C) 2009 Free Software Foundation, Inc. +# +# This file is free software; as a special exception the author gives +# unlimited permission to copy and/or distribute it, with or without +# modifications, as long as this notice is preserved. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY, to the extent permitted by law; without even the +# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +AC_INIT([GNU Geiser],[0.0.7],[jao@gnu.org],geiser) +AC_CONFIG_SRCDIR([elisp/geiser.el]) +AM_INIT_AUTOMAKE + +AC_PROG_MAKE_SET +AC_PROG_INSTALL +AC_PROG_MKDIR_P +AC_CHECK_PROG(MAKEINFO, makeinfo, makeinfo, no) +AC_CHECK_PROG(TEXI2PDF, texi2pdf, texi2pdf, false) + +AM_PATH_LISPDIR + +dnl scheme/plt/Makefile +dnl scheme/plt/geiser/Makefile + +AC_CONFIG_FILES([ +Makefile +elisp/Makefile +elisp/geiser-version.el +scheme/Makefile +]) + +AC_OUTPUT diff --git a/elisp/Makefile.am b/elisp/Makefile.am new file mode 100644 index 0000000..790a033 --- /dev/null +++ b/elisp/Makefile.am @@ -0,0 +1,31 @@ +EXTRA_DIST = geiser-install.el.in + +dist_lisp_LISP = \ + geiser-autodoc.el \ + geiser-base.el \ + geiser-compile.el \ + geiser-completion.el \ + geiser-connection.el \ + geiser-custom.el \ + geiser-debug.el \ + geiser-doc.el \ + geiser-edit.el \ + geiser.el \ + geiser-eval.el \ + geiser-guile.el \ + geiser-impl.el \ + geiser-log.el \ + geiser-mode.el \ + geiser-plt.el \ + geiser-popup.el \ + geiser-reload.el \ + geiser-repl.el \ + geiser-syntax.el \ + geiser-xref.el \ + geiser-version.el + +lisp_LISP = geiser-install.el + +geiser-install.el: $(srcdir)/geiser.el $(srcdir)/geiser-install.el.in + @sed -e "s|@SCHEME_DIR[@]|$(datarootdir)/geiser|" $(srcdir)/geiser-install.el.in >$@ + diff --git a/elisp/geiser-install.el.in b/elisp/geiser-install.el.in new file mode 100644 index 0000000..da9f28f --- /dev/null +++ b/elisp/geiser-install.el.in @@ -0,0 +1,5 @@ +(require 'geiser) + +(setq geiser-scheme-dir "@SCHEME_DIR@") + +(provide 'geiser-install) diff --git a/elisp/geiser-reload.el b/elisp/geiser-reload.el new file mode 100644 index 0000000..f592164 --- /dev/null +++ b/elisp/geiser-reload.el @@ -0,0 +1,96 @@ +;; geiser-reload.el -- unload/load geiser packages + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz +;; Start date: Sat Aug 22, 2009 23:04 + +;; 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: + +(require 'geiser-impl) +(require 'geiser-repl) +(require 'geiser-mode) + + +;;; Reload: + +(defmacro geiser--features-list () + (quote '( + geiser-mode + geiser-repl + geiser-xref + geiser-edit + geiser-doc + geiser-debug + geiser-impl + geiser-completion + geiser-autodoc + geiser-compile + geiser-eval + geiser-connection + geiser-syntax + geiser-log + geiser-custom + geiser-base + geiser-popup + geiser + geiser-version + ))) + +(defun geiser-reload-unload-function () + (dolist (feature (geiser--features-list)) + (when (featurep feature) (unload-feature feature t))) + t) + +(defun geiser-unload () + (interactive) + (unload-feature 'geiser-reload)) + +(defun geiser-reload (&optional arg) + "Reload Geiser. +With prefix arg, prompts for the DIRECTORY from which Geiser should be +loaded." + (interactive "P") + (let* ((old-dir geiser-elisp-dir) + (dir (or (and arg (read-directory-name "New Geiser elisp dir: " + old-dir old-dir t old-dir)) + old-dir)) + (gf (expand-file-name "geiser.el" dir)) + (gfi (expand-file-name "geiser-install.el" dir))) + (unless (or (file-exists-p gfi) + (file-exists-p gf)) + (error "%s does not contain Geiser!" dir)) + (let ((installed-impls geiser-impl-installed-implementations) + (impls geiser-impl--impls) + (repls (geiser-repl--repl-list)) + (buffers (geiser-mode--buffers))) + (setq load-path (remove geiser-elisp-dir load-path)) + (geiser-unload) + (add-to-list 'load-path dir) + (setq geiser-impl-installed-implementations installed-impls) + (if (file-exists-p gfi) + (require 'geiser-install) + (load-file gf)) + (dolist (feature (geiser--features-list)) + (load-library (format "%s" feature))) + (geiser-impl--reload-implementations impls) + (geiser-repl--restore repls) + (geiser-mode--restore buffers) + (message "Geiser reloaded!")))) + + +(provide 'geiser-reload) +;;; geiser-reload.el ends here diff --git a/elisp/geiser-version.el.in b/elisp/geiser-version.el.in new file mode 100644 index 0000000..5b1258b --- /dev/null +++ b/elisp/geiser-version.el.in @@ -0,0 +1,12 @@ + +;;; Versioning: + +(defvar geiser-version-string "@PACKAGE_STRING@" + "Geiser's version as a string.") + +(defun geiser-version () + "Echoes Geiser's version." + (interactive) + (message "%s" geiser-version-string)) + +(provide 'geiser-version) diff --git a/elisp/geiser.el b/elisp/geiser.el index 1cc3c51..64d4efb 100644 --- a/elisp/geiser.el +++ b/elisp/geiser.el @@ -27,9 +27,6 @@ ;;; Locations: -(defvar geiser-root-dir nil - "Geiser's root directory.") - (defvar geiser-elisp-dir nil "Directory containing Geiser's Elisp files.") @@ -37,14 +34,19 @@ "Directory containing Geiser's Scheme files.") (setq geiser-elisp-dir (file-name-directory load-file-name)) -(setq geiser-scheme-dir (expand-file-name "../scheme/" geiser-elisp-dir)) -(setq geiser-root-dir (expand-file-name "../" geiser-elisp-dir)) - (add-to-list 'load-path geiser-elisp-dir) +(setq geiser-scheme-dir (expand-file-name "../scheme/" geiser-elisp-dir)) + ;;; Autoloads: +(autoload 'geiser-version "geiser-version.el" "Echo Geiser's version." t) + +(autoload 'geiser-unload "geiser-reload.el" "Unload all Geiser code." t) + +(autoload 'geiser-reload "geiser-reload.el" "Reload Geiser code." t) + (autoload 'geiser "geiser-repl.el" "Start a Geiser REPL, or switch to a running one." t) @@ -95,68 +97,5 @@ (eval-after-load "scheme" '(add-hook 'scheme-mode-hook 'turn-on-geiser-mode)) - -;;; Reload: - -(defmacro geiser--features-list () - (quote '( - geiser-mode - geiser-repl - geiser-xref - geiser-edit - geiser-doc - geiser-debug - geiser-impl - geiser-completion - geiser-autodoc - geiser-compile - geiser-eval - geiser-connection - geiser-syntax - geiser-log - geiser-custom - geiser-base - geiser-popup - ))) - -(defun geiser-unload-function () - (dolist (feature (geiser--features-list)) - (when (featurep feature) (unload-feature feature t))) - t) - -(defun geiser-unload () - (interactive) - (when (featurep 'geiser) (unload-feature 'geiser))) - -(defun geiser-reload (&optional arg) - "Reload Geiser. -With prefix arg, prompts for the DIRECTORY in which Geiser should be -loaded." - (interactive "P") - (let* ((dir (or (and arg (read-directory-name "New Geiser root dir: " - geiser-root-dir - geiser-root-dir - t - geiser-root-dir)) - geiser-root-dir)) - (geiser-main-file (expand-file-name "elisp/geiser.el" dir)) - (installed-impls geiser-impl-installed-implementations) - (impls (and (featurep 'geiser-impl) geiser-impl--impls)) - (repls (and (featurep 'geiser-repl) (geiser-repl--repl-list))) - (buffers (and (featurep 'geiser-mode) (geiser-mode--buffers)))) - (unless (file-exists-p geiser-main-file) - (error "%s does not contain Geiser!" dir)) - (geiser-unload) - (setq load-path (remove geiser-elisp-dir load-path)) - (setq geiser-impl-installed-implementations installed-impls) - (load-file geiser-main-file) - (dolist (feature (geiser--features-list)) - (load-library (format "%s" feature))) - (geiser-impl--reload-implementations impls) - (geiser-repl--restore repls) - (geiser-mode--restore buffers) - (message "Geiser reloaded!"))) - (provide 'geiser) -;;; geiser.el ends here 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 -- cgit v1.2.3