elisp/geiser-racket.el

   1 ;; geiser-racket.el -- geiser support for Racket scheme
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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-image)
  18 (require 'geiser-syntax)
  19 (require 'geiser-custom)
  20 (require 'geiser-base)
  21 (require 'geiser)
  22
  23 \f
  24 ;;; Customization:
  25
  26 (defgroup geiser-racket nil
  27   "Customization for Geiser's Racket flavour."
  28   :group 'geiser)
  29
  30 (geiser-custom--defcustom geiser-racket-binary
  31   (cond ((eq system-type 'windows-nt) "Racket.exe")
  32         (t "racket"))
  33   "Name to use to call the racket executable when starting a REPL."
  34   :type '(choice string (repeat string))
  35   :group 'geiser-racket)
  36
  37 (geiser-custom--defcustom geiser-racket-gracket-binary
  38   (cond ((eq system-type 'windows-nt) "GRacket-text.exe")
  39         (t "gracket-text"))
  40   "Name to use to call the gracket executable when starting a REPL.
  41 This executable is used by `run-gracket', and, if
  42 `geiser-racket-use-gracket-p' is set to t, by `run-racket'."
  43   :type '(choice string (repeat string))
  44   :group 'geiser-racket)
  45
  46 (geiser-custom--defcustom geiser-racket-collects nil
  47   "A list of paths to be added to racket's collection directories."
  48   :type '(repeat file)
  49   :group 'geiser-racket)
  50
  51 (geiser-custom--defcustom geiser-racket-init-file "~/.racket-geiser"
  52   "Initialization file with user code for the racket REPL."
  53   :type 'string
  54   :group 'geiser-racket)
  55
  56 (geiser-custom--defcustom geiser-racket-use-gracket-p nil
  57   "Whether to use the gracket binary to start Racket REPLs."
  58   :type 'boolean
  59   :group 'geiser-racket)
  60
  61 (geiser-custom--defcustom geiser-racket-extra-keywords
  62     '("define-syntax-rule" "provide" "require"
  63       "unless" "when" "with-handlers")
  64   "Extra keywords highlighted in Racket buffers."
  65   :type '(repeat string)
  66   :group 'geiser-racket)
  67
  68 (geiser-custom--defcustom geiser-racket-case-sensitive-p t
  69   "Non-nil means keyword highlighting is case-sensitive."
  70   :type 'boolean
  71   :group 'geiser-racket)
  72
  73 \f
  74 ;;; REPL support:
  75
  76 (defsubst geiser-racket--real-binary ()
  77   (if geiser-racket-use-gracket-p
  78       geiser-racket-gracket-binary
  79     geiser-racket-binary))
  80
  81 (defun geiser-racket--binary ()
  82   (let ((binary (geiser-racket--real-binary)))
  83     (if (listp binary) (car binary) binary)))
  84
  85 (defun geiser-racket--parameters ()
  86   "Return a list with all parameters needed to start racket.
  87 This function uses `geiser-racket-init-file' if it exists."
  88   (let ((init-file (and (stringp geiser-racket-init-file)
  89                         (expand-file-name geiser-racket-init-file)))
  90         (binary (geiser-racket--real-binary))
  91         (rackdir (expand-file-name "racket/" geiser-scheme-dir)))
  92     `("-i" "-q"
  93       "-S" ,rackdir
  94       ,@(apply 'append (mapcar (lambda (p) (list "-S" p))
  95                                geiser-racket-collects))
  96       ,@(and (listp binary) (cdr binary))
  97       ,@(and init-file (file-readable-p init-file) (list "-f" init-file))
  98       "-f" ,(expand-file-name "geiser/startup.rkt" rackdir))))
  99
 100 (defconst geiser-racket--prompt-regexp "\\(mzscheme\\|racket\\)@[^ ]*?> ")
 101
 102 (defun geiser-racket--startup (remote)
 103   (if geiser-image-cache-dir
 104       (geiser-eval--send/wait
 105        `(:eval (image-cache ,geiser-image-cache-dir) geiser/user))
 106     (setq geiser-image-cache-dir
 107           (geiser-eval--send/result '(:eval (image-cache) geiser/user)))))
 108
 109 \f
 110 ;;; Remote REPLs
 111
 112 (defun connect-to-racket ()
 113   "Start a Racket REPL connected to a remote process.
 114
 115 The remote process needs to be running a REPL server started
 116 using start-geiser, a procedure in the geiser/server module."
 117   (interactive)
 118   (geiser-connect 'racket))
 119
 120
 121 \f
 122 ;;; Evaluation support:
 123
 124 (defun geiser-racket--language ()
 125   (save-excursion
 126     (goto-char (point-min))
 127     (if (re-search-forward
 128          "^\\(?:#lang\\|(module +[^ ]+?\\) +\\([^ ]+?\\|([^)]+)\\) *$" nil t)
 129         (car (geiser-syntax--read-from-string (match-string-no-properties 1)))
 130       "#f")))
 131
 132 (defun geiser-racket--enter-command (module)
 133   (when (stringp module)
 134     (cond ((zerop (length module)) ",enter #f")
 135           ((file-name-absolute-p module) (format ",enter %S" module))
 136           (t (format ",enter %s" module)))))
 137
 138 (defun geiser-racket--geiser-procedure (proc &rest args)
 139   (case proc
 140     ((eval compile)
 141      (format ",geiser-eval %s %s %s"
 142              (or (car args) "#f")
 143              (geiser-racket--language)
 144              (mapconcat 'identity (cdr args) " ")))
 145     ((load-file compile-file)
 146      (format ",geiser-eval geiser/main racket (geiser:%s %s)"
 147              proc (car args)))
 148     ((no-values) ",geiser-no-values")
 149     (t (format ",apply geiser:%s (%s)" proc (mapconcat 'identity args " ")))))
 150
 151 (defconst geiser-racket--module-re
 152   "^(module +\\([^ ]+\\)")
 153
 154 (defun geiser-racket--explicit-module ()
 155   (save-excursion
 156     (goto-char (point-min))
 157     (and (re-search-forward geiser-racket--module-re nil t)
 158          (ignore-errors
 159            (car (geiser-syntax--read-from-string
 160                  (match-string-no-properties 1)))))))
 161
 162 (defsubst geiser-racket--implicit-module ()
 163   (save-excursion
 164     (goto-char (point-min))
 165     (if (re-search-forward "^#lang " nil t)
 166         (buffer-file-name)
 167       :f)))
 168
 169 (defun geiser-racket--get-module (&optional module)
 170   (cond ((and (null module) (buffer-file-name)))
 171         ;; (geiser-racket--explicit-module)
 172         ((null module) (geiser-racket--implicit-module))
 173         ((symbolp module) module)
 174         ((and (stringp module) (file-name-absolute-p module)) module)
 175         ((stringp module) (make-symbol module))
 176         (t nil)))
 177
 178 (defun geiser-racket--symbol-begin (module)
 179   (save-excursion (skip-syntax-backward "^-()>") (point)))
 180
 181 (defun geiser-racket--import-command (module)
 182   (and (stringp module)
 183        (not (zerop (length module)))
 184        (format "(require %s)" module)))
 185
 186 (defun geiser-racket--exit-command ()
 187   (comint-send-eof)
 188   (get-buffer-process (current-buffer)))
 189
 190 (defconst geiser-racket--binding-forms
 191   '("for" "for/list" "for/hash" "for/hasheq" "for/and" "for/or"
 192     "for/lists" "for/first" "for/last" "for/fold"
 193     "for:" "for/list:" "for/hash:" "for/hasheq:" "for/and:" "for/or:"
 194     "for/lists:" "for/first:" "for/last:" "for/fold:"
 195     "define-syntax-rule"))
 196
 197 (defconst geiser-racket--binding-forms*
 198   '("for*" "for*/list" "for*/lists" "for*/hash" "for*/hasheq" "for*/and"
 199     "for*/or" "for*/first" "for*/last" "for*/fold"
 200     "for*:" "for*/list:" "for*/lists:" "for*/hash:" "for*/hasheq:" "for*/and:"
 201     "for*/or:" "for*/first:" "for*/last:" "for*/fold:"))
 202 \f
 203 ;;; External help
 204
 205 (defsubst geiser-racket--get-help (symbol module)
 206   (geiser-eval--send/wait
 207    `(:eval (get-help ',symbol '(:module ,module)) geiser/autodoc)))
 208
 209 (defun geiser-racket--external-help (id module)
 210   (message "Looking up manual for '%s'..." id)
 211   (let ((out (geiser-eval--retort-output
 212               (geiser-racket--get-help id module))))
 213     (when (and out (string-match " but provided by:\n +\\(.+\\)\n" out))
 214       (geiser-racket--get-help id (match-string 1 out))))
 215   (minibuffer-message "%s done" (current-message))
 216   t)
 217
 218 \f
 219 ;;; Error display
 220
 221 (defconst geiser-racket--file-rxs
 222   '(nil
 223     "path:\"?\\([^>\"\n]+\\)\"?>"
 224     "module: \"\\([^>\"\n]+\\)\""))
 225
 226 (defconst geiser-racket--geiser-file-rx
 227   (format "^%s/?racket/geiser" (regexp-quote geiser-scheme-dir)))
 228
 229 (defun geiser-racket--purge-trace ()
 230   (save-excursion
 231     (while (re-search-forward geiser-racket--geiser-file-rx nil t)
 232       (kill-whole-line))))
 233
 234 (defun geiser-racket--display-error (module key msg)
 235   (when key
 236     (insert "Error: ")
 237     (geiser-doc--insert-button key nil 'racket)
 238     (newline 2))
 239   (when msg
 240     (let ((p (point)))
 241       (insert msg)
 242       (let ((end (point)))
 243         (goto-char p)
 244         (when key (geiser-racket--purge-trace))
 245         (mapc 'geiser-edit--buttonize-files geiser-racket--file-rxs)
 246         (goto-char end)
 247         (newline))))
 248   (or key (not (zerop (length msg)))))
 249
 250 \f
 251 ;;; Trying to ascertain whether a buffer is mzscheme scheme:
 252
 253 (defun geiser-racket--guess ()
 254   (or (save-excursion
 255         (goto-char (point-min))
 256         (re-search-forward "#lang " nil t))
 257       (geiser-racket--explicit-module)))
 258
 259 \f
 260 ;;; Keywords and syntax
 261
 262 (defun geiser-racket--keywords ()
 263   (append '(("^#lang\\>" . 0)
 264             ("\\[\\(else\\)\\>" . 1))
 265           (when geiser-racket-extra-keywords
 266             `((,(format "[[(]%s\\>" (regexp-opt geiser-racket-extra-keywords 1))
 267                . 1)))))
 268
 269 (geiser-syntax--scheme-indent
 270  (begin0 1)
 271  (case-lambda: 0)
 272  (class* defun)
 273  (compound-unit/sig 0)
 274  (define: defun)
 275  (for 1)
 276  (for* 1)
 277  (for*/and 1)
 278  (for*/first 1)
 279  (for*/fold 2)
 280  (for*/hash 1)
 281  (for*/hasheq 1)
 282  (for*/hasheqv 1)
 283  (for*/last 1)
 284  (for*/list 1)
 285  (for*/lists 2)
 286  (for*/or 1)
 287  (for*/product 1)
 288  (for*/sum 1)
 289  (for*/vector 1)
 290  (for/and 1)
 291  (for/first 1)
 292  (for/fold 2)
 293  (for/hash 1)
 294  (for/hasheq 1)
 295  (for/hasheqv 1)
 296  (for/last 1)
 297  (for/list 1)
 298  (for/lists 2)
 299  (for/or 1)
 300  (for/product 1)
 301  (for/sum 1)
 302  (for/vector 1)
 303  (instantiate 2)
 304  (interface 1)
 305  (lambda/kw 1)
 306  (lambda: 1)
 307  (let*-values: 1)
 308  (let+ 1)
 309  (let-values: 1)
 310  (let/cc: 1)
 311  (let: 1)
 312  (letrec-values: 1)
 313  (letrec: 1)
 314  (local 1)
 315  (match-let 1)
 316  (match/values 1)
 317  (mixin 2)
 318  (module defun)
 319  (module+ defun)
 320  (parameterize-break 1)
 321  (quasisyntax/loc 1)
 322  (send* 1)
 323  (splicing-let 1)
 324  (splicing-let-syntax 1)
 325  (splicing-let-syntaxes 1)
 326  (splicing-let-values 1)
 327  (splicing-letrec 1)
 328  (splicing-letrec-syntax 1)
 329  (splicing-letrec-syntaxes 1)
 330  (splicing-letrec-syntaxes+values 1)
 331  (splicing-letrec-values 1)
 332  (splicing-local 1)
 333  (struct 1)
 334  (syntax-id-rules defun)
 335  (syntax/loc 1)
 336  (type-case defun)
 337  (unit defun)
 338  (unit/sig 2)
 339  (with-handlers 1)
 340  (with-handlers: 1))
 341
 342
 343 \f
 344 ;;; Implementation definition:
 345
 346 (define-geiser-implementation racket
 347   (unsupported-procedures '(callers callees generic-methods))
 348   (binary geiser-racket--binary)
 349   (arglist geiser-racket--parameters)
 350   (repl-startup geiser-racket--startup)
 351   (prompt-regexp geiser-racket--prompt-regexp)
 352   (marshall-procedure geiser-racket--geiser-procedure)
 353   (find-module geiser-racket--get-module)
 354   (enter-command geiser-racket--enter-command)
 355   (import-command geiser-racket--import-command)
 356   (exit-command geiser-racket--exit-command)
 357   (find-symbol-begin geiser-racket--symbol-begin)
 358   (display-error geiser-racket--display-error)
 359   (external-help geiser-racket--external-help)
 360   (check-buffer geiser-racket--guess)
 361   (keywords geiser-racket--keywords)
 362   (case-sensitive geiser-racket-case-sensitive-p)
 363   (binding-forms geiser-racket--binding-forms)
 364   (binding-forms* geiser-racket--binding-forms*))
 365
 366 (geiser-impl--add-to-alist 'regexp "\\.ss$" 'racket t)
 367 (geiser-impl--add-to-alist 'regexp "\\.rkt$" 'racket t)
 368
 369 (defun run-gracket ()
 370   "Start the Racket REPL using gracket instead of plain racket."
 371   (interactive)
 372   (let ((geiser-racket-use-gracket-p t))
 373     (run-racket)))
 374
 375 \f
 376 (provide 'geiser-racket)