elisp/geiser-impl.el

   1 ;; geiser-impl.el -- generic support for scheme implementations
   2
   3 ;; Copyright (C) 2009, 2010, 2012 Jose Antonio Ortega Ruiz
   4
   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>.
   9
  10 ;; Start date: Sat Mar 07, 2009 23:32
  11
  12 \f
  13
  14 (require 'geiser-custom)
  15 (require 'geiser-base)
  16
  17 (require 'help-fns)
  18
  19 \f
  20 ;;; Customization:
  21
  22 (defgroup geiser-implementation nil
  23   "Generic support for multiple Scheme implementations."
  24   :group 'geiser)
  25
  26 (geiser-custom--defcustom geiser-default-implementation nil
  27   "Symbol naming the default Scheme implementation."
  28   :type 'symbol
  29   :group 'geiser-implementation)
  30
  31 (geiser-custom--defcustom geiser-active-implementations '(guile racket)
  32   "List of active installed Scheme implementations."
  33   :type '(repeat symbol)
  34   :group 'geiser-implementation)
  35
  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))
  45                        symbol))
  46   :group 'geiser-implementation)
  47
  48 \f
  49 ;;; Implementation registry:
  50
  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)
  56
  57 (geiser-custom--memoize 'geiser-impl--load-files)
  58
  59 (make-variable-buffer-local
  60  (defvar geiser-impl--implementation nil))
  61
  62 (defsubst geiser-impl--impl-str (&optional impl)
  63   (let ((impl (or impl geiser-impl--implementation)))
  64     (and impl (capitalize (format "%s" impl)))))
  65
  66 (defsubst geiser-impl--feature (impl)
  67   (intern (format "geiser-%s" impl)))
  68
  69 (defsubst geiser-impl--load-impl (impl)
  70   (require (geiser-impl--feature impl)
  71            (cdr (assq impl geiser-impl--load-files))
  72            t))
  73
  74 (defsubst geiser-impl--methods (impl)
  75   (cdr (assq impl geiser-impl--registry)))
  76
  77 (defun geiser-impl--method (method &optional impl)
  78   (let ((impl (or impl
  79                   geiser-impl--implementation
  80                   geiser-default-implementation)))
  81     (cadr (assq method (geiser-impl--methods impl)))))
  82
  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))))
  86
  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)))
  96
  97 (defun geiser-implementation-help ()
  98   "Shows a buffer with help on defining new supported Schemes."
  99   (interactive)
 100   (help-setup-xref (list #'geiser-implementation-help) t)
 101   (save-excursion
 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)))
 112           (princ (cdr m))
 113           (with-current-buffer (help-buffer)
 114             (fill-region-as-paragraph p (point)))
 115           (princ "\n\n")))
 116       (with-current-buffer standard-output (buffer-string)))))
 117
 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))
 122
 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))
 127
 128 (defmacro geiser-impl--define-caller (fun-name method arglist doc)
 129   (let ((impl (make-symbol "implementation-name")))
 130     `(progn
 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)
 135
 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)))
 141
 142 (defsubst geiser-activate-implementation (impl)
 143   (add-to-list 'geiser-active-implementations impl))
 144
 145 (defsubst geiser-deactivate-implementation (impl)
 146   (setq geiser-active-implementations
 147         (delq impl geiser-active-implementations)))
 148
 149 (defsubst geiser-impl--active-p (impl)
 150   (memq impl geiser-active-implementations))
 151
 152 \f
 153 ;;; Defining implementations:
 154
 155 (defun geiser-impl--normalize-method (m)
 156   (when (and (listp m)
 157              (= 2 (length m))
 158              (symbolp (car m)))
 159     (if (functionp (cadr m)) m
 160       `(,(car m) (lambda (&rest) ,(cadr m))))))
 161
 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)))
 171
 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
 177 defined in METHODS.
 178
 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.
 184
 185 Here's how a typical call to this macro looks like:
 186
 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)
 201     (display-help)
 202     (check-buffer geiser-guile--guess)
 203     (keywords geiser-guile--keywords))
 204
 205 This macro also defines a runner function (run-NAME) and a
 206 switcher (switch-to-NAME), and provides geiser-NAME."
 207   (let ((name (if (listp name) (car name) name))
 208         (parent (and (listp name) (cadr name))))
 209     (unless (symbolp name)
 210       (error "Malformed implementation name: %s" name))
 211     (let ((runner (intern (format "run-%s" name)))
 212           (switcher (intern (format "switch-to-%s" name)))
 213           (runner-doc (format "Start a new %s REPL." name))
 214           (switcher-doc (format "Switch to a running %s REPL, or start one."
 215                                 name))
 216           (ask (make-symbol "ask")))
 217       `(progn
 218          (geiser-impl--define ,load-file-name ',name ',parent ',methods)
 219          (require 'geiser-repl)
 220          (require 'geiser-menu)
 221          (defun ,runner ()
 222            ,runner-doc
 223            (interactive)
 224            (run-geiser ',name))
 225          (defun ,switcher (&optional ,ask)
 226            ,switcher-doc
 227            (interactive "P")
 228            (switch-to-geiser ,ask ',name))
 229          (geiser-menu--add-impl ',name ',runner ',switcher)
 230          (provide ',(geiser-impl--feature name))))))
 231
 232 (defun geiser-impl--add-to-alist (kind what impl &optional append)
 233   (add-to-list 'geiser-implementations-alist
 234                (list (list kind what) impl) append))
 235
 236 \f
 237 ;;; Trying to guess the scheme implementation:
 238
 239 (make-variable-buffer-local
 240  (defvar geiser-scheme-implementation nil
 241    "Set this buffer local variable to specify the Scheme
 242 implementation to be used by Geiser."))
 243
 244 (put 'geiser-scheme-implementation 'safe-local-variable 'symbolp)
 245
 246 (defun geiser-impl--match-impl (desc bn)
 247   (let ((rx (if (eq (car desc) 'regexp)
 248                 (cadr desc)
 249               (format "^%s" (regexp-quote (cadr desc))))))
 250     (and rx (string-match-p rx bn))))
 251
 252 (defvar geiser-impl--impl-prompt-history nil)
 253
 254 (defun geiser-impl--read-impl (&optional prompt impls non-req)
 255   (let* ((impls (or impls geiser-active-implementations))
 256          (impls (mapcar 'symbol-name impls))
 257          (prompt (or prompt "Scheme implementation: ")))
 258     (intern (completing-read prompt impls nil (not non-req) nil
 259                              geiser-impl--impl-prompt-history
 260                              (and (car impls) (car impls))))))
 261
 262 (geiser-impl--define-caller geiser-impl--check-buffer check-buffer ()
 263   "Method called without arguments that should check whether the current
 264 buffer contains Scheme code of the given implementation.")
 265
 266 (defun geiser-impl--guess (&optional prompt)
 267   (or geiser-impl--implementation
 268       (progn (hack-local-variables)
 269              (and (memq geiser-scheme-implementation
 270                         geiser-active-implementations)
 271                   geiser-scheme-implementation))
 272       (and (null (cdr geiser-active-implementations))
 273            (car geiser-active-implementations))
 274       (catch 'impl
 275         (dolist (impl geiser-active-implementations)
 276           (when (geiser-impl--check-buffer impl)
 277             (throw 'impl impl)))
 278         (let ((bn (buffer-file-name)))
 279           (when bn
 280             (dolist (x geiser-implementations-alist)
 281               (when (and (memq (cadr x) geiser-active-implementations)
 282                          (geiser-impl--match-impl (car x) bn))
 283                 (throw 'impl (cadr x)))))))
 284       geiser-default-implementation
 285       (and prompt (geiser-impl--read-impl))))
 286
 287 \f
 288 ;;; Using implementations:
 289
 290 (defsubst geiser-impl--registered-method (impl method fallback)
 291   (let ((m (geiser-impl--method method impl)))
 292     (if (fboundp m) m
 293       (or fallback (error "%s not defined for %s implementation"
 294                           method impl)))))
 295
 296 (defsubst geiser-impl--registered-value (impl method fallback)
 297   (let ((m (geiser-impl--method method impl)))
 298     (if (functionp m) (funcall m) fallback)))
 299
 300 (defun geiser-impl--set-buffer-implementation (&optional impl prompt)
 301   (let ((impl (or impl (geiser-impl--guess prompt))))
 302     (when impl
 303       (unless (geiser-impl--load-impl impl)
 304         (error "Cannot find %s implementation" impl))
 305       (setq geiser-impl--implementation impl)
 306       (dolist (m geiser-impl--local-methods)
 307         (set (make-local-variable (nth 0 m))
 308              (geiser-impl--registered-method impl (nth 1 m) (nth 2 m))))
 309       (dolist (m geiser-impl--local-variables)
 310         (set (make-local-variable (nth 0 m))
 311              (geiser-impl--registered-value impl (nth 1 m) (nth 2 m)))))))
 312
 313 (defmacro with--geiser-implementation (impl &rest body)
 314   (let* ((mbindings (mapcar (lambda (m)
 315                               `(,(nth 0 m)
 316                                 (geiser-impl--registered-method ,impl
 317                                                                 ',(nth 1 m)
 318                                                                 ',(nth 2 m))))
 319                             geiser-impl--local-methods))
 320          (vbindings (mapcar (lambda (m)
 321                               `(,(nth 0 m)
 322                                 (geiser-impl--registered-value ,impl
 323                                                                ',(nth 1 m)
 324                                                                ',(nth 2 m))))
 325                             geiser-impl--local-variables))
 326          (ibindings `((geiser-impl--implementation ,impl)))
 327          (bindings (append ibindings mbindings vbindings)))
 328     `(let* ,bindings ,@body)))
 329 (put 'with--geiser-implementation 'lisp-indent-function 1)
 330
 331 \f
 332 ;;; Reload support:
 333
 334 (defun geiser-impl-unload-function ()
 335   (dolist (imp (mapcar (lambda (i)
 336                          (geiser-impl--feature (car i)))
 337                        geiser-impl--registry))
 338     (when (featurep imp) (unload-feature imp t))))
 339
 340 \f
 341 (provide 'geiser-impl)
 342
 343 \f
 344 ;;; Initialization:
 345 ;; After providing 'geiser-impl, so that impls can use us.
 346 (mapc 'geiser-impl--load-impl geiser-active-implementations)