elisp/geiser-racket.el

   1 ;; geiser-racket.el -- geiser support for Racket scheme
   2
   3 ;; Copyright (C) 2009, 2010, 2011 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 (geiser-custom--defcustom geiser-racket-extra-keywords
  60     '("define-syntax-rule" "provide" "require"
  61       "unless" "when" "with-handlers")
  62   "Extra keywords highlighted in Racket buffers."
  63   :type '(repeat string)
  64   :group 'geiser-racket)
  65
  66 \f
  67 ;;; REPL support:
  68
  69 (defsubst geiser-racket--real-binary ()
  70   (if geiser-racket-use-gracket-p
  71       geiser-racket-gracket-binary
  72     geiser-racket-binary))
  73
  74 (defun geiser-racket--binary ()
  75   (let ((binary (geiser-racket--real-binary)))
  76     (if (listp binary) (car binary) binary)))
  77
  78 (defun geiser-racket--parameters ()
  79   "Return a list with all parameters needed to start racket.
  80 This function uses `geiser-racket-init-file' if it exists."
  81   (let ((init-file (and (stringp geiser-racket-init-file)
  82                         (expand-file-name geiser-racket-init-file)))
  83         (binary (geiser-racket--real-binary))
  84         (rackdir (expand-file-name "racket/" geiser-scheme-dir)))
  85     `("-i" "-q"
  86       "-S" ,rackdir
  87       ,@(apply 'append (mapcar (lambda (p) (list "-S" p))
  88                                geiser-racket-collects))
  89       ,@(and (listp binary) (cdr binary))
  90       ,@(and init-file (file-readable-p init-file) (list "-f" init-file))
  91       "-f" ,(expand-file-name "geiser/startup.rkt" rackdir))))
  92
  93 (defconst geiser-racket--prompt-regexp "\\(mzscheme\\|racket\\)@[^ ]*?> ")
  94
  95 \f
  96 ;;; Evaluation support:
  97
  98 (defun geiser-racket--language ()
  99   (save-excursion
 100     (goto-char (point-min))
 101     (if (re-search-forward
 102          "^\\(?:#lang\\|(module +[^ ]+?\\) +\\([^ ]+?\\|([^)]+)\\) *$" nil t)
 103         (car (geiser-syntax--read-from-string (match-string-no-properties 1)))
 104       "#f")))
 105
 106 (defun geiser-racket--enter-command (module)
 107   (when (stringp module)
 108     (cond ((zerop (length module)) ",enter #f")
 109           ((file-name-absolute-p module) (format ",enter %S" module))
 110           (t (format ",enter %s" module)))))
 111
 112 (defun geiser-racket--geiser-procedure (proc &rest args)
 113   (case proc
 114     ((eval compile)
 115      (format ",geiser-eval %s %s %s"
 116              (or (car args) "#f")
 117              (geiser-racket--language)
 118              (mapconcat 'identity (cdr args) " ")))
 119     ((load-file compile-file)
 120      (format ",geiser-eval geiser/main racket (geiser:%s %s)"
 121              proc (car args)))
 122     ((no-values) ",geiser-no-values")
 123     (t (format ",apply geiser:%s (%s)" proc (mapconcat 'identity args " ")))))
 124
 125 (defconst geiser-racket--module-re
 126   "^(module +\\([^ ]+\\)")
 127
 128 (defun geiser-racket--explicit-module ()
 129   (save-excursion
 130     (goto-char (point-min))
 131     (and (re-search-forward geiser-racket--module-re nil t)
 132          (ignore-errors
 133            (car (geiser-syntax--read-from-string
 134                  (match-string-no-properties 1)))))))
 135
 136 (defsubst geiser-racket--implicit-module ()
 137   (save-excursion
 138     (goto-char (point-min))
 139     (if (re-search-forward "^#lang " nil t)
 140         (buffer-file-name)
 141       :f)))
 142
 143 (defun geiser-racket--get-module (&optional module)
 144   (cond ((and (null module) (buffer-file-name)))
 145         ;; (geiser-racket--explicit-module)
 146         ((null module) (geiser-racket--implicit-module))
 147         ((symbolp module) module)
 148         ((and (stringp module) (file-name-absolute-p module)) module)
 149         ((stringp module) (make-symbol module))
 150         (t nil)))
 151
 152 (defun geiser-racket--symbol-begin (module)
 153   (save-excursion (skip-syntax-backward "^-()>") (point)))
 154
 155 (defun geiser-racket--import-command (module)
 156   (and (stringp module)
 157        (not (zerop (length module)))
 158        (format "(require %s)" module)))
 159
 160 (defun geiser-racket--exit-command ()
 161   (comint-send-eof)
 162   (get-buffer-process (current-buffer)))
 163
 164 (defconst geiser-racket--binding-forms
 165   '("for" "for/list" "for/hash" "for/hasheq" "for/and" "for/or"
 166     "for/lists" "for/first" "for/last" "for/fold"
 167     "for:" "for/list:" "for/hash:" "for/hasheq:" "for/and:" "for/or:"
 168     "for/lists:" "for/first:" "for/last:" "for/fold:"
 169     "define-syntax-rule"))
 170
 171 (defconst geiser-racket--binding-forms*
 172   '("for*" "for*/list" "for*/lists" "for*/hash" "for*/hasheq" "for*/and"
 173     "for*/or" "for*/first" "for*/last" "for*/fold"
 174     "for*:" "for*/list:" "for*/lists:" "for*/hash:" "for*/hasheq:" "for*/and:"
 175     "for*/or:" "for*/first:" "for*/last:" "for*/fold:"))
 176 \f
 177 ;;; External help
 178
 179 (defsubst geiser-racket--get-help (symbol module)
 180   (geiser-eval--send/wait
 181    `(:eval (get-help ',symbol '(:module ,module)) geiser/autodoc)))
 182
 183 (defun geiser-racket--external-help (id module)
 184   (message "Looking up manual for '%s'..." id)
 185   (let ((out (geiser-eval--retort-output
 186               (geiser-racket--get-help id module))))
 187     (when (and out (string-match " but provided by:\n +\\(.+\\)\n" out))
 188       (geiser-racket--get-help id (match-string 1 out))))
 189   (minibuffer-message "%s done" (current-message))
 190   t)
 191
 192 \f
 193 ;;; Error display
 194
 195 (defconst geiser-racket--file-rxs
 196   '(nil
 197     "path:\"?\\([^>\"\n]+\\)\"?>"
 198     "module: \"\\([^>\"\n]+\\)\""))
 199
 200 (defconst geiser-racket--geiser-file-rx
 201   (format "^%s/?racket/geiser" (regexp-quote geiser-scheme-dir)))
 202
 203 (defun geiser-racket--purge-trace ()
 204   (save-excursion
 205     (while (re-search-forward geiser-racket--geiser-file-rx nil t)
 206       (kill-whole-line))))
 207
 208 (defun geiser-racket--display-error (module key msg)
 209   (when key
 210     (insert "Error: ")
 211     (geiser-doc--insert-button key nil 'racket)
 212     (newline 2))
 213   (when msg
 214     (let ((p (point)))
 215       (insert msg)
 216       (when key
 217         (let ((end (point)))
 218         (goto-char p)
 219         (geiser-racket--purge-trace)
 220         (mapc 'geiser-edit--buttonize-files geiser-racket--file-rxs)
 221         (goto-char end)
 222         (newline)))))
 223   (or key (not (zerop (length msg)))))
 224
 225 \f
 226 ;;; Trying to ascertain whether a buffer is mzscheme scheme:
 227
 228 (defun geiser-racket--guess ()
 229   (or (save-excursion
 230         (goto-char (point-min))
 231         (re-search-forward "#lang " nil t))
 232       (geiser-racket--explicit-module)))
 233
 234 \f
 235 ;;; Keywords
 236 (defun geiser-racket--keywords ()
 237   (cons '("^#lang\\>" . 0)
 238         (when geiser-racket-extra-keywords
 239           `((,(format "[[(]%s\\>" (regexp-opt geiser-racket-extra-keywords 1))
 240              . 1)))))
 241
 242 \f
 243 ;;; Remote REPLs
 244
 245 (defun connect-to-racket ()
 246   "Start a Racket REPL connected to a remote process.
 247
 248 The remote process needs to be running a REPL server started
 249 using start-geiser, a procedure in the geiser/server module."
 250   (interactive)
 251   (geiser-connect 'racket))
 252
 253
 254 \f
 255 ;;; Implementation definition:
 256
 257 (define-geiser-implementation racket
 258   (unsupported-procedures '(callers callees generic-methods))
 259   (binary geiser-racket--binary)
 260   (arglist geiser-racket--parameters)
 261   (prompt-regexp geiser-racket--prompt-regexp)
 262   (marshall-procedure geiser-racket--geiser-procedure)
 263   (find-module geiser-racket--get-module)
 264   (enter-command geiser-racket--enter-command)
 265   (import-command geiser-racket--import-command)
 266   (exit-command geiser-racket--exit-command)
 267   (find-symbol-begin geiser-racket--symbol-begin)
 268   (display-error geiser-racket--display-error)
 269   (external-help geiser-racket--external-help)
 270   (check-buffer geiser-racket--guess)
 271   (keywords geiser-racket--keywords)
 272   (binding-forms geiser-racket--binding-forms)
 273   (binding-forms* geiser-racket--binding-forms*))
 274
 275 (geiser-impl--add-to-alist 'regexp "\\.ss$" 'racket t)
 276 (geiser-impl--add-to-alist 'regexp "\\.rkt$" 'racket t)
 277
 278 (defun run-gracket ()
 279   "Start the Racket REPL using gracket instead of plain racket."
 280   (interactive)
 281   (let ((geiser-racket-use-gracket-p t))
 282     (run-racket)))
 283
 284 \f
 285 (provide 'geiser-racket)