elisp/geiser-racket.el

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