diff options
author | Jose Antonio Ortega Ruiz <jao@gnu.org> | 2009-09-07 00:23:17 +0200 |
---|---|---|
committer | Jose Antonio Ortega Ruiz <jao@gnu.org> | 2009-09-07 00:23:17 +0200 |
commit | 8f5e58189692663901266dc83f2e2b4e47803b8d (patch) | |
tree | af04cbe37abec51cbf4106f06a497445904dc7a6 /elisp | |
parent | 61edb258a45d5ad00ee907594c6dfbcd21d93485 (diff) | |
parent | 3a80af06f2b9272db379fed3b5b659ecfeeceb70 (diff) | |
download | geiser-guile-8f5e58189692663901266dc83f2e2b4e47803b8d.tar.gz geiser-guile-8f5e58189692663901266dc83f2e2b4e47803b8d.tar.bz2 |
Merge branch 'devel'
Diffstat (limited to 'elisp')
-rw-r--r-- | elisp/Makefile.am | 34 | ||||
-rw-r--r-- | elisp/geiser-autodoc.el | 146 | ||||
-rw-r--r-- | elisp/geiser-base.el | 21 | ||||
-rw-r--r-- | elisp/geiser-company.el | 121 | ||||
-rw-r--r-- | elisp/geiser-completion.el | 19 | ||||
-rw-r--r-- | elisp/geiser-connection.el | 12 | ||||
-rw-r--r-- | elisp/geiser-debug.el | 63 | ||||
-rw-r--r-- | elisp/geiser-doc.el | 31 | ||||
-rw-r--r-- | elisp/geiser-edit.el | 73 | ||||
-rw-r--r-- | elisp/geiser-eval.el | 50 | ||||
-rw-r--r-- | elisp/geiser-guile.el | 41 | ||||
-rw-r--r-- | elisp/geiser-impl.el | 138 | ||||
-rw-r--r-- | elisp/geiser-install.el.in | 5 | ||||
-rw-r--r-- | elisp/geiser-log.el | 2 | ||||
-rw-r--r-- | elisp/geiser-mode.el | 11 | ||||
-rw-r--r-- | elisp/geiser-plt.el | 42 | ||||
-rw-r--r-- | elisp/geiser-reload.el | 95 | ||||
-rw-r--r-- | elisp/geiser-repl.el | 36 | ||||
-rw-r--r-- | elisp/geiser-syntax.el | 242 | ||||
-rw-r--r-- | elisp/geiser-version.el.in | 12 | ||||
-rw-r--r-- | elisp/geiser.el | 105 |
21 files changed, 898 insertions, 401 deletions
diff --git a/elisp/Makefile.am b/elisp/Makefile.am new file mode 100644 index 0000000..9f93e64 --- /dev/null +++ b/elisp/Makefile.am @@ -0,0 +1,34 @@ +EXTRA_DIST = geiser-install.el.in + +dist_lisp_LISP = \ + geiser-autodoc.el \ + geiser-base.el \ + geiser-company.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 + +CLEANFILES = 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-autodoc.el b/elisp/geiser-autodoc.el index f6d36a8..75f2e7c 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,79 +66,107 @@ 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" (if (eq arg '\#:rest) "." arg))) - (face (cond ((eq '\#:opt arg) - 'geiser-font-lock-autodoc-optional-arg-marker) - ((eq '\#:key 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 &optional keep-cached) + (when funs + (let ((fs (assq (car funs) geiser-autodoc--cached-signatures))) + (unless fs + (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 (or cached keep-cached) + (setq geiser-autodoc--cached-signatures nil)) + (when missing + (let ((res (geiser-eval--send/result `(:eval ((:ge autodoc) + (quote ,missing))) + 500))) + (when res + (setq geiser-autodoc--cached-signatures + (append res (if keep-cached + geiser-autodoc--cached-signatures + cached)))))))) + geiser-autodoc--cached-signatures))) + +(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) + (propertize str 'face 'geiser-font-lock-autodoc-procedure-name))) + +(defun geiser-autodoc--str (desc signature) + (let ((proc (car desc)) + (args (cdr (assoc 'args signature))) + (module (cdr (assoc 'module signature)))) + (if (not args) (geiser-autodoc--proc-name proc module) + (let ((cpos 1) + (pos (or (cadr desc) 0)) + (prev (caddr 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))) - (dolist (a args) + (when reqs (insert " ") - (geiser-autodoc--insert-arg a current pos) - (setq current (1+ current))) + (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 &optional keep-cached) + (let ((signs (geiser-autodoc--get-signatures (mapcar 'car path) keep-cached)) + (p (car path)) + (s)) + (while (and path (not s)) + (unless (setq s (cdr (assq (car p) signs))) + (setq p (car path)) + (setq path (cdr path)))) + (when s (geiser-autodoc--str p s)))) + ;;; Autodoc function: +(make-variable-buffer-local + (defvar geiser-autodoc--inhibit-flag nil)) + (defun geiser-autodoc--eldoc-function () (condition-case e - (geiser-autodoc--function-args (geiser-syntax--get-partial-sexp)) + (and (not geiser-autodoc--inhibit-flag) + (geiser-autodoc--autodoc (geiser-syntax--scan-sexps))) (error (format "Autodoc not available (%s)" (error-message-string e))))) diff --git a/elisp/geiser-base.el b/elisp/geiser-base.el index 362930d..fca955a 100644 --- a/elisp/geiser-base.el +++ b/elisp/geiser-base.el @@ -25,26 +25,10 @@ ;;; Code: - -;;; Versioning: - -(defconst geiser-version-major 0 - "Geiser's major version number.") -(defconst geiser-version-minor 1 - "Geiser's minor version number.") - -(defun geiser-version-string () - "Geiser's version as a string." - (format "%s.%s" geiser-version-major geiser-version-minor)) - -(defun geiser-version () - "Echoes Geiser's version." - (interactive) - (message "Geiser %s" (geiser-version-string))) - - ;;; Emacs compatibility: +(require 'cl) + (eval-after-load "ring" '(when (not (fboundp 'ring-member)) (defun ring-member (ring item) @@ -55,7 +39,6 @@ (when (not (fboundp 'completion-table-dynamic)) (defun completion-table-dynamic (fun) - (require 'cl) (lexical-let ((fun fun)) (lambda (string pred action) (with-current-buffer (let ((win (minibuffer-selected-window))) diff --git a/elisp/geiser-company.el b/elisp/geiser-company.el new file mode 100644 index 0000000..37c2196 --- /dev/null +++ b/elisp/geiser-company.el @@ -0,0 +1,121 @@ +;; geiser-company.el -- integration with company-mode + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; Start date: Mon Aug 24, 2009 12:44 + +;; 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 <http://www.gnu.org/licenses/>. + +;;; Code: + +(require 'geiser-autodoc) +(require 'geiser-completion) +(require 'geiser-edit) +(require 'geiser-base) + + +;;; Helpers: + +(make-variable-buffer-local + (defvar geiser-company--enabled-flag nil)) + +(make-variable-buffer-local + (defvar geiser-company--autodoc-flag nil)) + +(defsubst geiser-company--candidates (prefix module) + (car (geiser-completion--complete prefix module))) + +(defsubst geiser-company--doc (id module) + (ignore-errors + (if module + (format "%s [module]" id) + (or (geiser-autodoc--autodoc (list (list (intern id) 0)) t) + (format "%s [local id]" id))))) + +(defsubst geiser-company--doc-buffer (id module) + nil) + +(defun geiser-company--location (id module) + (ignore-errors + (let ((id (intern id))) + (save-excursion + (if module + (geiser-edit-module id 'noselect) + (geiser-edit-symbol id 'noselect)))))) + +(defun geiser-company--prefix-at-point (module) + (when geiser-company--enabled-flag + (cond ((nth 8 (syntax-ppss)) 'stop) + ((looking-at-p "\\_>") (geiser-completion--prefix module)) + (module 'stop) + (t nil)))) + + +;;; Activation + +(defun geiser-company--setup (enable) + (setq geiser-company--enabled-flag enable) + (when (fboundp 'geiser-company--setup-company) + (geiser-company--setup-company enable))) + +(defun geiser-company--inhibit-autodoc (ignored) + (when (setq geiser-company--autodoc-flag geiser-autodoc-mode) + (geiser-autodoc-mode -1))) + +(defun geiser-company--restore-autodoc (&optional ignored) + (when geiser-company--autodoc-flag + (geiser-autodoc-mode 1))) + + +;;; Backends: +(defmacro geiser-company--make-backend (name mod) + `(defun ,name (command &optional arg &rest ignored) + "A `company-mode' completion back-end for `geiser-mode'." + (interactive (list 'interactive)) + (case command + ('interactive (company-begin-backend ',name)) + ('prefix (geiser-company--prefix-at-point ,mod)) + ('candidates (geiser-company--candidates arg ,mod)) + ('meta (geiser-company--doc arg ,mod)) + ('doc-buffer (geiser-company--doc-buffer arg ,mod)) + ('location (geiser-company--location arg ,mod)) + ('sorted t)))) + +(defvar geiser-company--backend '(company-geiser-ids company-geiser-modules)) + +(eval-after-load "company" + '(progn + (defun geiser-company--setup-company (enable) + (set (make-local-variable 'company-default-lighter) "/C") + (set (make-local-variable 'company-echo-delay) 0.01) + (company-mode nil) + (when enable (company-mode enable))) + (geiser-company--make-backend company-geiser-ids nil) + (geiser-company--make-backend company-geiser-modules t) + (add-to-list 'company-backends geiser-company--backend) + (add-hook 'company-completion-finished-hook 'geiser-company--restore-autodoc) + (add-hook 'company-completion-cancelled-hook 'geiser-company--restore-autodoc) + (add-hook 'company-completion-started-hook 'geiser-company--inhibit-autodoc))) + + +;;; Reload support: + +(defun geiser-company-unload-function () + (when (boundp 'company-backends) + (setq company-backends (remove geiser-company--backend company-backends)))) + + +(provide 'geiser-company) +;;; geiser-company.el ends here diff --git a/elisp/geiser-completion.el b/elisp/geiser-completion.el index 799280e..e3bd74b 100644 --- a/elisp/geiser-completion.el +++ b/elisp/geiser-completion.el @@ -29,7 +29,7 @@ (require 'geiser-syntax) (require 'geiser-base) -(eval-when-compile (require 'cl)) +(require 'cl) ;;; Completions window handling, heavily inspired in slime's: @@ -84,7 +84,7 @@ terminates a current completion." (remove-hook 'pre-command-hook 'geiser-completion--maybe-restore-window-cfg) (condition-case err - (cond ((find last-command-char "()\"'`,# \r\n:") + (cond ((find last-command-event "()\"'`,# \r\n:") (geiser-completion--restore-window-cfg)) ((not (geiser-completion--window-active-p)) (geiser-completion--forget-window-cfg)) @@ -146,11 +146,10 @@ terminates a current completion." ;;; Completion functionality: -(defsubst geiser-completion--symbol-list (prefix) +(defun 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) @@ -205,14 +204,16 @@ terminates a current completion." (funcall geiser-completion--symbol-begin-function module)) (save-excursion (skip-syntax-backward "^-()>") (point)))) +(defsubst geiser-completion--prefix (module) + (buffer-substring-no-properties (point) + (geiser-completion--symbol-begin module))) + (defun geiser-completion--complete-symbol (&optional arg) "Complete the symbol at point. Perform completion similar to Emacs' complete-symbol. With prefix, complete module name." (interactive "P") - (let* ((end (point)) - (beg (geiser-completion--symbol-begin arg)) - (prefix (buffer-substring-no-properties beg end)) + (let* ((prefix (geiser-completion--prefix arg)) (result (geiser-completion--complete prefix arg)) (completions (car result)) (partial (cdr result))) diff --git a/elisp/geiser-connection.el b/elisp/geiser-connection.el index 33579f6..4f8592b 100644 --- a/elisp/geiser-connection.el +++ b/elisp/geiser-connection.el @@ -160,11 +160,15 @@ (defun geiser-con--comint-buffer-form () (with-current-buffer (geiser-con--comint-buffer) - (geiser-syntax--prepare-scheme-for-elisp-reader) (condition-case nil - (let ((form (read (current-buffer)))) - (if (listp form) form (error))) - (error `((error (key . geiser-con-error) (msg . ,(buffer-string)))))))) + (progn + (goto-char (point-min)) + (re-search-forward "((\\(result\\|error\\)\\>") + (goto-char (match-beginning 0)) + (let ((form (read (current-buffer)))) + (if (listp form) form (error)))) + (error `((error (key . geiser-con-error)) + (output . ,(buffer-string))))))) (defun geiser-con--process-next (con) (when (not (geiser-con--connection-current-request con)) diff --git a/elisp/geiser-debug.el b/elisp/geiser-debug.el index 7ebd0b5..6d795df 100644 --- a/elisp/geiser-debug.el +++ b/elisp/geiser-debug.el @@ -25,6 +25,7 @@ ;;; Code: +(require 'geiser-impl) (require 'geiser-eval) (require 'geiser-popup) (require 'geiser-base) @@ -32,15 +33,23 @@ ;;; Debug buffer mode: -(defconst geiser-debug--error-alist - '(("^\\(In file +\\| +\\)\\([^ \n]+\\):\\([0-9]+\\):\\([0-9]+\\)" 2 3 4) - ("^Error.+$" nil nil nil 0))) +(defvar geiser-debug-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (set-keymap-parent map button-buffer-map) + map)) -(define-derived-mode geiser-debug-mode compilation-mode "Geiser Dbg" +(defun geiser-debug-mode () "A major mode for displaying Scheme compilation and evaluation results. \\{geiser-debug-mode-map}" - (set (make-local-variable 'compilation-error-regexp-alist) - geiser-debug--error-alist)) + (interactive) + (kill-all-local-variables) + (buffer-disable-undo) + (use-local-map geiser-debug-mode-map) + (set-syntax-table scheme-mode-syntax-table) + (setq mode-name "Geiser DBG") + (setq major-mode 'geiser-debug-mode) + (setq buffer-read-only t)) ;;; Buffer for displaying evaluation results: @@ -50,42 +59,25 @@ ;;; 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)) - (stack (geiser-eval--retort-stack ret))) + (impl geiser-impl--implementation) + (module (geiser-eval--get-module))) (geiser-debug--with-buffer (erase-buffer) (insert what) (newline 2) - (when err (insert (geiser-eval--error-str err) "\n\n")) - (when output (insert output "\n\n")) - (when stack (geiser-debug--display-stack stack)) + (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"))) (goto-char (point-min))) (when err (geiser-debug--pop-to-buffer)))) -(defsubst geiser-debug--frame-proc (frame) (cdr (assoc 'procedure frame))) -(defsubst geiser-debug--frame-desc (frame) (cdr (assoc 'description frame))) -(defsubst geiser-debug--frame-source (frame) (cdr (assoc 'source frame))) -(defsubst geiser-debug--frame-source-file (src) (car src)) -(defsubst geiser-debug--frame-source-line (src) (or (cadr src) 1)) -(defsubst geiser-debug--frame-source-column (src) (or (caddr src) 0)) - -(defun geiser-debug--display-stack (stack) - (mapc 'geiser-debug--display-stack-frame (reverse (cdr stack)))) - -(defun geiser-debug--display-stack-frame (frame) - (let ((procedure (geiser-debug--frame-proc frame)) - (source (geiser-debug--frame-source frame)) - (description (geiser-debug--frame-desc frame))) - (if source - (insert (format "In file %s:%s:%s\n" - (geiser-debug--frame-source-file source) - (geiser-debug--frame-source-line source) - (1+ (geiser-debug--frame-source-column source)))) - (insert "In expression:\n")) - (insert (format "%s\n" description)))) - (defsubst geiser-debug--wrap-region (str) (format "(begin %s)" str)) @@ -99,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-doc.el b/elisp/geiser-doc.el index 8024239..29f0de2 100644 --- a/elisp/geiser-doc.el +++ b/elisp/geiser-doc.el @@ -24,7 +24,9 @@ ;;; Code: +(require 'geiser-impl) (require 'geiser-completion) +(require 'geiser-autodoc) (require 'geiser-eval) (require 'geiser-syntax) (require 'geiser-popup) @@ -157,32 +159,27 @@ ;;; Commands: -(make-variable-buffer-local - (defvar geiser-doc--external-help-function nil)) - -(defun geiser-doc--external-help (symbol module) - (and geiser-doc--external-help-function - (funcall geiser-doc--external-help-function symbol module))) - (defun geiser-doc--get-docstring (symbol module) - (geiser-eval--send/result `(:eval ((:ge symbol-documentation) ',symbol) ,module))) + (geiser-eval--send/result + `(:eval ((:ge symbol-documentation) ',symbol) ,module))) (defun geiser-doc--get-module-exports (module) (geiser-eval--send/result `(:eval ((:ge module-exports) (:module ,module))))) (defun geiser-doc-symbol (symbol &optional module impl) - (let ((module (or module (geiser-eval--get-module)))) - (unless (geiser-doc--external-help symbol module) - (let ((impl (or impl geiser-impl--implementation)) - (ds (geiser-doc--get-docstring symbol module))) + (let ((module (or module (geiser-eval--get-module))) + (impl (or impl geiser-impl--implementation))) + (unless (geiser-impl--external-help impl symbol module) + (let ((ds (geiser-doc--get-docstring symbol module))) (if (or (not ds) (not (listp ds))) (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 (list (format "%s" symbol) 0) + (cdr (assoc 'signature ds)))) (newline) (insert (or (cdr (assoc 'docstring ds)) "")) - (goto-line (point-min)) + (goto-char (point-min)) (setq geiser-doc--buffer-link (geiser-doc--history-push (geiser-doc--make-link symbol module impl)))) @@ -193,7 +190,8 @@ With prefix argument, ask for symbol (with completion)." (interactive "P") (let ((symbol (or (and (not arg) (symbol-at-point)) - (geiser-completion--read-symbol "Symbol: " (symbol-at-point))))) + (geiser-completion--read-symbol "Symbol: " + (symbol-at-point))))) (when symbol (geiser-doc-symbol symbol)))) @@ -219,7 +217,8 @@ With prefix argument, ask for symbol (with completion)." impl)) (goto-char (point-min)) (setq geiser-doc--buffer-link - (geiser-doc--history-push (geiser-doc--make-link nil module impl)))) + (geiser-doc--history-push + (geiser-doc--make-link nil module impl)))) (geiser-doc--pop-to-buffer)))) (defun geiser-doc-next (&optional forget-current) diff --git a/elisp/geiser-edit.el b/elisp/geiser-edit.el index 986099e..0ec1669 100644 --- a/elisp/geiser-edit.el +++ b/elisp/geiser-edit.el @@ -44,7 +44,11 @@ (geiser-edit--define-custom-visit geiser-edit-symbol-method geiser-mode - "How the new buffer is opened when invoking \\[geiser-edit-symbol-at-point].") + "How the new buffer is opened when invoking \\[geiser-edit-symbol-at-point] +or following links in error buffers.") + +(geiser-custom--defface error-link + 'link geiser-debug "links in error buffers") ;;; Auxiliar functions: @@ -52,6 +56,7 @@ (defun geiser-edit--visit-file (file method) (cond ((eq method 'window) (find-file-other-window file)) ((eq method 'frame) (find-file-other-frame file)) + ((eq method 'noselect) (find-file-noselect file t)) (t (find-file file)))) (defsubst geiser-edit--location-name (loc) @@ -60,8 +65,18 @@ (defsubst geiser-edit--location-file (loc) (cdr (assoc 'file loc))) +(defsubst geiser-edit--to-number (x) + (cond ((numberp x) x) + ((stringp x) (string-to-number x)))) + (defsubst geiser-edit--location-line (loc) - (cdr (assoc 'line loc))) + (geiser-edit--to-number (cdr (assoc 'line loc)))) + +(defsubst geiser-edit--location-column (loc) + (geiser-edit--to-number (cdr (assoc 'column loc)))) + +(defsubst geiser-edit--make-location (name file line column) + `((name . ,name) (file . ,file) (line . ,line) (column . ,column))) (defconst geiser-edit--def-re (regexp-opt '("define" @@ -92,8 +107,9 @@ (format "\\_<%s\\_>" (regexp-quote (format "%s" thing)))) (defun geiser-edit--goto-line (symbol line) + (goto-char (point-min)) (if (numberp line) - (goto-line line) + (forward-line (max 0 (1- line))) (goto-char (point-min)) (when (or (re-search-forward (geiser-edit--def-re symbol) nil t) (re-search-forward (geiser-edit--def-re* symbol) nil t) @@ -103,26 +119,51 @@ (defun geiser-edit--try-edit-location (symbol loc &optional method) (let ((symbol (or (geiser-edit--location-name loc) symbol)) (file (geiser-edit--location-file loc)) - (line (geiser-edit--location-line loc))) + (line (geiser-edit--location-line loc)) + (col (geiser-edit--location-column loc))) (unless file (error "Couldn't find edit location for '%s'" symbol)) (unless (file-readable-p file) (error "Couldn't open '%s' for read" file)) (geiser-edit--visit-file file (or method geiser-edit-symbol-method)) - (geiser-edit--goto-line symbol line))) + (geiser-edit--goto-line symbol line) + (when col + (beginning-of-line) + (forward-char col)) + (cons (current-buffer) (point)))) -(defsubst geiser-edit--try-edit (symbol ret) - (geiser-edit--try-edit-location symbol (geiser-eval--retort-result ret))) +(defsubst geiser-edit--try-edit (symbol ret &optional method) + (geiser-edit--try-edit-location symbol (geiser-eval--retort-result ret) method)) + + +;;; Links + +(define-button-type 'geiser-edit--button + 'action 'geiser-edit--button-action + 'face 'geiser-font-lock-error-link + 'follow-link t) + +(defun geiser-edit--button-action (button) + (let ((loc (button-get button 'geiser-location))) + (when loc (geiser-edit--try-edit-location nil loc)))) + +(defun geiser-edit--make-link (beg end file line col) + (make-button beg end + :type 'geiser-edit--button + 'geiser-location + (geiser-edit--make-location 'error file line col) + 'help-echo "Go to error location")) ;;; Commands: -(defun geiser-edit-symbol () +(defvar geiser-edit--symbol-history nil) + +(defun geiser-edit-symbol (symbol &optional method) "Asks for a symbol to edit, with completion." - (interactive) - (let* ((symbol (geiser-completion--read-symbol "Edit symbol: " - nil - geiser-edit--symbol-history)) - (cmd `(:eval ((:ge symbol-location) ',symbol)))) - (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd)))) + (interactive (list (geiser-completion--read-symbol "Edit symbol: " + nil + geiser-edit--symbol-history))) + (let ((cmd `(:eval ((:ge symbol-location) ',symbol)))) + (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd) method))) (defun geiser-edit-symbol-at-point (&optional arg) "Opens a new window visiting the definition of the symbol at point. @@ -142,11 +183,11 @@ With prefix, asks for the symbol to edit." (pop-tag-mark) (error "No previous location for find symbol invocation"))) -(defun geiser-edit-module (module) +(defun geiser-edit-module (module &optional method) "Asks for a module and opens it in a new buffer." (interactive (list (geiser-completion--read-module))) (let ((cmd `(:eval ((:ge module-location) (:module ,module))))) - (geiser-edit--try-edit module (geiser-eval--send/wait cmd)))) + (geiser-edit--try-edit module (geiser-eval--send/wait cmd) method))) (provide 'geiser-edit) diff --git a/elisp/geiser-eval.el b/elisp/geiser-eval.el index c493092..1c8cbfe 100644 --- a/elisp/geiser-eval.el +++ b/elisp/geiser-eval.el @@ -54,25 +54,6 @@ EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be supported.")) ;;; Code formatting: -(defun geiser-eval--scheme-str (code) - (cond ((null code) "'()") - ((eq code :f) "#f") - ((eq code :t) "#t") - ((listp code) - (cond ((eq (car code) :eval) (geiser-eval--eval (cdr code))) - ((eq (car code) :comp) (geiser-eval--comp (cdr code))) - ((eq (car code) :load-file) - (geiser-eval--load-file (cadr code))) - ((eq (car code) :comp-file) - (geiser-eval--comp-file (cadr code))) - ((eq (car code) :module) (geiser-eval--module (cadr code))) - ((eq (car code) :ge) (geiser-eval--ge (cadr code))) - ((eq (car code) :scm) (cadr code)) - (t (concat "(" - (mapconcat 'geiser-eval--scheme-str code " ") ")")))) - ((symbolp code) (format "%s" code)) - (t (format "%S" code)))) - (defsubst geiser-eval--eval (code) (geiser-eval--scheme-str `(,(geiser-eval--form 'eval) (quote ,(nth 0 code)) @@ -99,6 +80,25 @@ EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be supported.")) (defsubst geiser-eval--ge (proc) (geiser-eval--scheme-str (geiser-eval--form proc))) +(defun geiser-eval--scheme-str (code) + (cond ((null code) "'()") + ((eq code :f) "#f") + ((eq code :t) "#t") + ((listp code) + (cond ((eq (car code) :eval) (geiser-eval--eval (cdr code))) + ((eq (car code) :comp) (geiser-eval--comp (cdr code))) + ((eq (car code) :load-file) + (geiser-eval--load-file (cadr code))) + ((eq (car code) :comp-file) + (geiser-eval--comp-file (cadr code))) + ((eq (car code) :module) (geiser-eval--module (cadr code))) + ((eq (car code) :ge) (geiser-eval--ge (cadr code))) + ((eq (car code) :scm) (cadr code)) + (t (concat "(" + (mapconcat 'geiser-eval--scheme-str code " ") ")")))) + ((symbolp code) (format "%s" code)) + (t (format "%S" code)))) + ;;; Code sending: @@ -145,11 +145,17 @@ 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))) -(defsubst geiser-eval--retort-stack (ret) (cdr (assoc 'stack ret))) (defsubst geiser-eval--error-key (err) (cdr (assoc 'key err))) (defsubst geiser-eval--error-subr (err) (cdr (assoc 'subr err))) @@ -160,7 +166,7 @@ EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be supported.")) (let* ((key (geiser-eval--error-key err)) (key-str (if key (format ": %s" key) ":")) (subr (geiser-eval--error-subr err)) - (subr-str (if subr (format " (%s):" subr) ":")) + (subr-str (if subr (format " (%s):" subr) "")) (msg (geiser-eval--error-msg err)) (msg-str (if msg (format "\n %s" msg) "")) (rest (geiser-eval--error-rest err)) diff --git a/elisp/geiser-guile.el b/elisp/geiser-guile.el index 44a4e9f..ed14e87 100644 --- a/elisp/geiser-guile.el +++ b/elisp/geiser-guile.el @@ -27,6 +27,9 @@ (require 'geiser-syntax) (require 'geiser-custom) (require 'geiser-base) +(require 'geiser-eval) +(require 'geiser-edit) +(require 'geiser) ;;; Customization: @@ -121,6 +124,44 @@ This function uses `geiser-guile-init-file' if it exists." (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: (defun geiser-guile-guess () diff --git a/elisp/geiser-impl.el b/elisp/geiser-impl.el index 6bc4e79..00fa1ef 100644 --- a/elisp/geiser-impl.el +++ b/elisp/geiser-impl.el @@ -27,7 +27,6 @@ (require 'geiser-eval) (require 'geiser-base) -(require 'geiser-doc) (require 'geiser-completion) @@ -47,16 +46,63 @@ :type '(repeat symbol) :group 'geiser-impl) +(defcustom geiser-impl-implementations-alist nil + "A map from regular expressions or directories to implementations. +When opening a new file, its full path will be matched against +each one of the regular expressions or directories in this map in order to +determine its scheme flavour." + :type '(repeat (list (choice (group :tag "Regular expression" + (const regexp) regexp) + (group :tag "Directory" + (const dir) directory)) + symbol)) + :group 'geiser-impl) + + +;;; Auxiliary functions: +(defsubst geiser-impl--sym (imp name) + (intern (format "geiser-%s-%s" imp name))) + +(defsubst geiser-impl--boundp (imp name) + (boundp (geiser-impl--sym imp name))) + +(defsubst geiser-impl--fboundp (imp name) + (fboundp (geiser-impl--sym imp name))) + +(defsubst geiser-impl--impl-feature (impl) + (intern (format "geiser-%s" impl))) + +(defun geiser-impl--value (imp name &optional fun) + (let ((sym (geiser-impl--sym imp name))) + (unless (or (and (not fun) (boundp sym)) + (and fun (fboundp sym))) + (error "Unbound %s '%s' in Geiser Scheme implementation %s" + (if fun "function" "variable") sym imp)) + (if fun (symbol-function sym) (symbol-value sym)))) + +(defsubst geiser-impl--call-if-bound (imp name &rest args) + (when (geiser-impl--fboundp imp name) + (apply (geiser-impl--value imp name t) args))) + ;;; Registering implementations: (defvar geiser-impl--impls nil) +(make-variable-buffer-local + (defvar geiser-impl--implementation nil)) + (defun geiser-impl--register (impl) - (add-to-list 'geiser-impl--impls impl)) + (when (and (not (memq impl geiser-impl--impls)) + (require (geiser-impl--impl-feature impl) nil t)) + (add-to-list 'geiser-impl--impls impl))) (defun geiser-impl--unregister (impl) - (setq geiser-impl--impls (remove impl geiser-impl--impls))) + (setq geiser-impl--impls (remove impl geiser-impl--impls)) + (ignore-errors (unload-feature (geiser-impl--impl-feature impl)))) + +(defun geiser-impl--add-to-alist (kind what impl) + (add-to-list 'geiser-impl-implementations-alist (list (list kind what) impl))) (defvar geiser-impl--default-implementation geiser-impl-default-implementation) @@ -74,9 +120,6 @@ ;;; Installing Scheme implementations: -(make-variable-buffer-local - (defvar geiser-impl--implementation nil)) - (defvar geiser-impl--impl-prompt-history nil) (defun geiser-impl--read-impl (&optional prompt impls non-req) @@ -97,37 +140,12 @@ (geiser-impl--install-vars impl) (geiser-impl--register impl))) -(defsubst geiser-impl--sym (imp name) - (intern (format "geiser-%s-%s" imp name))) - -(defsubst geiser-impl--boundp (imp name) - (boundp (geiser-impl--sym imp name))) - -(defsubst geiser-impl--fboundp (imp name) - (fboundp (geiser-impl--sym imp name))) - -(defun geiser-impl--value (imp name &optional fun) - (let ((sym (geiser-impl--sym imp name))) - (unless (or (and (not fun) (boundp sym)) - (and fun (fboundp sym))) - (error "Unbound %s '%s' in Geiser Scheme implementation %s" - (if fun "function" "variable") sym imp)) - (if fun (symbol-function sym) (symbol-value sym)))) - -(defsubst geiser-impl--call-if-bound (imp name &rest args) - (when (geiser-impl--fboundp imp name) - (apply (geiser-impl--value imp name t) args))) - (defsubst geiser-impl--module-function (impl) (geiser-impl--sym impl "get-module")) (defsubst geiser-impl--geiser-procedure-function (impl) (geiser-impl--sym impl "geiser-procedure")) -(defsubst geiser-impl--external-help-function (impl) - (let ((f (geiser-impl--sym impl "external-help"))) - (and (fboundp f) f))) - (defsubst geiser-impl--symbol-begin (impl) (geiser-impl--sym impl "symbol-begin")) @@ -136,8 +154,6 @@ (geiser-impl--module-function impl)) (setq geiser-eval--geiser-procedure-function (geiser-impl--geiser-procedure-function impl)) - (setq geiser-doc--external-help-function - (geiser-impl--external-help-function impl)) (setq geiser-completion--symbol-begin-function (geiser-impl--symbol-begin impl))) @@ -150,8 +166,6 @@ (geiser-impl--module-function imp)) (geiser-eval--geiser-procedure-function (geiser-impl--geiser-procedure-function imp)) - (geiser-doc--external-help-function - (geiser-impl--external-help-function imp)) (geiser-completion--symbol-begin-function (geiser-impl--symbol-begin imp))) (funcall thunk))) @@ -171,7 +185,8 @@ (geiser-impl--call-if-bound (geiser-impl--default-implementation) "geiser-procedure" proc)) -(set-default 'geiser-eval--geiser-procedure-function 'geiser-impl-geiser-procedure) +(set-default 'geiser-eval--geiser-procedure-function + 'geiser-impl-geiser-procedure) ;;; Access to implementation specific execution parameters: @@ -191,6 +206,12 @@ (defsubst geiser-impl--startup (impl) (geiser-impl--call-if-bound impl "startup")) +(defsubst geiser-impl--external-help (impl symbol module) + (geiser-impl--call-if-bound impl "external-help" symbol module)) + +(defsubst geiser-impl--display-error (impl module key msg) + (geiser-impl--call-if-bound impl "display-error" module key msg)) + ;;; Access to implementation guessing function: @@ -199,22 +220,58 @@ "Set this buffer local variable to specify the Scheme implementation to be used by Geiser.")) +(defun geiser-impl--match-impl (desc bn) + (let ((rx (if (eq (car desc) 'regexp) + (cadr desc) + (format "^%s" (regexp-quote (cadr desc)))))) + (and rx (string-match-p rx bn)))) + (defun geiser-impl--guess () (or geiser-impl--implementation geiser-scheme-implementation (catch 'impl + (let ((bn (buffer-file-name))) + (when bn + (dolist (x geiser-impl-implementations-alist) + (when (geiser-impl--match-impl (car x) bn) + (throw 'impl (cadr x)))))) (dolist (impl geiser-impl--impls) (when (geiser-impl--call-if-bound impl "guess") (throw 'impl impl)))) (geiser-impl--default-implementation))) +;;; User commands + +(defun geiser-register-implementation () + "Register a new Scheme implementation." + (interactive) + (let ((current geiser-impl-installed-implementations) + (impl (geiser-impl--read-impl "New Scheme implementation: " nil t))) + (unless (geiser-impl--register impl) + (error "geiser-%s.el not found in load-path" impl)) + (when (and (not (memq impl current)) + (y-or-n-p "Remember this implementation using customize? ")) + (customize-save-variable + 'geiser-impl-installed-implementations (cons impl current))))) + +(defun geiser-unregister-implementation () + "Unregister an installed Scheme implementation." + (interactive) + (let* ((current geiser-impl-installed-implementations) + (impl (geiser-impl--read-impl "Forget implementation: " current))) + (geiser-impl--unregister impl) + (when (and impl + (y-or-n-p "Forget permanently using customize? ")) + (customize-save-variable + 'geiser-impl-installed-implementations (remove impl current))))) + + ;;; Unload support (defun geiser-impl-unload-function () (dolist (imp (mapcar 'geiser-impl--impl-feature geiser-impl--impls)) - (when (featurep imp) (unload-feature imp))) - t) + (when (featurep imp) (unload-feature imp t)))) (defun geiser-impl--reload-implementations (impls) (dolist (impl impls) @@ -223,8 +280,11 @@ implementation to be used by Geiser.")) ;;; Initialization: -(mapc 'geiser-impl--register geiser-impl-installed-implementations) +(eval-after-load 'geiser-impl + '(mapc 'geiser-impl--register + (or geiser-impl-installed-implementations '(guile plt)))) (provide 'geiser-impl) + ;;; geiser-impl.el ends here 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-log.el b/elisp/geiser-log.el index 68e0fae..27a485a 100644 --- a/elisp/geiser-log.el +++ b/elisp/geiser-log.el @@ -28,6 +28,8 @@ (require 'geiser-popup) (require 'geiser-base) +(require 'comint) + ;;; Customization: diff --git a/elisp/geiser-mode.el b/elisp/geiser-mode.el index e19cb68..fa686ec 100644 --- a/elisp/geiser-mode.el +++ b/elisp/geiser-mode.el @@ -28,6 +28,7 @@ (require 'geiser-doc) (require 'geiser-compile) (require 'geiser-completion) +(require 'geiser-company) (require 'geiser-xref) (require 'geiser-edit) (require 'geiser-autodoc) @@ -52,6 +53,11 @@ :group 'geiser-autodoc :type 'boolean) +(defcustom geiser-mode-company-p t + "Whether to use company-mode for completion, if available." + :group 'geiser-mode + :type 'boolean) + (defcustom geiser-mode-smart-tab-p nil "Whether `geiser-smart-tab-mode' gets enabled by default in Scheme buffers." :group 'geiser-mode @@ -188,6 +194,7 @@ interacting with the Geiser REPL is at your disposal. (when geiser-mode (geiser-impl--set-buffer-implementation)) (setq geiser-autodoc-mode-string "/A") (setq geiser-smart-tab-mode-string "/T") + (geiser-company--setup (and geiser-mode geiser-mode-company-p)) (when geiser-mode-autodoc-p (geiser-autodoc-mode geiser-mode)) (when geiser-mode-smart-tab-p (geiser-smart-tab-mode geiser-mode))) @@ -261,6 +268,10 @@ interacting with the Geiser REPL is at your disposal. (geiser-mode 1) (when (cdr b) (geiser-impl--set-buffer-implementation (cdr b)))))) +(defun geiser-mode-unload-function () + (dolist (b (geiser-mode--buffers)) + (with-current-buffer (car b) (geiser-mode nil)))) + (provide 'geiser-mode) ;;; geiser-mode.el ends here diff --git a/elisp/geiser-plt.el b/elisp/geiser-plt.el index 44312b9..8810250 100644 --- a/elisp/geiser-plt.el +++ b/elisp/geiser-plt.el @@ -24,6 +24,8 @@ ;;; Code: +(require 'geiser-edit) +(require 'geiser-doc) (require 'geiser-eval) (require 'geiser-syntax) (require 'geiser-custom) @@ -109,7 +111,7 @@ This function uses `geiser-plt-init-file' if it exists." :f))) (defun geiser-plt-get-module (&optional module) - (cond ((and (null module) (geiser-plt--explicit-module))) + (cond ((and (null module) (buffer-file-name))) ;; (geiser-plt--explicit-module) ((null module) (geiser-plt--implicit-module)) ((symbolp module) module) ((and (stringp module) (file-name-absolute-p module)) module) @@ -121,13 +123,47 @@ This function uses `geiser-plt-init-file' if it exists." ;;; External help + (defun geiser-plt-external-help (symbol module) (message "Requesting help for '%s'..." symbol) - (geiser-eval--send/wait `(:eval (get-help ',symbol (:module ,module)) geiser/autodoc)) + (geiser-eval--send/wait + `(:eval (get-help ',symbol (:module ,module)) geiser/autodoc)) (minibuffer-message "%s done" (current-message)) t) +;;; Error display + +(defconst geiser-plt--file-rxs '("^\\([^:\n\"]+\\):\\([0-9]+\\):\\([0-9]+\\)" + "path:\"?\\([^>\"\n]+\\)\"?>" + "module: \"\\([^>\"\n]+\\)\"")) + +(defun geiser-plt--find-files (rx) + (save-excursion + (while (re-search-forward rx nil t) + (geiser-edit--make-link (match-beginning 1) + (match-end 1) + (match-string 1) + (match-string 2) + (match-string 3))))) + +(defun geiser-plt-display-error (module key msg) + (when key + (insert "Error: ") + (geiser-doc--insert-button key nil 'plt) + (newline 2)) + (when msg + (let ((p (point))) + (insert msg) + (let ((end (point))) + (goto-char p) + (mapc 'geiser-plt--find-files geiser-plt--file-rxs) + (goto-char end) + (fill-region p end) + (newline)))) + t) + + ;;; Trying to ascertain whether a buffer is mzscheme scheme: (defun geiser-plt-guess () @@ -135,7 +171,7 @@ This function uses `geiser-plt-init-file' if it exists." (goto-char (point-min)) (re-search-forward "#lang " nil t)) (geiser-plt--explicit-module) - (string-equal (file-name-extension (buffer-file-name)) "ss"))) + (string-equal (file-name-extension (or (buffer-file-name) "")) "ss"))) (provide 'geiser-plt) diff --git a/elisp/geiser-reload.el b/elisp/geiser-reload.el new file mode 100644 index 0000000..5a30e1f --- /dev/null +++ b/elisp/geiser-reload.el @@ -0,0 +1,95 @@ +;; geiser-reload.el -- unload/load geiser packages + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; Code: + +(require 'geiser-impl) +(require 'geiser-repl) +(require 'geiser-mode) +(require 'geiser-base) +(require 'geiser) + + +;;; Reload: + +(defmacro geiser--features-list () + (quote '( + geiser-mode + geiser-repl + geiser-xref + geiser-edit + geiser-doc + geiser-debug + geiser-impl + geiser-company + geiser-completion + geiser-autodoc + geiser-compile + geiser-eval + geiser-connection + geiser-syntax + geiser-log + geiser-custom + geiser-base + geiser-popup + geiser-install + geiser + geiser-version + ))) + +(defun geiser-unload () + "Unload all Geiser modules." + (interactive) + (let ((fs (geiser--features-list))) + (unload-feature 'geiser-reload t) + (dolist (f fs) + (when (featurep f) (unload-feature f t))))) + +(defun geiser-reload (&optional arg) + "Reload Geiser. +With prefix arg, prompts for the DIRECTORY from which Geiser should be +loaded again." + (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))) + (unless (or (file-exists-p (expand-file-name "geiser-reload.el" dir)) + (file-exists-p (expand-file-name "geiser-reload.elc" dir))) + (error "%s does not contain Geiser!" dir)) + (let ((installed (featurep 'geiser-install)) + (installed-impls geiser-impl-installed-implementations) + (impls geiser-impl--impls) + (repls (geiser-repl--repl-list)) + (buffers (geiser-mode--buffers))) + (geiser-unload) + (setq load-path (remove old-dir load-path)) + (add-to-list 'load-path dir) + (setq geiser-impl-installed-implementations installed-impls) + (require 'geiser-reload) + (when installed (require 'geiser-install nil t)) + (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-repl.el b/elisp/geiser-repl.el index f4d85dc..4ea1bb7 100644 --- a/elisp/geiser-repl.el +++ b/elisp/geiser-repl.el @@ -24,6 +24,7 @@ ;;; Code: +(require 'geiser-company) (require 'geiser-autodoc) (require 'geiser-edit) (require 'geiser-impl) @@ -70,6 +71,11 @@ implementation name gets appended to it." :type 'boolean :group 'geiser-repl) +(defcustom geiser-repl-company-p t + "Whether to use company-mode for completion, if available." + :group 'geiser-mode + :type 'boolean) + (defcustom geiser-repl-read-only-prompt-p t "Whether the REPL's prompt should be read-only." :type 'boolean @@ -141,8 +147,8 @@ implementation name gets appended to it." (geiser-repl--history-setup) (geiser-con--setup-connection (current-buffer) prompt-rx) (add-to-list 'geiser-repl--repls (current-buffer)) - (geiser-impl--startup impl) - (geiser-repl--set-this-buffer-repl (current-buffer)))) + (geiser-repl--set-this-buffer-repl (current-buffer)) + (geiser-impl--startup impl))) (defun geiser-repl--process () (let ((buffer (geiser-repl--get-repl geiser-impl--implementation))) @@ -152,8 +158,10 @@ implementation name gets appended to it." (setq geiser-eval--default-proc-function 'geiser-repl--process) (defun geiser-repl--wait-for-prompt (timeout) - (let ((p (point)) (seen)) - (while (and (not seen) (> timeout 0)) + (let ((p (point)) (seen) (buffer (current-buffer))) + (while (and (not seen) + (> timeout 0) + (get-buffer-process buffer)) (sleep-for 0.1) (setq timeout (- timeout 100)) (goto-char p) @@ -176,7 +184,8 @@ implementation name gets appended to it." (interactive (list (or (geiser-repl--only-impl-p) (and (eq major-mode 'geiser-repl-mode) geiser-impl--implementation) - (geiser-repl--read-impl "Start Geiser for scheme implementation: ")))) + (geiser-repl--read-impl + "Start Geiser for scheme implementation: ")))) (geiser-repl--start-repl impl)) (defun switch-to-geiser (&optional ask impl) @@ -254,7 +263,8 @@ If no REPL is running, execute `run-geiser' to start a fresh one." (set (make-local-variable 'comint-input-filter) 'geiser-repl--input-filter) (add-hook 'kill-buffer-hook 'geiser-repl--on-kill nil t) (comint-read-input-ring t) - (set-process-sentinel (get-buffer-process (current-buffer)) 'geiser-repl--sentinel)) + (set-process-sentinel (get-buffer-process (current-buffer)) + 'geiser-repl--sentinel)) ;;; geiser-repl mode: @@ -288,18 +298,22 @@ If no REPL is running, execute `run-geiser' to start a fresh one." 'geiser-repl--beginning-of-defun) (set-syntax-table scheme-mode-syntax-table) (setq geiser-eval--get-module-function 'geiser-repl--module-function) - (when geiser-repl-autodoc-p (geiser-autodoc-mode 1))) + (when geiser-repl-autodoc-p (geiser-autodoc-mode 1)) + (geiser-company--setup geiser-repl-company-p) + (compilation-shell-minor-mode 1)) (define-key geiser-repl-mode-map "\C-d" 'delete-char) -(define-key geiser-repl-mode-map "\C-cz" 'run-geiser) -(define-key geiser-repl-mode-map "\C-c\C-z" 'run-geiser) +(define-key geiser-repl-mode-map "\C-ck" 'geiser-repl-nuke) +(define-key geiser-repl-mode-map "\C-c\C-k" 'geiser-repl-nuke) + +(define-key geiser-repl-mode-map "\C-cz" 'switch-to-geiser) +(define-key geiser-repl-mode-map "\C-c\C-z" 'switch-to-geiser) (define-key geiser-repl-mode-map "\C-a" 'geiser-repl--bol) (define-key geiser-repl-mode-map (kbd "<home>") 'geiser-repl--bol) (define-key geiser-repl-mode-map "\C-ca" 'geiser-autodoc-mode) (define-key geiser-repl-mode-map "\C-cd" 'geiser-doc-symbol-at-point) (define-key geiser-repl-mode-map "\C-cm" 'geiser-repl--doc-module) -(define-key geiser-repl-mode-map "\C-ck" 'geiser-compile-file) (define-key geiser-repl-mode-map "\C-cl" 'geiser-load-file) (define-key geiser-repl-mode-map "\M-p" 'comint-previous-matching-input-from-input) @@ -326,7 +340,7 @@ If no REPL is running, execute `run-geiser' to start a fresh one." (defun geiser-repl--restore (impls) (dolist (impl impls) - (when impl (geiser impl)))) + (when impl (geiser nil impl)))) (defun geiser-repl-unload-function () (dolist (repl geiser-repl--repls) diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el index 14d996c..ca218c8 100644 --- a/elisp/geiser-syntax.el +++ b/elisp/geiser-syntax.el @@ -80,87 +80,183 @@ (with-syntax 1)) +;;; A simple scheme reader + +(defvar geiser-syntax--read/buffer-limit nil) + +(defsubst geiser-syntax--read/eos () + (or (eobp) + (and geiser-syntax--read/buffer-limit + (<= geiser-syntax--read/buffer-limit (point))))) + +(defsubst geiser-syntax--read/next-char () + (unless (geiser-syntax--read/eos) + (forward-char) + (char-after))) + +(defsubst geiser-syntax--read/token (token) + (geiser-syntax--read/next-char) + (if (listp token) token (list token))) + +(defsubst geiser-syntax--read/elisp () + (ignore-errors (read (current-buffer)))) + +(defun geiser-syntax--read/matching (open close) + (let ((count 1) + (p (1+ (point)))) + (while (and (> count 0) + (geiser-syntax--read/next-char)) + (cond ((looking-at-p open) (setq count (1+ count))) + ((looking-at-p close) (setq count (1- count))))) + (buffer-substring-no-properties p (point)))) + +(defsubst geiser-syntax--read/unprintable () + (geiser-syntax--read/token + (cons 'unprintable (geiser-syntax--read/matching "<" ">")))) + +(defun geiser-syntax--read/skip-comment () + (while (and (geiser-syntax--read/next-char) + (nth 8 (syntax-ppss)))) + (geiser-syntax--read/next-token)) + +(defun geiser-syntax--read/next-token () + (skip-syntax-forward "->") + (if (geiser-syntax--read/eos) '(eob) + (case (char-after) + (?\; (geiser-syntax--read/skip-comment)) + ((?\( ?\[) (geiser-syntax--read/token 'lparen)) + ((?\) ?\]) (geiser-syntax--read/token 'rparen)) + (?. (if (memq (syntax-after (1+ (point))) '(0 11 12)) + (geiser-syntax--read/token 'dot) + (cons 'atom (geiser-syntax--read/elisp)))) + (?\# (case (geiser-syntax--read/next-char) + ('nil '(eob)) + (?| (geiser-syntax--read/skip-comment)) + (?: (if (geiser-syntax--read/next-char) + (cons 'kwd (geiser-syntax--read/elisp)) + '(eob))) + (?\\ (cons 'char (geiser-syntax--read/elisp))) + (?\( (geiser-syntax--read/token 'vectorb)) + (?\< (geiser-syntax--read/unprintable)) + (t (let ((tok (geiser-syntax--read/elisp))) + (if tok (cons 'atom (intern (format "#%s" tok))) + (geiser-syntax--read/next-token)))))) + (?\' (geiser-syntax--read/token '(quote . quote))) + (?\` (geiser-syntax--read/token + `(backquote . ,backquote-backquote-symbol))) + (?, (if (eq (geiser-syntax--read/next-char) ?@) + (geiser-syntax--read/token + `(splice . ,backquote-splice-symbol)) + `(unquote . ,backquote-unquote-symbol))) + (?\" (cons 'string (geiser-syntax--read/elisp))) + (t (cons 'atom (geiser-syntax--read/elisp)))))) + +(defsubst geiser-syntax--read/match (&rest tks) + (let ((token (geiser-syntax--read/next-token))) + (if (memq (car token) tks) token + (error "Unexpected token: %s" token)))) + +(defsubst geiser-syntax--read/try (&rest tks) + (let ((p (point)) + (tk (ignore-errors (apply 'geiser-syntax--read/match tks)))) + (unless tk (goto-char p)) + tk)) + +(defun geiser-syntax--read/list () + (cond ((geiser-syntax--read/try 'dot) + (let ((tail (geiser-syntax--read))) + (geiser-syntax--read/match 'eob 'rparen) + tail)) + ((geiser-syntax--read/try 'rparen 'eob) nil) + (t (cons (geiser-syntax--read) + (geiser-syntax--read/list))))) + +(defun geiser-syntax--read () + (let ((token (geiser-syntax--read/next-token))) + (case (car token) + (eob nil) + (lparen (geiser-syntax--read/list)) + (vectorb (apply 'vector (geiser-syntax--read/list))) + ((quote backquote unquote splice) (list (cdr token) + (geiser-syntax--read))) + (kwd `(:keyword . ,(cdr token))) + (unprintable (format "#<%s>" (cdr token))) + ((char string atom) (cdr token)) + (t (error "Reading scheme syntax: unexpected token: %s" token))))) + +(defsubst geiser-syntax--read/keyword-value (s) + (and (consp s) (eq (car s) :keyword) (cdr s))) + +(defsubst geiser-syntax--form-after-point (&optional boundary) + (let ((geiser-syntax--read/buffer-limit (and (numberp boundary) boundary))) + (save-excursion (values (geiser-syntax--read) (point))))) + + ;;; Code parsing: -(geiser-popup--define syntax " *geiser syntax analyst*" scheme-mode) +(defsubst geiser-syntax--skip-comment/string () + (goto-char (or (nth 8 (syntax-ppss)) (point)))) -(defun geiser-syntax--prepare-scheme-for-elisp-reader () - (let ((end (save-excursion - (goto-char (point-max)) - (and (re-search-backward "(output \\. \"" nil t) - (point))))) - (goto-char (point-min)) - (while (re-search-forward "#\<\\([^>]*?\\)\>" end t) - (let ((from (match-beginning 1)) - (to (match-end 1))) - (goto-char from) - (while (re-search-forward "\\([ ;'`]\\)" to t) - (replace-match "\\\\\\1")) - (goto-char from) - (while (re-search-forward "[()]" to t) - (replace-match "")) - (goto-char to))) - (goto-char (point-min)) - (while (re-search-forward "#(" end t) (replace-match "(vector ")) - (goto-char (point-min)) - (while (re-search-forward "#" end t) (replace-match "\\\\#")) - (goto-char (point-min)) - (skip-syntax-forward "^("))) - -(defsubst geiser-syntax--del-sexp (arg) - (let ((p (point))) - (forward-sexp arg) - (delete-region p (point)))) - -(defconst geiser-syntax--placeholder (format "___%s___" (random 100))) - -(defsubst geiser-syntax--beginning-of-form () - (memq (char-after (point)) '(?\" ?\())) - -(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)) +(defsubst geiser-syntax--nesting-level () + (or (nth 0 (syntax-ppss)) 0)) + +(defun geiser-syntax--scan-sexps () + (save-excursion + (let* ((fst (symbol-at-point)) + (path (and fst (list (list fst 0))))) + (while (not (zerop (geiser-syntax--nesting-level))) + (let ((boundary (1+ (point)))) + (backward-up-list) + (let ((form + (nth-value 0 (geiser-syntax--form-after-point boundary)))) + (when (and (listp form) (car form) (symbolp (car form))) + (let* ((len-1 (1- (length form))) + (prev (and (> len-1 1) (nth (1- len-1) form))) + (prev (and prev + (geiser-syntax--read/keyword-value prev)))) + (push `(,(car form) + ,len-1 ,@(and prev (symbolp prev) (list prev))) + path)))))) + (nreverse path)))) + +(defun geiser-syntax--scan-locals (form partial locals) + (flet ((if-symbol (x) (and (symbolp x) x)) + (if-list (x) (and (listp x) x)) + (normalize (vars) (mapcar (lambda (i) (if (listp i) (car i) i)) vars))) + (cond ((or (null form) (not (listp form))) (normalize locals)) + ((not (memq (car form) '(define let let* letrec lambda))) + (geiser-syntax--scan-locals (car (last form)) partial locals)) + (t + (let* ((head (car form)) + (name (if-symbol (cadr form))) + (names (if name (if-list (caddr form)) + (if-list (cadr form)))) + (rest (if name (cdddr form) (cddr form))) + (use-names (or (eq head 'let*) (not partial) rest))) + (when name (push name locals)) + (when use-names (dolist (n names) (push n locals))) + (dolist (f (butlast rest)) + (when (eq (car f) 'define) (push (cadr f) locals))) + (geiser-syntax--scan-locals (car (last (or rest names))) + partial + locals)))))) + +(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 ((boundary (point))) + (while (not (zerop (geiser-syntax--nesting-level))) + (backward-up-list)) + (multiple-value-bind (form end) + (geiser-syntax--form-after-point boundary) + (geiser-syntax--scan-locals form (> end boundary) '())))))) ;;; Fontify strings as Scheme code: +(geiser-popup--define syntax " *geiser syntax analyst*" scheme-mode) + (defun geiser-syntax--font-lock-buffer () (let ((name " *geiser font lock*")) (or (get-buffer name) 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 b12127c..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) @@ -85,94 +87,15 @@ geiser-faces geiser-mode geiser-guile - geiser-plt)) - - -;;; Scheme mode setup: - -(defun geiser-setup-scheme-mode () - (eval-after-load "scheme" - '(add-hook 'scheme-mode-hook 'turn-on-geiser-mode))) - -(defun geiser-setup-implementations (impls) - (setq geiser-impl-installed-implementations (or impls '(guile plt)))) - -(defsubst geiser-impl--impl-feature (impl) - (intern (format "geiser-%s" impl))) - -(defun geiser-setup (&rest impls) - (geiser-setup-implementations impls) - (geiser-setup-scheme-mode) - (mapc (lambda (impl) - (require (geiser-impl--impl-feature impl) nil t)) - geiser-impl-installed-implementations)) - - -;;; Reload: - -(defmacro geiser--features-list () - (quote '( - geiser-mode - geiser-repl - geiser-impl - geiser-doc - geiser-xref - geiser-edit - geiser-completion - geiser-autodoc - geiser-compile - geiser-debug - 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)) - (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)) - (load-file geiser-main-file) - (geiser-setup) - (dolist (feature (reverse (geiser--features-list))) - (load-library (format "%s" feature))) - (geiser-impl--reload-implementations impls) - (geiser-repl--restore repls) - (geiser-mode--restore buffers) - (message "Geiser reloaded!"))) + geiser-plt + geiser-impl + geiser-xref)) -;; Initialization: +;;; Setup: -(geiser-setup) +(eval-after-load "scheme" + '(add-hook 'scheme-mode-hook 'turn-on-geiser-mode)) (provide 'geiser) -;;; geiser.el ends here |