[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[nongnu] elpa/racket-mode 25224889d2: Redesign REPL I/O and add racket-h
|
From: |
ELPA Syncer |
|
Subject: |
[nongnu] elpa/racket-mode 25224889d2: Redesign REPL I/O and add racket-hash-lang-mode |
|
Date: |
Thu, 9 Nov 2023 10:00:15 -0500 (EST) |
branch: elpa/racket-mode
commit 25224889d20b37bfd0d315a656542bb4fe8c2076
Author: Greg Hendershott <git@greghendershott.com>
Commit: Greg Hendershott <git@greghendershott.com>
Redesign REPL I/O and add racket-hash-lang-mode
This commit is a squash of nearly 250 commits from the long-running
branch, `hash-lang`.
Major themes:
1. Change REPL I/O. We no longer use a TCP connection to do I/O for
each REPL. Instead use commands (input) and notifications (output).
Furthermore send various kinds of output as distinct notifications.
2. Support use of hash-lang colors, indent, navigation when editing
and in REPL.
Add racket-hash-lang-mode, an alternative to racket-mode for editing
source files, which uses coloring, indent and navigation supplied by a
lang.
Any number of racket-mode or racket-hash-lang-mode buffers may take
turns using the same racket-repl-mode. The last-run edit buffer's
settings are used in the REPL.
Needs Racket 6.12+ for interval-map-ref/bounds.
Use syntax-color/color-textoid when available (with new-enough
versions of Racket and/or syntax-color-lib) but not required.
3. racket-xp-mode: Do "semantic" highlighting of binding sites.
Intended for use by racket-hash-lang-mode to get more than just lexer
colors.
---
Fixes #482.
Fixes #619.
Fixes #642.
Fixes #663.
Fixes #667.
Fixes #671.
Fixes #672.
Fixes #673.
Closes #64.
Closes #633.
Closes PR #661.
---
.github/workflows/test.yml | 21 +-
Makefile | 17 +-
README.org | 2 +-
doc/arch-pict.rkt | 18 +-
doc/generate.el | 27 +-
doc/racket-mode.org | 48 +-
doc/racket-mode.texi | 548 ++++++++++++++---
racket-back-end.el | 98 +---
racket-cmd.el | 67 ++-
racket-common.el | 105 ++--
racket-custom.el | 168 +++++-
racket-debug.el | 7 +-
racket-edit.el | 12 +-
racket-hash-lang.el | 707 ++++++++++++++++++++++
racket-indent.el | 16 +-
racket-mode.el | 67 ++-
racket-ppss.el | 2 +-
racket-profile.el | 3 +-
racket-repl-buffer-name.el | 4 +-
racket-repl.el | 1163 +++++++++++++++++++++++--------------
racket-stepper.el | 8 +-
racket-util.el | 32 +-
racket-xp.el | 501 ++++++++--------
racket/command-server.rkt | 28 +-
racket/debug.rkt | 29 +-
racket/elisp.rkt | 1 +
racket/error.rkt | 338 +++--------
racket/hash-lang-bridge.rkt | 191 ++++++
racket/hash-lang.rkt | 864 +++++++++++++++++++++++++++
racket/image.rkt | 2 +-
racket/instrument.rkt | 25 +-
racket/interaction.rkt | 63 ++
racket/interactions.rkt | 91 ---
racket/lang-info.rkt | 30 +
racket/main.rkt | 23 +-
racket/print.rkt | 91 ++-
racket/repl-output.rkt | 106 ++++
racket/repl-session.rkt | 38 +-
racket/repl.rkt | 211 +++----
racket/text-lines.rkt | 689 ++++++++++++++++++++++
racket/util.rkt | 25 +-
test/example/compilation-mode.rkt | 12 -
test/racket-tests.el | 222 ++++---
test/racket/hash-lang-test.rkt | 769 ++++++++++++++++++++++++
44 files changed, 5712 insertions(+), 1777 deletions(-)
diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml
index 91aa248cd8..3681d4d44b 100644
--- a/.github/workflows/test.yml
+++ b/.github/workflows/test.yml
@@ -13,9 +13,9 @@ jobs:
emacs_version:
- '25.1' # our minimum supported version
- '26.3'
- - '28.1' # most recent release
+ - '29.1' # most recent release
racket_version:
- - '6.9' # our minimum supported version
+ - '6.12' # our minimum supported version
- 'stable' # most recent release
# Also include bleeding edge snapshots of both Emacs and
# Racket. Note that "allow_failure: true" doesn't seem to
@@ -46,10 +46,12 @@ jobs:
run: make show-versions
- name: Install Emacs Packages
run: make deps
- - name: Compile Elisp
+ - name: Compile Emacs Lisp
run: make compile
- - name: Run Tests
- run: make test
+ - name: Run Emacs Lisp Tests
+ run: make test-elisp
+ - name: Run Racket Tests
+ run: xvfb-run make test-racket
windows:
runs-on: windows-latest
@@ -57,7 +59,7 @@ jobs:
fail-fast: false
matrix:
emacs_version:
- - '28.1' # most recent release
+ - '29.1' # most recent release
racket_version:
- 'stable' # most recent release
name: Windows Emacs ${{ matrix.emacs_version }} and Racket ${{
matrix.racket_version }}
@@ -78,6 +80,7 @@ jobs:
run: make deps
- name: Compile Elisp
run: make compile
- - name: Run Tests
- run: make test
-
+ - name: Run Emacs Lisp Tests
+ run: make test-elisp
+ - name: Run Racket Tests
+ run: make test-racket
diff --git a/Makefile b/Makefile
index dac376a007..87654b81f2 100644
--- a/Makefile
+++ b/Makefile
@@ -7,6 +7,8 @@ help:
# default on PATH. e.g. `EMACS=/path/to/emacs make`.
EMACS ?= emacs
RACKET ?= racket
+# Allow another locations for Emacs packages.
+EMACS_PACKAGES ?= ~/.emacs.d/elpa
show-versions:
@echo `which $(RACKET)`
@@ -14,7 +16,10 @@ show-versions:
@echo `which $(EMACS)`
@$(EMACS) --version
-batch-emacs := $(EMACS) --batch -Q -L . --eval '(package-initialize)'
+batch-emacs := \
+ $(EMACS) --batch -Q -L . \
+ --eval '(setq package-user-dir "$(EMACS_PACKAGES)")' \
+ --eval '(package-initialize)'
byte-compile := \
$(batch-emacs) \
@@ -61,10 +66,16 @@ test-elisp:
--eval '(setq racket-program "$(RACKET)")' \
-f ert-run-tests-batch-and-exit
+# Files to test using `raco test -x`.
+test-x-rkt-files := $(wildcard ./racket/*.rkt) $(wildcard
./racket/commands/*.rkt)
+# Exclude hash-lang.rkt because it will fail to eval on older Rackets;
+# normally we only dynamic-require it. Furthermore its tests are in
+# ./test/racket/hash-lang-test.rkt.
+test-x-rkt-files := $(filter-out ./racket/hash-lang.rkt, $(test-x-rkt-files))
+
test-racket:
+ $(RACKET) -l raco test -x $(test-x-rkt-files)
$(RACKET) -l raco test ./test/racket/
- $(RACKET) -l raco test -x ./racket/*.rkt
- $(RACKET) -l raco test -x ./racket/commands/*.rkt
test-slow:
$(RACKET) -l raco test --submodule slow-test ./racket/imports.rkt
diff --git a/README.org b/README.org
index 2ec5cd287b..bc75f251ae 100644
--- a/README.org
+++ b/README.org
@@ -9,7 +9,7 @@ A variety of Emacs major and minor modes for
[[https://www.racket-lang.org/][Rac
check-syntax, debug, profile, logging, and more. The edit/run
experience is similar to [[https://docs.racket-lang.org/drracket/][DrRacket]].
-Compatible with *Emacs 25.1+* and *Racket 6.9+*.
+Compatible with *Emacs 25.1+* and *Racket 6.12+*.
** Documentation
diff --git a/doc/arch-pict.rkt b/doc/arch-pict.rkt
index fc25633ccd..e7723f9909 100644
--- a/doc/arch-pict.rkt
+++ b/doc/arch-pict.rkt
@@ -9,7 +9,6 @@
(define pipe-color "blue")
(define ssh-color "purple")
-(define tcp-color "brown")
(define host-color (make-color 0 0 0 0.0))
(define front-end-color (make-color #xF0 #xF7 #xF0 1.0))
@@ -48,17 +47,14 @@
(vl-append
(text "Emacs front end" '(bold))
(hc-append
- (text "Command requests/responses via ")
+ (text "Command requests/responses and notifications via ")
(colorize (text "pipe" '(bold)) pipe-color)
(text " or ")
(colorize (text "ssh" '(bold)) ssh-color)
- (text "."))
- (hc-append
- (text "REPL I/O via one ")
- (colorize (text "TCP" '(bold)) tcp-color)
- (text " connection per REPL buffer.")))))
+ (text ".")))))
(define (backend path)
+ (define i/o-color (if (regexp-match? #rx"^/[^:]+:" path) ssh-color
pipe-color))
(box
#:inset 5
#:color (light "black")
@@ -73,17 +69,17 @@
10
(colorize
(box #:inset 5 (text "Commands"))
- (if (regexp-match? #rx"^/[^:]+:" path) ssh-color pipe-color))
+ i/o-color)
(vl-append
4
(colorize (box #:inset 2 (text "REPL 1"))
- tcp-color)
+ i/o-color)
(colorize (box #:inset 2 (text "REPL 2"))
- tcp-color)
+ i/o-color)
(colorize (box #:inset 2
#:segment 2
(text "REPL n" '(italic)))
- tcp-color))))))
+ i/o-color))))))
(define (back-end-source-files)
(box
diff --git a/doc/generate.el b/doc/generate.el
index 70aa0bcdc3..623120219a 100644
--- a/doc/generate.el
+++ b/doc/generate.el
@@ -19,6 +19,7 @@
(require 'racket-unicode-input-method)
(require 'racket-smart-open)
(require 'racket-repl-buffer-name)
+(require 'racket-hash-lang)
(require 'seq)
(defun racket-generate-reference.org ()
@@ -51,6 +52,13 @@
racket-align
racket-unalign
racket-complete-at-point
+ "Hash Langs"
+ racket-hash-lang-mode
+ (racket-hash-lang-backward ,racket-hash-lang-mode-map)
+ (racket-hash-lang-forward ,racket-hash-lang-mode-map)
+ (racket-hash-lang-up ,racket-hash-lang-mode-map)
+ (racket-hash-lang-down ,racket-hash-lang-mode-map)
+ (racket-hash-lang-C-M-q-dwim ,racket-hash-lang-mode-map)
"Explore"
racket-xp-mode
(racket-xp-describe ,racket-xp-mode-map)
@@ -180,7 +188,11 @@
racket-browse-url-function
racket-xp-after-change-refresh-delay
racket-xp-highlight-unused-regexp
+ racket-xp-binding-font-lock-face-modes
racket-documentation-search-location
+ "Hash lang variables"
+ racket-hash-lang-token-face-alist
+ racket-hash-lang-module-language-hook
"REPL variables"
racket-repl-buffer-name-function
racket-submodules-to-run
@@ -241,6 +253,12 @@
racket-xp-unused-face
racket-xp-tail-target-face
racket-xp-tail-position-face
+ racket-xp-binding-lang-face
+ racket-xp-binding-lang-use-face
+ racket-xp-binding-import-face
+ racket-xp-binding-import-use-face
+ racket-xp-binding-local-face
+ racket-xp-binding-local-use-face
racket-logger-config-face
racket-logger-topic-face
racket-logger-fatal-face
@@ -251,7 +269,14 @@
racket-doc-link-face
racket-ext-link-face
racket-doc-output-face
- racket-doc-litchar-face)
+ racket-doc-litchar-face
+ racket-repl-message
+ racket-repl-prompt
+ racket-repl-value
+ racket-repl-error-message
+ racket-repl-error-location
+ racket-repl-stdout
+ racket-repl-stderr)
"Faces to include in the Reference.")
(defun racket-generate--faces ()
diff --git a/doc/racket-mode.org b/doc/racket-mode.org
index 136321511e..0dc0ae0ff3 100644
--- a/doc/racket-mode.org
+++ b/doc/racket-mode.org
@@ -1,7 +1,7 @@
#+OPTIONS: ':t toc:t author:t email:t H:4
#+MACRO: kbd @@texinfo:@kbd{$1}@@ @@html:<kbd>$1</kbd>@@
-#+MACRO: img @@texinfo:@image{$1,,,$2. Command I/O via pipe (local) or ssh
(remote). REPL I/O via one TCP connection per REPL buffer (local/remote). Each
back end provides zero or more REPLs.,.svg}@@
+#+MACRO: img @@texinfo:@image{$1,,,$2. Command I/O via pipe (local) or ssh
(remote). Each back end provides zero or more REPLs.,.svg}@@
#+MACRO: ref @@texinfo:@ref{$1}@@
#+MACRO: see @@texinfo:@xref{$1}@@
@@ -32,11 +32,13 @@ SPDX-License-Identifier: GPL-3.0-or-later
The [[https://www.racket-mode.com/][Racket Mode]] package consists of a
variety of Emacs major and minor modes, including:
-- ~racket-mode~: A major mode for editing ~.rkt~ files.
+- ~racket-mode~: A major mode to edit ~.rkt~ files. Generally assumes ~#lang
racket~.
-- {{{ref(racket-xp-mode)}}}: An optional minor mode that enhances
~racket-mode~ to explain and explore code.
+- {{{ref(racket-hash-lang-mode)}}}: An alternative to ~racket-mode~ using
behavior specified by a ~#lang~ for colors, indent, expression navigation, etc.
/Experimental/.
-- ~racket-repl-mode~: A major mode for running programs providing a REPL.
+- {{{ref(racket-xp-mode)}}}: A minor mode to enhance either edit mode. Explain
and explore code, similar to background check-syntax in Dr Racket.
+
+- ~racket-repl-mode~: A major mode to run programs and use a REPL.
- Various other modes to support specific features:
- {{{ref(racket-logger-mode)}}}
@@ -45,7 +47,7 @@ The [[https://www.racket-mode.com/][Racket Mode]] package
consists of a variety
For code, issues, and pull requests, see the
[[https://github.com/greghendershott/racket-mode][Git repo]].
-To fund this work, see
[[https://github.com/users/greghendershott/sponsorship][GitHub Sponsors]] or
[[https://www.paypal.me/greghendershott][PayPal]].
+To sponsor this work, see
[[https://github.com/users/greghendershott/sponsorship][GitHub Sponsors]] or
[[https://www.paypal.me/greghendershott][PayPal]].
* Install, Update, and Uninstall
@@ -163,6 +165,29 @@ On macOS, downloading Racket doesn't add its ~bin~
directory to your ~PATH~. Eve
You can ~setq~ this directly in your Emacs init file (=~/.emacs= or
=~/.emacs.d/init.el=), or, use {{{kbd(M-x)}}} ~customize~, as you prefer.
+** Which major mode to use
+
+Racket is a programming language.
+
+Racket is also a "language-oriented programming language". Most Racket source
files contain a `#lang` line. The lang may be an s-expression lang like
~racket~, or an at-expression lang like ~scribble/manual~, or something
completely different like ~datalog~ or ~rhombus~.
+
+The Racket Mode package offers a choice of two major modes to use in buffers
for viewing and editing source code. Each has pros and cons.
+
+Whereas ~racket-mode~ is in the tradition of Emacs ~lisp-mode~ and
~scheme-mode~ and assumes s-expression langs, ~racket-hash-lang-mode~ takes the
approach of DrRacket to work for all langs.
+
+- ~racket-mode~ is the original, "classic" mode for ~#lang racket~ and related
s-expression languages. It is implemented entirely in Emacs and does /not/ need
Racket Mode's back end racket process running. Font-lock (coloring) uses rules
for a fixed set of identifiers from ~racket~ lang and popular modules like
~racket/match~. Indentation uses rules for a fixed set of forms, and may be
customized (see below).
+
+- ~racket-hash-lang-mode~ uses font-lock (colors) and indentation determined
by the lang; to get this information it /does/ need the Racket Mode's back end
racket process running. Although basic editing should feel fast, you might
notice some delay when indenting. You might see colors appear after a small
delay (but it will not block editing). Speaking of colors, they will be
"plainer" than ~racket-mode~ -- mostly just for different kinds of tokens like
numbers, comments, strings, and ke [...]
+
+You can use different major modes for different kinds of files:
+
+- For editing ~.rkt~ files and s-expression langs, which mode to use is
personal preference.
+
+- For ~.scrbl~ and at-expression langs like ~scribble/manual~,
~racket-hash-lang-mode~ is probably better than ~racket-mode~. (Note there is
also an unrelated ~scribble-mode~ package.)
+
+- For non-s-expression langs like ~datalog~ or ~rhombus~ (~.rhm~),
~racket-hash-lang-mode~ is definitely better than ~racket-mode~. (Note there is
also an unrelated ~rhombus-mode~ package.)
+
+You can use ~auto-mode-alist~ to tell Emacs which major mode to use initially
for certain file extensions. Also, in a buffer you can use ~M-x racket-mode~
and ~M-x racket-hash-lang-mode~ to switch between them.
** Key bindings
To customize things like key bindings, you can use ~racket-mode-hook~ in your
Emacs init file to modify ~racket-mode-map~. For example, although {{{kbd(C-c
C-c)}}} is bound by default to the ~racket-run~ command, let's say you wanted
{{{kbd(F5)}}} to be an additional binding:
@@ -171,13 +196,16 @@ To customize things like key bindings, you can use
~racket-mode-hook~ in your Em
(add-hook 'racket-mode-hook
(lambda ()
(define-key racket-mode-map (kbd "<f5>") 'racket-run)))
-
#+END_SRC
Likewise for ~racket-repl-mode-hook~ and ~racket-repl-mode-map~.
** Font-lock (syntax highlighting)
+#+BEGIN_QUOTE
+Note: The alternative major mode {{{ref(racket-hash-lang-mode)}}} disables all
of the following behavior and uses colors determined by the #lang.
+#+END_QUOTE
+
Font-lock (as Emacs calls syntax highlighting) can be controlled using the
variable ~font-lock-maximum-decoration~, which defaults to ~t~ (maximum). You
can set it to a number, where ~0~ is the lowest level. You can even supply an
association list to specify different values for different major modes.
Historically you might choose a lower level for speed. These days you might do
so because you prefer a simpler appearance.
@@ -249,12 +277,20 @@ In any case, using the Emacs xref API allows for
consistent command names, short
** Indent
+#+BEGIN_QUOTE
+Note: The alternative major mode {{{ref(racket-hash-lang-mode)}}} disables all
of the following behavior and uses indentation determined by the #lang.
+#+END_QUOTE
+
Indentation can be customized in a way similar to lisp-mode and scheme-mode:
{{{ref(racket-indent-line)}}}.
(Indentation preserves your line breaks. If you want to use an
auto-reformatter --- an expressive pretty printer that chooses line breaks
while computing an optimal layout --- the Racket package
[[https://docs.racket-lang.org/fmt/][fmt]] is supported by the Emacs package
[[https://github.com/lassik/emacs-format-all-the-code][emacs-format-all-the-code]].)
** paredit
+#+BEGIN_QUOTE
+Note: If you use {{{ref(racket-hash-lang-mode)}}}, you can use
~racket-hash-lang-mode-hook~ to enable/disable paredit based on the specific
#lang.
+#+END_QUOTE
+
If you use [[https://melpa.org/#/paredit][paredit]], you might want to add
keybindings to ~paredit-mode-map~:
- Bind the curly brace keys to ~paredit-open-curly~ and ~paredit-close-curly~.
diff --git a/doc/racket-mode.texi b/doc/racket-mode.texi
index 21b73635d1..1f43d1a6f4 100644
--- a/doc/racket-mode.texi
+++ b/doc/racket-mode.texi
@@ -65,6 +65,7 @@ Update
* Updating just Racket Mode::
Configure
+* Which major mode to use::
* Key bindings::
* Font-lock (syntax highlighting)::
* Completion at point::
@@ -83,6 +84,7 @@ Configure
Commands
* Edit::
+* Hash Langs::
* Explore::
* Run::
* Test::
@@ -111,6 +113,15 @@ Edit
* racket-unalign::
* racket-complete-at-point::
+Hash Langs
+
+* racket-hash-lang-mode::
+* racket-hash-lang-backward::
+* racket-hash-lang-forward::
+* racket-hash-lang-up::
+* racket-hash-lang-down::
+* racket-hash-lang-C-M-q-dwim::
+
Explore
* racket-xp-mode::
@@ -178,6 +189,7 @@ Other
Variables
* General variables::
+* Hash lang variables::
* REPL variables::
* Other variables::
* Experimental debugger variables::
@@ -194,8 +206,14 @@ General variables
* racket-browse-url-function::
* racket-xp-after-change-refresh-delay::
* racket-xp-highlight-unused-regexp::
+* racket-xp-binding-font-lock-face-modes::
* racket-documentation-search-location::
+Hash lang variables
+
+* racket-hash-lang-token-face-alist::
+* racket-hash-lang-module-language-hook::
+
REPL variables
* racket-repl-buffer-name-function::
@@ -281,6 +299,12 @@ All
* racket-xp-unused-face::
* racket-xp-tail-target-face::
* racket-xp-tail-position-face::
+* racket-xp-binding-lang-face::
+* racket-xp-binding-lang-use-face::
+* racket-xp-binding-import-face::
+* racket-xp-binding-import-use-face::
+* racket-xp-binding-local-face::
+* racket-xp-binding-local-use-face::
* racket-logger-config-face::
* racket-logger-topic-face::
* racket-logger-fatal-face::
@@ -292,6 +316,13 @@ All
* racket-ext-link-face::
* racket-doc-output-face::
* racket-doc-litchar-face::
+* racket-repl-message::
+* racket-repl-prompt::
+* racket-repl-value::
+* racket-repl-error-message::
+* racket-repl-error-location::
+* racket-repl-stdout::
+* racket-repl-stderr::
@end detailmenu
@end menu
@@ -304,13 +335,16 @@ The @uref{https://www.racket-mode.com/,Racket Mode}
package consists of a variet
@itemize
@item
-@code{racket-mode}: A major mode for editing @code{.rkt} files.
+@code{racket-mode}: A major mode to edit @code{.rkt} files. Generally assumes
@code{#lang racket}.
@item
-@ref{racket-xp-mode}: An optional minor mode that enhances @code{racket-mode}
to explain and explore code.
+@ref{racket-hash-lang-mode}: An alternative to @code{racket-mode} using
behavior specified by a @code{#lang} for colors, indent, expression navigation,
etc. @emph{Experimental}.
@item
-@code{racket-repl-mode}: A major mode for running programs providing a REPL.
+@ref{racket-xp-mode}: A minor mode to enhance either edit mode. Explain and
explore code, similar to background check-syntax in Dr Racket.
+
+@item
+@code{racket-repl-mode}: A major mode to run programs and use a REPL.
@item
Various other modes to support specific features:
@@ -326,7 +360,7 @@ Various other modes to support specific features:
For code, issues, and pull requests, see the
@uref{https://github.com/greghendershott/racket-mode,Git repo}.
-To fund this work, see
@uref{https://github.com/users/greghendershott/sponsorship,GitHub Sponsors} or
@uref{https://www.paypal.me/greghendershott,PayPal}.
+To sponsor this work, see
@uref{https://github.com/users/greghendershott/sponsorship,GitHub Sponsors} or
@uref{https://www.paypal.me/greghendershott,PayPal}.
@node Install Update and Uninstall
@chapter Install, Update, and Uninstall
@@ -490,6 +524,7 @@ On macOS, downloading Racket doesn't add its @code{bin}
directory to your @code{
You can @code{setq} this directly in your Emacs init file (@verb{,~/.emacs,}
or @verb{,~/.emacs.d/init.el,}), or, use @kbd{M-x} @code{customize}, as you
prefer.
@menu
+* Which major mode to use::
* Key bindings::
* Font-lock (syntax highlighting)::
* Completion at point::
@@ -506,6 +541,40 @@ You can @code{setq} this directly in your Emacs init file
(@verb{,~/.emacs,} or
* Ligatures::
@end menu
+@node Which major mode to use
+@section Which major mode to use
+
+Racket is a programming language.
+
+Racket is also a ``language-oriented programming language''. Most Racket
source files contain a `#lang` line. The lang may be an s-expression lang like
@code{racket}, or an at-expression lang like @code{scribble/manual}, or
something completely different like @code{datalog} or @code{rhombus}.
+
+The Racket Mode package offers a choice of two major modes to use in buffers
for viewing and editing source code. Each has pros and cons.
+
+Whereas @code{racket-mode} is in the tradition of Emacs @code{lisp-mode} and
@code{scheme-mode} and assumes s-expression langs, @code{racket-hash-lang-mode}
takes the approach of DrRacket to work for all langs.
+
+@itemize
+@item
+@code{racket-mode} is the original, ``classic'' mode for @code{#lang racket}
and related s-expression languages. It is implemented entirely in Emacs and
does @emph{not} need Racket Mode's back end racket process running. Font-lock
(coloring) uses rules for a fixed set of identifiers from @code{racket} lang
and popular modules like @code{racket/match}. Indentation uses rules for a
fixed set of forms, and may be customized (see below).
+
+@item
+@code{racket-hash-lang-mode} uses font-lock (colors) and indentation
determined by the lang; to get this information it @emph{does} need the Racket
Mode's back end racket process running. Although basic editing should feel
fast, you might notice some delay when indenting. You might see colors appear
after a small delay (but it will not block editing). Speaking of colors, they
will be ``plainer'' than @code{racket-mode} -- mostly just for different kinds
of tokens like numbers, comments, [...]
+@end itemize
+
+You can use different major modes for different kinds of files:
+
+@itemize
+@item
+For editing @code{.rkt} files and s-expression langs, which mode to use is
personal preference.
+
+@item
+For @code{.scrbl} and at-expression langs like @code{scribble/manual},
@code{racket-hash-lang-mode} is probably better than @code{racket-mode}. (Note
there is also an unrelated @code{scribble-mode} package.)
+
+@item
+For non-s-expression langs like @code{datalog} or @code{rhombus}
(@code{.rhm}), @code{racket-hash-lang-mode} is definitely better than
@code{racket-mode}. (Note there is also an unrelated @code{rhombus-mode}
package.)
+@end itemize
+
+You can use @code{auto-mode-alist} to tell Emacs which major mode to use
initially for certain file extensions. Also, in a buffer you can use @code{M-x
racket-mode} and @code{M-x racket-hash-lang-mode} to switch between them.
+
@node Key bindings
@section Key bindings
@@ -522,6 +591,10 @@ Likewise for @code{racket-repl-mode-hook} and
@code{racket-repl-mode-map}.
@node Font-lock (syntax highlighting)
@section Font-lock (syntax highlighting)
+@quotation
+Note: The alternative major mode @ref{racket-hash-lang-mode} disables all of
the following behavior and uses colors determined by the #lang.
+@end quotation
+
Font-lock (as Emacs calls syntax highlighting) can be controlled using the
variable @code{font-lock-maximum-decoration}, which defaults to @code{t}
(maximum). You can set it to a number, where @code{0} is the lowest level. You
can even supply an association list to specify different values for different
major modes.
Historically you might choose a lower level for speed. These days you might do
so because you prefer a simpler appearance.
@@ -623,6 +696,10 @@ In any case, using the Emacs xref API allows for
consistent command names, short
@node Indent
@section Indent
+@quotation
+Note: The alternative major mode @ref{racket-hash-lang-mode} disables all of
the following behavior and uses indentation determined by the #lang.
+@end quotation
+
Indentation can be customized in a way similar to lisp-mode and scheme-mode:
@ref{racket-indent-line}.
(Indentation preserves your line breaks. If you want to use an
auto-reformatter --- an expressive pretty printer that chooses line breaks
while computing an optimal layout --- the Racket package
@uref{https://docs.racket-lang.org/fmt/,fmt} is supported by the Emacs package
@uref{https://github.com/lassik/emacs-format-all-the-code,emacs-format-all-the-code}.)
@@ -630,6 +707,10 @@ Indentation can be customized in a way similar to
lisp-mode and scheme-mode: @re
@node paredit
@section paredit
+@quotation
+Note: If you use @ref{racket-hash-lang-mode}, you can use
@code{racket-hash-lang-mode-hook} to enable/disable paredit based on the
specific #lang.
+@end quotation
+
If you use @uref{https://melpa.org/#/paredit,paredit}, you might want to add
keybindings to @code{paredit-mode-map}:
@itemize
@@ -768,25 +849,25 @@ To learn more about how @emph{many} REPLs are used:
@xref{racket-repl-buffer-nam
In the common case there is only one back end, on the same local host as
Emacs, and it is used for @code{.rkt} files in any directory.
-@image{scenario-0,,, Emacs front end and one local back end. Command I/O via
pipe (local) or ssh (remote). REPL I/O via one TCP connection per REPL buffer
(local/remote). Each back end provides zero or more REPLs.,.svg}
+@image{scenario-0,,, Emacs front end and one local back end. Command I/O via
pipe (local) or ssh (remote). Each back end provides zero or more REPLs.,.svg}
However you can configure using any number of back ends on any number of local
or remote hosts.
As one example, you can have multiple back ends on the local host. One back
end is used for a project under a specific subdirectory, and the other back end
for all others. (Perhaps one project needs Racket built from source, and
everything else uses an installed, older version of Racket. By using different
back ends, not only will @code{racket-run} use the desired version of Racket
for a file, so will commands for documentation or visiting definitions.)
-@image{scenario-1,,, Emacs front end and two local back ends --- one for a
project path. Command I/O via pipe (local) or ssh (remote). REPL I/O via one
TCP connection per REPL buffer (local/remote). Each back end provides zero or
more REPLs.,.svg}
+@image{scenario-1,,, Emacs front end and two local back ends --- one for a
project path. Command I/O via pipe (local) or ssh (remote). Each back end
provides zero or more REPLs.,.svg}
Furthermore, you could work with a project located on a remote host, whose
files you edit using TRAMP. You also want the back end to run there. For a
remote host, Racket Mode copies its back end source files to the remote when
necessary, and runs the back end using ssh.
-@image{scenario-2,,, Emacs front end and a back end on a remote host. Command
I/O via pipe (local) or ssh (remote). REPL I/O via one TCP connection per REPL
buffer (local/remote). Each back end provides zero or more REPLs.,.svg}
+@image{scenario-2,,, Emacs front end and a back end on a remote host. Command
I/O via pipe (local) or ssh (remote). Each back end provides zero or more
REPLs.,.svg}
Of course the remote can also use different back ends for different paths.
-@image{scenario-3,,, Emacs front end and two back ends on a remote host.
Command I/O via pipe (local) or ssh (remote). REPL I/O via one TCP connection
per REPL buffer (local/remote). Each back end provides zero or more REPLs.,.svg}
+@image{scenario-3,,, Emacs front end and two back ends on a remote host.
Command I/O via pipe (local) or ssh (remote). Each back end provides zero or
more REPLs.,.svg}
And of course you can have multiple remotes.
-@image{scenario-4,,, Emacs front end and two back ends each on two remote
hosts. Command I/O via pipe (local) or ssh (remote). REPL I/O via one TCP
connection per REPL buffer (local/remote). Each back end provides zero or more
REPLs.,.svg}
+@image{scenario-4,,, Emacs front end and two back ends each on two remote
hosts. Command I/O via pipe (local) or ssh (remote). Each back end provides
zero or more REPLs.,.svg}
If you need any of these ``fancy'' configurations: @xref{racket-add-back-end}.
@@ -811,6 +892,7 @@ You can also view these by using the normal Emacs help
mechanism:
@menu
* Edit::
+* Hash Langs::
* Explore::
* Run::
* Test::
@@ -1415,6 +1497,141 @@ Completion candidates are drawn from the same symbols
used for
font-lock. This is a static list. If you want dynamic, smarter
completion candidates, enable the minor mode @ref{racket-xp-mode}.
+@node Hash Langs
+@section Hash Langs
+
+@menu
+* racket-hash-lang-mode::
+* racket-hash-lang-backward::
+* racket-hash-lang-forward::
+* racket-hash-lang-up::
+* racket-hash-lang-down::
+* racket-hash-lang-C-M-q-dwim::
+@end menu
+
+@node racket-hash-lang-mode
+@subsection racket-hash-lang-mode
+
+@kbd{M-x} @code{racket-hash-lang-mode}
+
+Use color-lexer, indent, and navigation supplied by a #lang.
+
+An experimental major mode alternative to @ref{racket-mode} for
+source file edit buffers.
+
+In your Emacs configuration, you may want to update the
+variable @code{auto-mode-alist} to use @ref{racket-hash-lang-mode} for
+file extensions like ``.rkt'', ``.scrbl'', and/or ``.rhm''.
+
+See also the customization variable
+@ref{racket-hash-lang-token-face-alist} and the hook variable
+@ref{racket-hash-lang-module-language-hook}.
+
+A discussion of the information provided by a Racket language:
+
+@uref{https://docs.racket-lang.org/tools/lang-languages-customization.html}
+
+Note that langs supply colors only for lexer tokens like strings
+and comments. If you enable the minor mode @ref{racket-xp-mode}, it
+can contribute more colors; see the customization variable
+@ref{racket-xp-binding-font-lock-face-modes}.
+
+@multitable {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
{aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@item Key
+@tab Binding
+@item @kbd{RET}
+@tab @code{newline-and-indent}
+@item @kbd{C-M-q}
+@tab @ref{racket-hash-lang-C-M-q-dwim}
+@item @kbd{C-M-d}
+@tab @ref{racket-hash-lang-down}
+@item @kbd{C-M-u}
+@tab @ref{racket-hash-lang-up}
+@item @kbd{C-M-f}
+@tab @ref{racket-hash-lang-forward}
+@item @kbd{C-M-b}
+@tab @ref{racket-hash-lang-backward}
+@item @kbd{C-M-y}
+@tab @ref{racket-insert-lambda}
+@item @kbd{TAB}
+@tab @code{indent-for-tab-command}
+@item @kbd{C-c C-x C-f}
+@tab @ref{racket-open-require-path}
+@item @kbd{C-c C-e f}
+@tab @ref{racket-expand-file}
+@item @kbd{C-c C-o}
+@tab @ref{racket-profile}
+@item @kbd{C-c C-l}
+@tab @ref{racket-logger}
+@item @kbd{C-c C-t}
+@tab @ref{racket-test}
+@item @kbd{C-c C-z}
+@tab @ref{racket-repl}
+@item @kbd{C-c C-k}
+@tab @ref{racket-run-module-at-point}
+@item @kbd{C-c C-c}
+@tab @ref{racket-run-module-at-point}
+@end multitable
+
+
+
+
+In addition to any hooks its parent mode @code{prog-mode} might have run,
+this mode runs the hook @code{racket-hash-lang-mode-hook}, as the final step
+during initialization.
+
+@node racket-hash-lang-backward
+@subsection racket-hash-lang-backward
+
+@kbd{C-M-b}
+
+Like @code{backward-sexp} but uses #lang supplied navigation.
+
+@node racket-hash-lang-forward
+@subsection racket-hash-lang-forward
+
+@kbd{C-M-f}
+
+Like @code{forward-sexp} but uses #lang supplied navigation.
+
+@node racket-hash-lang-up
+@subsection racket-hash-lang-up
+
+@kbd{C-M-u}
+
+Like @code{backward-up-list} but uses #lang supplied navigation.
+
+@node racket-hash-lang-down
+@subsection racket-hash-lang-down
+
+@kbd{C-M-d}
+
+Like @code{down-list} but uses #lang supplied navigation.
+
+@node racket-hash-lang-C-M-q-dwim
+@subsection racket-hash-lang-C-M-q-dwim
+
+@kbd{C-M-q}
+
+Fill or indent depending on lang lexer's token at point.
+
+When the lang lexer token is@dots{}
+
+@itemize
+@item
+``text'', for example in Scribble document text, do
+@code{fill-paragraph}.
+
+@item
+``comment'', do @code{fill-comment}.
+
+@item
+``whitespace'', give an error message.
+
+@item
+anything else, do @code{prog-indent-sexp}.
+@end itemize
+
@node Explore
@section Explore
@@ -1922,12 +2139,20 @@ identifier bindings and modules from the REPL's
namespace.
@tab @ref{racket-expand-definition}
@item @kbd{C-c C-e f}
@tab @ref{racket-expand-file}
-@item @kbd{C-w}
-@tab @code{comint-kill-region}
-@item @kbd{C-a}
-@tab @code{comint-bol}
+@item @kbd{C-c C-o}
+@tab @code{racket-repl-delete-output}
+@item @kbd{C-c C-n}
+@tab @code{racket-repl-next-prompt}
+@item @kbd{C-c C-p}
+@tab @code{racket-repl-previous-prompt}
+@item @kbd{C-c C-u}
+@tab @code{racket-repl-clear-input}
@item @kbd{C-M-y}
@tab @ref{racket-insert-lambda}
+@item @kbd{M-n}
+@tab @code{racket-repl-next-input}
+@item @kbd{M-p}
+@tab @code{racket-repl-previous-input}
@item @kbd{C-M-q}
@tab @code{prog-indent-sexp}
@item @kbd{C-M-u}
@@ -1942,8 +2167,7 @@ identifier bindings and modules from the REPL's namespace.
-In addition to any hooks its parent mode @code{comint-mode} might have run,
-this mode runs the hook @code{racket-repl-mode-hook}, as the final step
+This mode runs the hook @code{racket-repl-mode-hook}, as the final step
during initialization.
@node racket-run
@@ -2000,22 +2224,9 @@ See also @ref{racket-run-and-switch-to-repl}, which is
even more like
Dr Racket's Run command because it selects the REPL window after
running.
-In the @ref{racket-repl-mode} buffer, output that describes a file
-and position is automatically ``linkified''. Examples of such
-text include:
-
-@itemize
-@item
-Racket error messages.
-@item
-rackunit test failure location messages.
-@item
-print representation of path objects.
-@end itemize
-
-To visit these locations, move point there and press RET or mouse
+To visit error locations, move point there and press RET or mouse
click. Or, use the standard @code{next-error} and @code{previous-error}
-commands.
+commands from either the edit or REPL buffer.
@node racket-run-and-switch-to-repl
@subsection racket-run-and-switch-to-repl
@@ -2437,7 +2648,7 @@ When the expression is a sexp comment, the sexp itself is
sent,
without the #; prefix.
With a prefix argument (e.g. @kbd{C-u} @kbd{C-x C-e} ), the sexp is copied
-into the REPL, followed by a ``;; ->'' line, to distinguish it
+into the REPL, followed by a ``=>'' line, to distinguish it
from the zero or more values to which it evaluates.
@node Collections
@@ -2675,6 +2886,7 @@ Delete the ``compiled'' directories made by
@ref{racket-mode-start-faster}.
@menu
* General variables::
+* Hash lang variables::
* REPL variables::
* Other variables::
* Experimental debugger variables::
@@ -2694,6 +2906,7 @@ Delete the ``compiled'' directories made by
@ref{racket-mode-start-faster}.
* racket-browse-url-function::
* racket-xp-after-change-refresh-delay::
* racket-xp-highlight-unused-regexp::
+* racket-xp-binding-font-lock-face-modes::
* racket-documentation-search-location::
@end menu
@@ -2810,6 +3023,30 @@ Only give @ref{racket-xp-unused-face} to unused bindings
that match this regexp.
The default is to highlight identifiers that do not start with
an underline, which is a common convention.
+@node racket-xp-binding-font-lock-face-modes
+@subsection racket-xp-binding-font-lock-face-modes
+
+Major modes where @ref{racket-xp-mode} will fontify binding identifier sites.
+
+A `font-lock-face property is added for bindings from:
+
+@itemize
+@item
+the module language, using @ref{racket-xp-binding-lang-face} and
+@ref{racket-xp-binding-lang-use-face}.
+
+@item
+other imports, using @ref{racket-xp-binding-import-face} and
+@ref{racket-xp-binding-import-use-face}.
+
+@item
+local definitions, using @ref{racket-xp-binding-local-face} and
+@ref{racket-xp-binding-local-use-face}.
+@end itemize
+
+This has a visible effect only when there is @emph{not} also a
+`face property applied by the major mode's fontification.
+
@node racket-documentation-search-location
@subsection racket-documentation-search-location
@@ -2829,6 +3066,89 @@ after applying @code{url-hexify-string}. Apart from
``%s'', the
string should be a properly encoded URL.
@end itemize
+@node Hash lang variables
+@section Hash lang variables
+
+@menu
+* racket-hash-lang-token-face-alist::
+* racket-hash-lang-module-language-hook::
+@end menu
+
+@node racket-hash-lang-token-face-alist
+@subsection racket-hash-lang-token-face-alist
+
+An association list from color-lexer token symbols to face symbols.
+
+Note: In many Racket languages, the lexer classifies tokens for
+identifiers as `symbol. In many programs, a majority of the
+source consists of identifiers at binding definition and use
+sites. Therefore the appearance of ``symbol'' tokens is
+significant, and a matter of personal preference.
+
+@itemize
+@item
+If you prefer a ``plainer'' appearance, similar to Dr Racket:
+Add `symbol with the value `default. This gives an
+explicit `face property that prevails over any
+`font-lock-face property that a minor mode might apply to
+enhance the basic fontification.
+
+@item
+If you prefer a more ``colorful'' appearance, similar to
+``classic'' @ref{racket-mode}: Do @emph{not} map `symbol tokens in
+this list. Instead enable @ref{racket-xp-mode} and let it do
+``semantic'' highlighting of bindings; see the customization
+variable @ref{racket-xp-binding-font-lock-face-modes}.
+@end itemize
+
+Note: Some tokens are hardwired and not customizable by this
+list: Comment tokens use the face @code{font-lock-comment-face},
+sometimes blended with other faces. Parenthesis tokens use the
+face @code{parenthesis} if defined, as by the paren-face package.
+String tokens use @code{font-lock-string-face}. Text tokens, e.g.
+Scribble text, use the face @code{default}
+
+@node racket-hash-lang-module-language-hook
+@subsection racket-hash-lang-module-language-hook
+
+Hook run when the module language changes.
+
+The hook is called when a file is first visited, and thereafter
+whenever the ``#lang'' line is edited -- provided that results in
+new language info; for example changing from ``#lang racket'' to
+``#lang racket/base'' will @emph{not} run the hook.
+
+The function is called with a string returned by the lang's
+``module-language'' info key. This info key is supplied
+automatically when a language is defined using
+syntax/module-reader:
+
+@uref{https://docs.racket-lang.org/syntax/reader-helpers.html#%28mod-path._syntax%2Fmodule-reader%29}.
+
+Otherwise a lang might not supply this and the value will be nil.
+
+The hook is useful when you want to vary Emacs behavior in ways
+that go beyond what a lang can describe. This may include
+enabling ``fancy'' or ``classic'' Emacs behaviors only for
+s-expression langs.
+
+For example, maybe you want to use @code{paredit-mode} when it is
+suitable for the module language, otherwise stick with the
+plainer @code{electric-pair-mode}.
+
+@lisp
+ (defun my-hook (module-language)
+ (cond
+ ((member module-language (list "racket" "racket/base"
+ "typed/racket" "typed/racket/base"))
+ (electric-pair-local-mode -1)
+ (paredit-mode 1))
+ (t
+ (paredit-mode -1)
+ (electric-pair-local-mode 1))))
+ (add-hook 'racket-hash-lang-module-language-hook #'my-hook)
+@end lisp
+
@node REPL variables
@section REPL variables
@@ -3015,10 +3335,13 @@ like ``debug'' and not get overhwelmed by these noisy
topics.
Normal hook done before various Racket Mode run commands.
+Here ``before'' means that the @ref{racket-repl-mode} buffer might not
+exist yet.
+
When hook functions are called, @code{current-buffer} is that of the
-@ref{racket-mode} buffer when the run command was issued. If a hook
-function instead needs the @ref{racket-repl-mode} buffer, it should
-get that from the variable @code{racket-repl-buffer-name}.
+edit buffer when the run command was issued. If a hook function
+instead needs the @ref{racket-repl-mode} buffer, it should get that
+from the variable @code{racket-repl-buffer-name}.
@node racket-after-run-hook
@subsection racket-after-run-hook
@@ -3029,9 +3352,9 @@ Here ``after'' means that the run has completed and the
REPL is
waiting at another prompt.
When hook functions are called, @code{current-buffer} is that of the
-@ref{racket-mode} buffer when the run command was issued. If a hook
-function instead needs the @ref{racket-repl-mode} buffer, it should
-get that from the variable @code{racket-repl-buffer-name}.
+buffer when the run command was issued. If a hook function
+instead needs the @ref{racket-repl-mode} buffer, it should get that
+from the variable @code{racket-repl-buffer-name}.
@node racket-sexp-comment-fade
@subsection racket-sexp-comment-fade
@@ -3357,15 +3680,6 @@ buffer, DIRECTORY determines:
@item
Whether the back end is local or remote.
-@item
-The host name. Used to make TCP/IP connections to a back end
-for REPL sesssions. When remote used for SSH connections to
-start the back end process.
-
-This may be a Host alias from ~/.ssh/config with a HostName, in
-which case HostName is used as the actual host name for both
-SSH and TCP/IP connections.
-
@item
When remote, any explicit user and port used to make SSH
connections (as opposed to relying on values from
@@ -3396,33 +3710,11 @@ files. This must be @code{file-name-absolute-p} on the
remote. Only
supply the localname there (not a full @code{file-remote-p}). The
default value is ``/tmp/racket-mode-back-end''.
-@item
-:repl-tcp-accept-host
-
-Host from which the back end TCP REPL server will accept
-connections. ``127.0.0.1'' means it will accept only local
-connections. ``0.0.0.0'' means it will accept connections from
-anywhere --- which usually is risky unless the remote is behind
-a firewall that limits connections!
-
-@item
-:repl-tcp-port
-
-The port number the back end TCP REPL server uses to listen for
-connections.
-
-Note that this is @code{numberp} --- not @code{stringp}.
-
-When 0, this means the back end chooses an available port --- a
-so-called ``ephemeral'' port. Usually that is practical only on
-a local host. Otherwise a specific port number should be used,
-and, remember to allow that in the remote's firewall.
-
@item
:windows
-Whether the back end uses Windows style path names. Used to do
-translation betwen slashes and backslashes between the Emacs
+Whether the back end uses Windows style path names. Used to
+translate betwen slashes and backslashes between the Emacs
front end (which uses slashes even on Windows) and the Racket
back end (which expects native backslashes on Windows).
@@ -3443,28 +3735,10 @@ DIRECTORY is local or remote:
@itemize
@item
-When DIRECTORY is remote, :repl-tcp-port is set to 55555,
-:repl-tcp-accept-host is set to ``0.0.0.0'' (accepts
-connections from anywhere), and :windows is nil.
-
-When working with back ends on remote hosts, @strong{remember to check
-your remote host firewall}. Your goal is to make sure things
-work for you --- but only for you.
-
-Probably you want the firewall to limit from where it accepts
-SSH connections.
-
-Also you need the firewall to accept connections on
-:repl-tcp-port, but again, limiting from where --- either in
-the firewall or by setting :repl-tcp-accept-host to a value
-that is @emph{not} ``0.0.0.0''.
+When DIRECTORY is remote, :windows defaults to nil.
@item
-Otherwise, reasonable defaults are used for a local back end:
-:repl-tcp-port is set to 0 (meaning the back end picks an
-ephemeral port), :repl-tcp-accept-host is set to ``127.0.0.1''
-(meaning the back end only accept TCP connections locally),
-and :windows is set based on @code{system-type}.
+Otherwise, :windows defaults to a value based on @code{system-type}.
@end itemize
Although the default values usually ``just work'' for local and
@@ -3569,6 +3843,12 @@ A value for the variable
@ref{racket-shell-or-terminal-function}.
* racket-xp-unused-face::
* racket-xp-tail-target-face::
* racket-xp-tail-position-face::
+* racket-xp-binding-lang-face::
+* racket-xp-binding-lang-use-face::
+* racket-xp-binding-import-face::
+* racket-xp-binding-import-use-face::
+* racket-xp-binding-local-face::
+* racket-xp-binding-local-use-face::
* racket-logger-config-face::
* racket-logger-topic-face::
* racket-logger-fatal-face::
@@ -3580,6 +3860,13 @@ A value for the variable
@ref{racket-shell-or-terminal-function}.
* racket-ext-link-face::
* racket-doc-output-face::
* racket-doc-litchar-face::
+* racket-repl-message::
+* racket-repl-prompt::
+* racket-repl-value::
+* racket-repl-error-message::
+* racket-repl-error-location::
+* racket-repl-stdout::
+* racket-repl-stderr::
@end menu
@node racket-keyword-argument-face
@@ -3615,12 +3902,12 @@ Face for here strings.
@node racket-xp-def-face
@subsection racket-xp-def-face
-Face @ref{racket-xp-mode} uses to highlight definitions.
+Face @ref{racket-xp-mode} uses when point is on a definition.
@node racket-xp-use-face
@subsection racket-xp-use-face
-Face @ref{racket-xp-mode} uses to highlight uses.
+Face @ref{racket-xp-mode} uses when point is on a use.
@node racket-xp-unused-face
@subsection racket-xp-unused-face
@@ -3637,6 +3924,48 @@ Face @ref{racket-xp-mode} uses to highlight targets of a
tail position.
Face @ref{racket-xp-mode} uses to highlight expressions in a tail position.
+@node racket-xp-binding-lang-face
+@subsection racket-xp-binding-lang-face
+
+Face @ref{racket-xp-mode} gives to the module language name.
+
+See the variable @ref{racket-xp-binding-font-lock-face-modes}.
+
+@node racket-xp-binding-lang-use-face
+@subsection racket-xp-binding-lang-use-face
+
+Face @ref{racket-xp-mode} gives uses of bindings imported from the module
language.
+
+See the variable @ref{racket-xp-binding-font-lock-face-modes}.
+
+@node racket-xp-binding-import-face
+@subsection racket-xp-binding-import-face
+
+Face @ref{racket-xp-mode} gives to imported module names.
+
+See the variable @ref{racket-xp-binding-font-lock-face-modes}.
+
+@node racket-xp-binding-import-use-face
+@subsection racket-xp-binding-import-use-face
+
+Face @ref{racket-xp-mode} gives uses of imported bindings.
+
+See the variable @ref{racket-xp-binding-font-lock-face-modes}.
+
+@node racket-xp-binding-local-face
+@subsection racket-xp-binding-local-face
+
+Face @ref{racket-xp-mode} gives to local definitions.
+
+See the variable @ref{racket-xp-binding-font-lock-face-modes}.
+
+@node racket-xp-binding-local-use-face
+@subsection racket-xp-binding-local-use-face
+
+Face @ref{racket-xp-mode} gives to uses of local definitions.
+
+See the variable @ref{racket-xp-binding-font-lock-face-modes}.
+
@node racket-logger-config-face
@subsection racket-logger-config-face
@@ -3696,5 +4025,40 @@ Face @code{racket-describe-mode} uses for Scribble
@@example or @@interactions o
Face @code{racket-describe-mode} uses for Scribble @@litchar.
+@node racket-repl-message
+@subsection racket-repl-message
+
+Face @ref{racket-repl-mode} uses for messages from the back end.
+
+@node racket-repl-prompt
+@subsection racket-repl-prompt
+
+Face @ref{racket-repl-mode} uses for prompts.
+
+@node racket-repl-value
+@subsection racket-repl-value
+
+Face @ref{racket-repl-mode} uses for values output by current-print.
+
+@node racket-repl-error-message
+@subsection racket-repl-error-message
+
+Face @ref{racket-repl-mode} uses for error messages.
+
+@node racket-repl-error-location
+@subsection racket-repl-error-location
+
+Face @ref{racket-repl-mode} uses for error locations.
+
+@node racket-repl-stdout
+@subsection racket-repl-stdout
+
+Face @ref{racket-repl-mode} uses for output to current-output-port.
+
+@node racket-repl-stderr
+@subsection racket-repl-stderr
+
+Face @ref{racket-repl-mode} uses for output to current-error-port.
+
@c Emacs 25.2.2 (Org mode 8.2.10)
@bye
\ No newline at end of file
diff --git a/racket-back-end.el b/racket-back-end.el
index c48838d79a..a2001b1ec6 100644
--- a/racket-back-end.el
+++ b/racket-back-end.el
@@ -26,9 +26,7 @@
;;
;; The back end accepts commands and returns responses, as well as
;; giving non-command-response notifications (logging, debugging),
-;; which is handled in racket-cmd.el. The back end also accepts
-;; connections on a TCP port for one or more REPL sessions, which is
-;; handled in racket-repl.el.
+;; which is handled in racket-cmd.el.
;;
;; When some buffer needs a back end, which back end does it use?
;; That's the concern of the back end configuration code in this file.
@@ -123,14 +121,6 @@ buffer, DIRECTORY determines:
- Whether the back end is local or remote.
-- The host name. Used to make TCP/IP connections to a back end
- for REPL sesssions. When remote used for SSH connections to
- start the back end process.
-
- This may be a Host alias from ~/.ssh/config with a HostName, in
- which case HostName is used as the actual host name for both
- SSH and TCP/IP connections.
-
- When remote, any explicit user and port used to make SSH
connections (as opposed to relying on values from
~/.ssh/config).
@@ -155,30 +145,10 @@ of a back end:
supply the localname there (not a full `file-remote-p'). The
default value is \"/tmp/racket-mode-back-end\".
-- :repl-tcp-accept-host
-
- Host from which the back end TCP REPL server will accept
- connections. \"127.0.0.1\" means it will accept only local
- connections. \"0.0.0.0\" means it will accept connections from
- anywhere --- which usually is risky unless the remote is behind
- a firewall that limits connections!
-
-- :repl-tcp-port
-
- The port number the back end TCP REPL server uses to listen for
- connections.
-
- Note that this is `numberp' --- not `stringp'.
-
- When 0, this means the back end chooses an available port --- a
- so-called \"ephemeral\" port. Usually that is practical only on
- a local host. Otherwise a specific port number should be used,
- and, remember to allow that in the remote's firewall.
-
- :windows
- Whether the back end uses Windows style path names. Used to do
- translation betwen slashes and backslashes between the Emacs
+ Whether the back end uses Windows style path names. Used to
+ translate betwen slashes and backslashes between the Emacs
front end (which uses slashes even on Windows) and the Racket
back end (which expects native backslashes on Windows).
@@ -195,27 +165,9 @@ of a back end:
The default property values are appropriate for whether
DIRECTORY is local or remote:
-- When DIRECTORY is remote, :repl-tcp-port is set to 55555,
- :repl-tcp-accept-host is set to \"0.0.0.0\" (accepts
- connections from anywhere), and :windows is nil.
-
- When working with back ends on remote hosts, *remember to check
- your remote host firewall*. Your goal is to make sure things
- work for you --- but only for you.
+- When DIRECTORY is remote, :windows defaults to nil.
- Probably you want the firewall to limit from where it accepts
- SSH connections.
-
- Also you need the firewall to accept connections on
- :repl-tcp-port, but again, limiting from where --- either in
- the firewall or by setting :repl-tcp-accept-host to a value
- that is /not/ \"0.0.0.0\".
-
-- Otherwise, reasonable defaults are used for a local back end:
- :repl-tcp-port is set to 0 (meaning the back end picks an
- ephemeral port), :repl-tcp-accept-host is set to \"127.0.0.1\"
- (meaning the back end only accept TCP connections locally),
- and :windows is set based on `system-type'.
+- Otherwise, :windows defaults to a value based on `system-type'.
Although the default values usually \"just work\" for local and
remote back ends, you might want a special configuration. Here
@@ -260,10 +212,6 @@ are a few examples.
:remote-source-dir (or (plist-get plist :remote-source-dir)
(unless local-p
"/tmp/racket-mode-back-end"))
- :repl-tcp-accept-host (or (plist-get plist :repl-tcp-accept-host)
- (if local-p "127.0.0.1" "0.0.0.0"))
- :repl-tcp-port (or (plist-get plist :repl-tcp-port)
- (if local-p 0 55555))
:restart-watch-directories (plist-get plist
:restart-watch-directories)
;; These booleanp things need to distinguish nil meaning
;; "user specififed false" from "user did not specify
@@ -291,8 +239,6 @@ are a few examples.
(number-or-null-p (n) (or (not n) (numberp n))))
(check #'stringp :directory)
(check #'string-or-null-p :racket-program)
- (check #'stringp :repl-tcp-accept-host)
- (check #'numberp :repl-tcp-port)
(when (file-remote-p (plist-get plist :directory))
(check #'stringp :remote-source-dir)
(check #'file-name-absolute-p :remote-source-dir))
@@ -375,40 +321,6 @@ Instead need the following."
;;(racket--file-name-sans-remote-method "/ssh:user@host:/path/to/foo.rkt")
;;(racket--file-name-sans-remote-method "/ssh:user@host#123:/path/to/foo.rkt")
-(defun racket--back-end-actual-host ()
- "Return actual host name, considering possible ~/.ssh/config HostName.
-
-The user may have supplied a tramp file name using a Host defined
-in ~/.ssh/config, which has a HostName option that is the actual
-host name. The ssh command of course uses that config so we can
-start a back end process just fine. However `racket-repl-mode'
-needs to open a TCP connection at the same host, hence this
-helper function."
- (pcase-let ((`(,host ,_user ,_port _name)
- (racket--file-name->host+user+port+name
- (plist-get (racket-back-end) :directory))))
- (racket--back-end-ssh-config-lookup host)))
-
-(defun racket--back-end-ssh-config-lookup (host)
- "Return HOST or its HostName if any from ~/.ssh/config."
- (condition-case nil
- (with-temp-buffer
- (insert-file-contents-literally "~/.ssh/config")
- (goto-char (point-min))
- ;; Dumb parsing with regular expressions:
- (save-match-data
- (let ((case-fold-search t))
- ;; Find start of desired Host block
- (re-search-forward (concat "host[ ]+" host "[ \n]"))
- ;; Find start of next Host or Match block, as limit
- (let ((limit (save-excursion
- (or (re-search-forward "\\(?:host\\|match\\) " nil
t)
- (point-max)))))
- ;; Find HostName if any
- (search-forward-regexp "hostname[ ]+\\([^ \n]+\\)" limit)
- (match-string 1)))))
- (error host)))
-
(defun racket--back-end-local-p (&optional back-end)
(not (file-remote-p (plist-get (or back-end (racket-back-end))
:directory))))
diff --git a/racket-cmd.el b/racket-cmd.el
index 7af4cb1659..4d94bd34ed 100644
--- a/racket-cmd.el
+++ b/racket-cmd.el
@@ -24,6 +24,12 @@
(declare-function racket--logger-on-notify "racket-logger" (back-end-name
str))
(autoload 'racket--logger-on-notify "racket-logger")
+(declare-function racket--hash-lang-on-notify "racket-hash-lang" (id v))
+(autoload 'racket--hash-lang-on-notify "racket-hash-lang")
+
+(declare-function racket--repl-on-output "racket-repl" (session-id kind
value))
+(autoload 'racket--repl-on-output "racket-repl")
+
;;;###autoload
(defvar racket-start-back-end-hook nil
"Hook run after `racket-start-back-end' finishes successfully.")
@@ -62,15 +68,10 @@ Before doing anything runs the hook
`racket-stop-back-end-hook'."
"This is no longer supported."
"2021-08-16")
-(defvar racket--back-end-auth-token (format "token-%x" (random))
- "A value used to start a REPL in a back end process.
-We share this among back ends, which is fine. Keep in mind this
-does get freshly initialized each time this .el file is loaded --
-even from compiled bytecode.")
-
(defun racket--cmd-open ()
;; Avoid excess processes/buffers like "racket-process<1>".
- (racket--cmd-close)
+ (when (racket--cmd-open-p)
+ (racket--cmd-close))
;; Give the process buffer the current values of some vars; see
;; <https://github.com/purcell/envrc/issues/22>.
(cl-letf* (((default-value 'process-environment) process-environment)
@@ -101,14 +102,7 @@ even from compiled bytecode.")
(image-type-available-p 'imagemagick))))
"--use-svg"
"--do-not-use-svg"))
- (args (list main-dot-rkt
- "--auth" racket--back-end-auth-token
- "--accept-host" (plist-get back-end
- :repl-tcp-accept-host)
- "--port" (format "%s"
- (plist-get back-end
- :repl-tcp-port))
- svg-flag))
+ (args (list main-dot-rkt svg-flag))
(command (racket--back-end-args->command back-end args))
(process
(make-process
@@ -203,15 +197,6 @@ sentinel is `ignore'."
(setq racket--cmd-read-from (point-min))
t)))))
-;; (with-temp-buffer
-;; (dolist (str '("(1 2 3)\n"
-;; "(1 2)\n(1 2)\n(1 2 "
-;; "3 4"
-;; " 5 6)\n"))
-;; (goto-char (point-max))
-;; (insert str)
-;; (racket--cmd-read #'prin1)))
-
(defvar racket--cmd-nonce->callback (make-hash-table :test 'eq)
"A hash from command nonce to callback function.")
(defvar racket--cmd-nonce 0
@@ -219,13 +204,18 @@ sentinel is `ignore'."
(defun racket--cmd-dispatch (back-end response)
"Do something with a sexpr sent to us from the command server.
-Although mostly these are 1:1 responses to command requests,
-\"logger\" and \"debug-break\" are notifications."
+Although mostly these are 1:1 responses to command requests, some
+like \"logger\", \"debug-break\", and \"hash-lang\" are
+notifications."
(pcase response
(`(logger ,str)
(run-at-time 0.001 nil #'racket--logger-on-notify back-end str))
(`(debug-break . ,response)
(run-at-time 0.001 nil #'racket--debug-on-break response))
+ (`(hash-lang ,id . ,vs)
+ (run-at-time 0.001 nil #'racket--hash-lang-on-notify id vs))
+ (`(repl-output ,session-id ,kind ,v)
+ (run-at-time 0.001 nil #'racket--repl-on-output session-id kind v))
(`(,nonce . ,response)
(when-let (callback (gethash nonce racket--cmd-nonce->callback))
(remhash nonce racket--cmd-nonce->callback)
@@ -299,11 +289,15 @@ mistake."
(pcase response
(`(ok ,v) (when (buffer-live-p buf)
(with-current-buffer buf (funcall callback v))))
- (`(error ,m) (message "%s command exception:\n%s" name m))
+ (`(error ,m) (let ((print-length nil) ;for %S
+ (print-level nil))
+ (message "Exception for command %S with repl-id %S
from %S to %S:\n%s"
+ command-sexpr repl-session-id buf name
m)))
(`(break) nil)
(v (let ((print-length nil) ;for %S
(print-level nil))
- (message "%s unknown command response:\n%S" name
v)))))
+ (message "Unknown response to command %S with
repl-id %S from %S to %S:\n%S"
+ command-sexpr repl-session-id buf name
v)))))
#'ignore))))
(defun racket--cmd/await (repl-session-id command-sexpr)
@@ -312,20 +306,29 @@ mistake."
REPL-SESSION-ID may be nil for commands that do not need to run
in a specific namespace."
(let* ((awaiting 'RACKET-REPL-AWAITING)
- (response awaiting))
+ (response awaiting)
+ (buf (current-buffer))
+ (name (racket--back-end-process-name)))
(racket--cmd/async-raw repl-session-id
command-sexpr
(lambda (v) (setq response v)))
(with-timeout (racket-command-timeout
- (error "racket-command process timeout"))
+ (let ((print-length nil) ;for %S
+ (print-level nil))
+ (error "Command %S from %S to %S timed out after %s
seconds"
+ command-sexpr buf name racket-command-timeout)))
(while (eq response awaiting)
(accept-process-output nil 0.001))
(pcase response
(`(ok ,v) v)
- (`(error ,m) (error "%s" m))
+ (`(error ,m) (let ((print-length nil) ;for %S
+ (print-level nil))
+ (error "Exception for command %S from %S to %S:\n%s"
+ command-sexpr buf name m)))
(v (let ((print-length nil) ;for %S
(print-level nil))
- (error "Unknown command response: %S" v)))))))
+ (error "Unknown response to command %S from %S to
%S:\n%S"
+ command-sexpr buf name v)))))))
(provide 'racket-cmd)
diff --git a/racket-common.el b/racket-common.el
index c8d76ab8ae..979d54cb4e 100644
--- a/racket-common.el
+++ b/racket-common.el
@@ -1,6 +1,6 @@
;;; racket-common.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; Copyright (c) 2013-2023 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
@@ -199,58 +199,6 @@ property whose value is STRING. The close | syntax is set
by
'syntax-table
(string-to-syntax "|"))))))))
-;;;
-
-(defun racket--common-variables ()
- "Set variables common to `racket-mode' and `racket-repl-mode'."
- ;;; Syntax
- (set-syntax-table racket-mode-syntax-table)
- (setq-local multibyte-syntax-as-symbol t)
- (setq-local parse-sexp-ignore-comments t)
- (setq-local syntax-propertize-function #'racket-syntax-propertize-function)
- (syntax-propertize (point-max)) ;for e.g. paredit: see issue #222
- ;; -----------------------------------------------------------------
- ;; Font-lock
- (setq-local font-lock-defaults
- (list racket-font-lock-keywords ;keywords
- nil ;keywords-only?
- nil ;case-fold?
- nil ;syntax-alist
- nil ;syntax-begin
- ;; Additional variables:
- (cons 'font-lock-mark-block-function #'mark-defun)
- (cons 'parse-sexp-lookup-properties t)
- (cons 'font-lock-multiline t)
- (cons 'font-lock-syntactic-face-function
- #'racket-font-lock-syntactic-face-function)
- (list 'font-lock-extend-region-functions
- #'font-lock-extend-region-wholelines
- #'font-lock-extend-region-multiline)))
- ;; -----------------------------------------------------------------
- ;; Comments. Mostly borrowed from lisp-mode and/or scheme-mode
- (setq-local comment-start ";")
- (setq-local comment-add 1) ;default to `;;' in comment-region
- (setq-local comment-start-skip ";+ *")
- (setq-local comment-column 40)
- (setq-local comment-multi-line t) ;for auto-fill-mode and #||# comments
- ;; Font lock mode uses this only when it knows a comment is starting:
- (setq-local font-lock-comment-start-skip ";+ *")
- ;; -----------------------------------------------------------------
- ;; Indent
- (setq-local indent-line-function #'racket-indent-line)
- (setq-local indent-tabs-mode nil)
- ;; -----------------------------------------------------------------
- ;;; Misc
- (setq-local local-abbrev-table racket-mode-abbrev-table)
- (setq-local paragraph-start (concat "$\\|" page-delimiter))
- (setq-local paragraph-separate paragraph-start)
- (setq-local paragraph-ignore-fill-prefix t)
- (setq-local fill-paragraph-function #'lisp-fill-paragraph)
- (setq-local adaptive-fill-mode nil)
- (setq-local outline-regexp ";;; \\|(....")
- (setq-local beginning-of-defun-function
#'racket--beginning-of-defun-function))
-
-
;;; Insert lambda char (like DrRacket)
(defconst racket-lambda-char (make-char 'greek-iso8859-7 107)
@@ -337,11 +285,17 @@ new buffer has a file on-disk."
(cl-every #'symbolp subs)))
(_ nil)))
+(defvar-local racket-submodules-at-point-function nil)
+
(defun racket--what-to-run ()
(cons (racket--buffer-file-name)
- (racket--submod-path)))
+ (and racket-submodules-at-point-function
+ (funcall racket-submodules-at-point-function))))
-(defun racket--submod-path ()
+(defun racket-submodules-at-point-text-sexp ()
+ "A value for variable `racket--submodules-at-point-function',
+which is suitable for `racket-mode' and possibly for
+`racket-hash-lang-mode' when the hash-lang is like lang racket."
(let ((mods (racket--modules-at-point)))
(if (racket--lang-p)
mods
@@ -364,18 +318,19 @@ new buffer has a file on-disk."
"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
- (racket--escape-string-or-comment)
- (while t
- (when-let (mod-name-sym (racket--looking-at-module-form))
- (push mod-name-sym xs))
- (when (racket--looking-at-quoted-form-p)
- (push nil xs))
- (backward-up-list)))
- (scan-error xs))
- (racket--take-while xs #'identity)))
+ (save-excursion
+ (let ((xs nil))
+ (condition-case ()
+ (progn
+ (racket--escape-string-or-comment)
+ (while t
+ (when-let (mod-name-sym (racket--looking-at-module-form))
+ (push mod-name-sym xs))
+ (when (racket--looking-at-quoted-form-p)
+ (push nil xs))
+ (backward-up-list)))
+ ((scan-error user-error) xs))
+ (racket--take-while xs #'identity))))
(defun racket--looking-at-module-form ()
"When looking at a module form, return the mod name as a symbol."
@@ -416,6 +371,22 @@ repeatedly."
(racket--escape-string-or-comment)
(backward-up-list 1))
+(defconst racket--plain-syntax-table
+ (let ((table (make-syntax-table)))
+ ;; Modify entries for characters for parens, strings, and
+ ;; comments, setting them to word syntax instead. (For the these
+ ;; raw syntax descriptor numbers, see Emacs Lisp Info: "Syntax
+ ;; Table Internals".)
+ (map-char-table (lambda (key value)
+ (when (memq (car value) '(4 5 7 10 11 12))
+ (aset table key '(2))))
+ table)
+ table)
+ "A syntax-table that makes no assumptions that characters are
+delimiters for parens, quotes, comments, etc. Just whitespace and
+word syntax, so the user has /some/ basic navigation as opposed
+to it being one opaque blob.")
+
(provide 'racket-common)
;; racket-common.el ends here
diff --git a/racket-custom.el b/racket-custom.el
index 6a195f9361..8ea917a51d 100644
--- a/racket-custom.el
+++ b/racket-custom.el
@@ -146,6 +146,72 @@ an underline, which is a common convention."
:safe #'stringp
:group 'racket-xp)
+(defcustom racket-xp-binding-font-lock-face-modes '(racket-hash-lang-mode)
+ "Major modes where `racket-xp-mode' will fontify binding identifier sites.
+
+A \\='font-lock-face property is added for bindings from:
+
+ - the module language, using `racket-xp-binding-lang-face' and
+ `racket-xp-binding-lang-use-face'.
+
+ - other imports, using `racket-xp-binding-import-face' and
+ `racket-xp-binding-import-use-face'.
+
+ - local definitions, using `racket-xp-binding-local-face' and
+ `racket-xp-binding-local-use-face'.
+
+This has a visible effect only when there is /not/ also a
+\\='face property applied by the major mode's fontification."
+ :tag "Racket Xp Mode Binding Font Lock Face Modes"
+ :type '(repeat symbol)
+ :safe #'listp
+ :group 'racket-xp)
+
+;;; Hash Lang
+
+(defgroup racket-hash-lang nil
+ "`racket-hash-lang-mode' options"
+ :tag "Hash Lang"
+ :group 'racket)
+
+(defcustom racket-hash-lang-token-face-alist
+ `((constant . font-lock-constant-face)
+ (error . error)
+ (other . font-lock-doc-face)
+ (keyword . font-lock-keyword-face)
+ (hash-colon-keyword . racket-keyword-argument-face)
+ (at . font-lock-doc-face))
+ "An association list from color-lexer token symbols to face symbols.
+
+Note: In many Racket languages, the lexer classifies tokens for
+identifiers as \\='symbol. In many programs, a majority of the
+source consists of identifiers at binding definition and use
+sites. Therefore the appearance of \"symbol\" tokens is
+significant, and a matter of personal preference.
+
+ - If you prefer a \"plainer\" appearance, similar to Dr Racket:
+ Add \\='symbol with the value \\='default. This gives an
+ explicit \\='face property that prevails over any
+ \\='font-lock-face property that a minor mode might apply to
+ enhance the basic fontification.
+
+ - If you prefer a more \"colorful\" appearance, similar to
+ \"classic\" `racket-mode': Do /not/ map \\='symbol tokens in
+ this list. Instead enable `racket-xp-mode' and let it do
+ \"semantic\" highlighting of bindings; see the customization
+ variable `racket-xp-binding-font-lock-face-modes'.
+
+Note: Some tokens are hardwired and not customizable by this
+list: Comment tokens use the face `font-lock-comment-face',
+sometimes blended with other faces. Parenthesis tokens use the
+face `parenthesis' if defined, as by the paren-face package.
+String tokens use `font-lock-string-face'. Text tokens, e.g.
+Scribble text, use the face `default'"
+ :tag "Hash Lang Token Face Association List"
+ :type '(alist :key-type symbol :value-type face)
+ :safe #'listp
+ :group 'racket-hash-lang)
+
;;; REPL
(defgroup racket-repl nil
@@ -327,13 +393,17 @@ will use this to decide whether to submit your input,
yet."
:safe #'booleanp
:group 'racket-repl)
+
(defcustom racket-before-run-hook nil
"Normal hook done before various Racket Mode run commands.
+Here \"before\" means that the `racket-repl-mode' buffer might not
+exist yet.
+
When hook functions are called, `current-buffer' is that of the
-`racket-mode' buffer when the run command was issued. If a hook
-function instead needs the `racket-repl-mode' buffer, it should
-get that from the variable `racket-repl-buffer-name'."
+edit buffer when the run command was issued. If a hook function
+instead needs the `racket-repl-mode' buffer, it should get that
+from the variable `racket-repl-buffer-name'."
:tag "Before Run Hook"
:type 'hook
:risky t
@@ -346,9 +416,9 @@ Here \"after\" means that the run has completed and the
REPL is
waiting at another prompt.
When hook functions are called, `current-buffer' is that of the
-`racket-mode' buffer when the run command was issued. If a hook
-function instead needs the `racket-repl-mode' buffer, it should
-get that from the variable `racket-repl-buffer-name'."
+buffer when the run command was issued. If a hook function
+instead needs the `racket-repl-mode' buffer, it should get that
+from the variable `racket-repl-buffer-name'."
:tag "After Run Hook"
:type 'hook
:risky t
@@ -515,14 +585,56 @@ ignore POS. Examples: `racket-show-echo-area' and
(defface-racket racket-xp-def-face
'((t (:inherit match :underline (:style line))))
- "Face `racket-xp-mode' uses to highlight definitions."
+ "Face `racket-xp-mode' uses when point is on a definition."
"Definition Face")
(defface-racket racket-xp-use-face
'((t (:inherit match)))
- "Face `racket-xp-mode' uses to highlight uses."
+ "Face `racket-xp-mode' uses when point is on a use."
"Use Face")
+(defface-racket racket-xp-binding-lang-face
+ '((t (:inherit font-lock-doc-face)))
+ "Face `racket-xp-mode' gives to the module language name.
+
+See the variable `racket-xp-binding-font-lock-face-modes'."
+ "Binding Lang Face")
+
+(defface-racket racket-xp-binding-lang-use-face
+ '((t (:inherit font-lock-keyword-face)))
+ "Face `racket-xp-mode' gives uses of bindings imported from the module
language.
+
+See the variable `racket-xp-binding-font-lock-face-modes'."
+ "Binding Lang Use Face")
+
+(defface-racket racket-xp-binding-import-face
+ '((t (:inherit default)))
+ "Face `racket-xp-mode' gives to imported module names.
+
+See the variable `racket-xp-binding-font-lock-face-modes'."
+ "Binding Import Face")
+
+(defface-racket racket-xp-binding-import-use-face
+ '((t (:inherit font-lock-keyword-face)))
+ "Face `racket-xp-mode' gives uses of imported bindings.
+
+See the variable `racket-xp-binding-font-lock-face-modes'."
+ "Binding Import Use Face")
+
+(defface-racket racket-xp-binding-local-face
+ '((t (:inherit font-lock-variable-name-face)))
+ "Face `racket-xp-mode' gives to local definitions.
+
+See the variable `racket-xp-binding-font-lock-face-modes'."
+ "Binding Local Face")
+
+(defface-racket racket-xp-binding-local-use-face
+ '((t (:inherit default)))
+ "Face `racket-xp-mode' gives to uses of local definitions.
+
+See the variable `racket-xp-binding-font-lock-face-modes'."
+ "Binding Local Use Face")
+
(defface-racket racket-xp-error-face
'((t (:underline (:color "red" :style wave))))
"Face `racket-xp-mode' uses to highlight errors."
@@ -668,6 +780,46 @@ See the variable `racket-browse-url-function'."
"Face `racket-describe-mode' uses for Scribble @litchar."
"Racket Doc Litchar Face")
+(defface-racket racket-repl-message
+ '((t (:inherit font-lock-comment-face :slant italic)))
+ "Face `racket-repl-mode' uses for messages from the back end."
+ "Racket REPL Message")
+
+(defface-racket racket-repl-prompt
+ '((t (:inherit bold)))
+ "Face `racket-repl-mode' uses for prompts."
+ "Racket REPL Prompt")
+
+(defface-racket racket-repl-value
+ '((t (:inherit font-lock-constant-face)))
+ "Face `racket-repl-mode' uses for values output by current-print."
+ "Racket REPL Value")
+
+(defface-racket racket-repl-error-message
+ '((t (:inherit error)))
+ "Face `racket-repl-mode' uses for error messages."
+ "Racket REPL Error Message")
+
+(defface-racket racket-repl-error-location
+ '((t (:inherit underline)))
+ "Face `racket-repl-mode' uses for error locations."
+ "Racket REPL Error Location")
+
+(defface-racket racket-repl-error-label
+ '((t (:inherit font-lock-variable-name-face)))
+ "Face `racket-repl-mode' uses for error labels."
+ "Racket REPL Error Label")
+
+(defface-racket racket-repl-stdout
+ '((t (:inherit default)))
+ "Face `racket-repl-mode' uses for output to current-output-port."
+ "Racket REPL Stdout")
+
+(defface-racket racket-repl-stderr
+ '((t (:inherit error)))
+ "Face `racket-repl-mode' uses for output to current-error-port."
+ "Racket REPL Stderr")
+
(provide 'racket-custom)
;;; racket-custom.el ends here
diff --git a/racket-debug.el b/racket-debug.el
index f1328b5949..c7b5dac5b3 100644
--- a/racket-debug.el
+++ b/racket-debug.el
@@ -282,7 +282,8 @@ parens and close parens are breakble positions."
(defun racket-debug-disable ()
(interactive)
- (racket--cmd/async (racket--repl-session-id) `(debug-disable))
+ (when (racket--cmd-open-p) ;otherwise no need
+ (racket--cmd/async (racket--repl-session-id) `(debug-disable)))
(racket-debug-mode -1)
(setq racket--debug-breakable-positions nil)
(setq racket--debug-break-locals nil)
@@ -349,9 +350,7 @@ How to debug:
("!" racket-debug-toggle-breakpoint)
("h" racket-debug-run-to-here)
("?" racket-debug-help)))
- (unless (eq major-mode 'racket-mode)
- (setq racket-debug-mode nil)
- (user-error "racket-debug-mode only works with racket-mode"))
+ (racket--assert-edit-mode (lambda () (setq racket-debug-mode nil)))
(cond
(racket-debug-mode
(racket--debug-make-overlay
diff --git a/racket-edit.el b/racket-edit.el
index 6d8c4ceaaa..dadbaa532a 100644
--- a/racket-edit.el
+++ b/racket-edit.el
@@ -74,8 +74,7 @@ At most one required module is listed per line.
See also: `racket-trim-requires' and `racket-base-requires'."
(interactive)
- (unless (eq major-mode 'racket-mode)
- (user-error "Current buffer is not a racket-mode buffer"))
+ (racket--assert-racket-mode)
(racket--tidy-requires '() #'ignore))
(defun racket--tidy-requires (add callback)
@@ -115,8 +114,7 @@ actually needed by such submodules.
See also: `racket-base-requires'."
(interactive)
- (unless (eq major-mode 'racket-mode)
- (user-error "Current buffer is not a racket-mode buffer"))
+ (racket--assert-edit-mode)
(when (racket--submodule-y-or-n-p)
(racket--save-if-changed)
(pcase (racket--module-requires 'find t)
@@ -160,8 +158,7 @@ Note: Currently this only helps change \"#lang racket\" to
conversions, such as changing \"#lang typed/racket\" to \"#lang
typed/racket/base\"."
(interactive)
- (unless (eq major-mode 'racket-mode)
- (user-error "Current buffer is not a racket-mode buffer"))
+ (racket--assert-racket-mode)
(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$")
@@ -272,8 +269,7 @@ The mechanism is similar to that used for Racket's \"Search
Manuals\" feature. Today there exists no system-wide database of
identifiers that are exported but not documented."
(interactive)
- (unless (eq major-mode 'racket-mode)
- (user-error "Current buffer is not a racket-mode buffer"))
+ (racket--assert-racket-mode)
(let ((sym-at-point (thing-at-point 'symbol t)))
(unless sym-at-point
(user-error "There does not seem to be an identifier at point"))
diff --git a/racket-hash-lang.el b/racket-hash-lang.el
new file mode 100644
index 0000000000..00cf7de7fd
--- /dev/null
+++ b/racket-hash-lang.el
@@ -0,0 +1,707 @@
+;;; racket-hash-lang.el -*- lexical-binding: t; -*-
+
+;; Copyright (c) 2020-2023 by Greg Hendershott.
+;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
+
+;; Author: Greg Hendershott
+;; URL: https://github.com/greghendershott/racket-mode
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+(require 'cl-lib)
+(require 'seq)
+(require 'racket-cmd)
+(require 'racket-mode)
+(require 'racket-repl)
+
+(defvar racket-hash-lang-mode-map
+ (racket--easy-keymap-define
+ `((("C-c C-c"
+ "C-c C-k") ,#'racket-run-module-at-point)
+ ("C-c C-z" ,#'racket-repl)
+ ("<f5>" ,#'racket-run-and-switch-to-repl)
+ ("M-C-<f5>" ,#'racket-racket)
+ ("C-<f5>" ,#'racket-test)
+ ("C-c C-t" ,#'racket-test)
+ ("C-c C-l" ,#'racket-logger)
+ ("C-c C-o" ,#'racket-profile)
+ ("C-c C-e f" ,#'racket-expand-file)
+ ("C-c C-x C-f" ,#'racket-open-require-path)
+ ("TAB" ,#'indent-for-tab-command)
+ ;; ("C-c C-p" racket-cycle-paren-shapes) equivalent using
paren-matches?
+ ("M-C-y" ,#'racket-insert-lambda)
+ ("RET" ,#'newline-and-indent)
+ ("C-M-b" ,#'racket-hash-lang-backward)
+ ("C-M-f" ,#'racket-hash-lang-forward)
+ ("C-M-u" ,#'racket-hash-lang-up)
+ ("C-M-d" ,#'racket-hash-lang-down)
+ ("C-M-q" ,#'racket-hash-lang-C-M-q-dwim))))
+
+(easy-menu-define racket-hash-lang-mode-menu racket-hash-lang-mode-map
+ "Menu for `racket-hash-lang-mode'."
+ '("Racket-Hash-Lang"
+ ("Run"
+ ["in REPL" racket-run]
+ ["in REPL and switch to REPL" racket-run-and-switch-to-repl]
+ ["in *shell* using `racket`" racket-racket])
+ ("Tests"
+ ["in REPL" racket-test]
+ ["in *shell* using `raco test`" racket-raco-test])
+ ("Macro Expand"
+ ["File" racket-expand-file])
+ ["Switch to REPL" racket-repl]
+ ("Tools"
+ ["Profile" racket-profile]
+ ["Error Trace" racket-run-with-errortrace]
+ ["Step Debug" racket-run-with-debugging]
+ ["Toggle XP Mode" racket-xp-mode])
+ "---"
+ ["Comment" comment-dwim]
+ ["Insert λ" racket-insert-lambda]
+ ["Indent Region" indent-region]
+ "---"
+ ["Open Require Path" racket-open-require-path]
+ ["Find Collection" racket-find-collection]
+ "---"
+ ["Next Error or Link" next-error]
+ ["Previous Error" previous-error]
+ ["Customize..." customize-mode]))
+
+(defvar-local racket--hash-lang-submit-predicate-p nil)
+
+(defvar racket-hash-lang-module-language-hook nil
+ "Hook run when the module language changes.
+
+The hook is called when a file is first visited, and thereafter
+whenever the \"#lang\" line is edited -- provided that results in
+new language info; for example changing from \"#lang racket\" to
+\"#lang racket/base\" will /not/ run the hook.
+
+The function is called with a string returned by the lang's
+\"module-language\" info key. This info key is supplied
+automatically when a language is defined using
+syntax/module-reader:
+
+
<https://docs.racket-lang.org/syntax/reader-helpers.html#%28mod-path._syntax%2Fmodule-reader%29>.
+
+Otherwise a lang might not supply this and the value will be nil.
+
+The hook is useful when you want to vary Emacs behavior in ways
+that go beyond what a lang can describe. This may include
+enabling \"fancy\" or \"classic\" Emacs behaviors only for
+s-expression langs.
+
+For example, maybe you want to use `paredit-mode' when it is
+suitable for the module language, otherwise stick with the
+plainer `electric-pair-mode'.
+
+#+BEGIN_SRC elisp
+ (defun my-hook (module-language)
+ (cond
+ ((member module-language (list \"racket\" \"racket/base\"
+ \"typed/racket\" \"typed/racket/base\"))
+ (electric-pair-local-mode -1)
+ (paredit-mode 1))
+ (t
+ (paredit-mode -1)
+ (electric-pair-local-mode 1))))
+ (add-hook \\='racket-hash-lang-module-language-hook #\\='my-hook)
+#+END_SRC
+")
+
+;;;###autoload
+(define-derived-mode racket-hash-lang-mode prog-mode
+ "#lang"
+ "Use color-lexer, indent, and navigation supplied by a #lang.
+
+An experimental major mode alternative to `racket-mode' for
+source file edit buffers.
+
+In your Emacs configuration, you may want to update the
+variable `auto-mode-alist' to use `racket-hash-lang-mode' for
+file extensions like \".rkt\", \".scrbl\", and/or \".rhm\".
+
+See also the customization variable
+`racket-hash-lang-token-face-alist' and the hook variable
+`racket-hash-lang-module-language-hook'.
+
+A discussion of the information provided by a Racket language:
+
+ <https://docs.racket-lang.org/tools/lang-languages-customization.html>
+
+Note that langs supply colors only for lexer tokens like strings
+and comments. If you enable the minor mode `racket-xp-mode', it
+can contribute more colors; see the customization variable
+`racket-xp-binding-font-lock-face-modes'.
+
+\\{racket-hash-lang-mode-map}
+"
+ (racket-call-racket-repl-buffer-name-function)
+ (add-hook 'kill-buffer-hook
+ #'racket-mode-maybe-offer-to-kill-repl-buffer
+ nil t)
+ (set-syntax-table racket--plain-syntax-table)
+ (setq-local font-lock-defaults nil)
+ (setq-local font-lock-fontify-region-function
+ #'racket--hash-lang-font-lock-fontify-region)
+ (font-lock-set-defaults) ;issue #642
+ (setq-local syntax-propertize-function nil)
+ (setq-local text-property-default-nonsticky
+ (append
+ (racket--hash-lang-text-prop-list #'cons t)
+ text-property-default-nonsticky))
+ (add-hook 'after-change-functions #'racket--hash-lang-after-change-hook t t)
+ (add-hook 'kill-buffer-hook #'racket--hash-lang-delete t t)
+ (add-hook 'change-major-mode-hook #'racket--hash-lang-delete t t)
+ (electric-indent-local-mode -1)
+ (setq-local electric-indent-inhibit t)
+ (setq-local blink-paren-function nil)
+ (setq-local imenu-create-index-function nil)
+ (setq-local completion-at-point-functions nil) ;rely on racket-xp-mode
+ (setq-local eldoc-documentation-function nil)
+ (setq racket-submodules-at-point-function nil) ;might change in on-new-lang
+ (racket--hash-lang-create))
+
+(defvar-local racket--hash-lang-id nil
+ "Unique integer used to identify the back end hash-lang object.
+Although it's tempting to use `buffer-file-name' for the ID, not
+all buffers have files. Although it's tempting to use
+`buffer-name', buffers can be renamed. Although it's tempting to
+use the buffer object, we can't serialize that.")
+(defvar racket--hash-lang-next-id 0
+ "Increment when we need a new id.")
+
+(defvar-local racket--hash-lang-generation 1
+ "Monotonic increasing value for hash-lang updates.
+
+This is set to 1 when we hash-lang create, incremented every time
+we do a hash-lang update, and then supplied for all other, query
+hash-lang operations. That way the queries can block if necessary
+until the back end has handled the update commands and also
+re-tokenization has progressed sufficiently.")
+
+;; For use by both racket-hash-lang-mode and racket-repl-mode
+(defun racket--hash-lang-create (&optional other-buffer)
+ (setq-local racket--hash-lang-id (cl-incf racket--hash-lang-next-id))
+ (setq-local racket--hash-lang-generation 1)
+ (cl-case major-mode
+ ((racket-hash-lang-mode)
+ (let ((text (save-restriction
+ (widen)
+ (buffer-substring-no-properties (point-min) (point-max)))))
+ ;; On the one hand, racket--cmd/await would be simpler to use
+ ;; here. On the other hand, when someone visits a file without the
+ ;; back end running yet, there's a delay for that to start, during
+ ;; which the buffer isn't displayed and Emacs seems frozen. On the
+ ;; third hand, if we use async the buffer could try to interact
+ ;; with a back end object that doesn't yet exist, and error.
+ ;;
+ ;; Warm bowl of porridge: Make buffer read-only and not font-lock.
+ ;; Set a timer to show a message in the header-line after awhile.
+ ;; Send command async. Only when the response arrives, i.e. the
+ ;; back end object is ready, enable read/write and font-lock.
+ ;;
+ ;; Finally, handle the back end returning nil for the create,
+ ;; meaning there's no sufficiently new syntax-color-lib.
+ (font-lock-mode -1)
+ (read-only-mode 1)
+ (unless (racket--cmd-open-p)
+ (setq-local header-line-format "Waiting for back end to start..."))
+ (racket--cmd/async
+ nil
+ `(hash-lang create ,racket--hash-lang-id ,nil ,text)
+ (lambda (maybe-id)
+ (font-lock-mode 1)
+ (read-only-mode -1)
+ (setq-local header-line-format nil)
+ (unless maybe-id
+ (prog-mode)
+ (message "hash-lang support not available; needs newer
syntax-color-lib"))))))
+ ((racket-repl-mode)
+ (let ((other-lang-source
+ (when other-buffer
+ (with-current-buffer other-buffer
+ (save-restriction
+ (widen)
+ (buffer-substring-no-properties (point-min) (min 4096
(point-max)))))))
+ (text
+ (racket--hash-lang-repl-buffer-string (point-min) (point-max))))
+ (racket--cmd/async
+ nil
+ `(hash-lang create ,racket--hash-lang-id ,other-lang-source ,text))))
+ (otherwise
+ (error "racket--hash-lang-create doesn't work for %s" major-mode))))
+
+(defun racket--hash-lang-delete ()
+ (when racket--hash-lang-id
+ (ignore-errors
+ (racket--cmd/await
+ (when (eq major-mode 'racket-repl-mode) racket--repl-session-id)
+ `(hash-lang delete ,racket--hash-lang-id)))
+ (setq racket--hash-lang-id nil)
+ (setq-local racket--hash-lang-generation 1)))
+
+;;; Handle back end stopping
+
+(defun racket--hash-lang-on-stop-back-end ()
+ "Because `racket-hash-lang-mode' buffers can't work without a
+live back end, downgrade them all to `prog-mode'."
+ (dolist (buf (buffer-list))
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (when (eq major-mode 'racket-hash-lang-mode)
+ (prog-mode))))))
+(add-hook 'racket-stop-back-end-hook #'racket--hash-lang-on-stop-back-end)
+
+;;; Other
+
+(defun racket--hash-lang-find-buffer (id)
+ "Find the buffer whose local value for `racket--hash-lang-id' is ID."
+ (cl-some (lambda (buf)
+ (when (equal id (buffer-local-value 'racket--hash-lang-id buf))
+ buf))
+ (buffer-list)))
+
+(defun racket--make-non-sexp-syntax-table (parens quotes)
+ "Make a syntax-table with the given parens and quotes.
+
+Intended for use by things like `electric-pair-mode'."
+ (let ((table (make-syntax-table racket--plain-syntax-table)))
+ (dolist (str-pair parens)
+ (pcase-let ((`(,open . ,close) str-pair))
+ ;; Unsure how to handle in syntax-table when > 1 char.
+ (when (and (= 1 (length open)) (= 1 (length close)))
+ (modify-syntax-entry (aref open 0)
+ (concat "(" (substring close 0 1) " ")
+ table)
+ (modify-syntax-entry (aref close 0)
+ (concat ")" (substring open 0 1) " ")
+ table))))
+ (dolist (str quotes)
+ (when (= 1 (length str))
+ (modify-syntax-entry (aref str 0) "\" " table)))
+ table))
+
+;;; Updates: Front end --> back end
+
+(defun racket--hash-lang-repl-buffer-string (beg end)
+ "Like `buffer-substring-no-properties' treat as whitespace,
+preserving only line breaks for indentation, everything that is
+not a value output since the last run, or input after the last
+live prompt."
+ (let ((result-str ""))
+ (racket--repl-call-with-value-and-input-ranges
+ beg end
+ (lambda (beg end is-value-or-input-p)
+ (let ((raw (buffer-substring-no-properties beg end)))
+ (setq
+ result-str
+ (concat result-str
+ (if is-value-or-input-p
+ raw
+ (replace-regexp-in-string "[^\r\n]+"
+ (lambda (s)
+ (make-string (length s) 32))
+ raw)))))))
+ result-str))
+
+(defun racket--hash-lang-after-change-hook (beg end len)
+ ;;;(message "racket--hash-lang-after-change-hook %s %s %s" beg end len)
+ ;; This might be called as frequently as once per single changed
+ ;; character.
+ (racket--cmd/async
+ nil
+ `(hash-lang update
+ ,racket--hash-lang-id
+ ,(cl-incf racket--hash-lang-generation)
+ ,beg
+ ,len
+ ,(if (eq major-mode 'racket-repl-mode)
+ (racket--hash-lang-repl-buffer-string beg end)
+ (buffer-substring-no-properties beg end)))))
+
+;;; Notifications: Front end <-- back end
+
+(defun racket--hash-lang-on-notify (id params)
+ (when-let (buf (racket--hash-lang-find-buffer id))
+ (with-current-buffer buf
+ (pcase params
+ (`(lang . ,plist) (racket--hash-lang-on-new-lang plist))
+ (`(update ,gen ,beg ,end) (racket--hash-lang-on-changed-tokens gen beg
end))))))
+
+(defun racket--hash-lang-on-new-lang (plist)
+ "We get this whenever any #lang supplied attributes have changed.
+
+We do /not/ get notified when a new lang uses exactly the same
+attributes as the old one. For example changing from #lang racket
+to #lang racket/base will /not/ notify us, because none of the
+lang's attributes that we care about have changed."
+ ;;;(message "racket--hash-lang-on-new-lang %s" plist)
+ (with-silent-modifications
+ (save-restriction
+ (widen)
+ (unless (eq major-mode 'racket-repl-mode)
+ (racket--hash-lang-remove-text-properties (point-min) (point-max))
+ (font-lock-flush (point-min) (point-max)))
+ ;; If the lang uses racket-grouping-position, i.e. it uses
+ ;; s-expressions, then use racket-mode-syntax-table. That way
+ ;; other Emacs features and packages are more likely to work.
+ ;; Otherwise, assume nothing about the lang and set a "plain"
+ ;; syntax table where no characters are assumed to delimit
+ ;; parens, comments, or strings.
+ (set-syntax-table (if (plist-get plist 'racket-grouping)
+ racket-mode-syntax-table
+ (racket--make-non-sexp-syntax-table
+ (plist-get plist 'paren-matches)
+ (plist-get plist 'quote-matches))))
+ ;; Similarly for `forward-sexp-function'. The
+ ;; drracket:grouping-position protocol doesn't support a nuance
+ ;; where a `forward-sexp-function' should signal an exception
+ ;; containing failure positions. Although this is N/A for simple
+ ;; forward/backward scenarios (such as when `prog-indent-sexp'
+ ;; uses `forward-sexp' to set a region), it matters when things
+ ;; like `up-list' use `forward-sexp'.
+ (setq-local forward-sexp-function (unless (plist-get plist
'racket-grouping)
+ #'racket-hash-lang-forward-sexp))
+ (syntax-ppss-flush-cache (point-min))
+ (setq-local indent-line-function
+ #'racket-hash-lang-indent-line-function)
+ (setq-local indent-region-function
+ (when (plist-get plist 'range-indenter)
+ #'racket-hash-lang-indent-region-function))
+ (setq-local racket--hash-lang-submit-predicate-p
+ (plist-get plist 'submit-predicate))
+ ;; If racket-grouping i.e.sexp lang then we can probably
+ ;; determine submodules textually from sexprs. Something like
+ ;; racket-pdb-mode could determine this non-textually (albeit
+ ;; after an analysis delay) someday.
+ (setq racket-submodules-at-point-function
+ (and (plist-get plist 'racket-grouping)
+ #'racket-submodules-at-point-text-sexp))
+ ;; (setq-local racket-hash-lang-mode-lighter
+ ;; (concat " #lang"
+ ;; (when (plist-get plist 'racket-grouping) "()")
+ ;; (when (plist-get plist 'range-indenter) "⇉")))
+ (pcase-let ((`(,start ,continue ,end ,padding)
+ (plist-get plist 'comment-delimiters)))
+ (setq-local comment-start start)
+ (setq-local comment-continue continue)
+ (setq-local comment-end end)
+ (setq-local comment-padding padding)
+ (setq-local comment-use-syntax nil)
+ ;; Use `comment-normalize-vars' to recalc the skip regexps.
+ (setq-local comment-start-skip nil)
+ (setq-local comment-end-skip nil)
+ (comment-normalize-vars))
+ ;; Finally run user's module-language-hook.
+ (run-hook-with-args 'racket-hash-lang-module-language-hook
+ (plist-get plist 'module-language)))))
+
+(defun racket--hash-lang-on-changed-tokens (_gen beg end)
+ "The back end has processed a change that resulted in new tokens.
+
+All we do here is mark the span as not fontified, then let
+jit-lock do its thing if/when this span ever becomes visible."
+ ;;;(message "racket--hash-lang-on-changed-tokens %s %s %s" _gen beg end)
+ (font-lock-flush beg end))
+
+;;; Fontification
+
+(defun racket--hash-lang-font-lock-fontify-region (beg end &optional _loudly)
+ "Our value for the variable `font-lock-fontify-region-function'.
+
+We ask the back end for tokens, and handle its response
+asynchronously in `racket--hash-lang-on-tokens' which does the
+actual application of faces and syntax. It wouldn't be
+appropriate to wait for a response while being called from Emacs
+C redisplay engine, as is the case with `jit-lock-mode'."
+ ;;;(message "racket--hash-lang-font-lock-fontify-region %s %s" beg end)
+ (racket--cmd/async
+ nil
+ `(hash-lang get-tokens
+ ,racket--hash-lang-id
+ ,racket--hash-lang-generation
+ ,beg
+ ,end)
+ #'racket--hash-lang-on-tokens)
+ `(jit-lock-bounds ,beg . ,end))
+
+(defun racket--hash-lang-on-tokens (tokens)
+ (save-restriction
+ (widen)
+ (with-silent-modifications
+ (cl-flet* ((put-face (beg end face) (put-text-property beg end 'face
face))
+ (put-stx (beg end stx) (put-text-property beg end
'syntax-table stx))
+ (put-fence (beg end stx)
+ (put-stx beg (1+ beg) stx)
+ (put-stx (1- end) end stx)))
+ (dolist (token tokens)
+ (pcase-let ((`(,beg ,end ,kinds) token))
+ (setq beg (max (point-min) beg))
+ (setq end (min end (point-max)))
+ (racket--hash-lang-remove-text-properties beg end)
+ ;; Add 'racket-token just for me to examine results using
+ ;; `describe-char'; use vector b/c `describe-property-list'
+ ;; assumes lists of symbols are "widgets".
+ (put-text-property beg end 'racket-token (apply #'vector kinds))
+ (dolist (kind kinds)
+ (pcase kind
+ ('comment
+ (put-face beg end 'font-lock-comment-face)
+ (put-fence beg end '(14)))
+ ('sexp-comment ;just the "#;" prefix not following sexp body
+ (put-face beg end 'font-lock-comment-face)
+ (put-fence beg end '(14)))
+ ('string
+ (put-face beg end 'font-lock-string-face)
+ (put-fence beg end '(15)))
+ ;; Note: This relies on the back end supplying `kinds`
+ ;; with sexp-comment-body last, so that we can modify
+ ;; the face property already set by the previous
+ ;; kind(s).
+ ('sexp-comment-body
+ (put-face beg end (racket--sexp-comment-face
+ (get-text-property beg 'face))))
+ ('parenthesis (when (facep 'parenthesis)
+ (put-face beg end 'parenthesis)))
+ ('text (put-stx beg end racket--plain-syntax-table))
+ (sym
+ (when-let (face (cdr (assq sym
racket-hash-lang-token-face-alist)))
+ (put-face beg end face)))))))))))
+
+(defconst racket--hash-lang-text-properties
+ '(face syntax-table racket-token)
+ "The text properties we use.")
+
+(defun racket--hash-lang-text-prop-list (f val)
+ (mapcar (lambda (prop-sym) (funcall f prop-sym val))
+ racket--hash-lang-text-properties))
+
+(defun racket--hash-lang-remove-text-properties (beg end)
+ "Remove `racket--hash-lang-text-properties' from region BEG..END."
+ (remove-text-properties beg end
+ (apply #'append
+ (racket--hash-lang-text-prop-list #'list
nil))))
+
+;;; Indent
+
+(defun racket-hash-lang-indent-line-function ()
+ "Use drracket:indentation supplied by the lang.
+
+If a lang doesn't supply this, or if the supplied function ever
+returns false, then we always use the standard s-expression
+indenter from syntax-color/racket-indentation.
+
+We never use `racket-indent-line' from traditional
+`racket-mode'."
+ (let* ((bol (save-excursion (beginning-of-line) (point)))
+ (pos (- (point-max) (point)))
+ (col (racket--cmd/await ; await = :(
+ nil
+ `(hash-lang indent-amount
+ ,racket--hash-lang-id
+ ,racket--hash-lang-generation
+ ,(point)))))
+ (goto-char bol)
+ (skip-chars-forward " \t") ;;TODO: Is this reliable for all langs?
+ (unless (= col (current-column))
+ (delete-region bol (point))
+ (indent-to col))
+ ;; When point is within the leading whitespace, move it past the
+ ;; new indentation whitespace. Otherwise preserve its position
+ ;; relative to the original text.
+ (when (< (point) (- (point-max) pos))
+ (goto-char (- (point-max) pos)))))
+
+(defun racket-hash-lang-indent-region-function (from upto)
+ "Maybe use #lang drracket:range-indentation, else plain `indent-region'."
+ (pcase (racket--cmd/await ; await = :(
+ nil
+ `(hash-lang indent-region-amounts
+ ,racket--hash-lang-id
+ ,racket--hash-lang-generation
+ ,from
+ ,upto))
+ ('false (let ((indent-region-function nil))
+ (indent-region from upto)))
+ (`() nil)
+ (results
+ (save-excursion
+ (goto-char from)
+ ;; drracket:range-indent docs say `results` could have more
+ ;; elements than lines in from..upto, and we should ignore
+ ;; extras. Handle that. (Although it could also have fewer, we
+ ;; need no special handling for that here.)
+ (let ((results (seq-take results (count-lines from upto))))
+ (dolist (result results)
+ (pcase-let ((`(,delete-amount ,insert-string) result))
+ (beginning-of-line)
+ (when (< 0 delete-amount) (delete-char delete-amount))
+ (unless (equal "" insert-string) (insert insert-string))
+ (end-of-line 2))))))))
+
+;; Motion
+
+(defun racket-hash-lang-move (direction &optional count)
+ (let ((count (or count 1)))
+ (pcase (racket--cmd/await ; await = :(
+ nil
+ `(hash-lang grouping
+ ,racket--hash-lang-id
+ ,racket--hash-lang-generation
+ ,(point)
+ ,direction
+ 0
+ ,count))
+ ((and (pred numberp) pos)
+ (goto-char pos))
+ (_ (user-error "Cannot move %s%s" direction (if (memq count '(-1 0 1))
+ ""
+ (format " %s times"
count)))))))
+
+(defun racket-hash-lang-backward (&optional count)
+ "Like `backward-sexp' but uses #lang supplied navigation."
+ (interactive "^p")
+ (racket-hash-lang-move 'backward count))
+
+(defun racket-hash-lang-forward (&optional count)
+ "Like `forward-sexp' but uses #lang supplied navigation."
+ (interactive "^p")
+ (racket-hash-lang-move 'forward count))
+
+(defun racket-hash-lang-up (&optional count)
+ "Like `backward-up-list' but uses #lang supplied navigation."
+ (interactive "^p")
+ (racket-hash-lang-move 'up count))
+
+(defun racket-hash-lang-down (&optional count)
+ "Like `down-list' but uses #lang supplied navigation."
+ (interactive "^p")
+ (racket-hash-lang-move 'down count))
+
+(defun racket-hash-lang-forward-sexp (&optional arg)
+ "A value for the variable `forward-sexp-function'.
+
+Caveat: This uses drracket:grouping-position, which doesn't have
+a concept of signaling the position of a \"barrier\" that
+prevented navigation forward/backward. Some users of
+`forward-sexp' depend on that signal, for example `up-list'.
+However other users don't need that, so we supply this
+`forward-sexp-function' as \"better than nothing\"."
+ (let* ((arg (or arg 1))
+ (dir (if (< arg 0) 'backward 'forward))
+ (cnt (abs arg)))
+ (racket-hash-lang-move dir cnt)))
+
+;;; Fill
+
+(defun racket-hash-lang-C-M-q-dwim (&optional prefix)
+ "Fill or indent depending on lang lexer's token at point.
+
+When the lang lexer token is...
+
+ - \"text\", for example in Scribble document text, do
+ `fill-paragraph'.
+
+ - \"comment\", do `fill-comment'.
+
+ - \"whitespace\", give an error message.
+
+ - anything else, do `prog-indent-sexp'.
+"
+ (interactive "P")
+ (racket--cmd/async nil
+ `(hash-lang
+ classify
+ ,racket--hash-lang-id
+ ,racket--hash-lang-generation
+ ,(point))
+ (pcase-lambda (`(,_beg ,_end ,type))
+ (cl-case type
+ ((whitespace) (user-error "ambiguous; did nothing"))
+ ((text) (fill-paragraph prefix))
+ ((comment) (fill-comment-paragraph prefix))
+ (otherwise (prog-indent-sexp prefix))))))
+
+;;; REPL
+
+(defvar racket-hash-lang-repl-mode-map
+ (racket--easy-keymap-define
+ `(("C-M-b" ,#'racket-hash-lang-backward)
+ ("C-M-f" ,#'racket-hash-lang-forward)
+ ("C-M-u" ,#'racket-hash-lang-up)
+ ("C-M-d" ,#'racket-hash-lang-down)
+ ("C-M-q" ,#'racket-hash-lang-C-M-q-dwim))))
+
+(define-minor-mode racket-hash-lang-repl-mode
+ "A minor mode just to override some keybindings in `racket-repl-mode'.
+
+\\{racket-hash-lang-repl-mode-map}
+"
+ :lighter " #lang"
+ :keymap racket-hash-lang-repl-mode-map)
+
+(defun racket--hash-lang-configure-repl-buffer-from-edit-buffer ()
+ "Update the `racket-repl-mode' buffer associated with the current edit
buffer.
+
+A value for the hook `racket--repl-configure-buffer-hook'.
+
+To be called when a `racket-mode' or `racket-hash-lang-mode' edit
+buffer is `current-buffer'.
+
+It is possible for multiple edit buffers to \"take turns\" using
+the same `racket-repl-mode' buffer, for successive `racket-run'
+commands. Even if various edit buffers all use
+`racket-hash-lang-mode', the hash-lang for each may differ, e.g.
+one buffer is \"#lang racket\" while another is \"#lang
+rhombus\"."
+ ;;;(message "racket--hash-lang-configure-repl called from buffer %s"
(buffer-name))
+ (let ((hl (and (eq major-mode 'racket-hash-lang-mode)
+ racket--hash-lang-id))
+ (edit-buffer (current-buffer)))
+ (with-racket-repl-buffer
+ ;; Clean up from previous hash-lang use of REPL, if any
+ (racket--hash-lang-delete)
+ ;; char-syntax
+ (set-syntax-table (with-current-buffer edit-buffer (syntax-table)))
+ (setq-local syntax-propertize-function
+ (with-current-buffer edit-buffer syntax-propertize-function))
+ ;; font-lock
+ (setq-local font-lock-defaults
+ (with-current-buffer edit-buffer font-lock-defaults))
+ (setq-local font-lock-fontify-region-function
+ (racket--repl-limited-fontify-region
+ (with-current-buffer edit-buffer
font-lock-fontify-region-function)))
+ (font-lock-set-defaults)
+ ;; indent
+ (setq-local indent-line-function
+ (with-current-buffer edit-buffer indent-line-function))
+ (setq-local indent-region-function
+ (with-current-buffer edit-buffer indent-region-function))
+ ;; nav
+ (setq-local forward-sexp-function
+ (with-current-buffer edit-buffer forward-sexp-function))
+ (racket-hash-lang-repl-mode (if hl 1 -1)) ;keybindings
+ (when hl
+ (racket--hash-lang-create edit-buffer))
+ (if hl
+ (add-hook 'after-change-functions
#'racket--hash-lang-after-change-hook t t)
+ (remove-hook 'after-change-functions
#'racket--hash-lang-after-change-hook t))
+ (setq-local racket-repl-submit-function
+ (if hl #'racket-hash-lang-submit nil)))))
+(add-hook 'racket--repl-before-run-hook
+ #'racket--hash-lang-configure-repl-buffer-from-edit-buffer)
+
+(defun racket-hash-lang-submit (input)
+ ""
+ (or (not racket--hash-lang-submit-predicate-p)
+ (racket--cmd/await nil
+ `(hash-lang
+ submit-predicate
+ ,racket--hash-lang-id
+ ,input
+ t))))
+
+(provide 'racket-hash-lang)
+
+;; racket-hash-lang.el ends here
diff --git a/racket-indent.el b/racket-indent.el
index 077a43d183..87e0e35c8f 100644
--- a/racket-indent.el
+++ b/racket-indent.el
@@ -33,17 +33,17 @@
;; `racket-indent-function'.
;; Having said all that, we still have the matter of `paredit-mode'.
-;; It directly calls `lisp-indent-line' instead of `indent-function'.
-;; And, it directly calls `indent-sexp' instead of `prog-indent-sexp'.
-;; Therefore it gets `lisp-mode' indent, not ours. To address this,
-;; advise those two functions to do the right thing when one of our
-;; major modes is active.
+;; It directly calls `lisp-indent-line' instead of
+;; `indent-line-function'. And, it directly calls `indent-sexp'
+;; instead of `prog-indent-sexp'. Therefore it gets `lisp-mode'
+;; indent, not ours. To address this, advise those two functions to do
+;; the right thing when one of our major modes is active.
(defun racket--lisp-indent-line-advice (orig &rest args)
- "When `racket--mode-edits-racket-p' instead use `racket-indent-line'."
- (apply (if (racket--mode-edits-racket-p) #'racket-indent-line orig)
+ "If `racket--mode-edits-racket-p' use the variable `indent-line-function'."
+ (apply (if (racket--mode-edits-racket-p) indent-line-function orig)
args))
(defun racket--indent-sexp-advice (orig &rest args)
- "When `racket--mode-edits-racket-p' instead use `prog-indent-sexp'."
+ "If `racket--mode-edits-racket-p' use `prog-indent-sexp'."
(apply (if (racket--mode-edits-racket-p) #'prog-indent-sexp orig)
args))
(advice-add 'lisp-indent-line :around #'racket--lisp-indent-line-advice)
diff --git a/racket-mode.el b/racket-mode.el
index 53c58366e7..8ed1345b9a 100644
--- a/racket-mode.el
+++ b/racket-mode.el
@@ -1,6 +1,6 @@
;;; racket-mode.el --- Racket editing, REPL, and more -*- lexical-binding: t;
-*-
-;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; Copyright (c) 2013-2023 by Greg Hendershott.
;; Package: racket-mode
;; Package-Requires: ((emacs "25.1"))
@@ -17,7 +17,7 @@
;; - Focus on Racket lang.
;; - Follow DrRacket concepts where applicable.
;; - Thorough font-lock and indent.
-;; - Compatible with Emacs 25.1+ and Racket 6.9+.
+;; - Compatible with Emacs 25.1+ and Racket 6.12+.
;;
;; Details: https://github.com/greghendershott/racket-mode
@@ -72,7 +72,7 @@
"Keymap for Racket mode.")
(easy-menu-define racket-mode-menu racket-mode-map
- "Menu for Racket mode."
+ "Menu for `racket-mode'."
'("Racket"
("Run"
["in REPL" racket-run]
@@ -132,21 +132,66 @@
"Major mode for editing Racket source files.
\\{racket-mode-map}"
- (racket--common-variables)
+ ;;; Syntax
+ (set-syntax-table racket-mode-syntax-table)
+ (setq-local multibyte-syntax-as-symbol t)
+ (setq-local parse-sexp-ignore-comments t)
+ (setq-local syntax-propertize-function #'racket-syntax-propertize-function)
+ (syntax-propertize (point-max)) ;for e.g. paredit: see issue #222
+ ;; -----------------------------------------------------------------
+ ;; REPL
(racket-call-racket-repl-buffer-name-function)
+ (add-hook 'kill-buffer-hook
+ #'racket-mode-maybe-offer-to-kill-repl-buffer
+ nil t)
+ ;; -----------------------------------------------------------------
+ ;; Font-lock
+ (setq-local font-lock-defaults
+ (list racket-font-lock-keywords ;keywords
+ nil ;keywords-only?
+ nil ;case-fold?
+ nil ;syntax-alist
+ nil ;syntax-begin
+ ;; Additional variables:
+ (cons 'font-lock-mark-block-function #'mark-defun)
+ (cons 'parse-sexp-lookup-properties t)
+ (cons 'font-lock-multiline t)
+ (cons 'font-lock-syntactic-face-function
+ #'racket-font-lock-syntactic-face-function)
+ (list 'font-lock-extend-region-functions
+ #'font-lock-extend-region-wholelines
+ #'font-lock-extend-region-multiline)))
+ ;; -----------------------------------------------------------------
+ ;; Comments. Mostly borrowed from lisp-mode and/or scheme-mode
+ (setq-local comment-start ";")
+ (setq-local comment-add 1) ;default to `;;' in comment-region
+ (setq-local comment-start-skip ";+ *")
+ (setq-local comment-column 40)
+ (setq-local comment-multi-line t) ;for auto-fill-mode and #||# comments
+ ;; Font lock mode uses this only when it knows a comment is starting:
+ (setq-local font-lock-comment-start-skip ";+ *")
+ ;; -----------------------------------------------------------------
+ ;; Indent
+ (setq-local indent-line-function #'racket-indent-line)
+ (setq-local indent-tabs-mode nil)
+ ;; -----------------------------------------------------------------
+ ;;; Misc
+ (setq-local local-abbrev-table racket-mode-abbrev-table)
+ (setq-local paragraph-start (concat "$\\|" page-delimiter))
+ (setq-local paragraph-separate paragraph-start)
+ (setq-local paragraph-ignore-fill-prefix t)
+ (setq-local fill-paragraph-function #'lisp-fill-paragraph)
+ (setq-local adaptive-fill-mode nil)
+ (setq-local outline-regexp ";;; \\|(....")
+ (setq-local beginning-of-defun-function
#'racket--beginning-of-defun-function)
(setq-local imenu-create-index-function #'racket-imenu-create-index-function)
(hs-minor-mode t)
(setq-local completion-at-point-functions (list #'racket-complete-at-point))
(setq-local eldoc-documentation-function nil)
- (funcall (or (and (functionp racket-repl-buffer-name-function)
- racket-repl-buffer-name-function)
- #'racket-repl-buffer-name-shared))
- (add-hook 'kill-buffer-hook
- #'racket-mode-maybe-offer-to-kill-repl-buffer
- nil t)
(add-hook 'xref-backend-functions
#'racket-mode-xref-backend-function
- nil t))
+ nil t)
+ (setq racket-submodules-at-point-function
#'racket-submodules-at-point-text-sexp))
;;;###autoload
(progn
diff --git a/racket-ppss.el b/racket-ppss.el
index 29b4c9d663..ab61925c64 100644
--- a/racket-ppss.el
+++ b/racket-ppss.el
@@ -1,4 +1,4 @@
-;;; racket-ppss.el --- Major mode for Racket language.
+;;; racket-ppss.el -*- lexical-binding: t; -*-
;; Copyright (c) 2013-2020 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
diff --git a/racket-profile.el b/racket-profile.el
index 415f4e6302..c99c245220 100644
--- a/racket-profile.el
+++ b/racket-profile.el
@@ -32,8 +32,7 @@ results.
Caveat: Only source files are instrumented. You may need to
delete compiled/*.zo files."
(interactive)
- (unless (eq major-mode 'racket-mode)
- (user-error "Works only in a racket-mode buffer"))
+ (racket--assert-edit-mode)
(message "Running with profiling instrumentation...")
(let ((buf-name (format "*Racket Profile <%s>*"
(racket-back-end-name)))
diff --git a/racket-repl-buffer-name.el b/racket-repl-buffer-name.el
index 58c715610e..bb1d9b43fc 100644
--- a/racket-repl-buffer-name.el
+++ b/racket-repl-buffer-name.el
@@ -62,7 +62,7 @@ Offer to kill a `racket-repl-mode' buffer when killing the
last
so, a user might want to do some \"cleanup\" -- especially if
they're using a `racket-repl-buffer-name-function' such as
`racket-repl-buffer-name-unique'."
- (when (eq major-mode 'racket-mode)
+ (when (racket--edit-mode-p)
(pcase (get-buffer racket-repl-buffer-name)
((and (pred bufferp) repl-buffer)
(let ((n (1-
@@ -86,7 +86,7 @@ they're using a `racket-repl-buffer-name-function' such as
(defun racket--buffers-using-repl (repl-buffer-name)
(seq-filter (lambda (buffer)
(with-current-buffer buffer
- (and (eq major-mode 'racket-mode)
+ (and (racket--edit-mode-p)
(equal racket-repl-buffer-name repl-buffer-name))))
(buffer-list)))
diff --git a/racket-repl.el b/racket-repl.el
index f1dc8ef4ad..ee16aaf162 100644
--- a/racket-repl.el
+++ b/racket-repl.el
@@ -1,6 +1,6 @@
;;; racket-repl.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; Copyright (c) 2013-2023 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Image portions Copyright (C) 2012 Jose Antonio Ortega Ruiz.
@@ -22,7 +22,6 @@
(require 'racket-visit)
(require 'racket-cmd)
(require 'racket-back-end)
-(require 'comint)
(require 'compile)
(require 'easymenu)
(require 'cl-lib)
@@ -30,54 +29,76 @@
(require 'rx)
(require 'xref)
(require 'semantic/symref/grep)
+(require 'ring)
-(defvar racket--back-end-auth-token)
(declare-function racket--what-to-run-p "racket-common" (v))
;; Don't (require 'racket-debug). Mutual dependency. Instead:
(declare-function racket--debuggable-files "racket-debug" (file-to-run))
(autoload 'racket--debuggable-files "racket-debug")
-;;; racket-mode <=> racket-repl-mode associations
+;;; edit buffers <=> `racket-repl-mode' buffers
;; There are some nuances here regarding these variables being
;; buffer-local or not, and, whether the variables have any meaning in
;; certain modes, or not. We use Emacs variable semantics to handle
-;; the association between `racket-mode' edit buffers and
-;; `racket-repl-mode' buffers, for a variety of use cases the user
-;; might prefer. These range from all edit buffers sharing one REPL
-;; buffer (the traditional default for Racket Mode), up to each edit
-;; buffers having its own REPL (as in Dr Racket), or anything in
-;; between (such as one REPL per projectile project, or whatever).
-;; Some of these scenarios might benefit from some higher-level UI.
-;; But ultimately they reduce to setting the variable
-;; `racket-repl-buffer-name' globally and/or locally for `racket-mode'
-;; buffers -- that is the fundamental representation. Similarly, each
-;; `racket-repl-mode' buffer has an always-buffer-local value for the
-;; variable `racket--repl-session-id'. (Note that
-;; `racket-repl-buffer-name' only has meaning for `racket-mode'
-;; buffers, and `racket--repl-session-id' only has meaning for
-;; `racket-repl-mode' buffers. Emacs variables exist for all buffers
-;; using all major modes. All we can do is remember in which buffers
-;; they mean something as opposed to being ignored..)
+;; the association between `racket-mode' or `racket-hash-lang-mode'
+;; edit buffers and `racket-repl-mode' buffers, for a variety of use
+;; cases the user might prefer. These range from all edit buffers
+;; sharing one REPL buffer (the traditional default for Racket Mode),
+;; up to each edit buffers having its own REPL (as in Dr Racket), or
+;; anything in between (such as one REPL per projectile project, or
+;; whatever).
+;;
+;; Although some of these scenarios might benefit from a higher-level
+;; UI, they all come down to setting the variable
+;; `racket-repl-buffer-name' globally and/or locally for each edit
+;; buffer -- that is the fundamental representation.
+;;
+;; Similarly, each `racket-repl-mode' buffer has an
+;; always-buffer-local value for the variable
+;; `racket--repl-session-id'. (Note that `racket-repl-buffer-name'
+;; only has meaning for `racket-mode' buffers, and
+;; `racket--repl-session-id' only has meaning for `racket-repl-mode'
+;; buffers. Emacs variables exist for all buffers using all major
+;; modes. All we can do is remember in which buffers they mean
+;; something as opposed to being ignored.)
(defvar racket-repl-buffer-name nil
"The name of the `racket-repl-mode' buffer associated with `racket-mode'
buffer.
Important: This variable only means something in each
-`racket-mode' buffer. It has no meaning in `racket-repl-mode' or
-other buffers.
+`racket-mode' or `racket-hash-lang-mode' edit buffer. It has no
+meaning in `racket-repl-mode' or other buffers.
-By default all `racket-mode' edit buffers share the same REPL.
+When nil, all `racket-mode' edit buffers share the same REPL.
However, a buffer may `setq-local' this to some other value. See
-the defcustom `racket-repl-buffer-name-function' and example
+the defcustom `racket-repl-buffer-name-function' as well as several
values for it in racket-repl-buffer-name.el.")
+(defun racket--call-with-repl-buffer (thunk)
+ (pcase (if (eq major-mode 'racket-repl-mode)
+ (buffer-name)
+ racket-repl-buffer-name)
+ ((and (pred stringp) name)
+ (pcase (get-buffer name)
+ ((and (pred bufferp) (pred buffer-live-p) buf)
+ (with-current-buffer buf (funcall thunk)))))))
+
+(defmacro with-racket-repl-buffer (&rest body)
+ "Execute forms in BODY with `racket-repl-mode' temporarily current buffer."
+ (declare (indent 0) (debug t))
+ `(racket--call-with-repl-buffer (lambda () ,@body)))
+
+;;; REPL back end sessions <=> `racket-repl-mode' buffers
+
+(defvar racket--repl-next-session-id 0)
+
(defvar-local racket--repl-session-id nil
- "The REPL session ID returned from the back end.
+ "An ID for each back end REPL session.
-Must be supplied in command requests, although for some commands
-it can be nil.
+Commands that are about a specific REPL session must supply this;
+see `racket--cmd/async'.
Important: This variable only means something in each
`racket-repl-mode' buffer. It has no meaning in `racket-mode' or
@@ -98,77 +119,297 @@ but does not have a live session."
(with-current-buffer racket-repl-buffer-name
racket--repl-session-id))))))
-(defun racket--call-with-repl-buffer (thunk)
- (pcase (if (eq major-mode 'racket-repl-mode)
- (buffer-name)
- racket-repl-buffer-name)
- ((and (pred stringp) name)
- (pcase (get-buffer name)
- ((and (pred bufferp) buf)
- (with-current-buffer buf (funcall thunk)))))
- (v (error "bad racket-repl-buffer-name: %s" v))))
-
-(defmacro with-racket-repl-buffer (&rest body)
- "Execute forms in BODY with `racket-repl-mode' temporarily current buffer."
- (declare (indent 0) (debug t))
- `(racket--call-with-repl-buffer (lambda () ,@body)))
-
-(defun racket--repl-live-p ()
- "Does a Racket REPL buffer exist and have a live Racket process?"
- (and (racket--repl-session-id)
- (comint-check-proc racket-repl-buffer-name)))
-
-;;; Misc
+(defun racket--call-with-repl-session-id (id proc &rest args)
+ "Find `racket-repl-mode' buffer with `racket--repl-session-id'
+`eq' to ID. Apply ARGS to PROC while that is current buffer."
+ ;; If searching buffer-list too slow, we could maintain a hash table
+ ;; and clean it with a kill-buffer hook.
+ (seq-some (lambda (buf)
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (when (and (eq major-mode 'racket-repl-mode)
+ (eq racket--repl-session-id id))
+ (apply proc args)
+ t))))
+ (buffer-list)))
-(defun racket-repl--input-filter (str)
- "Don't save anything matching `racket-history-filter-regexp'."
- (not (string-match-p racket-history-filter-regexp str)))
+(defun racket--repl-on-stop-back-end ()
+ (dolist (buf (buffer-list))
+ (with-current-buffer buf
+ (when (and (eq major-mode 'racket-repl-mode)
+ (buffer-live-p buf))
+ (racket--repl-insert-output 'exit "REPL session stopped")))))
+(add-hook 'racket-stop-back-end-hook #'racket--repl-on-stop-back-end)
+
+;;; Markers for run, interactions prompt, and program I/O
+
+(defvar-local racket--repl-run-mark nil
+ "The point at which a run command was issued.")
+
+;; Note: One goal here is to make read-only all of the output, as well
+;; as "old" input that has already been submitted. This involves
+;; paying careful attention to the read-only and rear-nonsticky
+;; properties.
+
+(defvar-local racket--repl-prompt-mark nil
+ "A marker for the start of the active prompt, if any.
+
+Non-nil only when the REPL is in a prompt-read.
+
+Marker insertion type is non-nil: text inserted there
+automatically advances the marker position.
+
+The prompt itself is read-only. `racket--repl-prompt-mark-end'
+gives the position where the following read/write portion
+starts.")
+
+(defvar-local racket--repl-output-mark nil
+ "A marker where REPL output should be inserted, and user may input.
+
+Plays a role similar to `process-mark' in `comint-mode', except
+we have no process.
+
+Various kinds of output get various field property values. All
+output is read-only, but we arrange for the last character to be
+rear-nonsticky so self-insert-command will let the user type
+input. When the user types text there and presses RET, then that
+is submitted as plain input -- as opposed to REPL interaction
+input.
+
+When `racket--repl-prompt-mark' marker exists, that always
+/follows/ `racket--repl-output-mark'. If e.g. the user program
+has a thread that continues to run after we're back at a prompt,
+its output is displayed /before/ the prompt. Otherwise with no
+live prompt this marker will be at `point-max'.")
+
+(defun racket--repl-make-prompt-mark (prompt-str)
+ (when racket--repl-prompt-mark
+ (racket--repl-delete-prompt-mark t))
+ (let ((inhibit-read-only t))
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert ?\n))
+ (let ((start (point)))
+ (insert (propertize (concat prompt-str " ")
+ 'read-only t
+ 'font-lock-face racket-repl-prompt
+ 'field 'prompt
+ 'racket-prompt t))
+ (add-text-properties (1- (point)) (point)
+ (list 'rear-nonsticky t))
+ (setq racket--repl-prompt-mark (make-marker))
+ (set-marker racket--repl-prompt-mark start)
+ ;; Marker /does/ advance when text inserted there.
+ (set-marker-insertion-type racket--repl-prompt-mark t)
+ ;; Ensure output marker position <= prompt marker position;
+ ;; output always goes /before/ the last active prompt, if any.
+ (set-marker racket--repl-output-mark
+ (min (marker-position racket--repl-output-mark)
+ (marker-position racket--repl-prompt-mark))))))
+
+(defun racket--repl-delete-prompt-mark (abandon-p)
+ (when racket--repl-prompt-mark
+ (let ((inhibit-read-only t))
+ (if abandon-p
+ (delete-region racket--repl-prompt-mark (point-max))
+ (add-text-properties (racket--repl-prompt-mark-end)
+ (point-max)
+ (list 'read-only t
+ 'field 'input)))
+ (goto-char (point-max))
+ (set-marker racket--repl-prompt-mark nil)
+ (setq racket--repl-prompt-mark nil)
+ (set-marker racket--repl-output-mark (point-max)))))
+
+(defun racket--repl-prompt-mark-end ()
+ "May return when there is no live prompt."
+ (when racket--repl-prompt-mark
+ (or (next-single-property-change racket--repl-prompt-mark 'racket-prompt)
+ (point-max))))
+
+;;; Output
+
+(defun racket--repl-on-output (session-id kind value)
+ ;;;(message "%S" (list 'racket--repl-on-output session-id kind value))
+ (racket--call-with-repl-session-id session-id
+ #'racket--repl-insert-output
+ kind value))
+
+(defun racket--repl-insert-output (kind value)
+ (let ((moving (= (point) racket--repl-output-mark))
+ (inhibit-read-only t))
+ (save-excursion
+ (goto-char racket--repl-output-mark)
+ (let ((pt (point)))
+ ;; Previous chunks of output may have ended with a
+ ;; rear-nonsticky property to allow input to follow. Now that
+ ;; we're adding more output, remove that property so there are
+ ;; no read/write "seams" between chunks.
+ (remove-text-properties (point-min) (point) '(rear-nonsticky nil))
+ (cl-flet*
+ ((fresh-line () (unless (bolp) (newline)))
+ (insert-faced (str face) (insert (propertize str 'font-lock-face
face))))
+ (cl-case kind
+ ((run)
+ (racket--repl-delete-prompt-mark 'abandon)
+ (unless (equal value "")
+ (fresh-line)
+ (insert-faced (format "————— run %s —————\n" value)
'racket-repl-message)))
+ ((prompt)
+ (racket--repl-make-prompt-mark value))
+ ((message)
+ (fresh-line)
+ (insert-faced value 'racket-repl-message)
+ (unless (bolp) (newline)))
+ ((exit)
+ (racket--repl-delete-prompt-mark 'abandon)
+ (fresh-line)
+ (insert-faced value 'racket-repl-message)
+ (unless (bolp) (newline))
+ (setq moving t) ;leave point after, for tests
+ (setq racket--repl-session-id nil))
+ ((value)
+ (insert-faced value 'racket-repl-value))
+ ((value-special)
+ (pcase-let ((`(image . ,file) value))
+ (racket--repl-insert-image file)))
+ ((error)
+ (pcase value
+ (`(,msg ,srclocs (,context-kind . ,context-names-and-locs))
+ (fresh-line)
+ (insert-faced msg 'racket-repl-error-message)
+ (newline)
+ ;; Heuristic: When something supplies exn-srclocs,
+ ;; show those only. Otherwise show context if any.
+ ;; This seems to work well for most runtime
+ ;; exceptions, as well as for rackunit test failures
+ ;; (where the srcloc suffices and the context esp
+ ;; w/errortrace is useless noise).
+ (cond (srclocs
+ (dolist (loc srclocs)
+ (insert (racket--format-error-location loc))
+ (newline)))
+ (context-names-and-locs
+ (insert-faced (format "Context (%s):" context-kind)
+ 'racket-repl-error-message)
+ (newline)
+ (dolist (v context-names-and-locs)
+ (pcase-let ((`(,name . ,loc) v))
+ (insert " ")
+ (insert (racket--format-error-location loc))
+ (insert " ")
+ (when name
+ (insert-faced name 'racket-repl-error-label)))
+ (newline)))))))
+ ((stdout)
+ (insert-faced value 'racket-repl-stdout))
+ ((stderr)
+ (insert-faced value 'racket-repl-stderr))
+ (otherwise
+ (fresh-line)
+ (insert-faced value 'racket-repl-message))))
+ (unless (eq kind 'prompt)
+ (add-text-properties pt (point)
+ (list
+ 'read-only t
+ 'field kind))
+ ;; Make last character rear-nonsticky. Among other things,
+ ;; means `racket--repl-output-mark' won't be read-only; and
+ ;; user may input there (for user program reading from
+ ;; current-input-port).
+ (add-text-properties (max (point-min) (1- (point))) (point)
+ (list 'rear-nonsticky t))
+ (set-marker racket--repl-output-mark (point))
+ ;; When stdout/stderr output ends with prompt following on
+ ;; same line, push the prompt down to its own line.
+ (when (and (memq kind '(stdout stderr))
+ racket--repl-prompt-mark
+ (equal (point) (marker-position
racket--repl-prompt-mark)))
+ (insert (propertize "\n"
+ 'read-only t
+ 'field kind))))))
+ ;; If we just inserted a new prompt, position after it.
+ (let ((win (get-buffer-window (current-buffer))))
+ (if (eq kind 'prompt)
+ (let ((pos (racket--repl-prompt-mark-end)))
+ (goto-char pos)
+ (when win (set-window-point win pos)))
+ ;; When point was exactly at the old output marker value, move
+ ;; point to follow it. (Otherwise user is navigating through
+ ;; buffer, leave them alone.)
+ (when moving
+ (goto-char racket--repl-output-mark)
+ (when win (set-window-point win racket--repl-output-mark)))))))
+
+(defun racket--repl-call-with-value-and-input-ranges (from upto proc)
+ "Call PROC with sub-ranges of FROM..UPTO, saying whether each
+is a value or input since `racket--repl-run-mark'."
+ (setq upto (min upto (point-max)))
+ ;; Everything before the last run is "stale": No.
+ (when (< from racket--repl-run-mark)
+ (funcall proc from racket--repl-run-mark nil)
+ (setq from racket--repl-run-mark))
+ (let ((prompt-end (or (racket--repl-prompt-mark-end) (point-max))))
+ (while (< from upto)
+ (cond
+ ;; If we're at/after the end of the last, live prompt, then
+ ;; everything remaining is input, yes, and we're done.
+ ((<= prompt-end from)
+ (funcall proc from upto t)
+ (setq from upto))
+ ;; Keep getting chunks at racket-output prop change boundaries,
+ ;; until we reach the earlier of prompt-end or point-max.
+ (t
+ (let ((in (memq (get-text-property from 'field) '(value input)))
+ (pos (min (or (next-single-property-change from 'field)
+ (point-max))
+ prompt-end)))
+ (funcall proc from (min pos upto) in)
+ (setq from pos)))))))
(defalias 'racket-repl-eval-or-newline-and-indent #'racket-repl-submit)
-(defun racket-repl-submit (&optional prefix)
- "Submit your input to the Racket REPL.
+(defvar-local racket-repl-submit-function nil)
-If the REPL is running a Racket lang whose language-info has a
-drracket:submit-predicate, that is first called to see if the
-input is valid to be submitted.
+(defun racket-repl-submit ()
+ "Submit interaction or input.
-\\<racket-repl-mode-map>
-With a prefix argument (e.g. \\[universal-argument] \\[racket-repl-submit]):
-
-After sending your input and a newline, also calls
-`process-send-eof' -- because some langs require EOF to mark the
-end of an interactive expression/statement."
- (interactive "P")
- (let* ((proc (get-buffer-process (current-buffer)))
- (_ (unless proc (user-error "Current buffer has no process")))
- (text (substring-no-properties (funcall comint-get-old-input)))
- (submitp
- (if racket-use-repl-submit-predicate
- (cl-case (racket--cmd/await (racket--repl-session-id)
- `(repl-submit? ,text t))
- ((t) t)
- ((nil) (user-error "Not a complete expression, according to
the current lang's submit-predicate."))
- ((default) (racket--repl-submit-p proc)))
- (racket--repl-submit-p proc))))
- (cond (submitp
- (comint-send-input)
- (remove-text-properties comint-last-input-start
- comint-last-input-end
- '(font-lock-face comint-highlight-input))
- ;; Hack for datalog/lang
- (when prefix (process-send-eof proc)))
- (t
- (message "Not yet a complete s-expression")
- (newline-and-indent)))))
-
-(defun racket--repl-submit-p (proc)
- "Is user REPL input ready to submit?
-
-True when there is at least one expression, and, all expressions
-are complete."
+When at a REPL prompt, submit as an interaction expression.
+Otherwise send to current-input-port of user program."
+ (interactive)
+ (unless (racket--repl-session-id)
+ (user-error "no REPL session"))
+ (let ((prompt-end (racket--repl-prompt-mark-end)))
+ (if (and prompt-end (< prompt-end (point-max)))
+ (let* ((input (buffer-substring-no-properties prompt-end (point-max)))
+ (input+ret (concat input "\n")))
+ (when (if racket-repl-submit-function
+ (funcall racket-repl-submit-function input+ret)
+ (racket--repl-complete-sexp-p))
+ (racket--repl-add-to-input-history input)
+ (goto-char (point-max))
+ (insert ?\n)
+ (add-text-properties prompt-end (point-max)
+ (list 'read-only t
+ 'rear-nonsticky t))
+ (racket--repl-delete-prompt-mark nil)
+ (racket--cmd/async (racket--repl-session-id) `(repl-submit
,input+ret))))
+ (end-of-line)
+ (when (< racket--repl-output-mark (point))
+ (let ((input (buffer-substring-no-properties racket--repl-output-mark
(point))))
+ ;; Intentionally do NOT `racket--repl-add-to-input-history'.
+ (insert ?\n)
+ (add-text-properties racket--repl-output-mark (point)
+ (list 'read-only t
+ 'rear-nonsticky t))
+ (set-marker racket--repl-output-mark (point))
+ (racket--cmd/async (racket--repl-session-id)
+ `(repl-input ,(concat input "\n"))))))))
+
+(defun racket--repl-complete-sexp-p ()
+ "Is there at least one complete sexp at REPL prompt?"
(condition-case nil
- (let* ((beg (marker-position (process-mark proc)))
+ (let* ((beg (racket--repl-prompt-mark-end))
(end (save-excursion
(goto-char beg)
(while (< (point) (point-max))
@@ -187,35 +428,30 @@ are complete."
(scan-error nil)))
(defun racket-repl-break ()
- "Send a break to the REPL program's main thread."
+ "Send an interrupt break to the REPL."
(interactive)
- (cond ((racket--cmd-open-p) ;don't auto-start the back end
- (racket--cmd/async (racket--repl-session-id) `(break break)))
- (t
- (user-error "Back end is not running"))))
-
-(defun racket-repl-exit (&optional killp)
- "Send a terminate break to the REPL program's main thread.
-
-If your program is running, equivalent to `racket-repl-break'.
+ (unless (racket--cmd-open-p) ;don't auto-start the back end
+ (user-error "Back end is not running"))
+ (racket--cmd/async (racket--repl-session-id) `(repl-break)))
-If already at the REPL prompt, effectively the same as entering
-\"(exit)\" at the prompt, but works even when the module language
-doesn't provide any binding for \"exit\".
-
-\\<racket-repl-mode-map>
-With a prefix argument (e.g. \\[universal-argument] \\[racket-repl-exit]):
+(defun racket-repl-exit ()
+ "Exit the REPL session.
-Terminates the entire Racket Mode back end process --- the
-command server and all REPL sessions."
- (interactive "P")
- (cond (killp
- (message "Killing entire Racket Mode back end process")
- (racket--cmd-close))
- ((racket--cmd-open-p) ;don't auto-start the back end
- (racket--cmd/async (racket--repl-session-id) `(break terminate)))
- (t
- (user-error "Back end is not running"))))
+Equivalent to entering \"(exit)\" at the REPL prompt, but works
+even when the module language doesn't provide any binding for
+\"exit\"."
+ (interactive)
+ ;; Avoid sending a command about exiting a REPL session that can't
+ ;; exist because the back end isn't running. That's worse than a
+ ;; no-op; that would auto-start the back end for no good reason now.
+ (when (racket--cmd-open-p)
+ (when (racket--repl-session-id)
+ ;; Note: We don't `(setq racket--repl-session-id nil)` here
+ ;; because (1) the repl buffer isn't necessarily current and
+ ;; anyway (2) we want to allow our output handler function to
+ ;; get the "exit" message from the back end; it will set nil,
+ ;; then.
+ (racket--cmd/async (racket--repl-session-id) `(repl-exit)))))
(declare-function racket-call-racket-repl-buffer-name-function
"racket-repl-buffer-name" ())
(autoload 'racket-call-racket-repl-buffer-name-function
"racket-repl-buffer-name")
@@ -242,18 +478,11 @@ Mode's REPL as intended, then consider using a plain Emacs
`shell' buffer to run command-line Racket."
(interactive "P")
(racket-call-racket-repl-buffer-name-function)
- (cl-flet
- ((display-and-maybe-select
- ()
- (display-buffer racket-repl-buffer-name)
- (unless noselect
- (select-window (get-buffer-window racket-repl-buffer-name t)))))
- (if (racket--repl-live-p)
- (display-and-maybe-select)
- (racket--repl-start
- (lambda ()
- (racket--repl-refresh-namespace-symbols)
- (display-and-maybe-select))))))
+ (racket--repl-ensure-buffer-and-session
+ (lambda (repl-buffer)
+ (racket--repl-refresh-namespace-symbols)
+ (unless noselect
+ (select-window (get-buffer-window repl-buffer t))))))
;;; Run
@@ -309,17 +538,9 @@ See also `racket-run-and-switch-to-repl', which is even
more like
Dr Racket's Run command because it selects the REPL window after
running.
-In the `racket-repl-mode' buffer, output that describes a file
-and position is automatically \"linkified\". Examples of such
-text include:
-
-- Racket error messages.
-- rackunit test failure location messages.
-- print representation of path objects.
-
-To visit these locations, move point there and press RET or mouse
+To visit error locations, move point there and press RET or mouse
click. Or, use the standard `next-error' and `previous-error'
-commands."
+commands from either the edit or REPL buffer."
(interactive "P")
(racket--repl-run (list (racket--buffer-file-name))
racket-submodules-to-run
@@ -483,6 +704,9 @@ The following values will /not/ work:
(defvar racket--repl-before-run-hook nil
"Thunks to do before each `racket--repl-run'.
+Here \"before\" means that the `racket-repl-mode' buffer might not
+exist yet.
+
This hook is for internal use by Racket Mode. An equivalent hook
for end user customization is `racket-before-run-hook'.")
@@ -511,14 +735,8 @@ CONTEXT-LEVEL should be a valid value for the variable
defaults to the variable `racket-error-context'.
CALLBACK is used as the callback for `racket--cmd/async'; it may
-be nil which is equivalent to #\\='ignore.
-
-If not `racket--repl-live-p', start it and supply the run
-command via the start callback.the REPL is not live, create it.
-
-Otherwise if `racket--repl-live-p', send the command."
- (unless (eq major-mode 'racket-mode)
- (user-error "Racket Mode run command only works from a `racket-mode'
buffer"))
+be nil which is equivalent to #\\='ignore."
+ (racket--assert-edit-mode)
;; Support running buffers created by `org-edit-src-code': see
;; issues #626, #630.
(when (bound-and-true-p org-src-mode)
@@ -551,16 +769,13 @@ Otherwise if `racket--repl-live-p', send the command."
changes
(racket-back-end-name)))
(message "")
- ;; Starting a new REPL process here seems to be reliable only if
- ;; we stop the back end and wait for the old REPL process to
- ;; die.
- (racket-stop-back-end)
- (with-temp-message "Waiting for old REPL to terminate..."
- (while (racket--repl-live-p)
- (accept-process-output)))
(racket-start-back-end)))
- (run-hook-with-args 'racket--repl-before-run-hook) ;ours
- (run-hook-with-args 'racket-before-run-hook) ;user's
+
+ (racket--repl-delete-prompt-mark 'abandon)
+ (with-racket-repl-buffer ;if it already exists
+ (set-marker racket--repl-run-mark (point)))
+ (run-hooks 'racket--repl-before-run-hook
+ 'racket-before-run-hook)
(pcase-let*
((context-level (or context-level racket-error-context))
(what (or what (racket--what-to-run)))
@@ -585,25 +800,13 @@ Otherwise if `racket--repl-live-p', send the command."
(buf (current-buffer))
(after (lambda (_ignore)
(with-current-buffer buf
- (run-hook-with-args 'racket--repl-after-run-hook) ;ours
- (run-hook-with-args 'racket-after-run-hook) ;user's
+ (run-hooks 'racket--repl-after-run-hook
+ 'racket-after-run-hook)
(when callback
(funcall callback))))))
- (cond ((racket--repl-live-p)
- (unless (racket--repl-session-id)
- (error "No REPL session"))
- (racket--cmd/async (racket--repl-session-id) cmd after)
- (display-buffer racket-repl-buffer-name))
- (t
- (racket--repl-start
- (lambda ()
- (when noninteractive
- (princ "{racket--repl-run}: callback from racket--repl-start
called\n"))
- (with-current-buffer buf
- (unless (racket--repl-session-id)
- (error "No REPL session"))
- (racket--cmd/async (racket--repl-session-id) cmd after)
- (display-buffer racket-repl-buffer-name))))))))
+ (racket--repl-ensure-buffer-and-session
+ (lambda (_repl-buffer)
+ (racket--cmd/async (racket--repl-session-id) cmd after)))))
(defun racket--write-contents ()
(write-region nil nil buffer-file-name)
@@ -616,90 +819,40 @@ Otherwise if `racket--repl-live-p', send the command."
(set-window-buffer nil (current-buffer))
(car (window-text-pixel-size nil (line-beginning-position) (point))))))
-(defun racket--repl-start (callback)
- "Create a `comint-mode' / `racket-repl-mode' buffer connected to a REPL
session.
-
-Sets `racket--repl-session-id'.
-
-This does not display the buffer or change the selected window."
- (when noninteractive (princ "{racket--repl-start}: entered\n"))
- ;; Capture buffer-local values for this buffer, to use in command
- ;; callback below.
- (let ((name racket-repl-buffer-name)
- (host (racket--back-end-actual-host)))
- ;; Issue the command to learn the ephemeral TCP port chosen by the
- ;; back end for REPL I/O. As a bonus, this will start the back end
- ;; if necessary.
- (racket--cmd/async
- nil
- `(repl-tcp-port-number)
- (lambda (port)
- (when noninteractive
- (princ (format "{racket--repl-start}: (repl-tcp-port-number) replied
%s\n"
- port)))
- (with-current-buffer (get-buffer-create name)
- ;; Add a pre-output hook that -- possibly over multiple calls
- ;; to accumulate text -- reads `(ok ,id) to set
- ;; `racket--repl-session-id' then removes itself.
- (let ((hook nil)
- (read-buf (generate-new-buffer "
*racket-repl-session-id-reader*")))
- (when noninteractive
- (princ (format "{racket--repl-start}: buffer is '%s'\n"
read-buf)))
- (setq hook (lambda (txt)
- (when noninteractive
- (princ (format "{racket--repl-start}: early
pre-output-hook called '%s'\n" txt)))
- (with-current-buffer read-buf
- (goto-char (point-max))
- (insert txt)
- (goto-char (point-min)))
- (pcase (ignore-errors (read read-buf))
- (`(ok ,id)
- (remove-hook 'comint-preoutput-filter-functions
hook t)
- (when noninteractive
- (princ (format "{racket--repl-start}: %s\n" id)))
- (setq racket--repl-session-id id)
- (run-with-timer 0.001 nil callback)
- (prog1
- (with-current-buffer read-buf
- (buffer-substring (if (eq (char-after) ?\n)
- (1+ (point))
- (point))
- (point-max)))
- (kill-buffer read-buf)))
- (_ ""))))
- (add-hook 'comint-preoutput-filter-functions hook nil t))
-
- (condition-case ()
- (let ((auth racket--back-end-auth-token))
- (make-comint-in-buffer name
- (current-buffer)
- (cons host port))
- (process-send-string (get-buffer-process (current-buffer))
- (format "\"%s\"\n" auth))
- (when noninteractive
- (princ
- (format "{racket--repl-start}: did process-send-string of
auth %s\n"
- auth)))
- (set-process-coding-system (get-buffer-process (current-buffer))
- 'utf-8 'utf-8) ;for e.g. λ
- ;; Buffer might already be in `racket-repl-mode' -- e.g.
- ;; `racket-repl-exit' was used and now we're
- ;; "restarting". In that case avoid re-initialization
- ;; that is at best unnecessary or at worst undesirable
- ;; (e.g. `comint-input-ring' would lose input history).
- (unless (eq major-mode 'racket-repl-mode)
- (when noninteractive
- (princ "{racket--repl-start}: (racket-repl-mode)\n"))
- (racket-repl-mode)))
- (file-error
- (let ((kill-buffer-query-functions nil)
- (kill-buffer-hook nil))
- (kill-buffer)) ;don't leave partially initialized REPL buffer
- (message "Could not connect to REPL TCP server at %s:%s%s"
- host
- port
- (if (equal host "127.0.0.1")
- "" "; do you need to open a firewall?")))))))))
+(defun racket--repl-ensure-buffer-and-session (continue)
+ "Ensure a `racket-repl-mode' buffer exists with a live session.
+
+Create the buffer if necessary, enabling `racket-repl-mode'.
+
+Start the session if necessary.
+
+Calls CONTINUE with one argument, the repl buffer.
+
+This displays the buffer but does not change the selected window."
+ (let ((repl-buf (or (get-buffer racket-repl-buffer-name)
+ (with-current-buffer (get-buffer-create
racket-repl-buffer-name)
+ (racket-repl-mode)
+ (add-hook 'kill-buffer-hook #'racket-repl-exit nil t)
+ (current-buffer)))))
+ (display-buffer repl-buf)
+ (with-current-buffer repl-buf
+ (if racket--repl-session-id
+ (funcall continue repl-buf)
+ (setq racket--repl-session-id (cl-incf racket--repl-next-session-id))
+ (when noninteractive
+ (princ (format "{racket--repl-start}: picked next session id %S\n"
+ racket--repl-session-id)))
+ (goto-char (point-max))
+ (racket--repl-delete-prompt-mark t)
+ (setq racket--repl-run-mark (point-marker))
+ (setq racket--repl-output-mark (point-marker))
+ (set-marker-insertion-type racket--repl-output-mark nil)
+ (unless (racket--cmd-open-p)
+ (racket--repl-insert-output 'message "Starting back end..."))
+ (racket--cmd/async nil
+ `(repl-start ,racket--repl-session-id)
+ (lambda (_id)
+ (funcall continue repl-buf)))))))
;;; Misc
@@ -708,7 +861,7 @@ This does not display the buffer or change the selected
window."
The result can be nil if the REPL is not started, or if it is
running no particular file."
- (when (comint-check-proc racket-repl-buffer-name)
+ (when (racket--repl-session-id)
(racket--cmd/await (racket--repl-session-id) `(path))))
(defun racket--in-repl-or-its-file-p ()
@@ -733,14 +886,14 @@ most recent `racket-mode' buffer, if any."
((and (pred bufferp) buffer) (pop-to-buffer buffer t))
(_ (other-window 1)
(find-file path))))
- (_ (pcase (racket--most-recent-racket-mode-buffer)
+ (_ (pcase (racket--most-recent-edit-buffer)
((and (pred bufferp) buffer) (pop-to-buffer buffer t))
(_ (user-error "There are no racket-mode buffers"))))))
-(defun racket--most-recent-racket-mode-buffer ()
+(defun racket--most-recent-edit-buffer ()
(cl-some (lambda (b)
(with-current-buffer b
- (and (eq major-mode 'racket-mode) b)))
+ (and (racket--edit-mode-p) b)))
(buffer-list)))
;;; send to REPL
@@ -758,25 +911,28 @@ Finally, displays the REPL buffer in some window, so the
user may
see the results."
(unless (and start end)
(error "start and end must not be nil"))
- (unless (racket--repl-live-p)
+ (unless (racket--repl-session-id)
(user-error "No REPL session available; run the file first"))
- ;; Save the current buffer in case something changes it before we
- ;; call `comint-send-region'; see e.g. issue 407.
+ ;; Capture source buffer in case something changes; see e.g. #407.
(let ((source-buffer (current-buffer)))
(racket--repl-forget-errors)
- (let ((proc (get-buffer-process racket-repl-buffer-name)))
- (with-racket-repl-buffer
- (save-excursion
- (goto-char (process-mark proc))
- (insert ?\n)
- (when echo-p
- (insert (with-current-buffer source-buffer
- (buffer-substring start end)))
- (insert "\n;; =>\n"))
- (set-marker (process-mark proc) (point))))
- (with-current-buffer source-buffer
- (comint-send-region proc start end)
- (comint-send-string proc "\n")))
+ (with-racket-repl-buffer
+ (save-excursion
+ (racket--repl-delete-prompt-mark nil)
+ (goto-char (point-max))
+ (insert ?\n)
+ (when echo-p
+ (insert (with-current-buffer source-buffer
+ (buffer-substring start end)))
+ (insert (propertize "\n=>\n"
+ 'font-lock-face 'racket-repl-message)))
+ (add-text-properties racket--repl-output-mark (point)
+ (list 'field 'send
+ 'read-only t))
+ (set-marker racket--repl-output-mark (point))))
+ (racket--cmd/async (racket--repl-session-id)
+ `(repl-submit ,(with-current-buffer source-buffer
+ (buffer-substring-no-properties start
end))))
(display-buffer racket-repl-buffer-name)))
(defun racket-send-region (start end)
@@ -805,7 +961,7 @@ without the #; prefix.
\\<racket-mode-map>
With a prefix argument (e.g. \\[universal-argument]
\\[racket-send-last-sexp]), the sexp is copied
-into the REPL, followed by a \";; ->\\n\" line, to distinguish it
+into the REPL, followed by a \"=>\" line, to distinguish it
from the zero or more values to which it evaluates."
(interactive "P")
(racket--send-region-to-repl (racket--start-of-previous-expression)
@@ -820,7 +976,7 @@ The eventual results are presented using the variable
The expression may be either an at-expression or an s-expression."
(interactive)
- (unless (racket--repl-live-p)
+ (unless (racket--repl-session-id)
(user-error "No REPL session available; run the file first"))
(let ((beg (racket--start-of-previous-expression))
(end (point)))
@@ -849,24 +1005,6 @@ The expression may be either an at-expression or an
s-expression."
(+ (point) 2)
(point)))))
-(defun racket--repl-forget-errors ()
- "Forget existing errors in the REPL.
-Although they remain clickable they will be ignored by
-`next-error' and `previous-error'"
- (with-racket-repl-buffer
- (compilation-forget-errors)
- ;; `compilation-forget-errors' may have just set
- ;; `compilation-messages-start' to a marker at position 1. But in
- ;; that case process output (including error messages) will be
- ;; inserted ABOVE the marker, in which case `next-error' won't see
- ;; them. Instead use a non-marker position like 1 or use nil.
- (when (and (markerp compilation-messages-start)
- (equal (marker-position compilation-messages-start) 1)
- (equal (marker-buffer compilation-messages-start)
(current-buffer)))
- (setq compilation-messages-start nil))))
-
-(add-hook 'racket--repl-before-run-hook #'racket--repl-forget-errors)
-
;;; Inline images in REPL
(defvar racket-image-cache-dir nil)
@@ -897,48 +1035,28 @@ images in `racket-image-cache-dir'."
racket-images-keep-last))
(delete-file file)))
-(defun racket-repl-display-images (_txt)
- "Replace all image patterns with actual images.
-A value for the variable `comint-output-filter-functions'."
- (with-silent-modifications
- (save-excursion
- (goto-char (if (and (markerp comint-last-output-start)
- (eq (marker-buffer comint-last-output-start)
- (current-buffer))
- (marker-position comint-last-output-start))
- comint-last-output-start
- (point-min-marker)))
- (forward-line 0) ;in case comint-last-output-start left mid line: #535
- (let ((pmark (process-mark (get-buffer-process (current-buffer)))))
- (while (re-search-forward "\"#<Image: \\(.+?racket-image-.+?\\)>\""
- pmark
- t)
- (let* ((beg (match-beginning 0))
- (file (match-string-no-properties 1))
- (file (save-match-data (racket-file-name-back-to-front file)))
- (file (save-match-data (or (file-local-copy file) file))))
- (cond ((and racket-images-inline (display-images-p))
- (replace-match "")
- (insert-image
- (apply #'create-image
- file
- (and (image-type-available-p 'imagemagick)
- racket-imagemagick-props
- 'imagemagick)
- nil ;data-p
- (append
- '(:scale 1.0) ;#529
- (and (image-type-available-p 'imagemagick)
- racket-imagemagick-props)))))
- (t
- (replace-match (format "[file://%s]" file))))
- (set-marker pmark (max pmark (point)))
- (add-text-properties beg (point)
- `(keymap ,racket-image-map
- racket-image ,file
- help-echo "RET or Mouse-2 to view image"))
- (setq racket-image-cache-dir (file-name-directory file))
- (racket-repl--clean-image-cache)))))))
+(defun racket--repl-insert-image (file)
+ (let ((beg (point)))
+ (if (and racket-images-inline (display-images-p))
+ (insert-image
+ (apply #'create-image
+ file
+ (and (image-type-available-p 'imagemagick)
+ racket-imagemagick-props
+ 'imagemagick)
+ nil ;data-p
+ (append
+ '(:scale 1.0) ;#529
+ (and (image-type-available-p 'imagemagick)
+ racket-imagemagick-props))))
+ (insert (propertize (format "[file://%s]" file)
+ 'font-lock-face 'italic)))
+ (add-text-properties beg (point)
+ (list 'keymap racket-image-map
+ 'racket-image file
+ 'help-echo "RET or Mouse-2 to view image"))
+ (setq racket-image-cache-dir (file-name-directory file))
+ (racket-repl--clean-image-cache)))
(defun racket-view-image ()
"View the image at point using `racket-images-system-viewer'."
@@ -969,11 +1087,10 @@ image."
(defvar racket--repl-namespace-symbols nil)
(defun racket--repl-refresh-namespace-symbols ()
- (racket--cmd/async
- (racket--repl-session-id)
- '(syms)
- (lambda (syms)
- (setq racket--repl-namespace-symbols syms))))
+ (racket--cmd/async (racket--repl-session-id)
+ '(syms)
+ (lambda (syms)
+ (setq racket--repl-namespace-symbols syms))))
(add-hook 'racket--repl-after-run-hook
#'racket--repl-refresh-namespace-symbols)
@@ -1162,54 +1279,6 @@ The command varies based on how many
\\[universal-argument] command prefixes you
(interactive "P")
(racket--doc prefix 'namespace racket--repl-namespace-symbols))
-;;; compilation-mode
-
-(defconst racket--compilation-error-regexp-alist
- (list
- ;; Any apparent file:line[:.]col optionally prefaced by
- ;; "#<syntax:".
- (list (rx (optional "#<syntax:")
- (group-n 1
- (+ (not (any " \r\n")))
- ?.
- (+ (not (any " \r\n"))))
- ?\:
- (group-n 2 (+ digit))
- (any ?\: ?\.)
- (group-n 3 (+ digit)))
- #'racket--adjust-group-1 2 3)
- ;; Any path struct
- (list (rx "#<path:" (group-n 1 (+? (not (any ?\>)))) ?\>)
- #'racket--adjust-group-1 nil nil 0)
- ;; Any (srcloc path line column ...) struct
- (list (rx "(" "srcloc" (+ space)
- ;; path
- "\"" (group-n 1 (+? any)) "\""
- ;; line
- (+ space) (group-n 2 (+ digit))
- ;; column
- (+ space) (group-n 3 (+ digit)))
- #'racket--adjust-group-1 2 3 0 1)
- ;; Any htdp check-expect failure message
- (list (rx "In "
- (group-n 1
- (+ (not (any " \r\n")))
- ?.
- (+ (not (any " \r\n"))))
- " at line "
- (group-n 2 (+ digit))
- " column "
- (group-n 3 (+ digit)))
- #'racket--adjust-group-1 2 3))
- "Our value for the variable `compilation-error-regexp-alist'.")
-
-(defun racket--adjust-group-1 ()
- (let ((file (match-string 1)))
- (if (string-match-p (rx "...") file) ;#604
- "*unknown*"
- (save-match-data
- (racket-file-name-back-to-front file)))))
-
;;; racket-repl-mode definition per se
(defvar racket-repl-mode-map
@@ -1219,9 +1288,12 @@ The command varies based on how many
\\[universal-argument] command prefixes you
("TAB" indent-for-tab-command)
("C-M-u" racket-backward-up-list)
("C-M-q" prog-indent-sexp)
- ("C-a" comint-bol)
- ("C-w" comint-kill-region)
- ("<C-S-backspace>" comint-kill-whole-line)
+ ("M-p" racket-repl-previous-input)
+ ("M-n" racket-repl-next-input)
+ ("C-c C-u" racket-repl-clear-input)
+ ("C-c C-p" racket-repl-previous-prompt)
+ ("C-c C-n" racket-repl-next-prompt)
+ ("C-c C-o" racket-repl-delete-output)
("C-c C-e f" racket-expand-file)
("C-c C-e x" racket-expand-definition)
("C-c C-e e" racket-expand-last-sexp)
@@ -1261,7 +1333,22 @@ The command varies based on how many
\\[universal-argument] command prefixes you
"---"
["Switch to Edit Buffer" racket-repl-switch-to-edit]))
-(define-derived-mode racket-repl-mode comint-mode "Racket-REPL"
+(defun racket--repl-limited-fontify-region (original)
+ "Limit a `font-lock-fontify-region-function' to certain spans.
+
+The resulting function uses ORIGINAL only to fontify input and
+value output spans since the last run -- see also
+`racket--hash-lang-configure-repl-buffer-from-edit-buffer'. Other
+spans are just marked fontified with no action."
+ (lambda (beg end loudly)
+ (racket--repl-call-with-value-and-input-ranges
+ beg end
+ (lambda (beg end v)
+ (when v (funcall original beg end loudly))))
+ (put-text-property beg end 'fontified t)
+ `(jit-lock-bounds ,beg . ,end)))
+
+(define-derived-mode racket-repl-mode fundamental-mode "Racket-REPL"
"Major mode for Racket REPL.
You may use `xref-find-definitions' \\[xref-find-definitions] and
@@ -1271,38 +1358,36 @@ You may use `xref-find-definitions'
\\[xref-find-definitions] and
identifier bindings and modules from the REPL's namespace.
\\{racket-repl-mode-map}"
- (racket--common-variables)
- (setq-local comint-use-prompt-regexp nil)
- (setq-local comint-prompt-read-only t)
- (setq-local comint-scroll-show-maximum-output nil) ;t slow for big outputs
- (setq-local mode-line-process nil)
+ ;; Here we set some values that will definitely be used when the
+ ;; buffer is created by the `racket-repl' command. Otherwise,
+ ;; `racket--hash-lang-configure-repl-buffer-from-edit-buffer' will
+ ;; refresh these upon each run command via
+ ;; `racket--repl-before-run-hook', drawing values from the
+ ;; `racket-mode' or `racket-hash-lang-mode' edit buffer to also use
+ ;; in the repl.
+ (setq-local font-lock-fontify-region-function
+ (racket--repl-limited-fontify-region
#'font-lock-default-fontify-region))
+ (font-lock-set-defaults)
+ (setq-local window-point-insertion-type t)
+ (setq-local indent-line-function #'racket-indent-line)
+ (setq-local indent-tabs-mode nil)
(setq-local completion-at-point-functions (list
#'racket-repl-complete-at-point))
(setq-local eldoc-documentation-function nil)
- (define-key racket-repl-mode-map [menu-bar signals] 'undefined)
- (add-hook 'comint-output-filter-functions #'racket-repl-display-images nil t)
- (compilation-setup t)
- (setq-local compilation-error-regexp-alist
racket--compilation-error-regexp-alist)
- ;; Persistent history
- (setq-local comint-input-autoexpand nil) ;#450
- (setq-local comint-input-filter #'racket-repl--input-filter)
- (make-directory racket-repl-history-directory t)
- (setq-local comint-input-ring-file-name
- (expand-file-name (racket--buffer-name-slug)
- racket-repl-history-directory))
- (comint-read-input-ring t)
- (add-hook 'kill-buffer-hook #'comint-write-input-ring nil t)
- (add-hook 'kill-emacs-hook #'racket--repl-save-all-histories nil t)
+ (setq-local next-error-function #'racket-repl-next-error)
+ (racket-repl-read-history)
+ (add-hook 'kill-buffer-hook #'racket-repl-write-history nil t)
+ (add-hook 'kill-emacs-hook #'racket-repl-write-all-histories nil t)
(add-hook 'xref-backend-functions #'racket-repl-xref-backend-function nil t)
(add-to-list 'semantic-symref-filepattern-alist
'(racket-repl-mode "*.rkt" "*.rktd" "*.rktl")))
-(defun racket--repl-save-all-histories ()
- "Call comint-write-input-ring for all `racket-repl-mode' buffers.
+(defun racket-repl-write-all-histories ()
+ "Call `racket-repl-write-history' for all `racket-repl-mode' buffers.
A suitable value for the hook `kill-emacs-hook'."
(dolist (buf (buffer-list))
(with-current-buffer buf
(when (eq major-mode 'racket-repl-mode)
- (comint-write-input-ring)))))
+ (racket-repl-write-history)))))
(defun racket--buffer-name-slug ()
"Change `buffer-name' to a string that is a valid filename."
@@ -1317,6 +1402,8 @@ A suitable value for the hook `kill-emacs-hook'."
"-"
(buffer-name))))
+;;; Clearing the REPL
+
(defun racket-repl-clear ()
"Delete all text in the REPL.
@@ -1328,10 +1415,6 @@ Emacs init file something like:
(add-hook \\='racket-before-run-hook #\\='racket-repl-clear)
See also the command `racket-repl-clear-leaving-last-prompt'."
- ;; This prevents a first blank line, by telling the back end that
- ;; output is no longer sitting at some non-zero column after a
- ;; prompt; therefore fresh-line won't need to issue a newline.
- (racket--cmd/async (racket--repl-session-id) `(repl-zero-column))
(racket--do-repl-clear nil))
(defun racket-repl-clear-leaving-last-prompt ()
@@ -1340,32 +1423,218 @@ See also the command
`racket-repl-clear-leaving-last-prompt'."
(racket--do-repl-clear t))
(defun racket--do-repl-clear (leave-last-prompt-p)
- (cl-case major-mode
- (racket-repl-mode
- (racket--delete-all-buffer-text leave-last-prompt-p))
- (racket-mode
- (when (get-buffer racket-repl-buffer-name)
- (with-current-buffer racket-repl-buffer-name
- (racket--delete-all-buffer-text leave-last-prompt-p))))
- (otherwise
- (user-error "Current buffer is not a Racket Mode edit or REPL buffer"))))
+ (cond ((eq major-mode 'racket-repl-mode)
+ (racket--delete-all-buffer-text leave-last-prompt-p))
+ ((racket--edit-mode-p)
+ (when (get-buffer racket-repl-buffer-name)
+ (with-current-buffer racket-repl-buffer-name
+ (racket--delete-all-buffer-text leave-last-prompt-p))))
+ (t
+ (user-error "Current buffer is not a Racket edit or REPL buffer"))))
(defun racket--delete-all-buffer-text (leave-last-prompt-p)
- (with-silent-modifications
- (widen)
- (let ((end (if leave-last-prompt-p
- (save-excursion
- (goto-char (point-max))
- (comint-previous-prompt 1)
- (comint-next-prompt 1)
- (forward-line 0) ;BOL ignoring fields
- (point))
- (point-max)))
- (inhibit-read-only t))
- (delete-region (point-min) end)
- (goto-char (point-max))
- (dolist (win (get-buffer-window-list))
- (set-window-point win (point-max))))))
+ (widen)
+ (let ((end (if leave-last-prompt-p
+ (save-excursion
+ (goto-char (point-max))
+ (racket-repl-previous-prompt)
+ (racket-repl-next-prompt)
+ (forward-line 0) ;BOL ignoring fields
+ (point))
+ (point-max)))
+ (inhibit-read-only t))
+ (delete-region (point-min) end)
+ (goto-char (point-max))
+ (dolist (win (get-buffer-window-list))
+ (set-window-point win (point-max)))))
+
+;;; Errors
+
+(defvar racket-repl-error-location-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-2] #'racket-repl-goto-error-location)
+ (define-key map (kbd "RET") #'racket-repl-goto-error-location)
+ map))
+
+(defun racket--format-error-location (loc)
+ (pcase loc
+ (`(,str ,_file ,_line ,_col ,_pos ,_span)
+ (propertize str
+ 'font-lock-face 'racket-repl-error-location
+ 'racket-error-loc loc
+ 'keymap racket-repl-error-location-map))
+ (_ (propertize "location N/A" 'font-lock-face 'italic))))
+
+(defun racket-repl-goto-error-location ()
+ (interactive)
+ (pcase (get-text-property (point) 'racket-error-loc)
+ (`(,_str ,file ,_line ,_col ,pos ,span)
+ (with-current-buffer (or (get-file-buffer file)
+ (let ((find-file-suppress-same-file-warnings t))
+ (find-file-noselect file)))
+ (display-buffer (current-buffer))
+ (goto-char pos)
+ (set-window-point (get-buffer-window (current-buffer)) pos)
+ (pulse-momentary-highlight-region pos (+ pos span))))))
+
+(defvar-local racket--errors-reset t)
+(defvar-local racket--errors-point-min nil)
+(defun racket--repl-forget-errors ()
+ "Forget existing errors in the REPL.
+Although they remain clickable they will be ignored by
+`next-error' and `previous-error'"
+ (with-racket-repl-buffer
+ (setq racket--errors-reset t)
+ (setq racket--errors-point-min (point-max))))
+(add-hook 'racket--repl-before-run-hook #'racket--repl-forget-errors)
+
+(defun racket-repl-next-error (count reset)
+ "A value for `next-error-function'."
+ (let ((prop 'racket-error-loc))
+ (cl-flet* ((get () (get-text-property (point) prop))
+ (next () (next-single-property-change (point) prop))
+ (prev () (previous-single-property-change (point) prop))
+ (go-next () (goto-char (or (next) (point-max))))
+ (go-prev () (goto-char (max (or (prev) racket--errors-point-min)
+ racket--errors-point-min))))
+ (when (or reset racket--errors-reset)
+ (goto-char racket--errors-point-min))
+ (setq racket--errors-reset nil)
+ (if (< 0 count)
+ (dotimes (_ count)
+ (when (get) (go-next))
+ (go-next)
+ (unless (get) (go-next)))
+ (dotimes (_ (- count))
+ (when (get) (go-prev))
+ (go-prev)
+ (unless (get) (go-prev))))
+ (cond ((get)
+ ;; Show in REPL buffer
+ (set-window-point (get-buffer-window (current-buffer)) (point))
+ ;; Show in edit buffer
+ (racket-repl-goto-error-location))
+ (t (user-error "No more errors"))))))
+
+;;; Nav
+
+(defun racket-repl-previous-prompt ()
+ "Move to the character after the previous prompt."
+ (interactive)
+ (cl-flet* ((prev (pos) (previous-single-property-change pos 'racket-prompt))
+ (go-prev () (goto-char (or (prev (point)) (point-min))))
+ (in-prompt () (get-text-property (point) 'racket-prompt)))
+ (go-prev)
+ (when (in-prompt)
+ (go-prev))))
+
+(defun racket-repl-next-prompt ()
+ "Move to the character after the next prompt."
+ (interactive)
+ (cl-flet* ((next (pos) (next-single-property-change pos 'racket-prompt))
+ (go-next () (goto-char (or (next (point)) (point-max))))
+ (in-prompt () (get-text-property (point) 'racket-prompt)))
+ (go-next)
+ (when (in-prompt)
+ (go-next))))
+
+(defun racket-repl-delete-output ()
+ "Delete output from REPL interaction.
+
+When point is within a prompt or input, delete the output of the
+previous interaction.
+
+When point is within output, delete that output."
+ (interactive)
+ (let ((pt (point))
+ (end-of-input (progn
+ (when (eq (get-text-property (point) 'field) 'input)
+ (goto-char (field-beginning (1+ (point)))))
+ (racket-repl-previous-prompt)
+ (if (bobp)
+ (point-min)
+ (field-end (1+ (point))))))
+ (end-of-output (progn
+ (racket-repl-next-prompt)
+ (forward-line 0)
+ (point))))
+ (goto-char pt)
+ (let ((inhibit-read-only t))
+ (delete-region end-of-input end-of-output)
+ (save-excursion
+ (goto-char end-of-input)
+ (insert (propertize "(output deleted)\n"
+ 'read-only t
+ 'font-lock-face racket-repl-message))))))
+
+;;; Input history
+
+;; TODO: Make defcustom
+(defvar racket-repl-history-size 128)
+
+(defvar-local racket--repl-input-ring nil)
+(defvar-local racket--repl-input-ring-index nil)
+
+(defun racket--repl-add-to-input-history (input)
+ "To be called from `racket-repl-submit'."
+ (unless (ring-p racket--repl-input-ring)
+ (setq racket--repl-input-ring (make-ring racket-repl-history-size)))
+ (when (or (ring-empty-p racket--repl-input-ring)
+ (not (string-equal (ring-ref racket--repl-input-ring 0) input)))
+ (ring-insert racket--repl-input-ring input))
+ (setq racket--repl-input-ring-index nil))
+
+(defun racket-repl-previous-input (arg)
+ (interactive "*p")
+ (unless (and (ring-p racket--repl-input-ring)
+ (not (ring-empty-p racket--repl-input-ring)))
+ (user-error "No history"))
+ (unless (racket--repl-prompt-mark-end)
+ (user-error "No prompt"))
+ (setq racket--repl-input-ring-index
+ (if racket--repl-input-ring-index
+ (+ racket--repl-input-ring-index arg)
+ (if (< 0 arg)
+ (1- arg) ;0 is already previous item in ring
+ arg)))
+ (delete-region (racket--repl-prompt-mark-end) (point-max))
+ (let ((input (ring-ref racket--repl-input-ring
racket--repl-input-ring-index)))
+ (insert input)))
+
+(defun racket-repl-next-input (arg)
+ (interactive "*p")
+ (racket-repl-previous-input (- arg)))
+
+(defun racket-repl-clear-input ()
+ (interactive)
+ (when-let (prompt-end (racket--repl-prompt-mark-end))
+ (delete-region prompt-end (point-max)))
+ (setq racket--repl-input-ring-index nil))
+
+(defun racket--repl-history-filename ()
+ (make-directory racket-repl-history-directory t)
+ (expand-file-name (concat "input-history-" (racket--buffer-name-slug))
+ racket-repl-history-directory))
+
+(defun racket-repl-write-history ()
+ (when (and (ring-p racket--repl-input-ring)
+ (not (ring-empty-p racket--repl-input-ring)))
+ (let* ((items (ring-elements racket--repl-input-ring))
+ (str (format "%S" items)))
+ (write-region str nil (racket--repl-history-filename) nil 'no-message))))
+
+(defun racket-repl-read-history ()
+ (let* ((file (racket--repl-history-filename))
+ (items (with-temp-buffer
+ (ignore-errors
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (read (current-buffer))))))
+ ;; Although `ring-convert-sequence-to-ring' looks handy, it
+ ;; creates a ring without letting us set the size (capacity).
+ (setq racket--repl-input-ring (make-ring racket-repl-history-size))
+ (dolist (item items)
+ (ring-insert-at-beginning racket--repl-input-ring item))))
(provide 'racket-repl)
diff --git a/racket-stepper.el b/racket-stepper.el
index 7f4d882105..04bb5afb2a 100644
--- a/racket-stepper.el
+++ b/racket-stepper.el
@@ -74,8 +74,7 @@ original form is displayed and you can start stepping.
With \\[universal-argument] also expands syntax from racket/base
-- which can result in very many expansion steps."
(interactive "P")
- (unless (eq major-mode 'racket-mode)
- (user-error "Only works in racket-mode buffer"))
+ (racket--assert-edit-mode)
(racket--save-if-changed)
(racket-stepper--start 'file (racket--buffer-file-name) into-base))
@@ -133,12 +132,11 @@ stepping.")
WHICH should be \"expr\" or \"file\".
STR should be the expression or pathname.
INTO-BASE is treated as a raw command prefix arg and converted to boolp."
- (unless (eq major-mode 'racket-mode)
- (error "Only works from racket-mode buffers"))
+ (racket--assert-edit-mode)
(setq racket--stepper-repl-session-id (racket--repl-session-id))
(unless (or racket--stepper-repl-session-id
(eq which 'file))
- (error "Only works when the racket-mode buffer has a REPL buffer, and, you
should racket-run first"))
+ (error "Only works when the edit buffer has a REPL buffer, and, you should
racket-run first"))
;; Create buffer if necessary
(let ((name (racket--stepper-buffer-name)))
(unless (get-buffer name)
diff --git a/racket-util.el b/racket-util.el
index 015667ebec..e0525d9000 100644
--- a/racket-util.el
+++ b/racket-util.el
@@ -17,9 +17,12 @@
SPEC is
(list (list KEY-OR-KEYS DEF) ...)
-KEY-OR-KEYS is either a string given to `kbd', or, for the case
-where multiple keys bind to the same command, a list of such
-strings.
+KEY-OR-KEYs is either a single key, or, as a convenience when
+multiple keys bind to the same command, a list of keys.
+
+Each key is either a string, which transformed by `kbd' before
+being given to `define-key', or another value given directly to
+`define-key'. An example of the latter is [remap command-name].
DEF is the same as DEF for `define-key'."
(let ((m (make-sparse-keymap)))
@@ -29,7 +32,11 @@ DEF is the same as DEF for `define-key'."
(list (car x))))
(def (cadr x)))
(mapc (lambda (key)
- (define-key m (kbd key) def))
+ (define-key m
+ (if (stringp key)
+ (kbd key)
+ key)
+ def))
keys)))
spec)
m))
@@ -51,8 +58,7 @@ this to use the names with shell programs or a Racket back
end."
v)))
(defun racket--save-if-changed ()
- (unless (eq major-mode 'racket-mode)
- (user-error "Current buffer is not a racket-mode buffer"))
+ (racket--assert-edit-mode)
(when (or (buffer-modified-p)
(and (buffer-file-name)
(not (file-exists-p (buffer-file-name)))))
@@ -147,6 +153,20 @@ The \"project\" is determined by trying, in order:
(cdr (project-current nil dir)))
dir)))
+(defun racket--edit-mode-p ()
+ (and (seq-some #'derived-mode-p '(racket-mode racket-hash-lang-mode)) t))
+
+(defun racket--assert-edit-mode (&optional fail-thunk)
+ (unless (racket--edit-mode-p)
+ (when fail-thunk (funcall fail-thunk))
+ (user-error "%S works only in racket-mode or racket-hash-lang-mode edit
buffers"
+ this-command)))
+
+(defun racket--assert-racket-mode ()
+ (unless (derived-mode-p 'racket-mode)
+ (user-error "%S works only in racket-mode edit buffers"
+ this-command)))
+
(provide 'racket-util)
;; racket-util.el ends here
diff --git a/racket-xp.el b/racket-xp.el
index 52dbbd80b1..779dae8203 100644
--- a/racket-xp.el
+++ b/racket-xp.el
@@ -251,9 +251,7 @@ commands directly to whatever keys you prefer.
"
:lighter racket-xp-mode-lighter
:keymap racket-xp-mode-map
- (unless (eq major-mode 'racket-mode)
- (setq racket-xp-mode nil)
- (user-error "racket-xp-mode only works with racket-mode buffers"))
+ (racket--assert-edit-mode (lambda () (setq racket-xp-mode nil)))
(setq-local text-property-default-nonsticky
(append text-property-default-nonsticky
'((racket-xp-def . t)
@@ -308,6 +306,268 @@ commands directly to whatever keys you prefer.
#'racket-xp-pre-redisplay
t))))
+;;; Change hook and idle timer
+
+(defvar-local racket--xp-annotate-idle-timer nil)
+
+(defvar-local racket--xp-edit-generation 0
+ "A counter to detect check-syntax command responses we should ignore.
+Example scenario: User edits. Timer set. Timer expires; we
+request annotations. While waiting for that response, user makes
+more edits. When the originally requested annotations arrive, we
+can see they're out of date and should be ignored. Instead just wait
+for the annotations resulting from the user's later edits.")
+
+(defvar-local racket--xp-inhibit-after-change-hook nil)
+
+(defun racket--xp-after-change-hook (_beg _end _len)
+ (unless racket--xp-inhibit-after-change-hook
+ (cl-incf racket--xp-edit-generation)
+ (when (timerp racket--xp-annotate-idle-timer)
+ (cancel-timer racket--xp-annotate-idle-timer))
+ (racket--xp-set-status 'outdated)
+ (when racket-xp-after-change-refresh-delay
+ (racket--xp-start-idle-timer (current-buffer)))))
+
+(defun racket--xp-start-idle-timer (buffer)
+ (setq racket--xp-annotate-idle-timer
+ (run-with-idle-timer racket-xp-after-change-refresh-delay
+ nil ;no repeat
+ #'racket--xp-on-idle-timer
+ buffer)))
+
+(defun racket--xp-on-idle-timer (buffer)
+ "Handle after-change-hook => idle-timer expiration.
+
+One scenario to keep in mind: The user has typed a few characters
+-- which are likely to be a syntax error -- and is in the process
+of using manual or auto completion. We don't want to annotate
+yet. At best it's a waste of work, and at worst the completion UI
+and our UI might distractingly interfere with each other. Just do
+nothing for now. If the user selects a completion candiate, that
+buffer modification will cause us to run later -- which is
+perfect. If they cancel completion, the annotation won't refresh
+and might miss a change from before they even started completion
+-- which is not great, but is better than making a mistake
+rescheduling an idle-timer with an amount <= the amount of idle
+time that has already elapsed: see #504."
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (unless (racket--xp-completing-p)
+ (racket--xp-annotate)))))
+
+(defun racket--xp-completing-p ()
+ "Is completion underway?
+This is ad hoc and forensic."
+ (or (get-buffer-window "*Completions*")
+ (and (boundp 'company-pseudo-tooltip-overlay)
+ company-pseudo-tooltip-overlay)))
+
+;;; Annotation
+
+(defun racket-xp-annotate-all-buffers ()
+ "Call `racket-xp-annotate' in all `racket-xp-mode' buffers."
+ (interactive)
+ (let ((buffers (seq-filter (lambda (buffer)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ racket-xp-mode)))
+ (buffer-list))))
+ (when (y-or-n-p
+ (format "Request re-annotation of %s racket-xp-mode buffers?"
+ (length buffers)))
+ (message "")
+ (with-temp-message "Working..."
+ (dolist (buffer buffers)
+ (with-current-buffer buffer
+ (racket-xp-annotate)))))))
+
+(defun racket-xp-annotate ()
+ "Request the buffer to be analyzed and annotated.
+
+If you have set `racket-xp-after-change-refresh-delay' to nil --
+or to a very large amount -- you can use this command to annotate
+manually."
+ (interactive)
+ (when (and racket-xp-mode
+ (or (< (buffer-size) racket-xp-buffer-size-limit)
+ (yes-or-no-p "The buffer is so large Emacs will probably
'freeze'! Are you sure you want to continue? ")))
+ (racket--xp-annotate
+ (let ((windows (get-buffer-window-list (current-buffer) nil t)))
+ (lambda ()
+ (dolist (window windows)
+ (racket-xp--force-redisplay window)))))))
+
+(defvar-local racket--xp-imenu-index nil)
+
+(defun racket--xp-annotate (&optional after-thunk)
+ (racket--xp-set-status 'running)
+ (let ((generation-of-our-request racket--xp-edit-generation))
+ (racket--cmd/async
+ nil
+ `(check-syntax ,(racket-file-name-front-to-back
+ (or (racket--buffer-file-name) (buffer-name)))
+ ,(buffer-substring-no-properties (point-min) (point-max)))
+ (lambda (response)
+ (when (= generation-of-our-request racket--xp-edit-generation)
+ (racket-show "")
+ (racket--xp-clear-errors)
+ (pcase response
+ (`(check-syntax-ok
+ (completions . ,completions)
+ (imenu . ,imenu)
+ (annotations . ,annotations))
+ (racket--xp-clear)
+ (setq racket--xp-binding-completions completions)
+ (setq racket--xp-imenu-index imenu)
+ (racket--xp-insert annotations)
+ (racket--xp-set-status 'ok)
+ (when (and annotations after-thunk)
+ (funcall after-thunk)))
+ (`(check-syntax-errors
+ (errors . ,errors)
+ (annotations . ,annotations))
+ ;; Don't do full `racket--xp-clear': The old completions and
+ ;; some old annotations may be helpful to user while editing
+ ;; to correct the error. However do clear things related to
+ ;; previous _errors_.
+ (racket--xp-clear t)
+ (racket--xp-insert errors)
+ (racket--xp-insert annotations)
+ (racket--xp-set-status 'err)
+ (when (and annotations after-thunk)
+ (funcall after-thunk)))))))))
+
+(defun racket--xp-insert (xs)
+ "Insert text properties."
+ (with-silent-modifications
+ (overlay-recenter (point-max))
+ (let ((binding-font-lock-face-p (and (memq major-mode
+
racket-xp-binding-font-lock-face-modes)
+ t)))
+ (dolist (x xs)
+ (pcase x
+ (`(error ,path ,beg ,end ,str)
+ (let ((path (racket-file-name-back-to-front path)))
+ (racket--xp-add-error path beg str)
+ (when (equal path (racket--buffer-file-name))
+ (remove-text-properties
+ beg end
+ (list 'help-echo nil
+ 'racket-xp-def nil
+ 'racket-xp-use nil))
+ (racket--add-overlay beg end racket-xp-error-face)
+ (add-text-properties
+ beg end
+ (list 'help-echo str)))))
+ (`(info ,beg ,end ,str)
+ (put-text-property beg end 'help-echo str)
+ (when (and (string-equal str "no bound occurrences")
+ (string-match-p racket-xp-highlight-unused-regexp
+ (buffer-substring beg end)))
+ (racket--add-overlay beg end racket-xp-unused-face)))
+ (`(unused-require ,beg ,end)
+ (put-text-property beg end 'help-echo "unused require")
+ (racket--add-overlay beg end racket-xp-unused-face))
+ (`(require ,beg ,end ,file)
+ (put-text-property beg end 'racket-xp-require file))
+ (`(def/uses ,def-beg ,def-end ,req ,id ,uses)
+ (let ((def-beg (copy-marker def-beg t))
+ (def-end (copy-marker def-end t))
+ (uses (mapcar (lambda (use)
+ (mapcar (lambda (pos)
+ (copy-marker pos t))
+ use))
+ uses)))
+ (put-text-property (marker-position def-beg)
+ (marker-position def-end)
+ 'racket-xp-def (list req id uses))
+ (when binding-font-lock-face-p
+ (racket--xp-add-def-face (marker-position def-beg)
+ (marker-position def-end)
+ req))
+ (dolist (use uses)
+ (pcase-let* ((`(,use-beg ,use-end) use))
+ (put-text-property (marker-position use-beg)
+ (marker-position use-end)
+ 'racket-xp-use (list def-beg def-end))
+ (when binding-font-lock-face-p
+ (racket--xp-add-use-face (marker-position use-beg)
+ (marker-position use-end)
+ req))))))
+ (`(target/tails ,target ,calls)
+ (let ((target (copy-marker target t))
+ (calls (mapcar (lambda (call)
+ (copy-marker call t))
+ calls)))
+ (put-text-property (marker-position target)
+ (1+ (marker-position target))
+ 'racket-xp-tail-target
+ calls)
+ (dolist (call calls)
+ (put-text-property (marker-position call)
+ (1+ (marker-position call))
+ 'racket-xp-tail-position
+ target))))
+ (`(jump ,beg ,end ,path ,subs ,ids)
+ (add-text-properties
+ beg end
+ (list 'racket-xp-visit
+ (list (racket-file-name-back-to-front path) subs ids))))
+ (`(doc ,beg ,end ,path ,anchor)
+ (add-text-properties
+ beg end
+ (list 'racket-xp-doc
+ (list (racket-file-name-back-to-front path) anchor)))))))))
+
+(defun racket--xp-add-binding-face (beg end face)
+ (add-text-properties beg end
+ (list 'font-lock-face face
+ 'fontified nil)))
+
+(defun racket--xp-add-def-face (beg end arrow-kind)
+ (racket--xp-add-binding-face
+ beg end
+ (cl-case arrow-kind
+ ((module-lang) racket-xp-binding-lang-face)
+ ((import) racket-xp-binding-import-face)
+ ((local) racket-xp-binding-local-face))))
+
+(defun racket--xp-add-use-face (beg end arrow-kind)
+ (racket--xp-add-binding-face
+ beg end
+ (cl-case arrow-kind
+ ((module-lang) racket-xp-binding-lang-use-face)
+ ((import) racket-xp-binding-import-use-face)
+ ((local) racket-xp-binding-local-use-face))))
+
+(defun racket--xp-clear (&optional only-errors-p)
+ (with-silent-modifications
+ (racket-show "")
+ (racket--xp-clear-errors)
+ (racket--remove-overlays-in-buffer racket-xp-error-face)
+ (remove-text-properties (point-min) (point-max)
+ (list 'help-echo nil))
+ (unless only-errors-p
+ (setq racket--xp-binding-completions nil)
+ (setq racket--xp-imenu-index nil)
+ (racket--remove-overlays-in-buffer racket-xp-def-face
+ racket-xp-use-face
+ racket-xp-unused-face
+ racket-xp-tail-position-face
+ racket-xp-tail-target-face)
+ (remove-text-properties (point-min) (point-max)
+ (list 'racket-xp-def nil
+ 'racket-xp-use nil
+ 'racket-xp-tail-position nil
+ 'racket-xp-tail-target nil
+ 'racket-xp-visit nil
+ 'racket-xp-doc nil
+ 'racket-xp-require nil
+ 'font-lock-face nil)))))
+
+;;; xref
+
(defun racket-xp-describe (&optional prefix)
"Describe the identifier at point.
@@ -547,6 +807,8 @@ command prefixes you supply.
(_
(racket--doc prefix (buffer-file-name) racket--xp-binding-completions))))
+;;; Navigation
+
(defun racket-xp--forward-use (amt)
"When point is on a use, go AMT uses forward. AMT may be negative.
@@ -612,9 +874,11 @@ If point is instead on a definition, then go to its first
use."
locs))
(point-marker (let ((m (make-marker)))
(set-marker m (point) (current-buffer)))))
- ;; Don't let our after-change hook run until all changes are
- ;; made, otherwise check-syntax will find a syntax error.
- (let ((inhibit-modification-hooks t))
+ ;; Don't let our after-change hook run while we make changes,
+ ;; otherwise check-syntax will find a syntax error. Note:
+ ;; `inhibit-modification-hooks' is too strong here; inhibit just
+ ;; our hook.
+ (let ((racket--xp-inhibit-after-change-hook t))
(dolist (marker-pair marker-pairs)
(let ((beg (marker-position (nth 0 marker-pair)))
(end (marker-position (nth 1 marker-pair))))
@@ -835,231 +1099,6 @@ evaluation errors that won't be found merely from
expansion -- or
;; they're given to grep.
(cl-call-next-method backend (substring-no-properties str))))
-;;; Change hook and idle timer
-
-(defvar-local racket--xp-annotate-idle-timer nil)
-
-(defvar-local racket--xp-edit-generation 0
- "A counter to detect check-syntax command responses we should ignore.
-Example scenario: User edits. Timer set. Timer expires; we
-request annotations. While waiting for that response, user makes
-more edits. When the originally requested annotations arrive, we
-can see they're out of date and should be ignored. Instead just wait
-for the annotations resulting from the user's later edits.")
-
-(defun racket--xp-after-change-hook (_beg _end _len)
- (cl-incf racket--xp-edit-generation)
- (when (timerp racket--xp-annotate-idle-timer)
- (cancel-timer racket--xp-annotate-idle-timer))
- (racket--xp-set-status 'outdated)
- (when racket-xp-after-change-refresh-delay
- (racket--xp-start-idle-timer (current-buffer))))
-
-(defun racket--xp-start-idle-timer (buffer)
- (setq racket--xp-annotate-idle-timer
- (run-with-idle-timer racket-xp-after-change-refresh-delay
- nil ;no repeat
- #'racket--xp-on-idle-timer
- buffer)))
-
-(defun racket--xp-on-idle-timer (buffer)
- "Handle after-change-hook => idle-timer expiration.
-
-One scenario to keep in mind: The user has typed a few characters
--- which are likely to be a syntax error -- and is in the process
-of using manual or auto completion. We don't want to annotate
-yet. At best it's a waste of work, and at worst the completion UI
-and our UI might distractingly interfere with each other. Just do
-nothing for now. If the user selects a completion candiate, that
-buffer modification will cause us to run later -- which is
-perfect. If they cancel completion, the annotation won't refresh
-and might miss a change from before they even started completion
--- which is not great, but is better than making a mistake
-rescheduling an idle-timer with an amount <= the amount of idle
-time that has already elapsed: see #504."
- (when (buffer-live-p buffer)
- (with-current-buffer buffer
- (unless (racket--xp-completing-p)
- (racket--xp-annotate)))))
-
-(defun racket--xp-completing-p ()
- "Is completion underway?
-This is ad hoc and forensic."
- (or (get-buffer-window "*Completions*")
- (and (boundp 'company-pseudo-tooltip-overlay)
- company-pseudo-tooltip-overlay)))
-
-;;; Annotation
-
-(defun racket-xp-annotate-all-buffers ()
- "Call `racket-xp-annotate' in all `racket-xp-mode' buffers."
- (interactive)
- (let ((buffers (seq-filter (lambda (buffer)
- (when (buffer-live-p buffer)
- (with-current-buffer buffer
- racket-xp-mode)))
- (buffer-list))))
- (when (y-or-n-p
- (format "Request re-annotation of %s racket-xp-mode buffers?"
- (length buffers)))
- (message "")
- (with-temp-message "Working..."
- (dolist (buffer buffers)
- (with-current-buffer buffer
- (racket-xp-annotate)))))))
-
-(defun racket-xp-annotate ()
- "Request the buffer to be analyzed and annotated.
-
-If you have set `racket-xp-after-change-refresh-delay' to nil --
-or to a very large amount -- you can use this command to annotate
-manually."
- (interactive)
- (when (and racket-xp-mode
- (or (< (buffer-size) racket-xp-buffer-size-limit)
- (yes-or-no-p "The buffer is so large Emacs will probably
'freeze'! Are you sure you want to continue? ")))
- (racket--xp-annotate
- (let ((windows (get-buffer-window-list (current-buffer) nil t)))
- (lambda ()
- (dolist (window windows)
- (racket-xp--force-redisplay window)))))))
-
-(defvar-local racket--xp-imenu-index nil)
-
-(defun racket--xp-annotate (&optional after-thunk)
- (racket--xp-set-status 'running)
- (let ((generation-of-our-request racket--xp-edit-generation))
- (racket--cmd/async
- nil
- `(check-syntax ,(racket-file-name-front-to-back
- (or (racket--buffer-file-name) (buffer-name)))
- ,(buffer-substring-no-properties (point-min) (point-max)))
- (lambda (response)
- (when (= generation-of-our-request racket--xp-edit-generation)
- (racket-show "")
- (racket--xp-clear-errors)
- (pcase response
- (`(check-syntax-ok
- (completions . ,completions)
- (imenu . ,imenu)
- (annotations . ,annotations))
- (racket--xp-clear)
- (setq racket--xp-binding-completions completions)
- (setq racket--xp-imenu-index imenu)
- (racket--xp-insert annotations)
- (racket--xp-set-status 'ok)
- (when (and annotations after-thunk)
- (funcall after-thunk)))
- (`(check-syntax-errors
- (errors . ,errors)
- (annotations . ,annotations))
- ;; Don't do full `racket--xp-clear': The old completions and
- ;; some old annotations may be helpful to user while editing
- ;; to correct the error. However do clear things related to
- ;; previous _errors_.
- (racket--xp-clear t)
- (racket--xp-insert errors)
- (racket--xp-insert annotations)
- (racket--xp-set-status 'err)
- (when (and annotations after-thunk)
- (funcall after-thunk)))))))))
-
-(defun racket--xp-insert (xs)
- "Insert text properties."
- (with-silent-modifications
- (overlay-recenter (point-max))
- (dolist (x xs)
- (pcase x
- (`(error ,path ,beg ,end ,str)
- (let ((path (racket-file-name-back-to-front path)))
- (racket--xp-add-error path beg str)
- (when (equal path (racket--buffer-file-name))
- (remove-text-properties
- beg end
- (list 'help-echo nil
- 'racket-xp-def nil
- 'racket-xp-use nil))
- (racket--add-overlay beg end racket-xp-error-face)
- (add-text-properties
- beg end
- (list 'help-echo str)))))
- (`(info ,beg ,end ,str)
- (put-text-property beg end 'help-echo str)
- (when (and (string-equal str "no bound occurrences")
- (string-match-p racket-xp-highlight-unused-regexp
- (buffer-substring beg end)))
- (racket--add-overlay beg end racket-xp-unused-face)))
- (`(unused-require ,beg ,end)
- (put-text-property beg end 'help-echo "unused require")
- (racket--add-overlay beg end racket-xp-unused-face))
- (`(require ,beg ,end ,file)
- (put-text-property beg end 'racket-xp-require file))
- (`(def/uses ,def-beg ,def-end ,req ,id ,uses)
- (let ((def-beg (copy-marker def-beg t))
- (def-end (copy-marker def-end t))
- (uses (mapcar (lambda (use)
- (mapcar (lambda (pos)
- (copy-marker pos t))
- use))
- uses)))
- (put-text-property (marker-position def-beg)
- (marker-position def-end)
- 'racket-xp-def (list req id uses))
- (dolist (use uses)
- (pcase-let* ((`(,use-beg ,use-end) use))
- (put-text-property (marker-position use-beg)
- (marker-position use-end)
- 'racket-xp-use (list def-beg def-end))))))
-
- (`(target/tails ,target ,calls)
- (let ((target (copy-marker target t))
- (calls (mapcar (lambda (call)
- (copy-marker call t))
- calls)))
- (put-text-property (marker-position target)
- (1+ (marker-position target))
- 'racket-xp-tail-target
- calls)
- (dolist (call calls)
- (put-text-property (marker-position call)
- (1+ (marker-position call))
- 'racket-xp-tail-position
- target))))
- (`(jump ,beg ,end ,path ,subs ,ids)
- (add-text-properties
- beg end
- (list 'racket-xp-visit
- (list (racket-file-name-back-to-front path) subs ids))))
- (`(doc ,beg ,end ,path ,anchor)
- (add-text-properties
- beg end
- (list 'racket-xp-doc
- (list (racket-file-name-back-to-front path) anchor))))))))
-
-(defun racket--xp-clear (&optional only-errors-p)
- (with-silent-modifications
- (racket-show "")
- (racket--xp-clear-errors)
- (racket--remove-overlays-in-buffer racket-xp-error-face)
- (remove-text-properties (point-min) (point-max)
- (list 'help-echo nil))
- (unless only-errors-p
- (setq racket--xp-binding-completions nil)
- (setq racket--xp-imenu-index nil)
- (racket--remove-overlays-in-buffer racket-xp-def-face
- racket-xp-use-face
- racket-xp-unused-face
- racket-xp-tail-position-face
- racket-xp-tail-target-face)
- (remove-text-properties (point-min) (point-max)
- (list 'racket-xp-def nil
- 'racket-xp-use nil
- 'racket-xp-tail-position nil
- 'racket-xp-tail-target nil
- 'racket-xp-visit nil
- 'racket-xp-doc nil
- 'racket-xp-require nil)))))
-
;;; Mode line status
(defvar-local racket--xp-mode-status nil)
diff --git a/racket/command-server.rkt b/racket/command-server.rkt
index 5463b22006..dce5dc0eb8 100644
--- a/racket/command-server.rkt
+++ b/racket/command-server.rkt
@@ -10,8 +10,10 @@
"debug.rkt"
"elisp.rkt"
(only-in "instrument.rkt" get-uncovered get-profile)
+ "hash-lang-bridge.rkt"
"logger.rkt"
"repl.rkt"
+ "repl-output.rkt"
"repl-session.rkt"
(only-in "scribble.rkt"
doc-index-names
@@ -79,17 +81,19 @@
`(ok ,(call-with-session-context sid command sexp)))))))
(procedure-rename thk (string->symbol label)))
- (define (write-responses-forever)
+ (define (write-responses-and-notifications)
(parameterize ([current-output-port out])
(let loop ()
(elisp-writeln (sync response-channel
+ repl-output-channel
logger-notify-channel
- debug-notify-channel))
+ debug-notify-channel
+ hash-lang-notify-channel))
(flush-output)
(loop))))
;; With all the pieces defined, let's go:
- (thread write-responses-forever)
+ (thread write-responses-and-notifications)
(parameterize ([current-output-port out])
(elisp-writeln `(ready)))
(let read-a-command ()
@@ -131,7 +135,6 @@
;; Commands that do NOT need a REPL session
[`(no-op) #t]
[`(logger ,v) (channel-put logger-command-channel v)]
- [`(repl-tcp-port-number) repl-tcp-port-number]
[`(check-syntax ,path-str ,code) (check-syntax path-str code)]
[`(macro-stepper ,str ,into-base?) (macro-stepper str into-base?)]
[`(macro-stepper/next ,what) (macro-stepper/next what)]
@@ -142,6 +145,7 @@
[`(requires/find ,str) (libs-exporting-documented str)]
[`(doc-index-names) (doc-index-names)]
[`(doc-index-lookup ,str) (doc-index-lookup str)]
+ [`(hash-lang . ,more) (apply hash-lang more)]
;; Commands that MIGHT need a REPL session for context (e.g. its
;; namespace), if their first "how" argument is 'namespace.
@@ -150,6 +154,7 @@
[`(describe ,how ,str) (describe how str)]
[`(doc ,how ,str) (doc how str)]
[`(type ,how ,v) (type how v)]
+ [`(repl-start, sid) (repl-start sid)]
;; Commands that DEFINITELY DO need a REPL session for context,
;; e.g. its namespace. Should they pass a session-id explicitly,
@@ -162,19 +167,14 @@
[`(get-profile) (get-profile)]
[`(get-uncovered) (get-uncovered file)]
[`(eval ,v) (eval-command v)]
- [`(repl-submit? ,str ,eos?) (repl-submit? str eos?)]
[`(debug-resume ,v) (debug-resume v)]
[`(debug-disable) (debug-disable)]
- [`(break ,kind) (repl-break kind)]
- [`(repl-zero-column) (repl-zero-column)]))
+ [`(repl-input ,str) (repl-input str)]
+ [`(repl-submit ,str) (repl-submit str)]
+ [`(repl-break) (repl-break)]
+ [`(repl-exit) (repl-exit)]))
-;;; A few commands defined here
-
-(define/contract (repl-submit? text eos)
- (-> string? elisp-bool/c (or/c 'default #t #f))
- (if (current-session-submit-pred)
- ((current-session-submit-pred) (open-input-string text) (as-racket-bool
eos))
- 'default))
+;;; Some trivial commands defined here
(define (syms)
(sort (map symbol->string (namespace-mapped-symbols))
diff --git a/racket/debug.rkt b/racket/debug.rkt
index dca7456212..b6f407155b 100644
--- a/racket/debug.rkt
+++ b/racket/debug.rkt
@@ -13,7 +13,8 @@
syntax/modread
"debug-annotator.rkt"
"elisp.rkt"
- "interactions.rkt"
+ "interaction.rkt"
+ "repl-output.rkt"
"repl-session.rkt"
"util.rkt")
@@ -47,7 +48,7 @@
(define/contract (annotate stx #:source [source (syntax-source stx)])
(->* (syntax?) (#:source path?) syntax?)
- (display-commented (format "Debug annotate ~v" source))
+ (repl-output-message (format "Debug annotate ~v" source))
(define-values (annotated breakables)
(annotate-for-single-stepping stx break? break-before break-after))
(hash-update! breakable-positions
@@ -126,7 +127,7 @@
(if (or (equal? condition #t) ;short-cut
(with-handlers ([values
(λ (e)
- (display-commented
+ (repl-output-message
(format "~a\nin debugger condition
expression:\n ~v"
(exn-message e)
condition))
@@ -144,12 +145,12 @@
(when (memq 'print actions)
(unless (null? (mark-bindings top-mark))
- (display-commented "Debugger watchpoint; locals:")
+ (repl-output-message "Debugger watchpoint; locals:")
(for* ([binding (in-list (reverse (mark-bindings top-mark)))]
[stx (in-value (first binding))]
[get/set! (in-value (second binding))]
#:when (and (syntax-original? stx) (syntax-source stx)))
- (display-commented (format " ~a = ~a" stx (~v (get/set!)))))))
+ (repl-output-message (format " ~a = ~a" stx (~v (get/set!)))))))
(when (memq 'log actions)
(log-racket-mode-debugger-info
@@ -230,8 +231,7 @@
(match new-vals-pair
[(cons #t new-vals-str) (read-str/default new-vals-str
vals)]
[(cons '() _) vals]) ])
- (kill-thread repl-thread)
- (newline))]
+ (kill-thread repl-thread))]
[_ (wait)]))]
;; Otherwise, if we didn't break, we simply need to (a) calculate
;; next-break and (b) tell the annotator to use the original
@@ -303,11 +303,14 @@
(parameterize ([current-prompt-read (make-prompt-read src pos top-mark)])
(read-eval-print-loop)))
-(define ((make-prompt-read src pos top-mark))
- (define-values (_base name _dir) (split-path src))
- (define stx (get-interaction (format "[~a:~a]" name pos)))
- (call-with-session-context (current-session-id)
- with-locals stx (mark-bindings top-mark)))
+(define (make-prompt-read src pos top-mark)
+ (define (racket-mode-debug-prompt-read)
+ (define-values (_base name _dir) (split-path src))
+ (define prompt (format "[~a:~a]" name pos))
+ (define stx (get-interaction prompt))
+ (call-with-session-context (current-session-id)
+ with-locals stx (mark-bindings top-mark)))
+ racket-mode-debug-prompt-read)
(define (with-locals stx bindings)
;; Before or during module->namespace -- i.e. during a racket-run --
@@ -421,7 +424,7 @@
[else (orig-eval top-stx)])]))
(define (load-module/annotate file m)
- (display-commented (format "~v" `(load-module/annotate ,file ,m)))
+ (repl-output-message (format "~v" `(load-module/annotate ,file ,m)))
(call-with-input-file* file
(λ (in)
(port-count-lines! in)
diff --git a/racket/elisp.rkt b/racket/elisp.rkt
index 5b836210d1..ab100000a1 100644
--- a/racket/elisp.rkt
+++ b/racket/elisp.rkt
@@ -76,6 +76,7 @@
[(or (? number? v)
(? symbol? v)
(? string? v)) (write v)]
+ [(? bytes? bstr) (write (bytes->string/utf-8 bstr))] ; ???
[v (eprintf "elisp-write can't write Racket value ~v\n" v)
(void)]))
diff --git a/racket/error.rkt b/racket/error.rkt
index ed17dfe92c..322ce91345 100644
--- a/racket/error.rkt
+++ b/racket/error.rkt
@@ -1,270 +1,102 @@
-;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; Copyright (c) 2013-2023 by Greg Hendershott.
;; SPDX-License-Identifier: GPL-3.0-or-later
-#lang at-exp racket/base
+#lang racket/base
-(require (only-in pkg/db
- get-catalogs)
- (only-in pkg/lib
- pkg-catalog-suggestions-for-module
- pkg-directory)
- racket/format
+(require racket/format
racket/match
- racket/string
- setup/dirs
"instrument.rkt"
- "stack-checkpoint.rkt"
- "util.rkt")
+ "repl-output.rkt"
+ "stack-checkpoint.rkt")
-(provide racket-mode-error-display-handler
- prevent-path-elision-by-srcloc->string)
+(provide racket-mode-error-display-handler)
-(module+ test
- (require rackunit))
+(define default-error-display-handler (error-display-handler))
+;; On the one hand, the docs say: "An error display handler can print
+;; errors in different ways, but it should always print to the current
+;; error port." After all, a user program might use
+;; error-display-handler, as in #672.
+;;
+;; On the other hand, we really want to give our front end REPL
+;; /structured/ error data via our special channel, not text.
+;;
+;; I think the solution is to check whether current-error-port is the
+;; special one we use for structured REPL output, a.k.a. the original
+;; value for the user program.
+
+;; - If so it's fine to bend the rules and use our special output
+;; channel to the front end. Probably we're the one using the
+;; handler. Even if the user program is, the meaning is "use it
+;; for-effect to output to the original error port", which in this
+;; case means ultimately to the Racket Mode front end REPL. It's OK
+;; and in fact desirable to get the same structured error handling.
+;;
+;; - Otherwise, we're running while the user program has parameterized
+;; current-error-port, perhaps to an output-string to use for-value,
+;; or to some other port to use for-effect. In that case we defer
+;; /completely/ to the default error-display-handler. Not only does
+;; that output to current-error-port, the overall format will be the
+;; same as when the user program is run with command-line racket.
+;; (Of course some context items may differ on the "outside" edge,
+;; showing wx/queue.rkt, racket-mode's repl.rkt, etc. But the
+;; "inner" items and the overall format will be the same.)
(define (racket-mode-error-display-handler msg v)
- (parameterize ([current-output-port (current-error-port)])
- (cond [(with-handlers ([values (λ _ #f)])
- ((dynamic-require 'rackunit 'exn:test:check?) v))
- (displayln msg)]
- [(exn? v)
- (define (show msg)
- (display-commented
- (complete-paths
- (undo-path->relative-string/library msg))))
- (show msg)
- (unless (member (exn-message v) (list "" msg))
- (show (exn-message v)))
- (display-srclocs v)
- (unless (or (exn:fail:syntax? v)
- (and (exn:fail:read? v) (not (exn:fail:read:eof? v)))
- (exn:fail:user? v))
- (display-context v))
- (maybe-suggest-packages v)]
+ (cond
+ [(repl-error-port? (current-error-port))
+ (cond
+ [(exn? v)
+ (let ([msg (if (member (exn-message v) (list msg ""))
+ msg
+ (string-append msg "\n" (exn-message v)))])
+ (repl-output-error (list msg (srclocs v) (context v))))]
+ [else
+ (displayln msg (current-error-port))
+ (flush-output (current-error-port))])]
+ [else
+ (default-error-display-handler msg v)]))
+
+(define (srclocs e)
+ (cond [(exn:srclocs? e)
+ (for*/list ([sl (in-list ((exn:srclocs-accessor e) e))]
+ [elv (in-value (srcloc->elisp-value sl))]
+ #:when elv)
+ elv)]
+ [else null]))
+
+(define (context e)
+ (define-values (kind pairs)
+ (cond [(instrumenting-enabled)
+ (values 'errortrace
+ (get-error-trace e))]
[else
- (display-commented msg)])))
-
-;;; srclocs
-
-(define (display-srclocs exn)
- (when (exn:srclocs? exn)
- ;; Display srclocs that aren't already present in exn-message.
- ;;
- ;; Often the first srcloc is already in exn-message.
- ;;
- ;; Sometimes (e.g. Typed Racket) ALL the srclocs are in
- ;; exn-message.
- ;;
- ;; On Racket BC, if a path is very long, it might be truncated and
- ;; start with "..." in exn-message. As a result, we will display
- ;; the full path from the srcloc here, which is helpful; see #604.
- (define strs
- (for*/list ([srcloc (in-list ((exn:srclocs-accessor exn) exn))]
- [str (in-value (source-location->string srcloc))]
- #:when (not (regexp-match? (regexp-quote str)
- (exn-message exn))))
- (string-append " " str)))
- (unless (null? strs)
- (display-commented " Source locations:")
- (for-each display-commented strs))))
-
-(module+ test
- (let ([o (open-output-string)])
- (parameterize ([current-error-port o])
- (display-srclocs (make-exn:fail:read "..."
- (current-continuation-marks)
- '())))
- (check-equal? (get-output-string o) "")))
-
-;; We don't use source-location->string from syntax/srcloc, because we
-;; don't want the setup/path-to-relative behavior that elides complete
-;; pathnames with prefixes like "<pkgs>/" etc. For strings we create
-;; ourselves, we use our own such function, defined here.
-(define (source-location->string x)
+ (values 'plain
+ (for/list ([_ (error-print-context-length)]
+ [v (in-list
+ (continuation-mark-set->trimmed-context
+ (exn-continuation-marks e)))])
+ v))]))
+ (cons kind
+ (for/list ([v (in-list pairs)])
+ (match-define (cons label src) v)
+ (cons (and label (~a label))
+ (and src (srcloc->elisp-value src))))))
+
+(define (srcloc->elisp-value loc)
(define src
;; Although I want to find/fix this properly upstream -- is
;; something a path-string? when it should be a path? -- for now
;; just catch here the case where the source is a string like
;; "\"/path/to/file.rkt\"" i.e. the string value has quotes.
- (match (srcloc-source x)
+ (match (srcloc-source loc)
[(pregexp "^\"(.+)\"$" (list _ unquoted)) unquoted]
+ [(? path? v) (path->string v)]
[v v]))
- (define line (or (srcloc-line x) 1))
- (define col (or (srcloc-column x) 0))
- (format "~a:~a:~a" src line col))
-
-;;; context
-
-(define (display-context exn)
- (cond [(instrumenting-enabled)
- (define p (open-output-string))
- (print-error-trace p exn)
- (match (get-output-string p)
- ["" (void)]
- [s (display-commented (~a "Context (errortrace):" s))])]
- [else
- (match (context->string
- (continuation-mark-set->trimmed-context
- (exn-continuation-marks exn)))
- ["" (void)]
- [s (display-commented
- (~a "Context (plain; to see better errortrace context, re-run
with C-u prefix):\n"
- s))])]))
-
-(define (context->string xs)
- (string-join (for/list ([x xs]
- [_ (error-print-context-length)])
- (context-item->string x))
- "\n"))
-
-(define (context-item->string ci)
- (match-define (cons id srcloc) ci)
- (~a (if (or srcloc id) " " "")
- (if srcloc (source-location->string srcloc) "")
- (if (and srcloc id) " " "")
- (if id (format "~a" id) "")))
-
-;;; Complete pathnames for Emacs
-
-;; The background here is that want source locations in error messages
-;; to use complete pathnames ("complete" as in complete-path? a.k.a.
-;; "absolute" plus drive letter on Windows). That way, Emacs features
-;; like compilation-mode's next-error command will work nicely.
-;;
-;; - When we create strings from srclocs, ourselves: We create them
-;; that way. See source-location->string defined/used in this file.
-;;
-;; - When other things create strings from scrlocs: We try to prevent
-;; them from eliding in the first place. And since we can't always
-;; prevent, we try to undo any elision baked into the error message
-;; by the time we get it. As a sanity check, we don't transform
-;; things into complete pathnames unless the result actually exists.
-
-;; srcloc->string from racket/base uses current-directory-for-user to
-;; elide paths. Setting that to 'pref-dir -- where it is very unlikely
-;; a user's source file will be -- should prevent it from eliding
-;; anything.
-(define (prevent-path-elision-by-srcloc->string)
- (current-directory-for-user (find-system-path 'pref-dir)))
-
-;; The source-location->string function provided by syntax/srcloc uses
-;; path->relative-string/library to elide paths with prefixes like
-;; <pkgs>/ or <collects>/. We avoid using that function in this
-;; module, for example in display-srclocs and in context-item->string
-;; above. However things like racket/contract use syntax/srcloc and
-;; those prefixes might be baked into exn-message. Here we try to undo
-;; this for things that look like such source locations.
-(define (undo-path->relative-string/library s)
- (regexp-replace*
- #px"(<(.+?)>/(.+?)):(\\d+[:.]\\d+)"
- s
- (λ (_ prefix+rel-path prefix rel-path line+col)
- (define (f dir [rel rel-path])
- (existing (simplify-path (build-path dir rel))))
- (~a (or (and (path-string? rel-path)
- (match prefix
- ["collects" (f (find-collects-dir))]
- ["user" (f (find-user-collects-dir))]
- ["doc" (f (find-doc-dir))]
- ["user-doc" (f (find-user-doc-dir))]
- ["pkgs" (match rel-path
- [(pregexp "^(.+?)/(.+?)$" (list _ pkg-name
more))
- (f (pkg-directory pkg-name) more)]
- [_ #f])]
- [_ #f]))
- prefix+rel-path) ;keep as-is
- ":" line+col))))
-
-(module+ test
- (check-equal? (undo-path->relative-string/library
"<collects>/racket/file.rkt:1:0:")
- (~a (build-path (find-collects-dir) "racket" "file.rkt")
":1:0:"))
- (check-equal? (undo-path->relative-string/library "<doc>/2d/index.html:1:0:")
- (~a (build-path (find-doc-dir) "2d" "index.html") ":1:0:"))
- ;; Note: No test for <user-doc> because unlikely to work on Travis CI
- (let ([non-existing "<collects>/racket/does-not-exist.rkt:1:0 blah blah
blah"])
- (check-equal? (undo-path->relative-string/library non-existing)
- non-existing
- "does not change to non-existing pathname")))
-
-(module+ test
- (let ()
- (local-require racket/path
- setup/path-to-relative)
- (define-polyfill (alternate-racket-clcl/clcp path box)
- #:module drracket/find-module-path-completions
- (values null null null))
- (define-values (_links _paths pkg-dirs)
- (alternate-racket-clcl/clcp (find-system-path 'exec-file) (box #f)))
- (printf "Checking .rkt files in ~v packages...\n" (length pkg-dirs))
- (define c (make-hash))
- (for ([item (in-list pkg-dirs)])
- (match item
- [(list (? string?) (? path? dir))
- (for ([p (in-directory dir)]
- #:when (equal? #".rkt" (path-get-extension p)))
- (define complete (~a p
":1.0"))
- (define relative (~a (path->relative-string/library p #:cache c)
":1.0"))
- (define undone (undo-path->relative-string/library relative))
- (check-equal? undone complete))]
- [_ (void)]))))
-
-;; If this looks like a source location where the pathname is
-;; relative, prepend current-directory if that results in an actually
-;; existing file.
-(define (complete-paths s)
- (regexp-replace*
- #px"([^:]+):(\\d+[:.]\\d+)"
- s
- (λ (_ orig-path line+col)
- (~a (or (and (relative-path? orig-path)
- (existing (build-path (current-directory) orig-path)))
- orig-path)
- ":" line+col))))
-
-(define (existing p)
- (and (path? p) (file-exists? p) p))
-
-(module+ test
- (let ()
- (local-require racket/file
- racket/path)
- (define temp-dir (find-system-path 'temp-dir))
- (define example (make-temporary-file "racket-mode-test-~a" #f temp-dir))
- (define name (file-name-from-path example))
- (parameterize ([current-directory temp-dir])
- (let ([suffix ":3:0: f: unbound identifier\n in: f"])
- (check-equal? (complete-paths (~a name suffix))
- (~a (build-path temp-dir name) suffix)
- "relative path: curdir prepended when that is an
existing file"))
- (let ([msg (~a example ":3:0: f: unbound identifier\n in: f")])
- (check-equal? (complete-paths msg)
- msg
- "already complete path: no change")))
- (delete-file example)))
-
-;;; packages
-
-(define (maybe-suggest-packages exn)
- (when (exn:missing-module? exn)
- (match (get-catalogs)
- [(list)
- (display-commented
- @~a{-----
- Can't suggest packages to install, because pkg/db get-catalogs is
'().
- To configure:
- 1. Start DrRacket.
- 2. Choose "File | Package Manager".
- 3. Click "Available from Catalog".
- 4. When prompted, click "Update".
- -----})]
- [_
- (define mod ((exn:missing-module-accessor exn) exn))
- (match (pkg-catalog-suggestions-for-module mod)
- [(list) void]
- [(list p)
- (display-commented
- @~a{Try "raco pkg install @|p|" ?})]
- [(? list? ps)
- (display-commented
- @~a{Try "raco pkg install" one of @(string-join ps ", ") ?})]
- [_ void])])))
+ (define str (or (srcloc->string loc)
+ (format "~a:~a:~a" src (srcloc-line loc) (srcloc-column
loc))))
+ (and (path-string? src)
+ (srcloc-line loc)
+ (srcloc-column loc)
+ (srcloc-position loc)
+ (srcloc-span loc)
+ (list str src (srcloc-line loc) (srcloc-column loc) (srcloc-position
loc) (srcloc-span loc))))
diff --git a/racket/hash-lang-bridge.rkt b/racket/hash-lang-bridge.rkt
new file mode 100644
index 0000000000..68b0c8da83
--- /dev/null
+++ b/racket/hash-lang-bridge.rkt
@@ -0,0 +1,191 @@
+;; Copyright (c) 2020-2023 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+#lang racket/base
+
+(require racket/async-channel
+ racket/class
+ racket/match
+ racket/runtime-path
+ "elisp.rkt"
+ "lang-info.rkt"
+ "util.rkt")
+
+(provide hash-lang
+ hash-lang-notify-channel)
+
+;; Bridge for Emacs front end to use hash-lang%
+;;
+;; - Reference hash-lang% objects by a serializable ID supplied by the
+;; front end.
+;;
+;; - Adjust Emacs 1-based positions to/from hash-lang% 0-based.
+;;
+;; - Handle notifications about changed languages and tokens, by
+;; putting values to an async channel that is handled in
+;; command-server.rkt, and then and up in Emacs, similar to
+;; notifications used for logging and debugging.
+
+(define-runtime-path hash-lang.rkt "hash-lang.rkt")
+
+(define hash-lang-class-or-error-message
+ (with-handlers ([exn:fail? exn-message])
+ (dynamic-require hash-lang.rkt 'hash-lang%)))
+
+(define our-hash-lang%
+ (when (class? hash-lang-class-or-error-message)
+ (class hash-lang-class-or-error-message
+ (super-new)
+ (init-field id)
+ (define/override (on-changed-lang-info _gen li)
+ (async-channel-put
+ hash-lang-notify-channel
+ (list
+ 'hash-lang id
+ 'lang
+ 'module-language (lang-info-module-language li)
+ 'racket-grouping (lang-info-grouping-position-is-racket? li)
+ 'range-indenter (and (lang-info-range-indenter li) #t)
+ 'submit-predicate (and (lang-info-submit-predicate li) #t)
+ ;; String-ize paren-matches and quotes-matches data to avoid
+ ;; discrepancies with Emacs Lisp allowed symbols and char
+ ;; reader syntax.
+ 'paren-matches (for/list ([o/c (in-list
(lang-info-paren-matches li))])
+ (match-define (list o c) o/c)
+ (cons (symbol->string o) (symbol->string c)))
+ 'quote-matches (for/list ([c (in-list (lang-info-quote-matches
li))])
+ (make-string 1 c))
+ 'comment-delimiters (lang-info-comment-delimiters li))))
+ (define/override (on-changed-tokens gen beg end)
+ (when (< beg end)
+ (async-channel-put hash-lang-notify-channel
+ (list 'hash-lang id
+ 'update
+ gen (add1 beg) (add1 end))))))))
+
+(define (hash-lang . args)
+ (cond
+ [(class? hash-lang-class-or-error-message) (apply hash-lang* args)]
+ [(eq? 'create (car args)) #f]
+ [else (error 'hash-lang hash-lang-class-or-error-message)]))
+
+(define (hash-lang* . args)
+ (match args
+ [`(create ,id ,ols ,str) (create id ols str)]
+ [`(delete ,id) (delete id)]
+ [`(update ,id ,gen ,pos ,old-len ,str) (update id gen pos old-len
str)]
+ [`(indent-amount ,id ,gen ,pos) (indent-amount id gen pos)]
+ [`(indent-region-amounts ,id ,gen ,from ,upto) (indent-region-amounts id
gen from upto)]
+ [`(classify ,id ,gen ,pos) (classify id gen pos)]
+ [`(grouping ,id ,gen ,pos ,dir ,limit ,count) (grouping id gen pos dir
limit count)]
+ [`(get-tokens ,id ,gen ,from ,upto) (get-tokens id gen from
upto)]
+ [`(submit-predicate ,id ,str ,eos?) (submit-predicate id str
eos?)]))
+
+(define hash-lang-notify-channel (make-async-channel))
+
+(define ht (make-hash)) ;id => hash-lang%
+(define (get-object id)
+ (hash-ref ht id
+ (λ () (error 'hash-lang-bridge
+ "No hash-lang exists with ID ~v" id))))
+
+(define (create id ols str) ;any/c (or/c #f string?) string? -> void
+ (define obj (new our-hash-lang%
+ [id id]
+ [other-lang-source (and ols (not (null? ols)) ols)]))
+ (hash-set! ht id obj)
+ (send obj update! 1 0 0 str)
+ id)
+
+(define (delete id)
+ (hash-remove! ht id))
+
+(define (update id gen pos old-len str)
+ (send (get-object id) update! gen (sub1 pos) old-len str))
+
+(define (indent-amount id gen pos)
+ (with-time/log "hash-lang indent-amount"
+ (send (get-object id) indent-line-amount gen (sub1 pos))))
+
+(define (indent-region-amounts id gen from upto)
+ (with-time/log "hash-lang indent-region-amounts"
+ (match (send (get-object id) indent-range-amounts gen (sub1 from) (sub1
upto))
+ [#f 'false] ;avoid Elisp nil/`() punning problem
+ [v v])))
+
+(define (classify id gen pos)
+ (match-define (list beg end attribs) (send (get-object id) classify gen
(sub1 pos)))
+ (list (add1 beg) (add1 end) attribs))
+
+(define (grouping id gen pos dir limit count)
+ (match (send (get-object id) grouping gen (sub1 pos) dir limit count)
+ [(? number? n) (add1 n)]
+ [v v]))
+
+(define (get-tokens id gen from upto)
+ (for/list ([tok (in-list (send (get-object id) get-tokens gen (sub1 from)
(sub1 upto)))])
+ (match-define (list (app add1 beg) (app add1 end) (app attribs->types
types)) tok)
+ (list beg end types)))
+
+(define (attribs->types attribs)
+ (match attribs
+ [(? symbol? s) (list s)]
+ [(? hash? ht) (cons (hash-ref ht 'type 'unknown)
+ (if (hash-ref ht 'comment? #f)
+ '(sexp-comment-body)
+ null))]))
+
+(define (submit-predicate id str -eos?)
+ (define in (open-input-string str))
+ (define eos (as-racket-bool -eos?))
+ (send (get-object id) submit-predicate in eos))
+
+(module+ example-0
+ (define id 0)
+ (define str "#lang racket\n42 (print \"hello\") @print{Hello} 'foo #:bar")
+ (hash-lang 'create id str)
+ (hash-lang 'update id 2 14 2 "9999")
+ (hash-lang 'classify id 2 14)
+ (hash-lang 'update id 3 14 4 "")
+ (hash-lang 'classify id 3 14)
+ (hash-lang 'classify id 3 15)
+ (hash-lang 'grouping id 3 15 'forward 0 1))
+
+(module+ example-1
+ (define id 0)
+ (define str "#lang at-exp racket\n42 (print \"hello\") @print{Hello (there)}
'foo #:bar")
+ (hash-lang 'create id str)
+ (hash-lang 'classify id 1 (sub1 (string-length str))))
+
+(module+ example-1.5
+ (define id 0)
+ (define str "#lang scribble/manual\n(print \"hello\")\n@print[#:kw 12]{Hello
(there) #:not-a-keyword}\n")
+ (hash-lang 'create id str))
+
+(module+ example-2
+ (define id 0)
+ (define str "#lang scribble/text\nHello @(print \"hello\") @print{Hello
(there)} #:not-a-keyword")
+ (hash-lang 'create id str)
+ (hash-lang 'classify id (sub1 (string-length str))))
+
+(module+ example-3
+ (define id 0)
+ (define str "#lang racket\n(λ () #t)")
+ (hash-lang 'create id str)
+ (hash-lang 'classify id 1 14)
+ (hash-lang 'classify id 1 (sub1 (string-length str))))
+
+(module+ example-4
+ (define id 0)
+ (define str "#lang racket\n#rx\"1234\"\n#(1 2 3)\n#'(1 2 3)")
+ (hash-lang 'create id str))
+
+(module+ example-5
+ (define id 0)
+ (define str "#lang racket\n123\n(print 123)\n")
+ ;; 1234567890123 4567 890123456789 0
+ ;; 1 2 3
+ (hash-lang 'create id str)
+ (indent-amount id 1 18)
+ (update id 2 28 0 "\n")
+ (indent-amount id 2 29))
diff --git a/racket/hash-lang.rkt b/racket/hash-lang.rkt
new file mode 100644
index 0000000000..2515b3f496
--- /dev/null
+++ b/racket/hash-lang.rkt
@@ -0,0 +1,864 @@
+;; Copyright (c) 2020-2023 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+#lang racket/base
+
+(require racket/async-channel
+ racket/class
+ racket/contract/base
+ racket/contract/option
+ racket/format
+ racket/match
+ syntax-color/token-tree
+ syntax-color/paren-tree
+ (only-in syntax-color/lexer-contract dont-stop)
+ (only-in syntax-color/color-textoid color-textoid<%>)
+ (only-in syntax-color/module-lexer module-lexer*)
+ (only-in syntax-color/racket-lexer racket-lexer)
+ (only-in syntax-color/racket-indentation racket-amount-to-indent)
+ (only-in syntax-color/racket-navigation racket-grouping-position)
+ syntax/parse/define
+ "lang-info.rkt"
+ (prefix-in lines: "text-lines.rkt")
+ "util.rkt")
+
+(provide hash-lang%
+ generation/c
+ position/c
+ min-position
+ (struct-out lang-info))
+
+;; Overview
+;;
+;; An instance of a hash-lang% object can be used to represent program
+;; source text and obtain information based on the #lang.
+;;
+;; The hash-lang% `update!` method may be called safely from any
+;; thread to change the program source text (e.g. as the result of a
+;; human editing the text). The `update!` method returns immediately;
+;; the actual updating work is handled by a dedicated thread.
+;; Furthermore the updater minimizes the work done for a change. As a
+;; result it is fine to call `update!` frequently for edits that
+;; insert or delete a single character, as well as for bigger changes.
+;;
+;; Each update! must specify a "generation", which is a strictly
+;; successive increasing exact integer. A new object is generation 0;
+;; the first update! must be generation 1. [It is fine if update!
+;; calls are made from multiple threads and arrive with out-of-order
+;; generation numbers; they are automatically queued and handled in
+;; the correct order.]
+;;
+;; Other public methods -- `classify`, `get-tokens`, `grouping`,
+;; `indent-line`, `indent-range` -- take both a generation and a
+;; position. They automatically block until the updating thread has
+;; progressed through that generation and position.
+;;
+;; The generation number is intended to support "distributed" use
+;; patterns, where the editor might live in a different process or
+;; even on a remote machine.
+;;
+;; As the updater thread works, it may produce "notifications" by
+;; calling the `on-changed-lang-info` and `on-changed-token` methods.
+;; This happens on the updater thread; the recipient should only queue
+;; these (e.g. in an async channel) to handle later in some other
+;; thread, and return immediately.
+;;
+;; `on-changed-lang-info` is called for the generation 1 update, as
+;; well as for updates that change the #lang meaningfully (change lang
+;; info values such as 'color-lexer or 'drracket:indentation).
+;;
+;; `on-changed-tokens` is called when an update! results in different
+;; tokens for some span. The recipient should simply queue this
+;; information in an async channel. What should it do when retrieving
+;; them later? It depends on the program. One approach is to call
+;; `get-tokens` eagerly for the entire invalid span and use the tokens
+;; to color/propertize the entire span. Another approach is to record
+;; the invalid span, but let some other mechanism call `get-tokens`
+;; only if/as/when portions of the invalid span become visible to the
+;; user, such as when they scroll. (The latter approach is what we use
+;; in Emacs: Clear a "fontified" property for the invalid region, and
+;; let the normal font-lock mechanism ask us to fontify visible
+;; non-fontified areas.)
+;;
+;; Although this class implements the color-textoid<%> interface,
+;; those methods are NOT intended to be used directly by a tool ---
+;; for speed they are intentionally NOT thread-safe! Instead the
+;; `grouping` and `indent-x` methods work by supplying these methods
+;; to a lang grouper or indenter, within a single dynamic extent where
+;; it is thread-safe to call them.
+;;
+;;
+;; Portions originated from
+;; /src/racket-lang/racket/share/pkgs/gui-lib/framework/private
+
+(define generation/c exact-nonnegative-integer?)
+
+;; We use 0-based positions
+(define min-position 0)
+(define max-position (sub1 (expt 2 63)))
+(define position/c (integer-in min-position max-position))
+
+;; Our data for token-tree%
+(struct data (attribs backup mode) #:transparent #:authentic)
+
+(define-simple-macro (with-semaphore sema e:expr ...+)
+ (call-with-semaphore sema (λ () e ...)))
+
+(define hash-lang%
+ (class* object% (color-textoid<%>)
+ (super-new)
+
+ ;; Virtual methods to override for notifications
+ (define/public (on-changed-lang-info gen li) (void))
+ (define/public (on-changed-tokens gen beg end) (void))
+
+ ;; A new object has an empty string and is at updated-generation
+ ;; 0. The creator should then use update! to set the initial
+ ;; string value and start the initial tokenization. That way both
+ ;; `new` and `update!` return immediately, and all tokenization is
+ ;; done on the updater thread.
+ (define updated-generation 0)
+ (define updated-position (sub1 min-position))
+
+ (define content lines:empty-text-lines)
+ (define tokens (new token-tree%))
+ (define tokens-sema (make-semaphore 1))
+ (define parens (new paren-tree% [matches default-paren-matches]))
+ (define parens-sema (make-semaphore 1))
+
+ ;; By default the lang is read from `content`, for when that
+ ;; represents a source file containing #lang or a file module.
+ ;; However `other-lang-source` may be a string used instead to
+ ;; read the language, for a REPL buffer that should use the lang
+ ;; from the file for which it is a REPL.
+ (init-field [other-lang-source #f])
+ (define lang-info (if other-lang-source
+ (read-lang-info (open-input-string other-lang-source))
+ default-lang-info))
+ (define/public (get-lang-info) lang-info)
+
+ ;; Some methods intended just for tests
+ (define/public (-get-content) (lines:get-text content 0))
+ (define/public (-get-modes)
+ (define modes null)
+ (send tokens search-min!)
+ (send tokens
+ for-each
+ (λ (beg end data)
+ (set! modes (cons (list beg end (data-mode data))
+ modes))))
+ (reverse modes))
+ #;
+ (define/private (-show-tree msg t [offset 0])
+ (displayln msg)
+ (send t for-each
+ (λ (-beg len dat)
+ (define beg (+ -beg offset))
+ (define end (+ beg len))
+ (println (vector beg end (lines:get-text content beg end)
dat)))))
+
+ ;; position/c -> (or/c #f (list/c position/c position/c token?))
+ ;;
+ ;; Note: To be thread-safe must use tokens-sema.
+ (define/private (token-ref pos)
+ (send tokens search! pos)
+ (define beg (send tokens get-root-start-position))
+ (define end (send tokens get-root-end-position))
+ (and (<= beg pos) (< pos end)
+ (list beg end (send tokens get-root-data))))
+
+ ;; ----------------------------------------------------------------------
+ ;;
+ ;; Coordinate progress of tokenizing updater thread
+
+ ;; Allow threads to wait -- safely and without polling -- for the
+ ;; updater thread to progress to at least a given generation and
+ ;; position.
+ (define monitor (make-monitor))
+
+ ;; Called from updater thread.
+ (define/private (set-update-progress #:generation [g updated-generation]
+ #:position p)
+ (progress monitor
+ (λ ()
+ (set! updated-generation g)
+ (set! updated-position p))))
+
+ ;; Called from threads that need to wait for update progress to a
+ ;; certain generation and position.
+ (define/public (block-until-updated-thru gen [pos max-position])
+ (wait monitor
+ (λ ()
+ (and (<= gen updated-generation)
+ (<= pos updated-position)))))
+
+ ;; -----------------------------------------------------------------
+ ;;
+ ;; Tokenizer updater thread
+
+ ;; Entry thunk of our updater thread, which gets items from the
+ ;; async channel `update-chan`, put there by the public `update!`
+ ;; method.
+ ;;
+ ;; The only complexity here is that we tolerate update requests
+ ;; arriving with out-of-order generation numbers. (This could
+ ;; result from update! being called from various threads. For
+ ;; example Racket Mode commands are each handled on their own
+ ;; thread, much like a web server. As a rough analogy, this is
+ ;; like handling TCP packets arriving possibly out of order.)
+ ;;
+ ;; TODO: Does this complexity belong here in this class, or should
+ ;; it move outside? Strictly speaking this is about coordinating
+ ;; multi-thread calls to our public update! method -- not about
+ ;; coordinating our updater thread with other threads. This could
+ ;; as easily live in e.g. hash-lang-bridge.rkt instead of here.
+ (define update-chan (make-async-channel))
+ (thread
+ (λ ()
+ (define pending-updates (make-hash))
+ (let get ([next-update-gen 1])
+ (match-define (cons gen more) (async-channel-get update-chan))
+ (hash-set! pending-updates gen more)
+ (let do-pending ([next-update-gen next-update-gen])
+ (match (hash-ref pending-updates next-update-gen #f)
+ [(list pos old-len new-str)
+ (hash-remove! pending-updates next-update-gen)
+ (do-update! next-update-gen pos old-len new-str)
+ (do-pending (add1 next-update-gen))]
+ [#f (get next-update-gen)])))))
+
+ ;; Runs on updater thread.
+ (define/private (do-update! gen pos old-len new-str)
+ (define new-len (string-length new-str))
+ ;; Initial progress for other threads: Nothing yet within this
+ ;; new generation.
+ (set-update-progress #:generation gen
+ #:position (sub1 min-position))
+ ;; Update the text-lines data structure.
+ (when (< 0 old-len)
+ (set! content (lines:delete content pos (+ pos old-len))))
+ (when (< 0 new-len)
+ (set! content (lines:insert content pos new-str)))
+ ;; Update tokens and parens trees. If lang lexer changed, it
+ ;; could result in entirely different tokens and parens, so in
+ ;; that case restart from scratch.
+ (cond [(check-lang-info/lexer-changed? gen pos)
+ (set! tokens (new token-tree%))
+ (set! parens (new paren-tree%
+ [matches (lang-info-paren-matches lang-info)]))
+ (update-tokens-and-parens min-position
+ (lines:text-length content))]
+ [else
+ (update-tokens-and-parens pos
+ (- new-len old-len))]))
+
+ ;; Detect whether #lang changed AND ALSO (to avoid excessive
+ ;; notifications and work) whether that changed any lang info
+ ;; values we use. Notify if any changed, or if this is the first
+ ;; generation. Return true IFF the lexer changed. For example this
+ ;; will return false for a change from #lang racket to
+ ;; racket/base.
+ (define last-lang-end-pos (add1 min-position))
+ (define/private (check-lang-info/lexer-changed? gen pos)
+ (define new-lang-info
+ (cond
+ [other-lang-source lang-info]
+ [else
+ (cond
+ [(< pos last-lang-end-pos)
+ (define in (lines:open-input-text content 0))
+ (define-values (new-lang-info end-pos) (read-lang-info* in))
+ (set! last-lang-end-pos end-pos) ;for checking next time
+ new-lang-info]
+ [else lang-info])]))
+ (define any-changed? (not (equal? lang-info
+ new-lang-info)))
+ (define lexer-changed? (not (equal? (lang-info-lexer lang-info)
+ (lang-info-lexer new-lang-info))))
+ (set! lang-info new-lang-info)
+ (when (or any-changed? (= gen 1))
+ (on-changed-lang-info gen new-lang-info))
+ lexer-changed?)
+
+ (define/private (update-tokens-and-parens edit-pos diff)
+ (define raw-lexer (if other-lang-source
+ (lang-info-lexer lang-info)
+ (waive-option module-lexer*)))
+ ;; Determine the position from which we need to start
+ ;; re-tokenizing (this will be less than the edit position) and
+ ;; the initial lexer mode.
+ (define-values (initial-pos initial-mode effective-lexer)
+ (cond
+ [(procedure-arity-includes? raw-lexer 3)
+ (with-semaphore tokens-sema
+ ;; Find beginning of the token, if any, corresponding to the
+ ;; edit position.
+ ;;
+ ;; An update at the end can result in token-ref returning #f
+ ;; so make an initial adjustment of edit-pos to give to
+ ;; token-ref.
+ (send tokens search! edit-pos)
+ (define pos (send tokens get-root-start-position))
+ (match (token-ref pos)
+ [(list beg _end (struct* data ([backup backup])))
+ ;; Initially back up by at least 1 (i.e. to the previous
+ ;; token) or by this token's `backup` amount.
+ (let loop ([pos (- beg (max 1 backup))])
+ (match (token-ref pos)
+ [(list beg _end (struct* data ([backup backup])))
+ (if (< 0 backup)
+ (loop (- beg backup))
+ ;; Finally, back up one more to get the initial
+ ;; lexer mode, if any. (Why: The mode stored
+ ;; with a token is state with which to read the
+ ;; _next_ token.)
+ (match (token-ref (sub1 beg))
+ [(list _beg _end (struct* data ([mode mode])))
+ (values beg mode raw-lexer)]
+ [#f (values beg #f raw-lexer)]))]
+ [#f (values min-position #f raw-lexer)]))]
+ [#f (values min-position #f raw-lexer)]))]
+ [(procedure-arity-includes? raw-lexer 1)
+ (values min-position
+ 'dummy-mode
+ (λ (port _pos _mode)
+ (define-values (lexeme attribs paren beg end)
+ (raw-lexer port))
+ (values lexeme attribs paren beg end beg 'dummy-mode)))]
+ [else
+ (error 'update-tokens-and-parens "Unknown lexer arity")]))
+ ;; Everything before this is valid; allow other threads to
+ ;; progress thru that position of this generation.
+ (set-update-progress #:position (sub1 initial-pos))
+
+ ;; Split the token and paren trees.
+ (define old-tokens (with-semaphore tokens-sema
+ (send tokens search! initial-pos)
+ (define-values (t1 t2) (send tokens split-before))
+ (set! tokens t1)
+ t2))
+ (with-semaphore parens-sema
+ (send parens split-tree initial-pos))
+
+ ;; Run the lexer until it produces sufficient unchanged tokens.
+ ;; Update token-tree and paren-tree. Track bounds of visible
+ ;; changes to notify via on-changed-tokens.
+ (define in (lines:open-input-text content initial-pos))
+ (define-values (min-changed-pos max-changed-pos)
+ (let tokenize ([pos initial-pos]
+ [mode initial-mode]
+ [previous-same? #f]
+ [contig-same-count 0]
+ [min-changed-pos max-position]
+ [max-changed-pos min-position])
+ (define pos/port (add1 pos))
+ (define-values (lexeme attribs paren beg/port end/port backup
new-mode/ds)
+ (effective-lexer in pos/port mode))
+ (define-values (new-mode may-stop?)
+ (match new-mode/ds
+ [(struct* dont-stop ([val v])) (values v #f)]
+ [v (values v #t)]))
+ (cond
+ [(eof-object? lexeme)
+ (values min-changed-pos max-changed-pos)]
+ [else
+ (define new-beg (sub1 beg/port))
+ (define new-end (sub1 end/port))
+ (define new-span (- new-end new-beg))
+ (define new-tok (data attribs backup new-mode))
+ (with-semaphore tokens-sema (insert-last-spec! tokens new-span
new-tok))
+ (with-semaphore parens-sema (send parens add-token paren
new-span))
+ (set-update-progress #:position (sub1 new-end))
+
+ ;; Detect whether same as before (just shifted by `diff`)
+ (send old-tokens search! (- new-beg initial-pos diff))
+ (define old-beg (send old-tokens get-root-start-position))
+ (define old-end (send old-tokens get-root-end-position))
+ (define old-span (- old-end old-beg))
+ (define old-tok (send old-tokens get-root-data))
+ (define same? (and (equal? new-span old-span)
+ (equal? new-tok old-tok)))
+ (define new-contig-same-count (if (and previous-same? same?)
+ (add1 contig-same-count)
+ 0))
+ (cond
+ [(and may-stop?
+ ;; If enough same tokens in a row, assume
+ ;; tokenization has "converged" with old one and
+ ;; there is no need to continue. Here "3" is a
+ ;; WAG. [IIUC the framework colorer feels "1" is
+ ;; enough and relies on lexer dont-stop.]
+ (>= new-contig-same-count 3))
+ (send old-tokens search! old-beg)
+ (define-values (_ keep) (send old-tokens split-after))
+ (with-semaphore tokens-sema (insert-last! tokens keep))
+ (define paren-keep-span (- (last-position) new-end))
+ (with-semaphore parens-sema (send parens merge-tree
paren-keep-span))
+ (values min-changed-pos max-changed-pos)]
+ [else
+ ;; For purposes of notifying clients to re-color we
+ ;; use a stricter sense of "same" than we do for
+ ;; deciding whether to continue lexing. Here we care
+ ;; only whether the span and attributes are the same
+ ;; (not whether backup or mode changed; those are N/A
+ ;; for visible coloring changes).
+ (define same-span/attribs?
+ (and (equal? new-span old-span)
+ (equal? (data-attribs new-tok) (data-attribs old-tok))))
+ (tokenize new-end
+ new-mode
+ same?
+ new-contig-same-count
+ (if same-span/attribs?
+ min-changed-pos
+ (min min-changed-pos new-beg))
+ (if same-span/attribs?
+ max-changed-pos
+ (max max-changed-pos new-end)))])])))
+ (on-changed-tokens updated-generation
+ min-changed-pos
+ max-changed-pos)
+ (set-update-progress #:position max-position))
+
+ ;; ------------------------------------------------------------
+ ;;
+ ;; Public methods for Emacs commands.
+
+ ;; This method is safe to call from various threads.
+ ;;
+ ;; The method signature here is similar to that of Emacs'
+ ;; after-change functions: Something changed starting at POS. The
+ ;; text there used to be OLD-LEN chars long, but is now NEW-STR.
+ (define/public (update! gen pos old-len new-str)
+ ;;(-> generation/c position/c exact-nonnegative-integer? string? any)
+ (unless (< updated-generation gen)
+ (raise-argument-error 'update! "valid generation" 0 gen pos old-len
new-str))
+ (unless (<= min-position pos)
+ (raise-argument-error 'update! "valid position" 1 gen pos old-len
new-str))
+ (async-channel-put update-chan
+ (list gen pos old-len new-str)))
+
+ ;; Can be called on any command thread.
+ (define/public (classify gen pos)
+ ;; (-> generation/c position/c (or/c #f (list/c position/c position/c
(or/c symbol? hash-eq?))
+ (block-until-updated-thru gen pos)
+ (match (with-semaphore tokens-sema (token-ref pos))
+ [(list beg end (struct* data ([attribs attribs])))
+ (list beg end attribs)]
+ [#f #f]))
+
+ ;; Can be called on any command thread.
+ (define/public (get-tokens gen
+ [from min-position]
+ [upto max-position])
+ (block-until-updated-thru gen upto)
+ (let loop ([pos from])
+ (match (with-semaphore tokens-sema (token-ref pos))
+ [(list beg end (struct* data ([attribs attribs])))
+ (if (<= end upto)
+ (cons (list beg end attribs)
+ (loop end))
+ null)]
+ [#f null])))
+
+ ;; Methods for Emacs navigation and indent commands.
+ ;;
+ ;; These command methods work by calling various drracket:xyz
+ ;; functions, supplying `this` as the color-textoid<%> argument.
+ ;; In other words, those functions will "call back" use the
+ ;; textoid methods.
+ ;;
+ ;; These command methods call block-until-updated-thru, to wait
+ ;; until the updater thread has progressed far enough to support
+ ;; the command.
+ ;;
+ ;; These command methods take the tokens and parens semaphores for
+ ;; the dynamic extent the call to the drracket:xyz function. As a result
+ ;; the textoid methods need not. This is signficantly faster (e.g. 2X).
+ ;;
+
+ ;; Can be called on any command thread.
+ (define/public (grouping gen pos dir limit count)
+ (cond
+ [(<= count 0) pos]
+ [else
+ (block-until-updated-thru gen
+ (case dir
+ [(up backward) min-position]
+ [(down forward) max-position]))
+ (define grouping-position (lang-info-grouping-position lang-info))
+ (let loop ([pos pos]
+ [count count])
+ (match (with-semaphore tokens-sema
+ (with-semaphore parens-sema
+ (match (grouping-position this pos limit dir)
+ ;; Handle case where it returns #t, meaning
+ ;; "use default s-expr grouping". That spec
+ ;; slightly predates the addition of
+ ;; syntax-color/racket-navigation --- the
+ ;; availability of which probably means that
+ ;; this #t value should no longer be returned?
+ ;; In other words, if a lang wants s-expr nav,
+ ;; its lang info should either not supply any
+ ;; drracket:grouping-position at all, or,
+ ;; supply racket-grouping-position as that?
+ [#t
+ (when (equal? grouping-position
racket-grouping-position)
+ (error 'grouping "racket-grouping-position returned
#t"))
+ (racket-grouping-position this pos limit dir)]
+ [v v])))
+ [#f #f]
+ [(? number? new-pos)
+ (cond [(< 1 count) (loop new-pos (sub1 count))]
+ [(= new-pos pos) #f]
+ [else new-pos])]))]))
+
+ ;; Can be called on any command thread.
+ (define/public (indent-line-amount gen pos)
+ (block-until-updated-thru gen pos)
+ (with-semaphore tokens-sema
+ (with-semaphore parens-sema
+ (or ((lang-info-line-indenter lang-info) this pos) ;may return #f
meaning...
+ (racket-amount-to-indent this pos)))))
+
+ ;; Can be called on any command thread.
+ (define/public (indent-range-amounts gen from upto)
+ (define range-indenter (lang-info-range-indenter lang-info))
+ (cond [(not range-indenter) #f]
+ [else
+ (block-until-updated-thru gen upto)
+ (with-semaphore tokens-sema
+ (with-semaphore parens-sema
+ (range-indenter this from upto)))]))
+
+ ;; Can be called on any command thread.
+ (define/public (submit-predicate in eos?)
+ (match (lang-info-submit-predicate lang-info)
+ [(? procedure? p) (p in eos?)]
+ [_ #f]))
+
+ ;; -----------------------------------------------------------------
+ ;; color-textoid<%> methods.
+ ;;
+ ;; Warning: As discussed above, these are thread-safe to call only
+ ;; from the dyanamic extent of the `grouping`,
+ ;; `indent-line-amount`, or `indent-range-amounts` methods.
+
+ (define/public (last-position)
+ (lines:text-length content))
+
+ (define/public (get-character pos)
+ (if (< pos (lines:text-length content))
+ (string-ref (lines:get-text content pos (add1 pos)) 0)
+ #\nul))
+
+ (define/public (get-text from upto)
+ (lines:get-text content from (if (eq? upto 'eof) (last-position) upto)))
+
+ (define/public (position-paragraph pos [eol? #f])
+ (lines:position->line content (min pos (last-position))))
+
+ (define/public (paragraph-start-position para)
+ (lines:line->start content (max 0 (min para (lines:text-line-count
content)))))
+
+ (define/public (paragraph-end-position para)
+ (cond [(<= (lines:text-line-count content) (add1 para))
+ (lines:text-length content)]
+ [else
+ (sub1 (lines:line->start content (add1 para)))]))
+
+ (define/public (classify-position* position)
+ (send tokens search! position)
+ (match (send tokens get-root-data)
+ [(struct* data ([attribs (app attribs->table table)])) table]
+ [#f #f]))
+
+ (define/public (classify-position position)
+ (send tokens search! position)
+ (match (send tokens get-root-data)
+ [(struct* data ([attribs (app attribs->type type)])) type]
+ [#f #f]))
+
+ (define/public (get-token-range position)
+ (send tokens search! position)
+ (values (send tokens get-root-start-position)
+ (send tokens get-root-end-position)))
+
+ (define/public (get-backward-navigation-limit pos)
+ 0)
+
+ (define/public (backward-match position cutoff)
+ (let ([x (internal-backward-match position cutoff)])
+ (cond
+ [(or (eq? x 'open) (eq? x 'beginning)) #f]
+ [else x])))
+
+ (define/private (internal-backward-match position cutoff)
+ (let ([position (skip-whitespace position 'backward #t)])
+ (define-values (start end error) (send parens match-backward position))
+ (cond
+ [(and start end (not error))
+ (let ((match-pos start))
+ (cond
+ ((>= match-pos cutoff) match-pos)
+ (else #f)))]
+ [(and start end error) #f]
+ [else
+ (send tokens search! (sub1 position))
+ (define tok-start (send tokens get-root-start-position))
+ (cond
+ [(send parens is-open-pos? tok-start) 'open]
+ [(= tok-start position) 'beginning]
+ [else tok-start])])))
+
+ (define/public (backward-containing-sexp position cutoff)
+ (let loop ([cur-pos position])
+ (let ([p (internal-backward-match cur-pos cutoff)])
+ (cond
+ [(eq? 'open p)
+ ;; [Comment from color.rkt: "Should this function skip
+ ;; backwards past whitespace? the docs seem to indicate
+ ;; it does, but it doesn't really."]
+ cur-pos]
+ [(eq? 'beginning p) #f]
+ [(not p) #f]
+ (else (loop p))))))
+
+ (define/public (forward-match position cutoff)
+ (do-forward-match position cutoff #t))
+
+ (define/private (do-forward-match position cutoff skip-whitespace?)
+ (let ([position (if skip-whitespace?
+ (skip-whitespace position 'forward #t)
+ position)])
+ (define-values (start end error) (send parens match-forward position))
+ (cond
+ [(and start end (not error))
+ (cond
+ [(<= end cutoff) end]
+ [else #f])]
+ [(and start end error) #f]
+ [else
+ (skip-past-token position)])))
+
+ (define/private (skip-past-token position)
+ (send tokens search! position)
+ (define start (send tokens get-root-start-position))
+ (define end (send tokens get-root-end-position))
+ (cond
+ [(or (send parens is-close-pos? start)
+ (= end position))
+ #f]
+ [else end]))
+
+ (define/public (skip-whitespace position direction comments?)
+ (cond
+ [(and (eq? direction 'forward) (>= position (last-position))) position]
+ [(and (eq? direction 'backward) (<= position 0)) position]
+ [else
+ (send tokens search! (if (eq? direction 'backward)
+ (sub1 position)
+ position))
+ (match (send tokens get-root-data)
+ [(struct* data ([attribs (app attribs->type type)]))
+ (cond
+ [(or (eq? 'white-space type)
+ (and comments? (eq? 'comment type)))
+ (skip-whitespace (if (eq? direction 'forward)
+ (send tokens get-root-end-position)
+ (send tokens get-root-start-position))
+ direction
+ comments?)]
+ [else position])]
+ [#f position])]))
+
+ (define/public (get-regions)
+ '((0 end)))))
+
+(define default-lexer racket-lexer)
+(define default-module-language #f)
+(define default-paren-matches '((\( \)) (\[ \]) (\{ \})))
+(define default-quote-matches '(#\" #\|))
+
+(define default-lang-info
+ (lang-info default-module-language
+ default-lexer
+ default-paren-matches
+ default-quote-matches
+ racket-grouping-position
+ racket-amount-to-indent
+ #f
+ #f
+ #f))
+
+(define (read-lang-info* in)
+ (define info (or (with-handlers ([values (λ _ #f)])
+ (read-language in (λ _ #f)))
+ (λ (_key default) default)))
+ (define-values (_line _col end-pos) (port-next-location in))
+ (define mod-lang (safe-info-module-language info))
+ (values (lang-info mod-lang
+ (info 'color-lexer default-lexer)
+ (info 'drracket:paren-matches default-paren-matches)
+ (info 'drracket:quote-matches default-quote-matches)
+ (info 'drracket:grouping-position
racket-grouping-position)
+ (info 'drracket:indentation racket-amount-to-indent)
+ (info 'drracket:range-indentation #f)
+ (info 'drracket:submit-predicate #f)
+ (comment-delimiters info mod-lang))
+ end-pos))
+
+;; Handle the module-language lang info key, as documented at
+;;
<https://docs.racket-lang.org/syntax/reader-helpers.html#%28mod-path._syntax%2Fmodule-reader%29>.
+;; (info-proc -> (or/c #f string?)
+(define (safe-info-module-language info)
+ (define (handle v)
+ (match v
+ [(== default-module-language) default-module-language]
+ [(? module-path? mp)
+ (~a mp)]
+ [(? syntax? stx)
+ #:when (module-path? (syntax->datum stx))
+ (~a (syntax->datum stx))]
+ [(? procedure? p)
+ (handle v)]
+ [hopeless
+ (log-racket-mode-debug "Ignoring value returned for module-language
key: ~v"
+ info hopeless)
+ default-module-language]))
+ (handle (info 'module-language default-module-language)))
+
+;; Return (list start continue end padding)
+(define (comment-delimiters info mod-lang)
+ (define (fallback)
+ ;; Fallback when langs don't support the info key, or the value
+ ;; isn't as expected.
+ (define (root mp-str) ;e.g. 'racket and 'racket/base => 'racket
+ (match mp-str
+ [(pregexp "^([^/]+)" (list _ str))
+ (string->symbol str)]
+ [_ #f]))
+ (match (root mod-lang)
+ ["scribble" '("@;" "@;" "" " ")]
+ ["rhombus" '("//" "//" "" " ")]
+ [_ '(";;" ";;" "" " ")]))
+ (match (info 'drracket:comment-delimiters #f)
+ [#f (fallback)]
+ [(list* (list 'line (? string? start) (? string? padding))
+ _other-styles)
+ (list start start "" padding)]
+ [(list* (list 'region (? string? start) (? string? continue) (? string?
end) (? string? padding))
+ _other-styles)
+ (list start continue end padding)]
+ [unexpected
+ (log-racket-mode-warning
+ "drracket:comment-delimiters from mod-lang ~v\n unexpected value: ~v"
+ mod-lang
+ unexpected)
+ (fallback)]))
+
+(define (read-lang-info in)
+ (define-values (v _pos) (read-lang-info* in))
+ v)
+
+(define (attribs->type attribs)
+ (match attribs
+ [(? symbol? s) s]
+ [(? hash? ht) (hash-ref ht 'type 'unknown)]
+ [_ 'unknown]))
+
+(define (attribs->table attribs)
+ (if (symbol? attribs)
+ (hasheq 'type attribs)
+ attribs))
+
+;; This could be moved to its own file.
+(module monitor racket/base
+ (require racket/match
+ syntax/parse/define)
+
+ (provide make-monitor
+ monitor?
+ progress
+ wait
+ wait-evt)
+
+ (struct monitor ([waiters #:mutable] sema) #:authentic)
+
+ (struct waiter (pred sema) #:transparent #:authentic)
+
+ (define (make-monitor)
+ (monitor null (make-semaphore 1)))
+
+ (define-simple-macro (with-semaphore sema e:expr ...+)
+ (call-with-semaphore sema (λ () e ...)))
+
+ ;; To be called by a worker thread, to make progress that might cause
+ ;; some waiter's predicate to become true. The thunk is called within
+ ;; the monitor's semaphore, so it is safe for it to e.g. set! multiple
+ ;; variables.
+ (define (progress m thunk)
+ (with-semaphore (monitor-sema m)
+ (thunk)
+ (set-monitor-waiters!
+ m
+ (let loop ([waiters (monitor-waiters m)])
+ (match waiters
+ [(list) (list)]
+ [(cons w more)
+ (cond [((waiter-pred w))
+ (semaphore-post (waiter-sema w))
+ (loop more)] ;remove
+ [else ;keep
+ (cons w (loop more))])])))))
+
+ ;; To be called by any number of observer threads, to wait until a
+ ;; predicate becomes true. The predicate is checked initially in case
+ ;; it is already true, but thereafter only whenever a worker thread
+ ;; calls `progress`. The predicate is called within the monitor's
+ ;; semaphore (if the `progress` thunk set!s multiple vars, it's safe
+ ;; for the pred to check them).
+ (define (wait m pred)
+ (unless (call-with-semaphore (monitor-sema m) pred) ;fast path
+ (semaphore-wait (wait-evt m pred))))
+
+ ;; Like `wait` but returns a synchronizable event.
+ (define (wait-evt m pred)
+ (cond [(call-with-semaphore (monitor-sema m) pred) ;fast path
+ always-evt]
+ [else
+ (define pred-sema (make-semaphore 0))
+ (with-semaphore (monitor-sema m)
+ (set-monitor-waiters! m (cons (waiter pred pred-sema)
+ (monitor-waiters m))))
+ pred-sema]))
+
+ (module+ example
+ ;; Some variables that a worker thread will increase monotonically.
+ (define i 0)
+ (define j 0)
+ ;; A monitor object
+ (define m (make-monitor))
+ ;; Some threads that want to wait for certain values.
+ (void (thread (λ ()
+ (define (pred-0) (and (<= 0 i)))
+ (wait m pred-0)
+ (displayln "pred-0 became true (fast path)"))))
+ (void (thread (λ ()
+ (define (pred-i-3-j-6) (and (<= 3 i) (<= 6 j)))
+ (wait m pred-i-3-j-6)
+ (displayln "pred-i-3-j-6 became true"))))
+ (void (thread (λ ()
+ (define (pred-i-5) (<= 5 i))
+ (wait m pred-i-5)
+ (displayln "pred-i-5 became true"))))
+ ;; A worker thread.
+ (let loop ()
+ (progress m (λ ()
+ (set! i (add1 i))
+ (set! j (add1 j))
+ (displayln (list i j))))
+ (when (< i 10)
+ (sleep 0.5)
+ (loop)))))
+(require 'monitor)
diff --git a/racket/image.rkt b/racket/image.rkt
index 280ab170a7..8503d469d8 100644
--- a/racket/image.rkt
+++ b/racket/image.rkt
@@ -44,5 +44,5 @@
(and (? bytes? bstr) (app default-width width))) ;bytes
(define filename (make-temporary-file (~a "racket-image-~a." ext)))
(with-output-to-file filename #:exists 'truncate (λ () (display bstr)))
- (cons (format "#<Image: ~a>" filename) width)]
+ (cons (path->string filename) width)]
[#f #f]))
diff --git a/racket/instrument.rkt b/racket/instrument.rkt
index 656c7c7bda..19ad16bdd8 100644
--- a/racket/instrument.rkt
+++ b/racket/instrument.rkt
@@ -15,18 +15,18 @@
stacktrace-imports^
original-stx
expanded-stx)
- racket/dict
racket/format
racket/match
racket/set
racket/unit
syntax/parse
+ "repl-output.rkt"
"repl-session.rkt"
"util.rkt")
(provide make-instrumented-eval-handler
error-context-display-depth
- print-error-trace
+ get-error-trace
instrumenting-enabled
test-coverage-enabled
clear-test-coverage-info!
@@ -89,7 +89,7 @@
[(#%app time-apply . _)
(unless (set-member? warned-sessions (current-session-id))
(set-add! warned-sessions (current-session-id))
- (display-commented
+ (repl-output-message
@~a{Warning: time or time-apply used in errortrace annotated code.
Instead use command-line racket for more-accurate measurements.
(Will not warn again for this REPL session.)}))
@@ -121,12 +121,19 @@
loc
expr)))]))
-;; print-error-trace
-;;
-;; Just re-provide the one from errortrace-lib because (a) it works
-;; and (b) the `make-st-mark' representation is intentionally not
-;; documented.
-
+;; Functional alternative to print-error-trace.
+(define (get-error-trace e)
+ (for/list ([_ (error-context-display-depth)]
+ [stx (in-list
+ (map st-mark-source
+ (continuation-mark-set->list (exn-continuation-marks e)
+ errortrace-key)))])
+ (cons (syntax->datum stx)
+ (srcloc (syntax-source stx)
+ (syntax-line stx)
+ (syntax-column stx)
+ (syntax-position stx)
+ (syntax-span stx)))))
;;; Test coverage
diff --git a/racket/interaction.rkt b/racket/interaction.rkt
new file mode 100644
index 0000000000..179ee7f210
--- /dev/null
+++ b/racket/interaction.rkt
@@ -0,0 +1,63 @@
+;; Copyright (c) 2013-2023 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+#lang at-exp racket/base
+
+(require racket/format
+ racket/gui/dynamic
+ racket/set
+ "gui.rkt"
+ "repl-output.rkt"
+ "repl-session.rkt"
+ "stack-checkpoint.rkt")
+
+(provide get-interaction)
+
+(define (get-interaction prompt)
+ (maybe-warn-for-session)
+ (repl-output-prompt (string-append prompt ">"))
+ (define str (get-submission))
+ (define in (open-input-string str))
+ (with-stack-checkpoint
+ ((current-read-interaction) 'racket-mode-repl in)))
+
+(define current-get-interaction-evt
+ (dynamic-require 'racket/base 'current-get-interaction-evt (λ () #f)))
+
+;; Get a string from current-submissions channel in the best manner
+;; available given the version of Racket. Avoids hard dependency on
+;; Racket 8.4+.
+(define (get-submission)
+ (cond
+ [current-get-interaction-evt
+ (let loop ()
+ (sync
+ (handle-evt ((current-get-interaction-evt)) ;allow GUI yield
+ (λ (thk)
+ (thk)
+ (loop)))
+ (current-submissions)))]
+ [else
+ ((txt/gui sync yield) (current-submissions))]))
+
+;; Note: We try to eagerly load racket/gui/base in gui.rkt. See
+;; comments there, explaining why.
+;;
+;; As a result, gui-available? here merely means that a user program
+;; _could_ use it (e.g. gui-lib is installed and running on a
+;; non-headless system where Gtk can initialize).
+;;
+;; As a result, a user on a GUI-capable Racket install will see the
+;; warning at the start of _every_ REPL session -- not just when first
+;; running a GUI program (which would be more desirable, but I don't
+;; immediately see how to do that).
+(define warned-sessions (mutable-set))
+(define (maybe-warn-for-session)
+ (unless current-get-interaction-evt
+ (when (gui-available?)
+ (unless (set-member? warned-sessions (current-session-id))
+ (set-add! warned-sessions (current-session-id))
+ (repl-output-message
+ @~a{Warning: GUI programs might not work correctly because
+ your version of Racket lacks `current-get-interaction-evt`,
+ which was added in Racket 8.4.})))))
diff --git a/racket/interactions.rkt b/racket/interactions.rkt
deleted file mode 100644
index 4aa62a3a88..0000000000
--- a/racket/interactions.rkt
+++ /dev/null
@@ -1,91 +0,0 @@
-;; Copyright (c) 2013-2022 by Greg Hendershott.
-;; SPDX-License-Identifier: GPL-3.0-or-later
-
-#lang racket/base
-
-(require racket/match
- racket/port
- "stack-checkpoint.rkt"
- "util.rkt")
-
-(provide get-interaction)
-
-;; Note: We handle eof-object? and exn:fail:network? by doing an exit
-;; and letting the exit-handler in run.rkt cleanup the TCP connection.
-;; This handles the case where e.g. the user kills the REPL buffer and
-;; its process on the client/Emacs side. We used to have code here in
-;; an effort support lang/datalog using eof as an expression separator
-;; -- but that just causes an endless loop 100% CPU spike with an
-;; abandoned tcp-input-port. So give up on that, reverting issue #305.
-
-(define (get-interaction prompt)
- ;; Need to port-count-lines! here -- not sufficient to do once to
- ;; REPL TCP input port upon connection -- because racket/gui/base
- ;; sets current-get-interaction-port to wrap the original input
- ;; port. See issues #519 #556.
- (define in ((current-get-interaction-input-port)))
- (port-count-lines! in)
- ;; Using with-handlers here would be a mistake; see #543.
- (call-with-exception-handler
- (λ (e)
- (when (exn:fail:network? e)
- (log-racket-mode-info "get-interaction: exn:fail:network")
- (exit 'get-interaction-exn:fail:network))
- (when (exn:fail:read? e) ;#646
- (discard-remaining-lines! in)
- (zero-column!))
- e)
- (λ ()
- (unless (already-more-to-read? in) ;#311
- (display-prompt prompt))
- (define v (with-stack-checkpoint
- ((current-read-interaction) prompt in)))
- (when (eof-object? v)
- (log-racket-mode-info "get-interaction: eof")
- (display-commented
- "Closing REPL session because language's current-read-interaction
returned EOF")
- (exit 'get-interaction-eof))
- (zero-column!)
- v)))
-
-(define (discard-remaining-lines! in)
- (define (f)
- (void (read-line in))
- (f))
- (sync/timeout 0.1 (thread f)))
-
-(define (already-more-to-read? in)
- ;; Is there already at least one more expression available to read
- ;; from the input port?
- ;;
- ;; - Use a "peeking read" so that, if the answer is yes, we don't
- ;; actually consume it (which could cause #449).
- ;;
- ;; To handle multiple expressions the underlying tcp-input-port
- ;; needs block buffer-mode; see issue #582 (it seems to be fine
- ;; that racket/gui/base's current-get-interaction-port wrapper for
- ;; that underlying tcp port reports #f for the buffer-mode).
- ;;
- ;; - Use a thread + channel + sync/timeout so that, if the answer is
- ;; no because there is only a partial sexp -- e.g. "(+ 1" -- we
- ;; don't get stuck inside `read`. Use a custodian to ensure that
- ;; the thread and peeking port are cleaned up; this seems to
- ;; matter on Windows wrt a break, as with issue #609.
- (define ch (make-channel))
- (define cust (make-custodian))
- (parameterize ([current-custodian cust])
- (thread
- (λ ()
- (channel-put ch
- (with-handlers ([values (λ _ #f)])
- (define pin (peeking-input-port in))
- (define v ((current-read-interaction) #f pin))
- (not (eof-object? v)))))))
- (begin0 (sync/timeout 0.01 ch)
- (custodian-shutdown-all cust)))
-
-(define (display-prompt str)
- (fresh-line)
- (display str)
- (display "> ")
- (flush-output))
diff --git a/racket/lang-info.rkt b/racket/lang-info.rkt
new file mode 100644
index 0000000000..795279ba53
--- /dev/null
+++ b/racket/lang-info.rkt
@@ -0,0 +1,30 @@
+;; Copyright (c) 2020-2023 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+#lang racket/base
+
+(provide (struct-out lang-info)
+ lang-info-grouping-position-is-racket?)
+
+;; This is its own file really just so that hash-lang.bridge.rkt can
+;; require it normally and not need to do more dynamic-requires.
+
+(struct lang-info
+ (module-language
+ lexer
+ paren-matches
+ quote-matches
+ grouping-position
+ line-indenter
+ range-indenter
+ submit-predicate
+ comment-delimiters)
+ #:transparent #:authentic)
+
+(define racket-grouping-position
+ (with-handlers ([exn:fail? (λ _ #f)])
+ (dynamic-require 'syntax-color/racket-navigation
'racket-grouping-position)))
+
+(define (lang-info-grouping-position-is-racket? li)
+ (equal? (lang-info-grouping-position li) racket-grouping-position))
+
diff --git a/racket/main.rkt b/racket/main.rkt
index db6289a9e1..238de27fbe 100644
--- a/racket/main.rkt
+++ b/racket/main.rkt
@@ -7,12 +7,11 @@
racket/port
version/utils
"command-server.rkt"
- (only-in "image.rkt" set-use-svg?!)
- "repl.rkt")
+ (only-in "image.rkt" set-use-svg?!))
(module+ main
;; Assert Racket minimum version
- (define minimum-version "6.9")
+ (define minimum-version "6.12")
(define actual-version (version))
(unless (version<=? minimum-version actual-version)
(error '|Racket Mode back end| "Need Racket ~a or newer but ~a is ~a"
@@ -21,17 +20,12 @@
actual-version))
;; Command-line flags (from Emacs front end invoking us)
- (define-values (launch-token accept-host tcp-port)
- (match (current-command-line-arguments)
- [(vector "--auth" auth
- "--accept-host" accept-host
- "--port" port
- (or (and "--use-svg" (app (λ _ (set-use-svg?! #t)) _))
- (and "--do-not-use-svg" (app (λ _ (set-use-svg?! #f)) _))))
- (values auth accept-host (string->number port))]
- [v
- (error '|Racket Mode back end|
- "Bad command-line arguments:\n~v\n" v)]))
+ (match (current-command-line-arguments)
+ [(vector "--use-svg" ) (set-use-svg?! #t)]
+ [(vector "--do-not-use-svg") (set-use-svg?! #f)]
+ [v
+ (error '|Racket Mode back end|
+ "Bad command-line arguments:\n~v\n" v)])
;; Save original current-{input output}-port to give to
;; command-server-loop for command I/O.
@@ -40,5 +34,4 @@
;; Set no-ops so e.g. rando print can't bork the command I/O.
(parameterize ([current-input-port (open-input-bytes #"")]
[current-output-port (open-output-nowhere)])
- (start-repl-session-server launch-token accept-host tcp-port)
(command-server-loop stdin stdout))))
diff --git a/racket/print.rkt b/racket/print.rkt
index 9c570e78e3..4b97d908e1 100644
--- a/racket/print.rkt
+++ b/racket/print.rkt
@@ -4,26 +4,66 @@
#lang racket/base
(require racket/match
+ racket/port
racket/pretty
- "image.rkt")
+ "image.rkt"
+ "repl-output.rkt")
-(provide set-print-parameters)
+(provide make-racket-mode-print-handler
+ current-value-port)
-(define (set-print-parameters pretty? columns pixels/char)
- (cond [pretty?
- (current-print pretty-print-handler)
- (pretty-print-columns columns)
- (pretty-print-size-hook (make-pretty-print-size-hook pixels/char))
- (pretty-print-print-hook (make-pretty-print-print-hook))]
- [else
- (current-print racket-mode-plain-print-handler)])
- (print-syntax-width +inf.0))
+(define current-value-port (make-parameter #f))
-(define (racket-mode-plain-print-handler v)
- (unless (void? v)
- (println (match (convert-image v)
- [(cons path-name _pixel-width) path-name]
- [_ v]))))
+(define (make-racket-mode-print-handler pretty? columns pixels/char)
+ (define (racket-mode-print-handler v)
+ (unless (void? v)
+ (define-values (in out) (make-value-pipe))
+ (parameterize ([current-output-port out]
+ [print-syntax-width +inf.0])
+ (cond
+ [pretty?
+ (parameterize ([pretty-print-columns columns]
+ [pretty-print-size-hook (make-pp-size-hook
pixels/char)]
+ [pretty-print-print-hook (make-pp-print-hook)])
+ (pretty-print v))]
+ [else
+ (match (convert-image v)
+ [(cons path-name _pixel-width)
+ (write-special (cons 'image path-name))]
+ [_
+ (print v)])]))
+ (drain-value-pipe in out)))
+ racket-mode-print-handler)
+
+;; Because pretty-print does a print for each value within a list,
+;; plus for each space and newline, etc., it can result in many calls
+;; to repl-output-value with short strings.
+;;
+;; To avoid this: Use for current-output-port a pipe of unlimited size
+;; to accumulate all the pretty-printed bytes and specials. Finally
+;; drain it using read-bytes-avail! to consolidate runs of bytes
+;; (interrupted only by specials, if any) up to a fixed buffer size.
+
+(define (make-value-pipe)
+ (make-pipe-with-specials))
+
+(define (drain-value-pipe in out)
+ (flush-output out)
+ (close-output-port out)
+ (define buffer (make-bytes 2048))
+ (let loop ()
+ (match (read-bytes-avail! buffer in)
+ [(? exact-nonnegative-integer? len)
+ (define v (bytes->string/utf-8 (subbytes buffer 0 len)))
+ (repl-output-value v)
+ (loop)]
+ [(? procedure? read-special)
+ ;; m-p-w-specials ignores the position arguments so just pass
+ ;; something satisfying the contract.
+ (define v (read-special #f #f #f 1))
+ (repl-output-value-special v)
+ (loop)]
+ [(? eof-object?) (void)])))
;; pretty-print uses separate size and print hooks -- and the size
;; hook can even be called more than once per object. Avoid calling
@@ -36,29 +76,34 @@
;;
;; (Note: Although I had tried using the pre-print and post-print
;; hooks, they seemed to be called inconsistently.)
+;;
+;; Also: "The print-hook procedure is applied to a value for printing
+;; when the sizing hook (see pretty-print-size-hook) returns an
+;; integer size for the value." i.e. But not called otherwise.
(define ht (make-weak-hasheq)) ;weak because #624
-(define (make-pretty-print-size-hook pixels/char)
- (define (racket-mode-size-hook value _display? _port)
+(define (make-pp-size-hook pixels/char)
+ (define (racket-mode-size-hook value display? port)
(define (not-found)
(match (convert-image value)
[(cons path-name pixel-width)
(define char-width (inexact->exact (ceiling (/ pixel-width
pixels/char))))
- (define path+width (cons path-name char-width))
- path+width]
+ (cons path-name char-width)]
[#f #f]))
(match (hash-ref! ht value not-found)
[(cons _path-name char-width) char-width]
[#f #f]))
racket-mode-size-hook)
-(define (make-pretty-print-print-hook)
+;; Only called if size-hook returned an integer size.
+(define (make-pp-print-hook)
(define orig (pretty-print-print-hook))
(define (racket-mode-print-hook value display? port)
(match (hash-ref ht value #f)
[(cons path-name _char-width)
(hash-remove! ht value)
- ((if display? display print) path-name port)]
- [#f (orig value display? port)]))
+ (write-special (cons 'image path-name))]
+ [_ ;shouldn't happen, but...
+ (orig value display? port)]))
racket-mode-print-hook)
diff --git a/racket/repl-output.rkt b/racket/repl-output.rkt
new file mode 100644
index 0000000000..a55e6a013a
--- /dev/null
+++ b/racket/repl-output.rkt
@@ -0,0 +1,106 @@
+;; Copyright (c) 2023 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+#lang racket/base
+
+(require racket/async-channel
+ "repl-session.rkt")
+
+(provide repl-output-channel
+ repl-output-error
+ repl-output-message
+ repl-output-run
+ repl-output-prompt
+ repl-output-exit
+ repl-output-value
+ repl-output-value-special
+ make-repl-output-port
+ make-repl-error-port
+ repl-error-port?)
+
+;;; REPL output
+
+;; Traditionally a REPL's output is a hopeless mix of things dumped
+;; into stdout and stderr. This forces a client to use unreliable
+;; regexps in an attempt to recover the original pieces.
+;;
+;; Instead we want structured output -- distinctly separated:
+;; - current-output-port
+;; - current-error-port
+;; - current-print values
+;; - strings
+;; - image files
+;; - prompts
+;; - structured errors from error-display-handler
+;; - various messages from the back end
+
+;; A channel from which the command-server can sync.
+(define repl-output-channel (make-async-channel))
+
+(define (repl-output kind value)
+ (async-channel-put repl-output-channel
+ (list 'repl-output (current-session-id) kind value)))
+
+;; Various wrappers around repl-output:
+
+;; To be called from the error-display-handler. Instead of raw text,
+;; `v` may be any structured data that elisp-write can handle. As long
+;; as the front end understands the structure, here we don't care.
+(define (repl-output-error v)
+ (repl-output 'error v))
+
+;; Replacement for the old `display-commented`: Miscellaneous messages
+;; from this back end, as opposed to from Racket or from the user
+;; program.
+(define (repl-output-message v)
+ (repl-output 'message v))
+
+;; To be called from get-interaction, i.e. "display-prompt".
+(define (repl-output-prompt v)
+ (repl-output 'prompt v))
+
+(define (repl-output-run v)
+ (repl-output 'run v))
+
+(define (repl-output-exit)
+ (repl-output 'exit "REPL session ended"))
+
+;; For current-print
+(define (repl-output-value v)
+ (repl-output 'value v))
+
+(define (repl-output-value-special v)
+ (repl-output 'value-special v))
+
+;; Output port wrappers around repl-output:
+
+;; Tuck the port in a struct just for a simple, reliable
+;; repl-error-port? predicate.
+(struct repl-error-port (p)
+ #:property prop:output-port 0)
+(define (make-repl-error-port)
+ (repl-error-port (make-repl-port 'stderr)))
+
+;; And do same for this, just for conistency.
+(struct repl-output-port (p)
+ #:property prop:output-port 0)
+(define (make-repl-output-port)
+ (repl-output-port (make-repl-port 'stdout)))
+
+(define (make-repl-port kind)
+ (define name (format "racket-mode-repl-~a" kind))
+ (define special-kind (string->symbol (format "~a-special" kind)))
+ (define (write-out bstr start end non-block? breakable?)
+ (async-channel-put repl-output-channel
+ (repl-output kind (subbytes bstr start end)))
+ (- end start))
+ (define (write-out-special v _non-block? _breakable?)
+ (async-channel-put repl-output-channel
+ (repl-output special-kind v))
+ #t)
+ (define close void)
+ (make-output-port name
+ repl-output-channel
+ write-out
+ close
+ write-out-special))
diff --git a/racket/repl-session.rkt b/racket/repl-session.rkt
index 39cac5da62..245466d6de 100644
--- a/racket/repl-session.rkt
+++ b/racket/repl-session.rkt
@@ -7,12 +7,11 @@
racket/match
"util.rkt")
-(provide next-session-id!
- call-with-session-context
+(provide call-with-session-context
current-session-id
current-repl-msg-chan
+ current-submissions
current-session-maybe-mod
- current-session-submit-pred
(struct-out session)
get-session
set-session!
@@ -20,36 +19,27 @@
;;; REPL session "housekeeping"
-;; Session IDs are strings based on time + monotonic number
-(define next-session-id!
- (let ([n 0])
- (λ ()
- (format "repl-session-~a-~a"
- (current-inexact-milliseconds)
- (begin0 n
- (inc! n))))))
-
;; Each REPL session has an entry in this hash-table.
-(define sessions (make-hash)) ;string? => session?
+(define sessions (make-hasheq)) ;number? => session?
(struct session
(thread ;thread? the repl manager thread
repl-msg-chan ;channel?
+ submissions ;channel?
maybe-mod ;(or/c #f module-path?)
- namespace ;namespace?
- submit-pred) ;(or/c #f drracket:submit-predicate/c)
+ namespace)
#:transparent)
(define (get-session sid)
(hash-ref sessions sid #f))
-(define (set-session! sid maybe-mod repl-submit-predicate)
+(define (set-session! sid maybe-mod)
(hash-set! sessions sid (session (current-thread)
(current-repl-msg-chan)
+ (current-submissions)
maybe-mod
- (current-namespace)
- repl-submit-predicate))
- (log-racket-mode-debug @~a{(set-session! @~v[sid] @~v[maybe-mod]
@~v[repl-submit-predicate]) => sessions: @~v[sessions]}))
+ (current-namespace)))
+ (log-racket-mode-debug @~a{(set-session! @~v[sid] @~v[maybe-mod]) =>
sessions: @~v[sessions]}))
(define (remove-session! sid)
(hash-remove! sessions sid)
@@ -57,22 +47,22 @@
(define current-session-id (make-parameter #f))
(define current-repl-msg-chan (make-parameter #f))
+(define current-submissions (make-parameter #f))
(define current-session-maybe-mod (make-parameter #f))
-(define current-session-submit-pred (make-parameter #f))
;; A way to parameterize e.g. commands that need to work with a
;; specific REPL session. Called from e.g. a command-server thread.
(define (call-with-session-context sid proc . args)
(match (get-session sid)
[(? session? s)
- (log-racket-mode-debug @~a{@car[args]: using session ID @~v[sid]})
+ (log-racket-mode-debug @~a{@~v[@car[args]]: using session ID @~v[sid]})
(parameterize ([current-session-id sid]
[current-repl-msg-chan (session-repl-msg-chan s)]
+ [current-submissions (session-submissions s)]
[current-session-maybe-mod (session-maybe-mod s)]
- [current-namespace (session-namespace s)]
- [current-session-submit-pred (session-submit-pred s)])
+ [current-namespace (session-namespace s)])
(apply proc args))]
[_
(unless (equal? sid '())
- (log-racket-mode-warning @~a{@car[args]: session ID @~v[sid] not
found}))
+ (log-racket-mode-warning @~a{@~v[@car[args]]: session ID @~v[sid] not
found}))
(apply proc args)]))
diff --git a/racket/repl.rkt b/racket/repl.rkt
index 39dac5260a..abae84e343 100644
--- a/racket/repl.rkt
+++ b/racket/repl.rkt
@@ -10,24 +10,25 @@
(only-in racket/path path-only file-name-from-path)
racket/set
(only-in racket/string string-join)
- racket/tcp
(only-in "debug.rkt" make-debug-eval-handler next-break)
"elisp.rkt"
"error.rkt"
"gui.rkt"
+ "interaction.rkt"
"instrument.rkt"
- "interactions.rkt"
"print.rkt"
+ "repl-output.rkt"
"repl-session.rkt"
"stack-checkpoint.rkt"
(only-in "syntax.rkt" make-caching-load/use-compiled-handler)
"util.rkt")
-(provide start-repl-session-server
- repl-tcp-port-number
+(provide repl-start
+ repl-exit
run
repl-break
- repl-zero-column
+ repl-submit
+ repl-input
maybe-module-path->file)
;;; Messages to each repl manager thread
@@ -80,19 +81,37 @@
ready-thunk))
;; Command. Called from a command-server thread
-(struct break (kind))
-(define/contract (repl-break kind)
- (-> (or/c 'break 'hang-up 'terminate) any)
+(define (repl-start sid)
+ (when (get-session sid)
+ (error 'repl-start "session already exists with id ~a" sid))
+ (define ready-ch (make-channel))
+ (thread (repl-manager-thread-thunk sid ready-ch))
+ (sync ready-ch))
+
+(define (repl-exit)
+ (unless (current-repl-msg-chan)
+ (error 'repl-exit "No REPL session to exit"))
+ (channel-put (current-repl-msg-chan) 'exit))
+
+;; Command. Called from a command-server thread
+(define (repl-break)
(unless (current-repl-msg-chan)
(error 'repl-break "No REPL session to break"))
- (channel-put (current-repl-msg-chan) (break kind)))
+ (channel-put (current-repl-msg-chan) 'break))
;; Command. Called from a command-server thread
-(struct zero-column (chan))
-(define (repl-zero-column)
- (define ch (make-channel))
- (channel-put (current-repl-msg-chan) (zero-column ch))
- (sync ch))
+(define/contract (repl-submit str)
+ (-> string? any)
+ (unless (current-submissions)
+ (error 'repl-submit "No REPL session for submit"))
+ (channel-put (current-submissions) str))
+
+;; Command. Called from a command-server thread
+(define/contract (repl-input str)
+ (-> string? any)
+ (unless (current-repl-msg-chan)
+ (error 'repl-input "No REPL session for input"))
+ (channel-put (current-repl-msg-chan) `(input ,(string->bytes/utf-8 str))))
;; Command. Called from a command-server thread
(define/contract (run what subs mem pp cols pix/char ctx args dbgs)
@@ -142,77 +161,22 @@
[(list* 'submod p xs) (string-join (cons (name p) (map ~a xs)) "/")]
[#f ""]))
-;;; REPL session server
-
-(define repl-tcp-port-number #f)
-
-(define (start-repl-session-server launch-token accept-host tcp-port)
- (define listener
- (tcp-listen tcp-port ;0 == choose port dynamically, a.k.a. "ephemeral" port
- 64
- (not (zero? tcp-port)) ;reuse not good for ephemeral ports
- accept-host))
- (set! repl-tcp-port-number
- (let-values ([(_loc-addr port _rem-addr _rem-port) (tcp-addresses
listener #t)])
- port))
- (log-racket-mode-info "Accepting TCP connections from host ~v on port ~v"
- accept-host
- repl-tcp-port-number)
- (thread (listener-thread-thunk launch-token listener)))
-
-(define ((listener-thread-thunk launch-token listener))
- (let accept-a-connection ()
- (define custodian (make-custodian))
- (parameterize ([current-custodian custodian])
- ;; `exit` in a REPL should terminate that REPL session -- not
- ;; the entire back end server. Also, this is opportunity to
- ;; remove the session from `sessions` hash table.
- (define (our-exit-handler code)
- (log-racket-mode-info "(our-exit-handler ~v) ~v"
- code (current-session-id))
- (when (current-session-id) ;might exit before session created
- (remove-session! (current-session-id)))
- (custodian-shutdown-all custodian))
- (parameterize ([exit-handler our-exit-handler])
- (define-values (in out) (tcp-accept listener))
- (parameterize ([current-input-port in]
- [current-output-port out]
- [current-error-port out])
- (file-stream-buffer-mode in (if (eq? (system-type) 'windows)
- 'none
- 'block)) ;#582
- (file-stream-buffer-mode out 'none)
- ;; Immediately after connecting, the client must send us
- ;; exactly the same launch token value that it gave us as a
- ;; command line argument when it started us. Else we close
- ;; the connection. See issue #327.
- (define supplied-token (elisp-read in))
- (unless (equal? launch-token supplied-token)
- (log-racket-mode-fatal "Authorization failed: ~v"
- supplied-token)
- (exit 'racket-mode-repl-auth-failure))
- (port-count-lines! in) ;but for #519 #556 see interactions.rkt
- (port-count-lines! out) ;for fresh-line
- (thread repl-manager-thread-thunk))))
- (accept-a-connection)))
-
-(define (repl-manager-thread-thunk)
- (define session-id (next-session-id!))
- (log-racket-mode-info "start ~v" session-id)
- (parameterize* ([error-display-handler racket-mode-error-display-handler]
- [current-session-id session-id]
- [current-repl-msg-chan (make-channel)])
+;;; REPL sessions
+
+(define ((repl-manager-thread-thunk session-id ready-ch))
+ (log-racket-mode-info "starting repl session ~v" session-id)
+ ;; Make pipe for user program input (as distinct form repl-submit
+ ;; input).
+ (parameterize* ([current-session-id session-id]
+ [current-repl-msg-chan (make-channel)]
+ [current-submissions (make-channel)]
+ [error-display-handler racket-mode-error-display-handler])
+ (set-session! session-id #f)
(do-run
(initial-run-config
(λ ()
- ;; Write a sexpr containing the session-id, which the client
- ;; can use in certain commands that need to run in the context
- ;; of a specific REPL. We wait to do so until this ready-thunk
- ;; to ensure the `sessions` hash table has this session before
- ;; any subsequent commands use call-with-session-context.
- (elisp-writeln `(ok ,session-id))
- (flush-output)
- (display-commented (string-append "\n" (banner))))))))
+ (channel-put ready-ch #t)
+ (repl-output-message (banner)))))))
(define (do-run cfg) ;run-config? -> void?
(match-define (run-config maybe-mod
@@ -225,30 +189,41 @@
cmd-line-args
debug-files
ready-thunk) cfg)
+ (repl-output-run (maybe-module-path->prompt-string maybe-mod))
(define file (maybe-module-path->file maybe-mod))
(define dir (path-only file))
;; Set current-directory -- but not current-load-relative-directory,
;; see #492 -- to the source file's directory.
(current-directory dir)
- ;; Make srcloc->string provide full pathnames
- (prevent-path-elision-by-srcloc->string)
;; Custodian for the REPL.
(define repl-cust (make-custodian))
(when (< 0 mem-limit)
(custodian-limit-memory repl-cust
(inexact->exact (round (* 1024 1024 mem-limit)))
repl-cust))
+ (define (our-exit [_v #f])
+ (repl-output-exit)
+ (custodian-shutdown-all repl-cust)
+ (remove-session! (current-session-id)))
+ (exit-handler our-exit)
+
+ ;; Input for user program (as distinct from REPL submissions, for
+ ;; which see current-submissions and get-interaction).
+ (define-values (user-pipe-in user-pipe-out) (make-pipe #f 'repl))
;; repl-thunk loads the user program and enters read-eval-print-loop
(define (repl-thunk)
;; Command line arguments
(current-command-line-arguments cmd-line-args)
- ;; Set print hooks and output handlers
- (set-print-parameters pretty-print? columns pixels/char)
+ ;; Set ports, current-print handler, and output handlers
+ (current-input-port user-pipe-in)
+ (current-output-port (make-repl-output-port))
+ (current-error-port (make-repl-error-port))
+ (current-print (make-racket-mode-print-handler pretty-print? columns
pixels/char))
(set-output-handlers)
;; Record as much info about our session as we can, before
;; possibly entering module->namespace.
- (set-session! (current-session-id) maybe-mod #f)
+ (set-session! (current-session-id) maybe-mod)
;; Set our initial value for current-namespace. When no module,
;; this will be the ns used in the REPL. Otherwise this is simply
;; the intial ns used for module->namespace, below, which returns
@@ -281,17 +256,11 @@
(configure/require/enter maybe-mod extra-submods-to-run dir)
(check-#%top-interaction))))
;; Update information about our session -- now that
- ;; current-namespace is possibly updated, and, it is OK to call
- ;; get-repl-submit-predicate.
- (set-session! (current-session-id)
- maybe-mod
- (get-repl-submit-predicate maybe-mod))
+ ;; current-namespace is possibly updated.
+ (set-session! (current-session-id) maybe-mod)
;; Now that user's program has run, and `sessions` is updated,
- ;; call the ready-thunk. On REPL session startup this lets us
- ;; postpone sending the repl-session-id until `sessions` is
- ;; updated. And for subsequent run commands, this lets us it wait
- ;; to send a response, which is useful for commands that want to
- ;; run after a run command has finished.
+ ;; call the ready-thunk: useful for commands that want to run
+ ;; after a run command has finished.
(ready-thunk)
;; And finally, enter read-eval-print-loop.
(parameterize ([current-prompt-read (make-prompt-read maybe-mod)])
@@ -318,18 +287,22 @@
[(profile) (clear-profile-info!)]
[(coverage) (clear-test-coverage-info!)])
(custodian-shutdown-all repl-cust)
- (fresh-line)
(do-run c)]
- [(zero-column ch) (zero-column!)
- (channel-put ch 'done)]
- [(break kind) (break-thread repl-thread (if (eq? kind 'break) #f
kind))]
- [v (log-racket-mode-warning "ignoring unknown repl-msg-chan message: ~v"
v)])
- (get-message)))
-
-(define ((make-prompt-read m))
- (begin0 (get-interaction (maybe-module-path->prompt-string m))
- ;; let debug-instrumented code break again
- (next-break 'all)))
+ ['break (break-thread repl-thread #f)
+ (get-message)]
+ [`(input ,bstr) (write-bytes bstr user-pipe-out)
+ (get-message)]
+ ['exit (our-exit)]
+ [v (log-racket-mode-warning "ignoring unknown repl-msg-chan message: ~v"
v)
+ (get-message)])))
+
+(define (make-prompt-read maybe-mod)
+ (define (racket-mode-prompt-read)
+ (define prompt (maybe-module-path->prompt-string maybe-mod))
+ (define stx (get-interaction prompt))
+ (next-break 'all) ;let debug-instrumented code break again
+ stx)
+ racket-mode-prompt-read)
;; Change one of our non-false maybe-mod values (for which we use path
;; objects, not path-strings) into a module-path applied to
@@ -379,30 +352,10 @@
(raise-argument-error 'runtime-configure "(listof (vector any any
any))" infos))
(for-each info-load infos)))))
-;;
<https://docs.racket-lang.org/tools/lang-languages-customization.html#(part._.R.E.P.L_.Submit_.Predicate)>
-(define drracket:submit-predicate/c (-> input-port? boolean? boolean?))
-(define/contract (get-repl-submit-predicate m)
- (-> (or/c #f module-path?) (or/c #f drracket:submit-predicate/c))
- (and m
- (or (with-handlers ([exn:fail? (λ _ #f)])
- (match (with-input-from-file (maybe-module-path->file m)
- read-language)
- [(? procedure? get-info)
- (match (get-info 'drracket:submit-predicate #f)
- [#f #f]
- [v v])]
- [_ #f]))
- (with-handlers ([exn:fail? (λ _ #f)])
- (match (module->language-info m #t)
- [(vector mp name val)
- (define get-info ((dynamic-require mp name) val))
- (get-info 'drracket:submit-predicate #f)]
- [_ #f])))))
-
(define (check-#%top-interaction)
;; Check that the lang defines #%top-interaction
(unless (memq '#%top-interaction (namespace-mapped-symbols))
- (display-commented
+ (repl-output-message
"Because the language used by this module provides no #%top-interaction\n
you will be unable to evaluate expressions here in the REPL.")))
;;; Output handlers; see issues #381 #397
diff --git a/racket/text-lines.rkt b/racket/text-lines.rkt
new file mode 100644
index 0000000000..95a05eeed0
--- /dev/null
+++ b/racket/text-lines.rkt
@@ -0,0 +1,689 @@
+;; Copyright (c) 2021-2023 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+#lang racket/base
+
+;; Provenance:
+;;
+;;
https://gist.githubusercontent.com/mflatt/6ab71f8214c5fd98dae98c8531056fa2/raw/b407e8ff41d37b5a992fc7a516d6dae0459b694a/text-lines.rkt
+;;
+;; https://github.com/racket/expeditor/issues/10#issuecomment-974146291.
+
+(provide text-lines?
+ (rename-out [empty empty-text-lines])
+
+ ;; 0 is the position before everything, and the position
+ ;; after a newline is on the subsequent line
+
+ text-length ; t -> position at end
+ insert ; t position str -> t, detecting "\n"
+ delete ; t start-position end-position -> t
+ get-text ; t start-position end-position -> string
+ open-input-text ; t start-position -> input-port
+
+ position->start ; t position -> position of line start
+ position->line ; t position -> line number
+ line->start ; t line number -> position
+
+ text-line-count) ; t -> one more than line number at end
+
+;; ----------------------------------------
+
+(define (insert t pos str)
+ (check-in-range 'insert t pos)
+ (let loop ([t t] [i 0] [pos pos] [accum 0])
+ (cond
+ [(= i (string-length str))
+ (if (zero? accum)
+ t
+ (adjust-within-line t pos (substring str (- i accum) i)))]
+ [(char=? #\newline (string-ref str i))
+ (define len (add1 accum))
+ (loop (insert-newline t pos (substring str (- i accum) i))
+ (add1 i)
+ (+ pos len)
+ 0)]
+ [else (loop t (add1 i) pos (add1 accum))])))
+
+(define (delete t pos end)
+ (check-in-range 'delete t pos)
+ (check-in-range 'delete t end)
+ (let delete ([t t] [pos pos] [end end])
+ (cond
+ [(= pos end) t]
+ [else
+ (define-values (left-len left-count sub-t) (find-line t pos))
+ (define line-start (+ left-len (node-left-len sub-t)))
+ (define line-len (node-len sub-t))
+ (define line-end (+ line-start line-len))
+ (cond
+ [(end . < . line-end)
+ (adjust-within-line t pos (- pos end))]
+ [(= pos line-start)
+ (define new-t (delete-line t line-start))
+ (delete new-t line-start (- end line-len))]
+ [else
+ (define keep (substring (node-content sub-t) 0 (- pos line-start)))
+ (define new-t (delete t line-start end))
+ (insert new-t line-start keep)])])))
+
+(define (get-text t pos [end (text-length t)])
+ (check-in-range 'get-text t pos)
+ (check-in-range 'get-text t end)
+ (define str
+ (let loop ([pos pos] [end end])
+ (define-values (left-len left-count sub-t) (find-line t pos))
+ (define line-start (+ left-len (node-left-len sub-t)))
+ (define line-len (node-len sub-t))
+ (define line-end (+ line-start line-len))
+ (cond
+ [(<= end line-end)
+ (define rel-pos (- pos line-start))
+ (cond
+ [(= end line-end)
+ (string-append (substring (node-content sub-t) rel-pos) "\n")]
+ [else
+ (define rel-end (- end line-start))
+ (substring (node-content sub-t) rel-pos rel-end)])]
+ [else
+ (define pre-str (loop pos line-end))
+ (define post-strs (loop line-end end))
+ (cons pre-str
+ (if (pair? post-strs)
+ post-strs
+ (list post-strs)))])))
+ (if (string? str)
+ str
+ (apply string-append str)))
+
+;; ----------------------------------------
+
+;; a node represents one text line that ends with a newline
+(struct node (content ; characters in this line, excluding ending newline
+ left-len ; characters in left subtree
+ total-len ; total in both subtrees
+ left-count ; number of lines in left subtree
+ total-count ; total number of lines
+ height ; head of tree (for balancing)
+ left ; left subtree
+ right) ; right subtree
+ #:transparent
+ #:authentic
+ #:reflection-name 'lines-of-text)
+
+(define (text-lines? v) (node? v))
+
+(define (node-len n)
+ (content-len (node-content n)))
+
+(define (content-len content)
+ (add1 (string-length content)))
+
+(define (text-length n)
+ (sub1 (node-total-len n)))
+
+(define (text-line-count n)
+ (node-total-count n))
+
+;; represent an editor with a sentinel newline, but hide
+;; its existence to the outside
+(define empty (node "" 0 1 0 1 0 #f #f))
+
+(define (check-in-range* who t pos limit what)
+ (unless (node? t)
+ (raise-argument-error who "text-lines?" t))
+ (unless (exact-nonnegative-integer? pos)
+ (raise-argument-error who "exact-nonnegative-integer?" pos))
+ (unless (pos . < . limit)
+ (raise-arguments-error who
+ (format "~a is out of bounds" what)
+ what pos
+ "upper limit" (sub1 limit))))
+
+(define (check-in-range who t pos)
+ (check-in-range* who t pos (node-total-len t) "position"))
+
+(define (check-in-range-line who t line)
+ (check-in-range* who t line (add1 (node-total-count t)) "line"))
+
+;; ----------------------------------------
+
+(define (tree-height t)
+ (cond
+ [(not t) 0]
+ [else (node-height t)]))
+
+(define (tree-total-len t)
+ (cond
+ [(not t) 0]
+ [else (node-total-len t)]))
+
+(define (tree-total-count t)
+ (cond
+ [(not t) 0]
+ [else (node-total-count t)]))
+
+;; ----------------------------------------
+
+(define (combine content left right)
+ (node content
+ (tree-total-len left)
+ (+ (content-len content) (tree-total-len left) (tree-total-len right))
+ (tree-total-count left)
+ (+ 1 (tree-total-count left) (tree-total-count right))
+ (+ 1 (max (tree-height left) (tree-height right)))
+ left
+ right))
+
+(define (reverse-combine content right left)
+ (combine content left right))
+
+;; ----------------------------------------
+
+(define (position->start t pos)
+ (check-in-range 'position->start t pos)
+ (define-values (left-len left-count sub-t) (find-line t pos))
+ (+ left-len (node-left-len sub-t)))
+
+;; ----------------------------------------
+
+(define (position->line t pos)
+ (check-in-range 'position->line t pos)
+ (define-values (left-len left-count sub-t) (find-line t pos))
+ (+ left-count (node-left-count sub-t)))
+
+;; ----------------------------------------
+
+(define (find-line t pos)
+ (cond
+ [(< pos (node-left-len t))
+ (find-line (node-left t) pos)]
+ [else
+ (define right-left-len (+ (node-len t) (node-left-len t)))
+ (define new-pos (- pos right-left-len))
+ (cond
+ [(new-pos . < . 0) (values 0 0 t)]
+ [else
+ (define right-left-count (+ 1 (node-left-count t)))
+ (define-values (left-len left-count sub-t) (find-line (node-right t)
new-pos))
+ (values (+ left-len right-left-len)
+ (+ left-count right-left-count)
+ sub-t)])]))
+
+;; ----------------------------------------
+
+(define (line->start t line)
+ (check-in-range-line 'line->start t line)
+ (find-start t line))
+
+(define (find-start t line)
+ (define here (node-left-count t))
+ (cond
+ [(line . < . here)
+ (find-start (node-left t) line)]
+ [(line . > . here)
+ (define pre (+ (node-left-len t) (node-len t)))
+ (+ (find-start (node-right t) (- line here 1))
+ pre)]
+ [else
+ (node-left-len t)]))
+
+;; ----------------------------------------
+
+(define (adjust-within-line t pos amt) ; amt is string or negative number
+ (check-in-range 'adjust-within-line t pos)
+ (unless (or (string? amt)
+ (and (exact-integer? amt) (negative? amt)))
+ (raise-argument-error 'adjust-within-line "(or string? (and/c
exact-integer? negative?))" amt))
+ (when (exact-integer? amt)
+ (define-values (left-len left-count line-t) (find-line t pos))
+ (when ((+ left-len (node-left-len line-t) (node-len line-t))
+ . <= .
+ (+ pos amt))
+ (raise-arguments-error 'adjust-within-line
+ "subtracting too much"
+ "amount" amt)))
+ (adjust t pos amt))
+
+(define (adjust t pos amt)
+ (define rel-pos (- pos (node-left-len t)))
+ (cond
+ [(rel-pos . < . 0)
+ (combine (node-content t)
+ (adjust (node-left t) pos amt)
+ (node-right t))]
+ [(rel-pos . >= . (node-len t))
+ (define new-pos (- rel-pos (node-len t)))
+ (combine (node-content t)
+ (node-left t)
+ (adjust (node-right t) new-pos amt))]
+ [else
+ (combine (cond
+ [(string? amt) (string-append (substring (node-content t) 0
rel-pos)
+ amt
+ (substring (node-content t)
rel-pos))]
+ [else (string-append (substring (node-content t) 0 rel-pos)
+ (substring (node-content t) (- rel-pos
amt)))])
+ (node-left t)
+ (node-right t))]))
+
+;; ----------------------------------------
+
+;; inserts `len` characters that end with a newline
+(define (insert-newline t pos content)
+ (check-in-range 'insert-newline t pos)
+ (unless (string? content)
+ (raise-argument-error 'insert-newline "string?" content))
+ (define-values (left-len left-count sub-t) (find-line t pos))
+ (define start (+ left-len (node-left-len sub-t)))
+ (define delta (- pos start))
+ (cond
+ [(zero? delta)
+ ;; insert new line before existing one
+ (insert-line t pos content)]
+ [else
+ ;; split node by first shrinking, then insert
+ (define pre (substring (node-content sub-t) 0 delta))
+ (insert-line (adjust-within-line t start (- delta))
+ start
+ (string-append pre content))]))
+
+;; ----------------------------------------
+
+(define (delete-line t pos)
+ (check-in-range 'delete-line t pos)
+ ;; sanity check:
+ (define start (position->start t pos))
+ (unless (= start pos)
+ (error 'delete-line "line does not start at position"))
+ (delete-node t pos))
+
+;; ----------------------------------------
+
+(define (insert-line t pos str)
+ (cond
+ [(not t) (combine str #f #f)]
+ [(<= pos (node-left-len t))
+ (insert-to t pos str
+ node-left
+ node-right
+ combine
+ rotate-right)]
+ [else
+ (define right-left-len (+ (node-len t) (node-left-len t)))
+ (when (pos . < . right-left-len)
+ (error "insert-line cannot insert into the middle"))
+ (insert-to t (- pos right-left-len) str
+ node-right
+ node-left
+ reverse-combine
+ rotate-left)]))
+
+;; Like insert, but inserts to a child, where `node-to'
+;; determines the side where the child is added,`node-other'
+;; is the other side, and `comb' builds the new tree gven the
+;; two new children.
+(define-syntax-rule (insert-to t new-pos new-content node-to node-other comb
rotate)
+ (begin
+ ;; Insert into the `node-to' child:
+ (define new-to (insert-line (node-to t) new-pos new-content))
+ (define new-other (node-other t))
+
+ (define new-t (comb (node-content t) new-to new-other))
+
+ ;; Check for rotation:
+ (define to-height (tree-height new-to))
+ (define other-height (tree-height new-other))
+ (if ((- to-height other-height) . = . 2)
+ (rotate new-t)
+ new-t)))
+
+(define (delete-node t pos)
+ (define key (node-left-len t))
+ (cond
+ [(pos . < . key)
+ (delete-from t pos
+ node-left
+ node-right
+ combine
+ rotate-left)]
+ [(not (= pos key))
+ (delete-from t (- pos key (node-len t))
+ node-right
+ node-left
+ reverse-combine
+ rotate-right)]
+ [else
+ (define l (node-left t))
+ (define r (node-right t))
+ (cond
+ [(not l) r]
+ [(not r) l]
+ [else
+ (delete-here t)])]))
+
+(define-syntax-rule (delete-from t pos node-to node-other comb rotate)
+ (begin
+ ;; Delete from the `node-to' child:
+ (define new-to (delete-node (node-to t) pos))
+ (define new-other (node-other t))
+
+ (define new-t (comb (node-content t) new-to new-other))
+
+ ;; Check for rotation:
+ (define to-height (tree-height new-to))
+ (define other-height (tree-height new-other))
+ (if ((- to-height other-height) . = . -2)
+ (rotate new-t)
+ new-t)))
+
+(define-syntax-rule (delete-here t)
+ (begin
+ ;; Delete by moving from `from` to `other`
+ (define from (node-left t))
+ (define new-t
+ (let loop ([end from] [left-len 0])
+ (cond
+ [(node-right end)
+ => (lambda (e) (loop e (+ left-len (node-left-len end) (node-len
end))))]
+ [else
+ (define pos (node-left-len end))
+ (define new-from (delete-node from (+ pos left-len)))
+ (combine (node-content end) new-from (node-right t))])))
+
+ ;; Check for rotation:
+ (define from-height (tree-height (node-left new-t)))
+ (define other-height (tree-height (node-right new-t)))
+ (if ((- from-height other-height) . = . -2)
+ (rotate-left new-t)
+ new-t)))
+
+(define-syntax-rule (define-rotate rotate node-to node-other comb)
+ (begin
+ ;; Helper rotate function:
+ (define (rotate t)
+ (define to (node-to t))
+ (define to-balance (- (tree-height (node-to to))
+ (tree-height (node-other to))))
+ (cond
+ [(to-balance . < . 0)
+ (double-rotate t)]
+ [else
+ (single-rotate t)]))
+
+ ;; Helper double-rotate function:
+ (define (double-rotate t)
+ (define orange (node-to t))
+ (define yellow (node-other orange))
+ (define A (node-to orange))
+ (define B (node-to yellow))
+ (define C (node-other yellow))
+ (define D (node-other t))
+ (single-rotate (comb (node-content t)
+ (comb (node-content yellow)
+ (comb (node-content orange)
+ A
+ B)
+ C)
+ D)))
+
+ ;; Helper single-rotate function:
+ (define (single-rotate t)
+ (define yellow (node-to t))
+ (comb (node-content yellow)
+ (node-to yellow)
+ (comb (node-content t)
+ (node-other yellow)
+ (node-other t))))))
+
+(define-rotate rotate-right node-left node-right combine)
+(define-rotate rotate-left node-right node-left reverse-combine)
+
+;; ----------------------------------------
+
+(module+ main
+ (define (do-check av bv form)
+ (unless (equal? av bv)
+ (error 'fail "~s: ~v vs. ~v" form av bv)))
+ (define-syntax-rule (check a b)
+ (do-check a b '(check a b)))
+ (define (at desc) (printf "~a\n" desc))
+
+ (at "empty")
+ (check (position->start empty 0) 0)
+ (check (position->line empty 0) 0)
+ (check (text-length empty) 0)
+ (check (text-line-count empty) 1)
+
+ (at "insert within only line")
+ (let* ([t (adjust-within-line empty 0 "xxx")])
+ (check (get-text t 0 3) "xxx")
+ (check (text-length t) 3)
+ (check (text-line-count t) 1)
+ (check (position->start t 0) 0)
+ (check (position->line t 0) 0)
+ (check (line->start t 0) 0)
+ (check (position->start t 2) 0)
+ (check (position->line t 2) 0)
+ (check (position->start t 3) 0)
+ (check (position->line t 3) 0))
+
+ (at "insert line 1")
+ (let* ([t (insert-newline empty 0 "")])
+ ;; "|", where "|" means newline
+ (check (get-text t 0 1) "\n")
+ (check (text-length t) 1)
+ (check (text-line-count t) 2)
+ (check (position->start t 0) 0)
+ (check (position->line t 0) 0)
+ (check (position->start t 1) 1)
+ (check (position->line t 1) 1)
+ (at "insert 3 within line 0")
+ (let* ([t (adjust-within-line t 0 "xxx")])
+ ;; "xxx|"
+ (check (get-text t 0 4) "xxx\n")
+ (check (position->start t 0) 0)
+ (check (position->line t 0) 0)
+ (check (position->start t 1) 0)
+ (check (position->start t 3) 0)
+ (check (position->line t 3) 0)
+ (check (position->start t 4) 4)
+ (check (position->line t 4) 1)
+ (at "insert 1 within line 1")
+ (let* ([t (adjust-within-line t 4 "x")])
+ ;; "xxx|x"
+ (check (get-text t 0 5) "xxx\nx")
+ (check (position->start t 4) 4)
+ (check (position->line t 4) 1)
+ (check (position->start t 5) 4)
+ (check (position->line t 5) 1)
+ (at "delete 1 within line 0")
+ (let* ([t (adjust-within-line t 1 -1)])
+ ;; "xx|x"
+ (check (get-text t 0 4) "xx\nx")
+ (check (position->start t 0) 0)
+ (check (position->line t 0) 0)
+ (check (position->start t 1) 0)
+ (check (position->start t 2) 0)
+ (check (position->line t 2) 0)
+ (check (position->start t 3) 3)
+ (check (position->line t 3) 1)
+ (check (position->start t 4) 3)
+ (check (position->line t 4) 1)
+ (at "insert before line 1")
+ (let* ([t (insert-newline t 3 "yyyy")])
+ ;; "xx|yyyy|x"
+ (check (get-text t 0 9) "xx\nyyyy\nx")
+ (check (position->start t 0) 0)
+ (check (position->line t 0) 0)
+ (check (position->start t 2) 0)
+ (check (position->line t 2) 0)
+ (check (position->start t 3) 3)
+ (check (position->line t 3) 1)
+ (check (position->start t 7) 3)
+ (check (position->line t 7) 1)
+ (check (position->start t 8) 8)
+ (check (position->line t 8) 2)
+ (check (position->start t 9) 8)
+ (check (position->line t 9) 2)
+ (void))
+ (at "insert newline into line 1")
+ (let* ([t (insert-newline t 1 "yyyy")])
+ ;; "xyyyy|x|x"
+ (check (get-text t 0 9) "xyyyy\nx\nx")
+ (check (position->start t 0) 0)
+ (check (position->line t 0) 0)
+ (check (position->start t 1) 0)
+ (check (position->line t 1) 0)
+ (check (position->start t 6) 6)
+ (check (position->line t 6) 1)
+ (at "delete line 0")
+ (let* ([t (delete-line t 0)])
+ ;; "x|x"
+ (check (position->start t 0) 0)
+ (check (position->line t 0) 0)
+ (check (position->start t 1) 0)
+ (check (position->line t 1) 0)
+ (check (position->start t 2) 2)
+ (check (position->line t 2) 1)
+ (check (position->start t 3) 2)
+ (check (position->line t 3) 1)
+ (void)))))))
+
+ (at "three lines")
+ (let* ([t (insert empty 0 "abc\ndef\nghi")])
+ (check (get-text t 0 11) "abc\ndef\nghi")
+ (check (get-text (insert t 0 "xy") 0 13) "xyabc\ndef\nghi")
+ (check (get-text (insert t 1 "xy") 0 13) "axybc\ndef\nghi")
+ (check (get-text (insert t 4 "xy") 0 13) "abc\nxydef\nghi")
+ (check (get-text (insert t 5 "xy") 0 13) "abc\ndxyef\nghi")
+ (check (get-text (insert t 11 "xy") 0 13) "abc\ndef\nghixy")
+ (check (get-text (insert t 0 "x\ny") 0 14) "x\nyabc\ndef\nghi")
+ (check (get-text (insert t 4 "x\ny") 0 14) "abc\nx\nydef\nghi")
+ (check (get-text (insert t 7 "x\ny") 0 14) "abc\ndefx\ny\nghi")
+ (check (get-text (delete t 0 1) 0 10) "bc\ndef\nghi")
+ (check (get-text (delete t 1 2) 0 10) "ac\ndef\nghi")
+ (check (get-text (delete t 2 3) 0 10) "ab\ndef\nghi")
+ (check (get-text (delete t 3 4) 0 10) "abcdef\nghi")
+ (check (get-text (delete t 4 5) 0 10) "abc\nef\nghi")
+ (check (get-text (delete t 0 4) 0 7) "def\nghi")
+ (check (get-text (delete t 2 5) 0 8) "abef\nghi")
+ (check (get-text (delete t 1 10) 0 2) "ai"))
+
+ (at "random modify")
+ (define (random-modify-test W)
+ (define N 32)
+ (define M 8)
+ (define (make-str W) (make-string (sub1 W) #\-))
+ ;; insert lines of length W in a random order
+ (define t
+ (for/fold ([t empty]) ([i (in-range N)])
+ (insert-newline t (* (random (add1 i)) W) (make-str W))))
+ (define (check-N*W t N str)
+ (define W (add1 (string-length str)))
+ (define content (apply string-append
+ (for/list ([i N])
+ (string-append str "\n"))))
+ (for* ([i (in-range N)]
+ [j (in-range W)])
+ (check (position->line t (+ (* i W) j)) i))
+ (check (get-text t 0 (* N W)) content)
+ (for ([i (in-range (* N W))]
+ [k (in-range 5)])
+ (define j (+ i (random (add1 (- (* N W) i)))))
+ (check (get-text t i j) (substring content i j))))
+ (check-N*W t N (make-str W))
+ ;; try inserting then deleting at each point within the line
+ (for ([k (in-range W)])
+ (define new-str (string-append (substring (make-str W) 0 k)
+ "!"
+ (substring (make-str W) k)))
+ (define t+
+ (for/fold ([t t]) ([i (in-range (sub1 N) -1 -1)])
+ (adjust-within-line t (+ (* i W) k) "!")))
+ (check-N*W t+ N new-str)
+ (define t-
+ (for/fold ([t t+]) ([i (in-range 0 N)])
+ (adjust-within-line t (+ (* i W) k) -1)))
+ (check-N*W t- N (make-str W)))
+ ;; delete a few random lines
+ (define t-
+ (for/fold ([t t]) ([i (in-range (- N M 1) -1 -1)])
+ (delete-line t (* (random (add1 i)) W))))
+ (check-N*W t- M (make-str W)))
+ (for ([i (in-range 100)])
+ (for ([W (in-range 2 6)])
+ (random-modify-test W)))
+
+ (at "random")
+ (define (random-create-test)
+ (define n (add1 (random 4096)))
+ (define str (make-string n))
+ (for ([i (in-range n)])
+ (define ch (random 27))
+ (string-set! str i (if (zero? ch)
+ #\newline
+ (integer->char (+ (sub1 (char->integer #\a))
ch)))))
+ (define t (insert empty 0 str))
+ (check (get-text t 0 n) str)
+ (for ([i 1])
+ (define start (random n))
+ (define len (random (- n start)))
+ (check (get-text (delete t start (+ start len)) 0 (- n len))
+ (string-append (substring str 0 start)
+ (substring str (+ start len))))))
+ (for ([i (in-range 1000)])
+ (random-create-test))
+
+ (void))
+
+;; Provenance: framework/mred/private/snipfile.rkt
+(require (only-in racket/port make-input-port/read-to-peek)
+ (only-in racket/match match))
+(define (open-input-text t [start 0])
+ (unless (text-lines? t)
+ (raise-argument-error 'open-input-text "text-lines?" t))
+ (unless (exact-nonnegative-integer? start)
+ (raise-argument-error 'open-input-text "exact-nonnegative-integer?" start))
+ (define-values (pipe-r pipe-w) (make-pipe))
+ (define in (make-input-port/read-to-peek
+ t
+ ;; read-in
+ (let ([beg start])
+ (λ (s)
+ (match (read-bytes-avail!* s pipe-r)
+ [0
+ (match (min (- (text-length t) beg) 4096)
+ [0
+ (close-output-port pipe-w)
+ eof]
+ [amt
+ (define end (+ beg amt))
+ (write-string (get-text t beg end) pipe-w)
+ (set! beg end)
+ (read-bytes-avail!* s pipe-r)])]
+ [v v])))
+ ;; fast-peek
+ (λ (s skip general-peek)
+ (match (peek-bytes-avail!* s skip #f pipe-r)
+ [0 (general-peek s skip)]
+ [v v]))
+ ;; close
+ void))
+ (port-count-lines! in) ;important for Unicode e.g. λ
+ (set-port-next-location! in 1 0 (add1 start)) ;port pos is 1-based
+ in)
+
+(module+ test
+ (require rackunit
+ racket/port)
+ (define len 240000)
+ (define (random-char _ix) (integer->char (+ 32 (random 26))))
+ (define str (list->string (build-list len random-char)))
+ (define text (insert empty 0 str))
+ (let loop ([pos 0])
+ (check-equal? (substring str pos) (get-text text pos))
+ (check-equal? (substring str pos) (port->string (open-input-text text
pos)))
+ (define next-pos (+ pos 10000))
+ (when (< next-pos len)
+ (loop next-pos))))
diff --git a/racket/util.rkt b/racket/util.rkt
index d9ac05d19e..eb42c517cd 100644
--- a/racket/util.rkt
+++ b/racket/util.rkt
@@ -11,15 +11,11 @@
filename-extension
some-system-path->string))
-(provide fresh-line
- zero-column!
- display-commented
- string->namespace-syntax
+(provide string->namespace-syntax
syntax-or-sexpr->syntax
syntax-or-sexpr->sexpr
nat/c
pos/c
- inc!
memq?
in-syntax
log-racket-mode-debug
@@ -34,22 +30,6 @@
path-replace-extension
some-system-path->string)
-;; Issue a newline unless already in column zero. Assumes
-;; port-count-lines! already applied to current-output-port.
-(define (fresh-line)
- (flush-output)
- (define-values [_line col _pos] (port-next-location (current-output-port)))
- (unless (eq? col 0) (newline)))
-
-(define (zero-column!)
- (define-values [line col pos] (port-next-location (current-output-port)))
- (set-port-next-location! (current-output-port) line 0 (- pos col)))
-
-(define (display-commented str)
- (fresh-line)
- (printf "; ~a\n"
- (regexp-replace* "\n" str "\n; ")))
-
(define (string->namespace-syntax str)
(namespace-syntax-introduce
(read-syntax #f (open-input-string str))))
@@ -67,9 +47,6 @@
(define nat/c exact-nonnegative-integer?)
(define pos/c exact-positive-integer?)
-(define-simple-macro (inc! v:id)
- (set! v (add1 v)))
-
(define (memq? x xs)
(and (memq x xs) #t))
diff --git a/test/example/compilation-mode.rkt
b/test/example/compilation-mode.rkt
deleted file mode 100644
index fbf077a77a..0000000000
--- a/test/example/compilation-mode.rkt
+++ /dev/null
@@ -1,12 +0,0 @@
-#lang racket/base
-
-"[{\"type\":\"NumericLiteral\",\"value\":1},{\"type\":\"NumericLiteral\",\"value\":1},{\"type\":\"NumericLiteral\",\"value\":1}]"
;issue #616
-(displayln
"[{\"type\":\"NumericLiteral\",\"value\":1},{\"type\":\"NumericLiteral\",\"value\":1},{\"type\":\"NumericLiteral\",\"value\":1}]")
-(displayln "/path/to/file.rkt:2:10")
-(displayln " /path/to/file.rkt:2:10")
-(displayln "#<syntax:/path/to/file.rkt:2:10>")
-(displayln " #<syntax:/path/to/file.rkt:2:10>")
-(displayln "...truncated:2:1")
-(displayln " ...truncated:2:1")
-(displayln "#<syntax:....truncated:2:1")
-'done
diff --git a/test/racket-tests.el b/test/racket-tests.el
index d80e1d13b1..08fd33f11e 100644
--- a/test/racket-tests.el
+++ b/test/racket-tests.el
@@ -1,6 +1,6 @@
;;; racket-tests.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; Copyright (c) 2013-2023 by Greg Hendershott.
;; License:
;; This is free software; you can redistribute it and/or modify it
@@ -19,6 +19,7 @@
(require 'faceup)
(require 'paredit)
(require 'racket-mode)
+(require 'racket-hash-lang)
(require 'racket-xp)
(require 'racket-cmd)
(require 'racket-repl)
@@ -116,14 +117,14 @@ supplied to it."
(message "racket-tests/repl")
(racket-tests/with-back-end-settings
(racket-repl)
- (racket-tests/eventually (get-buffer racket-repl-buffer-name))
- (racket-tests/eventually (racket--repl-live-p))
+ (racket-tests/eventually (racket--repl-session-id))
(with-racket-repl-buffer
(should
(racket-tests/see-back-rx
- (rx "; \n"
- "; Welcome to Racket v" (+ (any digit ".")) (? " [" (or "bc" "cs")
"]") ".\n"
- "; \n"
+ (rx "Welcome to Racket v" (+ (any digit ".")) (? " [" (or "bc" "cs")
"]") ".\n"
+ (? "Warning: GUI programs might not work correctly because\n"
+ "your version of Racket lacks `current-get-interaction-evt`,\n"
+ "which was added in Racket 8.4.\n")
"> ")))
;; Completion
@@ -143,14 +144,16 @@ supplied to it."
(racket-tests/type&press "3)" "RET")
(should (racket-tests/see-back "3)\n2\n> "))
- ;; Multiple expressions at one prompt should produce multiple
- ;; values, one per line.
- (racket-tests/type&press "1 2 3" "RET")
- (should (racket-tests/see-back "1\n2\n3\n> "))
- (racket-tests/type&press "(+ 1) (+ 2) (+ 3)" "RET")
- (should (racket-tests/see-back "1\n2\n3\n> "))
- (racket-tests/type&press "\"1\" '2 #(3)" "RET")
- (should (racket-tests/see-back "\"1\"\n2\n'#(3)\n> "))
+ ;;; This behavior no longer expected
+ ;; ;; Multiple expressions at one prompt should produce multiple
+ ;; ;; values, one per line.
+ ;; (racket-tests/type&press "1 2 3" "RET")
+ ;; (should (racket-tests/see-back "1\n2\n3\n> "))
+ ;; (racket-tests/type&press "(+ 1) (+ 2) (+ 3)" "RET")
+ ;; (should (racket-tests/see-back "1\n2\n3\n> "))
+ ;; (racket-tests/type&press "\"1\" '2 #(3)" "RET")
+ ;; (should (racket-tests/see-back "\"1\"\n2\n'#(3)\n> "))
+
;; A trailing space should not cause a hang until another
;; expression is entered.
(racket-tests/type&press "1 " "RET")
@@ -180,13 +183,13 @@ supplied to it."
;; Exit
(racket-tests/type&press "(exit)" "RET")
(should (racket-tests/see-back
- "Process *Racket REPL </>* connection broken by remote peer\n"))
+ "REPL session ended\n"))
(kill-buffer))))
;;; Multi REPLs
(ert-deftest racket-test/unique-repls ()
- "Excercise one unique REPL per racket-mode buffer.
+ "Exercise one unique REPL per racket-mode buffer.
Create file a.rkt with (define a \"a\") -- and so on for b.rkt,
c.rkt. Visit each file, racket-run, and check as expected."
(message "racket-test/unique-repls")
@@ -226,23 +229,32 @@ c.rkt. Visit each file, racket-run, and check as
expected."
(ert-deftest racket-tests/run ()
"Start the REPL via a racket-run command."
(message "racket-tests/run")
- (racket-tests/with-back-end-settings
- (let* ((path (make-temp-file "test" nil ".rkt"))
- (name (file-name-nondirectory path))
- (code "#lang racket/base\n(define foobar 42)\nfoobar\n"))
- (write-region code nil path nil 'no-wrote-file-message)
- (find-file path)
- (racket-run)
- (racket-tests/should-eventually (get-buffer racket-repl-buffer-name))
- (racket-tests/should-eventually (racket--repl-live-p))
- (with-racket-repl-buffer
- (should (racket-tests/see-back (concat "\n" name "> ")))
- (racket-repl-exit)
- (should (racket-tests/see-back
- "Process *Racket REPL </>* connection broken by remote
peer\n"))
- (kill-buffer))
- (kill-buffer)
- (delete-file path))))
+ (dolist (edit-mode (list #'racket-mode #'racket-hash-lang-mode))
+ (racket-tests/with-back-end-settings
+ (let* ((path (make-temp-file "test" nil ".rkt"))
+ (name (file-name-nondirectory path))
+ (code "#lang racket/base\n(define foobar 42)\nfoobar\n"))
+ (write-region code nil path nil 'no-wrote-file-message)
+ (find-file path)
+ (funcall edit-mode)
+ ;; On older Rackets racket-hash-lang-mode may fail gracefully
+ ;; down to prog-mode, but only eventually, after back end
+ ;; responds.
+ (racket-tests/should-eventually
+ (cl-case major-mode
+ ((racket-hash-lang-mode) (not buffer-read-only)) ;keep waiting
+ ((racket-mode prog-mode) t)))
+ (unless (eq major-mode 'prog-mode)
+ (racket-run)
+ (racket-tests/should-eventually (racket--repl-session-id))
+ (with-racket-repl-buffer
+ (should (racket-tests/see-back (concat "\n" name "> ")))
+ (racket-repl-exit)
+ (should (racket-tests/see-back
+ "REPL session ended\n"))
+ (kill-buffer)))
+ (kill-buffer)
+ (delete-file path)))))
;;; Profile
@@ -276,7 +288,7 @@ c.rkt. Visit each file, racket-run, and check as expected."
(with-current-buffer repl-name
(racket-repl-exit)
(should (racket-tests/see-back
- "Process *Racket REPL </>* connection broken by remote
peer\n"))
+ "REPL session ended\n"))
(kill-buffer))
(kill-buffer)
(delete-file path)))))
@@ -317,51 +329,59 @@ c.rkt. Visit each file, racket-run, and check as
expected."
(ert-deftest racket-tests/debugger ()
(message "racket-tests/debugger")
- (racket-tests/with-back-end-settings
- (let* ((path (make-temp-file "test" nil ".rkt"))
- (name (file-name-nondirectory path))
- (code "#lang racket/base\n(define (f x) (+ 1 x))\n(f 41)\n"))
- (write-region code nil path nil 'no-wrote-file-message)
- (find-file path)
- (should (eq major-mode 'racket-mode))
- (racket-run `(16))
- (racket-tests/should-eventually (get-buffer racket-repl-buffer-name))
- (racket-tests/should-eventually (racket--repl-live-p))
- (racket-tests/should-eventually racket-debug-mode)
-
- (with-racket-repl-buffer
- (should (racket-tests/see-back (concat "\n[" name ":42]> "))))
;debugger prompt
- (should (racket-tests/see-char-property (point) 'face
- racket-debug-break-face))
-
- (racket-debug-step)
- (with-racket-repl-buffer
- (should (racket-tests/see-back (concat "\n[" name ":33]> "))))
- (should (racket-tests/see-char-property (point) 'face
- racket-debug-break-face))
- (should (racket-tests/see-char-property (- (point) 3) 'after-string
- (propertize "41" 'face
racket-debug-locals-face)))
-
- (racket-debug-step)
- (with-racket-repl-buffer
- (should (racket-tests/see-back (concat "\n[" name ":47]> "))))
- (should (racket-tests/see-char-property (point) 'after-string
- (propertize "⇒ (values 42)"
'face racket-debug-result-face)))
-
- (racket-debug-step) ;no more debug breaks left
- (with-racket-repl-buffer
- (should (racket-tests/see-back (concat "\n" name "> "))))
- (should (racket-tests/see-char-property (point) 'after-string
- nil))
- (should-not racket-debug-mode)
- (with-racket-repl-buffer
- (racket-repl-exit)
- (should (racket-tests/see-back
- "Process *Racket REPL </>* connection broken by remote
peer\n"))
- (kill-buffer))
-
- (kill-buffer)
- (delete-file path))))
+ (dolist (edit-mode (list #'racket-mode #'racket-hash-lang-mode))
+ (racket-tests/with-back-end-settings
+ (let* ((path (make-temp-file "test" nil ".rkt"))
+ (name (file-name-nondirectory path))
+ (code "#lang racket/base\n(define (f x) (+ 1 x))\n(f 41)\n"))
+ (write-region code nil path nil 'no-wrote-file-message)
+ (find-file path)
+ (funcall edit-mode)
+ ;; On older Rackets racket-hash-lang-mode may fail gracefully
+ ;; down to prog-mode, but only eventually, after back end
+ ;; responds.
+ (racket-tests/should-eventually
+ (cl-case major-mode
+ ((racket-hash-lang-mode) (not buffer-read-only)) ;keep waiting
+ ((racket-mode prog-mode) t)))
+ (unless (eq major-mode 'prog-mode)
+ (racket-run `(16))
+ (racket-tests/should-eventually (get-buffer racket-repl-buffer-name))
+ (racket-tests/should-eventually (racket--repl-session-id))
+ (racket-tests/should-eventually racket-debug-mode)
+
+ (with-racket-repl-buffer
+ (should (racket-tests/see-back (concat "\n[" name ":42]> "))))
;debugger prompt
+ (should (racket-tests/see-char-property (point) 'face
+ racket-debug-break-face))
+
+ (racket-debug-step)
+ (with-racket-repl-buffer
+ (should (racket-tests/see-back (concat "\n[" name ":33]> "))))
+ (should (racket-tests/see-char-property (point) 'face
+ racket-debug-break-face))
+ (should (racket-tests/see-char-property (- (point) 3) 'after-string
+ (propertize "41" 'face
racket-debug-locals-face)))
+
+ (racket-debug-step)
+ (with-racket-repl-buffer
+ (should (racket-tests/see-back (concat "\n[" name ":47]> "))))
+ (should (racket-tests/see-char-property (point) 'after-string
+ (propertize "⇒ (values 42)"
'face racket-debug-result-face)))
+
+ (racket-debug-step) ;no more debug breaks left
+ (with-racket-repl-buffer
+ (should (racket-tests/see-back (concat "\n" name "> "))))
+ (should (racket-tests/see-char-property (point) 'after-string
+ nil))
+ (should-not racket-debug-mode)
+ (with-racket-repl-buffer
+ (racket-repl-exit)
+ (should (racket-tests/see-back
+ "REPL session ended\n"))
+ (kill-buffer)))
+ (kill-buffer)
+ (delete-file path)))))
;;; For both "shallow" and "deep" macro stepper tests
@@ -605,7 +625,7 @@ want to use the value of `racket-program' at run time."
(racket-run)
(racket-tests/should-eventually (get-buffer racket-repl-buffer-name))
- (racket-tests/should-eventually (racket--repl-live-p))
+ (racket-tests/should-eventually (racket--repl-session-id))
(with-racket-repl-buffer
(should (racket-tests/see-back (concat "\n" name "> "))))
@@ -634,7 +654,7 @@ want to use the value of `racket-program' at run time."
(with-racket-repl-buffer
(racket-repl-exit)
(should (racket-tests/see-back
- "Process *Racket REPL </>* connection broken by remote
peer\n"))
+ "REPL session ended\n"))
(kill-buffer))
(kill-buffer)
@@ -722,46 +742,6 @@ FILE is interpreted as relative to this source directory."
";; blah blah blah blah blah blah\n"))
(kill-buffer (current-buffer))))
-(ert-deftest racket-tests/compilation-mode ()
- (racket-tests/with-back-end-settings
- (with-current-buffer (find-file (expand-file-name
"example/compilation-mode.rkt"
- racket-tests/here-dir))
- (racket-mode)
- (racket-run)
- (racket-tests/should-eventually (get-buffer racket-repl-buffer-name))
- (racket-tests/should-eventually (racket--repl-live-p))
- (with-racket-repl-buffer
- (should (racket-tests/see-back "'done\ncompilation-mode.rkt> "))
- (compilation--ensure-parse (point-max))
- (should (equal (racket-tests/compilation-message 176)
- nil)) ;not the printed JSON on prev line
- (should (equal (racket-tests/compilation-message 286)
- (list "/path/to/file.rkt" 2 10)))
- (should (equal (racket-tests/compilation-message 310)
- (list "/path/to/file.rkt" 2 10)))
- (should (equal (racket-tests/compilation-message 333)
- (list "/path/to/file.rkt" 2 10)))
- (should (equal (racket-tests/compilation-message 367)
- (list "/path/to/file.rkt" 2 10)))
- (should (equal (racket-tests/compilation-message 400)
- (list "*unknown*" 2 1)))
- (should (equal (racket-tests/compilation-message 418)
- (list "*unknown*" 2 1)))
- (should (equal (racket-tests/compilation-message 435)
- (list "*unknown*" 2 1)))
- (racket-repl-exit)
- (should (racket-tests/see-back
- "Process *Racket REPL </>* connection broken by remote
peer\n"))
- (kill-buffer))
- (kill-buffer))))
-
-(defun racket-tests/compilation-message (pos)
- (when-let (cm (get-text-property pos 'compilation-message))
- (save-match-data
- (pcase (compilation--message->loc cm)
- (`(,col ,line ((,file . ,_) . ,_) . ,_)
- (list (substring-no-properties file) line col))))))
-
(ert-deftest racket-tests/cmd-read ()
"Exercise `racket--cmd-read' with randomly generated and chunked sexprs."
(dotimes (_ 10)
diff --git a/test/racket/hash-lang-test.rkt b/test/racket/hash-lang-test.rkt
new file mode 100644
index 0000000000..7f1a68d4d1
--- /dev/null
+++ b/test/racket/hash-lang-test.rkt
@@ -0,0 +1,769 @@
+#lang racket/base
+
+(require rackunit
+ framework
+ racket/class
+ racket/dict
+ racket/async-channel
+ racket/match
+ racket/port
+ net/url
+ "../../racket/lang-info.rkt")
+
+(define hash-lang%
+ (with-handlers ([exn:fail:filesystem:missing-module?
+ (λ _
+ (displayln "hash-lang% NOT available: SKIPPING hash-lang
tests")
+ (exit 0))])
+ (dynamic-require "../../racket/hash-lang.rkt" 'hash-lang%)))
+
+(displayln "hash-lang% IS available: running hash-lang tests")
+
+(define racket-lexer (dynamic-require 'syntax-color/racket-lexer
'racket-lexer))
+(define racket-lexer* (dynamic-require 'syntax-color/racket-lexer
'racket-lexer*))
+(define module-lexer* (dynamic-require 'syntax-color/module-lexer
'module-lexer*))
+
+;; To test async updates from the updater thread, we supply an
+;; on-changed-tokens override method that puts some of them to a
+;; "results" channel.
+(define result-channel (make-async-channel))
+(define (test-create str #:other-lang-source [other-lang-source #f])
+ (define our-hash-lang%
+ (class hash-lang%
+ (super-new [other-lang-source other-lang-source])
+ (define/override (on-changed-tokens gen beg end)
+ (async-channel-put result-channel (list gen beg end)))))
+ (define o (new our-hash-lang%))
+ (test-update! o 1 0 0 str)
+ o)
+(define (test-update! o gen pos old-len str)
+ (send o update! gen pos old-len str)
+ (match (async-channel-get result-channel)
+ [(list gen beg end)
+ (send o get-tokens gen beg end)]))
+
+;;; Various tests of tokenizing and updating
+
+(let* ([str "#lang racket\n42 (print \"hello\") @print{Hello} 'foo #:bar"]
+ ;; 0123456789012 345678901234 567890 12345678901234567890123456
+ ;; 1 2 3 4 5
+ [o (test-create str)])
+ (check-equal? (send o get-tokens 1)
+ (list
+ (list 0 12 'other)
+ (list 12 13 'white-space)
+ (list 13 15 'constant)
+ (list 15 16 'white-space)
+ (list 16 17 'parenthesis)
+ (list 17 22 'symbol)
+ (list 22 23 'white-space)
+ (list 23 30 'string)
+ (list 30 31 'parenthesis)
+ (list 31 32 'white-space)
+ (list 32 38 'symbol)
+ (list 38 39 'parenthesis)
+ (list 39 44 'symbol)
+ (list 44 45 'parenthesis)
+ (list 45 46 'white-space)
+ (list 46 47 'constant)
+ (list 47 50 'symbol)
+ (list 50 51 'white-space)
+ (list 51 56 'hash-colon-keyword)))
+ (check-equal? (send o -get-content) str)
+ (check-equal? (send o -get-modes)
+ `((0 12 (,racket-lexer* . #f))
+ (12 1 (,racket-lexer* . ,(void)))
+ (13 2 (,racket-lexer* . ,(void)))
+ (15 1 (,racket-lexer* . ,(void)))
+ (16 1 (,racket-lexer* . ,(void)))
+ (17 5 (,racket-lexer* . ,(void)))
+ (22 1 (,racket-lexer* . ,(void)))
+ (23 7 (,racket-lexer* . ,(void)))
+ (30 1 (,racket-lexer* . ,(void)))
+ (31 1 (,racket-lexer* . ,(void)))
+ (32 6 (,racket-lexer* . ,(void)))
+ (38 1 (,racket-lexer* . ,(void)))
+ (39 5 (,racket-lexer* . ,(void)))
+ (44 1 (,racket-lexer* . ,(void)))
+ (45 1 (,racket-lexer* . ,(void)))
+ (46 1 (,racket-lexer* . ,(void)))
+ (47 3 (,racket-lexer* . ,(void)))
+ (50 1 (,racket-lexer* . ,(void)))
+ (51 5 (,racket-lexer* . ,(void))))
+ "racket-lexer* used for #lang racket")
+ (check-equal? (test-update! o 2 51 5 "'bar")
+ '((50 51 white-space)
+ (51 52 constant)
+ (52 55 symbol)))
+ (check-equal? (test-update! o 3 46 4 "'bar")
+ '()
+ "Although lexeme changed from 'foo' to 'bar', the token bounds
did not change nor did the type 'symbol nor the backup")
+
+ (check-equal? (test-update! o 4 23 7 "'hell")
+ '((22 23 white-space)
+ (23 24 constant)
+ (24 28 symbol)))
+ (check-equal? (test-update! o 5 13 2 "99999")
+ '((13 18 constant)))
+ ;; Double check final result of the edits
+ (check-equal? (send o -get-content)
+ "#lang racket\n99999 (print 'hell) @print{Hello} 'bar 'bar")
+ ;; 0123456789012 34567890123456789012345678901234567890123456
+ ;; 1 2 3 4 5
+ (check-equal? (send o get-tokens 1)
+ (list
+ (list 0 12 'other)
+ (list 12 13 'white-space)
+ (list 13 18 'constant)
+ (list 18 19 'white-space)
+ (list 19 20 'parenthesis)
+ (list 20 25 'symbol)
+ (list 25 26 'white-space)
+ (list 26 27 'constant)
+ (list 27 31 'symbol)
+ (list 31 32 'parenthesis)
+ (list 32 33 'white-space)
+ (list 33 39 'symbol)
+ (list 39 40 'parenthesis)
+ (list 40 45 'symbol)
+ (list 45 46 'parenthesis)
+ (list 46 47 'white-space)
+ (list 47 48 'constant)
+ (list 48 51 'symbol)
+ (list 51 52 'white-space)
+ (list 52 53 'constant)
+ (list 53 56 'symbol))))
+
+(let* ([str "#lang at-exp racket\n42 (print \"hello\") @print{Hello (there)}
'foo #:bar"]
+ [o (test-create str)])
+ (check-equal? (send o get-tokens 1)
+ (list
+ (list 0 19 'other)
+ (list 19 20 'white-space)
+ (list 20 22 'constant)
+ (list 22 23 'white-space)
+ (list 23 24 'parenthesis)
+ (list 24 29 'symbol)
+ (list 29 30 'white-space)
+ (list 30 37 'string)
+ (list 37 38 'parenthesis)
+ (list 38 39 'white-space)
+ (list 39 40 'parenthesis) ;;??
+ (list 40 45 'symbol)
+ (list 45 46 'parenthesis)
+ (list 46 59 'text)
+ (list 59 60 'parenthesis)
+ (list 60 61 'white-space)
+ (list 61 62 'constant)
+ (list 62 65 'symbol)
+ (list 65 66 'white-space)
+ (list 66 71 'hash-colon-keyword)))
+ (for ([(_ mode) (in-dict (send o -get-modes))])
+ (check-false (equal? mode racket-lexer)
+ "racket-lexer NOT used for #lang at-exp")
+ (check-false (equal? mode racket-lexer*)
+ "racket-lexer* NOT used for #lang at-exp"))
+ (check-equal? (send o -get-content) str)
+ (check-equal? (send o classify 1 (sub1 (string-length str)))
+ (list 66 71 'hash-colon-keyword)))
+
+(let* ([str "#lang scribble/text\nHello @(print \"hello\") @print{Hello
(there)} #:not-a-keyword"]
+ [o (test-create str)])
+ (check-equal? (send o get-tokens 1)
+ (list
+ (list 0 19 'other)
+ (list 19 20 'white-space)
+ (list 20 26 'text)
+ (list 26 27 'parenthesis) ;;??
+ (list 27 28 'parenthesis)
+ (list 28 33 'symbol)
+ (list 33 34 'white-space)
+ (list 34 41 'string)
+ (list 41 42 'parenthesis)
+ (list 42 43 'text)
+ (list 43 44 'parenthesis)
+ (list 44 49 'symbol)
+ (list 49 50 'parenthesis)
+ (list 50 63 'text)
+ (list 63 64 'parenthesis)
+ (list 64 80 'text)))
+ (for ([(_ mode) (in-dict (send o -get-modes))])
+ (check-false (equal? mode racket-lexer)
+ "racket-lexer NOT used for #lang at-exp")
+ (check-false (equal? mode racket-lexer*)
+ "racket-lexer* NOT used for #lang at-exp"))
+ (check-equal? (send o -get-content) str))
+
+(let* ([str "#lang racket\n(λ () #t)"]
+ ;; 0123456789012 34567890
+ ;; 1 2
+ [o (test-create str)])
+ (check-equal? (send o classify 1 14)
+ (list 14 15 'symbol))
+ (check-equal? (test-update! o 2 17 0 "a")
+ '((17 18 symbol)))
+ (check-equal? (send o classify 2 17)
+ (list 17 18 'symbol)))
+
+(let ([o (test-create "#lang racket\n#rx\"1234\"\n#(1 2 3)\n#'(1 2 3)")])
+ (check-equal? (send o get-tokens 1)
+ (list
+ (list 0 12 'other)
+ (list 12 13 'white-space)
+ (list 13 22 'string)
+ (list 22 23 'white-space)
+ (list 23 25 'parenthesis)
+ (list 25 26 'constant)
+ (list 26 27 'white-space)
+ (list 27 28 'constant)
+ (list 28 29 'white-space)
+ (list 29 30 'constant)
+ (list 30 31 'parenthesis)
+ (list 31 32 'white-space)
+ (list 32 34 'constant)
+ (list 34 35 'parenthesis)
+ (list 35 36 'constant)
+ (list 36 37 'white-space)
+ (list 37 38 'constant)
+ (list 38 39 'white-space)
+ (list 39 40 'constant)
+ (list 40 41 'parenthesis))))
+
+(let ([o (test-create "#lang racket\n#<<HERE\nblah blah\nblah blah\nHERE\n")])
+ (check-equal? (send o get-tokens 1)
+ (list
+ (list 0 12 'other)
+ (list 12 13 'white-space)
+ (list 13 45 'string)
+ (list 45 46 'white-space))))
+
+
+(let ()
+ (define str "#lang racket\n")
+ ;; 1234567890123 45678901234 567890 12345678901234567890123456
+ ;; 1 2 3 4 5
+ (define o (test-create str))
+ (test-update! o 2 13 0 "()")
+ (test-update! o 3 14 0 "d")
+ (test-update! o 4 15 0 "o")
+ (test-update! o 5 14 0 "1")
+ (test-update! o 6 15 0 "2")
+ (test-update! o 7 16 0 " ")
+ (void))
+
+(let* ([str "#lang racket\n"]
+ ;; 1234567890123 4
+ ;; 1
+ [o (test-create str)])
+ (test-update! o 2 13 0 "d")
+ (test-update! o 3 14 0 "o")
+ (check-equal? (send o -get-content) "#lang racket\ndo")
+ (check-equal? (send o get-tokens 3)
+ (list
+ (list 0 12 'other)
+ (list 12 13 'white-space)
+ (list 13 15 'symbol))))
+
+(let* ([str "#lang racket\n"]
+ ;; 0123456789012 3
+ ;; 1
+ [o (test-create str)])
+ (test-update! o 2 13 0 "1") ;initially lexed as 'constant
+ (test-update! o 3 14 0 "x") ;should re-lex "1x" as 'symbol
+ (check-equal? (send o -get-content) "#lang racket\n1x")
+ (check-equal? (send o get-tokens 3)
+ (list
+ (list 0 12 'other)
+ (list 12 13 'white-space)
+ (list 13 15 'symbol))))
+(let* ([str "#lang racket\n"]
+ ;; 0123456789012 34
+ ;; 1
+ [o (test-create str)])
+ (test-update! o 2 13 0 "1") ;initially lexed as 'constant
+ (test-update! o 3 14 0 "x") ;should re-lex "1x" as 'symbol
+ (test-update! o 4 15 0 "1") ;still symbol
+ (test-update! o 5 14 1 "") ;deleting the "x" should re-lex the "11" as
constant
+ (check-equal? (send o -get-content) "#lang racket\n11")
+ (check-equal? (send o get-tokens 5)
+ (list
+ (list 0 12 'other)
+ (list 12 13 'white-space)
+ (list 13 15 'constant))))
+
+(let* ([str "#lang racket\n"]
+ ;; 1234567890123 4
+ ;; 1
+ [o (test-create str)])
+ ;; as if paredit etc. were enabled
+ (test-update! o 2 13 0 "(")
+ (test-update! o 3 14 0 ")")
+ (test-update! o 4 14 0 "h")
+ (test-update! o 5 15 0 "i")
+ (check-equal? (send o -get-content) "#lang racket\n(hi)")
+ (check-equal? (send o get-tokens 5)
+ (list
+ (list 0 12 'other)
+ (list 12 13 'white-space)
+ (list 13 14 'parenthesis)
+ (list 14 16 'symbol)
+ (list 16 17 'parenthesis))))
+
+;; Exercise calling update! from various threads and out-of-order
+;; wrt the generation number.
+(let* ([str "#lang racket\n"]
+ ;; 0123456789012 3
+ ;; 1
+ [o (new hash-lang%)])
+ (send o update! 1 0 0 str)
+ (thread (λ () (send o update! 2 13 0 "(")))
+ (thread (λ () (send o update! 4 14 0 "h")))
+ (thread (λ () (send o update! 5 15 0 "i")))
+ (thread (λ () (send o update! 3 14 0 ")")))
+ (check-equal? (send o get-tokens 5)
+ (list
+ (list 0 12 'other)
+ (list 12 13 'white-space)
+ (list 13 14 'parenthesis)
+ (list 14 16 'symbol)
+ (list 16 17 'parenthesis))))
+
+(let* ([str "#lang racket\n#hash\n"]
+ ;; 0123456789012 3456789
+ ;; 1
+ [o (test-create str)])
+ (check-equal? (send o classify 1 13)
+ (list 13 18 'error))
+ (check-equal? (test-update! o 2 18 0 "(")
+ '((13 19 parenthesis))
+ "Adding parens after #hash re-lexes from an error to an open")
+ (check-equal? (send o classify 2 13)
+ (list 13 19 'parenthesis)))
+
+(let* ([str "#lang racket\n\n(1 2)"]
+ ;; 0123456789012 3 456789
+ ;; 1
+ [o (test-create str)])
+ (check-equal? (test-update! o 2 13 0 "(")
+ '((12 13 white-space)
+ (13 14 parenthesis)
+ (14 15 white-space))
+ "Update that splits an existing token does not produce
execessive notifications.")
+ (check-equal? (test-update! o 3 13 0 ")")
+ '((13 14 parenthesis))))
+
+(let* ([str "#lang racket\n\n#;(1 2)"]
+ ;; 0123456789012 3 4567890
+ ;; 1 2
+ [o (test-create str)])
+ (check-equal? (send o get-tokens 1)
+ (list
+ (list 0 12 'other)
+ (list 12 14 'white-space)
+ (list 14 16 'sexp-comment)
+ (list 16 17 '#hash((comment? . #t) (type . parenthesis)))
+ (list 17 18 '#hash((comment? . #t) (type . constant)))
+ (list 18 19 '#hash((comment? . #t) (type . white-space)))
+ (list 19 20 '#hash((comment? . #t) (type . constant)))
+ (list 20 21 '#hash((comment? . #t) (type . parenthesis))))))
+
+(let* ([str "#lang scribble/manual\n\ntext text\ntext text\n"]
+ ;; 0123456789012345678901 2 3456789012 3456789012
+ ;; 1 2 3 4
+ [o (test-create str)])
+ (check-equal? (send o get-tokens 1)
+ '((0 21 other)
+ (21 23 white-space)
+ (23 32 text)
+ (32 33 white-space)
+ (33 42 text)
+ (42 43 white-space))
+ "#lang scribble/manual: Initial lex is just lines of text
tokens.")
+ (check-equal? (test-update! o 2 22 0 "@(1 a 3")
+ '((21 22 white-space)
+ (22 23 parenthesis)
+ (23 24 parenthesis)
+ (24 25 constant)
+ (25 26 white-space)
+ (26 27 symbol)
+ (27 28 white-space)
+ (28 29 constant)
+ (29 30 white-space)
+ (30 34 symbol)
+ (34 35 white-space)
+ (35 39 symbol)
+ (39 40 white-space)
+ (40 44 symbol)
+ (44 45 white-space)
+ (45 49 symbol))
+ "#lang scribble/manual: adding \"@(1 a 3\" with no close paren
causes text tokens to become symbol and white-space tokens, i.e. as if part of
the new s-expression.")
+ (check-equal? (send o -get-content)
+ "#lang scribble/manual\n@(1 a 3\ntext text\ntext text\n")
+ ;; 0123456789012345678901 23456789 0123456789 0123456789
+ ;; 1 2 3 4
+ (check-equal? (test-update! o 3 29 0 ")")
+ '((29 30 parenthesis)
+ (30 31 white-space)
+ (31 40 text)
+ (40 41 white-space)
+ (41 50 text))
+ "#lang scribble/manual: adding a ) to close an unmatched @(
causes things after the ) to be tokenzied back to text.")
+ (check-equal? (send o -get-content)
+ "#lang scribble/manual\n@(1 a 3)\ntext text\ntext text\n")
+ ;; 0123456789012345678901 234567890 1234567890 1234567890 1
+ ;; 1 2 3 4 5
+ )
+
+(let* ([o (test-create "" #:other-lang-source "#lang scribble/manual")])
+ (test-update! o 2 0 0 "blah blah blah @racket[x]")
+ (check-equal? (send o get-tokens 1)
+ '((0 15 text) ;; "blah blah blah"
+ (15 16 parenthesis)
+ (16 22 symbol)
+ (22 23 parenthesis)
+ (23 24 symbol)
+ (24 25 parenthesis))
+ "other-lang-source used to tokenize using #lang
scribble/manual instead of default #lang racket"))
+
+(unless (getenv "CI") ;needs github.com:mflatt/shrubbery-rhombus-0.git
+ (let* ([o (test-create "#lang rhombus\n@//{block comment}")]
+ ;; 01234567890123 4567890123456789012
+ ;; 1 2 3
+ [gen-1-tokens (send o get-tokens 1)])
+ (check-equal? (test-update! o 2 16 0 " ")
+ '((14 15 #hasheq((rhombus-type . at) (type . at)))
+ (15 16 #hasheq((rhombus-type . operator) (type .
operator)))
+ (16 17 #hasheq((rhombus-type . whitespace) (type .
white-space)))
+ (17 18 #hasheq((rhombus-type . operator) (type .
operator)))
+ (18 19 #hasheq((rhombus-type . opener) (type .
parenthesis)))
+ (19 24 #hasheq((rhombus-type . identifier) (type .
symbol)))
+ (24 25 #hasheq((rhombus-type . whitespace) (type .
white-space)))
+ (25 32 #hasheq((rhombus-type . identifier) (type .
symbol)))
+ (32 33 #hasheq((rhombus-type . closer) (type .
parenthesis))))
+ "non-zero backup amounts are used: edit removes block
comment")
+ (check-equal? (test-update! o 3 16 1 "")
+ '((14 17 #hasheq((rhombus-type . at-comment) (type .
comment)))
+ (17 18 #hasheq((comment? . #t) (rhombus-type . at-opener)
(type . parenthesis)))
+ (18 31 #hasheq((comment? . #t) (rhombus-type . at-content)
(type . text)))
+ (31 32 #hasheq((comment? . #t) (rhombus-type . at-closer)
(type . parenthesis))))
+ "non-zero backup amounts are used: edit restores block
comment")
+ (check-equal? gen-1-tokens
+ (send o get-tokens 3)
+ "non-zero backup amounts are used: edits remove and restore
block comment")))
+
+(let ([o (test-create "#lang scribble/manual\ntext @|foo| @foo|{text}|
@;{comment} @;comment")]
+ ;; 0123456789012345678901
23456789012345678901234567890123456789012345678
+ ;; 1 2 3 4 5
6
+ )
+ (check-equal? (test-update! o 2 38 0 " ")
+ '((38 48 text))
+ "non-zero backup amounts are used"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Test equivalance of our text%-like methods to those of racket:text%
+;;;
+
+(define (create-objects str)
+ ;; Create an object of our class.
+ (define o (test-create str))
+
+ ;; Create an object of racket:text%, which also implements the
+ ;; color:text<%> interface. Since our class uses module-lexer*, and
+ ;; reads lang info to get paren-matches, give those same values to
+ ;; the racket:text% object's `start-colorer` method.
+ (define t (new racket:text%))
+ (send t start-colorer symbol->string
+ module-lexer*
+ (lang-info-paren-matches (send o get-lang-info)))
+ (send t insert str)
+ (send t freeze-colorer)
+ (send t thaw-colorer)
+
+ (values o t))
+
+(define (compare-objects str
+ o
+ t
+ #:what [what (string-append (substring str 0 20)
"...")]
+ #:check-motion? check-motion?
+ #:check-indent? check-indent?)
+ (define lp (string-length str))
+ (check-equal? (send o last-position)
+ (send t last-position)
+ (format "equal last-position in ~a" what))
+
+ ;; Test that our implementation of skip-whitespace is equivalent
+ ;; to racket:text%.
+ (for ([pos (in-range 0 (string-length str))])
+ (for* ([dir (in-list '(forward backward))]
+ [comments? (in-list '(#f #t))])
+ (check-equal? (send o skip-whitespace pos dir comments?)
+ (send t skip-whitespace pos dir comments?)
+ (format "skip-whitespace ~v ~v ~v in ~a" pos dir comments?
what))))
+
+ ;; Test that our implementation of position-paragraph is
+ ;; equivalent to racket:text%.
+ (for ([pos (in-range 0 (string-length str))])
+ (check-equal? (send o position-paragraph pos)
+ (send t position-paragraph pos)
+ (format "position-paragraph ~v in ~a" pos what)))
+
+ ;; Test that our implementation of paragraph-start-position and
+ ;; paragraph-end-position are equivalent to racket:text%.
+ (define num-paras (add1 (for/sum ([c (in-string str)])
+ (if (char=? c #\newline) 1 0))))
+ (for ([para (in-range 0 num-paras)])
+ (check-equal? (send o paragraph-start-position para)
+ (send t paragraph-start-position para)
+ (format "paragraph-start-position ~v in ~a" para what)))
+ (check-exn exn:fail?
+ (λ () (send o paragraph-start-position (add1 num-paras))))
+ (for ([para (in-range 0 (+ num-paras 2))]) ;should work for excess para #s
+ (check-equal? (send o paragraph-end-position para)
+ (send t paragraph-end-position para)
+ (format "paragraph-end-position ~v in ~a" para what)))
+
+ ;; Test that the classifications -- token spans and contents -- are
+ ;; identical.
+ (let loop ([pos 0])
+ (define-values (o-beg o-end) (send o get-token-range pos))
+ (define-values (t-beg t-end) (send t get-token-range pos))
+ (check-equal? o-beg t-beg)
+ (check-equal? o-end t-end)
+ (unless (zero? o-beg) ;Ignore possible 'other vs. 'text
+ ;discrepancy with lang scribble for the lang
+ ;line itself. FIXME: Figure out why.
+ (check-equal? (send o classify-position* o-beg)
+ (send t classify-position* t-beg)
+ (format "classify-position* ~v in ~a" o-beg what)))
+ (when (< o-end (send o last-position))
+ (loop o-end)))
+
+ (when check-motion?
+ ;; Test that our implementations of {forward backward}-match and
+ ;; backward-containing-sexp are equivalent to those of
+ ;; racket:text%.
+ (for ([pos (in-range 0 (string-length str))])
+ (send t set-position pos pos)
+ (check-equal? (send o forward-match pos lp)
+ (send t forward-match pos lp)
+ (format "forward-match ~v ~v in ~a" pos lp what))
+ (check-equal? (send o backward-match pos 0)
+ (send t backward-match pos 0)
+ (format "backward-match ~v ~v in ~a" pos 0 what))
+ (check-equal? (send o backward-containing-sexp pos 0)
+ (send t backward-containing-sexp pos 0)
+ (format "backward-containing-sexp ~v ~v in ~a" pos 0
what))))
+
+ (when check-indent?
+ ;; Test that we supply enough color-text% methods, and that they
+ ;; behave equivalently to those from racket-text%, as needed by a
+ ;; lang-supplied drracket:indentation a.k.a. determine-spaces
+ ;; function. (After all, this is our motivation to provide
+ ;; text%-like methods; otherwise we wouldn't bother.)
+ (define line-indent (lang-info-line-indenter (send o get-lang-info)))
+ (when line-indent
+ (for ([pos (in-range 0 (string-length str))])
+ (when (or (= pos 0)
+ (char=? (string-ref str (sub1 pos)) #\newline))
+ (check-equal? (line-indent o pos)
+ (line-indent t pos)
+ (format "~v ~v in ~a" line-indent pos what)))))
+
+ ;; Test range-indent.
+ (define range-indent (lang-info-range-indenter (send o get-lang-info)))
+ (when range-indent
+ (define len (string-length str))
+ (check-equal? (range-indent o 0 len)
+ (range-indent t 0 len)))))
+
+(define (check-string str
+ #:check-motion? check-motion?
+ #:check-indent? check-indent?)
+ (define-values (o t) (create-objects str))
+ (compare-objects str o t #:check-motion? check-motion? #:check-indent?
check-indent?))
+
+(let ([str "#lang racket\n(1) #(2) #hash((1 . 2))\n@racket[]{\n#(2)\n}\n"]
+ ;; 0123456789012 345678901234567890123456 78901234567 89012 34
+ ;; 1 2 3 4 5
+ )
+ (check-string str
+ #:check-motion? #t
+ #:check-indent? #t))
+
+(let ([str "#lang at-exp racket\n(1) #(2) #hash((1 .
2))\n@racket[]{\n#(2)\n}\n"]
+ ;; 01234567890123456789 012345678901234567890123 45678901234 56789 01
+ ;; 1 2 3 4 5 6
+ )
+ (check-string str
+ #:check-motion? #t
+ ;; This needs a newer at-exp from Racket 8.3.0.8+,
+ ;; which avoids using the `find-up-sexp` method.
+ #:check-indent? #t))
+
+(check-string (call/input-url (string->url
"https://raw.githubusercontent.com/mflatt/shrubbery-rhombus-0/master/demo.rkt";)
get-pure-port port->string)
+ #:check-motion? #f ;large file & we already test motion above
+ #:check-indent? #t)
+
+;; Compare the result of making edits using both implementations.
+(define (check-edits str)
+ (define-values (o t) (create-objects str))
+ (define (compare what)
+ (compare-objects str o t
+ #:what what
+ #:check-motion? #f
+ #:check-indent? #f)
+ (let loop ([pos 0])
+ (define next-o (send o forward-match pos (send o last-position)))
+ (define next-t (send t forward-match pos (send t last-position)))
+ (check-equal? next-o next-t
+ (format "forward-match ~v => ~v ~v after ~a"
+ pos next-o next-t what))
+ (when next-o
+ (loop next-o))))
+ (define gen 1)
+ (define (insert pos str #:check? [check? #t])
+ (set! gen (add1 gen))
+ (test-update! o gen pos 0 str)
+ (send t insert str pos)
+ (when check?
+ (compare (format "~v" `(insert ,str ,pos)))))
+ (define (delete pos len #:check? [check? #t])
+ (set! gen (add1 gen))
+ (test-update! o gen pos len "")
+ (send t kill (current-milliseconds) pos (+ pos len))
+ (when check?
+ (compare (format "~v" `(delete ,pos ,len)))))
+ (compare "start")
+ (insert (send o last-position) "(")
+ (insert (send o last-position) ")")
+ (delete (- (send o last-position) 2) 2)
+ (delete 0 (string-length "#lang racket/base") #:check? #f)
+ (insert 0 "#lang scribble/manual"))
+
+(require racket/runtime-path
+ racket/file)
+(define-runtime-path class-internal.rkt "../example/class-internal.rkt")
+(check-edits (file->string class-internal.rkt #:mode 'text))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Benchmarks
+;;;
+
+(when #f
+
+ (define (cpu-time proc)
+ (define-values (_results cpu _real _gc) (time-apply proc null))
+ cpu)
+
+ (define (bench what str)
+ (newline)
+ (displayln (make-string 76 #\-))
+ (printf "BENCHMARK: ~v\n" what)
+ (println (string-append (substring str 0 20) "..."))
+
+ ;; Create an object of our class.
+ (define o (new hash-lang%))
+ (send o update! 1 0 0 str)
+
+ ;; Create an object of racket:text%, which also implements the
+ ;; color:text<%> interface. Since our class reads lang info to get
+ ;; things like the initial lexer and paren-matches, give those
+ ;; values from our object to color:text<%> `start-colorer`.
+ (define t (new racket:text%))
+ (send t start-colorer symbol->string
+ (lang-info-lexer (send o get-lang-info))
+ (lang-info-paren-matches (send o get-lang-info)))
+ (send t insert str)
+ (send t freeze-colorer)
+ (send t thaw-colorer)
+
+ (define (compare what reps proc)
+ (newline)
+ (displayln what)
+ (define o-time (cpu-time (λ () (for ([_ reps]) (proc o)))))
+ (define t-time (cpu-time (λ () (for ([_ reps]) (proc t)))))
+ (define factor (/ (* 1.0 o-time) t-time))
+ (printf "~v ~v\n~v ~v\n~v\n"
+ o-time o
+ t-time t
+ factor))
+
+ (compare "paragraph methods"
+ 10
+ (λ (t)
+ (for ([pos (in-range 0 (string-length str))])
+ (define para (send t position-paragraph pos))
+ (send t paragraph-start-position para)
+ (send t paragraph-end-position para))))
+
+ (compare "classify-position*"
+ 10
+ (λ (t)
+ (for ([pos (in-range 0 (string-length str))])
+ (send t classify-position* pos))))
+
+ (compare "get-token-range"
+ 10
+ (λ (t)
+ (for ([pos (in-range 0 (string-length str))])
+ (send t get-token-range pos))))
+
+ (compare "skip-whitespace 'forward"
+ 10
+ (λ (t)
+ (for ([pos (in-range 0 (string-length str))])
+ (send t skip-whitespace pos 'forward #t))))
+ (compare "skip-whitespace 'backward"
+ 10
+ (λ (t)
+ (for ([pos (in-range 0 (string-length str))])
+ (send t skip-whitespace pos 'backward #t))))
+
+ (compare "backward-match"
+ 1
+ (λ (t)
+ (for ([pos (in-range 0 (string-length str))])
+ (send t backward-match pos 0))))
+ (compare "forward-match"
+ 1
+ (λ (t)
+ (define lp (send t last-position))
+ (for ([pos (in-range 0 (string-length str))])
+ (send t forward-match pos lp))))
+
+ (compare "backward-containing-sexp"
+ 1
+ (λ (t)
+ (for ([pos (in-range 0 (string-length str) 1000)])
+ (send t backward-containing-sexp pos 0))))
+
+ (define line-indent (lang-info-line-indenter (send o get-lang-info)))
+ (when line-indent
+ (compare line-indent
+ 1
+ (λ (t)
+ (for ([pos (in-range 0 (string-length str))])
+ (when (or (= pos 0)
+ (char=? (string-ref str (sub1 pos)) #\newline))
+ (line-indent t pos))))))
+
+ (define range-indent (lang-info-range-indenter (send o get-lang-info)))
+ (when range-indent
+ (compare range-indent
+ 10
+ (λ (t) (range-indent t 0 (string-length str))))))
+
+ (displayln (make-string 76 #\=))
+
+ (let* ([uri
"https://raw.githubusercontent.com/racket/racket/448b77a6629c68659e1360fbe9f9e1ecea078f9c/pkgs/racket-doc/scribblings/reference/class.scrbl";]
+ [str (call/input-url (string->url uri) get-pure-port port->string)])
+ (bench uri str))
+
+ (let* ([uri
"https://raw.githubusercontent.com/mflatt/shrubbery-rhombus-0/master/demo.rkt";]
+ [str (call/input-url (string->url uri) get-pure-port port->string)])
+ (bench uri str))
+
+ (newline))
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [nongnu] elpa/racket-mode 25224889d2: Redesign REPL I/O and add racket-hash-lang-mode,
ELPA Syncer <=