;; geiser-racket.el -- geiser support for Racket scheme ;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Jose Antonio Ortega Ruiz ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the Modified BSD License. You should ;; have received a copy of the license along with this program. If ;; not, see . ;; Start date: Sat Apr 25, 2009 21:13 (require 'geiser-edit) (require 'geiser-doc) (require 'geiser-eval) (require 'geiser-image) (require 'geiser-syntax) (require 'geiser-custom) (require 'geiser-base) (require 'geiser) (eval-when-compile (require 'cl)) ;;; Customization: (defgroup geiser-racket nil "Customization for Geiser's Racket flavour." :group 'geiser) (geiser-custom--defcustom geiser-racket-binary (cond ((eq system-type 'windows-nt) "Racket.exe") (t "racket")) "Name to use to call the racket executable when starting a REPL." :type '(choice string (repeat string)) :group 'geiser-racket) (geiser-custom--defcustom geiser-racket-gracket-binary (cond ((eq system-type 'windows-nt) "GRacket-text.exe") (t "gracket-text")) "Name to use to call the gracket executable when starting a REPL. This executable is used by `run-gracket', and, if `geiser-racket-use-gracket-p' is set to t, by `run-racket'." :type '(choice string (repeat string)) :group 'geiser-racket) (geiser-custom--defcustom geiser-racket-collects nil "A list of paths to be added to racket's collection directories." :type '(repeat file) :group 'geiser-racket) (geiser-custom--defcustom geiser-racket-init-file "~/.racket-geiser" "Initialization file with user code for the racket REPL." :type 'string :group 'geiser-racket) (geiser-custom--defcustom geiser-racket-use-gracket-p nil "Whether to use the gracket binary to start Racket REPLs." :type 'boolean :group 'geiser-racket) (geiser-custom--defcustom geiser-racket-extra-keywords '("define-syntax-rule" "provide" "require" "unless" "when" "with-handlers") "Extra keywords highlighted in Racket buffers." :type '(repeat string) :group 'geiser-racket) (geiser-custom--defcustom geiser-racket-case-sensitive-p t "Non-nil means keyword highlighting is case-sensitive." :type 'boolean :group 'geiser-racket) ;;; REPL support: (defsubst geiser-racket--real-binary () (if geiser-racket-use-gracket-p geiser-racket-gracket-binary geiser-racket-binary)) (defun geiser-racket--binary () (let ((binary (geiser-racket--real-binary))) (if (listp binary) (car binary) binary))) (defun geiser-racket--parameters () "Return a list with all parameters needed to start racket. This function uses `geiser-racket-init-file' if it exists." (let ((init-file (and (stringp geiser-racket-init-file) (expand-file-name geiser-racket-init-file))) (binary (geiser-racket--real-binary)) (rackdir (expand-file-name "racket/" geiser-scheme-dir))) `("-i" "-q" "-S" ,rackdir ,@(apply 'append (mapcar (lambda (p) (list "-S" p)) geiser-racket-collects)) ,@(and (listp binary) (cdr binary)) ,@(and init-file (file-readable-p init-file) (list "-f" init-file)) "-f" ,(expand-file-name "geiser/startup.rkt" rackdir)))) (defconst geiser-racket--prompt-regexp "\\(mzscheme\\|racket\\)@[^ ]*> ") ;;; Remote REPLs (defun connect-to-racket () "Start a Racket REPL connected to a remote process. The remote process needs to be running a REPL server started using start-geiser, a procedure in the geiser/server module." (interactive) (geiser-connect 'racket)) ;;; Evaluation support: (defconst geiser-racket--module-re "^(module[+*]? +\\([^ ]+\\)\\W+\\([^ ]+\\)?") (defun geiser-racket--explicit-module () (save-excursion (ignore-errors (while (not (zerop (geiser-syntax--nesting-level))) (backward-up-list))) (and (looking-at geiser-racket--module-re) (let ((mod (match-string-no-properties 1)) (lang (match-string-no-properties 2))) (cons (geiser-syntax--form-from-string mod) (geiser-syntax--form-from-string lang)))))) (defun geiser-racket--language () (or (cdr (geiser-racket--explicit-module)) (save-excursion (goto-char (point-min)) (if (re-search-forward "^#lang +\\([^ ]+\\)" nil t) (geiser-syntax--form-from-string (match-string-no-properties 1)))) "#f")) (defun geiser-racket--implicit-module () (save-excursion (goto-char (point-min)) (when (re-search-forward "^#lang " nil t) (buffer-file-name)))) (defun geiser-racket--find-module () (let ((bf (geiser-racket--implicit-module)) (sub (car (geiser-racket--explicit-module)))) (cond ((and (not bf) (not sub)) nil) ((and (not bf) sub) sub) (sub `(submod (file ,bf) ,sub)) (t bf)))) (defun geiser-racket--enter-command (module) (when (or (stringp module) (listp module)) (cond ((zerop (length module)) ",enter #f") ((or (listp module) (file-name-absolute-p module)) (format ",enter %S" module)) (t (format ",enter %s" module))))) (defun geiser-racket--geiser-procedure (proc &rest args) (case proc ((eval compile) (format ",geiser-eval %s %s %s" (or (car args) "#f") (geiser-racket--language) (mapconcat 'identity (cdr args) " "))) ((load-file compile-file) (format ",geiser-load %S" (geiser-racket--find-module))) ((no-values) ",geiser-no-values") (t (format ",apply geiser:%s (%s)" proc (mapconcat 'identity args " "))))) (defun geiser-racket--get-module (&optional module) (cond ((null module) (or (geiser-racket--find-module) :f)) ((symbolp module) module) ((and (stringp module) (file-name-absolute-p module)) module) ((stringp module) (make-symbol module)) (t nil))) (defun geiser-racket--symbol-begin (module) (save-excursion (skip-syntax-backward "^-()>") (point))) (defun geiser-racket--import-command (module) (and (stringp module) (not (zerop (length module))) (format "(require %s)" module))) (defun geiser-racket--exit-command () (comint-send-eof) (get-buffer-process (current-buffer))) (defconst geiser-racket--binding-forms '("for" "for/list" "for/hash" "for/hasheq" "for/and" "for/or" "for/lists" "for/first" "for/last" "for/fold" "for:" "for/list:" "for/hash:" "for/hasheq:" "for/and:" "for/or:" "for/lists:" "for/first:" "for/last:" "for/fold:" "define-syntax-rule")) (defconst geiser-racket--binding-forms* '("for*" "for*/list" "for*/lists" "for*/hash" "for*/hasheq" "for*/and" "for*/or" "for*/first" "for*/last" "for*/fold" "for*:" "for*/list:" "for*/lists:" "for*/hash:" "for*/hasheq:" "for*/and:" "for*/or:" "for*/first:" "for*/last:" "for*/fold:")) ;;; External help (defsubst geiser-racket--get-help (symbol module) (geiser-eval--send/wait `(:scm ,(format ",help %s %s" symbol module)))) (defun geiser-racket--external-help (id module) (message "Looking up manual for '%s'..." id) (let* ((ret (geiser-racket--get-help id (format "%S" module))) (out (geiser-eval--retort-output ret)) (ret (if (and out (string-match " but provided by:\n +\\(.+\\)\n" out)) (geiser-racket--get-help id (match-string 1 out)) ret))) (unless (string-match "^Sending to web browser.+" (geiser-eval--retort-output ret)) (minibuffer-message "%s not found" (current-message))) t)) ;;; Error display (defconst geiser-racket--file-rxs '(nil "path:\"?\\([^>\"\n]+\\)\"?>" "module: \"\\([^>\"\n]+\\)\"")) (defconst geiser-racket--geiser-file-rx (format "^ *%s/?racket/geiser" (regexp-quote geiser-scheme-dir))) (defun geiser-racket--purge-trace () (save-excursion (while (re-search-forward geiser-racket--geiser-file-rx nil t) (kill-whole-line)))) (defun geiser-racket--display-error (module key msg) (when key (insert "Error: ") (geiser-doc--insert-button key nil 'racket) (newline 2)) (when msg (let ((p (point))) (insert msg) (let ((end (point))) (goto-char p) (when key (geiser-racket--purge-trace)) (mapc 'geiser-edit--buttonize-files geiser-racket--file-rxs) (goto-char end) (newline)))) (or key (not (zerop (length msg))))) ;;; Trying to ascertain whether a buffer is mzscheme scheme: (defun geiser-racket--guess () (or (save-excursion (goto-char (point-min)) (re-search-forward "#lang " nil t)) (geiser-racket--explicit-module))) ;;; Keywords and syntax (setq geiser-racket-font-lock-forms '(("^#lang\\>" . 0) ("\\[\\(else\\)\\>" . 1) ("(\\(define/match\\)\\W+[[(]?\\(\\w+\\)+\\b" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) (defun geiser-racket--keywords () (append geiser-racket-font-lock-forms (when geiser-racket-extra-keywords `((,(format "[[(]%s\\>" (regexp-opt geiser-racket-extra-keywords 1)) . 1))))) (geiser-syntax--scheme-indent (begin0 1) (case-lambda: 0) (class* defun) (compound-unit/sig 0) (define: defun) (for 1) (for* 1) (for*/and 1) (for*/first 1) (for*/fold 2) (for*/hash 1) (for*/hasheq 1) (for*/hasheqv 1) (for*/last 1) (for*/list 1) (for*/lists 2) (for*/or 1) (for*/product 1) (for*/set 1) (for*/seteq 1) (for*/seteqv 1) (for*/sum 1) (for*/vector 1) (for/and 1) (for/first 1) (for/fold 2) (for/hash 1) (for/hasheq 1) (for/hasheqv 1) (for/last 1) (for/list 1) (for/lists 2) (for/or 1) (for/product 1) (for/set 1) (for/seteq 1) (for/seteqv 1) (for/sum 1) (for/vector 1) (instantiate 2) (interface 1) (lambda/kw 1) (lambda: 1) (let*-values: 1) (let+ 1) (let-values: 1) (let/cc: 1) (let: 1) (letrec-values: 1) (letrec: 1) (local 1) (match-let 1) (match-let-values 1) (match/values 1) (mixin 2) (module defun) (module+ defun) (module* defun) (parameterize-break 1) (quasisyntax/loc 1) (send* 1) (splicing-let 1) (splicing-let-syntax 1) (splicing-let-syntaxes 1) (splicing-let-values 1) (splicing-letrec 1) (splicing-letrec-syntax 1) (splicing-letrec-syntaxes 1) (splicing-letrec-syntaxes+values 1) (splicing-letrec-values 1) (splicing-local 1) (struct 1) (syntax-id-rules defun) (syntax/loc 1) (type-case defun) (unit defun) (unit/sig 2) (with-handlers 1) (with-handlers: 1)) ;;; Startup (defun geiser-racket--startup (remote) (set (make-local-variable 'compilation-error-regexp-alist) `(("^ *\\([^:(\t\n]+\\):\\([0-9]+\\):\\([0-9]+\\):" 1 2 3))) (compilation-setup t) (if geiser-image-cache-dir (geiser-eval--send/wait `(:eval (image-cache ,geiser-image-cache-dir) geiser/user)) (setq geiser-image-cache-dir (geiser-eval--send/result '(:eval (image-cache) geiser/user))))) ;;; Additional commands (defvar geiser-racket--submodule-history ()) (defun geiser-racket--submodule-form (name) (format "module[+*]? %s" (cond ((eq 1 name) "") ((numberp name) (read-string "Submodule name: " nil 'geiser-racket--submodule-history)) ((stringp name) name) (t "")))) (defun geiser-racket-toggle-submodules (&optional name) "Toggle visibility of submodule forms. Use a prefix to be asked for a submodule name." (interactive "p") (geiser-edit--toggle-visibility (geiser-racket--submodule-form name))) (defun geiser-racket-show-submodules (&optional name) "Unconditionally shows all submodule forms. Use a prefix to be asked for a submodule name." (interactive "p") (cond ((eq 1 name) (geiser-edit--show-all)) (t (geiser-edit--show (geiser-racket--submodule-form name))))) (defun geiser-racket-hide-submodules (&optional name) "Unconditionally hides all visible submodules. Use a prefix to be asked for a submodule name." (interactive "p") (geiser-edit--hide (geiser-racket--submodule-form name))) ;;; Implementation definition: (define-geiser-implementation racket (unsupported-procedures '(callers callees generic-methods)) (binary geiser-racket--binary) (arglist geiser-racket--parameters) (repl-startup geiser-racket--startup) (prompt-regexp geiser-racket--prompt-regexp) (marshall-procedure geiser-racket--geiser-procedure) (find-module geiser-racket--get-module) (enter-command geiser-racket--enter-command) (import-command geiser-racket--import-command) (exit-command geiser-racket--exit-command) (find-symbol-begin geiser-racket--symbol-begin) (display-error geiser-racket--display-error) (external-help geiser-racket--external-help) (check-buffer geiser-racket--guess) (keywords geiser-racket--keywords) (case-sensitive geiser-racket-case-sensitive-p) (binding-forms geiser-racket--binding-forms) (binding-forms* geiser-racket--binding-forms*)) (geiser-impl--add-to-alist 'regexp "\\.ss$" 'racket t) (geiser-impl--add-to-alist 'regexp "\\.rkt$" 'racket t) (defun run-gracket () "Start the Racket REPL using gracket instead of plain racket." (interactive) (let ((geiser-racket-use-gracket-p t)) (run-racket))) (provide 'geiser-racket)