1 ;; geiser-impl.el -- generic support for scheme implementations
3 ;; Copyright (C) 2009, 2010 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
)
20 (defgroup geiser-implementation nil
21 "Generic support for multiple Scheme implementations."
24 (geiser-custom--defcustom geiser-default-implementation nil
25 "Symbol naming the default Scheme implementation."
27 :group
'geiser-implementation
)
29 (geiser-custom--defcustom geiser-active-implementations
'(guile racket
)
30 "List of active installed Scheme implementations."
31 :type
'(repeat symbol
)
32 :group
'geiser-implementation
)
34 (geiser-custom--defcustom geiser-implementations-alist nil
35 "A map from regular expressions or directories to implementations.
36 When opening a new file, its full path will be matched against
37 each one of the regular expressions or directories in this map in order to
38 determine its scheme flavour."
39 :type
'(repeat (list (choice (group :tag
"Regular expression"
40 (const regexp
) regexp
)
41 (group :tag
"Directory"
42 (const dir
) directory
))
44 :group
'geiser-implementation
)
47 ;;; Implementation registry:
49 (defvar geiser-impl--registry nil
)
50 (defvar geiser-impl--load-files nil
)
51 (defvar geiser-impl--method-docs nil
)
52 (defvar geiser-impl--local-methods nil
)
53 (defvar geiser-impl--local-variables nil
)
55 (geiser-custom--memoize 'geiser-impl--load-files
)
57 (make-variable-buffer-local
58 (defvar geiser-impl--implementation nil
))
60 (defsubst geiser-impl--impl-str
(&optional impl
)
61 (let ((impl (or impl geiser-impl--implementation
)))
62 (and impl
(capitalize (format "%s" impl
)))))
64 (defsubst geiser-impl--feature
(impl)
65 (intern (format "geiser-%s" impl
)))
67 (defsubst geiser-impl--load-impl
(impl)
68 (require (geiser-impl--feature impl
)
69 (cdr (assq impl geiser-impl--load-files
))
72 (defsubst geiser-impl--methods
(impl)
73 (cdr (assq impl geiser-impl--registry
)))
75 (defun geiser-impl--method (method &optional impl
)
77 geiser-impl--implementation
78 geiser-default-implementation
)))
79 (cadr (assq method
(geiser-impl--methods impl
)))))
81 (defun geiser-impl--call-method (method impl
&rest args
)
82 (let ((fun (geiser-impl--method method impl
)))
83 (when (functionp fun
) (apply fun args
))))
85 (defun geiser-impl--method-doc (method doc
)
86 (push (cons method doc
) geiser-impl--method-docs
))
88 (defun geiser-impl--register-local-method (var-name method fallback doc
)
89 (add-to-list 'geiser-impl--local-methods
(list var-name method fallback
))
90 (geiser-impl--method-doc method doc
))
92 (defun geiser-impl--register-local-variable (var-name method fallback doc
)
93 (add-to-list 'geiser-impl--local-variables
(list var-name method fallback
))
94 (geiser-impl--method-doc method doc
))
96 (defmacro geiser-impl--define-caller
(fun-name method arglist doc
)
97 (let ((m (make-symbol "method-candidate"))
98 (impl (make-symbol "implementation-name")))
100 (defun ,fun-name
,(cons impl arglist
) ,doc
101 (geiser-impl--call-method ',method
,impl
,@arglist
))
102 (geiser-impl--method-doc ',method
,doc
))))
103 (put 'geiser-impl--define-caller
'lisp-indent-function
3)
105 (defun geiser-impl--register (file impl methods
)
106 (let ((current (assq impl geiser-impl--registry
)))
107 (if current
(setcdr current methods
)
108 (push (cons impl methods
) geiser-impl--registry
))
109 (push (cons impl file
) geiser-impl--load-files
)))
111 (defsubst geiser-activate-implementation
(impl)
112 (add-to-list 'geiser-active-implementations impl
))
114 (defsubst geiser-deactivate-implementation
(impl)
115 (setq geiser-active-implementations
116 (delq impl geiser-active-implementations
)))
118 (defsubst geiser-impl--active-p
(impl)
119 (memq impl geiser-active-implementations
))
122 ;;; Defining implementations:
124 (defun geiser-impl--normalize-method (m)
128 (if (functionp (cadr m
)) m
129 `(,(car m
) (lambda (&rest
) ,(cadr m
))))))
131 (defun geiser-impl--define (file name parent methods
)
132 (let* ((methods (mapcar 'geiser-impl--normalize-method methods
))
133 (methods (delq nil methods
))
134 (inherited-methods (and parent
(geiser-impl--methods parent
)))
135 (methods (append methods
136 (dolist (m methods inherited-methods
)
137 (setq inherited-methods
138 (assq-delete-all m inherited-methods
))))))
139 (geiser-impl--register file name methods
)))
141 (defmacro define-geiser-implementation
(name &rest methods
)
142 (let ((name (if (listp name
) (car name
) name
))
143 (parent (and (listp name
) (cadr name
))))
144 (unless (symbolp name
)
145 (error "Malformed implementation name: %s" name
))
146 (let ((runner (intern (format "run-%s" name
)))
147 (switcher (intern (format "switch-to-%s" name
)))
148 (runner-doc (format "Start a new %s REPL." name
))
149 (switcher-doc (format "Switch to a running %s REPL, or start one."
151 (ask (make-symbol "ask")))
153 (geiser-impl--define ,load-file-name
',name
',parent
',methods
)
154 (require 'geiser-repl
)
155 (require 'geiser-menu
)
160 (defun ,switcher
(&optional
,ask
)
163 (switch-to-geiser ,ask
',name
))
164 (geiser-menu--add-impl ',name
',runner
',switcher
)
165 (provide ',(geiser-impl--feature name
))))))
167 (defun geiser-impl--add-to-alist (kind what impl
&optional append
)
168 (add-to-list 'geiser-implementations-alist
169 (list (list kind what
) impl
) append
))
172 ;;; Trying to guess the scheme implementation:
174 (make-variable-buffer-local
175 (defvar geiser-scheme-implementation nil
176 "Set this buffer local variable to specify the Scheme
177 implementation to be used by Geiser."))
179 (put 'geiser-scheme-implementation
'safe-local-variable
'symbolp
)
181 (defun geiser-impl--match-impl (desc bn
)
182 (let ((rx (if (eq (car desc
) 'regexp
)
184 (format "^%s" (regexp-quote (cadr desc
))))))
185 (and rx
(string-match-p rx bn
))))
187 (defvar geiser-impl--impl-prompt-history nil
)
189 (defun geiser-impl--read-impl (&optional prompt impls non-req
)
190 (let* ((impls (or impls geiser-active-implementations
))
191 (impls (mapcar 'symbol-name impls
))
192 (prompt (or prompt
"Scheme implementation: ")))
193 (intern (completing-read prompt impls nil
(not non-req
) nil
194 geiser-impl--impl-prompt-history
195 (and (car impls
) (car impls
))))))
197 (geiser-impl--define-caller geiser-impl--check-buffer check-buffer
()
198 "Method called without arguments that should check whether the current
199 buffer contains Scheme code of the given implementation.")
201 (defun geiser-impl--guess (&optional prompt
)
202 (or geiser-impl--implementation
203 (progn (hack-local-variables)
204 (and (memq geiser-scheme-implementation
205 geiser-active-implementations
)
206 geiser-scheme-implementation
))
207 (and (null (cdr geiser-active-implementations
))
208 (car geiser-active-implementations
))
210 (dolist (impl geiser-active-implementations
)
211 (when (geiser-impl--check-buffer impl
)
213 (let ((bn (buffer-file-name)))
215 (dolist (x geiser-implementations-alist
)
216 (when (and (memq (cadr x
) geiser-active-implementations
)
217 (geiser-impl--match-impl (car x
) bn
))
218 (throw 'impl
(cadr x
)))))))
219 geiser-default-implementation
220 (and prompt
(geiser-impl--read-impl))))
223 ;;; Using implementations:
225 (defsubst geiser-impl--registered-method
(impl method fallback
)
226 (let ((m (geiser-impl--method method impl
)))
228 (or fallback
(error "%s not defined for %s implementation"
231 (defsubst geiser-impl--registered-value
(impl method fallback
)
232 (let ((m (geiser-impl--method method impl
)))
233 (if (functionp m
) (funcall m
) fallback
)))
235 (defun geiser-impl--set-buffer-implementation (&optional impl
)
236 (let ((impl (or impl
(geiser-impl--guess))))
238 (unless (geiser-impl--load-impl impl
)
239 (error "Cannot find %s implementation" impl
))
240 (setq geiser-impl--implementation impl
)
241 (dolist (m geiser-impl--local-methods
)
242 (set (make-local-variable (nth 0 m
))
243 (geiser-impl--registered-method impl
(nth 1 m
) (nth 2 m
))))
244 (dolist (m geiser-impl--local-variables
)
245 (set (make-local-variable (nth 0 m
))
246 (geiser-impl--registered-value impl
(nth 1 m
) (nth 2 m
)))))))
248 (defmacro with--geiser-implementation
(impl &rest body
)
249 (let* ((mbindings (mapcar (lambda (m)
251 (geiser-impl--registered-method ,impl
254 geiser-impl--local-methods
))
255 (vbindings (mapcar (lambda (m)
257 (geiser-impl--registered-value ,impl
260 geiser-impl--local-variables
))
261 (ibindings `((geiser-impl--implementation ,impl
)))
262 (bindings (append ibindings mbindings vbindings
)))
263 `(let* ,bindings
,@body
)))
264 (put 'with--geiser-implementation
'lisp-indent-function
1)
269 (defun geiser-impl-unload-function ()
270 (dolist (imp (mapcar (lambda (i)
271 (geiser-impl--feature (car i
)))
272 geiser-impl--registry
))
273 (when (featurep imp
) (unload-feature imp t
))))
276 (provide 'geiser-impl
)
280 ;; After providing 'geiser-impl, so that impls can use us.
281 (mapc 'geiser-impl--load-impl geiser-active-implementations
)
283 ;;; geiser-impl.el ends here