elisp/geiser-racket.el

   1 ;; geiser-racket.el -- geiser support for Racket scheme
   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 Apr 25, 2009 21:13
  11
  12 \f
  13
  14 (require 'geiser-edit)
  15 (require 'geiser-doc)
  16 (require 'geiser-eval)
  17 (require 'geiser-syntax)
  18 (require 'geiser-custom)
  19 (require 'geiser-base)
  20
  21 \f
  22 ;;; Customization:
  23
  24 (defgroup geiser-racket nil
  25   "Customization for Geiser's Racket flavour."
  26   :group 'geiser)
  27
  28 (geiser-custom--defcustom geiser-racket-binary
  29   (cond ((eq system-type 'windows-nt) "Racket.exe")
  30         (t "racket"))
  31   "Name to use to call the racket executable when starting a REPL."
  32   :type '(choice string (repeat string))
  33   :group 'geiser-racket)
  34
  35 (geiser-custom--defcustom geiser-racket-gracket-binary
  36   (cond ((eq system-type 'windows-nt) "GRacket-text.exe")
  37         (t "gracket-text"))
  38   "Name to use to call the gracket executable when starting a REPL.
  39 This executable is used by `run-gracket', and, if
  40 `geiser-racket-use-gracket-p' is set to t, by `run-racket'."
  41   :type '(choice string (repeat string))
  42   :group 'geiser-racket)
  43
  44 (geiser-custom--defcustom geiser-racket-collects nil
  45   "A list of paths to be added to racket's collection directories."
  46   :type '(repeat file)
  47   :group 'geiser-racket)
  48
  49 (geiser-custom--defcustom geiser-racket-init-file "~/.racket-geiser"
  50   "Initialization file with user code for the racket REPL."
  51   :type 'string
  52   :group 'geiser-racket)
  53
  54 (geiser-custom--defcustom geiser-racket-use-gracket-p nil
  55   "Whether to use the gracket binary to start Racket REPLs."
  56   :type 'boolean
  57   :group 'geiser-racket)
  58
  59
  60 \f
  61 ;;; REPL support:
  62
  63 (defsubst geiser-racket--real-binary ()
  64   (if geiser-racket-use-gracket-p
  65       geiser-racket-gracket-binary
  66     geiser-racket-binary))
  67
  68 (defun geiser-racket--binary ()
  69   (let ((binary (geiser-racket--real-binary)))
  70     (if (listp binary) (car binary) binary)))
  71
  72 (defun geiser-racket--parameters ()
  73   "Return a list with all parameters needed to start racket.
  74 This function uses `geiser-racket-init-file' if it exists."
  75   (let ((init-file (and (stringp geiser-racket-init-file)
  76                         (expand-file-name geiser-racket-init-file)))
  77         (binary (geiser-racket--real-binary)))
  78     `("-i" "-q"
  79       "-S" ,(expand-file-name "racket/" geiser-scheme-dir)
  80       ,@(apply 'append (mapcar (lambda (p) (list "-S" p)) geiser-racket-collects))
  81       ,@(and (listp binary) (cdr binary))
  82       ,@(and init-file (file-readable-p init-file) (list "-f" init-file))
  83       "-f" ,(expand-file-name "racket/geiser.rkt" geiser-scheme-dir))))
  84
  85 (defconst geiser-racket--prompt-regexp "^=?\\(mzscheme\\|racket\\)@[^ ]*?> ")
  86
  87 \f
  88 ;;; Evaluation support:
  89
  90 (defun geiser-racket--language ()
  91   (save-excursion
  92     (goto-char (point-min))
  93     (if (re-search-forward
  94          "^\\(?:#lang\\|(module +[^ ]+?\\) +\\([^ ]+?\\|([^)]+)\\) *$" nil t)
  95         (car (geiser-syntax--read-from-string (match-string-no-properties 1)))
  96       :f)))
  97
  98 (defun geiser-racket--geiser-procedure (proc)
  99   (if (memq proc '(eval compile))
 100       `((dynamic-require 'geiser 'geiser:eval) ',(geiser-racket--language))
 101     `(dynamic-require 'geiser ',(intern (format "geiser:%s" proc)))))
 102
 103 (defconst geiser-racket--module-re
 104   "^(module +\\([^ ]+\\)")
 105
 106 (defun geiser-racket--explicit-module ()
 107   (save-excursion
 108     (goto-char (point-min))
 109     (and (re-search-forward geiser-racket--module-re nil t)
 110          (ignore-errors
 111            (car (geiser-syntax--read-from-string
 112                  (match-string-no-properties 1)))))))
 113
 114 (defsubst geiser-racket--implicit-module ()
 115   (save-excursion
 116     (goto-char (point-min))
 117     (if (re-search-forward "^#lang " nil t)
 118         (buffer-file-name)
 119       :f)))
 120
 121 (defun geiser-racket--get-module (&optional module)
 122   (cond ((and (null module) (buffer-file-name)))
 123         ;; (geiser-racket--explicit-module)
 124         ((null module) (geiser-racket--implicit-module))
 125         ((symbolp module) module)
 126         ((and (stringp module) (file-name-absolute-p module)) module)
 127         ((stringp module) (intern module))
 128         (t nil)))
 129
 130 (defun geiser-racket--symbol-begin (module)
 131   (save-excursion (skip-syntax-backward "^-()>") (point)))
 132
 133 (defun geiser-racket--enter-command (module)
 134   (when (stringp module)
 135     (cond ((zerop (length module)) ",enter #f")
 136           ((file-name-absolute-p module) (format ",enter (file %S)" module))
 137           (t (format ",enter %s" module)))))
 138
 139 (defun geiser-racket--import-command (module)
 140   (and (stringp module)
 141        (not (zerop (length module)))
 142        (format "(require %s)" module)))
 143
 144 (defun geiser-racket--exit-command ()
 145   (not (geiser-eval--send/result '(:eval (exit) geiser/emacs))))
 146
 147 (defconst geiser-racket--binding-forms
 148   '(for for/list for/hash for/hasheq for/and for/or
 149     for/lists for/first for/last for/fold
 150     for: for/list: for/hash: for/hasheq: for/and: for/or:
 151     for/lists: for/first: for/last: for/fold:))
 152
 153 (defconst geiser-racket--binding-forms*
 154   '(for* for*/list for*/lists for*/hash for*/hasheq for*/and
 155     for*/or for*/first for*/last for*/fold
 156     for*: for*/list: for*/lists: for*/hash: for*/hasheq: for*/and:
 157     for*/or: for*/first: for*/last: for*/fold:))
 158 \f
 159 ;;; External help
 160
 161 (defsubst geiser-racket--get-help (symbol module)
 162   (geiser-eval--send/wait
 163    `(:eval (get-help ',symbol (:module ,module)) geiser/autodoc)))
 164
 165 (defun geiser-racket--external-help (id module)
 166   (message "Requesting help for '%s'..." id)
 167   (let ((out (geiser-eval--retort-output
 168               (geiser-racket--get-help id module))))
 169     (when (and out (string-match " but provided by:\n +\\(.+\\)\n" out))
 170       (geiser-racket--get-help id (match-string 1 out))))
 171   (minibuffer-message "%s done" (current-message))
 172   t)
 173
 174 \f
 175 ;;; Error display
 176
 177 (defconst geiser-racket--file-rxs
 178   '(nil
 179     "path:\"?\\([^>\"\n]+\\)\"?>"
 180     "module: \"\\([^>\"\n]+\\)\""))
 181
 182 (defconst geiser-racket--geiser-file-rx
 183   (format "^%s/?racket/geiser" (regexp-quote geiser-scheme-dir)))
 184
 185 (defun geiser-racket--purge-trace ()
 186   (save-excursion
 187     (while (re-search-forward geiser-racket--geiser-file-rx nil t)
 188       (kill-whole-line))))
 189
 190 (defun geiser-racket--display-error (module key msg)
 191   (when key
 192     (insert "Error: ")
 193     (geiser-doc--insert-button key nil 'racket)
 194     (newline 2))
 195   (when msg
 196     (let ((p (point)))
 197       (insert msg)
 198       (when key
 199         (let ((end (point)))
 200         (goto-char p)
 201         (geiser-racket--purge-trace)
 202         (mapc 'geiser-edit--buttonize-files geiser-racket--file-rxs)
 203         (goto-char end)
 204         (newline)))))
 205   (or key (not (zerop (length msg)))))
 206
 207 \f
 208 ;;; Trying to ascertain whether a buffer is mzscheme scheme:
 209
 210 (defun geiser-racket--guess ()
 211   (or (save-excursion
 212         (goto-char (point-min))
 213         (re-search-forward "#lang " nil t))
 214       (geiser-racket--explicit-module)))
 215
 216 \f
 217 ;;; Implementation definition:
 218
 219 (define-geiser-implementation racket
 220   (unsupported-procedures '(callers callees generic-methods))
 221   (binary geiser-racket--binary)
 222   (arglist geiser-racket--parameters)
 223   (startup)
 224   (prompt-regexp geiser-racket--prompt-regexp)
 225   (marshall-procedure geiser-racket--geiser-procedure)
 226   (find-module geiser-racket--get-module)
 227   (enter-command geiser-racket--enter-command)
 228   (import-command geiser-racket--import-command)
 229   (exit-command geiser-racket--exit-command)
 230   (find-symbol-begin geiser-racket--symbol-begin)
 231   (display-error geiser-racket--display-error)
 232   (display-help geiser-racket--external-help)
 233   (check-buffer geiser-racket--guess)
 234   (binding-forms geiser-racket--binding-forms)
 235   (binding-forms* geiser-racket--binding-forms*))
 236
 237 (geiser-impl--add-to-alist 'regexp "\\.ss$" 'racket t)
 238 (geiser-impl--add-to-alist 'regexp "\\.rkt$" 'racket t)
 239
 240 (defun run-gracket ()
 241   "Start the Racket REPL using gracket instead of plain racket."
 242   (interactive)
 243   (let ((geiser-racket-use-gracket-p t))
 244     (run-racket)))
 245
 246 \f
 247 (provide 'geiser-racket)
 248 ;;; geiser-racket.el ends here