952 lines
34 KiB
EmacsLisp
952 lines
34 KiB
EmacsLisp
;;; racket-edit.el
|
||
|
||
;; Copyright (c) 2013-2016 by Greg Hendershott.
|
||
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
|
||
|
||
;; Author: Greg Hendershott
|
||
;; URL: https://github.com/greghendershott/racket-mode
|
||
|
||
;; License:
|
||
;; This is free software; you can redistribute it and/or modify it
|
||
;; under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation; either version 2, or (at your option)
|
||
;; any later version. This is distributed in the hope that it will be
|
||
;; useful, but without any warranty; without even the implied warranty
|
||
;; of merchantability or fitness for a particular purpose. See the GNU
|
||
;; General Public License for more details. See
|
||
;; http://www.gnu.org/licenses/ for details.
|
||
|
||
;; racket-mode per se, i.e. the .rkt file buffers
|
||
|
||
(require 'cl-lib)
|
||
(require 'cl-macs)
|
||
(require 'racket-custom)
|
||
(require 'racket-common)
|
||
(require 'racket-complete)
|
||
(require 'racket-util)
|
||
(require 'hideshow)
|
||
(require 'tooltip)
|
||
|
||
(defun racket-run (&optional errortracep)
|
||
"Save and evaluate the buffer in REPL, much like DrRacket's Run.
|
||
|
||
With a C-u prefix, uses errortrace for improved stack traces.
|
||
Otherwise follows the `racket-error-context' setting.
|
||
|
||
If point is within a Racket `module` form, the REPL \"enters\"
|
||
that submodule (uses its language info and namespace).
|
||
|
||
When you run again, the file is evaluated from scratch -- the
|
||
custodian releases resources like threads and the evaluation
|
||
environment is reset to the contents of the file. In other words,
|
||
like DrRacket, this provides the predictability of a \"static\"
|
||
baseline, plus the ability to explore interactively using the
|
||
REPL.
|
||
|
||
See also `racket-run-and-switch-to-repl', which is even more like
|
||
DrRacket's Run because it selects the REPL window (gives it the
|
||
focus), too.
|
||
|
||
If your source file has a syntax or runtime error, a \"skeleton\"
|
||
of your file is evaluated to get identifiers from module
|
||
languages, `require`s, and definitions. That way, things like
|
||
completion and `racket-describe' are more likely to work while
|
||
you edit the file to fix the error. If not even the \"skeleton\"
|
||
evaluation succeeds, you'll have only identifiers provided by
|
||
racket/base, until you fix the error and run again.
|
||
|
||
Output in the `*Racket REPL*` buffer that describes a file and
|
||
position is automatically \"linkified\". Examples of such text
|
||
include:
|
||
|
||
- Racket error messages.
|
||
- `rackunit` test failure location messages.
|
||
- `print`s of `#<path>` objects.
|
||
|
||
To visit these locations, move point there and press RET or mouse
|
||
click. Or, use the standard `next-error' and `previous-error'
|
||
commands.
|
||
|
||
In the `*Racket REPL*` buffer you can issue some special
|
||
commands. Some of them are the foundation for Emacs commands.
|
||
Others are available only as a command in the REPL.
|
||
|
||
- `,help`: See these commands.
|
||
|
||
- `,top`: Reset the REPL to an empty module (i.e. a racket/base namespace).
|
||
|
||
- `,run <module>` : What `racket-run' uses.
|
||
- `<module> = <file> | (<file> <submodule-id> ...)`
|
||
- `<file> = file.rkt | /path/to/file.rkt | \"file.rkt\" | \"/path/to/file.rkt\"`
|
||
|
||
- `,exit`: Exit Racket. Handy in a `#lang` like r5rs where the
|
||
`exit` procedure is not available. (Regardless of how Racket
|
||
exits, the `*Racket REPL*` buffer is not killed and is reused
|
||
if you `racket-run' again.)
|
||
|
||
- `,doc <symbol-or-string>`: Look for `<symbol-or-string>` in
|
||
Racket's documentation. What `racket-doc' uses.
|
||
|
||
- `,cd`, `,pwd`: Change and show `current-directory`."
|
||
(interactive "P")
|
||
(racket--do-run (if errortracep
|
||
'high
|
||
racket-error-context)))
|
||
|
||
(defun racket-run-with-errortrace ()
|
||
"Run with `racket-error-context' temporarily set to 'high.
|
||
This is just `racket-run' with a C-u prefix. Defined as a function so
|
||
it can be a menu target."
|
||
(interactive)
|
||
(racket-run t))
|
||
|
||
(defvar-local racket-user-command-line-arguments
|
||
nil
|
||
"List of command-line arguments to supply to your Racket program.
|
||
|
||
Accessible in your Racket program in the usual way -- the
|
||
parameter `current-command-line-arguments` and friends.
|
||
|
||
This is an Emacs buffer-local variable -- convenient to set as a
|
||
file local variable. For example at the end of your .rkt file:
|
||
|
||
;; Local Variables:
|
||
;; racket-user-command-line-arguments: (\"-f\" \"bar\")
|
||
;; End:
|
||
|
||
Set this way the value must be an unquoted list of strings such
|
||
as:
|
||
|
||
(\"-f\" \"bar\")
|
||
|
||
but NOT:
|
||
|
||
'(\"-f\" \"bar\")
|
||
(list \"-f\" \"bar\")
|
||
")
|
||
|
||
(defun racket--do-run (context-level &optional what-to-run)
|
||
"Helper function for `racket-run'-like commands.
|
||
|
||
Supplies CONTEXT-LEVEL to the back-end ,run command; see run.rkt.
|
||
|
||
If supplied, WHAT-TO-RUN should be a buffer filename, or a cons
|
||
of a file name to a list of submodule symbols. Otherwise, the
|
||
`racket--what-to-run' is used."
|
||
(unless (eq major-mode 'racket-mode)
|
||
(user-error "Current buffer is not a racket-mode buffer"))
|
||
(when (or (buffer-modified-p)
|
||
(and (racket--buffer-file-name)
|
||
(not (file-exists-p (racket--buffer-file-name)))))
|
||
(save-buffer))
|
||
(remove-overlays (point-min) (point-max) 'racket-uncovered-overlay)
|
||
(racket--invalidate-completion-cache)
|
||
(racket--invalidate-type-cache)
|
||
(racket--repl-eval ",run %S %s %s %s %S\n"
|
||
(or what-to-run (racket--what-to-run))
|
||
racket-memory-limit
|
||
racket-pretty-print
|
||
context-level
|
||
racket-user-command-line-arguments))
|
||
|
||
(defun racket--what-to-run ()
|
||
(cons (racket--buffer-file-name) (racket--submod-path)))
|
||
|
||
(defun racket--submod-path ()
|
||
(and (racket--lang-p)
|
||
(racket--modules-at-point)))
|
||
|
||
(defun racket--lang-p ()
|
||
"Is #lang the first sexpr in the file?"
|
||
(save-excursion
|
||
(goto-char 0)
|
||
(ignore-errors
|
||
(forward-sexp)
|
||
(backward-sexp)
|
||
(looking-at (rx "#lang")))))
|
||
|
||
(defun racket--modules-at-point ()
|
||
"List of module names that point is within, from outer to inner.
|
||
Ignores module forms nested (at any depth) in any sort of plain
|
||
or syntax quoting, because those won't be valid Racket syntax."
|
||
(let ((xs nil))
|
||
(condition-case ()
|
||
(save-excursion
|
||
(save-match-data
|
||
(racket--escape-string-or-comment)
|
||
(while t
|
||
(when (racket--looking-at-module-form)
|
||
(push (intern (match-string-no-properties 1)) xs))
|
||
(when (racket--looking-at-quoted-form)
|
||
(push nil xs))
|
||
(backward-up-list))))
|
||
(scan-error xs))
|
||
(racket--take-while xs #'identity)))
|
||
|
||
(defun racket--looking-at-module-form ()
|
||
"Sets match data group 1 to the module name."
|
||
(looking-at (rx ?\(
|
||
(or "module" "module*" "module+")
|
||
(1+ " ")
|
||
(group (+ (or (syntax symbol)
|
||
(syntax word)))))))
|
||
|
||
(defun racket--looking-at-quoted-form ()
|
||
(or (memq (char-before) '(?\' ?\` ?\,))
|
||
(and (eq (char-before (1- (point))) ?\,)
|
||
(eq (char-before) ?\@))
|
||
(looking-at
|
||
(rx ?\(
|
||
(or "quote" "quasiquote"
|
||
"unquote" "unquote-splicing"
|
||
"quote-syntax"
|
||
"syntax" "syntax/loc"
|
||
"quasisyntax" "quasisyntax/loc"
|
||
"unsyntax" "unsyntax-splicing")
|
||
" "))))
|
||
|
||
(defun racket-run-and-switch-to-repl (&optional errortracep)
|
||
"This is `racket-run' followed by `racket-switch-to-repl'.
|
||
|
||
With a C-u prefix, uses errortrace for improved stack traces.
|
||
Otherwise follows the `racket-error-context' setting."
|
||
(interactive "P")
|
||
(racket-run errortracep)
|
||
(racket-repl))
|
||
|
||
(defun racket-racket ()
|
||
"Do `racket <file>` in `*shell*` buffer."
|
||
(interactive)
|
||
(racket--shell (concat racket-program
|
||
" "
|
||
(shell-quote-argument (racket--buffer-file-name)))))
|
||
|
||
(defun racket-test (&optional coverage)
|
||
"Run the `test` submodule.
|
||
|
||
With prefix, runs with coverage instrumentation and highlights
|
||
uncovered code.
|
||
|
||
Put your tests in a `test` submodule. For example:
|
||
|
||
(module+ test
|
||
(require rackunit)
|
||
(check-true #t))
|
||
|
||
rackunit test failure messages show the location. You may use
|
||
`next-error' to jump to the location of each failing test.
|
||
|
||
See also:
|
||
- `racket-fold-all-tests'
|
||
- `racket-unfold-all-tests'
|
||
"
|
||
(interactive "P")
|
||
(racket--do-run (if coverage 'coverage racket-error-context)
|
||
(list 'submod (racket--buffer-file-name) 'test))
|
||
(when coverage
|
||
(message "Running tests with coverage instrumentation enabled...")
|
||
(while (not (racket--repl-command "prompt"))
|
||
(sit-for 0.5))
|
||
(message "Processing coverage results...")
|
||
(pcase (racket--repl-command "get-uncovered")
|
||
((and xs `((,beg0 . ,_) . ,_))
|
||
(dolist (x xs)
|
||
(let ((o (make-overlay (car x) (cdr x))))
|
||
(overlay-put o 'name 'racket-uncovered-overlay)
|
||
(overlay-put o 'priority 100)
|
||
(overlay-put o 'face font-lock-warning-face)))
|
||
(message "Missing coverage in %s place(s)." (length xs))
|
||
(goto-char beg0))
|
||
(_ (message "Full coverage.")))))
|
||
|
||
(defun racket-raco-test ()
|
||
"Do `raco test -x <file>` in `*shell*` buffer.
|
||
To run <file>'s `test` submodule."
|
||
(interactive)
|
||
(racket--shell (concat racket-program
|
||
" -l raco test -x "
|
||
(shell-quote-argument (racket--buffer-file-name)))))
|
||
|
||
(defun racket--shell (cmd)
|
||
(let ((w (selected-window)))
|
||
(save-buffer)
|
||
(pcase (get-buffer-window "*shell*" t)
|
||
(`() (other-window -1))
|
||
(win (select-window win)))
|
||
(with-temp-message cmd
|
||
(shell)
|
||
(pop-to-buffer-same-window "*shell*")
|
||
(comint-send-string "*shell*" (concat cmd "\n"))
|
||
(select-window w)
|
||
(sit-for 3))))
|
||
|
||
|
||
;;; visiting defs and mods
|
||
|
||
(defun racket-visit-definition (&optional prefix)
|
||
"Visit definition of symbol at point.
|
||
|
||
Use \\[racket-unvisit] to return.
|
||
|
||
Note: Only finds symbols defined in the current namespace. You
|
||
may need to invoke `racket-run' on the current buffer, first.
|
||
|
||
Note: Only visits the definition of module level identifiers (i.e.
|
||
things for which Racket's `identifier-binding` function returns a
|
||
list, as opposed to `'lexical`).
|
||
|
||
Note: If the definition is from Racket's `#%kernel` module, it
|
||
will tell you so but won't visit the definition site."
|
||
(interactive "P")
|
||
(let ((sym (racket--identifier-at-point-or-prompt prefix
|
||
"Visit definition of: ")))
|
||
(when sym
|
||
(racket--do-visit-def-or-mod "def" sym))))
|
||
|
||
(defun racket--do-visit-def-or-mod (cmd sym)
|
||
"CMD must be \"def\" or \"mod\". SYM must be `symbolp`."
|
||
(pcase (racket--repl-command "%s %s" cmd sym)
|
||
(`(,path ,line ,col)
|
||
(racket--push-loc)
|
||
(find-file path)
|
||
(goto-char (point-min))
|
||
(forward-line (1- line))
|
||
(forward-char col)
|
||
(message "Type M-, to return"))
|
||
(`kernel
|
||
(message "`%s' defined in #%%kernel -- source not available." sym))
|
||
(_ (when (y-or-n-p "Not found. Run current buffer and try again? ")
|
||
(racket-run)
|
||
(racket--do-visit-def-or-mod cmd sym)))))
|
||
|
||
(defun racket-visit-module (&optional prefix)
|
||
"Visit definition of module at point, e.g. net/url or \"file.rkt\".
|
||
|
||
Use \\[racket-unvisit] to return.
|
||
|
||
Note: Only works if you've `racket-run' the buffer so that its
|
||
namespace is active.
|
||
|
||
See also: `racket-find-collection'."
|
||
(interactive "P")
|
||
(let* ((v (thing-at-point 'filename)) ;matches both net/url and "file.rkt"
|
||
(v (and v (substring-no-properties v)))
|
||
(v (if (or prefix (not v))
|
||
(read-from-minibuffer "Visit module: " (or v ""))
|
||
v)))
|
||
(racket--do-visit-def-or-mod "mod" v)))
|
||
|
||
(defun racket-doc (&optional prefix)
|
||
"View documentation of the identifier or string at point.
|
||
|
||
Uses the default external web browser.
|
||
|
||
If point is an identifier required in the current namespace that
|
||
has help, opens the web browser directly at that help
|
||
topic. (i.e. Uses the identifier variant of racket/help.)
|
||
|
||
Otherwise, opens the 'search for a term' page, where you can
|
||
choose among multiple possibilities. (i.e. Uses the string
|
||
variant of racket/help.)
|
||
|
||
With a C-u prefix, prompts for the identifier or quoted string,
|
||
instead of looking at point."
|
||
(interactive "P")
|
||
(let ((sym (racket--symbol-at-point-or-prompt prefix
|
||
"Racket help for: ")))
|
||
(when sym
|
||
(racket--repl-command "doc %s" sym))))
|
||
|
||
(defvar racket--loc-stack '())
|
||
|
||
(defun racket--push-loc ()
|
||
(push (cons (current-buffer) (point))
|
||
racket--loc-stack))
|
||
|
||
(defun racket-unvisit ()
|
||
"Return from previous `racket-visit-definition' or `racket-visit-module'."
|
||
(interactive)
|
||
(if racket--loc-stack
|
||
(pcase (pop racket--loc-stack)
|
||
(`(,buffer . ,pt)
|
||
(pop-to-buffer-same-window buffer)
|
||
(goto-char pt)))
|
||
(message "Stack empty.")))
|
||
|
||
|
||
;;; code folding
|
||
|
||
;;;###autoload
|
||
(add-to-list 'hs-special-modes-alist
|
||
'(racket-mode "(" ")" ";" nil nil))
|
||
|
||
(defun racket--for-all-tests (verb f)
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(let ((n 0))
|
||
(while (re-search-forward "^(module[+*]? test" (point-max) t)
|
||
(funcall f)
|
||
(cl-incf n)
|
||
(goto-char (match-end 0)))
|
||
(message "%s %d test submodules" verb n))))
|
||
|
||
(defun racket-fold-all-tests ()
|
||
"Fold (hide) all test submodules."
|
||
(interactive)
|
||
(racket--for-all-tests "Folded" 'hs-hide-block))
|
||
|
||
(defun racket-unfold-all-tests ()
|
||
"Unfold (show) all test submodules."
|
||
(interactive)
|
||
(racket--for-all-tests "Unfolded" 'hs-show-block))
|
||
|
||
|
||
;;; macro expansion
|
||
|
||
(defun racket-expand-region (start end &optional prefix)
|
||
"Like `racket-send-region', but macro expand.
|
||
|
||
With C-u prefix, expands fully.
|
||
|
||
Otherwise, expands once. You may use `racket-expand-again'."
|
||
(interactive "rP")
|
||
(unless (region-active-p)
|
||
(user-error "No region"))
|
||
(racket--repl-send-expand-command prefix)
|
||
(racket--send-region-to-repl start end))
|
||
|
||
(defun racket-expand-definition (&optional prefix)
|
||
"Like `racket-send-definition', but macro expand.
|
||
|
||
With C-u prefix, expands fully.
|
||
|
||
Otherwise, expands once. You may use `racket-expand-again'."
|
||
(interactive "P")
|
||
(racket--repl-send-expand-command prefix)
|
||
(racket-send-definition))
|
||
|
||
(defun racket-expand-last-sexp (&optional prefix)
|
||
"Like `racket-send-last-sexp', but macro expand.
|
||
|
||
With C-u prefix, expands fully.
|
||
|
||
Otherwise, expands once. You may use `racket-expand-again'."
|
||
(interactive "P")
|
||
(racket--repl-send-expand-command prefix)
|
||
(racket-send-last-sexp))
|
||
|
||
(defun racket--repl-send-expand-command (prefix)
|
||
(comint-send-string (racket--get-repl-buffer-process)
|
||
(if prefix ",exp!" ",exp ")))
|
||
|
||
(defun racket-expand-again ()
|
||
"Macro expand again the previous expansion done by one of:
|
||
- `racket-expand-region'
|
||
- `racket-expand-definition'
|
||
- `racket-expand-last-sexp'
|
||
- `racket-expand-again'"
|
||
(interactive)
|
||
(comint-send-string (racket--get-repl-buffer-process) ",exp+\n"))
|
||
|
||
|
||
;;; requires
|
||
|
||
(defun racket-tidy-requires ()
|
||
"Make a single top-level `require`, modules sorted, one per line.
|
||
|
||
All top-level `require` forms are combined into a single form.
|
||
Within that form:
|
||
|
||
- A single subform is used for each phase level, sorted in this
|
||
order: for-syntax, for-template, for-label, for-meta, and
|
||
plain (phase 0).
|
||
|
||
- Within each level subform, the modules are sorted:
|
||
|
||
- Collection path modules -- sorted alphabetically.
|
||
|
||
- Subforms such as `only-in`.
|
||
|
||
- Quoted relative requires -- sorted alphabetically.
|
||
|
||
At most one module is listed per line.
|
||
|
||
Note: This only works for requires at the top level of a source
|
||
file using `#lang`. It does *not* work for `require`s inside
|
||
`module` forms.
|
||
|
||
See also: `racket-trim-requires' and `racket-base-requires'."
|
||
(interactive)
|
||
(let* ((reqs (racket--top-level-requires 'find))
|
||
(new (and reqs
|
||
(racket--repl-command "requires/tidy %S" reqs))))
|
||
(unless (string-equal "" new)
|
||
(goto-char (racket--top-level-requires 'kill))
|
||
(insert (concat new "\n")))))
|
||
|
||
(defun racket-trim-requires ()
|
||
"Like `racket-tidy-requires' but also deletes unused modules.
|
||
|
||
Note: This only works when the source file can be evaluated with
|
||
no errors.
|
||
|
||
Note: This only works for requires at the top level of a source
|
||
file using `#lang`. It does *not* work for `require`s inside
|
||
`module` forms.
|
||
|
||
See also: `racket-base-requires'."
|
||
(interactive)
|
||
(when (buffer-modified-p) (save-buffer))
|
||
(let* ((reqs (racket--top-level-requires 'find))
|
||
(new (and reqs
|
||
(racket--repl-command
|
||
"requires/trim \"%s\" %S"
|
||
(racket--buffer-file-name)
|
||
reqs))))
|
||
(unless new
|
||
(user-error "Can't do, source file has error"))
|
||
(goto-char (racket--top-level-requires 'kill))
|
||
(unless (string-equal "" new)
|
||
(insert (concat new "\n")))))
|
||
|
||
(defun racket-base-requires ()
|
||
"Change from `#lang racket` to `#lang racket/base`.
|
||
|
||
Adds explicit requires for modules that are provided by `racket`
|
||
but not by `racket/base`.
|
||
|
||
This is a recommended optimization for Racket applications.
|
||
Avoiding loading all of `racket` can reduce load time and memory
|
||
footprint.
|
||
|
||
Also, as does `racket-trim-requires', this removes unneeded
|
||
modules and tidies everything into a single, sorted require form.
|
||
|
||
Note: This only works when the source file can be evaluated with
|
||
no errors.
|
||
|
||
Note: This only works for requires at the top level of a source
|
||
file using `#lang`. It does *not* work for `require`s inside
|
||
`module` forms.
|
||
|
||
Note: Currently this only helps change `#lang racket` to
|
||
`#lang racket/base`. It does *not* help with other similar conversions,
|
||
such as changing `#lang typed/racket` to `#lang typed/racket/base`."
|
||
(interactive)
|
||
(when (racket--buffer-start-re "^#lang.*? racket/base$")
|
||
(user-error "Already using #lang racket/base. Nothing to change."))
|
||
(unless (racket--buffer-start-re "^#lang.*? racket$")
|
||
(user-error "File does not use use #lang racket. Cannot change."))
|
||
(when (buffer-modified-p) (save-buffer))
|
||
(let* ((reqs (racket--top-level-requires 'find))
|
||
(new (racket--repl-command
|
||
"requires/base \"%s\" %S"
|
||
(racket--buffer-file-name)
|
||
reqs)))
|
||
(unless new
|
||
(user-error "Source file has error"))
|
||
(goto-char (point-min))
|
||
(re-search-forward "^#lang.*? racket$")
|
||
(insert "/base")
|
||
(goto-char (or (racket--top-level-requires 'kill)
|
||
(progn (insert "\n") (point))))
|
||
(unless (string= "" new)
|
||
(insert (concat new "\n")))))
|
||
|
||
(defun racket--buffer-start-re (re)
|
||
(save-excursion
|
||
(ignore-errors
|
||
(goto-char (point-min))
|
||
(re-search-forward re)
|
||
t)))
|
||
|
||
(defun racket--top-level-requires (what)
|
||
"Identify all top-level requires and do WHAT.
|
||
|
||
When WHAT is 'find, returns the top-level require forms.
|
||
|
||
When WHAT is 'kill, kill the top-level requires, returning the
|
||
location of the first one."
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(let ((first-beg nil)
|
||
(requires nil))
|
||
(while (re-search-forward "^(require " nil t)
|
||
(let* ((beg (progn (up-list -1) (point)))
|
||
(end (progn (forward-sexp) (point)))
|
||
(str (buffer-substring-no-properties beg end))
|
||
(sexpr (read str)))
|
||
(unless first-beg (setq first-beg beg))
|
||
(setq requires (cons sexpr requires))
|
||
(when (eq 'kill what)
|
||
(kill-sexp -1)
|
||
(delete-blank-lines))))
|
||
(if (eq 'kill what) first-beg requires))))
|
||
|
||
|
||
;;; racket-check-syntax
|
||
|
||
(defvar racket--highlight-overlays nil)
|
||
|
||
(defun racket--highlight (beg end defp)
|
||
;; Unless one of our highlight overlays already exists there...
|
||
(let ((os (overlays-at beg)))
|
||
(unless (cl-some (lambda (o) (member o racket--highlight-overlays)) os)
|
||
(let ((o (make-overlay beg end)))
|
||
(setq racket--highlight-overlays (cons o racket--highlight-overlays))
|
||
(overlay-put o 'name 'racket-check-syntax-overlay)
|
||
(overlay-put o 'priority 100)
|
||
(overlay-put o 'face (if defp
|
||
racket-check-syntax-def-face
|
||
racket-check-syntax-use-face))))))
|
||
|
||
(defun racket--unhighlight-all ()
|
||
(while racket--highlight-overlays
|
||
(delete-overlay (car racket--highlight-overlays))
|
||
(setq racket--highlight-overlays (cdr racket--highlight-overlays))))
|
||
|
||
(defun racket--non-empty-string-p (v)
|
||
(and (stringp v)
|
||
(not (string-match-p "\\`[ \t\n\r]*\\'" v)))) ;`string-blank-p'
|
||
|
||
(defun racket--point-entered (_old new)
|
||
(pcase (get-text-property new 'help-echo)
|
||
((and s (pred racket--non-empty-string-p))
|
||
(if (and (boundp 'tooltip-mode)
|
||
tooltip-mode
|
||
(fboundp 'window-absolute-pixel-position))
|
||
(pcase (window-absolute-pixel-position new)
|
||
(`(,left . ,top)
|
||
(let ((tooltip-frame-parameters `((left . ,left)
|
||
(top . ,top)
|
||
,@tooltip-frame-parameters)))
|
||
(tooltip-show s))))
|
||
(message "%s" s))))
|
||
(pcase (get-text-property new 'racket-check-syntax-def)
|
||
((and uses `((,beg ,end) . ,_))
|
||
(pcase (get-text-property beg 'racket-check-syntax-use)
|
||
(`(,beg ,end) (racket--highlight beg end t)))
|
||
(dolist (use uses)
|
||
(pcase use (`(,beg ,end) (racket--highlight beg end nil))))))
|
||
(pcase (get-text-property new 'racket-check-syntax-use)
|
||
(`(,beg ,end)
|
||
(racket--highlight beg end t)
|
||
(dolist (use (get-text-property beg 'racket-check-syntax-def))
|
||
(pcase use (`(,beg ,end) (racket--highlight beg end nil)))))))
|
||
|
||
(defun racket--point-left (_old _new)
|
||
(racket--unhighlight-all))
|
||
|
||
(defun racket-check-syntax-mode-quit ()
|
||
(interactive)
|
||
(racket-check-syntax-mode -1))
|
||
|
||
(defun racket-check-syntax-mode-goto-def ()
|
||
"When point is on a use, go to its definition."
|
||
(interactive)
|
||
(pcase (get-text-property (point) 'racket-check-syntax-use)
|
||
(`(,beg ,end) (goto-char beg))))
|
||
|
||
(defun racket-check-syntax-mode-forward-use (amt)
|
||
"When point is on a use, go AMT uses forward. AMT may be negative.
|
||
|
||
Moving before/after the first/last use wraps around.
|
||
|
||
If point is instead on a definition, then go to its first use."
|
||
(pcase (get-text-property (point) 'racket-check-syntax-use)
|
||
(`(,beg ,end)
|
||
(pcase (get-text-property beg 'racket-check-syntax-def)
|
||
(uses (let* ((pt (point))
|
||
(ix-this (cl-loop for ix from 0 to (1- (length uses))
|
||
for use = (nth ix uses)
|
||
when (and (<= (car use) pt) (< pt (cadr use)))
|
||
return ix))
|
||
(ix-next (+ ix-this amt))
|
||
(ix-next (if (> amt 0)
|
||
(if (>= ix-next (length uses)) 0 ix-next)
|
||
(if (< ix-next 0) (1- (length uses)) ix-next)))
|
||
(next (nth ix-next uses)))
|
||
(goto-char (car next))))))
|
||
(_ (pcase (get-text-property (point) 'racket-check-syntax-def)
|
||
(`((,beg ,end) . ,_) (goto-char beg))))))
|
||
|
||
(defun racket-check-syntax-mode-goto-next-use ()
|
||
"When point is on a use, go to the next (sibling) use."
|
||
(interactive)
|
||
(racket-check-syntax-mode-forward-use 1))
|
||
|
||
(defun racket-check-syntax-mode-goto-prev-use ()
|
||
"When point is on a use, go to the previous (sibling) use."
|
||
(interactive)
|
||
(racket-check-syntax-mode-forward-use -1))
|
||
|
||
(defun racket-check-syntax-mode-help ()
|
||
(interactive)
|
||
(describe-function #'racket-check-syntax-mode))
|
||
|
||
(defun racket-check-syntax-mode-rename ()
|
||
(interactive)
|
||
;; If we're on a def, get its uses. If we're on a use, get its def.
|
||
(let* ((pt (point))
|
||
(uses (get-text-property pt 'racket-check-syntax-def))
|
||
(def (get-text-property pt 'racket-check-syntax-use)))
|
||
;; If we got one, get the other.
|
||
(when (or uses def)
|
||
(let* ((uses (or uses (get-text-property (car def) 'racket-check-syntax-def)))
|
||
(def (or def (get-text-property (caar uses) 'racket-check-syntax-use)))
|
||
(locs (cons def uses))
|
||
(strs (mapcar (lambda (loc)
|
||
(apply #'buffer-substring-no-properties loc))
|
||
locs)))
|
||
;; Proceed only if all the strings are the same. (They won't
|
||
;; be for e.g. import bindings.)
|
||
(when (cl-every (lambda (s) (equal (car strs) s))
|
||
(cdr strs))
|
||
(let ((new (read-from-minibuffer (format "Rename %s to: " (car strs))))
|
||
(marker-pairs
|
||
(mapcar (lambda (loc)
|
||
(let ((beg (make-marker))
|
||
(end (make-marker)))
|
||
(set-marker beg (nth 0 loc) (current-buffer))
|
||
(set-marker end (nth 1 loc) (current-buffer))
|
||
(list beg end)))
|
||
locs))
|
||
(point-marker (let ((m (make-marker)))
|
||
(set-marker m (point) (current-buffer)))))
|
||
(racket-check-syntax-mode -1)
|
||
(dolist (marker-pair marker-pairs)
|
||
(let ((beg (marker-position (nth 0 marker-pair)))
|
||
(end (marker-position (nth 1 marker-pair))))
|
||
(delete-region beg end)
|
||
(goto-char beg)
|
||
(insert new)))
|
||
(goto-char (marker-position point-marker))
|
||
(racket-check-syntax-mode 1)))))))
|
||
|
||
(defun racket-check-syntax-mode-goto-next-def ()
|
||
(interactive)
|
||
(let ((pos (next-single-property-change (point) 'racket-check-syntax-def)))
|
||
(when pos
|
||
(unless (get-text-property pos 'racket-check-syntax-def)
|
||
(setq pos (next-single-property-change pos 'racket-check-syntax-def)))
|
||
(and pos (goto-char pos)))))
|
||
|
||
(defun racket-check-syntax-mode-goto-prev-def ()
|
||
(interactive)
|
||
(let ((pos (previous-single-property-change (point) 'racket-check-syntax-def)))
|
||
(when pos
|
||
(unless (get-text-property pos 'racket-check-syntax-def)
|
||
(setq pos (previous-single-property-change pos 'racket-check-syntax-def)))
|
||
(and pos (goto-char pos)))))
|
||
|
||
(define-minor-mode racket-check-syntax-mode
|
||
"Analyze the buffer and annotate with information.
|
||
|
||
The buffer becomes read-only until you exit this minor mode.
|
||
However you may navigate the usual ways. When point is on a
|
||
definition or use, related items are highlighted and
|
||
information is displayed in the echo area. You may also use
|
||
special commands to navigate among the definition and its uses.
|
||
|
||
```
|
||
\\{racket-check-syntax-mode-map}
|
||
```
|
||
"
|
||
:lighter " CheckSyntax"
|
||
:keymap (racket--easy-keymap-define
|
||
'(("q" racket-check-syntax-mode-quit)
|
||
("h" racket-check-syntax-mode-help)
|
||
(("j" "TAB") racket-check-syntax-mode-goto-next-def)
|
||
(("k" "<backtab>") racket-check-syntax-mode-goto-prev-def)
|
||
("." racket-check-syntax-mode-goto-def)
|
||
("n" racket-check-syntax-mode-goto-next-use)
|
||
("p" racket-check-syntax-mode-goto-prev-use)
|
||
("r" racket-check-syntax-mode-rename)))
|
||
(unless (eq major-mode 'racket-mode)
|
||
(setq racket-check-syntax-mode nil)
|
||
(user-error "racket-check-syntax-mode only works with racket-mode"))
|
||
(racket--check-syntax-stop)
|
||
(when racket-check-syntax-mode
|
||
(racket--check-syntax-start)))
|
||
|
||
(defvar racket--check-syntax-start-timeout 30)
|
||
|
||
(defun racket--check-syntax-start ()
|
||
(let ((xs (with-temp-message "Analyzing..."
|
||
(let ((racket-command-timeout racket--check-syntax-start-timeout))
|
||
(racket--repl-command "check-syntax \"%s\""
|
||
(buffer-file-name))))))
|
||
(unless xs
|
||
(racket-check-syntax-mode -1)
|
||
(user-error "No bindings found"))
|
||
(unless (listp xs)
|
||
(racket-check-syntax-mode -1)
|
||
(error "Requires a newer version of Racket."))
|
||
(with-silent-modifications
|
||
(dolist (x xs)
|
||
(pcase x
|
||
(`(,`info ,beg ,end ,str)
|
||
(put-text-property beg end 'help-echo str))
|
||
(`(,`def/uses ,def-beg ,def-end ,uses)
|
||
(add-text-properties def-beg
|
||
def-end
|
||
(list 'racket-check-syntax-def uses
|
||
'point-entered #'racket--point-entered
|
||
'point-left #'racket--point-left))
|
||
(dolist (use uses)
|
||
(pcase-let* ((`(,use-beg ,use-end) use))
|
||
(add-text-properties use-beg
|
||
use-end
|
||
(list 'racket-check-syntax-use (list def-beg
|
||
def-end)
|
||
'point-entered #'racket--point-entered
|
||
'point-left #'racket--point-left)))))))
|
||
(setq buffer-read-only t)
|
||
(setq header-line-format
|
||
"Check Syntax. Buffer is read-only. Press h for help, q to quit.")
|
||
;; Make 'point-entered and 'point-left work in Emacs 25+. Note
|
||
;; that this is somewhat of a hack -- I spent a lot of time
|
||
;; trying to Do the Right Thing using the new
|
||
;; cursor-sensor-mode, but could not get it to work
|
||
;; satisfactorily. See:
|
||
;; http://emacs.stackexchange.com/questions/29813/point-motion-strategy-for-emacs-25-and-older
|
||
(setq-local inhibit-point-motion-hooks nil)
|
||
;; Go to next definition, as an affordance/hint what this does:
|
||
(racket-check-syntax-mode-goto-next-def))))
|
||
|
||
(defun racket--check-syntax-stop ()
|
||
(setq header-line-format nil)
|
||
(with-silent-modifications
|
||
(remove-text-properties (point-min)
|
||
(point-max)
|
||
'(help-echo nil
|
||
racket-check-syntax-def nil
|
||
racket-check-syntax-use nil
|
||
point-entered
|
||
point-left))
|
||
(racket--unhighlight-all)
|
||
(setq buffer-read-only nil)))
|
||
|
||
|
||
;;; align
|
||
|
||
(defun racket-align ()
|
||
"Align values in the same column.
|
||
|
||
Useful for binding forms like `let` and `parameterize`,
|
||
conditionals like `cond` and `match`, association lists, and any
|
||
series of couples like the arguments to `hash`.
|
||
|
||
Before choosing this command, put point on the first of a series
|
||
of \"couples\". A couple is:
|
||
|
||
- A list of two or more sexprs: `[sexpr val sexpr ...]`
|
||
- Two sexprs: `sexpr val`.
|
||
|
||
Each `val` moves to the same column and is
|
||
`prog-indent-sexp'-ed (in case it is a multi-line form).
|
||
|
||
For example with point on the `[` before `a`:
|
||
|
||
Before After
|
||
|
||
(let ([a 12] (let ([a 12]
|
||
[bar 23]) [bar 23])
|
||
....) ....)
|
||
|
||
'([a . 12] '([a . 12]
|
||
[bar . 23]) [bar . 23])
|
||
|
||
(cond [a? #t] (cond [a? #t]
|
||
[b? (f x [b? (f x
|
||
y)] y)]
|
||
[else #f]) [else #f])
|
||
|
||
Or with point on the `'` before `a`:
|
||
|
||
(list 'a 12 (list 'a 12
|
||
'bar 23) 'bar 23)
|
||
|
||
If more than one couple is on the same line, none are aligned,
|
||
because it is unclear where the value column should be. For
|
||
example the following form will not change; `racket-align' will
|
||
display an error message:
|
||
|
||
(let ([a 0][b 1]
|
||
[c 2]) error; unchanged
|
||
....)
|
||
|
||
When a couple's sexprs start on different lines, that couple is
|
||
ignored. Other, single-line couples in the series are aligned as
|
||
usual. For example:
|
||
|
||
(let ([foo (let ([foo
|
||
0] 0]
|
||
[bar 1] [bar 1]
|
||
[x 2]) [x 2])
|
||
....) ....)
|
||
|
||
See also: `racket-unalign'."
|
||
(interactive)
|
||
(save-excursion
|
||
(let ((listp (eq ?\( (char-syntax (char-after))))
|
||
(prev-line 0)
|
||
(max-col 0))
|
||
(racket--for-each-couple listp
|
||
(lambda ()
|
||
(setq max-col (max max-col (current-column)))
|
||
(let ((this-line (line-number-at-pos)))
|
||
(when (= prev-line this-line)
|
||
(user-error
|
||
"Can't align if any couples are on same line"))
|
||
(setq prev-line this-line))))
|
||
(racket--for-each-couple listp
|
||
(lambda ()
|
||
(indent-to max-col)
|
||
(prog-indent-sexp))))))
|
||
|
||
(defun racket-unalign ()
|
||
"The opposite of `racket-align'.
|
||
|
||
Effectively does M-x `just-one-space' and `prog-indent-sexp' for
|
||
each couple's value."
|
||
(interactive)
|
||
(save-excursion
|
||
(let ((listp (eq ?\( (char-syntax (char-after)))))
|
||
(racket--for-each-couple listp
|
||
(lambda ()
|
||
(just-one-space)
|
||
(prog-indent-sexp))))))
|
||
|
||
(defun racket--for-each-couple (listp f)
|
||
"Move point to each value sexp of a couple, and `funcall' F.
|
||
|
||
Only call F when the couple's sexprs are on the same line.
|
||
|
||
When LISTP is true, expects couples to be `[id val]`, else `id val`."
|
||
(save-excursion
|
||
(condition-case ()
|
||
(while t
|
||
(when listp
|
||
(down-list))
|
||
(forward-sexp)
|
||
(let ((line (line-number-at-pos)))
|
||
(forward-sexp)
|
||
(backward-sexp)
|
||
(when (= line (line-number-at-pos))
|
||
;; Defensive: Backup over any prefix or punctuation
|
||
;; chars just in case backward-sexp didn't (although it
|
||
;; should have if our syntax table is correct).
|
||
(while (memq (char-syntax (char-before)) '(?\' ?\.))
|
||
(goto-char (1- (point))))
|
||
(funcall f)))
|
||
;; On to the next couple...
|
||
(if listp
|
||
(up-list)
|
||
(forward-sexp)))
|
||
(scan-error nil))))
|
||
|
||
(provide 'racket-edit)
|
||
|
||
;; racket-edit.el ends here
|