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