summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2009-02-09 01:29:26 +0100
committerJose Antonio Ortega Ruiz <jao@gnu.org>2009-02-09 01:29:26 +0100
commit4e7c148fef58281345c1d4d0815732e27977da71 (patch)
tree22ed1c67b6fecd2c0bd024a6a04e897e2e105f59
parente16e29baa9d444be4fd5e60f93c124c666c60b80 (diff)
downloadgeiser-chez-4e7c148fef58281345c1d4d0815732e27977da71.tar.gz
geiser-chez-4e7c148fef58281345c1d4d0815732e27977da71.tar.bz2
Basic region/definition/sexp evaluation and autodoc mode working.
-rw-r--r--elisp/geiser-autodoc.el132
-rw-r--r--elisp/geiser-eval.el27
-rw-r--r--elisp/geiser-mode.el155
-rw-r--r--elisp/geiser-syntax.el96
-rw-r--r--elisp/geiser.el7
-rw-r--r--scheme/geiser/emacs.scm32
-rw-r--r--scheme/geiser/eval.scm16
-rw-r--r--scheme/geiser/introspection.scm65
8 files changed, 509 insertions, 21 deletions
diff --git a/elisp/geiser-autodoc.el b/elisp/geiser-autodoc.el
new file mode 100644
index 0000000..cff5794
--- /dev/null
+++ b/elisp/geiser-autodoc.el
@@ -0,0 +1,132 @@
+;; geiser-autodoc.el -- autodoc mode
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sun Feb 08, 2009 19: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/>.
+
+;;; Comentary:
+
+;; A minor mode that echoes information about procedures and variables
+;; near point at the minibuffer.
+
+;;; Code:
+
+(require 'geiser-eval)
+(require 'geiser-syntax)
+(require 'geiser-base)
+
+(require 'eldoc)
+
+
+;;; Customization:
+
+(defgroup geiser-autodoc nil
+ "Options for displaying autodoc strings in the echo area."
+ :group 'geiser)
+
+(defface geiser-font-lock-autodoc-current-arg
+ '((t (:background unspecified :foreground "red" :bold t)))
+ "Face for highlighting current argument in autodoc messages."
+ :group 'faces
+ :group 'geiser-faces
+ :group 'geiser-autodoc)
+
+(defcustom geiser-autodoc-delay 0.2
+ "Delay before autodoc messages are fetched and displayed, in seconds."
+ :type 'number
+ :group 'geiser-autodoc)
+
+
+;;; Procedure arguments:
+
+(make-variable-buffer-local
+ (defvar geiser-autodoc--last nil))
+
+(defun geiser-autodoc--function-args (fun)
+ (if (eq fun (car geiser-autodoc--last))
+ (cdr geiser-autodoc--last)
+ (let* ((cmd `(:gs ((:ge proc-args) ',fun)))
+ (result (geiser-eval--retort-result (geiser-eval--send/wait cmd))))
+ (when (and (not (eq result :f)) (listp result))
+ (setq geiser-autodoc--last (cons fun result))
+ result))))
+
+(defun geiser-autodoc--insert (sym current pos)
+ (let ((str (format "%s" sym)))
+ (when (= current pos)
+ (put-text-property 0 (length str) 'face 'geiser-font-lock-autodoc-current-arg str))
+ (insert str)))
+
+(defun geiser-autodoc--fun-args-str (fun args pos)
+ (save-current-buffer
+ (set-buffer (geiser-syntax--font-lock-buffer))
+ (erase-buffer)
+ (let ((current 0))
+ (insert "(")
+ (geiser-autodoc--insert fun current pos)
+ (dolist (arg (cdr (assoc 'required args)))
+ (setq current (1+ current))
+ (insert " ")
+ (geiser-autodoc--insert arg current pos))
+ (setq current (1+ current))
+ (when (cdr (assoc 'optional args))
+ (when (> pos current) (setq current pos))
+ (insert " . ")
+ (geiser-autodoc--insert (cdr (assoc 'optional args)) current pos))
+ (insert ")")
+ (buffer-string))))
+
+
+;;; Autodoc function:
+
+(defun geiser-autodoc--eldoc-function ()
+ (let* ((f/a (geiser-syntax--enclosing-form-data))
+ (fun (car f/a))
+ (arg-no (cdr f/a)))
+ (when fun
+ (let ((args (geiser-autodoc--function-args fun)))
+ (geiser-autodoc--fun-args-str fun args arg-no)))))
+
+
+;;; Autodoc mode:
+
+(make-variable-buffer-local
+ (defvar geiser-autodoc-mode-string " A"
+ "Modeline indicator for geiser-autodoc-mode"))
+
+(define-minor-mode geiser-autodoc-mode
+ "Toggle Geiser's Autodoc mode.
+With no argument, this command toggles the mode.
+Non-null prefix argument turns on the mode.
+Null prefix argument turns off the mode.
+
+When Autodoc mode is enabled, a synopsis of the word at point is
+displayed in the minibuffer."
+ :init-value nil
+ :lighter geiser-autodoc-mode-string
+ :group 'geiser-autodoc
+
+ (set (make-local-variable 'eldoc-documentation-function)
+ (when geiser-autodoc-mode 'geiser-autodoc--eldoc-function))
+ (set (make-local-variable 'eldoc-minor-mode-string) nil)
+ (set (make-local-variable 'eldoc-idle-delay) geiser-autodoc-delay)
+ (eldoc-mode geiser-autodoc-mode)
+ (message "Geiser Autodoc %s" (if geiser-autodoc-mode "enabled" "disabled")))
+
+
+(provide 'geiser-autodoc)
+;;; geiser-autodoc.el ends here
diff --git a/elisp/geiser-eval.el b/elisp/geiser-eval.el
index 68ef1ca..ee04139 100644
--- a/elisp/geiser-eval.el
+++ b/elisp/geiser-eval.el
@@ -26,6 +26,7 @@
;;; Code:
(require 'geiser-connection)
+(require 'geiser-syntax)
(require 'geiser-log)
(require 'geiser-base)
@@ -38,8 +39,10 @@
((eq code :t) "#t")
((listp code)
(cond ((eq (car code) :gs) (geiser-eval--gs (cdr code)))
+ ((eq (car code) :ge) (format "(@ (geiser emacs) %s)" (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--gs (code)
@@ -48,19 +51,8 @@
") (quote "
(or (and (nth 1 code)
(geiser-eval--scheme-str (nth 1 code)))
- (geiser-eval--buffer-module))
+ (geiser-syntax--buffer-module))
"))"))
-
-;;; Current module:
-
-(defun geiser-eval--buffer-module (&optional buffer)
- (let ((buffer (or buffer (current-buffer))))
- (with-current-buffer buffer
- (save-excursion
- (goto-char (point-min))
- (if (re-search-forward "(define-module +\\(([^)]+)\\)" nil t)
- (match-string-no-properties 1)
- "#f")))))
;;; Code sending:
@@ -116,6 +108,17 @@
(defsubst geiser-eval--error-msg (err) (cdr (assoc 'msg err)))
(defsubst geiser-eval--error-rest (err) (cdr (assoc 'rest err)))
+(defun geiser-eval--error-str (err)
+ (let* ((key (geiser-eval--error-key err))
+ (subr (geiser-eval--error-subr err))
+ (subr-str (if subr (format " (%s)" subr) ""))
+ (msg (geiser-eval--error-msg err))
+ (msg-str (if msg (format ": %s" msg) ""))
+ (rest (geiser-eval--error-rest err))
+ (rest-str (if rest (format " %s" rest) "")))
+ (format "Error%s: %s%s%s" subr-str key msg-str rest-str)))
+
+
(provide 'geiser-eval)
;;; geiser-eval.el ends here
diff --git a/elisp/geiser-mode.el b/elisp/geiser-mode.el
new file mode 100644
index 0000000..2b6778b
--- /dev/null
+++ b/elisp/geiser-mode.el
@@ -0,0 +1,155 @@
+;; geiser-mode.el -- minor mode for scheme buffers
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sun Feb 08, 2009 15:13
+
+;; 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/>.
+
+;;; Comentary:
+
+;; Minor mode adding Geiser REPL/Emacs interaction commands to Scheme
+;; buffers.
+
+;;; Code:
+
+(require 'geiser-autodoc)
+(require 'geiser-eval)
+(require 'geiser-popup)
+(require 'geiser-base)
+
+
+;;; Customization:
+
+(defgroup geiser-mode nil
+ "Mode enabling Geiser abilities in Scheme buffers &co.."
+ :group 'geiser)
+
+(defcustom geiser-mode-autodoc-p t
+ "Whether `geiser-autodoc-mode' gets enabled by default in factor buffers."
+ :group 'geiser-mode
+ :group 'geiser-autodoc
+ :type 'boolean)
+
+
+
+;;; Auxiliary functions:
+
+(geiser-popup--define mode "*Geiser evaluation results*" scheme-mode)
+
+(defun geiser-eval--display-error (err output)
+ (if (not output)
+ (message (geiser-eval--error-str err))
+ (geiser-mode--with-buffer
+ (erase-buffer)
+ (insert ";; " (geiser-eval--error-str err))
+ (newline 2)
+ (insert output)
+ (newline))
+ (geiser-mode--pop-to-buffer)))
+
+
+;;; Evaluation commands:
+
+(defun geiser-send-region (start end &optional and-go)
+ "Send the current region to the Geiser REPL.
+With prefix, goes to the REPL buffer afterwards (as
+`geiser-send-region-and-go')"
+ (interactive "rP")
+ (let* ((str (buffer-substring-no-properties start end))
+ (code `(:gs (:scm ,str)))
+ (ret (geiser-eval--send/wait code))
+ (err (geiser-eval--retort-error ret)))
+ (when and-go
+ (switch-to-guile)
+ (push-mark)
+ (goto-char (point-max)))
+ (if (not err)
+ (message (format "=> %s" (geiser-eval--retort-result ret)))
+ (geiser-eval--display-error err (geiser-eval--retort-output ret)))))
+
+(defun geiser-send-region-and-go (start end)
+ "Send the current region to the Geiser REPL and visit it afterwads."
+ (interactive "r")
+ (geiser-send-region start end t))
+
+(defun geiser-send-definition (&optional and-go)
+ "Send the current definition to the Geiser REPL.
+With prefix, goes to the REPL buffer afterwards (as
+`geiser-send-definition-and-go')"
+ (interactive "P")
+ (save-excursion
+ (end-of-defun)
+ (let ((end (point)))
+ (beginning-of-defun)
+ (geiser-send-region (point) end and-go))))
+
+(defun geiser-send-definition-and-go ()
+ "Send the current definition to the Geiser REPL and visit it afterwads."
+ (interactive)
+ (geiser-send-definition t))
+
+(defun geiser-send-last-sexp ()
+ "Send the previous sexp to the Geiser REPL."
+ (interactive)
+ (geiser-send-region (save-excursion (backward-sexp) (point)) (point)))
+
+
+;;; Geiser mode:
+
+(make-variable-buffer-local
+ (defvar geiser-mode-string " Geiser"
+ "Modeline indicator for geiser-mode"))
+
+(defvar geiser-mode-map (make-sparse-keymap)
+ "Key map for geiser-mode")
+
+(define-minor-mode geiser-mode
+ "Toggle Geiser's mode.
+With no argument, this command toggles the mode.
+Non-null prefix argument turns on the mode.
+Null prefix argument turns off the mode.
+
+When Geiser mode is enabled, a host of nice utilities for
+interacting with the Geiser REPL is at your disposal.
+\\{geiser-mode-map}"
+ :init-value nil
+ :lighter geiser-mode-string
+ :group 'geiser
+ :keymap geiser-mode-map
+ (setq geiser-autodoc-mode-string "/A")
+ (when geiser-mode-autodoc-p (geiser-autodoc-mode geiser-mode)))
+
+
+;;; Keys:
+
+(define-key geiser-mode-map "\M-\C-x" 'geiser-send-definition)
+(define-key geiser-mode-map "\C-c\C-a" 'geiser-autodoc-mode)
+(define-key geiser-mode-map "\C-x\C-e" 'geiser-send-last-sexp)
+(define-key geiser-mode-map "\C-c\C-e" 'geiser-send-definition)
+(define-key geiser-mode-map "\C-c\M-e" 'geiser-send-definition-and-go)
+(define-key geiser-mode-map "\C-c\C-r" 'geiser-send-region)
+(define-key geiser-mode-map "\C-c\M-r" 'geiser-send-region-and-go)
+(define-key geiser-mode-map "\C-c\M-c" 'geiser-compile-definition)
+(define-key geiser-mode-map "\C-c\C-c" 'geiser-compile-definition-and-go)
+(define-key geiser-mode-map "\C-c\C-t" 'geiser-trace-procedure)
+(define-key geiser-mode-map "\C-c\C-x" 'geiser-expand-current-form)
+(define-key geiser-mode-map "\C-c\C-z" 'switch-to-guile)
+(define-key geiser-mode-map "\C-c\C-l" 'geiser-load-file)
+(define-key geiser-mode-map "\C-c\C-k" 'geiser-compile-file)
+
+
+(provide 'geiser-mode)
+;;; geiser-mode.el ends here
diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el
new file mode 100644
index 0000000..07aafbb
--- /dev/null
+++ b/elisp/geiser-syntax.el
@@ -0,0 +1,96 @@
+;; geiser-syntax.el -- guile-specific scheme syntax
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sun Feb 08, 2009 15:03
+
+;; 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/>.
+
+;;; Comentary:
+
+;; Utilities for parsing Guile-specific Scheme syntax.
+
+;;; Code:
+
+(require 'geiser-base)
+
+(require 'scheme)
+
+
+;;; Modules:
+
+(defconst geiser-syntax--module-definition-re
+ "(define-module +\\(([^)]+)\\)")
+
+(defun geiser-syntax--buffer-module (&optional buffer)
+ (let ((buffer (or buffer (current-buffer))))
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward geiser-syntax--module-definition-re nil t)
+ (match-string-no-properties 1)
+ "#f")))))
+
+;;; Indentation:
+
+(defun geiser-syntax--setup-scheme-indent ()
+ (let ((defuns '(catch)))
+ (mapc (lambda (d) (put d 'scheme-indent-function 'defun)) defuns)))
+
+
+;;; Code parsing:
+
+(defun geiser-syntax--enclosing-form-data ()
+ (save-excursion
+ (let ((p (progn (ignore-errors
+ (unless (zerop (car (syntax-after (point))))
+ (forward-sexp)
+ (when (= 7 (car (syntax-after (point))))
+ (forward-char))))
+ (point)))
+ (arg-no 0)
+ (proc))
+ (condition-case nil
+ (progn (backward-up-list)
+ (forward-char)
+ (setq proc (symbol-at-point))
+ (while (< (point) p)
+ (forward-sexp)
+ (when (< (point) p) (setq arg-no (1+ arg-no))))
+ (cons proc arg-no))
+ (error nil)))))
+
+
+;;; Fontify strings as Scheme code:
+
+(defun geiser-syntax--font-lock-buffer ()
+ (let ((name " *geiser font lock*"))
+ (or (get-buffer name)
+ (let ((buffer (get-buffer-create name)))
+ (set-buffer buffer)
+ (scheme-mode)
+ buffer))))
+
+(defun geiser-syntax--scheme-str (str)
+ (save-current-buffer
+ (set-buffer (geiser-syntax--font-lock-buffer))
+ (erase-buffer)
+ (insert str)
+ (let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
+ (buffer-string)))
+
+
+(provide 'geiser-syntax)
+;;; geiser-syntax.el ends here
diff --git a/elisp/geiser.el b/elisp/geiser.el
index 2ce4e82..ab3e7ff 100644
--- a/elisp/geiser.el
+++ b/elisp/geiser.el
@@ -46,10 +46,13 @@
;;; Autoloads:
(autoload 'run-guile "geiser-repl.el"
- "Start a Geiser Guile REPL, or switch to a running one" t)
+ "Start a Geiser Guile REPL, or switch to a running one." t)
(autoload 'switch-to-guile "geiser-repl.el"
- "Start a Geiser Guile REPL, or switch to a running one" t)
+ "Start a Geiser Guile REPL, or switch to a running one." t)
+
+(autoload 'geiser-mode "geiser-mode.el"
+ "Minor mode adding Geiser REPL interaction to Scheme buffers." t)
(provide 'geiser)
diff --git a/scheme/geiser/emacs.scm b/scheme/geiser/emacs.scm
new file mode 100644
index 0000000..014c44a
--- /dev/null
+++ b/scheme/geiser/emacs.scm
@@ -0,0 +1,32 @@
+;; emacs.scm -- procedures for emacs interaction
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sun Feb 08, 2009 18:39
+
+;; 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/>.
+
+;;; Comentary:
+
+;; Re-exports of procedures used by Emacs.
+
+;;; Code:
+
+(define-module (geiser emacs)
+ #:re-export (proc-args var-metadata)
+ #:use-module (geiser introspection))
+
+
+;;; emacs.scm ends here
diff --git a/scheme/geiser/eval.scm b/scheme/geiser/eval.scm
index 450221a..e6fa0cf 100644
--- a/scheme/geiser/eval.scm
+++ b/scheme/geiser/eval.scm
@@ -38,13 +38,13 @@ SUBR, MSG and REST."
(let ((module (or (and module-name (resolve-module module-name))
(current-module))))
(catch #t
- (lambda ()
- (let* ((result #f)
- (output (with-output-to-string
- (lambda () (set! result (eval form module))))))
- (list (cons 'result result) (cons 'output output))))
- (lambda (key . args)
- (list (cons 'error (apply parse-error (cons key args))))))))
+ (lambda ()
+ (let* ((result #f)
+ (output (with-output-to-string
+ (lambda () (set! result (compile form module))))))
+ (list (cons 'result result) (cons 'output output))))
+ (lambda (key . args)
+ (list (cons 'error (apply parse-error (cons key args))))))))
(define (parse-error key . args)
(let* ((len (length args))
@@ -57,4 +57,6 @@ SUBR, MSG and REST."
(cons 'msg (if msg (apply format (cons #f (cons msg margs))) '()))
(cons 'rest (or rest '())))))
+(define (test-geiser) 4)
+
;;; eval.scm ends here
diff --git a/scheme/geiser/introspection.scm b/scheme/geiser/introspection.scm
new file mode 100644
index 0000000..eff9573
--- /dev/null
+++ b/scheme/geiser/introspection.scm
@@ -0,0 +1,65 @@
+;; introspection.scm -- name says it all
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sun Feb 08, 2009 18: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/>.
+
+;;; Comentary:
+
+;; Procedures introspecting on scheme objects and their properties.
+
+;;; Code:
+
+(define-module (geiser introspection)
+ #:export (proc-args var-metadata)
+ #:use-module (system vm program)
+ #:use-module (srfi srfi-1))
+
+(define (proc-args proc)
+ (let ((proc (and (symbol? proc)
+ (module-bound? (current-module) proc)
+ (eval proc (current-module)))))
+ (cond ((not proc) #f)
+ ((program? proc) (program-args proc))
+ ((procedure? proc) (procedure-args proc))
+ ((macro? proc) (macro-args proc))
+ (else #f))))
+
+(define (program-args program)
+ (let* ((arity (program-arity program))
+ (arg-no (first arity))
+ (opt (> (second arity) 0))
+ (args (map first (take (program-bindings program) arg-no))))
+ (format-args (if opt (drop-right args 1) args) (and opt (last args)))))
+
+(define (procedure-args proc)
+ (let* ((arity (procedure-property proc 'arity))
+ (req (first arity))
+ (opt (third arity)))
+ (format-args (map (lambda (n)
+ (string->symbol (format "arg~A" n)))
+ (iota req))
+ (and opt 'rest))))
+
+(define (macro-args macro)
+ (format-args '(...) #f))
+
+(define (format-args args opt)
+ (list (cons 'required args)
+ (cons 'optional (or opt '()))))
+
+;;; introspection.scm ends here