1 ;; geiser-impl.el -- generic support for scheme implementations
3 ;; Copyright (C) 2009, 2010, 2012, 2013 Jose Antonio Ortega Ruiz
5 ;; This program is free software; you can redistribute it and/or
6 ;; modify it under the terms of the Modified BSD License. You should
7 ;; have received a copy of the license along with this program. If
8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
10 ;; Start date: Sat Mar 07, 2009 23:32
14 (require 'geiser-custom
)
15 (require 'geiser-base
)
22 (defgroup geiser-implementation nil
23 "Generic support for multiple Scheme implementations."
26 (geiser-custom--defcustom geiser-default-implementation nil
27 "Symbol naming the default Scheme implementation."
29 :group
'geiser-implementation
)
31 (geiser-custom--defcustom geiser-active-implementations
'(guile racket
)
32 "List of active installed Scheme implementations."
33 :type
'(repeat symbol
)
34 :group
'geiser-implementation
)
36 (geiser-custom--defcustom geiser-implementations-alist nil
37 "A map from regular expressions or directories to implementations.
38 When opening a new file, its full path will be matched against
39 each one of the regular expressions or directories in this map in order to
40 determine its scheme flavour."
41 :type
'(repeat (list (choice (group :tag
"Regular expression"
42 (const regexp
) regexp
)
43 (group :tag
"Directory"
44 (const dir
) directory
))
46 :group
'geiser-implementation
)
49 ;;; Implementation registry:
51 (defvar geiser-impl--registry nil
)
52 (defvar geiser-impl--load-files nil
)
53 (defvar geiser-impl--method-docs nil
)
54 (defvar geiser-impl--local-methods nil
)
55 (defvar geiser-impl--local-variables nil
)
57 (geiser-custom--memoize 'geiser-impl--load-files
)
59 (make-variable-buffer-local
60 (defvar geiser-impl--implementation nil
))
62 (defsubst geiser-impl--impl-str
(&optional impl
)
63 (let ((impl (or impl geiser-impl--implementation
)))
64 (and impl
(capitalize (format "%s" impl
)))))
66 (defsubst geiser-impl--feature
(impl)
67 (intern (format "geiser-%s" impl
)))
69 (defsubst geiser-impl--load-impl
(impl)
70 (require (geiser-impl--feature impl
)
71 (cdr (assq impl geiser-impl--load-files
))
74 (defsubst geiser-impl--methods
(impl)
75 (cdr (assq impl geiser-impl--registry
)))
77 (defun geiser-impl--method (method &optional impl
)
79 geiser-impl--implementation
80 geiser-default-implementation
)))
81 (cadr (assq method
(geiser-impl--methods impl
)))))
83 (defun geiser-impl--call-method (method impl
&rest args
)
84 (let ((fun (geiser-impl--method method impl
)))
85 (when (functionp fun
) (apply fun args
))))
87 (defun geiser-impl--method-doc (method doc user
)
88 (let* ((user (if user
(format " Used via `%s'." user
) ""))
89 (extra-doc (format "%s%s" doc user
)))
90 (add-to-list 'geiser-impl--method-docs
(cons method extra-doc
))
91 (setq geiser-impl--method-docs
92 (sort geiser-impl--method-docs
93 (lambda (a b
) (string< (symbol-name (car a
))
94 (symbol-name (car b
))))))
95 (put method
'function-documentation doc
)))
97 (defun geiser-implementation-help ()
98 "Shows a buffer with help on defining new supported Schemes."
100 (help-setup-xref (list #'geiser-implementation-help
) t
)
102 (with-help-window (help-buffer)
103 (princ "Geiser: supporting new Scheme implementations.\n\n")
104 (princ "Use `define-geiser-implementation' to define ")
105 (princ "new implementations")
106 (princ "\n\n (define-geiser-implementation NAME &rest METHODS)\n\n")
107 (princ (documentation 'define-geiser-implementation
))
108 (princ "\n\nMethods used to define an implementation:\n\n")
109 (dolist (m geiser-impl--method-docs
)
110 (let ((p (with-current-buffer (help-buffer) (point))))
111 (princ (format "%s: " (car m
)))
113 (with-current-buffer (help-buffer)
114 (fill-region-as-paragraph p
(point)))
116 (with-current-buffer standard-output
(buffer-string)))))
118 (defun geiser-impl--register-local-method (var-name method fallback doc
)
119 (add-to-list 'geiser-impl--local-methods
(list var-name method fallback
))
120 (geiser-impl--method-doc method doc var-name
)
121 (put var-name
'function-documentation doc
))
123 (defun geiser-impl--register-local-variable (var-name method fallback doc
)
124 (add-to-list 'geiser-impl--local-variables
(list var-name method fallback
))
125 (geiser-impl--method-doc method doc var-name
)
126 (put var-name
'variable-documentation doc
))
128 (defmacro geiser-impl--define-caller
(fun-name method arglist doc
)
129 (let ((impl (make-symbol "implementation-name")))
131 (defun ,fun-name
,(cons impl arglist
) ,doc
132 (geiser-impl--call-method ',method
,impl
,@arglist
))
133 (geiser-impl--method-doc ',method
,doc
',fun-name
))))
134 (put 'geiser-impl--define-caller
'lisp-indent-function
3)
136 (defun geiser-impl--register (file impl methods
)
137 (let ((current (assq impl geiser-impl--registry
)))
138 (if current
(setcdr current methods
)
139 (push (cons impl methods
) geiser-impl--registry
))
140 (push (cons impl file
) geiser-impl--load-files
)))
142 (defsubst geiser-activate-implementation
(impl)
143 (add-to-list 'geiser-active-implementations impl
))
145 (defsubst geiser-deactivate-implementation
(impl)
146 (setq geiser-active-implementations
147 (delq impl geiser-active-implementations
)))
149 (defsubst geiser-impl--active-p
(impl)
150 (memq impl geiser-active-implementations
))
153 ;;; Defining implementations:
155 (defun geiser-impl--normalize-method (m)
159 (if (functionp (cadr m
)) m
160 `(,(car m
) (lambda (&rest
) ,(cadr m
))))))
162 (defun geiser-impl--define (file name parent methods
)
163 (let* ((methods (mapcar 'geiser-impl--normalize-method methods
))
164 (methods (delq nil methods
))
165 (inherited-methods (and parent
(geiser-impl--methods parent
)))
166 (methods (append methods
167 (dolist (m methods inherited-methods
)
168 (setq inherited-methods
169 (assq-delete-all m inherited-methods
))))))
170 (geiser-impl--register file name methods
)))
172 (defmacro define-geiser-implementation
(name &rest methods
)
173 "Defines a new supported Scheme implementation.
174 NAME can be either an unquoted symbol naming the implementation,
175 or a two-element list (NAME PARENT), with PARENT naming another
176 registered implementation from which to borrow methods not
179 After NAME come the methods, each one a two element list of the
180 form (METHOD-NAME FUN-OR-VAR), where METHOD-NAME is one of the
181 needed methods (for a list, execute `geiser-implementation-help')
182 and a value, variable name or function name implementing it.
183 Omitted method names will return nil to their callers.
185 Here's how a typical call to this macro looks like:
187 (define-geiser-implementation guile
188 (binary geiser-guile--binary)
189 (arglist geiser-guile--parameters)
190 (repl-startup geiser-guile--startup)
191 (prompt-regexp geiser-guile--prompt-regexp)
192 (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp)
193 (enter-debugger geiser-guile--enter-debugger)
194 (marshall-procedure geiser-guile--geiser-procedure)
195 (find-module geiser-guile--get-module)
196 (enter-command geiser-guile--enter-command)
197 (exit-command geiser-guile--exit-command)
198 (import-command geiser-guile--import-command)
199 (find-symbol-begin geiser-guile--symbol-begin)
200 (display-error geiser-guile--display-error)
202 (check-buffer geiser-guile--guess)
203 (keywords geiser-guile--keywords)
204 (case-sensitive geiser-guile-case-sensitive-p))
206 This macro also defines a runner function (run-NAME) and a
207 switcher (switch-to-NAME), and provides geiser-NAME."
208 (let ((name (if (listp name
) (car name
) name
))
209 (parent (and (listp name
) (cadr name
))))
210 (unless (symbolp name
)
211 (error "Malformed implementation name: %s" name
))
212 (let ((runner (intern (format "run-%s" name
)))
213 (switcher (intern (format "switch-to-%s" name
)))
214 (runner-doc (format "Start a new %s REPL." name
))
215 (switcher-doc (format "Switch to a running %s REPL, or start one."
217 (ask (make-symbol "ask")))
219 (geiser-impl--define ,load-file-name
',name
',parent
',methods
)
220 (require 'geiser-repl
)
221 (require 'geiser-menu
)
226 (defun ,switcher
(&optional
,ask
)
229 (switch-to-geiser ,ask
',name
))
230 (geiser-menu--add-impl ',name
',runner
',switcher
)
231 (provide ',(geiser-impl--feature name
))))))
233 (defun geiser-impl--add-to-alist (kind what impl
&optional append
)
234 (add-to-list 'geiser-implementations-alist
235 (list (list kind what
) impl
) append
))
238 ;;; Trying to guess the scheme implementation:
240 (make-variable-buffer-local
241 (defvar geiser-scheme-implementation nil
242 "Set this buffer local variable to specify the Scheme
243 implementation to be used by Geiser."))
245 (put 'geiser-scheme-implementation
'safe-local-variable
'symbolp
)
247 (defun geiser-impl--match-impl (desc bn
)
248 (let ((rx (if (eq (car desc
) 'regexp
)
250 (format "^%s" (regexp-quote (cadr desc
))))))
251 (and rx
(string-match-p rx bn
))))
253 (defvar geiser-impl--impl-prompt-history nil
)
255 (defun geiser-impl--read-impl (&optional prompt impls non-req
)
256 (let* ((impls (or impls geiser-active-implementations
))
257 (impls (mapcar 'symbol-name impls
))
258 (prompt (or prompt
"Scheme implementation: ")))
259 (intern (completing-read prompt impls nil
(not non-req
) nil
260 geiser-impl--impl-prompt-history
261 (and (car impls
) (car impls
))))))
263 (geiser-impl--define-caller geiser-impl--check-buffer check-buffer
()
264 "Method called without arguments that should check whether the current
265 buffer contains Scheme code of the given implementation.")
267 (defun geiser-impl--guess (&optional prompt
)
268 (or geiser-impl--implementation
269 (progn (hack-local-variables)
270 (and (memq geiser-scheme-implementation
271 geiser-active-implementations
)
272 geiser-scheme-implementation
))
273 (and (null (cdr geiser-active-implementations
))
274 (car geiser-active-implementations
))
276 (dolist (impl geiser-active-implementations
)
277 (when (geiser-impl--check-buffer impl
)
279 (let ((bn (buffer-file-name)))
281 (dolist (x geiser-implementations-alist
)
282 (when (and (memq (cadr x
) geiser-active-implementations
)
283 (geiser-impl--match-impl (car x
) bn
))
284 (throw 'impl
(cadr x
)))))))
285 geiser-default-implementation
286 (and prompt
(geiser-impl--read-impl))))
289 ;;; Using implementations:
291 (defsubst geiser-impl--registered-method
(impl method fallback
)
292 (let ((m (geiser-impl--method method impl
)))
294 (or fallback
(error "%s not defined for %s implementation"
297 (defsubst geiser-impl--registered-value
(impl method fallback
)
298 (let ((m (geiser-impl--method method impl
)))
299 (if (functionp m
) (funcall m
) fallback
)))
301 (defun geiser-impl--set-buffer-implementation (&optional impl prompt
)
302 (let ((impl (or impl
(geiser-impl--guess prompt
))))
304 (unless (geiser-impl--load-impl impl
)
305 (error "Cannot find %s implementation" impl
))
306 (setq geiser-impl--implementation impl
)
307 (dolist (m geiser-impl--local-methods
)
308 (set (make-local-variable (nth 0 m
))
309 (geiser-impl--registered-method impl
(nth 1 m
) (nth 2 m
))))
310 (dolist (m geiser-impl--local-variables
)
311 (set (make-local-variable (nth 0 m
))
312 (geiser-impl--registered-value impl
(nth 1 m
) (nth 2 m
)))))))
314 (defmacro with--geiser-implementation
(impl &rest body
)
315 (let* ((mbindings (mapcar (lambda (m)
317 (geiser-impl--registered-method ,impl
320 geiser-impl--local-methods
))
321 (vbindings (mapcar (lambda (m)
323 (geiser-impl--registered-value ,impl
326 geiser-impl--local-variables
))
327 (ibindings `((geiser-impl--implementation ,impl
)))
328 (bindings (append ibindings mbindings vbindings
)))
329 `(let* ,bindings
,@body
)))
330 (put 'with--geiser-implementation
'lisp-indent-function
1)
335 (defun geiser-impl-unload-function ()
336 (dolist (imp (mapcar (lambda (i)
337 (geiser-impl--feature (car i
)))
338 geiser-impl--registry
))
339 (when (featurep imp
) (unload-feature imp t
))))
342 (provide 'geiser-impl
)
346 ;; After providing 'geiser-impl, so that impls can use us.
347 (mapc 'geiser-impl--load-impl geiser-active-implementations
)