elisp/geiser-impl.el

   1 ;; geiser-impl.el -- generic support for scheme implementations
   2
   3 ;; Copyright (C) 2009, 2010 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 \f
  18 ;;; Customization:
  19
  20 (defgroup geiser-implementation nil
  21   "Generic support for multiple Scheme implementations."
  22   :group 'geiser)
  23
  24 (geiser-custom--defcustom geiser-default-implementation nil
  25   "Symbol naming the default Scheme implementation."
  26   :type 'symbol
  27   :group 'geiser-implementation)
  28
  29 (geiser-custom--defcustom geiser-active-implementations '(guile racket)
  30   "List of active installed Scheme implementations."
  31   :type '(repeat symbol)
  32   :group 'geiser-implementation)
  33
  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))
  43                        symbol))
  44   :group 'geiser-implementation)
  45
  46 \f
  47 ;;; Implementation registry:
  48
  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)
  54
  55 (geiser-custom--memoize 'geiser-impl--load-files)
  56
  57 (make-variable-buffer-local
  58  (defvar geiser-impl--implementation nil))
  59
  60 (defsubst geiser-impl--impl-str (&optional impl)
  61   (let ((impl (or impl geiser-impl--implementation)))
  62     (and impl (capitalize (format "%s" impl)))))
  63
  64 (defsubst geiser-impl--feature (impl)
  65   (intern (format "geiser-%s" impl)))
  66
  67 (defsubst geiser-impl--load-impl (impl)
  68   (require (geiser-impl--feature impl)
  69            (cdr (assq impl geiser-impl--load-files))
  70            t))
  71
  72 (defsubst geiser-impl--methods (impl)
  73   (cdr (assq impl geiser-impl--registry)))
  74
  75 (defun geiser-impl--method (method &optional impl)
  76   (let ((impl (or impl
  77                   geiser-impl--implementation
  78                   geiser-default-implementation)))
  79     (cadr (assq method (geiser-impl--methods impl)))))
  80
  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))))
  84
  85 (defun geiser-impl--method-doc (method doc)
  86   (push (cons method doc) geiser-impl--method-docs))
  87
  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))
  91
  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))
  95
  96 (defmacro geiser-impl--define-caller (fun-name method arglist doc)
  97   (let ((m (make-symbol "method-candidate"))
  98         (impl (make-symbol "implementation-name")))
  99     `(progn
 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)
 104
 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)))
 110
 111 (defsubst geiser-activate-implementation (impl)
 112   (add-to-list 'geiser-active-implementations impl))
 113
 114 (defsubst geiser-deactivate-implementation (impl)
 115   (setq geiser-active-implementations
 116         (delq impl geiser-active-implementations)))
 117
 118 (defsubst geiser-impl--active-p (impl)
 119   (memq impl geiser-active-implementations))
 120
 121 \f
 122 ;;; Defining implementations:
 123
 124 (defun geiser-impl--normalize-method (m)
 125   (when (and (listp m)
 126              (= 2 (length m))
 127              (symbolp (car m)))
 128     (if (functionp (cadr m)) m
 129       `(,(car m) (lambda (&rest) ,(cadr m))))))
 130
 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)))
 140
 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."
 150                                 name))
 151           (ask (make-symbol "ask")))
 152       `(progn
 153          (geiser-impl--define ,load-file-name ',name ',parent ',methods)
 154          (require 'geiser-repl)
 155          (require 'geiser-menu)
 156          (defun ,runner ()
 157            ,runner-doc
 158            (interactive)
 159            (run-geiser ',name))
 160          (defun ,switcher (&optional ,ask)
 161            ,switcher-doc
 162            (interactive "P")
 163            (switch-to-geiser ,ask ',name))
 164          (geiser-menu--add-impl ',name ',runner ',switcher)
 165          (provide ',(geiser-impl--feature name))))))
 166
 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))
 170
 171 \f
 172 ;;; Trying to guess the scheme implementation:
 173
 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."))
 178
 179 (put 'geiser-scheme-implementation 'safe-local-variable 'symbolp)
 180
 181 (defun geiser-impl--match-impl (desc bn)
 182   (let ((rx (if (eq (car desc) 'regexp)
 183                 (cadr desc)
 184               (format "^%s" (regexp-quote (cadr desc))))))
 185     (and rx (string-match-p rx bn))))
 186
 187 (defvar geiser-impl--impl-prompt-history nil)
 188
 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))))))
 196
 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.")
 200
 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))
 209       (catch 'impl
 210         (dolist (impl geiser-active-implementations)
 211           (when (geiser-impl--check-buffer impl)
 212             (throw 'impl impl)))
 213         (let ((bn (buffer-file-name)))
 214           (when bn
 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))))
 221
 222 \f
 223 ;;; Using implementations:
 224
 225 (defsubst geiser-impl--registered-method (impl method fallback)
 226   (let ((m (geiser-impl--method method impl)))
 227     (if (fboundp m) m
 228       (or fallback (error "%s not defined for %s implementation"
 229                           method impl)))))
 230
 231 (defsubst geiser-impl--registered-value (impl method fallback)
 232   (let ((m (geiser-impl--method method impl)))
 233     (if (functionp m) (funcall m) fallback)))
 234
 235 (defun geiser-impl--set-buffer-implementation (&optional impl prompt)
 236   (let ((impl (or impl (geiser-impl--guess prompt))))
 237     (when impl
 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)))))))
 247
 248 (defmacro with--geiser-implementation (impl &rest body)
 249   (let* ((mbindings (mapcar (lambda (m)
 250                               `(,(nth 0 m)
 251                                 (geiser-impl--registered-method ,impl
 252                                                                 ',(nth 1 m)
 253                                                                 ',(nth 2 m))))
 254                             geiser-impl--local-methods))
 255          (vbindings (mapcar (lambda (m)
 256                               `(,(nth 0 m)
 257                                 (geiser-impl--registered-value ,impl
 258                                                                ',(nth 1 m)
 259                                                                ',(nth 2 m))))
 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)
 265
 266 \f
 267 ;;; Reload support:
 268
 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))))
 274
 275 \f
 276 (provide 'geiser-impl)
 277
 278 \f
 279 ;;; Initialization:
 280 ;; After providing 'geiser-impl, so that impls can use us.
 281 (mapc 'geiser-impl--load-impl geiser-active-implementations)
 282
 283 ;;; geiser-impl.el ends here