diff options
40 files changed, 1508 insertions, 676 deletions
@@ -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 @@ -0,0 +1,4 @@ +Jose A. Ortega Ruiz <jao@gnu.org> designed and implemented GNU Geiser. For +more boring details about him, see <http://hacks-galore.org/jao>. + +See also the files THANKS and ChangeLog. diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..09d790c --- /dev/null +++ b/ChangeLog @@ -0,0 +1,6 @@ +## The contents of this file will be generated during 'make dist' by the +## shell command: + + git log --summary --stat + +# which you can run using 'sh ChangeLog' @@ -0,0 +1,318 @@ +Installing Geiser. +------------------ + +You'll find below the generic build and installation instructions for +a GNU package, which Geiser happens to be. As you know, they can be +summarised as: + + mkdir build && cd build + ../configure + make + make install + +And, in our case, we'll need to tell emacs about this new little +package with + + (require 'geiser-install) + +in your moral equivalent to ~/.emacs. + +As explained in the README file, Geiser is also directly usable from +its source tree, with no configuration whatsoever. Read that README to +see how. + +As promised, here you have the gory details of the autotools jazz, +which you can freely and safely skip on a first, second and third +reading. + +Installation Instructions +************************* + +Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005, +2006, 2007, 2008, 2009 Free Software Foundation, Inc. + + This file is free documentation; the Free Software Foundation gives +unlimited permission to copy, distribute and modify it. + +Basic Installation +================== + + Briefly, the shell commands `./configure; make; make install' should +configure, build, and install this package. The following +more-detailed instructions are generic; see the `README' file for +instructions specific to this package. + + The `configure' shell script attempts to guess correct values for +various system-dependent variables used during compilation. It uses +those values to create a `Makefile' in each directory of the package. +It may also create one or more `.h' files containing system-dependent +definitions. Finally, it creates a shell script `config.status' that +you can run in the future to recreate the current configuration, and a +file `config.log' containing compiler output (useful mainly for +debugging `configure'). + + It can also use an optional file (typically called `config.cache' +and enabled with `--cache-file=config.cache' or simply `-C') that saves +the results of its tests to speed up reconfiguring. Caching is +disabled by default to prevent problems with accidental use of stale +cache files. + + If you need to do unusual things to compile the package, please try +to figure out how `configure' could check whether to do them, and mail +diffs or instructions to the address given in the `README' so they can +be considered for the next release. If you are using the cache, and at +some point `config.cache' contains results you don't want to keep, you +may remove or edit it. + + The file `configure.ac' (or `configure.in') is used to create +`configure' by a program called `autoconf'. You need `configure.ac' if +you want to change it or regenerate `configure' using a newer version +of `autoconf'. + +The simplest way to compile this package is: + + 1. `cd' to the directory containing the package's source code and type + `./configure' to configure the package for your system. + + Running `configure' might take a while. While running, it prints + some messages telling which features it is checking for. + + 2. Type `make' to compile the package. + + 3. Optionally, type `make check' to run any self-tests that come with + the package. + + 4. Type `make install' to install the programs and any data files and + documentation. + + 5. You can remove the program binaries and object files from the + source code directory by typing `make clean'. To also remove the + files that `configure' created (so you can compile the package for + a different kind of computer), type `make distclean'. There is + also a `make maintainer-clean' target, but that is intended mainly + for the package's developers. If you use it, you may have to get + all sorts of other programs in order to regenerate files that came + with the distribution. + + 6. Often, you can also type `make uninstall' to remove the installed + files again. + +Compilers and Options +===================== + + Some systems require unusual options for compilation or linking that +the `configure' script does not know about. Run `./configure --help' +for details on some of the pertinent environment variables. + + You can give `configure' initial values for configuration parameters +by setting variables in the command line or in the environment. Here +is an example: + + ./configure CC=c99 CFLAGS=-g LIBS=-lposix + + *Note Defining Variables::, for more details. + +Compiling For Multiple Architectures +==================================== + + You can compile the package for more than one kind of computer at the +same time, by placing the object files for each architecture in their +own directory. To do this, you can use GNU `make'. `cd' to the +directory where you want the object files and executables to go and run +the `configure' script. `configure' automatically checks for the +source code in the directory that `configure' is in and in `..'. + + With a non-GNU `make', it is safer to compile the package for one +architecture at a time in the source code directory. After you have +installed the package for one architecture, use `make distclean' before +reconfiguring for another architecture. + + On MacOS X 10.5 and later systems, you can create libraries and +executables that work on multiple system types--known as "fat" or +"universal" binaries--by specifying multiple `-arch' options to the +compiler but only a single `-arch' option to the preprocessor. Like +this: + + ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ + CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ + CPP="gcc -E" CXXCPP="g++ -E" + + This is not guaranteed to produce working output in all cases, you +may have to build one architecture at a time and combine the results +using the `lipo' tool if you have problems. + +Installation Names +================== + + By default, `make install' installs the package's commands under +`/usr/local/bin', include files under `/usr/local/include', etc. You +can specify an installation prefix other than `/usr/local' by giving +`configure' the option `--prefix=PREFIX'. + + You can specify separate installation prefixes for +architecture-specific files and architecture-independent files. If you +pass the option `--exec-prefix=PREFIX' to `configure', the package uses +PREFIX as the prefix for installing programs and libraries. +Documentation and other data files still use the regular prefix. + + In addition, if you use an unusual directory layout you can give +options like `--bindir=DIR' to specify different values for particular +kinds of files. Run `configure --help' for a list of the directories +you can set and what kinds of files go in them. + + If the package supports it, you can cause programs to be installed +with an extra prefix or suffix on their names by giving `configure' the +option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. + +Optional Features +================= + + Some packages pay attention to `--enable-FEATURE' options to +`configure', where FEATURE indicates an optional part of the package. +They may also pay attention to `--with-PACKAGE' options, where PACKAGE +is something like `gnu-as' or `x' (for the X Window System). The +`README' should mention any `--enable-' and `--with-' options that the +package recognizes. + + For packages that use the X Window System, `configure' can usually +find the X include and library files automatically, but if it doesn't, +you can use the `configure' options `--x-includes=DIR' and +`--x-libraries=DIR' to specify their locations. + +Particular systems +================== + + On HP-UX, the default C compiler is not ANSI C compatible. If GNU +CC is not installed, it is recommended to use the following options in +order to use an ANSI C compiler: + + ./configure CC="cc -Ae" + +and if that doesn't work, install pre-built binaries of GCC for HP-UX. + + On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot +parse its `<wchar.h>' header file. The option `-nodtk' can be used as +a workaround. If GNU CC is not installed, it is therefore recommended +to try + + ./configure CC="cc" + +and if that doesn't work, try + + ./configure CC="cc -nodtk" + +Specifying the System Type +========================== + + There may be some features `configure' cannot figure out +automatically, but needs to determine by the type of machine the package +will run on. Usually, assuming the package is built to be run on the +_same_ architectures, `configure' can figure that out, but if it prints +a message saying it cannot guess the machine type, give it the +`--build=TYPE' option. TYPE can either be a short name for the system +type, such as `sun4', or a canonical name which has the form: + + CPU-COMPANY-SYSTEM + +where SYSTEM can have one of these forms: + + OS KERNEL-OS + + See the file `config.sub' for the possible values of each field. If +`config.sub' isn't included in this package, then this package doesn't +need to know the machine type. + + If you are _building_ compiler tools for cross-compiling, you should +use the option `--target=TYPE' to select the type of system they will +produce code for. + + If you want to _use_ a cross compiler, that generates code for a +platform different from the build platform, you should specify the +"host" platform (i.e., that on which the generated programs will +eventually be run) with `--host=TYPE'. + +Sharing Defaults +================ + + If you want to set default values for `configure' scripts to share, +you can create a site shell script called `config.site' that gives +default values for variables like `CC', `cache_file', and `prefix'. +`configure' looks for `PREFIX/share/config.site' if it exists, then +`PREFIX/etc/config.site' if it exists. Or, you can set the +`CONFIG_SITE' environment variable to the location of the site script. +A warning: not all `configure' scripts look for a site script. + +Defining Variables +================== + + Variables not defined in a site shell script can be set in the +environment passed to `configure'. However, some packages may run +configure again during the build, and the customized values of these +variables may be lost. In order to avoid this problem, you should set +them in the `configure' command line, using `VAR=value'. For example: + + ./configure CC=/usr/local2/bin/gcc + +causes the specified `gcc' to be used as the C compiler (unless it is +overridden in the site shell script). + +Unfortunately, this technique does not work for `CONFIG_SHELL' due to +an Autoconf bug. Until the bug is fixed you can use this workaround: + + CONFIG_SHELL=/bin/bash /bin/bash ./configure CONFIG_SHELL=/bin/bash + +`configure' Invocation +====================== + + `configure' recognizes the following options to control how it +operates. + +`--help' +`-h' + Print a summary of all of the options to `configure', and exit. + +`--help=short' +`--help=recursive' + Print a summary of the options unique to this package's + `configure', and exit. The `short' variant lists options used + only in the top level, while the `recursive' variant lists options + also present in any nested packages. + +`--version' +`-V' + Print the version of Autoconf used to generate the `configure' + script, and exit. + +`--cache-file=FILE' + Enable the cache: use and save the results of the tests in FILE, + traditionally `config.cache'. FILE defaults to `/dev/null' to + disable caching. + +`--config-cache' +`-C' + Alias for `--cache-file=config.cache'. + +`--quiet' +`--silent' +`-q' + Do not print messages saying which checks are being made. To + suppress all normal output, redirect it to `/dev/null' (any error + messages will still be shown). + +`--srcdir=DIR' + Look for the package's source code in directory DIR. Usually + `configure' can determine that directory automatically. + +`--prefix=DIR' + Use DIR as the installation prefix. *Note Installation Names:: + for more details, including other options available for fine-tuning + the installation locations. + +`--no-create' +`-n' + Run the configure checks, but stop before creating any output + files. + +`configure' also accepts some other, not widely useful, options. Run +`configure --help' for more details. + diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..c86aecb --- /dev/null +++ b/Makefile.am @@ -0,0 +1,6 @@ +SUBDIRS = . elisp scheme + +EXTRA_DIST = THANKS + +dist-hook: + $(SHELL) $(top_srcdir)/ChangeLog > $(top_distdir)/ChangeLog @@ -22,35 +22,75 @@ Currently supported implementations are Guile and PLT. - - Guile works only with the development, vm-based binary. Be sure - to customize `geiser-repl-guile-binary' to point to a correct vm - binary. + - Guile 1.9.x virtual machine required. - PLT Scheme 4.1.5.5 or better required. * Installation + Geiser can be used either directly from its uninstalled source tree + or byte-compiled and installed after perfoming the standard + configure/make/make install dance. - - In your .emacs: +*** In place + - Extract the tarball or clone the git repository anywhere in your + file system. Let's call that place <path-to-geiser>. + - In your .emacs: - (load-file "<path-to-geiser>/elisp/geiser.el") + (load-file "<path-to-geiser>/elisp/geiser.el") - This installs all supported Scheme implementations. You can list - explicitly the ones that you want by setting the variable - `geiser-impl-installed-implementations' *before* loading geiser.el. - For instance: +*** Byte-compiled + - Create a build directory, `build', say: + $ cd <path-to-geiser> + $ mkdir build; cd build + - Configure and make: + $ ../configure && make + You'll have a directory called "elisp" which contains Geiser's + elisp bytecode. Now, you can either use it in place, with the + .emacs incantation: - (setq geiser-impl-installed-implementations '(plt guile)) + (load-file "<path-to-geiser>/build/elisp/geiser.elc") - On opening a scheme file, Geiser will try to guess its Scheme, - defaulting to the first in the list. + or install it with: - - Check the geiser customization group for some options with: + $ make install + + and require 'geiser-install (not 'geiser, mind you) in your emacs + initialization file: + + (require 'geiser-install) + + You're ready to go! + +* Basic configuration + The loading invocations above install all supported Scheme + implementations. You can list explicitly the ones that you want by + setting the variable `geiser-impl-installed-implementations' *before* + loading geiser.el. For instance: + + (setq geiser-impl-installed-implementations '(plt guile)) + + On opening a scheme file, Geiser will try to guess its Scheme, + defaulting to the first in the list. Use `C-c C-s' to select the + implementation by hand (on a per file basis). + + Check the geiser customization group for some options with: M-x customize-group RET geiser RET - In particular, customize `geiser-repl-<impl>-binary' (in - geiser-repl), which should point to an executable in your path. + In particular, customize `geiser-repl-<impl>-binary' (in + geiser-repl), which should point to an executable in your path. + + To start a REPL, M-x geiser. + +*** Completion with company-mode + Geiser offers identifier and module name completion, bound to + M-TAB and M-` respectively. Only names visible in the current + module are offered. - - To start a REPL, M-x geiser. + While that is cool and all, things are even better: if you have + [[http://nschum.de/src/emacs/company-mode/][company-mode]] installed, Geiser's completion will use it. Just + require company-mode and, from then on, any new scheme buffer or + REPL will use it. If you didn't know about Nikolaj Schumacher's + awesome mode, check [[http://www.screentoaster.com/watch/stU0lSRERIR1pYRFVdXVlRVFFV/company_mode_for_gnu_emacs][this screencast]]. * Quick key reference @@ -94,22 +134,23 @@ *** In the REPL - |----------------+-------------------------------------------| - | C-c C-z, C-c z | Start Scheme REPL (if it's not running) | - |----------------+-------------------------------------------| - | M-. | Edit identifier at point | - | TAB, M-TAB | Complete identifier at point | - | M-`, C-. | Complete module name at point | - |----------------+-------------------------------------------| - | M-p, M-n | Prompt history, matching current prefix | - |----------------+-------------------------------------------| - | C-c k | Compile and load scheme file | - | C-c l | Load scheme file | - |----------------+-------------------------------------------| - | C-c d | See documentation for identifier at point | - | C-c m | See module documentation | - | C-c a | Toggle autodoc mode | - |----------------+-------------------------------------------| + |----------------+----------------------------------------------------| + | C-c C-z, C-c z | Start Scheme REPL (if it's not running) | + |----------------+----------------------------------------------------| + | M-. | Edit identifier at point | + | TAB, M-TAB | Complete identifier at point | + | M-`, C-. | Complete module name at point | + |----------------+----------------------------------------------------| + | M-p, M-n | Prompt history, matching current prefix | + |----------------+----------------------------------------------------| + | C-c C-k, C-c k | Nuke REPL: use it if the REPL becomes unresponsive | + |----------------+----------------------------------------------------| + | C-c l | Load scheme file | + |----------------+----------------------------------------------------| + | C-c d | See documentation for identifier at point | + | C-c m | See module documentation | + | C-c a | Toggle autodoc mode | + |----------------+----------------------------------------------------| *** In the documentation browser: @@ -0,0 +1,21 @@ + +Andy Wingo, Geiser's first user, has been a continuous source of +encouragement and suggestions, and keeps improving Guile and heeding +my feature requests. + +Eduardo Cavazos' contagious enthusiasm has helped in many ways to keep +Geiser alive, and he's become its best evangelist in R6RS circles. + +Eli Barzilay took the time to play with an early beta and make many +valuable suggestions, besides answering all my 'how do you in PLT' +questions. + +Matthew Flatt, Robby Findler and the rest of the PLT team did not only +answer my inquiries, but provided almost instant fixes to the few +issues i found. + +Thanks also to the PLT and Guile communities, for showing me that +Geiser was not only possible, but a pleasure to hack on. + +Karl Berry happily jeopardized GNU's prestige by reviewing and +accepting Geiser as a GNU official package. diff --git a/autogen.sh b/autogen.sh new file mode 100755 index 0000000..781eabd --- /dev/null +++ b/autogen.sh @@ -0,0 +1,5 @@ +#!/bin/sh + +[ -f elisp/geiser.el ] || exit 1 + +autoreconf -Wall -i diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000..2333901 --- /dev/null +++ b/configure.ac @@ -0,0 +1,30 @@ +# 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 + +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..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 diff --git a/scheme/Makefile.am b/scheme/Makefile.am new file mode 100644 index 0000000..01ed6ca --- /dev/null +++ b/scheme/Makefile.am @@ -0,0 +1,16 @@ + +nobase_dist_pkgdata_DATA = \ + guile/geiser/completion.scm \ + guile/geiser/doc.scm \ + guile/geiser/emacs.scm \ + guile/geiser/evaluation.scm \ + guile/geiser/modules.scm \ + guile/geiser/utils.scm \ + guile/geiser/xref.scm \ + plt/geiser.ss \ + plt/geiser/autodoc.ss \ + plt/geiser/completions.ss \ + plt/geiser/eval.ss \ + plt/geiser/locations.ss \ + plt/geiser/modules.ss \ + plt/geiser/utils.ss diff --git a/scheme/guile/geiser/completion.scm b/scheme/guile/geiser/completion.scm index f4342bb..564b8f5 100644 --- a/scheme/guile/geiser/completion.scm +++ b/scheme/guile/geiser/completion.scm @@ -31,28 +31,9 @@ #:use-module (ice-9 session) #:use-module (ice-9 regex)) -(define (completions prefix . context) - (let ((context (and (not (null? context)) (car context))) - (prefix (string-append "^" (regexp-quote prefix)))) - (append (filter (lambda (s) (string-match prefix s)) - (map symbol->string (local-bindings context))) - (sort! (map symbol->string (apropos-internal prefix)) string<?)))) - -(define (local-bindings form) - (define (body f) (if (> (length f) 2) (cddr f) '())) - (let loop ((form form) (bindings '())) - (cond ((not (pair? form)) bindings) - ((list? (car form)) - (loop (cdr form) (append (local-bindings (car form)) bindings))) - ((and (list? form) (< (length form) 2)) bindings) - ((memq (car form) '(define define* lambda)) - (loop (body form) (append (pair->list (cadr form)) bindings))) - ((and (memq (car form) '(let let* letrec letrec*)) - (list? (cadr form))) - (loop (body form) (append (map car (cadr form)) bindings))) - ((and (eq? 'let (car form)) (symbol? (cadr form))) - (loop (cons 'let (body form)) (cons (cadr form) bindings))) - (else (loop (cdr form) bindings))))) +(define (completions prefix) + (let ((prefix (string-append "^" (regexp-quote prefix)))) + (sort! (map symbol->string (apropos-internal prefix)) string<?))) (define (module-completions prefix) (let* ((prefix (string-append "^" (regexp-quote prefix))) diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm index c61502e..52f5625 100644 --- a/scheme/guile/geiser/doc.scm +++ b/scheme/guile/geiser/doc.scm @@ -37,82 +37,41 @@ #:use-module (oop goops) #:use-module (srfi srfi-1)) -(define (autodoc form) - (cond ((null? form) #f) - ((symbol? form) (describe-application (list form))) - ((not (pair? form)) #f) - ((not (list? form)) (autodoc (pair->list form))) - ((define-head? form) => autodoc) - (else (autodoc/list form)))) - -(define (autodoc/list form) - (let ((lst (last form))) - (cond ((and (symbol? lst) (describe-application (list lst)))) - ((and (pair? lst) (not (memq (car lst) '(quote))) (autodoc lst))) - (else (describe-application form))))) - -(define (define-head? form) - (define defforms '(define define* define-macro define-macro* - define-method define-class define-generic)) - (and (= 2 (length form)) - (memq (car form) defforms) - (car form))) - -(define (describe-application form) - (let* ((fun (car form)) - (args (obj-args (symbol->object fun)))) +(define (autodoc ids) + (if (not (list? ids)) + '() + (map (lambda (id) (or (autodoc* id) (list id))) ids))) + +(define (autodoc* id) + (let ((args (obj-args (symbol->object id)))) (and args - (list (cons 'signature (signature fun args)) - (cons 'position (find-position args form)) - (cons 'module (symbol-module fun)))))) + `(,@(signature id args) + (module . ,(symbol-module id)))))) (define (object-signature name obj) (let ((args (obj-args obj))) (and args (signature name args)))) -(define (signature fun args) - (let ((req (arglst args 'required)) - (opt (arglst args 'optional)) - (key (arglst args 'keyword)) - (rest (assq-ref args 'rest))) - (let ((sgn `(,fun ,@req - ,@(if (not (null? opt)) (cons #:opt opt) '()) - ,@(if (not (null? key)) (cons #:key key) '())))) - (if rest `(,@sgn #:rest ,rest) sgn)))) - -(define (find-position args form) - (let* ((lf (length form)) - (lf-1 (- lf 1))) - (if (= 1 lf) 0 - (let ((req (length (arglst args 'required))) - (opt (length (arglst args 'optional))) - (keys (map (lambda (k) (symbol->keyword (if (list? k) (car k) k))) - (arglst args 'keyword))) - (rest (assq-ref args 'rest))) - (cond ((<= lf (+ 1 req)) lf-1) - ((<= lf (+ 1 req opt)) (if (> opt 0) lf lf-1)) - ((or (memq (last form) keys) - (memq (car (take-right form 2)) keys)) => - (lambda (sl) - (+ 2 req - (if (> opt 0) (+ 1 opt) 0) - (- (length keys) (length sl))))) - (else (+ 1 req - (if (> opt 0) (+ 1 opt) 0) - (if (null? keys) 0 (+ 1 (length keys))) - (if rest 2 0)))))))) - -(define (arglst args kind) - (let ((args (assq-ref args kind))) - (cond ((or (not args) (null? args)) '()) - ((list? args) args) - (else (list args))))) +(define (signature id args) + (define (arglst kind) + (let ((args (assq-ref args kind))) + (cond ((or (not args) (null? args)) '()) + ((list? args) args) + (else (list args))))) + `(,id + (args ,@(if (list? args) + `((required ,@(arglst 'required)) + (optional ,@(arglst 'optional) + ,@(let ((rest (assq-ref args 'rest))) + (if rest (list "...") '()))) + (key ,@(arglst 'keyword))) + '())))) (define (obj-args obj) (cond ((not obj) #f) ((or (procedure? obj) (program? obj)) (arguments obj)) ((macro? obj) (or (obj-args (macro-transformer obj)) '((required ...)))) - (else #f))) + (else 'variable))) (define (arguments proc) (cond diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm index edae487..2aa91da 100644 --- a/scheme/guile/geiser/emacs.scm +++ b/scheme/guile/geiser/emacs.scm @@ -39,7 +39,8 @@ ge:module-exports ge:module-location ge:callers - ge:callees) + ge:callees + ge:find-file) #:use-module (geiser evaluation) #:use-module ((geiser modules) :renamer (symbol-prefix-proc 'ge:)) #:use-module ((geiser completion) :renamer (symbol-prefix-proc 'ge:)) diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm index 537e145..cbc088e 100644 --- a/scheme/guile/geiser/evaluation.scm +++ b/scheme/guile/geiser/evaluation.scm @@ -47,53 +47,47 @@ (else (display (format "ERROR: ~a, args: ~a" (car args) (cdr args))))) `(error (key . ,(car args)))) -(define (evaluate form module-name evaluator) - (let ((module (or (and (list? module-name) - (resolve-module module-name)) - (current-module))) - (evaluator (lambda (f m) - (call-with-values (lambda () (evaluator f m)) list))) - (result #f) - (captured-stack #f) - (error #f)) +(define (ge:compile form module-name) + (let* ((module (or (and (list? module-name) + (resolve-module module-name)) + (current-module))) + (result #f) + (captured-stack #f) + (error #f) + (ev (lambda () + (save-module-excursion + (lambda () + (set-current-module module) + (set! result (call-with-values + (lambda () (compile form)) + (lambda vs + (map (lambda (v) + (with-output-to-string + (lambda () (write v)))) + vs))))))))) (let ((output (with-output-to-string (lambda () - (set! result - (catch #t - (lambda () - (start-stack 'geiser-eval (evaluator form module))) - (lambda args - (set! error #t) - (apply handle-error captured-stack args)) - (lambda args - (set! captured-stack (make-stack #t 1 13))))))))) + (catch #t + (lambda () (start-stack 'geiser-eval (ev))) + (lambda args + (set! error #t) + (apply handle-error captured-stack args)) + (lambda args + (set! captured-stack (make-stack #t 2 15)))))))) (write `(,(if error result (cons 'result result)) (output . ,output))) (newline)))) -(define (eval-compile form module) - (save-module-excursion - (lambda () - (set-current-module module) - (compile form)))) - -(define (ge:eval form module-name) - (evaluate form module-name eval)) - -(define (ge:compile form module-name) - (evaluate form module-name eval-compile)) +(define ge:eval ge:compile) (define (ge:compile-file path) - "Compile and load file, given its full @var{path}." - (evaluate `(and (compile-file ,path) - (load-compiled ,(compiled-file-name path))) - '(system base compile) - eval-compile)) + "Compile a file, given its full @var{path}." + (ge:compile `(compile-and-load ,path) '(geiser evaluation))) (define (ge:load-file path) "Load file, given its full @var{path}." - (evaluate `(load ,path) #f eval)) + (ge:compile `(load-compiled ,(compiled-file-name path)) '(geiser evaluation))) (define (ge:macroexpand form . all) (let ((all (and (not (null? all)) (car all)))) diff --git a/scheme/guile/geiser/xref.scm b/scheme/guile/geiser/xref.scm index f00f724..2336fb2 100644 --- a/scheme/guile/geiser/xref.scm +++ b/scheme/guile/geiser/xref.scm @@ -28,7 +28,8 @@ #:export (symbol-location generic-methods callers - callees) + callees + find-file) #:use-module (geiser utils) #:use-module (geiser modules) #:use-module (geiser doc) @@ -90,4 +91,10 @@ (and obj (map procedure-xref (procedure-callees obj))))) +(define (find-file path) + (let loop ((dirs %load-path)) + (if (null? dirs) #f + (let ((candidate (string-append (car dirs) "/" path))) + (if (file-exists? candidate) candidate (loop (cdr dirs))))))) + ;;; xref.scm ends here diff --git a/scheme/plt/geiser/autodoc.ss b/scheme/plt/geiser/autodoc.ss index 73ed24d..c43f8c9 100644 --- a/scheme/plt/geiser/autodoc.ss +++ b/scheme/plt/geiser/autodoc.ss @@ -31,39 +31,32 @@ (eval `(help ,symbol #:from ,mod))))) (eval `(help ,symbol)))) -(define (autodoc form) - (cond ((null? form) #f) - ((symbol? form) (describe-application (list form))) - ((not (pair? form)) #f) - ((not (list? form)) (autodoc (pair->list form))) - ((define-head? form) => autodoc) - (else (autodoc/list form)))) - -(define (autodoc/list form) - (let ((lst (last form))) - (cond ((and (symbol? lst) (describe-application (list lst)))) - ((and (pair? lst) (not (memq (car lst) '(quote))) (autodoc lst))) - (else (describe-application form))))) - -(define (define-head? form) - (define defforms '(-define - define define-values - define-method define-class define-generic define-struct - define-syntax define-syntaxes -define-syntax)) - (and (= 2 (length form)) - (memq (car form) defforms) - (car form))) - -(define (describe-application form) - (let* ((fun (car form)) - (loc (symbol-location* fun)) - (name (car loc)) - (path (cdr loc)) - (sgn (and path (find-signature path name fun)))) - (and sgn - (list (cons 'signature (format-signature fun sgn)) - (cons 'position (find-position sgn form)) - (cons 'module (module-path-name->name path)))))) +(define (autodoc ids) + (if (not (list? ids)) + '() + (map (lambda (id) (or (autodoc* id) (list id))) ids))) + +(define (autodoc* id) + (and + (symbol? id) + (let* ((loc (symbol-location* id)) + (name (car loc)) + (path (cdr loc)) + (sgn (and path (find-signature path name id)))) + (and sgn + `(,id + (name . ,name) + (args ,@(format-signature sgn)) + (module . ,(module-path-name->name path))))))) + +(define (format-signature sign) + (if (signature? sign) + `((required ,@(signature-required sign)) + (optional ,@(signature-optional sign) + ,@(let ((rest (signature-rest sign))) + (if rest (list "...") '()))) + (key ,@(signature-keys sign))) + '())) (define signatures (make-hash)) @@ -71,9 +64,7 @@ (define (find-signature path name local-name) (let ((path (if (path? path) (path->string path) path))) - (hash-ref! (hash-ref! signatures - path - (lambda () (parse-signatures path))) + (hash-ref! (hash-ref! signatures path (lambda () (parse-signatures path))) name (lambda () (infer-signature local-name))))) @@ -167,44 +158,6 @@ (opt-no (- max-val min-val))) (make-signature (args 0 min-val) (args min-val opt-no) '() #f))))) -(define (format-signature fun sign) - (cond ((symbol? sign) (cons fun sign)) - ((signature? sign) - (let ((req (signature-required sign)) - (opt (signature-optional sign)) - (keys (signature-keys sign)) - (rest (signature-rest sign))) - `(,fun - ,@req - ,@(if (null? opt) opt (cons '#:opt opt)) - ,@(if (null? keys) keys (cons '#:key keys)) - ,@(if rest (list '#:rest rest) '())))) - (else #f))) - -(define (find-position sign form) - (if (signature? sign) - (let* ((lf (length form)) - (lf-1 (- lf 1))) - (if (= 1 lf) 0 - (let ((req (length (signature-required sign))) - (opt (length (signature-optional sign))) - (keys (map (lambda (k) (symbol->keyword (if (list? k) (car k) k))) - (signature-keys sign))) - (rest (signature-rest sign))) - (cond ((<= lf (+ 1 req)) lf-1) - ((<= lf (+ 1 req opt)) (if (> opt 0) lf lf-1)) - ((or (memq (last form) keys) - (memq (car (take-right form 2)) keys)) => - (lambda (sl) - (+ 2 req - (if (> opt 0) (+ 1 opt) 0) - (- (length keys) (length sl))))) - (else (+ 1 req - (if (> opt 0) (+ 1 opt) 0) - (if (null? keys) 0 (+ 1 (length keys))) - (if rest 2 0))))))) - 0)) - (define (update-module-cache path . form) (when (and (string? path) (or (null? form) diff --git a/scheme/plt/geiser/completions.ss b/scheme/plt/geiser/completions.ss index 4537feb..15bc081 100644 --- a/scheme/plt/geiser/completions.ss +++ b/scheme/plt/geiser/completions.ss @@ -35,29 +35,10 @@ (filter (lambda (s) (string-prefix? prefix s)) (if sort? (sort lst string<?) lst))) -(define (symbol-completions prefix (context #f)) - (append (filter-prefix prefix - (map symbol->string (local-bindings context)) - #f) - (filter-prefix prefix - (map symbol->string (namespace-mapped-symbols)) - #t))) - -(define (local-bindings form) - (define (body f) (if (> (length f) 2) (cddr f) '())) - (let loop ((form form) (bindings '())) - (cond ((not (pair? form)) bindings) - ((list? (car form)) - (loop (cdr form) (append (local-bindings (car form)) bindings))) - ((and (list? form) (< (length form) 2)) bindings) - ((memq (car form) '(define define* lambda)) - (loop (body form) (append (pair->list (cadr form)) bindings))) - ((and (memq (car form) '(let let* letrec letrec*)) - (list? (cadr form))) - (loop (body form) (append (map car (cadr form)) bindings))) - ((and (eq? 'let (car form)) (symbol? (cadr form))) - (loop (cons 'let (body form)) (cons (cadr form) bindings))) - (else (loop (cdr form) bindings))))) +(define (symbol-completions prefix) + (filter-prefix prefix + (map symbol->string (namespace-mapped-symbols)) + #t)) (define (module-completions prefix) (filter-prefix prefix (module-list) #f)) diff --git a/scheme/plt/geiser/eval.ss b/scheme/plt/geiser/eval.ss index 8022a4c..5ae81ed 100644 --- a/scheme/plt/geiser/eval.ss +++ b/scheme/plt/geiser/eval.ss @@ -46,36 +46,37 @@ (vector-ref (struct->vector e) 0)) (define (set-last-error e) - (set! last-result `((error (key . ,(exn-key e)) - (subr) - (msg . ,(exn-message e)))))) + (set! last-result `((error (key . ,(exn-key e))))) + (display (exn-message e))) -(define (set-last-result v . vs) - (set! last-result `((result ,v ,@vs)))) +(define (write-value v) + (with-output-to-string + (lambda () (write v)))) + +(define (set-last-result . vs) + (set! last-result `((result ,@(map write-value vs))))) (define (eval-in form spec) (set-last-result (void)) - (with-handlers ((exn? set-last-error)) - (update-module-cache spec form) - (call-with-values - (lambda () (eval form (module-spec->namespace spec))) - set-last-result)) - last-result) + (let ((output + (with-output-to-string + (lambda () + (with-handlers ((exn? set-last-error)) + (update-module-cache spec form) + (call-with-values + (lambda () (eval form (module-spec->namespace spec))) + set-last-result)))))) + (append last-result `((output . ,output))))) (define compile-in eval-in) (define (load-file file) - (with-handlers ((exn? set-last-error)) - (let ((current-path (namespace->module-path-name (last-namespace)))) - (update-module-cache file) - (set-last-result - (string-append (with-output-to-string - (lambda () - (load-module file (current-output-port)))) - "done.")) - (load-module (and (path? current-path) - (path->string current-path))))) - last-result) + (let ((current-path (namespace->module-path-name (last-namespace))) + (result (eval-in `(load-module ,file (current-output-port)) + 'geiser/eval))) + (update-module-cache file) + (load-module (and (path? current-path) (path->string current-path))) + result)) (define compile-file load-file) |